unikernel/duniverse/ocaml-h2/examples/alpn/unix/alpn_server_ssl.ml

@@ -0,0 +1,77 @@
+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 () ])

unikernel/duniverse/ocaml-h2/examples/alpn/unix/alpn_server_tls.ml

@@ -0,0 +1,72 @@
+open Alpn_lib
+
+let http1_handler =
+  Httpun_lwt_unix.Server.TLS.create_connection_handler
+    ?config:None
+    ~request_handler:Http1_handler.request_handler
+    ~error_handler:Http1_handler.error_handler
+
+let h2_handler =
+  H2_lwt_unix.Server.TLS.create_connection_handler
+    ?config:None
+    ~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 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 () ->
+              X509_lwt.private_of_pems ~cert ~priv_key >>= fun certificate ->
+              let config =
+                Tls.Config.server
+                  ~alpn_protocols:[ "h2"; "http/1.1" ]
+                    (* accept h2 before http/1.1 *)
+                  ~certificates:(`Single certificate)
+                  ()
+                |> Result.get_ok
+              in
+              Tls_lwt.Unix.server_of_fd config fd >>= fun tls_server ->
+              match Tls_lwt.Unix.epoch tls_server with
+              | Error () ->
+                Lwt_io.eprintlf
+                  "Unable to fetch session data. Did the handshake fail?"
+              | Ok { alpn_protocol; _ } ->
+                (match alpn_protocol with
+                | None ->
+                  (* Unable to negotiate a protocol *)
+                  Lwt.return_unit
+                | Some "http/1.1" -> http1_handler client_addr tls_server
+                | Some "h2" -> h2_handler client_addr tls_server
+                | _ ->
+                  (* 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 () ])

unikernel/duniverse/ocaml-h2/examples/alpn/unix/dune

@@ -0,0 +1,9 @@
+(executable
+ (name alpn_server_tls)
+ (modules alpn_server_tls)
+ (libraries tls tls-lwt lwt lwt.unix alpn_lib))
+
+(executable
+ (name alpn_server_ssl)
+ (modules alpn_server_ssl)
+ (libraries lwt lwt.unix lwt_ssl alpn_lib))