~ syntax stuff

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 |> Lwt_result.map_error (fun err -> `Write err)
-      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
+      writev flow css |> Lwt_result.map_error (fun err -> `Write err)
-      | 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
+      let+ res = Happy_eyeballs.resolve happy_eyeballs hostname [ port ] in
-      | Error (`Msg err) -> Lwt.return_error (`Connect err)
+      match res with
-      | Ok ((_ipaddr, _port), flow) -> Lwt.return_ok flow
+      | 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
+      let* res = Happy_eyeballs.resolve happy_eyeballs hostname [ port ] in
-      | Ok ((_ipaddr, _port), flow) -> client_of_flow cfg ?host:peer_name flow
+      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
+  let*? ctx, host = Lwt.return (decode_uri ~ctx uri) 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

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 () =
+    let* res =
       Lwt.pick
         [
-        Lwt_result.Infix.(
+          (let+? v = Mimic.read src in
-          Mimic.read src >|= fun v -> (v :> [ `Closed | _ Mirage_flow.or_eof ]));
+           (v :> [ `Closed | _ Mirage_flow.or_eof ]));
-        (Lwt_mvar.take closed >|= fun v -> Ok v);
+          (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
+        let* res = Mimic.write dst cs in
-        | Ok () -> Lwt.pause () >>= loop ~src ~dst
+        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 "";

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

unikernel/unikernel.ml

@@ -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
+        match List.for_all (( = ) hd) tl with
-        | [ l ] -> Ok l
+        | false ->
-        | [] -> assert false
-        | _ll ->
             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*? terms_etag, terms_lang_l, terms_ext_l = get ro "terms" in
-      let*? privacy_assoc = get ro "privacy" in
+      let*? privacy_etag, privacy_lang_l, privacy_ext_l = get ro "privacy" in
-      Lwt_result.return (terms_assoc, privacy_assoc)
+      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
+          let*? data =
-          |> map_err_to_string Keys_ro.pp_error
+            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)
           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
+    | [] -> `None
-    | [ certchain ] -> Lwt.return_ok (`Single certchain)
+    | [ certchain ] -> `Single certchain
-    | certchains -> Lwt.return_ok (`Multiple certchains)
+    | 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
+    let open Lwt.Syntax in
-    >>= fun (`Initialized th0) ->
+    let* server = HTTP_server.init ~port:tls_port tcpv4v6 in
-    Paf.serve http_1_1_service http_server |> fun (`Initialized th1) ->
+    let (`Initialized th0) = Paf.serve alpn_service server in
-    Lwt.both th0 th1 >>= fun ((), ()) -> Lwt.return_unit
+    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 ->
+    let* assets_res = Assets.assets assets_ro in
-    match res with
+    match assets_res with
     | Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
-    | Ok (terms, _privacy) -> (
+    | Ok (_terms_etag, _privacy_etag, _lang_l, _ext_l) -> (
-        let etag, lang_l, ext_l = terms in
+        let* tls_res = tls certificate_ro key_ro 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 ->
         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 \