diff --git a/unikernel/server.ml b/unikernel/server.ml index f51c6652..19a8da65 100644 --- a/unikernel/server.ml +++ b/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 = - {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 "@[%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 "@[%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) +let root = {|Hello! + This is MTE, the MirageOS Taler Exchange unikernel. +|} 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,101 +141,39 @@ 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 -> - 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) + 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 + | _ -> + 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 *****) @@ -492,88 +243,36 @@ 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); - 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) + 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 + | _ -> + 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:_ -> @@ -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_request -> {plain|Bad request.|plain} + | `Bad_gateway -> {|Bad gateway.|} + | `Bad_request -> {|Bad request.|} | `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} + Fmt.str {|I/O error: %s.|} err + | `Exn exn -> Fmt.str {|Unknown error: %S.|} (Printexc.to_string exn) + | `Internal_server_error -> {|Internal server error.|} in let headers = headers_of_list protocol