~~

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
 
@@ -123,26 +103,49 @@ 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
-        | [ l ] -> Ok l
-        | [] -> assert false
-        | _ll ->
+        match List.for_all (( = ) hd) tl with
+        | false ->
             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*? privacy_assoc = get ro "privacy" in
-      Lwt_result.return (terms_assoc, privacy_assoc)
+      let*? terms_etag, terms_lang_l, terms_ext_l = get ro "terms" in
+      let*? privacy_etag, privacy_lang_l, privacy_ext_l = get ro "privacy" in
+      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 =
@@ -255,14 +258,7 @@ struct
     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) -> (
-        (*
-        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; *)
+    | Ok (_terms_etag, _privacy_etag, _lang_l, _ext_l) -> (
         let* tls_res = tls certificate_ro key_ro in
         match use_tls () with
         | false -> run ~ctx ~authenticator http_server