load data/assets/terms/..

unikernel/unikernel.ml

@@ -29,35 +29,88 @@ let alpn =
 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
+
 module Make
-    (Certificate : Mirage_kv.RO)
+    (Certificates_ro : Mirage_kv.RO)
-    (Key : Mirage_kv.RO)
+    (Keys_ro : Mirage_kv.RO)
     (Tcp : Tcpip.Tcp.S with type ipaddr = Ipaddr.t)
     (Connect : Connect.S)
     (HTTP_server : Paf_mirage.S) =
 struct
-  let tls key_ro certificate_ro =
+  (* WIP
-    let open Lwt_result.Infix in
+     read directories *)
-    Lwt.Infix.(
+  module Assets = struct
-      Key.list key_ro Mirage_kv.Key.empty
+    module Assets_ro = Keys_ro
-      >|= R.reword_error (R.msgf "%a" Key.pp_error))
+
+    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 =
+      let+? keys = Assets_ro.list ro k |> map_err_to_string in
+      List.filter (fun (_, t) -> t = `Dictionary) keys |> List.map fst
+
+    let get_values ro k =
+      let+? keys = Assets_ro.list ro k |> map_err_to_string in
+      List.filter (fun (_, t) -> t = `Value) keys |> List.map fst
+
+    let find keys name =
+      keys
+      |> List.find_opt Mirage_kv.Key.(equal (v name))
+      |> Option.to_result ~none:(`Msg (Fmt.str "missing `%s` directory" name))
+      |> Lwt_result.lift
+
+    let lwt_list_get_ok l =
+      let open Lwt.Syntax in
+      let+ l = l in
+      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 get ro s =
+      let*? base_dir = get_subdirs ro Mirage_kv.Key.empty in
+      let*? dir = find base_dir s in
+      let*? subdirs = get_subdirs ro dir in
+      let+? l =
+        subdirs
+        |> Lwt_list.map_s (fun lang_dir ->
+            let+? files = get_values ro lang_dir in
+            (lang_dir, files))
+        |> lwt_list_get_ok
+      in
+      l
+
+    let assets ro =
+      let*? terms_assoc = get ro "terms" in
+      let+? privacy_assoc = get ro "privacy" in
+      (terms_assoc, privacy_assoc)
+  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, _ = List.partition (fun (_, t) -> t = `Value) keys in
+    let keys = List.filter (fun (_, t) -> t = `Value) keys in
-    Lwt.Infix.(
+    Certificates_ro.list certificate_ro Mirage_kv.Key.empty
-      Certificate.list certificate_ro Mirage_kv.Key.empty
+    |> map_err_to_string Certificates_ro.pp_error
-      >|= R.reword_error (R.msgf "%a" Certificate.pp_error))
     >>= fun certificates ->
-    let certificates, _ =
+    let certificates = List.filter (fun (_, t) -> t = `Value) certificates in
-      List.partition (fun (_, t) -> t = `Value) certificates
-    in
     let fold acc (name, _) =
       match Mirage_kv.Key.basename name with
       | ".gitkeep" -> Lwt.return acc
       | _ ->
-          let open Lwt_result.Infix in
+          Certificates_ro.get certificate_ro name
-          Lwt.Infix.(
+          |> map_err_to_string Certificates_ro.pp_error
-            Certificate.get certificate_ro name
-            >|= R.reword_error (R.msgf "%a" Certificate.pp_error))
           >>= (Lwt.return <.> X509.Certificate.decode_pem_multiple)
           >>= fun certificates ->
           Lwt.return acc >>= fun acc ->
@@ -68,9 +121,8 @@ struct
       match Mirage_kv.Key.basename name with
       | ".gitkeep" -> Lwt.return acc
       | _ ->
-          let open Lwt_result.Infix in
+          Keys_ro.get key_ro name
-          Lwt.Infix.(
+          |> map_err_to_string Keys_ro.pp_error
-            Key.get key_ro name >|= R.reword_error (R.msgf "%a" Key.pp_error))
           >>= (Lwt.return <.> X509.Private_key.decode_pem)
           >>= fun key ->
           Lwt.return acc >>= fun acc -> Lwt.return_ok ((name, key) :: acc)
@@ -141,23 +193,21 @@ struct
   let start certificate_ro key_ro tcpv4v6 ctx http_server =
     let open Lwt.Infix in
     let authenticator = Connect.authenticator in
-    tls key_ro certificate_ro >>= fun tls ->
+    tls certificate_ro key_ro >>= fun tls ->
-    if use_tls () then
+    match use_tls () with
-      let tls =
+    | false -> run ~ctx ~authenticator http_server
-        let certificates =
+    | true -> (
-          match tls with
+        match tls with
-          | Ok certificates -> certificates
+        | Error (`Msg m) ->
-          | Error (`Msg m) ->
+            Fmt.failwith
-              Fmt.failwith
+              "A TLS server requires, at least, one certificate and one \
-                "A TLS server requires, at least, one certificate and one \
+               private key. Received error %s."
-                 private key. Received error %s."
+              m
-                m
+        | Ok certificates -> (
-        in
+            let alpn_protocols = alpn () in
-        let alpn_protocols = alpn () in
+            match Tls.Config.server ~certificates ~alpn_protocols () with
-        match Tls.Config.server ~certificates ~alpn_protocols () with
+            | Error (`Msg m) -> Fmt.failwith "TLS configuration error: %s." m
-        | Error (`Msg m) -> Fmt.failwith "TLS configuration error: %s." m
+            | Ok tls ->
-        | Ok tls -> tls
+                run_with_tls ~ctx ~authenticator ~tls http_server (tls_port ())
-      in
+                  tcpv4v6))
-      run_with_tls ~ctx ~authenticator ~tls http_server (tls_port ()) tcpv4v6
-    else run ~ctx ~authenticator http_server
 end