wip server.ml

unikernel/server.ml

@@ -6,157 +6,9 @@ module Log = (val Logs.src_log src : Logs.LOG)
 
 let is_digit = function '0' .. '9' -> true | _ -> false
 
-let root =
+let root = {|Hello!
-  {plain|Hello fellows!
+  This is MTE, the MirageOS Taler Exchange unikernel.
-
+|}
-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
@@ -169,37 +21,6 @@ module type S = sig
   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
@@ -272,14 +93,6 @@ module S_HTTP_1_1 = struct
     | _ -> 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
@@ -328,7 +141,6 @@ let connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd =
       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 ->
@@ -349,67 +161,6 @@ let http_1_1_request_handler ~ctx ~authenticator ~to_close =
           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 =
@@ -492,7 +243,6 @@ let connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd =
       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);
@@ -512,57 +262,6 @@ let http_2_0_request_handler ~ctx ~authenticator ~to_close =
           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 =
@@ -626,13 +325,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