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

unikernel/duniverse/ocaml-h2/examples/async/async_ssl_https_echo_server_post.ml

@@ -0,0 +1,76 @@
+open Core
+open Async
+open H2
+open H2_async
+
+let error_handler _ ?request:_ error start_response =
+  let response_body = start_response Headers.empty in
+  (match error with
+  | `Exn exn ->
+    Body.Writer.write_string response_body (Exn.to_string exn);
+    Body.Writer.write_string response_body "\n"
+  | #Status.standard as error ->
+    Body.Writer.write_string response_body (Status.default_reason_phrase error));
+  Body.Writer.close response_body
+
+let request_handler sock reqd =
+  eprintf "Received request from %s\n%!" (Socket.Address.Inet.to_string sock);
+  match Reqd.request reqd with
+  | { Request.meth = `POST; headers; _ } ->
+    let response =
+      let content_type =
+        match Headers.get headers "content-type" with
+        | None -> "application/octet-stream"
+        | Some x -> x
+      in
+      Response.create
+        ~headers:(Headers.of_list [ "content-type", content_type ])
+        `OK
+    in
+    let request_body = Reqd.request_body reqd in
+    let response_body = Reqd.respond_with_streaming reqd response in
+    let rec on_read buffer ~off ~len =
+      Body.Writer.write_bigstring response_body buffer ~off ~len;
+      Body.Reader.schedule_read request_body ~on_eof ~on_read
+    and on_eof () =
+      print_endline "eof";
+      Body.Writer.close response_body
+    in
+    Body.Reader.schedule_read (Reqd.request_body reqd) ~on_eof ~on_read
+  | _ -> Reqd.respond_with_string reqd (Response.create `Method_not_allowed) ""
+
+let main port max_accepts_per_batch () =
+  let where_to_listen =
+    Tcp.Where_to_listen.bind_to
+      Tcp.Bind_to_address.Localhost
+      (Tcp.Bind_to_port.On_port port)
+  in
+  Tcp.(
+    Server.create_sock
+      ~on_handler_error:`Ignore
+      ~backlog:10_000
+      ~max_connections:10_000
+      ~max_accepts_per_batch
+      where_to_listen)
+    (Server.SSL.create_connection_handler_with_default
+       ~certfile:"./certificates/server.pem"
+       ~keyfile:"./certificates/server.key"
+       ~request_handler
+       ~error_handler)
+  >>= fun _server -> Deferred.never ()
+
+let () =
+  Command.async_spec
+    ~summary:"Start a hello world async_ssl server"
+    Command.Spec.(
+      empty
+      +> flag
+           "-port"
+           (optional_with_default 8080 int)
+           ~doc:"int Source port to listen on"
+      +> flag
+           "-a"
+           (optional_with_default 1 int)
+           ~doc:"int Maximum accepts per batch")
+    main
+  |> Command_unix.run

unikernel/duniverse/ocaml-h2/examples/async/async_tls_https_echo_client_post.ml

@@ -0,0 +1,85 @@
+open Core
+open Async
+open H2
+open H2_async
+
+let error_handler = function
+  | `Invalid_response_body_length _resp ->
+    printf "invalid response body length\n%!"
+  | `Exn _exn -> printf "exception!\n%!"
+  | `Malformed_response s -> printf "malformed response: %s\n%!" s
+  | `Protocol_error (code, s) ->
+    printf "protocol error: %s, %s\n%!" (H2.Error_code.to_string code) s
+
+let response_handler response_received_ivar response response_body =
+  match Response.(response.status) with
+  | `OK ->
+    let rec read_response () =
+      Body.Reader.schedule_read
+        response_body
+        ~on_eof:(fun () ->
+          (Ivar.fill [@ocaml.alert "-deprecated"]) response_received_ivar ())
+        ~on_read:(fun response_fragment ~off ~len ->
+          printf
+            "Server response: %s\n%!"
+            (Bigstringaf.substring ~off ~len response_fragment);
+          read_response ())
+    in
+    read_response ()
+  | _ ->
+    Format.fprintf Format.err_formatter "%a\n%!" Response.pp_hum response;
+    Shutdown.shutdown 1
+
+let main port host () =
+  printf "Type in your text to send, then hit EOF:\n%!";
+  Reader.contents (Lazy.force Reader.stdin) >>= fun text_to_send ->
+  let socket = Unix.Socket.create Unix.Socket.Type.tcp in
+  let where_to_connect =
+    let hnp = Host_and_port.create ~host ~port in
+    Tcp.Where_to_connect.of_host_and_port hnp
+  in
+  Client.TLS.create_connection_with_default
+    ~error_handler
+    socket
+    where_to_connect
+  >>= fun tls_conn ->
+  let request_headers =
+    Request.create
+      `POST
+      "/"
+      ~scheme:"http"
+      ~headers:
+        Headers.(
+          of_list
+            [ ":authority", host
+            ; "content-length", string_of_int (String.length text_to_send)
+            ])
+  in
+  let response_received_ivar = Ivar.create () in
+  let response_handler = response_handler response_received_ivar in
+  let request_body =
+    H2_async.Client.TLS.request
+      tls_conn
+      request_headers
+      ~error_handler
+      ~response_handler
+  in
+  Body.Writer.write_string request_body text_to_send;
+  Body.Writer.close request_body;
+  Ivar.read response_received_ivar
+
+let () =
+  Command.async_spec
+    ~summary:"Start a hello world tls-async client"
+    Command.Spec.(
+      empty
+      +> flag
+           "-port"
+           (optional_with_default 8080 int)
+           ~doc:"int Source port to listen on"
+      +> flag
+           "-host"
+           (optional_with_default "localhost" string)
+           ~doc:"HOST to connect to")
+    main
+  |> Command_unix.run

unikernel/duniverse/ocaml-h2/examples/async/dune

@@ -0,0 +1,8 @@
+(executables
+ (libraries h2 h2-async async core core_unix.command_unix)
+ (names async_ssl_https_echo_server_post async_tls_https_echo_client_post))
+
+(alias
+ (name examples)
+ (deps
+  (glob_files *.exe)))

unikernel/duniverse/ocaml-h2/examples/eio/dune

@@ -0,0 +1,8 @@
+(executable
+ (name eio_get)
+ (libraries h2 h2-eio eio-ssl eio_main eio.unix))
+
+(alias
+ (name examples)
+ (deps
+  (glob_files *.exe)))

unikernel/duniverse/ocaml-h2/examples/eio/eio_get.ml

@@ -0,0 +1,118 @@
+open H2
+module Client = H2_eio.Client
+
+let response_handler ~on_eof response response_body =
+  Format.eprintf "Response: %a@." Response.pp_hum response;
+
+  let rec read_response () =
+    Body.Reader.schedule_read
+      response_body
+      ~on_eof
+      ~on_read:(fun bigstring ~off ~len ->
+        Format.eprintf "heh nice %d@." len;
+        let response_fragment = Bytes.create len in
+        Bigstringaf.blit_to_bytes
+          bigstring
+          ~src_off:off
+          response_fragment
+          ~dst_off:0
+          ~len;
+        print_string (Bytes.to_string response_fragment);
+        read_response ())
+  in
+  read_response ()
+
+let error_handler u err =
+  (match err with
+  | `Exn exn -> Format.eprintf "wut %S@." (Printexc.to_string exn)
+  | `Invalid_response_body_length res ->
+    Format.eprintf "invalid res: %a@." Response.pp_hum res
+  | `Malformed_response str -> Format.eprintf "malformed %S@." str
+  | `Protocol_error (err, s) ->
+    Format.eprintf "wut %a %S@." H2.Error_code.pp_hum err s);
+  Eio.Promise.resolve u ()
+
+let[@ocaml.alert "-deprecated"] () =
+  Ssl_threads.init ();
+  Ssl.init ~thread_safe:true ();
+  let host = ref None in
+  let port = ref 443 in
+  Arg.parse
+    [ "-p", Set_int port, " Port number (443 by default)" ]
+    (fun host_argument -> host := Some host_argument)
+    "eio_get.exe [-p N] HOST";
+  let host =
+    match !host with
+    | None -> failwith "No hostname provided"
+    | Some host -> host
+  in
+  Eio_main.run (fun env ->
+    let network = Eio.Stdenv.net env in
+    Eio.Switch.run (fun sw ->
+      let addrs =
+        let addrs =
+          Eio_unix.run_in_systhread (fun () ->
+            Unix.getaddrinfo
+              host
+              (string_of_int !port)
+              [ Unix.(AI_FAMILY PF_INET) ])
+        in
+        List.filter_map
+          (fun (addr : Unix.addr_info) ->
+             match addr.ai_addr with
+             | Unix.ADDR_UNIX _ -> None
+             | ADDR_INET (addr, port) -> Some (addr, port))
+          addrs
+      in
+      let addr =
+        let inet, port = List.hd addrs in
+        `Tcp (Eio_unix.Net.Ipaddr.of_unix inet, port)
+      in
+      let socket = Eio.Net.connect ~sw network addr in
+
+      let request =
+        Request.create
+          `GET
+          "/"
+          ~scheme:"https"
+          ~headers:
+            Headers.(
+              add_list
+                empty
+                [ "user-agent", "carl/0.0.0-experimental"; ":authority", host ])
+      in
+
+      let ctx = Ssl.create_context Ssl.SSLv23 Ssl.Client_context in
+      (* Ssl.disable_protocols ctx [ Ssl.SSLv23 ]; *)
+      Ssl.honor_cipher_order ctx;
+      Ssl.set_context_alpn_protos ctx [ "h2" ];
+
+      Ssl.set_min_protocol_version ctx TLSv1_3;
+      Ssl.set_max_protocol_version ctx TLSv1_3;
+
+      let ssl_ctx = Eio_ssl.Context.create ~ctx socket in
+      let ssl_sock = Eio_ssl.Context.ssl_socket ssl_ctx in
+      Ssl.set_client_SNI_hostname ssl_sock host;
+      Ssl.set_hostflags ssl_sock [ No_partial_wildcards ];
+      Ssl.set_host ssl_sock host;
+      let ssl_sock = Eio_ssl.connect ssl_ctx in
+
+      let shut_p, shut_u = Eio.Promise.create () in
+      let error_handler = error_handler shut_u in
+      let connection = Client.create_connection ~sw ~error_handler ssl_sock in
+      let response_handler =
+        response_handler ~on_eof:(fun () ->
+          Format.eprintf "eof@.";
+          Eio.Promise.resolve shut_u ())
+      in
+      let request_body =
+        Client.request
+          connection
+          request
+          ~error_handler
+          ~response_handler
+          ~flush_headers_immediately:true
+      in
+      Body.Writer.close request_body;
+      Eio.Promise.await shut_p;
+      Eio.Promise.await (Client.shutdown connection)))

unikernel/duniverse/ocaml-h2/examples/lwt/dune

@@ -0,0 +1,14 @@
+(executables
+ (names lwt_echo_server2 lwt_https_server lwt_get lwt_post)
+ (modules lwt_echo_server2 lwt_https_server lwt_get lwt_post)
+ (libraries h2 h2-lwt-unix lwt.unix))
+
+(executable
+ (name lwt_h2c)
+ (libraries h2 httpun-lwt-unix h2-lwt-unix lwt.unix)
+ (modules lwt_h2c))
+
+(alias
+ (name examples)
+ (deps
+  (glob_files *.exe)))

unikernel/duniverse/ocaml-h2/examples/lwt/lwt_echo_server2.ml

@@ -0,0 +1,155 @@
+let set_interval s f destroy =
+  let rec set_interval_loop s f n =
+    let timeout =
+      Lwt_timeout.create s (fun () ->
+        if n > 0
+        then (if f () then set_interval_loop s f (n - 1))
+        else destroy ())
+    in
+    Lwt_timeout.start timeout
+  in
+  set_interval_loop s f 2
+
+let connection_handler : Unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t =
+  let open H2 in
+  let request_handler : Unix.sockaddr -> Reqd.t -> unit =
+   fun _client_address request_descriptor ->
+    let request = Reqd.request request_descriptor in
+    match request.meth, request.target with
+    | `GET, "/" | `POST, "/" ->
+      let request_body = Reqd.request_body request_descriptor in
+      let response_content_type =
+        match Headers.get request.headers "content-type" with
+        | Some request_content_type -> request_content_type
+        | None -> "application/octet-stream"
+      in
+      let rec respond () =
+        Body.Reader.schedule_read
+          request_body
+          ~on_eof:(fun () ->
+            let response =
+              Response.create
+                ~headers:
+                  (Headers.of_list [ "content-type", response_content_type ])
+                `OK
+            in
+            Reqd.respond_with_string
+              request_descriptor
+              response
+              "non-empty data.")
+          ~on_read:(fun _request_data ~off:_ ~len:_ -> respond ())
+      in
+      respond ()
+    | `POST, "/other" ->
+      let request_body = Reqd.request_body request_descriptor in
+      let response_content_type =
+        match Headers.get request.headers "content-type" with
+        | Some request_content_type -> request_content_type
+        | None -> "application/octet-stream"
+      in
+      let response =
+        Response.create
+          ~headers:(Headers.of_list [ "content-type", response_content_type ])
+          `OK
+      in
+      let response_body =
+        Reqd.respond_with_streaming request_descriptor response
+      in
+      let rec respond () =
+        Body.Reader.schedule_read
+          request_body
+          ~on_eof:(fun () ->
+            set_interval
+              1
+              (fun () ->
+                 Body.Writer.write_string response_body "FOO";
+                 (* Body.flush response_body ignore; *)
+                 true)
+              (* Body.flush response_body ignore; *)
+                 (fun () -> Body.Writer.close response_body))
+          ~on_read:(fun request_data ~off ~len ->
+            Body.Writer.write_bigstring response_body request_data ~off ~len;
+            respond ())
+      in
+      respond ()
+    | `POST, "/foo" ->
+      let response =
+        Response.create
+          `OK
+          ~headers:(Headers.of_list [ "content-type", "text/event-stream" ])
+      in
+      let request_body = Reqd.request_body request_descriptor in
+      let response_body =
+        Reqd.respond_with_streaming request_descriptor response
+      in
+      (* let (finished, notify) = Lwt.wait () in *)
+      let rec on_read _request_data ~off:_ ~len:_ =
+        Body.Writer.flush response_body (fun _ ->
+          Body.Reader.schedule_read request_body ~on_eof ~on_read)
+      and on_eof () =
+        set_interval
+          2
+          (fun () ->
+             let _ =
+               Body.Writer.write_string response_body "data: some data\n\n"
+             in
+             Body.Writer.flush response_body ignore;
+             true)
+          (fun () ->
+             let _ =
+               Body.Writer.write_string response_body "event: end\ndata: 1\n\n"
+             in
+             Body.Writer.flush response_body (fun _ ->
+               Body.Writer.close response_body))
+      in
+      Body.Reader.schedule_read ~on_read ~on_eof request_body;
+      ()
+    | _ ->
+      Reqd.respond_with_string
+        request_descriptor
+        (Response.create `Method_not_allowed)
+        "Hello, Sean."
+  in
+  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
+    (match error with
+    | `Exn exn ->
+      Body.Writer.write_string response_body (Printexc.to_string exn);
+      Body.Writer.write_string response_body "\n"
+    | #Status.standard as error ->
+      Body.Writer.write_string
+        response_body
+        (Status.default_reason_phrase error));
+    Body.Writer.close response_body
+  in
+  H2_lwt_unix.Server.create_connection_handler
+    ?config:None
+    ~request_handler
+    ~error_handler
+
+let () =
+  let open Lwt.Infix in
+  Sys.(set_signal sigpipe Signal_ignore);
+  let port = ref 8080 in
+  Arg.parse
+    [ "-p", Arg.Set_int port, " Listening port number (8080 by default)" ]
+    ignore
+    "Echoes POST requests. Runs forever.";
+  let listen_address = Unix.(ADDR_INET (inet_addr_loopback, !port)) in
+  Lwt.async (fun () ->
+    Lwt_io.establish_server_with_client_socket listen_address connection_handler
+    >>= fun _server ->
+    Printf.printf "Listening on port %i and echoing POST requests.\n" !port;
+    print_string "To send a POST request, try\n\n";
+    print_string "  echo foo | dune exec examples/lwt/lwt_post.exe\n\n";
+    flush stdout;
+    Lwt.return_unit);
+  let forever, _ = Lwt.wait () in
+  Lwt_main.run forever

