unikernel/config.ml

@@ -5,8 +5,8 @@ type conn = Connect
 
 let conn = typ Connect
 
-let minipaf =
-  main "Unikernel.Make"
+let mte =
+  main "Unikernel.Make" ~local_libs:[ "mte" ]
     ~packages:
       [
         package "digestif"; package ~min:"0.0.9" "mimic-happy-eyeballs";
@@ -27,8 +27,11 @@ let stackv4v6 = generic_stackv4v6 default_network
 let tcpv4v6 = tcpv4v6_of_stackv4v6 stackv4v6
 let he = generic_happy_eyeballs stackv4v6
 let dns = generic_dns_client stackv4v6 he
-let certificates = crunch "data/tls/certificates"
-let keys = crunch "data/tls/keys"
+
+(* note: if crunch says that directory doesn't exists, it may be because
+   it's empty and you need to run gen_tls.sh *)
+let certificates = crunch "../data/tls/certificates"
+let keys = crunch "../data/tls/keys"
 
 let conn =
   let happy_eyeballs = mimic_happy_eyeballs stackv4v6 he dns in
@@ -38,5 +41,4 @@ let port = Runtime_arg.create ~pos:__POS__ "Unikernel.port"
 let http_server = paf_server ~port tcpv4v6
 
 let () =
-  register "minipaf"
-    [ minipaf $ certificates $ keys $ tcpv4v6 $ conn $ http_server ]
+  register "mte" [ mte $ certificates $ keys $ tcpv4v6 $ conn $ http_server ]

unikernel/connect.ml

@@ -0,0 +1,164 @@
+module type S = sig
+  val connect : Mimic.ctx -> Mimic.ctx Lwt.t
+  val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result
+end
+
+open Lwt.Infix
+
+let connect_scheme = Mimic.make ~name:"connect-scheme"
+let connect_port = Mimic.make ~name:"connect-port"
+let connect_hostname = Mimic.make ~name:"connect-hostname"
+let connect_tls_config = Mimic.make ~name:"connect-tls-config"
+
+module Make
+    (TCP : Tcpip.Tcp.S)
+    (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S =
+struct
+  module TCP = struct
+    include TCP
+
+    type endpoint = Happy_eyeballs.t * string * int
+
+    type nonrec write_error =
+      [ `Write of write_error
+      | `Connect of string
+      | `Closed
+      ]
+
+    let pp_write_error ppf = function
+      | `Connect err -> Fmt.string ppf err
+      | `Write err -> pp_write_error ppf err
+      | `Closed as err -> pp_write_error ppf err
+
+    let write flow cs =
+      let open Lwt.Infix in
+      write flow cs >>= function
+      | Ok _ as v -> Lwt.return v
+      | Error err -> Lwt.return_error (`Write err)
+
+    let writev flow css =
+      writev flow css >>= function
+      | Ok _ as v -> Lwt.return v
+      | Error err -> Lwt.return_error (`Write err)
+
+    let connect (happy_eyeballs, hostname, port) =
+      Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
+      | Error (`Msg err) -> Lwt.return_error (`Connect err)
+      | Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow
+  end
+
+  let tcp_edn, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP)
+
+  module TLS = struct
+    type endpoint = Happy_eyeballs.t * Tls.Config.client * string * int
+
+    include Tls_mirage.Make (TCP)
+
+    let connect (happy_eyeballs, cfg, hostname, port) =
+      let peer_name =
+        Result.(
+          to_option (bind (Domain_name.of_string hostname) Domain_name.host))
+      in
+      Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function
+      | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
+      | Error (`Msg err) -> Lwt.return_error (`Write (`Connect err))
+  end
+
+  let tls_edn, _tls_protocol = Mimic.register ~name:"tls" (module TLS)
+
+  let connect ctx =
+    let k0 happy_eyeballs connect_scheme connect_hostname connect_port =
+      match connect_scheme with
+      | "http" ->
+          Lwt.return_some (happy_eyeballs, connect_hostname, connect_port)
+      | _ -> Lwt.return_none
+    in
+    let k1 happy_eyeballs connect_scheme connect_hostname connect_port
+        tls_config =
+      match connect_scheme with
+      | "https" ->
+          Lwt.return_some
+            (happy_eyeballs, tls_config, connect_hostname, connect_port)
+      | _ -> Lwt.return_none
+    in
+    let ctx =
+      Mimic.fold tcp_edn
+        Mimic.Fun.
+          [
+            req Happy_eyeballs.happy_eyeballs; req connect_scheme;
+            req connect_hostname; dft connect_port 80;
+          ]
+        ~k:k0 ctx
+    in
+    let ctx =
+      Mimic.fold tls_edn
+        Mimic.Fun.
+          [
+            req Happy_eyeballs.happy_eyeballs; req connect_scheme;
+            req connect_hostname; dft connect_port 443; req connect_tls_config;
+          ]
+        ~k:k1 ctx
+    in
+    Lwt.return ctx
+
+  let authenticator = Ca_certs_nss.authenticator ()
+end
+
+let decode_uri ~ctx uri =
+  let ( >>= ) = Result.bind in
+  match String.split_on_char '/' uri with
+  | proto :: "" :: user_pass_host_port :: _path ->
+      (if String.equal proto "http:" then
+         Ok ("http", Mimic.add connect_scheme "http" ctx)
+       else if String.equal proto "https:" then
+         Ok ("https", Mimic.add connect_scheme "https" ctx)
+       else Error (`Msg "Couldn't decode user and password"))
+      >>= fun (_scheme, ctx) ->
+      (match String.split_on_char '@' user_pass_host_port with
+        | [ host_port ] -> Ok (None, host_port)
+        | [ _user_pass; host_port ] -> Ok (None, host_port)
+        | _ -> Error (`Msg "Couldn't decode URI"))
+      >>= fun (_user_pass, host_port) ->
+      (match String.split_on_char ':' host_port with
+        | [] -> Error (`Msg "Empty host & port")
+        | [ hostname ] -> Ok (hostname, Mimic.add connect_hostname hostname ctx)
+        | hd :: tl -> (
+            let port, hostname =
+              match List.rev (hd :: tl) with
+              | hd :: tl -> (hd, String.concat ":" (List.rev tl))
+              | _ -> assert false
+            in
+            try
+              Ok
+                ( hostname,
+                  Mimic.add connect_hostname hostname
+                    (Mimic.add connect_port (int_of_string port) ctx) )
+            with Failure _ -> Error (`Msg "Couldn't decode port")))
+      >>= fun (hostname, ctx) -> Ok (ctx, hostname)
+  | _ -> Error (`Msg "Couldn't decode URI on top")
+
+let tls_config ?tls_config authenticator =
+  lazy
+    (match tls_config with
+    | Some cfg -> Ok (`Custom cfg)
+    | None ->
+        let alpn_protocols = [ "h2"; "http/1.1" ] in
+        let ( let* ) = Result.bind in
+        let* authenticator = authenticator in
+        let* cfg = Tls.Config.client ~alpn_protocols ~authenticator () in
+        Ok (`Default cfg))
+
+let create_connection ?tls_config:cfg ~ctx ~authenticator uri =
+  let tls_config = tls_config ?tls_config:cfg authenticator in
+  let open Lwt_result.Infix in
+  Lwt.return (decode_uri ~ctx uri) >>= fun (ctx, host) ->
+  let ctx =
+    match Lazy.force tls_config with
+    | Ok (`Custom cfg) -> Mimic.add connect_tls_config cfg ctx
+    | Ok (`Default cfg) -> (
+        match Result.bind (Domain_name.of_string host) Domain_name.host with
+        | Ok peer -> Mimic.add connect_tls_config (Tls.Config.peer cfg peer) ctx
+        | Error _ -> Mimic.add connect_tls_config cfg ctx)
+    | Error _ -> ctx
+  in
+  Mimic.resolve ctx

unikernel/server.ml

@@ -0,0 +1,645 @@
+let src = Logs.Src.create "server"
+
+module Log = (val Logs.src_log src : Logs.LOG)
+
+let is_digit = function '0' .. '9' -> true | _ -> false
+
+let root =
+  {plain|Hello fellows!
+
+This unikernel is a simple example of a website that supports HTTP/1.1, H2 and
+the TLS security layer. This is an example of how to make a website with
+MirageOS.
+
+The website has several endpoints:
+- `http{,s}://$hostname/` the page you are about to read.
+- `http{,s}://$hostname/transmit` a page that copies what is sent (no matter
+  how big it is)
+- `http{,s}://$hostname/hash` calculates a hash from a random content
+  generated by a seed `x-seed`
+- `http{,s}://$hostname/random` a page that waits in the request for a size
+  (`x-length`) and generates a random (optionally seeded by `x-seed`) content
+  encoded in base64
+
+These different endpoints allow performance tests of what MirageOS can offer.
+Have fun, and hack it!
+|plain}
+
+let random_cstruct ~g buf len =
+  for i = 0 to Cstruct.length buf - 1 do
+    let v = Random.State.bits g land 0xff in
+    Cstruct.set_uint8 buf i v
+  done;
+  Cstruct.sub buf 0 len
+
+let random_state_of_seed str =
+  match Base64.decode str with
+  | Error _ -> None
+  | Ok seed ->
+      let res = Array.make (String.length seed / 2) 0 in
+      for i = 0 to (String.length seed / 2) - 1 do
+        res.(i) <-
+          (Char.code seed.[i * 2] lsl 8) lor Char.code seed.[(i * 2) + 1]
+      done;
+      Some (Random.State.make res)
+
+let transmit_random ~write_string ~flush ~close_writer
+    ?(g = Random.State.make_self_init ()) length body =
+  let tmp = Bytes.create (0x1000 * 4) in
+  let rnd = Cstruct.create 0x1000 in
+  let ctx = Digestif.SHA256.empty in
+
+  let encoder = Base64_rfc2045.encoder `Manual in
+
+  let rec go ctx length cs = function
+    | `Ok when Cstruct.length cs = 0 -> encode ctx length
+    | `Ok ->
+        go ctx length (Cstruct.shift cs 1)
+          (Base64_rfc2045.encode encoder (`Char (Cstruct.get_char cs 0)))
+    | `Partial ->
+        let len = Bytes.length tmp - Base64_rfc2045.dst_rem encoder in
+        write_string body (Bytes.sub_string tmp 0 len);
+        Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp);
+        let next () = go ctx length cs (Base64_rfc2045.encode encoder `Await) in
+        flush body next
+  and encode ctx = function
+    | 0L -> finalize ctx (Base64_rfc2045.encode encoder `End)
+    | length ->
+        let len = min (Int64.of_int (Cstruct.length rnd)) length in
+        let ({ Cstruct.buffer; off; len= buffer_len } as rnd) =
+          random_cstruct ~g rnd (Int64.to_int len)
+        in
+        Log.debug (fun m ->
+            m "@[<hov>%a@]"
+              (Hxd_string.pp Hxd.default)
+              (Bigstringaf.substring buffer ~off ~len:buffer_len));
+        let ctx =
+          Digestif.SHA256.feed_bigstring ctx ~off ~len:buffer_len buffer
+        in
+        go ctx (Int64.sub length len) rnd `Ok
+  and finalize ctx = function
+    | `Partial ->
+        let len = Bytes.length tmp - Base64_rfc2045.dst_rem encoder in
+        write_string body (Bytes.sub_string tmp 0 len);
+        Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp);
+        let next () = finalize ctx (Base64_rfc2045.encode encoder `Await) in
+        flush body next
+    | `Ok ->
+        Logs.debug (fun m ->
+            m "%a" Digestif.SHA256.pp (Digestif.SHA256.get ctx));
+        close_writer body
+  in
+
+  Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp);
+  encode ctx length
+
+let hash ~version ~create ?seed length =
+  let rec go g rnd ctx = function
+    | 0L ->
+        let headers =
+          [
+            ("content-length", string_of_int (Digestif.SHA256.digest_size * 2));
+            ("content-type", "text/plain");
+          ]
+        in
+        (* XXX(dinosaure): Connection: Close header is only true for http/1.1.
+           For h2, curl complains and abruptely closes the connection. The most
+           important seems Content-Length which closes properly the connection
+           on both sides. *)
+        let headers =
+          match version with
+          | `HTTP_1_1 -> ("connection", "close") :: headers
+          | `HTTP_2_0 -> headers
+        in
+        let response = create headers `OK in
+        (response, Digestif.SHA256.(to_hex (get ctx)))
+    | length ->
+        let len = min (Int64.of_int (Cstruct.length rnd)) length in
+        let { Cstruct.buffer; off; len= buffer_len } =
+          random_cstruct ~g rnd (Int64.to_int len)
+        in
+        Log.debug (fun m ->
+            m "@[<hov>%a@]"
+              (Hxd_string.pp Hxd.default)
+              (Bigstringaf.substring buffer ~off ~len:buffer_len));
+        let ctx =
+          Digestif.SHA256.feed_bigstring ctx ~off ~len:buffer_len buffer
+        in
+        go g rnd ctx (Int64.sub length len)
+  in
+  match
+    ( Option.bind seed random_state_of_seed,
+      Option.bind length Int64.of_string_opt )
+  with
+  | Some g, Some length ->
+      go g (Cstruct.create 0x1000) Digestif.SHA256.empty length
+  | _ ->
+      let contents = "Invalid seed." in
+      let headers =
+        [
+          ("content-length", string_of_int (String.length contents));
+          ("content-type", "text/plain");
+        ]
+      in
+      let headers =
+        match version with
+        | `HTTP_1_1 -> ("connection", "close") :: headers
+        | `HTTP_2_0 -> headers
+      in
+      let response = create headers `Bad_request in
+      (response, contents)
+
+module Cache = Ephemeron.K1.Make (struct
+  type t = string option * string option
+
+  let equal = ( = )
+  let hash = Hashtbl.hash
+end)
+
+module type S = sig
+  type response
+  type request
+
+  val version : [ `HTTP_1_1 | `HTTP_2_0 ]
+  val create : (string * string) list -> H2.Status.t -> response
+  val with_etag : string -> response -> response
+  val with_status : H2.Status.t -> response -> response
+  val get : request -> string -> string option
+end
+
+let hash_of_seed : type response request.
+    (module S with type response = response and type request = request) ->
+    respond:(response -> string -> unit) ->
+    request ->
+    unit =
+ fun (module S) ->
+  ();
+  let tbl = Cache.create 0x100 in
+  fun ~respond request ->
+    let seed = S.get request "x-seed" and length = S.get request "x-length" in
+
+    match
+      (Cache.find_opt tbl (seed, length), S.get request "if-none-match")
+    with
+    | None, _ | Some _, None ->
+        let response, contents =
+          hash ~version:S.version ~create:S.create ?seed length
+        in
+        Cache.add tbl (seed, length) (response, contents);
+        respond response contents
+    | Some (response, contents), Some etags ->
+        let hash = Digestif.SHA256.digest_string contents in
+        let hash = Digestif.SHA256.to_hex hash in
+
+        if List.mem hash (String.split_on_char ',' etags) then
+          let response =
+            S.with_etag hash (S.with_status `Not_modified response)
+          in
+          respond response String.empty
+        else respond response contents
+
+let transmit_over_http : to_close:_ -> Mimic.flow -> Mimic.flow -> unit Lwt.t =
+ fun ~to_close src dst ->
+  let open Lwt.Infix in
+  let closed = Lwt_mvar.create_empty () in
+  let rec loop ~src ~dst () =
+    Lwt.pick
+      [
+        Lwt_result.Infix.(
+          Mimic.read src >|= fun v -> (v :> [ `Closed | _ Mirage_flow.or_eof ]));
+        (Lwt_mvar.take closed >|= fun v -> Ok v);
+      ]
+    >>= function
+    | Error err ->
+        Log.err (fun m ->
+            m "Got an error while we reading the source (CONNECT): %a."
+              Mimic.pp_error err);
+        if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed
+        else Lwt.return_unit
+    | Ok `Closed -> Lwt.return_unit
+    | Ok `Eof ->
+        if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed
+        else Lwt.return_unit
+    | Ok (`Data cs) -> (
+        Log.debug (fun m -> m "Transfer over HTTP:");
+        Log.debug (fun m ->
+            m "@[<hov>%a@]." (Hxd_string.pp Hxd.default) (Cstruct.to_string cs));
+        Mimic.write dst cs >>= function
+        | Ok () -> Lwt.pause () >>= loop ~src ~dst
+        | Error err ->
+            Log.err (fun m ->
+                m
+                  "Got an error while we writing into the destination \
+                   (CONNECT): %a."
+                  Mimic.pp_write_error err);
+            if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed
+            else Lwt.return_unit)
+  in
+  Lwt.join [ loop ~src ~dst (); loop ~src:dst ~dst:src () ] >>= fun () ->
+  to_close src;
+  Lwt.join [ Mimic.close src; Mimic.close dst ] >>= fun () ->
+  Log.debug (fun m -> m "Connection closed properly on both side.");
+  Lwt.return_unit
+
+(***** HTTP/1.1 *****)
+
+module S_HTTP_1_1 = struct
+  type request = H1.Request.t
+  type response = H1.Response.t
+
+  let version = `HTTP_1_1
+  let get request name = H1.Headers.get request.H1.Request.headers name
+
+  let create headers = function
+    | #H1.Status.t as status ->
+        H1.Response.create ~headers:(H1.Headers.of_list headers) status
+    | _ -> assert false
+
+  let with_etag etag response =
+    let headers = response.H1.Response.headers in
+    { response with H1.Response.headers= H1.Headers.add headers "etag" etag }
+
+  let with_status (status : H2.Status.t) response =
+    match status with
+    | #H1.Status.t as status -> { response with H1.Response.status }
+    | _ -> assert false
+end
+
+let transmit src dst =
+  let rec on_eof () = H1.Body.Reader.close src; H1.Body.Writer.close dst
+  and on_read buf ~off ~len =
+    H1.Body.Writer.write_bigstring dst ~off ~len buf;
+    H1.Body.Reader.schedule_read src ~on_eof ~on_read
+  in
+  H1.Body.Reader.schedule_read src ~on_eof ~on_read
+
+let connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd =
+  let request = H1.Reqd.request reqd in
+  match H1.Headers.get request.H1.Request.headers "host" with
+  | Some uri ->
+      let uri = "http://" ^ uri in
+      let open Lwt.Infix in
+      Lwt.async (fun () ->
+          Connect.create_connection ~ctx ~authenticator uri >>= function
+          | Ok dst ->
+              let headers = H1.Headers.of_list [ ("connection", "close") ] in
+              let response =
+                H1.Response.create ~reason:"CONNECT" ~headers `OK
+              in
+              H1.Reqd.respond_with_string reqd response "";
+              H1.Body.Reader.close (H1.Reqd.request_body reqd);
+              transmit_over_http ~to_close flow dst
+          | Error err ->
+              Log.err (fun m ->
+                  m "Got an error while connection to %S: %a." uri
+                    Mimic.pp_error err);
+              let contents = Fmt.str "Invalid URI: %S" uri in
+              let headers =
+                H1.Headers.of_list
+                  [
+                    ("content-length", string_of_int (String.length contents));
+                    ("connection", "close"); ("content-type", "text/plain");
+                  ]
+              in
+              let response =
+                H1.Response.create ~reason:"CONNECT" ~headers `Bad_request
+              in
+              H1.Reqd.respond_with_string reqd response contents;
+              Lwt.return_unit)
+  | None ->
+      let contents = "Missing Host field." in
+      let headers =
+        H1.Headers.of_list
+          [
+            ("content-length", string_of_int (String.length contents));
+            ("connection", "close"); ("content-type", "text/plain");
+          ]
+      in
+      let response =
+        H1.Response.create ~reason:"CONNECT" ~headers `Bad_request
+      in
+      H1.Reqd.respond_with_string reqd response contents
+
+let http_1_1_request_handler ~ctx ~authenticator ~to_close =
+  let hash_of_seed = hash_of_seed (module S_HTTP_1_1) in
+  fun flow reqd ->
+    let request = H1.Reqd.request reqd in
+    Log.debug (fun m ->
+        m "(HTTP/1.1) request-handler: %S" request.H1.Request.target);
+    match request.H1.Request.meth with
+    | `CONNECT ->
+        Log.debug (fun m -> m "Start to transmit data over HTTP/1.1.");
+        connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd
+    | _meth -> (
+        match String.split_on_char '/' request.H1.Request.target with
+        | [ ""; "" ] ->
+            let headers =
+              H1.Headers.of_list
+                [
+                  ("content-length", string_of_int (String.length root));
+                  ("connection", "close"); ("content-type", "text/plain");
+                ]
+            in
+            let response = H1.Response.create ~reason:"root" ~headers `OK in
+            H1.Reqd.respond_with_string reqd response root
+        | [ ""; "transmit" ] ->
+            let content_type =
+              H1.Headers.get request.H1.Request.headers "content-type"
+            in
+            let content_type =
+              Option.value ~default:"application/octet-stream" content_type
+            in
+            let headers =
+              H1.Headers.of_list
+                [
+                  ("transfer-encoding", "chunked");
+                  ("content-type", content_type);
+                ]
+            in
+            let response = H1.Response.create ~reason:"transmit" ~headers `OK in
+            let src = H1.Reqd.request_body reqd in
+            let dst = H1.Reqd.respond_with_streaming reqd response in
+            transmit src dst
+        | [ ""; "hash" ] ->
+            let respond response contents =
+              H1.Reqd.respond_with_string reqd response contents
+            in
+            hash_of_seed ~respond request
+        | [ ""; "random" ] -> (
+            match H1.Headers.get request.H1.Request.headers "x-length" with
+            | Some v when String.for_all is_digit v ->
+                let length = Int64.of_string v in
+                let g =
+                  Option.bind
+                    (H1.Headers.get request.H1.Request.headers "x-seed")
+                    random_state_of_seed
+                in
+                let headers =
+                  H1.Headers.of_list
+                    [
+                      ("content-type", "text/plain");
+                      ("transfer-encoding", "chunked");
+                    ]
+                in
+                let response =
+                  H1.Response.create ~reason:"random" ~headers `OK
+                in
+                let body = H1.Reqd.respond_with_streaming reqd response in
+                transmit_random
+                  ~write_string:(fun body str ->
+                    H1.Body.Writer.write_string body str)
+                  ~flush:H1.Body.Writer.flush ~close_writer:H1.Body.Writer.close
+                  ?g length body
+            | _ ->
+                let contents = "Invalid length." in
+                let headers =
+                  H1.Headers.of_list
+                    [
+                      ("content-length", string_of_int (String.length contents));
+                      ("connection", "close"); ("content-type", "text/plain");
+                    ]
+                in
+                let response =
+                  H1.Response.create ~reason:"random" ~headers `Bad_request
+                in
+                H1.Reqd.respond_with_string reqd response contents)
+        | _ ->
+            let contents = "Not found." in
+            let headers =
+              H1.Headers.of_list
+                [
+                  ("content-type", "text/plain"); ("connection", "close");
+                  ("content-length", string_of_int (String.length contents));
+                ]
+            in
+            let response =
+              H1.Response.create ~reason:"not-found" ~headers `Not_found
+            in
+            H1.Reqd.respond_with_string reqd response contents)
+
+(***** H2 *****)
+
+module S_HTTP_2_0 = struct
+  type request = H2.Request.t
+  type response = H2.Response.t
+
+  let version = `HTTP_2_0
+  let get request name = H2.Headers.get request.H2.Request.headers name
+
+  let create headers status =
+    H2.Response.create ~headers:(H2.Headers.of_list headers) status
+
+  let with_etag etag response =
+    let headers = response.H2.Response.headers in
+    { response with H2.Response.headers= H2.Headers.add headers "etag" etag }
+
+  let with_status status response = { response with H2.Response.status }
+end
+
+let transmit src dst =
+  let rec on_eof () = H2.Body.Reader.close src; H2.Body.Writer.close dst
+  and on_read buf ~off ~len =
+    H2.Body.Writer.write_bigstring dst ~off ~len buf;
+    H2.Body.Reader.schedule_read src ~on_eof ~on_read
+  in
+  H2.Body.Reader.schedule_read src ~on_eof ~on_read
+
+let connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd =
+  let request = H2.Reqd.request reqd in
+  match H2.Headers.get request.H2.Request.headers "host" with
+  | Some uri ->
+      let uri = "http://" ^ uri in
+      let open Lwt.Infix in
+      Lwt.async (fun () ->
+          Connect.create_connection ~ctx ~authenticator uri >>= function
+          | Ok dst ->
+              let response = H2.Response.create `OK in
+              H2.Reqd.respond_with_string reqd response "";
+              H2.Body.Reader.close (H2.Reqd.request_body reqd);
+              transmit_over_http ~to_close flow dst
+          | Error err ->
+              Log.err (fun m ->
+                  m "Got an error while connection to %S: %a." uri
+                    Mimic.pp_error err);
+              let contents = Fmt.str "Invalid URI: %S" uri in
+              let headers =
+                H2.Headers.of_list
+                  [
+                    ("content-length", string_of_int (String.length contents));
+                    ("content-type", "text/plain");
+                  ]
+              in
+              let response = H2.Response.create ~headers `Bad_request in
+              H2.Reqd.respond_with_string reqd response contents;
+              Lwt.return_unit)
+  | None ->
+      let contents = "Missing Host field." in
+      let headers =
+        H2.Headers.of_list
+          [
+            ("content-length", string_of_int (String.length contents));
+            ("content-type", "text/plain");
+          ]
+      in
+      let response = H2.Response.create ~headers `Bad_request in
+      H2.Reqd.respond_with_string reqd response contents
+
+let http_2_0_request_handler ~ctx ~authenticator ~to_close =
+  let hash_of_seed = hash_of_seed (module S_HTTP_2_0) in
+  fun flow reqd ->
+    let request = H2.Reqd.request reqd in
+    Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target);
+    match request.H2.Request.meth with
+    | `CONNECT ->
+        Log.debug (fun m -> m "Start to transmit data over H2.");
+        connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd
+    | _meth -> (
+        match String.split_on_char '/' request.H2.Request.target with
+        | [ ""; "" ] ->
+            let headers =
+              H2.Headers.of_list
+                [
+                  ("content-length", string_of_int (String.length root));
+                  ("content-type", "text/plain");
+                ]
+            in
+            let response = H2.Response.create ~headers `OK in
+            H2.Reqd.respond_with_string reqd response root
+        | [ ""; "transmit" ] ->
+            let content_type =
+              H2.Headers.get request.H2.Request.headers "content-type"
+            in
+            let content_type =
+              Option.value ~default:"application/octet-stream" content_type
+            in
+            let headers =
+              H2.Headers.of_list [ ("content-type", content_type) ]
+            in
+            let response = H2.Response.create ~headers `OK in
+            let src = H2.Reqd.request_body reqd in
+            let dst = H2.Reqd.respond_with_streaming reqd response in
+            transmit src dst
+        | [ ""; "hash" ] ->
+            let respond response contents =
+              H2.Reqd.respond_with_string reqd response contents
+            in
+            hash_of_seed ~respond request
+        | [ ""; "random" ] -> (
+            match H2.Headers.get request.H2.Request.headers "x-length" with
+            | Some v when String.for_all is_digit v ->
+                let length = Int64.of_string v in
+                let g =
+                  Option.bind
+                    (H2.Headers.get request.H2.Request.headers "x-seed")
+                    random_state_of_seed
+                in
+                let headers =
+                  H2.Headers.of_list [ ("content-type", "text/plain") ]
+                in
+                let response = H2.Response.create ~headers `OK in
+                let body = H2.Reqd.respond_with_streaming reqd response in
+                let flush body next =
+                  H2.Body.Writer.flush body (fun _reason -> next ())
+                in
+                transmit_random
+                  ~write_string:(fun body str ->
+                    H2.Body.Writer.write_string body str)
+                  ~flush ~close_writer:H2.Body.Writer.close ?g length body
+            | _ ->
+                let contents = "Invalid length." in
+                let headers =
+                  H2.Headers.of_list
+                    [
+                      ("content-length", string_of_int (String.length contents));
+                      ("content-type", "text/plain");
+                    ]
+                in
+                let response = H2.Response.create ~headers `Bad_request in
+                H2.Reqd.respond_with_string reqd response contents)
+        | _ ->
+            let contents = "Not found." in
+            let headers =
+              H2.Headers.of_list
+                [
+                  ("content-type", "text/plain");
+                  ("content-length", string_of_int (String.length contents));
+                ]
+            in
+            let response = H2.Response.create ~headers `Not_found in
+            H2.Reqd.respond_with_string reqd response contents)
+
+let alpn_request_handler : type reqd headers request response ro wo.
+    ctx:_ ->
+    authenticator:_ ->
+    to_close:_ ->
+    ?shutdown:_ ->
+    _ ->
+    _ ->
+    reqd ->
+    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
+    unit =
+ fun ~ctx ~authenticator ~to_close ?shutdown:_ flow _edn reqd -> function
+  | Alpn.HTTP_1_1 _ ->
+      http_1_1_request_handler ~ctx ~authenticator ~to_close flow reqd
+  | Alpn.H2 _ ->
+      http_2_0_request_handler ~ctx ~authenticator ~to_close flow reqd
+
+let headers_of_list : type reqd headers request response ro wo.
+    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
+    (string * string) list ->
+    headers =
+ fun protocol lst ->
+  match protocol with
+  | Alpn.HTTP_1_1 _ -> H1.Headers.of_list lst
+  | Alpn.H2 _ -> H2.Headers.of_list lst
+
+let respond_with_string : type reqd headers request response ro wo.
+    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
+    headers:headers ->
+    respond:(headers -> wo) ->
+    string ->
+    unit =
+ fun protocol ~headers ~respond str ->
+  let body = respond headers in
+  match protocol with
+  | Alpn.HTTP_1_1 _ ->
+      H1.Body.Writer.write_string body str;
+      H1.Body.Writer.close body
+  | Alpn.H2 _ ->
+      H2.Body.Writer.write_string body str;
+      H2.Body.Writer.close body
+
+let alpn_error_handler : type reqd headers request response ro wo.
+    _ ->
+    (reqd, headers, request, response, ro, wo) Alpn.protocol ->
+    ?request:_ ->
+    _ ->
+    (headers -> wo) ->
+    unit =
+ fun _edn protocol ?request:_ error respond ->
+  let contents =
+    match error with
+    | `Bad_gateway -> {plain|Bad gateway.|plain}
+    | `Bad_request -> {plain|Bad request.|plain}
+    | `Exn (Paf.Flow err) | `Exn (Paf.Flow_write err) ->
+        Fmt.str {plain|I/O error: %s.|plain} err
+    | `Exn exn ->
+        Fmt.str {plain|Unknown error: %S.|plain} (Printexc.to_string exn)
+    | `Internal_server_error -> {plain|Internal server error.|plain}
+  in
+  let headers =
+    headers_of_list protocol
+      [
+        ("content-type", "text/plain");
+        ("content-length", string_of_int (String.length contents));
+      ]
+  in
+  respond_with_string protocol ~respond ~headers contents
+
+let http_1_1_error_handler edn ?request error respond =
+  alpn_error_handler edn ?request Alpn.http_1_1
+    (error :> Alpn.server_error)
+    respond
+
+let http_2_0_error_handler edn ?request error respond =
+  alpn_error_handler edn ?request Alpn.h2 (error :> Alpn.server_error) respond

unikernel/unikernel.ml

@@ -1,11 +1,10 @@
 open Rresult
 open Lwt.Infix
 open Cmdliner
-open Mte
 
 let port =
   let doc = Arg.info ~doc:"Port of HTTP service." [ "p"; "port" ] in
-  Arg.(value & opt int 8080 doc)
+  Arg.(value & opt int 3434 doc)
 
 let use_tls =
   let doc =