diff --git a/unikernel/unikernel.ml b/unikernel/unikernel.ml index 3e2d5206..686b4b04 100644 --- a/unikernel/unikernel.ml +++ b/unikernel/unikernel.ml @@ -1,5 +1,4 @@ open Rresult -open Lwt.Infix open Cmdliner let port = @@ -57,9 +56,10 @@ module Make (Connect : Connect.S) (HTTP_server : Paf_mirage.S) = struct + let ( let*? ) = Lwt_result.bind + let ( let+? ) x f = Lwt_result.map f x + 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 = @@ -148,38 +148,43 @@ struct end let tls certificate_ro key_ro = - let ( >>= ) = Lwt_result.bind in - Keys_ro.list key_ro Mirage_kv.Key.empty - |> map_err_to_string Keys_ro.pp_error - >>= fun keys -> + let*? keys = + Keys_ro.list key_ro Mirage_kv.Key.empty + |> map_err_to_string Keys_ro.pp_error + in let keys = List.filter (fun (_, t) -> t = `Value) keys in - Certificates_ro.list certificate_ro Mirage_kv.Key.empty - |> map_err_to_string Certificates_ro.pp_error - >>= fun certificates -> + let*? certificates = + Certificates_ro.list certificate_ro Mirage_kv.Key.empty + |> map_err_to_string Certificates_ro.pp_error + 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 | _ -> - 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) + let*? data = + Certificates_ro.get certificate_ro name + |> map_err_to_string Certificates_ro.pp_error + in + let*? certificates = + Lwt.return (X509.Certificate.decode_pem_multiple data) + in + let+? acc = Lwt.return acc in + (name, certificates) :: acc in - Lwt_list.fold_left_s fold (Ok []) certificates >>= fun certificates -> + 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 + let*? key = Lwt.return (X509.Private_key.decode_pem data) in + let+? acc = Lwt.return acc in + (name, key) :: acc in - Lwt_list.fold_left_s fold (Ok []) keys >>= fun keys -> + let+? keys = Lwt_list.fold_left_s fold (Ok []) keys in let tbl = Hashtbl.create 0x10 in List.iter (fun (name, certificates) -> @@ -188,9 +193,9 @@ 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 http_1_1_request_handler ~ctx ~authenticator flow _edn = let module R = (val Mimic.repr HTTP_server.tcp_protocol) in @@ -230,10 +235,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 +250,24 @@ 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) -> ( + | 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 -> + 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 \