From b30366305093510d98cb05f38d5928572c6730d6 Mon Sep 17 00:00:00 2001 From: swrup Date: Wed, 5 Nov 2025 19:41:38 +0100 Subject: [PATCH] clean up skeleton --- src/dune | 2 +- src/mte.ml | 42 ++- unikernel/config.ml | 22 +- unikernel/connect.ml | 164 ----------- unikernel/server.ml | 623 +++-------------------------------------- unikernel/unikernel.ml | 52 +--- 6 files changed, 95 insertions(+), 810 deletions(-) delete mode 100644 unikernel/connect.ml diff --git a/src/dune b/src/dune index 5bbd0b24..c9a63a75 100644 --- a/src/dune +++ b/src/dune @@ -1,4 +1,4 @@ (library (name mte) (wrapped false) - (libraries logs)) + (libraries logs h1 h2)) diff --git a/src/mte.ml b/src/mte.ml index 06ce6388..49d5cdd4 100644 --- a/src/mte.ml +++ b/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 } diff --git a/unikernel/config.ml b/unikernel/config.ml index 687154f2..5051bfcb 100644 --- a/unikernel/config.ml +++ b/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) - -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) + (kv_ro @-> kv_ro @-> kv_ro @-> tcpv4v6 @-> http_server @-> job) 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" - [ mte $ assets $ certificates $ keys $ tcpv4v6 $ conn $ http_server ] + register "mte" [ mte $ assets $ certificates $ keys $ tcpv4v6 $ http_server ] diff --git a/unikernel/connect.ml b/unikernel/connect.ml deleted file mode 100644 index 6bab28b3..00000000 --- a/unikernel/connect.ml +++ /dev/null @@ -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 diff --git a/unikernel/server.ml b/unikernel/server.ml index f51c6652..415c1757 100644 --- a/unikernel/server.ml +++ b/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 = - {plain|Hello fellows! +let request_from_h2 { H2.Request.meth; target; scheme; headers } = + Mte.{ meth; target; scheme; headers } -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) - -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 "@[%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 http_1_1_request_handler 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 - Lwt.async (fun () -> - 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 + Log.debug (fun m -> + m "(HTTP/1.1) request-handler: %S" request.H1.Request.target); + let Mte.{ status; headers; content } = + Mte.request_handler (request_from_h1 ~scheme:"http" request) 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 - | Some uri -> - let uri = "http://" ^ uri in - Lwt.async (fun () -> - let* res = Connect.create_connection ~ctx ~authenticator uri in - match res with - | 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) + Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target); + let Mte.{ status; headers; content } = + Mte.request_handler (request_from_h2 request) + in + let response = H2.Response.create ~headers status in + H2.Reqd.respond_with_string reqd response content 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 + reqd -> (reqd, headers, request, response, ro, wo) Alpn.protocol -> unit = + fun reqd -> function + | Alpn.HTTP_1_1 _ -> http_1_1_request_handler reqd + | Alpn.H2 _ -> http_2_0_request_handler 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_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 diff --git a/unikernel/unikernel.ml b/unikernel/unikernel.ml index 4a33bdfe..b4df85c3 100644 --- a/unikernel/unikernel.ml +++ b/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 module R = (val Mimic.repr HTTP_server.tcp_protocol) in - 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 http_1_1_request_handler _flow _edn reqd = + Server.http_1_1_request_handler reqd - let alpn_handler ~ctx ~authenticator = - 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 + let alpn_handler = { Alpn.error= Server.alpn_error_handler; Alpn.request= - (fun flow edn reqd protocol -> - Server.alpn_request_handler ~ctx ~authenticator ~to_close (R.T flow) - edn reqd protocol); + (fun _flow _edn reqd protocol -> + Server.alpn_request_handler reqd protocol); } - let run_with_tls ~ctx ~authenticator ~tls http_server tls_port tcpv4v6 = - let alpn_service = - HTTP_server.alpn_service ~tls (alpn_handler ~ctx ~authenticator) - in + let run_with_tls ~tls http_server tls_port tcpv4v6 = + let alpn_service = HTTP_server.alpn_service ~tls alpn_handler 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 -> - run_with_tls ~ctx ~authenticator ~tls http_server - (tls_port ()) tcpv4v6))) + | Ok tls -> run_with_tls ~tls http_server (tls_port ()) tcpv4v6) + )) end