+ clean up tos

src/assets.ml

@@ -1,62 +1,70 @@
-(* doc: https://docs.taler.net/design-documents/003-tos-rendering.html
+(* https://docs.taler.net/design-documents/003-tos-rendering.html
-   - must support `text/plain` and `text/markdown` *)
+   https://docs.taler.net/design-documents/003-tos-rendering.html
 
+   must support `text/plain` and `text/markdown` *)
+
+type t =
+  | Terms
+  | Privacy
+
+module Assets_config = struct
   (* hardcoded config just for static assets *)
   let default_lang = "en"
   let default_mimetype = ("text", "plain")
   let default_extension = ".txt"
   let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
-
-(* TODO how to update ToS version? *)
-let terms_legal_version = "0"
-let privacy_legal_version = "0"
-
-(* TODO config *)
-type t =
-  | Terms
-  | Privacy
-
-let etag k =
-  Result.get_ok
-  @@ Headers_lib.Etag.of_crockford32
-  @@ match k with Terms -> "0" | Privacy -> "0"
-
-let legal_version = function
-  | Terms -> terms_legal_version
-  | Privacy -> privacy_legal_version
-
   let base_dir = function Terms -> "terms" | Privacy -> "privacy"
 
-(* TODO clean up this horror *)
+  (* TODO this should be in the config like terms_etag *)
-let supported_lang_arr, supported_ext_arr =
+  let terms_legal_version = "0"
-  let open Syntax in
+  let privacy_legal_version = "0"
-  let path_l =
+end
-    Assets_crunch.file_list |> list_map Fpath.of_string |> function
+
-    | Error (`Msg e) -> Fmt.failwith "%s" e
+let etag k =
-    | Ok x -> x
+  let etag =
+    match k with Terms -> Config.terms_etag | Privacy -> Config.privacy_etag
   in
+  etag |> Headers_lib.Etag.of_crockford32 |> Result.get_ok
+
+let legal_version = function
+  | Terms -> Assets_config.terms_legal_version
+  | Privacy -> Assets_config.privacy_legal_version
+
+let supported_lang_arr, supported_ext_arr =
   let aux t =
-    let prefix = Fpath.v (base_dir t) in
+    let prefix = Fpath.v (Assets_config.base_dir t) in
-    let path_l = path_l |> List.filter_map (Fpath.rem_prefix prefix) in
+    let path_l = List.map Fpath.v Assets_crunch.file_list in
+    let path_l = List.filter_map (Fpath.rem_prefix prefix) path_l in
     let ext_l =
       path_l |> List.map Fpath.get_ext |> List.sort_uniq String.compare
     in
     let lang_l =
-      path_l
+      List.map
-      |> List.map (fun path ->
+        (fun path ->
           match Fpath.segs path with
           | [] -> assert false
           | [ dir; _file ] -> dir
           | _l ->
               Fmt.failwith "invalid folder structure, file `%s` is misplaced"
-                (Fpath.to_string path))
+                (Fpath.to_string Fpath.(prefix // path)))
-      |> List.sort_uniq String.compare
+        path_l
     in
-    let () =
+    let lang_l = List.sort_uniq String.compare lang_l in
+    let etag = Headers_lib.Etag.to_raw_string (etag t) in
+    List.iter
+      (fun path ->
+        let etag' = Fpath.to_string (Fpath.rem_ext (Fpath.base path)) in
+        if not @@ String.equal etag etag' then
+          Fmt.failwith
+            "filename of file `%s` does not match configuration ETAG value `%s`"
+            (Fpath.to_string Fpath.(prefix // path))
+            etag)
+      path_l;
     if List.is_empty lang_l then Fmt.failwith "no language supported";
     if List.is_empty ext_l then Fmt.failwith "no mimetype supported";
-      if not @@ List.mem default_lang lang_l then
+    if not @@ List.mem Assets_config.default_lang lang_l then
-        Fmt.failwith "default language `%s` files not found" default_lang;
+      Fmt.failwith "default language `%s` files not found"
+        Assets_config.default_lang;
     if not @@ List.mem ".txt" ext_l then
       Fmt.failwith "plain text file not found";
     if not @@ List.mem ".md" ext_l then Fmt.failwith "markdown file not found";
@@ -69,23 +77,19 @@ let supported_lang_arr, supported_ext_arr =
       Fmt.failwith
         "invalid folder structure, all supported language must provide the \
          same set of file mimetype"
-    in
+    else (lang_l, ext_l)
-    (lang_l, ext_l)
   in
   let lang_l, ext_l = aux Terms in
   let lang_l', ext_l' = aux Privacy in
-  let () =
+  match
-    if
+    List.equal String.equal lang_l lang_l'
-      not
+    && List.equal String.equal ext_l ext_l'
-      @@ (List.equal String.equal lang_l lang_l'
+  with
-         && List.equal String.equal ext_l ext_l')
+  | false ->
-    then
       Fmt.failwith
         "invalid folder structure, /terms and /privacy must support the same \
-         set of languages and mimetypes";
+         set of languages and mimetypes"
-    ()
+  | true -> (Array.of_list lang_l, Array.of_list ext_l)
-  in
-  (Array.of_list lang_l, Array.of_list ext_l)
 
 module Mimetype = struct
   type t = string * string
@@ -107,30 +111,47 @@ module Mimetype = struct
         (("image", "gif"), ".gif");
       ]
 
-  let all_supported, _ = List.split assoc
+  let arr =
+    let all_supported, all_supported_ext = List.split assoc in
+    match
+      Array.find_opt
+        (fun ext -> not @@ List.exists (( = ) ext) all_supported_ext)
+        supported_ext_arr
+    with
+    | Some ext -> Fmt.failwith "extension `%s` unsupported" ext
+    | None -> Array.of_list all_supported
 
-  let of_cohttp_media = function
+  let default =
+    match
+      List.mem
+        (Assets_config.default_mimetype, Assets_config.default_extension)
+        assoc
+    with
+    | false ->
+        Fmt.failwith "default content type `%a` not supported" pp
+          Assets_config.default_mimetype
+    | true -> Assets_config.default_mimetype
+
+  let of_cohttp = function
     | Cohttp.Accept.MediaType (m, m_sub) ->
-        List.find_opt (( = ) (m, m_sub)) all_supported
+        Array.find_opt (( = ) (m, m_sub)) arr
-    | AnyMediaSubtype m ->
+    | AnyMediaSubtype m -> Array.find_opt (fun (m', _) -> String.equal m m') arr
-        List.find_opt (fun (m', _) -> String.equal m m') all_supported
+    | AnyMedia -> Some default
-    | AnyMedia -> Some default_mimetype
 
-  let to_extension t =
+  let to_extension_exn t =
     match List.assoc_opt t assoc with
-    | None ->
+    | None -> Fmt.failwith "Mimetype.to_extension failure: `%a` unknown" pp t
-        Fmt.failwith "Mimetype.to_extension failure: `%s/%s` unknown" (fst t)
-          (snd t)
     | Some ext -> ext
-
-  let is_supported mime = List.mem mime all_supported
 end
 
 module Language = struct
   type t = string
 
-  let of_cohttp_language = function
+  let arr = supported_lang_arr
-    | Cohttp.Accept.AnyLanguage -> Some default_lang
+  let default = Assets_config.default_lang
+
+  let of_cohttp = function
+    | Cohttp.Accept.AnyLanguage -> Some default
     | Language language_range -> (
         (* ignore language subtags (e.g. "en-US" -> "en") *)
         match language_range with
@@ -142,8 +163,10 @@ end
 (* ! lang and mime must be supported *)
 let get_content ~lang ~mime t =
   let etag = Headers_lib.Etag.to_raw_string (etag t) in
-  let ext = Mimetype.to_extension mime in
+  let ext = Mimetype.to_extension_exn mime in
-  let path = Fpath.to_string Fpath.((v (base_dir t) / lang / etag) + ext) in
+  let path =
+    Fpath.to_string Fpath.((v (Assets_config.base_dir t) / lang / etag) + ext)
+  in
   match Assets_crunch.read path with
   | None -> Fmt.failwith "static file not found: `%s`" path
   | Some data -> data

src/headers.ml

@@ -1,22 +1,18 @@
-(* TODO header
-   Cohttp -> Http *)
-
 let accept_header_value =
-  let pp_list pp_item item = Fmt.list ~sep:(Fmt.any ", ") pp_item item in
+  Fmt.str "%a"
-  Fmt.str "%a" (pp_list Assets.Mimetype.pp) Assets.Mimetype.all_supported
+    (Fmt.array ~sep:(Fmt.any ", ") Assets.Mimetype.pp)
+    Assets.Mimetype.arr
 
 let avail_languages_header_value =
-  let pp_array pp_item item = Fmt.array ~sep:(Fmt.any ", ") pp_item item in
+  Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) Assets.Language.arr
-  let s = Fmt.str "%a" (pp_array Fmt.string) Assets.supported_lang_arr in
-  s
 
 let select_mimetype headers =
   let opt = Vif.Headers.get headers "accept" in
   Cohttp.Accept.media_ranges opt
   |> Cohttp.Accept.qsort
-  |> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp_media m)
+  |> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp m)
   |> function
-  | None -> Assets.default_mimetype
+  | None -> Assets.Mimetype.default
   | Some mime -> mime
 
 let select_language headers =
@@ -24,9 +20,9 @@ let select_language headers =
   Cohttp.Accept.languages opt
   |> Cohttp.Accept.qsort
   |> List.map snd
-  |> List.find_map Assets.Language.of_cohttp_language
+  |> List.find_map Assets.Language.of_cohttp
   |> function
-  | None -> Assets.default_lang
+  | None -> Assets.Language.default
   | Some lang -> lang
 
 let select_encoding headers =
@@ -38,7 +34,7 @@ let select_encoding headers =
     | Cohttp.Accept.Identity -> Some `Identity
     | Deflate -> Some `DEFLATE
     | Gzip -> Some `Gzip
-    | AnyEncoding -> Some Assets.default_encoding
+    | AnyEncoding -> Some Assets.Assets_config.default_encoding
     | Encoding _ | Compress -> (* unsupported *) None)
   |> function
   | None -> None

