From 28474322408412a6cea371f0d5386795ca7cf032 Mon Sep 17 00:00:00 2001 From: swrup Date: Wed, 29 Oct 2025 18:51:46 +0100 Subject: [PATCH] init skeleton --- .gitignore | 8 + certificates/.gitkeep | 0 config.ml | 45 +++ connect.ml | 166 +++++++++++ gen.sh | 5 + keys/.gitkeep | 0 server.ml | 654 ++++++++++++++++++++++++++++++++++++++++++ unikernel.ml | 163 +++++++++++ 8 files changed, 1041 insertions(+) create mode 100644 .gitignore create mode 100644 certificates/.gitkeep create mode 100644 config.ml create mode 100644 connect.ml create mode 100644 gen.sh create mode 100644 keys/.gitkeep create mode 100644 server.ml create mode 100644 unikernel.ml diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..0e6da31d --- /dev/null +++ b/.gitignore @@ -0,0 +1,8 @@ +_build/ +mirage/ +dist/ +dune.build +dune.config +dune-project +dune-workspace +duniverse/ diff --git a/certificates/.gitkeep b/certificates/.gitkeep new file mode 100644 index 00000000..e69de29b diff --git a/config.ml b/config.ml new file mode 100644 index 00000000..f14405ff --- /dev/null +++ b/config.ml @@ -0,0 +1,45 @@ +(* mirage >= 4.9.0 & < 4.11.0 *) +open Mirage + +type conn = Connect + +let conn = typ Connect + +let minipaf = + main "Unikernel.Make" + ~packages: + [ + package "digestif"; + package ~min:"0.0.9" "mimic-happy-eyeballs"; + package "hxd" ~sublibs:[ "core"; "string" ]; + package "rresult"; + package "h2" ~min:"0.13.0"; + package "base64" ~sublibs:[ "rfc2045" ]; + ] + (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) + +let stackv4v6 = generic_stackv4v6 default_network +let tcpv4v6 = tcpv4v6_of_stackv4v6 stackv4v6 +let he = generic_happy_eyeballs stackv4v6 +let dns = generic_dns_client stackv4v6 he +let certificates = crunch "certificates" +let keys = crunch "keys" + +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 "minipaf" + [ minipaf $ certificates $ keys $ tcpv4v6 $ conn $ http_server ] diff --git a/connect.ml b/connect.ml new file mode 100644 index 00000000..b36472fd --- /dev/null +++ b/connect.ml @@ -0,0 +1,166 @@ +module type S = sig + val connect : Mimic.ctx -> Mimic.ctx Lwt.t + val authenticator : (X509.Authenticator.t, [> `Msg of string ]) result +end + +open Lwt.Infix + +let connect_scheme = Mimic.make ~name:"connect-scheme" +let connect_port = Mimic.make ~name:"connect-port" +let connect_hostname = Mimic.make ~name:"connect-hostname" +let connect_tls_config = Mimic.make ~name:"connect-tls-config" + +module Make + (TCP : Tcpip.Tcp.S) + (Happy_eyeballs : Mimic_happy_eyeballs.S with type flow = TCP.flow) : S = +struct + module TCP = struct + include TCP + + type endpoint = Happy_eyeballs.t * string * int + + type nonrec write_error = + [ `Write of write_error | `Connect of string | `Closed ] + + let pp_write_error ppf = function + | `Connect err -> Fmt.string ppf err + | `Write err -> pp_write_error ppf err + | `Closed as err -> pp_write_error ppf err + + let write flow cs = + let open Lwt.Infix in + write flow cs >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let writev flow css = + writev flow css >>= function + | Ok _ as v -> Lwt.return v + | Error err -> Lwt.return_error (`Write err) + + let connect (happy_eyeballs, hostname, port) = + Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function + | Error (`Msg err) -> Lwt.return_error (`Connect err) + | Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow + end + + let tcp_edn, _tcp_protocol = Mimic.register ~name:"tcp" (module TCP) + + module TLS = struct + type endpoint = Happy_eyeballs.t * Tls.Config.client * string * int + + include Tls_mirage.Make (TCP) + + let connect (happy_eyeballs, cfg, hostname, port) = + let peer_name = + Result.( + to_option (bind (Domain_name.of_string hostname) Domain_name.host)) + in + Happy_eyeballs.resolve happy_eyeballs hostname [ port ] >>= function + | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow + | Error (`Msg err) -> Lwt.return_error (`Write (`Connect err)) + end + + let tls_edn, _tls_protocol = Mimic.register ~name:"tls" (module TLS) + + let connect ctx = + let k0 happy_eyeballs connect_scheme connect_hostname connect_port = + match connect_scheme with + | "http" -> + Lwt.return_some (happy_eyeballs, connect_hostname, connect_port) + | _ -> Lwt.return_none + in + let k1 happy_eyeballs connect_scheme connect_hostname connect_port + tls_config = + match connect_scheme with + | "https" -> + Lwt.return_some + (happy_eyeballs, tls_config, connect_hostname, connect_port) + | _ -> Lwt.return_none + in + let ctx = + Mimic.fold tcp_edn + Mimic.Fun. + [ + req Happy_eyeballs.happy_eyeballs; + req connect_scheme; + req connect_hostname; + dft connect_port 80; + ] + ~k:k0 ctx + in + let ctx = + Mimic.fold tls_edn + Mimic.Fun. + [ + req Happy_eyeballs.happy_eyeballs; + req connect_scheme; + req connect_hostname; + dft connect_port 443; + req connect_tls_config; + ] + ~k:k1 ctx + in + Lwt.return ctx + + let authenticator = Ca_certs_nss.authenticator () +end + +let decode_uri ~ctx uri = + let ( >>= ) = Result.bind in + match String.split_on_char '/' uri with + | proto :: "" :: user_pass_host_port :: _path -> + (if String.equal proto "http:" then + Ok ("http", Mimic.add connect_scheme "http" ctx) + else if String.equal proto "https:" then + Ok ("https", Mimic.add connect_scheme "https" ctx) + else Error (`Msg "Couldn't decode user and password")) + >>= fun (_scheme, ctx) -> + (match String.split_on_char '@' user_pass_host_port with + | [ host_port ] -> Ok (None, host_port) + | [ _user_pass; host_port ] -> Ok (None, host_port) + | _ -> Error (`Msg "Couldn't decode URI")) + >>= fun (_user_pass, host_port) -> + (match String.split_on_char ':' host_port with + | [] -> Error (`Msg "Empty host & port") + | [ hostname ] -> Ok (hostname, Mimic.add connect_hostname hostname ctx) + | hd :: tl -> ( + let port, hostname = + match List.rev (hd :: tl) with + | hd :: tl -> (hd, String.concat ":" (List.rev tl)) + | _ -> assert false + in + try + Ok + ( hostname, + Mimic.add connect_hostname hostname + (Mimic.add connect_port (int_of_string port) ctx) ) + with Failure _ -> Error (`Msg "Couldn't decode port"))) + >>= fun (hostname, ctx) -> Ok (ctx, hostname) + | _ -> Error (`Msg "Couldn't decode URI on top") + +let tls_config ?tls_config authenticator = + lazy + (match tls_config with + | Some cfg -> Ok (`Custom cfg) + | None -> + let alpn_protocols = [ "h2"; "http/1.1" ] in + let ( let* ) = Result.bind in + let* authenticator = authenticator in + let* cfg = Tls.Config.client ~alpn_protocols ~authenticator () in + Ok (`Default cfg)) + +let create_connection ?tls_config:cfg ~ctx ~authenticator uri = + let tls_config = tls_config ?tls_config:cfg authenticator in + let open Lwt_result.Infix in + Lwt.return (decode_uri ~ctx uri) >>= fun (ctx, host) -> + let ctx = + match Lazy.force tls_config with + | Ok (`Custom cfg) -> Mimic.add connect_tls_config cfg ctx + | Ok (`Default cfg) -> ( + match Result.bind (Domain_name.of_string host) Domain_name.host with + | Ok peer -> Mimic.add connect_tls_config (Tls.Config.peer cfg peer) ctx + | Error _ -> Mimic.add connect_tls_config cfg ctx) + | Error _ -> ctx + in + Mimic.resolve ctx diff --git a/gen.sh b/gen.sh new file mode 100644 index 00000000..818cc473 --- /dev/null +++ b/gen.sh @@ -0,0 +1,5 @@ +#!/bin/sh + +hostname="${2:-localhost}" + +openssl req -x509 -newkey rsa:4096 -keyout keys/$1 -out certificates/$1 -sha256 -days 365 -subj "/CN=$hostname" -nodes diff --git a/keys/.gitkeep b/keys/.gitkeep new file mode 100644 index 00000000..e69de29b diff --git a/server.ml b/server.ml new file mode 100644 index 00000000..700c6bc4 --- /dev/null +++ b/server.ml @@ -0,0 +1,654 @@ +let src = Logs.Src.create "server" + +module Log = (val Logs.src_log src : Logs.LOG) + +let is_digit = function '0' .. '9' -> true | _ -> false + +let root = + {plain|Hello fellows! + +This unikernel is a simple example of a website that supports HTTP/1.1, H2 and +the TLS security layer. This is an example of how to make a website with +MirageOS. + +The website has several endpoints: +- `http{,s}://$hostname/` the page you are about to read. +- `http{,s}://$hostname/transmit` a page that copies what is sent (no matter + how big it is) +- `http{,s}://$hostname/hash` calculates a hash from a random content + generated by a seed `x-seed` +- `http{,s}://$hostname/random` a page that waits in the request for a size + (`x-length`) and generates a random (optionally seeded by `x-seed`) content + encoded in base64 + +These different endpoints allow performance tests of what MirageOS can offer. +Have fun, and hack it! +|plain} + +let random_cstruct ~g buf len = + for i = 0 to Cstruct.length buf - 1 do + let v = Random.State.bits g land 0xff in + Cstruct.set_uint8 buf i v + done; + Cstruct.sub buf 0 len + +let random_state_of_seed str = + match Base64.decode str with + | Error _ -> None + | Ok seed -> + let res = Array.make (String.length seed / 2) 0 in + for i = 0 to (String.length seed / 2) - 1 do + res.(i) <- + (Char.code seed.[i * 2] lsl 8) lor Char.code seed.[(i * 2) + 1] + done; + Some (Random.State.make res) + +let transmit_random ~write_string ~flush ~close_writer + ?(g = Random.State.make_self_init ()) length body = + let tmp = Bytes.create (0x1000 * 4) in + let rnd = Cstruct.create 0x1000 in + let ctx = Digestif.SHA256.empty in + + let encoder = Base64_rfc2045.encoder `Manual in + + let rec go ctx length cs = function + | `Ok when Cstruct.length cs = 0 -> encode ctx length + | `Ok -> + go ctx length (Cstruct.shift cs 1) + (Base64_rfc2045.encode encoder (`Char (Cstruct.get_char cs 0))) + | `Partial -> + let len = Bytes.length tmp - Base64_rfc2045.dst_rem encoder in + write_string body (Bytes.sub_string tmp 0 len); + Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp); + let next () = go ctx length cs (Base64_rfc2045.encode encoder `Await) in + flush body next + and encode ctx = function + | 0L -> finalize ctx (Base64_rfc2045.encode encoder `End) + | length -> + let len = min (Int64.of_int (Cstruct.length rnd)) length in + let ({ Cstruct.buffer; off; len = buffer_len } as rnd) = + random_cstruct ~g rnd (Int64.to_int len) + in + Log.debug (fun m -> + m "@[%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 open Lwt.Infix in + let closed = Lwt_mvar.create_empty () in + let rec loop ~src ~dst () = + Lwt.pick + [ + Lwt_result.Infix.( + Mimic.read src >|= fun v -> (v :> [ `Closed | _ Mirage_flow.or_eof ])); + (Lwt_mvar.take closed >|= fun v -> Ok v); + ] + >>= function + | Error err -> + Log.err (fun m -> + m "Got an error while we reading the source (CONNECT): %a." + Mimic.pp_error err); + if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed + else Lwt.return_unit + | Ok `Closed -> Lwt.return_unit + | Ok `Eof -> + if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed + else Lwt.return_unit + | Ok (`Data cs) -> ( + Log.debug (fun m -> m "Transfer over HTTP:"); + Log.debug (fun m -> + m "@[%a@]." (Hxd_string.pp Hxd.default) (Cstruct.to_string cs)); + Mimic.write dst cs >>= function + | Ok () -> Lwt.pause () >>= loop ~src ~dst + | Error err -> + Log.err (fun m -> + m + "Got an error while we writing into the destination \ + (CONNECT): %a." + Mimic.pp_write_error err); + if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed + else Lwt.return_unit) + in + Lwt.join [ loop ~src ~dst (); loop ~src:dst ~dst:src () ] >>= fun () -> + to_close src; + Lwt.join [ Mimic.close src; Mimic.close dst ] >>= fun () -> + Log.debug (fun m -> m "Connection closed properly on both side."); + Lwt.return_unit + +(***** HTTP/1.1 *****) + +module S_HTTP_1_1 = struct + type request = H1.Request.t + type response = H1.Response.t + + let version = `HTTP_1_1 + let get request name = H1.Headers.get request.H1.Request.headers name + + let create headers = function + | #H1.Status.t as status -> + H1.Response.create ~headers:(H1.Headers.of_list headers) status + | _ -> assert false + + let with_etag etag response = + let headers = response.H1.Response.headers in + { response with H1.Response.headers = H1.Headers.add headers "etag" etag } + + let with_status (status : H2.Status.t) response = + match status with + | #H1.Status.t as status -> { response with H1.Response.status } + | _ -> assert false +end + +let transmit src dst = + let rec on_eof () = + H1.Body.Reader.close src; + H1.Body.Writer.close dst + and on_read buf ~off ~len = + H1.Body.Writer.write_bigstring dst ~off ~len buf; + H1.Body.Reader.schedule_read src ~on_eof ~on_read + in + H1.Body.Reader.schedule_read src ~on_eof ~on_read + +let connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd = + let request = H1.Reqd.request reqd in + match H1.Headers.get request.H1.Request.headers "host" with + | Some uri -> + let uri = "http://" ^ uri in + let open Lwt.Infix in + Lwt.async (fun () -> + Connect.create_connection ~ctx ~authenticator uri >>= function + | Ok dst -> + let headers = H1.Headers.of_list [ ("connection", "close") ] in + let response = + H1.Response.create ~reason:"CONNECT" ~headers `OK + in + H1.Reqd.respond_with_string reqd response ""; + H1.Body.Reader.close (H1.Reqd.request_body reqd); + transmit_over_http ~to_close flow dst + | Error err -> + Log.err (fun m -> + m "Got an error while connection to %S: %a." uri + Mimic.pp_error err); + let contents = Fmt.str "Invalid URI: %S" uri in + let headers = + H1.Headers.of_list + [ + ("content-length", string_of_int (String.length contents)); + ("connection", "close"); + ("content-type", "text/plain"); + ] + in + let response = + H1.Response.create ~reason:"CONNECT" ~headers `Bad_request + in + H1.Reqd.respond_with_string reqd response contents; + Lwt.return_unit) + | None -> + let contents = "Missing Host field." in + let headers = + H1.Headers.of_list + [ + ("content-length", string_of_int (String.length contents)); + ("connection", "close"); + ("content-type", "text/plain"); + ] + in + let response = + H1.Response.create ~reason:"CONNECT" ~headers `Bad_request + in + H1.Reqd.respond_with_string reqd response contents + +let http_1_1_request_handler ~ctx ~authenticator ~to_close = + let hash_of_seed = hash_of_seed (module S_HTTP_1_1) in + fun flow reqd -> + let request = H1.Reqd.request reqd in + Log.debug (fun m -> + m "(HTTP/1.1) request-handler: %S" request.H1.Request.target); + match request.H1.Request.meth with + | `CONNECT -> + Log.debug (fun m -> m "Start to transmit data over HTTP/1.1."); + connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd + | _meth -> ( + match String.split_on_char '/' request.H1.Request.target with + | [ ""; "" ] -> + let headers = + H1.Headers.of_list + [ + ("content-length", string_of_int (String.length root)); + ("connection", "close"); + ("content-type", "text/plain"); + ] + in + let response = H1.Response.create ~reason:"root" ~headers `OK in + H1.Reqd.respond_with_string reqd response root + | [ ""; "transmit" ] -> + let content_type = + H1.Headers.get request.H1.Request.headers "content-type" + in + let content_type = + Option.value ~default:"application/octet-stream" content_type + in + let headers = + H1.Headers.of_list + [ + ("transfer-encoding", "chunked"); + ("content-type", content_type); + ] + in + let response = H1.Response.create ~reason:"transmit" ~headers `OK in + let src = H1.Reqd.request_body reqd in + let dst = H1.Reqd.respond_with_streaming reqd response in + transmit src dst + | [ ""; "hash" ] -> + let respond response contents = + H1.Reqd.respond_with_string reqd response contents + in + hash_of_seed ~respond request + | [ ""; "random" ] -> ( + match H1.Headers.get request.H1.Request.headers "x-length" with + | Some v when String.for_all is_digit v -> + let length = Int64.of_string v in + let g = + Option.bind + (H1.Headers.get request.H1.Request.headers "x-seed") + random_state_of_seed + in + let headers = + H1.Headers.of_list + [ + ("content-type", "text/plain"); + ("transfer-encoding", "chunked"); + ] + in + let response = + H1.Response.create ~reason:"random" ~headers `OK + in + let body = H1.Reqd.respond_with_streaming reqd response in + transmit_random + ~write_string:(fun body str -> + H1.Body.Writer.write_string body str) + ~flush:H1.Body.Writer.flush ~close_writer:H1.Body.Writer.close + ?g length body + | _ -> + let contents = "Invalid length." in + let headers = + H1.Headers.of_list + [ + ("content-length", string_of_int (String.length contents)); + ("connection", "close"); + ("content-type", "text/plain"); + ] + in + let response = + H1.Response.create ~reason:"random" ~headers `Bad_request + in + H1.Reqd.respond_with_string reqd response contents) + | _ -> + let contents = "Not found." in + let headers = + H1.Headers.of_list + [ + ("content-type", "text/plain"); + ("connection", "close"); + ("content-length", string_of_int (String.length contents)); + ] + in + let response = + H1.Response.create ~reason:"not-found" ~headers `Not_found + in + H1.Reqd.respond_with_string reqd response contents) + +(***** H2 *****) + +module S_HTTP_2_0 = struct + type request = H2.Request.t + type response = H2.Response.t + + let version = `HTTP_2_0 + let get request name = H2.Headers.get request.H2.Request.headers name + + let create headers status = + H2.Response.create ~headers:(H2.Headers.of_list headers) status + + let with_etag etag response = + let headers = response.H2.Response.headers in + { response with H2.Response.headers = H2.Headers.add headers "etag" etag } + + let with_status status response = { response with H2.Response.status } +end + +let transmit src dst = + let rec on_eof () = + H2.Body.Reader.close src; + H2.Body.Writer.close dst + and on_read buf ~off ~len = + H2.Body.Writer.write_bigstring dst ~off ~len buf; + H2.Body.Reader.schedule_read src ~on_eof ~on_read + in + H2.Body.Reader.schedule_read src ~on_eof ~on_read + +let connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd = + let request = H2.Reqd.request reqd in + match H2.Headers.get request.H2.Request.headers "host" with + | Some uri -> + let uri = "http://" ^ uri in + let open Lwt.Infix in + Lwt.async (fun () -> + Connect.create_connection ~ctx ~authenticator uri >>= function + | Ok dst -> + let response = H2.Response.create `OK in + H2.Reqd.respond_with_string reqd response ""; + H2.Body.Reader.close (H2.Reqd.request_body reqd); + transmit_over_http ~to_close flow dst + | Error err -> + Log.err (fun m -> + m "Got an error while connection to %S: %a." uri + Mimic.pp_error err); + let contents = Fmt.str "Invalid URI: %S" uri in + let headers = + H2.Headers.of_list + [ + ("content-length", string_of_int (String.length contents)); + ("content-type", "text/plain"); + ] + in + let response = H2.Response.create ~headers `Bad_request in + H2.Reqd.respond_with_string reqd response contents; + Lwt.return_unit) + | None -> + let contents = "Missing Host field." in + let headers = + H2.Headers.of_list + [ + ("content-length", string_of_int (String.length contents)); + ("content-type", "text/plain"); + ] + in + let response = H2.Response.create ~headers `Bad_request in + H2.Reqd.respond_with_string reqd response contents + +let http_2_0_request_handler ~ctx ~authenticator ~to_close = + let hash_of_seed = hash_of_seed (module S_HTTP_2_0) in + fun flow reqd -> + let request = H2.Reqd.request reqd in + Log.debug (fun m -> m "(H2) request-handler: %S" request.H2.Request.target); + match request.H2.Request.meth with + | `CONNECT -> + Log.debug (fun m -> m "Start to transmit data over H2."); + connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd + | _meth -> ( + match String.split_on_char '/' request.H2.Request.target with + | [ ""; "" ] -> + let headers = + H2.Headers.of_list + [ + ("content-length", string_of_int (String.length root)); + ("content-type", "text/plain"); + ] + in + let response = H2.Response.create ~headers `OK in + H2.Reqd.respond_with_string reqd response root + | [ ""; "transmit" ] -> + let content_type = + H2.Headers.get request.H2.Request.headers "content-type" + in + let content_type = + Option.value ~default:"application/octet-stream" content_type + in + let headers = + H2.Headers.of_list [ ("content-type", content_type) ] + in + let response = H2.Response.create ~headers `OK in + let src = H2.Reqd.request_body reqd in + let dst = H2.Reqd.respond_with_streaming reqd response in + transmit src dst + | [ ""; "hash" ] -> + let respond response contents = + H2.Reqd.respond_with_string reqd response contents + in + hash_of_seed ~respond request + | [ ""; "random" ] -> ( + match H2.Headers.get request.H2.Request.headers "x-length" with + | Some v when String.for_all is_digit v -> + let length = Int64.of_string v in + let g = + Option.bind + (H2.Headers.get request.H2.Request.headers "x-seed") + random_state_of_seed + in + let headers = + H2.Headers.of_list [ ("content-type", "text/plain") ] + in + let response = H2.Response.create ~headers `OK in + let body = H2.Reqd.respond_with_streaming reqd response in + let flush body next = + H2.Body.Writer.flush body (fun _reason -> next ()) + in + transmit_random + ~write_string:(fun body str -> + H2.Body.Writer.write_string body str) + ~flush ~close_writer:H2.Body.Writer.close ?g length body + | _ -> + let contents = "Invalid length." in + let headers = + H2.Headers.of_list + [ + ("content-length", string_of_int (String.length contents)); + ("content-type", "text/plain"); + ] + in + let response = H2.Response.create ~headers `Bad_request in + H2.Reqd.respond_with_string reqd response contents) + | _ -> + let contents = "Not found." in + let headers = + H2.Headers.of_list + [ + ("content-type", "text/plain"); + ("content-length", string_of_int (String.length contents)); + ] + in + let response = H2.Response.create ~headers `Not_found in + H2.Reqd.respond_with_string reqd response contents) + +let alpn_request_handler : type reqd headers request response ro wo. + ctx:_ -> + authenticator:_ -> + to_close:_ -> + ?shutdown:_ -> + _ -> + _ -> + reqd -> + (reqd, headers, request, response, ro, wo) Alpn.protocol -> + unit = + fun ~ctx ~authenticator ~to_close ?shutdown:_ flow _edn reqd -> function + | Alpn.HTTP_1_1 _ -> + http_1_1_request_handler ~ctx ~authenticator ~to_close flow reqd + | Alpn.H2 _ -> + http_2_0_request_handler ~ctx ~authenticator ~to_close flow reqd + +let headers_of_list : type reqd headers request response ro wo. + (reqd, headers, request, response, ro, wo) Alpn.protocol -> + (string * string) list -> + headers = + fun protocol lst -> + match protocol with + | Alpn.HTTP_1_1 _ -> H1.Headers.of_list lst + | Alpn.H2 _ -> H2.Headers.of_list lst + +let respond_with_string : type reqd headers request response ro wo. + (reqd, headers, request, response, ro, wo) Alpn.protocol -> + headers:headers -> + respond:(headers -> wo) -> + string -> + unit = + fun protocol ~headers ~respond str -> + let body = respond headers in + match protocol with + | Alpn.HTTP_1_1 _ -> + H1.Body.Writer.write_string body str; + H1.Body.Writer.close body + | Alpn.H2 _ -> + H2.Body.Writer.write_string body str; + H2.Body.Writer.close body + +let alpn_error_handler : type reqd headers request response ro wo. + _ -> + (reqd, headers, request, response, ro, wo) Alpn.protocol -> + ?request:_ -> + _ -> + (headers -> wo) -> + unit = + fun _edn protocol ?request:_ error respond -> + let contents = + match error with + | `Bad_gateway -> {plain|Bad gateway.|plain} + | `Bad_request -> {plain|Bad request.|plain} + | `Exn (Paf.Flow err) | `Exn (Paf.Flow_write err) -> + Fmt.str {plain|I/O error: %s.|plain} err + | `Exn exn -> + Fmt.str {plain|Unknown error: %S.|plain} (Printexc.to_string exn) + | `Internal_server_error -> {plain|Internal server error.|plain} + in + let headers = + headers_of_list protocol + [ + ("content-type", "text/plain"); + ("content-length", string_of_int (String.length contents)); + ] + in + respond_with_string protocol ~respond ~headers contents + +let http_1_1_error_handler edn ?request error respond = + alpn_error_handler edn ?request Alpn.http_1_1 + (error :> Alpn.server_error) + respond + +let http_2_0_error_handler edn ?request error respond = + alpn_error_handler edn ?request Alpn.h2 (error :> Alpn.server_error) respond diff --git a/unikernel.ml b/unikernel.ml new file mode 100644 index 00000000..a936a947 --- /dev/null +++ b/unikernel.ml @@ -0,0 +1,163 @@ +open Rresult +open Lwt.Infix +open Cmdliner + +let port = + let doc = Arg.info ~doc:"Port of HTTP service." [ "p"; "port" ] in + Arg.(value & opt int 8080 doc) + +let use_tls = + let doc = + Arg.info ~doc:"Start an HTTP server with a TLS certificate." [ "tls" ] + in + Mirage_runtime.register_arg Arg.(value & flag doc) + +let tls_port = + let doc = Arg.info ~doc:"Port of HTTPS service." [ "tls-port" ] in + Mirage_runtime.register_arg Arg.(value & opt int 4343 doc) + +let alpn = + let alpns = [ "h2"; "http/1.1" ] in + let doc = + Printf.sprintf "Protocols handled by the HTTP server. Must be %s." + (Arg.doc_alts alpns) + in + let doc = Arg.info ~doc [ "alpn" ] in + Mirage_runtime.register_arg + Arg.(value & opt_all (enum (List.map (fun v -> (v, v)) alpns)) alpns doc) + +let ( <.> ) f g x = f (g x) +let always x _ = x + +module Make + (Certificate : Mirage_kv.RO) + (Key : Mirage_kv.RO) + (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t) + (Connect : Connect.S) + (HTTP_server : Paf_mirage.S) = +struct + let tls key_ro certificate_ro = + let open Lwt_result.Infix in + Lwt.Infix.( + Key.list key_ro Mirage_kv.Key.empty + >|= R.reword_error (R.msgf "%a" Key.pp_error)) + >>= fun keys -> + let keys, _ = List.partition (fun (_, t) -> t = `Value) keys in + Lwt.Infix.( + Certificate.list certificate_ro Mirage_kv.Key.empty + >|= R.reword_error (R.msgf "%a" Certificate.pp_error)) + >>= fun certificates -> + let certificates, _ = + List.partition (fun (_, t) -> t = `Value) certificates + in + let fold acc (name, _) = + match Mirage_kv.Key.basename name with + | ".gitkeep" -> Lwt.return acc + | _ -> + let open Lwt_result.Infix in + Lwt.Infix.( + Certificate.get certificate_ro name + >|= R.reword_error (R.msgf "%a" Certificate.pp_error)) + >>= (Lwt.return <.> X509.Certificate.decode_pem_multiple) + >>= fun certificates -> + Lwt.return acc >>= fun acc -> + Lwt.return_ok ((name, certificates) :: acc) + in + Lwt_list.fold_left_s fold (Ok []) certificates >>= fun certificates -> + let fold acc (name, _) = + match Mirage_kv.Key.basename name with + | ".gitkeep" -> Lwt.return acc + | _ -> + let open Lwt_result.Infix in + Lwt.Infix.( + Key.get key_ro name >|= R.reword_error (R.msgf "%a" Key.pp_error)) + >>= (Lwt.return <.> X509.Private_key.decode_pem) + >>= fun key -> + Lwt.return acc >>= fun acc -> Lwt.return_ok ((name, key) :: acc) + in + Lwt_list.fold_left_s fold (Ok []) keys >>= fun keys -> + let tbl = Hashtbl.create 0x10 in + List.iter + (fun (name, certificates) -> + match List.assoc_opt name keys with + | Some key -> Hashtbl.add tbl name (certificates, key) + | None -> ()) + certificates; + match Hashtbl.fold (fun _ certchain acc -> certchain :: acc) tbl [] with + | [] -> Lwt.return_ok `None + | [ certchain ] -> Lwt.return_ok (`Single certchain) + | certchains -> Lwt.return_ok (`Multiple certchains) + + 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 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 + { + 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); + } + + 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 http_1_1_service = + HTTP_server.http_service ~error_handler:Server.http_1_1_error_handler + (http_1_1_request_handler ~ctx ~authenticator) + in + HTTP_server.init ~port:tls_port tcpv4v6 >|= Paf.serve alpn_service + >>= fun (`Initialized th0) -> + Paf.serve http_1_1_service http_server |> fun (`Initialized th1) -> + Lwt.both th0 th1 >>= fun ((), ()) -> Lwt.return_unit + + let run ~ctx ~authenticator 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) + in + Paf.serve http_1_1_service http_server |> fun (`Initialized th) -> th + + let start certificate_ro key_ro tcpv4v6 ctx http_server = + let open Lwt.Infix in + let authenticator = Connect.authenticator in + tls key_ro certificate_ro >>= fun tls -> + if use_tls () then + let tls = + let certificates = + match tls with + | Ok certificates -> certificates + | Error (`Msg m) -> + Fmt.failwith + "A TLS server requires, at least, one certificate and one \ + private key. Received error %s." + m + in + let alpn_protocols = alpn () in + match Tls.Config.server ~certificates ~alpn_protocols () with + | Error (`Msg m) -> Fmt.failwith "TLS configuration error: %s." m + | Ok tls -> tls + in + run_with_tls ~ctx ~authenticator ~tls http_server (tls_port ()) tcpv4v6 + else run ~ctx ~authenticator http_server +end