~ syntax stuff

unikernel/unikernel.ml

@@ -1,5 +1,4 @@
 open Rresult
-open Lwt.Infix
 open Cmdliner
 
 let port =
@@ -26,22 +25,20 @@ 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
+    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 =
@@ -57,9 +54,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 +146,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 +191,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 +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 \