77 lines
2.9 KiB
OCaml
77 lines
2.9 KiB
OCaml
open Alpn_lib
|
|
|
|
let http1_handler =
|
|
Httpun_lwt_unix.Server.SSL.create_connection_handler
|
|
?config:None
|
|
~request_handler:Http1_handler.request_handler
|
|
~error_handler:Http1_handler.error_handler
|
|
|
|
let h2_handler =
|
|
H2_lwt_unix.Server.SSL.create_connection_handler
|
|
~request_handler:H2_handler.request_handler
|
|
~error_handler:H2_handler.error_handler
|
|
|
|
let start_http_server () =
|
|
let open Lwt.Infix in
|
|
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in
|
|
Lwt.async (fun () ->
|
|
Lwt_io.establish_server_with_client_socket
|
|
listen_address
|
|
(Httpun_lwt_unix.Server.create_connection_handler
|
|
?config:None
|
|
~request_handler:Http1_handler.redirect_handler
|
|
~error_handler:Http1_handler.redirect_error_handler)
|
|
>>= fun _server -> Lwt.return_unit);
|
|
let forever, _ = Lwt.wait () in
|
|
forever
|
|
|
|
let rec first_match l1 = function
|
|
| [] -> None
|
|
| x :: _ when List.mem x l1 -> Some x
|
|
| _ :: xs -> first_match l1 xs
|
|
|
|
let start_https_server () =
|
|
let open Lwt.Infix in
|
|
let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 9443)) in
|
|
let cert = "./certificates/server.pem" in
|
|
let priv_key = "./certificates/server.key" in
|
|
Lwt.async (fun () ->
|
|
Lwt_io.establish_server_with_client_socket
|
|
listen_address
|
|
(fun client_addr fd ->
|
|
Lwt.catch
|
|
(fun () ->
|
|
let server_ctx =
|
|
Ssl.create_context Ssl.TLSv1_3 Ssl.Server_context
|
|
in
|
|
Ssl.disable_protocols
|
|
server_ctx
|
|
([ Ssl.SSLv23; Ssl.TLSv1_1 ] [@ocaml.alert "-deprecated"]);
|
|
Ssl.use_certificate server_ctx cert priv_key;
|
|
let protos = [ "h2"; "http/1.1" ] in
|
|
Ssl.set_context_alpn_protos server_ctx protos;
|
|
Ssl.set_context_alpn_select_callback
|
|
server_ctx
|
|
(fun client_protos -> first_match client_protos protos);
|
|
Lwt_ssl.ssl_accept fd server_ctx >>= fun ssl_server ->
|
|
match Lwt_ssl.ssl_socket ssl_server with
|
|
| None -> assert false
|
|
| Some ssl_socket ->
|
|
(match Ssl.get_negotiated_alpn_protocol ssl_socket with
|
|
| None ->
|
|
(* Unable to negotiate a protocol *)
|
|
Lwt.return_unit
|
|
| Some "http/1.1" -> http1_handler client_addr ssl_server
|
|
| Some "h2" -> h2_handler client_addr ssl_server
|
|
| Some _ ->
|
|
(* Can't really happen - would mean that TLS negotiated a
|
|
* protocol that we didn't specify. *)
|
|
assert false))
|
|
(fun exn -> Lwt_io.eprintlf "EXN: %s" (Printexc.to_string exn)))
|
|
>>= fun _server -> Lwt.return_unit);
|
|
let forever, _ = Lwt.wait () in
|
|
forever
|
|
|
|
let () =
|
|
Sys.(set_signal sigpipe Signal_ignore);
|
|
Lwt_main.run (Lwt.join [ start_http_server (); start_https_server () ])
|