clean up skeleton

src/dune

@@ -1,4 +1,4 @@
 (library
  (name mte)
  (wrapped false)
- (libraries logs))
+ (libraries logs h1 h2))

src/mte.ml

@@ -1 +1,41 @@
-let uuu = "uuu"
+module Method = H2.Method
+module Headers = H2.Headers
+module Status = H2.Status
+
+type request = {
+  meth: Method.t;
+  target: string;
+  scheme: string;
+  headers: Headers.t;
+}
+
+type response = {
+  status: Status.t;
+  headers: Headers.t;
+  content: string;
+}
+
+let home_page_text =
+  "Hello!\n\nThis is MTE, the MirageOS Taler Exchange unikernel."
+
+let request_handler request =
+  match String.split_on_char '/' request.target with
+  | [ ""; "" ] ->
+      let headers =
+        Headers.of_list
+          [
+            ("content-length", string_of_int (String.length home_page_text));
+            ("connection", "close"); ("content-type", "text/plain");
+          ]
+      in
+      { status= `OK; headers; content= home_page_text }
+  | _ ->
+      let content = "Not found." in
+      let headers =
+        Headers.of_list
+          [
+            ("content-length", string_of_int (String.length content));
+            ("connection", "close"); ("content-type", "text/plain");
+          ]
+      in
+      { status= `Not_found; headers; content }

unikernel/config.ml

@@ -1,10 +1,6 @@
 (* mirage >= 4.9.0 & < 4.11.0 *)
 open Mirage
 
-type conn = Connect
-
-let conn = typ Connect
-
 let mte =
   main "Unikernel.Make" ~local_libs:[ "mte" ]
     ~packages:
@@ -13,15 +9,7 @@ let mte =
         package "hxd" ~sublibs:[ "core"; "string" ]; package "rresult";
         package "h2" ~min:"0.13.0"; package "base64" ~sublibs:[ "rfc2045" ];
       ]
-    (kv_ro @-> kv_ro @-> kv_ro @-> tcpv4v6 @-> conn @-> http_server @-> job)
+    (kv_ro @-> kv_ro @-> kv_ro @-> tcpv4v6 @-> http_server @-> job)
-
-let conn =
-  let connect _ modname = function
-    | [ _tcpv4v6; ctx ] ->
-        code ~pos:__POS__ {ocaml|%s.connect %s|ocaml} modname ctx
-    | _ -> assert false
-  in
-  impl ~connect "Connect.Make" (tcpv4v6 @-> mimic @-> conn)
 
 let stackv4v6 = generic_stackv4v6 default_network
 let tcpv4v6 = tcpv4v6_of_stackv4v6 stackv4v6
@@ -30,14 +18,8 @@ let dns = generic_dns_client stackv4v6 he
 let certificates = crunch "../data/tls/certificates"
 let keys = crunch "../data/tls/keys"
 let assets = crunch "../data/assets"
-
-let conn =
-  let happy_eyeballs = mimic_happy_eyeballs stackv4v6 he dns in
-  conn $ tcpv4v6 $ happy_eyeballs
-
 let port = Runtime_arg.create ~pos:__POS__ "Unikernel.port"
 let http_server = paf_server ~port tcpv4v6
 
 let () =
-  register "mte"
+  register "mte" [ mte $ assets $ certificates $ keys $ tcpv4v6 $ http_server ]
-    [ mte $ assets $ certificates $ keys $ tcpv4v6 $ conn $ http_server ]

unikernel/connect.ml

