swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

clean up skeleton

Browse source
This commit is contained in:
swrup 2025-11-05 19:41:38 +01:00
parent f4eb197093
commit d693537b39
6 changed files with 100 additions and 810 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/dune
View file

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

47
src/mte.ml
View file

@ -1 +1,46 @@
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 request_route request =
match String.split_on_char '/' request.target with
| "" :: l -> l
| _ -> assert false
let content_type_to_string = function
| `Text_plain -> "text/plain"
| `Application_json -> "application/json"
let default_headers ~content typ =
Headers.of_list
[
("content-length", string_of_int (String.length content));
("connection", "close"); ("content-type", content_type_to_string typ);
]
let home_page_text =
"Hello!\n\nThis is MTE, the MirageOS Taler Exchange unikernel."
let request_handler request =
match request_route request with
| [ "" ] ->
let content = home_page_text in
let headers = default_headers ~content `Text_plain in
{ status= `OK; headers; content }
| _ ->
let content = "Not found." in
let headers = default_headers ~content `Text_plain in
{ status= `Not_found; headers; content }

22
unikernel/config.ml
View file

@ -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 ]

164
unikernel/connect.ml
View file

@ -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

613
unikernel/server.ml
View file

@ -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 "@[<hov>%a@]"
(Hxd_string.pp Hxd.default)
(Bigstringaf.substring buffer ~off ~len:buffer_len));
let ctx =
Digestif.SHA256.feed_bigstring ctx ~off ~len:buffer_len buffer
in
go ctx (Int64.sub length len) rnd `Ok
and finalize ctx = function
| `Partial ->
let len = Bytes.length tmp - Base64_rfc2045.dst_rem encoder in
write_string body (Bytes.sub_string tmp 0 len);
Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp);
let next () = finalize ctx (Base64_rfc2045.encode encoder `Await) in
flush body next
| `Ok ->
Logs.debug (fun m ->
m "%a" Digestif.SHA256.pp (Digestif.SHA256.get ctx));
close_writer body
in
Base64_rfc2045.dst encoder tmp 0 (Bytes.length tmp);
encode ctx length
let hash ~version ~create ?seed length =
let rec go g rnd ctx = function
| 0L ->
let headers =
[
("content-length", string_of_int (Digestif.SHA256.digest_size * 2));
("content-type", "text/plain");
]
in
(* XXX(dinosaure): Connection: Close header is only true for http/1.1.
For h2, curl complains and abruptely closes the connection. The most
important seems Content-Length which closes properly the connection
on both sides. *)
let headers =
match version with
| `HTTP_1_1 -> ("connection", "close") :: headers
| `HTTP_2_0 -> headers
in
let response = create headers `OK in
(response, Digestif.SHA256.(to_hex (get ctx)))
| length ->
let len = min (Int64.of_int (Cstruct.length rnd)) length in
let { Cstruct.buffer; off; len= buffer_len } =
random_cstruct ~g rnd (Int64.to_int len)
in
Log.debug (fun m ->
m "@[<hov>%a@]"
(Hxd_string.pp Hxd.default)
(Bigstringaf.substring buffer ~off ~len:buffer_len));
let ctx =
Digestif.SHA256.feed_bigstring ctx ~off ~len:buffer_len buffer
in
go g rnd ctx (Int64.sub length len)
in
match
( Option.bind seed random_state_of_seed,
Option.bind length Int64.of_string_opt )
with
| Some g, Some length ->
go g (Cstruct.create 0x1000) Digestif.SHA256.empty length
| _ ->
let contents = "Invalid seed." in
let headers =
[
("content-length", string_of_int (String.length contents));
("content-type", "text/plain");
]
in
let headers =
match version with
| `HTTP_1_1 -> ("connection", "close") :: headers
| `HTTP_2_0 -> headers
in
let response = create headers `Bad_request in
(response, contents)
module Cache = Ephemeron.K1.Make (struct
type t = string option * string option
let equal = ( = )
let hash = Hashtbl.hash
end)
module type S = sig
type response
type request
val version : [ `HTTP_1_1 | `HTTP_2_0 ]
val create : (string * string) list -> H2.Status.t -> response
val with_etag : string -> response -> response
val with_status : H2.Status.t -> response -> response
val get : request -> string -> string option
end
let hash_of_seed : type response request.
(module S with type response = response and type request = request) ->
respond:(response -> string -> unit) ->
request ->
unit =
fun (module S) ->
();
let tbl = Cache.create 0x100 in
fun ~respond request ->
let seed = S.get request "x-seed" and length = S.get request "x-length" in
match
(Cache.find_opt tbl (seed, length), S.get request "if-none-match")
with
| None, _ | Some _, None ->
let response, contents =
hash ~version:S.version ~create:S.create ?seed length
in
Cache.add tbl (seed, length) (response, contents);
respond response contents
| Some (response, contents), Some etags ->
let hash = Digestif.SHA256.digest_string contents in
let hash = Digestif.SHA256.to_hex hash in
if List.mem hash (String.split_on_char ',' etags) then
let response =
S.with_etag hash (S.with_status `Not_modified response)
in
respond response String.empty
else respond response contents
let transmit_over_http : to_close:_ -> Mimic.flow -> Mimic.flow -> unit Lwt.t =
fun ~to_close src dst ->
let closed = Lwt_mvar.create_empty () in
let rec loop ~src ~dst () =
let* res =
Lwt.pick
[
(let+? v = Mimic.read src in
(v :> [ `Closed | _ Mirage_flow.or_eof ]));
(let+ v = Lwt_mvar.take closed in
Ok v);
]
in
match res with
| Error err ->
Log.err (fun m ->
m "Got an error while we reading the source (CONNECT): %a."
Mimic.pp_error err);
if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed
else Lwt.return_unit
| Ok `Closed -> Lwt.return_unit
| Ok `Eof ->
if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed
else Lwt.return_unit
| Ok (`Data cs) -> (
Log.debug (fun m -> m "Transfer over HTTP:");
Log.debug (fun m ->
m "@[<hov>%a@]." (Hxd_string.pp Hxd.default) (Cstruct.to_string cs));
let* res = Mimic.write dst cs in
match res with
| Ok () ->
let* () = Lwt.pause () in
loop ~src ~dst ()
| Error err ->
Log.err (fun m ->
m
"Got an error while we writing into the destination \
(CONNECT): %a."
Mimic.pp_write_error err);
if Lwt_mvar.is_empty closed then Lwt_mvar.put closed `Closed
else Lwt.return_unit)
in
let* () = Lwt.join [ loop ~src ~dst (); loop ~src:dst ~dst:src () ] in
to_close src;
let* () = Lwt.join [ Mimic.close src; Mimic.close dst ] in
Log.debug (fun m -> m "Connection closed properly on both side.");
Lwt.return_unit
(***** HTTP/1.1 *****)
module S_HTTP_1_1 = struct
type request = H1.Request.t
type response = H1.Response.t
let version = `HTTP_1_1
let get request name = H1.Headers.get request.H1.Request.headers name
let create headers = function
| #H1.Status.t as status ->
H1.Response.create ~headers:(H1.Headers.of_list headers) status
| _ -> assert false
let with_etag etag response =
let headers = response.H1.Response.headers in
{ response with H1.Response.headers= H1.Headers.add headers "etag" etag }
let with_status (status : H2.Status.t) response =
match status with
| #H1.Status.t as status -> { response with H1.Response.status }
| _ -> assert false
end
let transmit src dst =
let rec on_eof () = H1.Body.Reader.close src; H1.Body.Writer.close dst
and on_read buf ~off ~len =
H1.Body.Writer.write_bigstring dst ~off ~len buf;
H1.Body.Reader.schedule_read src ~on_eof ~on_read
in
H1.Body.Reader.schedule_read src ~on_eof ~on_read
let connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd =
let request = H1.Reqd.request reqd in
match H1.Headers.get request.H1.Request.headers "host" with
| 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 http_1_1_request_handler 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");
]
let Mte.{ status; headers; content } =
Mte.request_handler (request_from_h1 ~scheme:"http" request)
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"
let status =
match status with
| #H1.Status.t as status -> status
| _ -> Fmt.failwith "H2 status response on a H1 request"
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)
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
(***** 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
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 http_2_0_request_handler 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");
]
let Mte.{ status; headers; content } =
Mte.request_handler (request_from_h2 request)
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 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

52
unikernel/unikernel.ml
View file

@ -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