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

@@ -0,0 +1,4 @@
+(library
+ (name alpn_lib)
+ (modules h2_handler http1_handler)
+ (libraries h2 httpun httpun-lwt-unix h2-lwt-unix lwt))

unikernel/duniverse/ocaml-h2/examples/alpn/lib/h2_handler.ml

@@ -0,0 +1,30 @@
+open H2
+
+let request_handler : Unix.sockaddr -> Reqd.t -> unit =
+ fun _client_address request_descriptor ->
+  let request = Reqd.request request_descriptor in
+  let response_content_type =
+    match Headers.get request.headers "Content-Type" with
+    | Some request_content_type -> request_content_type
+    | None -> "text/plain"
+  in
+  let response =
+    Response.create
+      ~headers:(Headers.of_list [ "content-type", response_content_type ])
+      `OK
+  in
+  Reqd.respond_with_string
+    request_descriptor
+    response
+    "Welcome to an ALPN-negotiated HTTP/2 connection"
+
+let error_handler :
+     Unix.sockaddr
+    -> ?request:H2.Request.t
+    -> _
+    -> (Headers.t -> Body.Writer.t)
+    -> unit
+  =
+ fun _client_address ?request:_ _error start_response ->
+  let response_body = start_response Headers.empty in
+  Body.Writer.close response_body

unikernel/duniverse/ocaml-h2/examples/alpn/lib/http1_handler.ml

@@ -0,0 +1,54 @@
+open Httpun
+
+let redirect_handler : Unix.sockaddr -> Reqd.t Gluten.reqd -> unit =
+ fun _client_address { Gluten.reqd; _ } ->
+  let response =
+    Response.create
+      ~headers:
+        (Headers.of_list
+           [ "Location", "https://localhost:9443"; "Connection", "close" ])
+      `Moved_permanently
+  in
+  Reqd.respond_with_string reqd response ""
+
+let redirect_error_handler :
+     Unix.sockaddr
+    -> ?request:Request.t
+    -> _
+    -> (Headers.t -> Body.Writer.t)
+    -> unit
+  =
+ fun _client_address ?request:_ _error start_response ->
+  let response_body = start_response Headers.empty in
+  Body.Writer.close response_body
+
+let request_handler : Unix.sockaddr -> Reqd.t Gluten.reqd -> unit =
+ fun _client_address { Gluten.reqd; _ } ->
+  let request = Reqd.request reqd in
+  let response_content_type =
+    match Headers.get request.headers "Content-Type" with
+    | Some request_content_type -> request_content_type
+    | None -> "text/plain"
+  in
+  let response_body = "Welcome to an ALPN-negotiated HTTP/1.1 connection" in
+  let response =
+    Response.create
+      ~headers:
+        (Headers.of_list
+           [ "content-type", response_content_type
+           ; "Content-Length", String.length response_body |> string_of_int
+           ])
+      `OK
+  in
+  Reqd.respond_with_string reqd response response_body
+
+let error_handler :
+     Unix.sockaddr
+    -> ?request:Request.t
+    -> _
+    -> (Headers.t -> Body.Writer.t)
+    -> unit
+  =
+ fun _client_address ?request:_ _error start_response ->
+  let response_body = start_response Headers.empty in
+  Body.Writer.close response_body

unikernel/duniverse/ocaml-h2/examples/alpn/mirage/config.ml

@@ -0,0 +1,42 @@
+open Mirage
+
+(* Network configuration *)
+
+let stack = generic_stackv4 default_network
+
+(* Certificates *)
+
+let secrets = generic_kv_ro "../../../certificates"
+
+(* Dependencies *)
+
+let server =
+  let packages =
+    [ package "tls-mirage"
+    ; package ~pin:"git+https://github.com/anmonteiro/httpun#master" "httpun"
+    ; package
+        ~pin:"git+https://github.com/anmonteiro/httpun#master"
+        "httpun-lwt"
+    ; package
+        ~pin:"git+https://github.com/anmonteiro/httpun#master"
+        "httpun-mirage"
+    ; package ~pin:"file://../../.." "h2"
+    ; package ~pin:"file://../../.." "h2-lwt"
+    ; package ~pin:"file://../../.." "h2-mirage"
+    ]
+  in
+  foreign
+    ~packages
+    "Unikernel.Make"
+    (random @-> stackv4 @-> kv_ro @-> console @-> pclock @-> job)
+
+let () =
+  register
+    "alpn_unikernel"
+    [ server
+      $ default_random
+      $ stack
+      $ secrets
+      $ default_console
+      $ default_posix_clock
+    ]

unikernel/duniverse/ocaml-h2/examples/alpn/mirage/h2_handler.ml

@@ -0,0 +1,26 @@
+open H2
+
+let request_handler : Reqd.t -> unit =
+ fun request_descriptor ->
+  let { Request.headers; _ } = Reqd.request request_descriptor in
+  let response_content_type =
+    match Headers.get headers "Content-Type" with
+    | Some request_content_type -> request_content_type
+    | None -> "text/plain"
+  in
+  let response =
+    Response.create
+      ~headers:(Headers.of_list [ "content-type", response_content_type ])
+      `OK
+  in
+  Reqd.respond_with_string
+    request_descriptor
+    response
+    "Welcome to an ALPN-negotiated HTTP/2 connection"
+
+let error_handler :
+    ?request:H2.Request.t -> _ -> (Headers.t -> Body.Writer.t) -> unit
+  =
+ fun ?request:_ _error start_response ->
+  let response_body = start_response Headers.empty in
+  Body.Writer.close response_body