src/static.ml

@@ -26,8 +26,8 @@ module Respond_with = struct
     respond `Not_modified
 end
 
-let _aux kind req _server _env =
+let aux asset req _server _env =
-  let etag = Assets.etag kind in
+  let etag = Assets.etag asset in
   let headers = Vif.Request.headers req in
   let has_matching_etag =
     match Vif.Headers.get headers "if-none-match" with
@@ -46,7 +46,7 @@ let _aux kind req _server _env =
       let mime = Headers.select_mimetype headers in
       let lang = Headers.select_language headers in
       let compression = Headers.select_encoding headers in
-      let data = Assets.get_content ~mime ~lang kind in
+      let data = Assets.get_content ~mime ~lang asset in
       (* -- *)
       let open Vif.Response in
       let open Syntax in
@@ -57,7 +57,7 @@ let _aux kind req _server _env =
       in
       let* () =
         (* todo: is it "taler-privacy-version" for /policy ? *)
-        add ~field:"taler-terms-version" Assets.terms_legal_version
+        add ~field:"taler-terms-version" (Assets.legal_version asset)
       in
       (* TODO add compression and mimetype headers too *)
       let* () =
@@ -69,23 +69,6 @@ let _aux kind req _server _env =
       in
       respond `OK
 
-(* WIP DEBUG *)
-let aux _kind req _server _env =
-  let open Vif.Response in
-  let open Syntax in
-  let data = "uhuh" in
-  let etag = "0" in
-  let content_type = "text/plain" in
-  let* () = with_string req data in
-  let* () = add ~field:"etag" etag in
-  let* () =
-    (* todo: is it "taler-privacy-version" for /policy ? *)
-    add ~field:"taler-terms-version" Assets.terms_legal_version
-  in
-  let* () = add ~field:"avail-languages" Headers.avail_languages_header_value in
-  let* () = add ~field:"content-type" content_type in
-  respond `OK
-
 let terms req _server _env =
   Logs.info (fun m -> m "GET /terms");
   aux Assets.Terms req _server _env