From 619368f8db6a6c3a25e57a026e46a63e98dcc117 Mon Sep 17 00:00:00 2001 From: swrup Date: Tue, 10 Feb 2026 21:49:42 +0100 Subject: [PATCH] wip clean up ToS --- default/assets/privacy/en/0.md | 9 ++- default/assets/privacy/en/0.txt | 9 ++- default/assets/terms/en/0.md | 9 ++- default/assets/terms/en/0.txt | 9 ++- src/assets.ml | 123 ++++++++++++++++---------------- src/headers.ml | 52 +++++--------- src/headers_lib.ml | 9 +-- src/respond_util.ml | 3 + src/static.ml | 76 ++++++++------------ test/crypto.ml | 4 ++ 10 files changed, 150 insertions(+), 153 deletions(-) diff --git a/default/assets/privacy/en/0.md b/default/assets/privacy/en/0.md index 419e12ef..9c8e6b15 100644 --- a/default/assets/privacy/en/0.md +++ b/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 diff --git a/default/assets/privacy/en/0.txt b/default/assets/privacy/en/0.txt index 419e12ef..9c8e6b15 100644 --- a/default/assets/privacy/en/0.txt +++ b/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 diff --git a/default/assets/terms/en/0.md b/default/assets/terms/en/0.md index 419e12ef..033a5937 100644 --- a/default/assets/terms/en/0.md +++ b/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 diff --git a/default/assets/terms/en/0.txt b/default/assets/terms/en/0.txt index 419e12ef..033a5937 100644 --- a/default/assets/terms/en/0.txt +++ b/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 diff --git a/src/assets.ml b/src/assets.ml index 9d6c8088..9de7212e 100644 --- a/src/assets.ml +++ b/src/assets.ml @@ -1,55 +1,15 @@ -(* TODO clean up *) - -(* docs: https://docs.taler.net/manpages/taler-exchange.conf.5.html - https://docs.taler.net/design-documents/003-tos-rendering.html *) +(* doc: https://docs.taler.net/design-documents/003-tos-rendering.html + - must support `text/plain` and `text/markdown` *) (* 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 privacy_legal_version = "1" +let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity -module Mimetype = struct - let mimetype_extension_assoc = - [ - (("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 how to update ToS version? *) +let terms_legal_version = "0" +let privacy_legal_version = "0" (* TODO config *) type t = @@ -65,11 +25,9 @@ let legal_version = function | Terms -> terms_legal_version | Privacy -> privacy_legal_version -let base_dir = function - | Terms -> Fpath.v "terms" - | Privacy -> Fpath.v "privacy" +let base_dir = function Terms -> "terms" | Privacy -> "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 = - Array.map Mimetype.of_extension supported_ext_arr |> Array.map Option.get +module Mimetype = struct + type t = string * string -let is_supported_lang lang = Array.mem lang supported_lang_arr -let is_supported_ext ext = Array.mem ext supported_ext_arr -let is_supported_mimetype mime = Array.mem mime supported_mimetype_arr + let pp fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime) + + 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 = - match Mimetype.to_extension mime with - | 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 + let ext = Mimetype.to_extension mime in + let path = Fpath.to_string Fpath.((v (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 diff --git a/src/headers.ml b/src/headers.ml index f41fc976..b91e2f7b 100644 --- a/src/headers.ml +++ b/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 = - Fmt.str "%a" - (pp_array Assets.Mimetype.pp_mime) - Assets.supported_mimetype_arr - in - s + let pp_list pp_item item = Fmt.list ~sep:(Fmt.any ", ") pp_item item in + Fmt.str "%a" (pp_list Assets.Mimetype.pp) Assets.Mimetype.all_supported 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_opt Assets.is_supported_mimetype + |> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp_media m) + |> 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 (function - | Cohttp.Accept.AnyLanguage -> Assets.default_lang - | Language language_range -> ( - (* ignore language subtags (e.g. "en-US" -> "en") *) - match language_range with - | [] -> assert false - | primary_tag :: _ -> primary_tag)) - |> List.find_opt Assets.is_supported_lang - |> Option.value ~default:Assets.default_lang + |> List.map snd + |> List.find_map Assets.Language.of_cohttp_language + |> function + | None -> Assets.default_lang + | Some lang -> 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 - | `Identity :: _ -> None - | `DEFLATE :: _ -> Some `DEFLATE - | `Gzip :: _ -> Some `Gzip + | None -> None + | Some `Identity -> None + | Some `DEFLATE -> Some `DEFLATE + | Some `Gzip -> Some `Gzip diff --git a/src/headers_lib.ml b/src/headers_lib.ml index b26f5da1..ce9c7257 100644 --- a/src/headers_lib.ml +++ b/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 - its fine *) +(* TODO clean up *) module Etag : sig - (* module to parse etags header fields used by If-Match and If-None-Match - headers + (* https://httpwg.org/specs/rfc9110.html#field.etag *) - https://httpwg.org/specs/rfc9110.html#field.etag *) type t type header_value diff --git a/src/respond_util.ml b/src/respond_util.ml index 3c4faf5d..0303c12c 100644 --- a/src/respond_util.ml +++ b/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 diff --git a/src/static.ml b/src/static.ml index 52a7278d..4ac3be9e 100644 --- a/src/static.ml +++ b/src/static.ml @@ -1,14 +1,6 @@ -(* TODO check for mathcing ETAG with a middleware instead? *) -(* /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 *) +(* /terms + /privacy *) +(* 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 -> ( - match Headers.select_mimetype headers with - | None -> - Logs.err (fun m -> m "unsupported_media_type"); - Respond_with.unsupported_media_type req - | Some mime -> - let lang = Headers.select_language headers in - let compression = Headers.select_encoding headers in - let data = Assets.get_content ~mime ~lang kind in - (* -- *) - let open Vif.Response in - let open Syntax in - let* () = with_string ?compression req data in - let* () = - let etag_field_value = Headers_lib.Etag.to_field_value etag in - add ~field:"etag" etag_field_value - 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* () = - let content_type = Fmt.str "%a" Assets.Mimetype.pp_mime mime in - add ~field:"content-type" content_type - in - respond `OK) + | Ok false -> + 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 open Vif.Response in + let open Syntax in + let* () = with_string ?compression req data in + let* () = + let etag_field_value = Headers_lib.Etag.to_field_value etag in + add ~field:"etag" etag_field_value + in + let* () = + (* todo: is it "taler-privacy-version" for /policy ? *) + add ~field:"taler-terms-version" Assets.terms_legal_version + in + (* TODO add compression and mimetype headers too *) + let* () = + add ~field:"avail-languages" Headers.avail_languages_header_value + in + let* () = + let content_type = Fmt.str "%a" Assets.Mimetype.pp mime in + add ~field:"content-type" content_type + in + respond `OK (* WIP DEBUG *) let aux _kind req _server _env = diff --git a/test/crypto.ml b/test/crypto.ml index e2d007c9..83650235 100644 --- a/test/crypto.ml +++ b/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 =