From 387484d1c23429d4cac9a1b752c8c46ab73106d1 Mon Sep 17 00:00:00 2001 From: swrup Date: Thu, 12 Feb 2026 07:09:37 +0100 Subject: [PATCH] + clean up tos --- src/assets.ml | 178 +++++++++++++++++++++++++++---------------------- src/headers.ml | 22 +++--- src/static.ml | 31 ++------- 3 files changed, 114 insertions(+), 117 deletions(-) diff --git a/src/assets.ml b/src/assets.ml index 9de7212e..4e1b5e1e 100644 --- a/src/assets.ml +++ b/src/assets.ml @@ -1,91 +1,90 @@ -(* doc: 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 + https://docs.taler.net/design-documents/003-tos-rendering.html -(* 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 + must support `text/plain` and `text/markdown` *) -(* TODO how to update ToS version? *) -let terms_legal_version = "0" -let privacy_legal_version = "0" - -(* TODO config *) 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 + let base_dir = function Terms -> "terms" | Privacy -> "privacy" + + (* TODO this should be in the config like terms_etag *) + let terms_legal_version = "0" +end + 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 *) -let supported_lang_arr, supported_ext_arr = - let open Syntax in - let path_l = - Assets_crunch.file_list |> list_map Fpath.of_string |> function - | Error (`Msg e) -> Fmt.failwith "%s" e - | 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 supported_lang_arr, supported_ext_arr = let aux t = - let prefix = Fpath.v (base_dir t) in - let path_l = path_l |> List.filter_map (Fpath.rem_prefix prefix) in + let prefix = Fpath.v (Assets_config.base_dir t) 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 (fun path -> + List.map + (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)) - |> List.sort_uniq String.compare + (Fpath.to_string Fpath.(prefix // path))) + path_l in - let () = - 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 - Fmt.failwith "default language `%s` files not found" 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"; - List.iter - (fun dir -> - if String.length dir <> 2 then - Fmt.failwith "language directory with invalid name: `%s`" dir) - lang_l; - if List.length path_l <> List.length ext_l * List.length lang_l then - Fmt.failwith - "invalid folder structure, all supported language must provide the \ - same set of file mimetype" - in - (lang_l, ext_l) + 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 Assets_config.default_lang lang_l then + 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"; + List.iter + (fun dir -> + if String.length dir <> 2 then + Fmt.failwith "language directory with invalid name: `%s`" dir) + lang_l; + if List.length path_l <> List.length ext_l * List.length lang_l then + Fmt.failwith + "invalid folder structure, all supported language must provide the \ + same set of file mimetype" + else (lang_l, ext_l) in let lang_l, ext_l = aux Terms in let lang_l', ext_l' = aux Privacy in - let () = - if - not - @@ (List.equal String.equal lang_l lang_l' - && List.equal String.equal ext_l ext_l') - then + match + List.equal String.equal lang_l lang_l' + && List.equal String.equal ext_l ext_l' + with + | false -> Fmt.failwith "invalid folder structure, /terms and /privacy must support the same \ - set of languages and mimetypes"; - () - in - (Array.of_list lang_l, Array.of_list ext_l) + set of languages and mimetypes" + | true -> (Array.of_list lang_l, Array.of_list ext_l) module Mimetype = struct type t = string * string @@ -107,30 +106,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 - | AnyMediaSubtype m -> - List.find_opt (fun (m', _) -> String.equal m m') all_supported - | AnyMedia -> Some default_mimetype + Array.find_opt (( = ) (m, m_sub)) arr + | AnyMediaSubtype m -> Array.find_opt (fun (m', _) -> String.equal m m') arr + | AnyMedia -> Some default - let to_extension t = + let to_extension_exn t = match List.assoc_opt t assoc with - | None -> - Fmt.failwith "Mimetype.to_extension failure: `%s/%s` unknown" (fst t) - (snd t) + | None -> Fmt.failwith "Mimetype.to_extension failure: `%a` unknown" pp 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 + let arr = supported_lang_arr + 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 +158,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 path = Fpath.to_string Fpath.((v (base_dir t) / lang / etag) + ext) in + let ext = Mimetype.to_extension_exn mime 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 diff --git a/src/headers.ml b/src/headers.ml index b91e2f7b..0a71820e 100644 --- a/src/headers.ml +++ b/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" (pp_list Assets.Mimetype.pp) Assets.Mimetype.all_supported + Fmt.str "%a" + (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 - let s = Fmt.str "%a" (pp_array Fmt.string) Assets.supported_lang_arr in - s + Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) Assets.Language.arr 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 diff --git a/src/static.ml b/src/static.ml index 4ac3be9e..12f7f017 100644 --- a/src/static.ml +++ b/src/static.ml @@ -26,14 +26,14 @@ module Respond_with = struct respond `Not_modified end -let _aux kind req _server _env = - let etag = Assets.etag kind in +let aux asset req _server _env = + 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 | None -> Ok false | Some s -> - Headers_lib.Etag.parse s |> Result.map (Headers_lib.Etag.evaluate etag) + Result.map (Headers_lib.Etag.evaluate etag) (Headers_lib.Etag.parse s) in match has_matching_etag with | Error e -> @@ -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 @@ -56,10 +56,9 @@ let _aux kind req _server _env = 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 + add ~field:"taler-terms-version" + Assets.Assets_config.terms_legal_version in - (* TODO add compression and mimetype headers too *) let* () = add ~field:"avail-languages" Headers.avail_languages_header_value in @@ -67,25 +66,9 @@ let _aux kind req _server _env = let content_type = Fmt.str "%a" Assets.Mimetype.pp mime in add ~field:"content-type" content_type in + let* () = add ~field:"content-language" lang 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