diff --git a/unikernel/connect.ml b/unikernel/connect.ml index f50915dd..6bab28b3 100644 --- a/unikernel/connect.ml +++ b/unikernel/connect.ml @@ -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 diff --git a/unikernel/server.ml b/unikernel/server.ml index c91f0c8f..f51c6652 100644 --- a/unikernel/server.ml +++ b/unikernel/server.ml @@ -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 () = - 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 + 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." @@ -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 "@[%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 ""; diff --git a/unikernel/syntax.ml b/unikernel/syntax.ml new file mode 100644 index 00000000..e80a41b6 --- /dev/null +++ b/unikernel/syntax.ml @@ -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 diff --git a/unikernel/unikernel.ml b/unikernel/unikernel.ml index 52e61ec0..4a33bdfe 100644 --- a/unikernel/unikernel.ml +++ b/unikernel/unikernel.ml @@ -1,5 +1,6 @@ open Rresult open Cmdliner +open Syntax let port = let doc = Arg.info ~doc:"Port of HTTP service." [ "p"; "port" ] in @@ -28,24 +29,6 @@ let alpn = 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 - 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 - module Make (Assets_ro : Mirage_kv.RO) (Certificates_ro : Mirage_kv.RO) @@ -54,9 +37,6 @@ 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 map_err_to_string = map_err_to_string Assets_ro.pp_error