load data/assets/terms/..

unikernel/config.ml

@@ -13,7 +13,7 @@ let mte =
         package "hxd" ~sublibs:[ "core"; "string" ]; package "rresult";
         package "h2" ~min:"0.13.0"; package "base64" ~sublibs:[ "rfc2045" ];
       ]
-    (kv_ro @-> kv_ro @-> tcpv4v6 @-> conn @-> http_server @-> job)
+    (kv_ro @-> kv_ro @-> kv_ro @-> tcpv4v6 @-> conn @-> http_server @-> job)
 
 let conn =
   let connect _ modname = function
@@ -29,6 +29,7 @@ let he = generic_happy_eyeballs stackv4v6
 let dns = generic_dns_client stackv4v6 he
 let certificates = crunch "../data/tls/certificates"
 let keys = crunch "../data/tls/keys"
+let assets = crunch "../data/assets"
 
 let conn =
   let happy_eyeballs = mimic_happy_eyeballs stackv4v6 he dns in
@@ -38,4 +39,5 @@ let port = Runtime_arg.create ~pos:__POS__ "Unikernel.port"
 let http_server = paf_server ~port tcpv4v6
 
 let () =
-  register "mte" [ mte $ certificates $ keys $ tcpv4v6 $ conn $ http_server ]
+  register "mte"
+    [ mte $ assets $ certificates $ keys $ tcpv4v6 $ conn $ http_server ]

unikernel/unikernel.ml

@@ -29,35 +29,140 @@ 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
+
+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
-    (Certificate : Mirage_kv.RO)
+    (Assets_ro : Mirage_kv.RO)
-    (Key : Mirage_kv.RO)
+    (Certificates_ro : 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 =
+  module Assets = struct
-    let open Lwt_result.Infix in
+    let ( let*? ) = Lwt_result.bind
-    Lwt.Infix.(
+    let ( let+? ) x f = Lwt_result.map f x
-      Key.list key_ro Mirage_kv.Key.empty
+    let map_err_to_string = map_err_to_string Assets_ro.pp_error
-      >|= R.reword_error (R.msgf "%a" Key.pp_error))
+
-    >>= fun keys ->
+    let get_subdirs ro k =
-    let keys, _ = List.partition (fun (_, t) -> t = `Value) keys in
+      let+? keys = Assets_ro.list ro k |> map_err_to_string in
-    Lwt.Infix.(
+      List.filter (fun (_, t) -> t = `Dictionary) keys |> List.map fst
-      Certificate.list certificate_ro Mirage_kv.Key.empty
+
-      >|= R.reword_error (R.msgf "%a" Certificate.pp_error))
+    let get_values ro k =
-    >>= fun certificates ->
+      let+? keys = Assets_ro.list ro k |> map_err_to_string in
-    let certificates, _ =
+      List.filter (fun (_, t) -> t = `Value) keys |> List.map fst
-      List.partition (fun (_, t) -> t = `Value) certificates
+
+    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 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 =
+        lwt_list_get_ok
+        @@ Lwt_list.map_s
+             (fun lang_dir ->
+               let+? files = get_values ro lang_dir in
+               (lang_dir, files))
+             subdirs
       in
+      Lwt.return
+      @@
+      let open Result.Syntax in
+      let* l =
+        list_get_ok
+        @@ List.map
+             (fun (lang, l) ->
+               let lang = Mirage_kv.Key.basename lang in
+               let* l =
+                 List.map Mirage_kv.Key.basename l
+                 |> List.map (fun s ->
+                     match String.split_on_char '.' s with
+                     | [] -> assert false
+                     | [ etag; ext ] -> Ok (etag, ext)
+                     | _ -> Error (`Msg (Fmt.str "invalid file name: `%s`" s)))
+                 |> list_get_ok
+               in
+               let etag_l, ext_l = List.split l in
+               Ok (lang, etag_l, ext_l))
+             l
+      in
+      let lang_l =
+        l |> List.map (fun (v, _, _) -> v) |> List.sort String.compare
+      in
+      let* etag =
+        let etag_l = l |> List.map (fun (_, v, _) -> v) |> List.concat in
+        match List.sort_uniq String.compare etag_l with
+        | [ etag ] -> Ok etag
+        | [] ->
+            Fmt.error_msg "directory `%s` is empty"
+              (Mirage_kv.Key.to_string dir)
+        | l ->
+            Fmt.error_msg "directory `%s` contains more than one etag: %a"
+              (Mirage_kv.Key.to_string dir)
+              (Fmt.list Fmt.string) l
+      in
+      let* ext_l =
+        let ll =
+          l
+          |> List.map (fun (_, _, v) -> v)
+          |> List.map (List.sort String.compare)
+        in
+        match List.sort_uniq Stdlib.compare ll with
+        | [ l ] -> Ok l
+        | [] -> 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)
+      in
+      Ok (etag, lang_l, ext_l)
+
+    let assets ro =
+      let*? terms_assoc = get ro "terms" in
+      let*? privacy_assoc = get ro "privacy" in
+      Lwt_result.return (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.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 = List.filter (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 +173,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)
@@ -138,26 +242,35 @@ struct
     in
     Paf.serve http_1_1_service http_server |> fun (`Initialized th) -> th
 
-  let start certificate_ro key_ro tcpv4v6 ctx http_server =
+  let start assets_ro 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 ->
+    Assets.assets assets_ro >>= fun res ->
-    if use_tls () then
+    match res with
-      let tls =
+    | Error (`Msg m) -> Fmt.failwith "Assets configuration error: %s." m
-        let certificates =
+    | 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 ->
+        match use_tls () with
+        | false -> run ~ctx ~authenticator http_server
+        | true -> (
             match tls with
-          | Ok certificates -> certificates
             | Error (`Msg m) ->
                 Fmt.failwith
                   "A TLS server requires, at least, one certificate and one \
                    private key. Received error %s."
                   m
-        in
+            | Ok certificates -> (
                 let alpn_protocols = alpn () in
                 match Tls.Config.server ~certificates ~alpn_protocols () with
-        | Error (`Msg m) -> Fmt.failwith "TLS configuration error: %s." m
+                | Error (`Msg m) ->
-        | Ok tls -> tls
+                    Fmt.failwith "TLS configuration error: %s." m
-      in
+                | Ok tls ->
-      run_with_tls ~ctx ~authenticator ~tls http_server (tls_port ()) tcpv4v6
+                    run_with_tls ~ctx ~authenticator ~tls http_server
-    else run ~ctx ~authenticator http_server
+                      (tls_port ()) tcpv4v6)))
 end