unikernel/duniverse/ocaml-h2/examples/alpn/mirage/http1_handler.ml

@@ -0,0 +1,46 @@
+open Httpun
+
+let redirect_handler : Reqd.t Gluten.reqd -> unit =
+ fun { Gluten.reqd; _ } ->
+  let response =
+    Response.create
+      ~headers:
+        (Headers.of_list
+           [ "Location", "https://localhost:9443"; "Connection", "close" ])
+      `Moved_permanently
+  in
+  Reqd.respond_with_string reqd response ""
+
+let redirect_error_handler :
+    ?request:Request.t -> _ -> (Headers.t -> Body.Writer.t) -> unit
+  =
+ fun ?request:_ _error start_response ->
+  let response_body = start_response Headers.empty in
+  Body.Writer.close response_body
+
+let request_handler : Reqd.t Gluten.reqd -> unit =
+ fun { Gluten.reqd; _ } ->
+  let { Request.headers; _ } = Reqd.request reqd in
+  let response_content_type =
+    match Headers.get headers "Content-Type" with
+    | Some request_content_type -> request_content_type
+    | None -> "text/plain"
+  in
+  let response_body = "Welcome to an ALPN-negotiated HTTP/1.1 connection" in
+  let response =
+    Response.create
+      ~headers:
+        (Headers.of_list
+           [ "content-type", response_content_type
+           ; "Content-Length", String.length response_body |> string_of_int
+           ])
+      `OK
+  in
+  Reqd.respond_with_string reqd response response_body
+
+let error_handler :
+    ?request:Request.t -> _ -> (Headers.t -> Body.Writer.t) -> unit
+  =
+ fun ?request:_ _error start_response ->
+  let response_body = start_response Headers.empty in
+  Body.Writer.close response_body

unikernel/duniverse/ocaml-h2/examples/alpn/mirage/unikernel.ml

