wip clean up ToS

default/assets/privacy/en/0.md

@@ -1 +1,8 @@
-# TODO dummy ToS
+# Privacy Policy
+
+Welcome!
+This is a placeholder Privacy Policy file.
+
+
+------------------------------------------
+MTE - the MirageOS Taler Exchange

default/assets/privacy/en/0.txt

@@ -1 +1,8 @@
-# TODO dummy ToS
+# Privacy Policy
+
+Welcome!
+This is a placeholder Privacy Policy file.
+
+
+------------------------------------------
+MTE - the MirageOS Taler Exchange

default/assets/terms/en/0.md

@@ -1 +1,8 @@
-# TODO dummy ToS
+# Terms of Service
+
+Welcome!
+This is a placeholder Terms of Service file.
+
+
+------------------------------------------
+MTE - the MirageOS Taler Exchange

default/assets/terms/en/0.txt

@@ -1 +1,8 @@
-# TODO dummy ToS
+# Terms of Service
+
+Welcome!
+This is a placeholder Terms of Service file.
+
+
+------------------------------------------
+MTE - the MirageOS Taler Exchange

src/assets.ml

@@ -1,55 +1,15 @@
-(* TODO clean up *)
+(* doc: https://docs.taler.net/design-documents/003-tos-rendering.html
-
+   - must support `text/plain` and `text/markdown` *)
-(* docs: https://docs.taler.net/manpages/taler-exchange.conf.5.html
-   https://docs.taler.net/design-documents/003-tos-rendering.html *)
 
 (* hardcoded config just for static assets *)
 let default_lang = "en"
-let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
-
-(* todo: Taler documentation markdown mimetype should be the prefered one, and be
-   supported, according to DD we take text/plain as default instead for now *)
 let default_mimetype = ("text", "plain")
 let default_extension = ".txt"
-let terms_legal_version = "1"
+let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
-let privacy_legal_version = "1"
 
-module Mimetype = struct
+(* TODO how to update ToS version? *)
-  let mimetype_extension_assoc =
+let terms_legal_version = "0"
-    [
+let privacy_legal_version = "0"
-      (("text", "plain"), ".txt");
-      (("text", "markdown"), ".md");
-      (("text", "html"), ".html");
-      (("text", "html"), ".htm");
-      (("application", "pdf"), ".pdf");
-      (("image", "jpeg"), ".jpg");
-      (("image", "jpeg"), ".jpeg");
-      (("image", "png"), ".png");
-      (("image", "gif"), ".gif");
-    ]
-
-  let mimetype_l, _ = List.split mimetype_extension_assoc
-
-  let of_cohttp_media = function
-    | Cohttp.Accept.MediaType (m, m_sub) ->
-        List.find_opt (( = ) (m, m_sub)) mimetype_l
-    | AnyMediaSubtype m ->
-        List.find_opt (fun (m', _) -> String.equal m m') mimetype_l
-    | AnyMedia -> Some default_mimetype
-
-  let to_extension (m, m_sub) =
-    assert (m <> "*");
-    assert (m_sub <> "*");
-    List.assoc_opt (m, m_sub) mimetype_extension_assoc
-
-  let of_extension ext =
-    List.find_map
-      (fun (mime, ext') ->
-        match String.equal ext ext' with false -> None | true -> Some mime)
-      mimetype_extension_assoc
-
-  let pp_mime fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime)
-end
 
 (* TODO config *)
 type t =
@@ -65,11 +25,9 @@ let legal_version = function
   | Terms -> terms_legal_version
   | Privacy -> privacy_legal_version
 
-let base_dir = function
+let base_dir = function Terms -> "terms" | Privacy -> "privacy"
-  | Terms -> Fpath.v "terms"
-  | Privacy -> Fpath.v "privacy"
 
-(* does some checks on assets/ folder content and infer the set of supported languages and mimetype *)
+(* TODO clean up this horror *)
 let supported_lang_arr, supported_ext_arr =
   let open Syntax in
   let path_l =
@@ -78,7 +36,7 @@ let supported_lang_arr, supported_ext_arr =
     | Ok x -> x
   in
   let aux t =
-    let prefix = base_dir t in
+    let prefix = Fpath.v (base_dir t) in
     let path_l = path_l |> List.filter_map (Fpath.rem_prefix prefix) in
     let ext_l =
       path_l |> List.map Fpath.get_ext |> List.sort_uniq String.compare
@@ -129,22 +87,63 @@ let supported_lang_arr, supported_ext_arr =
   in
   (Array.of_list lang_l, Array.of_list ext_l)
 
-let supported_mimetype_arr =
+module Mimetype = struct
-  Array.map Mimetype.of_extension supported_ext_arr |> Array.map Option.get
+  type t = string * string
 
-let is_supported_lang lang = Array.mem lang supported_lang_arr
+  let pp fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime)
-let is_supported_ext ext = Array.mem ext supported_ext_arr
+
-let is_supported_mimetype mime = Array.mem mime supported_mimetype_arr
+  let assoc =
+    List.filter
+      (fun (_mime, ext) -> Array.mem ext supported_ext_arr)
+      [
+        (("text", "plain"), ".txt");
+        (("text", "markdown"), ".md");
+        (("text", "html"), ".html");
+        (("text", "html"), ".htm");
+        (("application", "pdf"), ".pdf");
+        (("image", "jpeg"), ".jpg");
+        (("image", "jpeg"), ".jpeg");
+        (("image", "png"), ".png");
+        (("image", "gif"), ".gif");
+      ]
+
+  let all_supported, _ = List.split assoc
+
+  let of_cohttp_media = function
+    | Cohttp.Accept.MediaType (m, m_sub) ->
+        List.find_opt (( = ) (m, m_sub)) all_supported
+    | AnyMediaSubtype m ->
+        List.find_opt (fun (m', _) -> String.equal m m') all_supported
+    | AnyMedia -> Some default_mimetype
+
+  let to_extension t =
+    match List.assoc_opt t assoc with
+    | None ->
+        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
+    | Cohttp.Accept.AnyLanguage -> Some default_lang
+    | Language language_range -> (
+        (* ignore language subtags (e.g. "en-US" -> "en") *)
+        match language_range with
+        | [] -> assert false
+        | lang :: _ when Array.mem lang supported_lang_arr -> Some lang
+        | _ -> None)
+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 =
+  let ext = Mimetype.to_extension mime in
-    match Mimetype.to_extension mime with
+  let path = Fpath.to_string Fpath.((v (base_dir t) / lang / etag) + ext) in
-    | None -> Fmt.failwith "mimetype `%s/%s` unknown" (fst mime) (snd mime)
-    | Some ext -> ext
-  in
-  let path = Fpath.to_string Fpath.((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,61 +1,47 @@
-let pp_array pp_item item = Fmt.array ~sep:(Fmt.any ", ") pp_item item
+(* TODO header
+   Cohttp -> Http *)
 
 let accept_header_value =
-  let s =
+  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
-      (pp_array Assets.Mimetype.pp_mime)
-      Assets.supported_mimetype_arr
-  in
-  s
 
 let avail_languages_header_value =
+  let pp_array pp_item item = Fmt.array ~sep:(Fmt.any ", ") pp_item item in
   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
-  Logs.err (fun m ->
-      let s = Option.value ~default:"none" opt in
-      m "Header accept: %s" s);
   Cohttp.Accept.media_ranges opt
   |> Cohttp.Accept.qsort
-  |> List.filter_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp_media m)
+  |> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp_media m)
-  |> List.find_opt Assets.is_supported_mimetype
+  |> function
+  | None -> Assets.default_mimetype
+  | Some mime -> mime
 
 let select_language headers =
   let opt = Vif.Headers.get headers "accept-language" in
-  Logs.err (fun m ->
-      let s = Option.value ~default:"none" opt in
-      m "Header accept-language: %s" s);
   Cohttp.Accept.languages opt
   |> Cohttp.Accept.qsort
-  |> List.map (fun (_q, lang) -> lang)
+  |> List.map snd
-  |> List.map (function
+  |> List.find_map Assets.Language.of_cohttp_language
-    | Cohttp.Accept.AnyLanguage -> Assets.default_lang
+  |> function
-    | Language language_range -> (
+  | None -> Assets.default_lang
-        (* ignore language subtags (e.g. "en-US" -> "en") *)
+  | Some lang -> lang
-        match language_range with
-        | [] -> assert false
-        | primary_tag :: _ -> primary_tag))
-  |> List.find_opt Assets.is_supported_lang
-  |> Option.value ~default:Assets.default_lang
 
 let select_encoding headers =
   let opt = Vif.Headers.get headers "accept-encoding" in
-  Logs.err (fun m ->
-      let s = Option.value ~default:"none" opt in
-      m "Header accept-encoding: %s" s);
   Cohttp.Accept.encodings opt
   |> Cohttp.Accept.qsort
   |> List.map snd
-  |> List.filter_map (function
+  |> List.find_map (function
     | Cohttp.Accept.Identity -> Some `Identity
     | Deflate -> Some `DEFLATE
     | Gzip -> Some `Gzip
     | AnyEncoding -> Some Assets.default_encoding
     | Encoding _ | Compress -> (* unsupported *) None)
   |> function
-  | [] -> assert false
+  | None -> None
-  | `Identity :: _ -> None
+  | Some `Identity -> None
-  | `DEFLATE :: _ -> Some `DEFLATE
+  | Some `DEFLATE -> Some `DEFLATE
-  | `Gzip :: _ -> Some `Gzip
+  | Some `Gzip -> Some `Gzip

src/headers_lib.ml

@@ -1,12 +1,9 @@
-(* independent library for headers fields value *)
+(* library for headers fields value *)
 
-(* TODO - test - can still bypass this module and directly set Etag header, but
+(* TODO clean up *)
-   its fine *)
 module Etag : sig
-  (* module to parse etags header fields used by If-Match and If-None-Match
+  (* https://httpwg.org/specs/rfc9110.html#field.etag *)
-     headers
 
-     https://httpwg.org/specs/rfc9110.html#field.etag *)
   type t
   type header_value
 

src/respond_util.ml

@@ -1,3 +1,6 @@
+(* TODO response
+   use ErrorDetail *)
+
 let respond_with_plain_text_error ?status e req =
   let open Vif.Response in
   let open Syntax in

src/static.ml

@@ -1,14 +1,6 @@
-(* TODO check for mathcing ETAG with a middleware instead? *)
+(* /terms + /privacy *)
-(* /terms + /privacy
-   - try to find a response with an acceptable mime-type
-   - pick the version in the most preferred language of the user
-   - apply compression if that is allowed by the client
-   - set ETAG header
-   - If it did not change, a "304 Not Modified" response will be returned
-   - A "Taler-Terms-Version" header is generated to indicate the legal version of the terms
-   - When returning a full response (not a "304 Not Modified"),
-     include a "Avail-Languages" header: a comma-separated list of the languages available *)
 
+(* TODO response *)
 module Respond_with = struct
   open Vif.Response
   open Syntax
@@ -32,15 +24,6 @@ module Respond_with = struct
   let not_modified () =
     let* () = empty in
     respond `Not_modified
-
-  let unsupported_media_type req =
-    let body =
-      error_detail ~hint:"no acceptable mimetype" `Unsupported_media_type
-    in
-    let* () = add ~field:"content-type" "application/json" in
-    let* () = add ~field:"accept" Headers.accept_header_value in
-    let* () = with_string ?compression:None req body in
-    respond `Unsupported_media_type
 end
 
 let _aux kind req _server _env =
@@ -59,35 +42,32 @@ let _aux kind req _server _env =
   | Ok true ->
       Logs.err (fun m -> m "not modified");
       Respond_with.not_modified ()
-  | Ok false -> (
+  | Ok false ->
-      match Headers.select_mimetype headers with
+      let mime = Headers.select_mimetype headers in
-      | None ->
+      let lang = Headers.select_language headers in
-          Logs.err (fun m -> m "unsupported_media_type");
+      let compression = Headers.select_encoding headers in
-          Respond_with.unsupported_media_type req
+      let data = Assets.get_content ~mime ~lang kind in
-      | Some mime ->
+      (* -- *)
-          let lang = Headers.select_language headers in
+      let open Vif.Response in
-          let compression = Headers.select_encoding headers in
+      let open Syntax in
-          let data = Assets.get_content ~mime ~lang kind in
+      let* () = with_string ?compression req data in
-          (* -- *)
+      let* () =
-          let open Vif.Response in
+        let etag_field_value = Headers_lib.Etag.to_field_value etag in
-          let open Syntax in
+        add ~field:"etag" etag_field_value
-          let* () = with_string ?compression req data in
+      in
-          let* () =
+      let* () =
-            let etag_field_value = Headers_lib.Etag.to_field_value etag in
+        (* todo: is it "taler-privacy-version" for /policy ? *)
-            add ~field:"etag" etag_field_value
+        add ~field:"taler-terms-version" Assets.terms_legal_version
-          in
+      in
-          let* () =
+      (* TODO add compression and mimetype headers too *)
-            (* todo: is it "taler-privacy-version" for /policy ? *)
+      let* () =
-            add ~field:"taler-terms-version" Assets.terms_legal_version
+        add ~field:"avail-languages" Headers.avail_languages_header_value
-          in
+      in
-          let* () =
+      let* () =
-            add ~field:"avail-languages" Headers.avail_languages_header_value
+        let content_type = Fmt.str "%a" Assets.Mimetype.pp mime in
-          in
+        add ~field:"content-type" content_type
-          let* () =
+      in
-            let content_type = Fmt.str "%a" Assets.Mimetype.pp_mime mime in
+      respond `OK
-            add ~field:"content-type" content_type
-          in
-          respond `OK)
 
 (* WIP DEBUG *)
 let aux _kind req _server _env =

test/crypto.ml

@@ -10,6 +10,10 @@ let () =
   let s_l = List.init 0x0f (fun i -> String.init i Char.chr) in
   List.iter round_trip s_l; ()
 
+(* TODO *)
+(* test vectors from:
+   https://git.gnunet.org/gnunet/gnunet/file/src/cli/util/crypto-test-vectors.json.html *)
+
 let () =
   let input = "91JPRV3F5GG4EKJNDSJQ8" in
   let expected =