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

JJ: Description from the destination commit:

Browse source 
~ syntax stuff

JJ: Description from source commit:
~~
This commit is contained in:
swrup 2025-11-04 18:36:32 +01:00
parent 774d55ebb1
commit 1a65fa9b8c
4 changed files with 131 additions and 102 deletions
Download patch file Download diff file Expand all files Collapse all files

28
unikernel/connect.ml
View file

@ -1,10 +1,10 @@
open Syntax
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"
@ -31,20 +31,16 @@ struct
| `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)
write flow cs |> Lwt_result.map_error (fun err -> `Write err)
let writev flow css =
writev flow css >>= function
| Ok _ as v -> Lwt.return v
| Error err -> Lwt.return_error (`Write err)
writev flow css |> Lwt_result.map_error (fun err -> `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
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)
@ -59,9 +55,10 @@ struct
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
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)
@ -154,8 +151,7 @@ let tls_config ?tls_config authenticator =
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, 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

33
unikernel/server.ml
View file

@ -1,3 +1,5 @@
open Syntax
let src = Logs.Src.create "server"
module Log = (val Logs.src_log src : Logs.LOG)
@ -200,16 +202,18 @@ let hash_of_seed : type response request.
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 () =
let* res =
Lwt.pick
[
Lwt_result.Infix.(
Mimic.read src >|= fun v -> (v :> [ `Closed | _ Mirage_flow.or_eof ]));
(Lwt_mvar.take closed >|= fun v -> Ok v);
(let+? v = Mimic.read src in
(v :> [ `Closed | _ Mirage_flow.or_eof ]));
(let+ v = Lwt_mvar.take closed in
Ok v);
]
>>= function
in
match res with
| Error err ->
Log.err (fun m ->
m "Got an error while we reading the source (CONNECT): %a."
@ -224,8 +228,11 @@ let transmit_over_http : to_close:_ -> Mimic.flow -> Mimic.flow -> unit Lwt.t =
Log.debug (fun m -> m "Transfer over HTTP:");
Log.debug (fun m ->
m "@[<hov>%a@]." (Hxd_string.pp Hxd.default) (Cstruct.to_string cs));
Mimic.write dst cs >>= function
| Ok () -> Lwt.pause () >>= loop ~src ~dst
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
@ -235,9 +242,9 @@ let transmit_over_http : to_close:_ -> Mimic.flow -> Mimic.flow -> unit Lwt.t =
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 () ->
let* () = Lwt.join [ loop ~src ~dst (); loop ~src:dst ~dst:src () ] in
to_close src;
Lwt.join [ Mimic.close src; Mimic.close dst ] >>= fun () ->
let* () = Lwt.join [ Mimic.close src; Mimic.close dst ] in
Log.debug (fun m -> m "Connection closed properly on both side.");
Lwt.return_unit
@ -278,9 +285,9 @@ let connect_http_1_1 ~ctx ~authenticator ~to_close flow reqd =
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
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 =
@ -449,9 +456,9 @@ let connect_http_2_0 ~ctx ~authenticator ~to_close flow reqd =
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
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 "";

22
unikernel/syntax.ml Normal file
View file

@ -0,0 +1,22 @@
let ( let* ) = Lwt.bind
let ( let+ ) x f = Lwt.map f x
let ( let*? ) = Lwt_result.bind
let ( let+? ) x f = Lwt_result.map f x
let list_get_ok l =
let err = ref None in
try
Ok
(List.map
(function
| Error _e as e ->
err := Some e;
raise Exit
| Ok v -> v)
l)
with Exit -> ( match !err with None -> assert false | Some v -> v)
let lwt_list_get_ok l =
let open Lwt.Syntax in
let+ l = l in
list_get_ok l

132
unikernel/unikernel.ml
View file

@ -1,6 +1,6 @@
open Rresult
open Lwt.Infix
open Cmdliner
open Syntax
let port =
let doc = Arg.info ~doc:"Port of HTTP service." [ "p"; "port" ] in
@ -26,29 +26,9 @@ let alpn =
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
let map_err_to_string pp_err res =
Lwt.map (R.reword_error (R.msgf "%a" pp_err)) res
let list_get_ok l =
let err = ref None in
try
l
|> List.map (function
| Error _e as e ->
err := Some e;
raise Exit
| Ok v -> v)
|> Result.ok
with Exit -> ( match !err with None -> assert false | Some v -> v)
let lwt_list_get_ok l =
let open Lwt.Syntax in
let+ l = l in
list_get_ok l
module Make
(Assets_ro : Mirage_kv.RO)
(Certificates_ro : Mirage_kv.RO)
@ -58,8 +38,6 @@ module Make
(HTTP_server : Paf_mirage.S) =
struct
module Assets = struct
let ( let*? ) = Lwt_result.bind
let ( let+? ) x f = Lwt_result.map f x
let map_err_to_string = map_err_to_string Assets_ro.pp_error
let get_subdirs ro k =
@ -125,61 +103,89 @@ struct
(Fmt.list Fmt.string) l
in
let* ext_l =
let ll =
let* hd, tl =
l
|> List.map (fun (_, _, v) -> v)
|> List.map (List.sort String.compare)
|> function
| [] ->
Fmt.error_msg "directory `%s` is empty"
(Mirage_kv.Key.to_string dir)
| hd :: tl -> Ok (hd, tl)
in
match List.sort_uniq Stdlib.compare ll with
| [ l ] -> Ok l
| [] -> assert false
| _ll ->
match List.for_all (( = ) hd) tl with
| false ->
Fmt.error_msg
"directory `%s` does not has the same set of file extensions for \
each language"
(Mirage_kv.Key.to_string dir)
| true -> Ok hd
in
Ok (etag, lang_l, ext_l)
let assets ro =
let*? terms_assoc = get ro "terms" in
let*? privacy_assoc = get ro "privacy" in
Lwt_result.return (terms_assoc, privacy_assoc)
let*? terms_etag, terms_lang_l, terms_ext_l = get ro "terms" in
let*? privacy_etag, privacy_lang_l, privacy_ext_l = get ro "privacy" in
Lwt.return
@@
let open Result.Syntax in
let* lang_l =
match terms_lang_l = privacy_lang_l with
| false ->
Fmt.error_msg
"terms and privacy directories does not support the same set of \
languages"
| true -> Ok terms_lang_l
in
let ext_l =
match terms_ext_l = privacy_ext_l with
| false ->
Fmt.error_msg
"terms and privacy directories does not support the same set of \
mimetype"
| true -> Ok terms_ext_l
in
Ok (terms_etag, privacy_etag, lang_l, ext_l)
end
let tls certificate_ro key_ro =
let ( >>= ) = Lwt_result.bind in
let*? keys =
Keys_ro.list key_ro Mirage_kv.Key.empty
|> map_err_to_string Keys_ro.pp_error
>>= fun keys ->
in
let keys = List.filter (fun (_, t) -> t = `Value) keys in
let*? certificates =
Certificates_ro.list certificate_ro Mirage_kv.Key.empty
|> map_err_to_string Certificates_ro.pp_error
>>= fun certificates ->
in
let certificates = List.filter (fun (_, t) -> t = `Value) certificates in
let fold acc (name, _) =
match Mirage_kv.Key.basename name with
| ".gitkeep" -> Lwt.return acc
| _ ->
let*? data =
Certificates_ro.get certificate_ro name
|> map_err_to_string Certificates_ro.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*? certificates =
Lwt.return (X509.Certificate.decode_pem_multiple data)
in
let+? acc = Lwt.return acc in
(name, certificates) :: acc
in
let*? certificates = Lwt_list.fold_left_s fold (Ok []) certificates in
let fold acc (name, _) =
match Mirage_kv.Key.basename name with
| ".gitkeep" -> Lwt.return acc
| _ ->
Keys_ro.get key_ro name
|> map_err_to_string Keys_ro.pp_error
>>= (Lwt.return <.> X509.Private_key.decode_pem)
>>= fun key ->
Lwt.return acc >>= fun acc -> Lwt.return_ok ((name, key) :: acc)
let*? data =
Keys_ro.get key_ro name |> map_err_to_string Keys_ro.pp_error
in
Lwt_list.fold_left_s fold (Ok []) keys >>= fun keys ->
let*? key = Lwt.return (X509.Private_key.decode_pem data) in
let+? acc = Lwt.return acc in
(name, key) :: acc
in
let+? keys = Lwt_list.fold_left_s fold (Ok []) keys in
let tbl = Hashtbl.create 0x10 in
List.iter
(fun (name, certificates) ->
@ -188,9 +194,11 @@ struct
| 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)
| [] -> `None
| [ certchain ] -> `Single certchain
| certchains -> `Multiple certchains
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
@ -230,10 +238,12 @@ struct
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 open Lwt.Syntax in
let* server = HTTP_server.init ~port:tls_port tcpv4v6 in
let (`Initialized th0) = Paf.serve alpn_service server in
let (`Initialized th1) = Paf.serve http_1_1_service http_server in
let+ (), () = Lwt.both th0 th1 in
()
let run ~ctx ~authenticator http_server =
let http_1_1_service =
@ -243,23 +253,17 @@ struct
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 open Lwt.Infix in
let open Lwt.Syntax in
let authenticator = Connect.authenticator in
Assets.assets assets_ro >>= fun res ->
match res with
let* assets_res = Assets.assets assets_ro in
match assets_res with
| Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
| Ok (terms, _privacy) -> (
let etag, lang_l, ext_l = terms in
Fmt.pr "ETAG: %s@\nlanguages: %a@\nextensions: %a@." etag
(Fmt.list ~sep:(Fmt.any ", ") Fmt.string)
lang_l
(Fmt.list ~sep:(Fmt.any ", ") Fmt.string)
ext_l;
tls certificate_ro key_ro >>= fun tls ->
| 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
| true -> (
match tls with
match tls_res with
| Error (`Msg m) ->
Fmt.failwith
"A TLS server requires, at least, one certificate and one \