@@ -0,0 +1,111 @@
+(*
+   * This code was adapted from
+ * https://github.com/mirage/mirage-www/blob/master/src/dispatch_tls.ml.
+ *
+ * Its copyright header is retained below.
+ *
+ * Copyright (c) 2015 Thomas Gazagnaire <thomas@gazagnaire.org>
+ *
+ * Permission to use, copy, modify, and distribute this software for any
+ * purpose with or without fee is hereby granted, provided that the above
+ * copyright notice and this permission notice appear in all copies.
+ *
+ * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+ * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+ * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+ * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+ * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+ *)
+open Lwt.Infix
+
+module type HTTP = Httpun_mirage.Server
+module type HTTP2 = H2_mirage.Server
+
+module Dispatch (Http : HTTP) (Https : HTTP) (Http2 : HTTP2) = struct
+  let redirect =
+    Http.create_connection_handler
+      ?config:None
+      ~request_handler:Http1_handler.redirect_handler
+      ~error_handler:Http1_handler.redirect_error_handler
+
+  let http1_handler =
+    Https.create_connection_handler
+      ?config:None
+      ~request_handler:Http1_handler.request_handler
+      ~error_handler:Http1_handler.error_handler
+
+  let h2_handler =
+    Http2.create_connection_handler
+      ?config:None
+      ~request_handler:H2_handler.request_handler
+      ~error_handler:H2_handler.error_handler
+end
+
+module Make
+    (Random : Mirage_random.S)
+    (S : Mirage_stack.V4)
+    (KEYS : Mirage_kv.RO)
+    (C : Mirage_console.S)
+    (Clock : Mirage_clock.PCLOCK) =
+struct
+  module X509 = Tls_mirage.X509 (KEYS) (Clock)
+  module TCP = S.TCPV4
+  module TLS = Tls_mirage.Make (TCP)
+  module Http = Httpun_mirage.Server (TCP)
+  module Https = Httpun_mirage.Server (TLS)
+  module Http2 = H2_mirage.Server (TLS)
+  module D = Dispatch (Http) (Https) (Http2)
+
+  let log_src = Logs.Src.create "dispatch_tls" ~doc:"web-over-tls server"
+
+  module Log = (val Logs.src_log log_src : Logs.LOG)
+
+  let log c fmt = Printf.ksprintf (C.log c) fmt
+
+  let with_tls cfg tcp ~f =
+    let peer, port = TCP.dst tcp in
+    let log str =
+      Log.debug (fun f -> f "[%s:%d] %s" (Ipaddr.V4.to_string peer) port str)
+    in
+    TLS.server_of_flow cfg tcp >>= function
+    | Error _ ->
+      log "TLS failed";
+      TCP.close tcp
+    | Ok tls_server ->
+      log "TLS ok";
+      f tls_server >>= fun () -> TLS.close tls_server
+
+  let tls_init kv =
+    X509.certificate kv `Default >|= fun certificate ->
+    Tls.Config.server
+      ~alpn_protocols:[ "h2"; "http/1.1" ] (* accept h2 before http/1.1 *)
+      ~certificates:(`Single certificate)
+      ()
+
+  let start _random stack keys c _clock =
+    tls_init keys >>= fun tls_config ->
+    log c "started unikernel listen (http: 8080, https: 9443)" >>= fun () ->
+    S.listen_tcpv4 stack ~port:8080 D.redirect;
+    S.listen_tcpv4 stack ~port:9443 (fun flow ->
+      with_tls tls_config flow ~f:(fun flow ->
+        match TLS.epoch flow with
+        | Error () ->
+          Lwt_io.eprintlf
+            "Unable to fetch session data. Did the handshake fail?"
+        | Ok { Tls.Core.alpn_protocol; _ } ->
+          (match alpn_protocol with
+          | None ->
+            (* Unable to negotiate a protocol *)
+            Lwt.return_unit
+          | Some "http/1.1" -> D.http1_handler flow
+          | Some "h2" -> D.h2_handler flow
+          | _ ->
+            (* Can't really happen - would mean that TLS negotiated a
+             * protocol that we didn't specify. *)
+            assert false)));
+    S.listen stack >>= fun () ->
+    let forever, _ = Lwt.wait () in
+    forever
+end

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))