@@ -1,164 +0,0 @@
-open Syntax
-
-module type S = sig
-  val connect : Mimic.ctx -> Mimic.ctx Lwt.t
-  val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result
-end
-
-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 =
-      write flow cs |> Lwt_result.map_error (fun err -> `Write err)
-
-    let writev flow css =
-      writev flow css |> Lwt_result.map_error (fun err -> `Write err)
-
-    let connect (happy_eyeballs, hostname, port) =
-      let+ res = Happy_eyeballs.resolve happy_eyeballs hostname [ port ] in
-      match res with
-      | Error (`Msg err) -> Error (`Connect err)
-      | Ok ((_ipaddr, _port), flow) -> 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
-      let* res = Happy_eyeballs.resolve happy_eyeballs hostname [ port ] in
-      match res with
-      | Error (`Msg err) -> Lwt.return_error (`Write (`Connect err))
-      | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
-  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 ( let* ) = Result.bind in
-  match String.split_on_char '/' uri with
-  | proto :: "" :: user_pass_host_port :: _path ->
-      let* _scheme, ctx =
-        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")
-      in
-      let* _user_pass, host_port =
-        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")
-      in
-      let* hostname, ctx =
-        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"))
-      in
-      Ok (ctx, hostname)
-  | _ -> Error (`Msg "Couldn't decode URI on top")
-
-let tls_config ?tls_config authenticator =
-  let ( let* ) = Result.bind in
-  lazy
-    (match tls_config with
-    | Some cfg -> Ok (`Custom cfg)
-    | None ->
-        let alpn_protocols = [ "h2"; "http/1.1" ] 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*? ctx, host = Lwt.return (decode_uri ~ctx uri) in
-  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

@@ -1,595 +1,47 @@
-open Syntax
-
 let src = Logs.Src.create "server"
 
 module Log = (val Logs.src_log src : Logs.LOG)
+module Method = Mte.Method
+module Headers = Mte.Headers
+module Status = Mte.Status
 
-let is_digit = function '0' .. '9' -> true | _ -> false
+let request_from_h1 ~scheme { H1.Request.meth; target; headers; _ } =
+  let headers = Mte.Headers.of_list (H1.Headers.to_list headers) in
+  Mte.{ meth; target; scheme; headers }
 
-let root =
+let request_from_h2 { H2.Request.meth; target; scheme; headers } =
-  {plain|Hello fellows!
+  Mte.{ meth; target; scheme; headers }
 
-This unikernel is a simple example of a website that supports HTTP/1.1, H2 and
+let http_1_1_request_handler reqd =
-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 closed = Lwt_mvar.create_empty () in
-  let rec loop ~src ~dst () =
-    let* res =
-      Lwt.pick
-        [
-          (let+? v = Mimic.read src in
-           (v :> [ `Closed | _ Mirage_flow.or_eof ]));
-          (let+ v = Lwt_mvar.take closed in
-           Ok v);
-        ]
-    in
-    match res with
-    | 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));
-        let* res = Mimic.write dst cs in
-        match res with
-        | Ok () ->
-            let* () = Lwt.pause () in
-            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
-  let* () = Lwt.join [ loop ~src ~dst (); loop ~src:dst ~dst:src () ] in
-  to_close src;
-  let* () = Lwt.join [ Mimic.close src; Mimic.close dst ] in
-  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
+  Log.debug (fun m ->
-  | Some uri ->
+      m "(HTTP/1.1) request-handler: %S" request.H1.Request.target);
-      let uri = "http://" ^ uri in
+  let Mte.{ status; headers; content } =
-      Lwt.async (fun () ->
+    Mte.request_handler (request_from_h1 ~scheme:"http" request)
-          let* res = Connect.create_connection ~ctx ~authenticator uri in
-          match res with
-          | 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 status =
+    match status with
+    | #H1.Status.t as status -> status
+    | _ -> Fmt.failwith "H2 status response on a H1 request"
+  in
+  let headers = H1.Headers.of_list (Headers.to_list headers) in
+  let response = H1.Response.create ~headers status in
+  H1.Reqd.respond_with_string reqd response content
 
-let connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd =
+let http_2_0_request_handler reqd =
   let request = H2.Reqd.request reqd in
-  match H2.Headers.get request.H2.Request.headers "host" with
+  Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target);
-  | Some uri ->
+  let Mte.{ status; headers; content } =
-      let uri = "http://" ^ uri in
+    Mte.request_handler (request_from_h2 request)
-      Lwt.async (fun () ->
+  in
-          let* res = Connect.create_connection ~ctx ~authenticator uri in
+  let response = H2.Response.create ~headers status in
-          match res with
+  H2.Reqd.respond_with_string reqd response content
-          | 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:_ ->
+    reqd -> (reqd, headers, request, response, ro, wo) Alpn.protocol -> unit =
-    authenticator:_ ->
+ fun reqd -> function
-    to_close:_ ->
+  | Alpn.HTTP_1_1 _ -> http_1_1_request_handler reqd
-    ?shutdown:_ ->
+  | Alpn.H2 _ -> http_2_0_request_handler reqd
-    _ ->
-    _ ->
-    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 ->
@@ -626,13 +78,12 @@ let alpn_error_handler : type reqd headers request response ro wo.
  fun _edn protocol ?request:_ error respond ->
   let contents =
     match error with
-    | `Bad_gateway -> {plain|Bad gateway.|plain}
+    | `Bad_gateway -> {|Bad gateway.|}
-    | `Bad_request -> {plain|Bad request.|plain}
+    | `Bad_request -> {|Bad request.|}
     | `Exn (Paf.Flow err) | `Exn (Paf.Flow_write err) ->
-        Fmt.str {plain|I/O error: %s.|plain} err
+        Fmt.str {|I/O error: %s.|} err
-    | `Exn exn ->
+    | `Exn exn -> Fmt.str {|Unknown error: %S.|} (Printexc.to_string exn)
-        Fmt.str {plain|Unknown error: %S.|plain} (Printexc.to_string exn)
+    | `Internal_server_error -> {|Internal server error.|}
-    | `Internal_server_error -> {plain|Internal server error.|plain}
   in
   let headers =
     headers_of_list protocol

unikernel/unikernel.ml

@@ -34,7 +34,6 @@ module Make
     (Certificates_ro : Mirage_kv.RO)
     (Keys_ro : Mirage_kv.RO)
     (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t)
-    (Connect : Connect.S)
     (HTTP_server : Paf_mirage.S) =
 struct
   module Assets = struct
@@ -200,43 +199,22 @@ struct
 
   let always x _ = x
 
-  let http_1_1_request_handler ~ctx ~authenticator flow _edn =
+  let http_1_1_request_handler _flow _edn reqd =
-    let module R = (val Mimic.repr HTTP_server.tcp_protocol) in
+    Server.http_1_1_request_handler reqd
-    fun reqd ->
-      match (H1.Reqd.request reqd).H1.Request.meth with
-      | `CONNECT ->
-          HTTP_server.TCP.no_close flow;
-          let to_close = function
-            | R.T flow -> HTTP_server.TCP.to_close flow
-            | _ -> ()
-          in
-          Server.http_1_1_request_handler ~ctx ~authenticator ~to_close
-            (R.T flow) reqd
-      | _ ->
-          Server.http_1_1_request_handler ~ctx ~authenticator
-            ~to_close:(always ()) (R.T flow) reqd
 
-  let alpn_handler ~ctx ~authenticator =
+  let alpn_handler =
-    let module R = (val Mimic.repr HTTP_server.tls_protocol) in
-    let to_close = function
-      | R.T flow -> HTTP_server.TLS.to_close flow
-      | _ -> ()
-    in
     {
       Alpn.error= Server.alpn_error_handler;
       Alpn.request=
-        (fun flow edn reqd protocol ->
+        (fun _flow _edn reqd protocol ->
-          Server.alpn_request_handler ~ctx ~authenticator ~to_close (R.T flow)
+          Server.alpn_request_handler reqd protocol);
-            edn reqd protocol);
     }
 
-  let run_with_tls ~ctx ~authenticator ~tls http_server tls_port tcpv4v6 =
+  let run_with_tls ~tls http_server tls_port tcpv4v6 =
-    let alpn_service =
+    let alpn_service = HTTP_server.alpn_service ~tls alpn_handler in
-      HTTP_server.alpn_service ~tls (alpn_handler ~ctx ~authenticator)
-    in
     let http_1_1_service =
       HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler
-        (http_1_1_request_handler ~ctx ~authenticator)
+        http_1_1_request_handler
     in
     let open Lwt.Syntax in
     let* server = HTTP_server.init ~port:tls_port tcpv4v6 in
@@ -245,23 +223,22 @@ struct
     let+ (), () = Lwt.both th0 th1 in
     ()
 
-  let run ~ctx ~authenticator http_server =
+  let run http_server =
     let http_1_1_service =
       HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler
-        (http_1_1_request_handler ~ctx ~authenticator)
+        http_1_1_request_handler
     in
     Paf.serve http_1_1_service http_server |> fun (`Initialized th) -> th
 
-  let start assets_ro certificate_ro key_ro tcpv4v6 ctx http_server =
+  let start assets_ro certificate_ro key_ro tcpv4v6 http_server =
     let open Lwt.Syntax in
-    let authenticator = Connect.authenticator in
     let* assets_res = Assets.assets assets_ro in
     match assets_res with
     | Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
     | Ok (_terms_etag, _privacy_etag, _lang_l, _ext_l) -> (
         let* tls_res = tls certificate_ro key_ro in
         match use_tls () with
-        | false -> run ~ctx ~authenticator http_server
+        | false -> run http_server
         | true -> (
             match tls_res with
             | Error (`Msg m) ->
@@ -274,7 +251,6 @@ struct
                 match Tls.Config.server ~certificates ~alpn_protocols () with
                 | Error (`Msg m) ->
                     Fmt.failwith "TLS configuration error: %s." m
-                | Ok tls ->
+                | Ok tls -> run_with_tls ~tls http_server (tls_port ()) tcpv4v6)
-                    run_with_tls ~ctx ~authenticator ~tls http_server
+            ))
-                      (tls_port ()) tcpv4v6)))
 end