unikernel/duniverse/ocaml-h2/examples/lwt/lwt_get.ml

@@ -0,0 +1,61 @@
+open H2
+module Client = H2_lwt_unix.Client
+
+let response_handler notify_response_received _response response_body =
+  let rec read_response () =
+    Body.Reader.schedule_read
+      response_body
+      ~on_eof:(fun () -> Lwt.wakeup_later notify_response_received ())
+      ~on_read:(fun bigstring ~off ~len ->
+        let response_fragment = Bytes.create len in
+        Bigstringaf.blit_to_bytes
+          bigstring
+          ~src_off:off
+          response_fragment
+          ~dst_off:0
+          ~len;
+        print_string (Bytes.to_string response_fragment);
+        read_response ())
+  in
+  read_response ()
+
+let error_handler _ = assert false
+
+open Lwt.Infix
+
+let () =
+  let host = ref None in
+  let port = ref 443 in
+  Arg.parse
+    [ "-p", Set_int port, " Port number (443 by default)" ]
+    (fun host_argument -> host := Some host_argument)
+    "lwt_get.exe [-p N] HOST";
+  let host =
+    match !host with
+    | None -> failwith "No hostname provided"
+    | Some host -> host
+  in
+  Lwt_main.run
+    ( Lwt_unix.getaddrinfo
+        host
+        (string_of_int !port)
+        [ Unix.(AI_FAMILY PF_INET) ]
+    >>= fun addresses ->
+      let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+      Lwt_unix.connect socket (List.hd addresses).Unix.ai_addr >>= fun () ->
+      let request =
+        Request.create
+          `GET
+          "/"
+          ~scheme:"https"
+          ~headers:Headers.(add_list empty [ ":authority", host ])
+      in
+      let response_received, notify_response_received = Lwt.wait () in
+      let response_handler = response_handler notify_response_received in
+      Client.SSL.create_connection_with_default ~error_handler socket
+      >>= fun connection ->
+      let request_body =
+        Client.SSL.request connection request ~error_handler ~response_handler
+      in
+      Body.Writer.close request_body;
+      response_received )

unikernel/duniverse/ocaml-h2/examples/lwt/lwt_h2c.ml

@@ -0,0 +1,142 @@
+open Lwt.Infix
+
+module Http2 = struct
+  open H2
+
+  let connection_handler :
+       Httpun.Request.t
+      -> Bigstringaf.t H2.IOVec.t list
+      -> (Server_connection.t, string) result
+    =
+    let request_handler : H2.Server_connection.request_handler =
+     fun request_descriptor ->
+      let request = Reqd.request request_descriptor in
+      match request.meth, request.target with
+      | `GET, "/" | `POST, "/" ->
+        (* This set of routes waits until the entire request body has been read
+         * to produce a response. *)
+        let request_body = Reqd.request_body request_descriptor in
+        let response_content_type =
+          match Headers.get request.headers "content-type" with
+          | Some request_content_type -> request_content_type
+          | None -> "application/octet-stream"
+        in
+        let buf = Buffer.create 10 in
+        let rec respond () =
+          Body.Reader.schedule_read
+            request_body
+            ~on_eof:(fun () ->
+              let response =
+                Response.create
+                  ~headers:
+                    (Headers.of_list [ "content-type", response_content_type ])
+                  `OK
+              in
+              Reqd.respond_with_string
+                request_descriptor
+                response
+                (Buffer.contents buf))
+            ~on_read:(fun request_data ~off ~len ->
+              let bytes = Bytes.create len in
+              Bigstringaf.blit_to_bytes
+                request_data
+                ~src_off:off
+                ~dst_off:0
+                ~len
+                bytes;
+              Buffer.add_bytes buf bytes;
+              respond ())
+        in
+        respond ()
+      | _ ->
+        Reqd.respond_with_string
+          request_descriptor
+          (Response.create `Method_not_allowed)
+          ""
+    in
+    let error_handler ?request:_ error start_response =
+      let response_body = start_response Headers.empty in
+      (match error with
+      | `Exn exn ->
+        Body.Writer.write_string response_body (Printexc.to_string exn);
+        Body.Writer.write_string response_body "\n"
+      | #Status.standard as error ->
+        Body.Writer.write_string
+          response_body
+          (Status.default_reason_phrase error));
+      Body.Writer.close response_body
+    in
+    fun http_request request_body ->
+      let { Httpun.Request.headers; target; meth; _ } = http_request in
+      H2.Server_connection.create_h2c
+        ?config:None
+        ~headers
+        ~target
+        ~meth
+        ~request_body
+        ~error_handler
+        request_handler
+end
+
+let connection_handler =
+  let module Body = Httpun.Body in
+  let module Headers = Httpun.Headers in
+  let module Reqd = Httpun.Reqd in
+  let module Response = Httpun.Response in
+  let module Status = Httpun.Status in
+  let upgrade_handler request upgrade () =
+    let off = 0 in
+    let len = 3 in
+    let body =
+      [ { H2.IOVec.buffer = Bigstringaf.of_string ~off ~len "foo"; off; len }
+      ; { buffer = Bigstringaf.of_string ~off ~len "bar"; off; len }
+      ; { buffer = Bigstringaf.of_string ~off ~len "baz"; off; len }
+      ]
+    in
+    let connection =
+      Stdlib.Result.get_ok (Http2.connection_handler request body)
+    in
+    upgrade (Gluten.make (module H2.Server_connection) connection)
+  in
+  let http_error_handler _client_address ?request:_ error handle =
+    let message =
+      match error with
+      | `Exn exn -> Printexc.to_string exn
+      | (#Status.client_error | #Status.server_error) as error ->
+        Status.to_string error
+    in
+    let body = handle Headers.empty in
+    Body.Writer.write_string body message;
+    Body.Writer.close body
+  in
+  let request_handler _addr (reqd : Httpun.Reqd.t Gluten.reqd) =
+    let { Gluten.reqd; upgrade } = reqd in
+    let headers =
+      Headers.of_list [ "Connection", "Upgrade"; "Upgrade", "h2c" ]
+    in
+    let request = Reqd.request reqd in
+    Reqd.respond_with_upgrade reqd headers (upgrade_handler request upgrade)
+  in
+  Httpun_lwt_unix.Server.create_connection_handler
+    ?config:None
+    ~request_handler
+    ~error_handler:http_error_handler
+
+let () =
+  Sys.(set_signal sigpipe Signal_ignore);
+  let port = ref 8080 in
+  Arg.parse
+    [ "-p", Arg.Set_int port, " Listening port number (8080 by default)" ]
+    ignore
+    "Echoes POST requests. Runs forever.";
+  let listen_address = Unix.(ADDR_INET (inet_addr_loopback, !port)) in
+  Lwt.async (fun () ->
+    Lwt_io.establish_server_with_client_socket listen_address connection_handler
+    >>= fun _server ->
+    Printf.printf "Listening on port %i and echoing POST requests.\n" !port;
+    print_string "To send a POST request, try\n\n";
+    print_string "  echo foo | dune exec examples/lwt/lwt_post.exe\n\n";
+    flush stdout;
+    Lwt.return_unit);
+  let forever, _ = Lwt.wait () in
+  Lwt_main.run forever

unikernel/duniverse/ocaml-h2/examples/lwt/lwt_https_server.ml

@@ -0,0 +1,120 @@
+let set_interval ?(times = 5) s f destroy =
+  let rec set_interval_loop s f n =
+    let timeout =
+      Lwt_timeout.create s (fun () ->
+        if n > 0
+        then (if f () then set_interval_loop s f (n - 1))
+        else destroy ())
+    in
+    Lwt_timeout.start timeout
+  in
+  set_interval_loop s f times
+
+let connection_handler : Unix.sockaddr -> Lwt_unix.file_descr -> unit Lwt.t =
+  let open H2 in
+  let request_handler : Unix.sockaddr -> Reqd.t -> unit =
+   fun _client_address request_descriptor ->
+    let request = Reqd.request request_descriptor in
+    match request.meth, request.target with
+    | `POST, "/" ->
+      (* let request_body = Reqd.request_body request_descriptor in *)
+      let response_content_type =
+        match Headers.get request.headers "Content-Type" with
+        | Some request_content_type -> request_content_type
+        | None -> "application/octet-stream"
+      in
+      let response =
+        Response.create
+          ~headers:
+            (Headers.of_list
+               [ "content-type", response_content_type
+                 (* "Connection", "close"; *)
+               ])
+          `OK
+      in
+
+      (* let response_body = Reqd.respond_with_streaming request_descriptor
+         response in *)
+
+      (* let rec respond () = Body.schedule_read request_body ~on_eof:(fun () ->
+         Body.close_writer response_body) ~on_read:(fun request_data ~off ~len
+         -> Body.write_bigstring response_body request_data ~off ~len; respond
+         ()) in respond () *)
+      Reqd.respond_with_string request_descriptor response "ANTOINO"
+    | `POST, "/foo" ->
+      set_interval
+        ~times:1
+        2
+        (fun () ->
+           let response_content_type =
+             match Headers.get request.headers "Content-Type" with
+             | Some request_content_type -> request_content_type
+             | None -> "application/octet-stream"
+           in
+           let response =
+             Response.create
+               ~headers:
+                 (Headers.of_list
+                    [ "content-type", response_content_type
+                      (* "Connection", "close"; *)
+                    ])
+               `OK
+           in
+           Reqd.respond_with_string request_descriptor response "ANTOINO";
+           true)
+        ignore
+    | `GET, _ ->
+      Reqd.respond_with_string
+        request_descriptor
+        (Response.create `OK)
+        "Welcome to ocaml-h2"
+    | _ ->
+      Reqd.respond_with_string
+        request_descriptor
+        (Response.create `Method_not_allowed)
+        ""
+  in
+  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
+    (* begin match error with | `Exn exn -> Body.write_string response_body
+       (Printexc.to_string exn); Body.write_string response_body "\n";
+
+       | #Status.standard as error -> Body.write_string response_body
+       (Status.default_reason_phrase error) end; *)
+    Body.Writer.close response_body
+  in
+  let certfile = "./certificates/server.pem" in
+  let keyfile = "./certificates/server.key" in
+  H2_lwt_unix.Server.SSL.create_connection_handler_with_default
+    ~certfile
+    ~keyfile
+    ?config:None
+    ~request_handler
+    ~error_handler
+
+let () =
+  let open Lwt.Infix in
+  Sys.(set_signal sigpipe Signal_ignore);
+  let port = ref 8080 in
+  Arg.parse
+    [ "-p", Arg.Set_int port, " Listening port number (8080 by default)" ]
+    ignore
+    "Echoes POST requests. Runs forever.";
+  let listen_address = Unix.(ADDR_INET (inet_addr_loopback, !port)) in
+  Lwt.async (fun () ->
+    Lwt_io.establish_server_with_client_socket listen_address connection_handler
+    >>= fun _server ->
+    Printf.printf "Listening on port %i and echoing POST requests.\n" !port;
+    print_string "To send a POST request, try\n\n";
+    print_string "  curl https://localhost:8080 -k -X POST -d foo\n\n";
+    flush stdout;
+    Lwt.return_unit);
+  let forever, _ = Lwt.wait () in
+  Lwt_main.run forever

unikernel/duniverse/ocaml-h2/examples/lwt/lwt_post.ml

@@ -0,0 +1,78 @@
+open H2
+
+let response_handler notify_response_received response response_body =
+  match Response.(response.status) with
+  | `OK ->
+    let rec read_response () =
+      Body.Reader.schedule_read
+        response_body
+        ~on_eof:(fun () -> Lwt.wakeup_later notify_response_received ())
+        ~on_read:(fun response_fragment ~off ~len ->
+          let response_fragment_string = Bytes.create len in
+          Lwt_bytes.blit_to_bytes
+            response_fragment
+            off
+            response_fragment_string
+            0
+            len;
+          print_string (Bytes.unsafe_to_string response_fragment_string);
+          read_response ())
+    in
+    read_response ()
+  | _ ->
+    Format.fprintf Format.err_formatter "%a\n%!" Response.pp_hum response;
+    exit 1
+
+let error_handler = function
+  | `Invalid_response_body_length _resp ->
+    Printf.printf "invalid response body length\n%!"
+  | `Exn _exn -> Printf.printf "exception!\n%!"
+  | `Malformed_response s -> Printf.printf "malformed response: %s\n%!" s
+  | `Protocol_error (code, s) ->
+    Printf.printf "protocol error: %s, %s\n%!" (H2.Error_code.to_string code) s
+
+open Lwt.Infix
+
+let () =
+  let host = ref "127.0.0.1" in
+  let port = ref 8080 in
+  Arg.parse
+    [ "-h", Set_string host, " Hostname (127.0.0.1 by default)"
+    ; "-p", Set_int port, " Port number (8080 by default)"
+    ]
+    ignore
+    "lwt_get.exe [-h HOST] [-p N]";
+  Lwt_main.run
+    ( Lwt_io.(read stdin) >>= fun text_to_send ->
+      Lwt_unix.getaddrinfo
+        !host
+        (string_of_int !port)
+        [ Unix.(AI_FAMILY PF_INET) ]
+      >>= fun addresses ->
+      let socket = Lwt_unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in
+      Lwt_unix.connect socket (List.hd addresses).Unix.ai_addr >>= fun () ->
+      let request_headers =
+        Request.create
+          `POST
+          "/"
+          ~scheme:"http"
+          ~headers:
+            Headers.(
+              of_list
+                [ ":authority", !host
+                ; "content-length", string_of_int (String.length text_to_send)
+                ])
+      in
+      let response_received, notify_response_received = Lwt.wait () in
+      let response_handler = response_handler notify_response_received in
+      H2_lwt_unix.Client.create_connection ~error_handler socket >>= fun conn ->
+      let request_body =
+        H2_lwt_unix.Client.request
+          conn
+          request_headers
+          ~error_handler
+          ~response_handler
+      in
+      Body.Writer.write_string request_body text_to_send;
+      Body.Writer.close request_body;
+      response_received )

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

@@ -0,0 +1,22 @@
+open Mirage
+
+(* Network configuration *)
+
+let stack = generic_stackv4 default_network
+
+(* Dependencies *)
+
+let server =
+  let packages =
+    [ package ~pin:"file://../../" "h2-lwt"
+    ; package ~pin:"file://../../" "h2-mirage"
+    ]
+  in
+  foreign "Unikernel.Make" ~packages (console @-> pclock @-> http2 @-> job)
+
+let app = http2_server @@ conduit_direct stack
+
+let () =
+  register
+    "h2_unikernel"
+    [ server $ default_console $ default_posix_clock $ app ]

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

@@ -0,0 +1,54 @@
+open Lwt.Infix
+open H2
+
+module type HTTP2 = H2_mirage.Server
+
+module Dispatch (C : Mirage_console.S) (Http2 : HTTP2) = struct
+  let log c fmt = Printf.ksprintf (C.log c) fmt
+
+  let get_content c path =
+    log c "Replying: %s" path >|= fun () -> "Hello from the h2 unikernel"
+
+  let dispatcher c reqd =
+    let { Request.target; _ } = Reqd.request reqd in
+    Lwt.catch
+      (fun () ->
+         get_content c target >|= fun body ->
+         let response =
+           Response.create
+             ~headers:
+               (Headers.of_list
+                  [ "content-length", body |> String.length |> string_of_int ])
+             `OK
+         in
+         Reqd.respond_with_string reqd response body)
+      (fun exn ->
+         let response = Response.create `Internal_server_error in
+         Lwt.return
+           (Reqd.respond_with_string reqd response (Printexc.to_string exn)))
+    |> ignore
+
+  let serve c dispatch =
+    let error_handler ?request:_ _error mk_response =
+      let response_body = mk_response Headers.empty in
+      Body.Writer.write_string response_body "Error handled";
+      Body.Writer.flush response_body (fun () ->
+        Body.Writer.close response_body)
+    in
+    Http2.create_connection_handler
+      ?config:None
+      ~request_handler:(dispatch c)
+      ~error_handler
+end
+
+(** Server boilerplate *)
+module Make (C : Mirage_console.S) (Clock : Mirage_clock.PCLOCK) (Http2 : HTTP2) =
+struct
+  module D = Dispatch (C) (Http2)
+
+  let log c fmt = Printf.ksprintf (C.log c) fmt
+
+  let start c _clock http2 =
+    log c "started unikernel listen on port 8001" >>= fun () ->
+    http2 (`TCP 8001) @@ D.serve c D.dispatcher
+end