From 6cdd1dcf9e6eddbba276ddbf6b0a0042fc09f813 Mon Sep 17 00:00:00 2001 From: Swrup Date: Tue, 23 Sep 2025 20:58:34 +0200 Subject: [PATCH] + ToS stuff --- src/assets/privacy/en/0.html | 4 +- src/assets/privacy/en/0.md | 1 + src/assets/privacy/en/0.txt | 1 + src/assets/terms/en/0.md | 1 + src/assets/terms/en/0.txt | 1 + src/config.ml | 128 +++++++++++++++++++++-------------- src/mte.ml | 118 ++++++++++++++++---------------- 7 files changed, 140 insertions(+), 114 deletions(-) create mode 100644 src/assets/privacy/en/0.md create mode 100644 src/assets/privacy/en/0.txt create mode 100644 src/assets/terms/en/0.md create mode 100644 src/assets/terms/en/0.txt diff --git a/src/assets/privacy/en/0.html b/src/assets/privacy/en/0.html index c9378279..829f6b79 100644 --- a/src/assets/privacy/en/0.html +++ b/src/assets/privacy/en/0.html @@ -2,10 +2,10 @@ - MTE privacy policy + MTE terms -

MTE privacy policy

+

MTE terms

TODO diff --git a/src/assets/privacy/en/0.md b/src/assets/privacy/en/0.md new file mode 100644 index 00000000..419e12ef --- /dev/null +++ b/src/assets/privacy/en/0.md @@ -0,0 +1 @@ +# TODO dummy ToS diff --git a/src/assets/privacy/en/0.txt b/src/assets/privacy/en/0.txt new file mode 100644 index 00000000..419e12ef --- /dev/null +++ b/src/assets/privacy/en/0.txt @@ -0,0 +1 @@ +# TODO dummy ToS diff --git a/src/assets/terms/en/0.md b/src/assets/terms/en/0.md new file mode 100644 index 00000000..419e12ef --- /dev/null +++ b/src/assets/terms/en/0.md @@ -0,0 +1 @@ +# TODO dummy ToS diff --git a/src/assets/terms/en/0.txt b/src/assets/terms/en/0.txt new file mode 100644 index 00000000..419e12ef --- /dev/null +++ b/src/assets/terms/en/0.txt @@ -0,0 +1 @@ +# TODO dummy ToS diff --git a/src/config.ml b/src/config.ml index 2464f1a6..3a350b19 100644 --- a/src/config.ml +++ b/src/config.ml @@ -1,48 +1,65 @@ -(* https://docs.taler.net/manpages/taler-exchange.conf.5.html *) +(* TODO + - don't hard code etag *) +let default_lang = "en" let terms_dir = Fpath.(v "terms") + +(* ETAG is used in static files filenames *) let terms_etag = "0" let privacy_dir = Fpath.(v "privacy") let privacy_etag = "0" -(* todo: should be infered from folder structure? *) -let supported_languages = [| "en"; "fr" |] +(* -- ToS stuff -- *) -(* -let supported_extensions = - [ "html"; "htm"; "txt"; "pdf"; "jpg"; "jpeg"; "png"; "gif" ] - *) +(* docs: + https://docs.taler.net/manpages/taler-exchange.conf.5.html + https://docs.taler.net/design-documents/003-tos-rendering.html *) -let supported_extensions_mimetype_assoc = +(* to simplify code, we enforce that terms and privacy support the same + languages and extensions and that each mimetype is avaible in all languages *) + +(* 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 mimetype_ext_assoc = [ - ("txt", ("text", "plain")); ("html", ("text", "html")) - ; ("htm", ("text", "html")); ("pdf", ("application", "pdf")) - ; ("jpg", ("image", "jpeg")); ("jpeg", ("image", "jpeg")) - ; ("png", ("image", "png")); ("gif", ("image", "gif")) + (("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 terms_assoc, privacy_assoc = +let media_to_ext media = + match media with + | Cohttp.Accept.MediaType (m, m_sub) -> + List.assoc_opt (m, m_sub) mimetype_ext_assoc + | AnyMediaSubtype m -> + List.find_opt (fun ((mm, _), _) -> String.equal m mm) mimetype_ext_assoc + |> Option.map snd + | AnyMedia -> Some "txt" + +let get_ok res = + match res with + | Error (`Msg s) -> Fmt.failwith "static file error: `%s`" s + | Ok l -> l + +let supported_lang_l, supported_ext_l = let open Syntax in - let get_ok res = - match res with - | Error (`Msg s) -> Fmt.failwith "static file error: `%s`" s - | Ok l -> l - in let l = Assets.file_list in List.iter (Fmt.pr "file: %s@.") l; let l = get_ok (list_map (fun s -> Fpath.of_string s) l) in let () = (* check that Assets only contains supported extensions *) - let supported_extensions, _ = - List.split supported_extensions_mimetype_assoc - in + let _, supported_extensions = List.split mimetype_ext_assoc in get_ok @@ list_iter (fun file -> match Fpath.mem_ext supported_extensions file with | true -> Ok () | false -> - Fmt.error_msg "Assets contains ussuported file `%s`" + Fmt.error_msg "Assets contains usupported file `%s`" (Fpath.to_string file)) l in @@ -50,36 +67,45 @@ let terms_assoc, privacy_assoc = let file_l = List.filter_map (fun file -> Fpath.rem_prefix base_dir file) l in - List.fold_left - (fun acc (ext, mime) -> - let lang_l = - List.filter (Fpath.has_ext ext) file_l - |> List.map Fpath.split_base - |> List.map fst - |> List.map Fpath.to_string - in - if List.is_empty lang_l then acc else (mime, (ext, lang_l)) :: acc) - [] supported_extensions_mimetype_assoc + let ext_l = + List.map Fpath.get_ext file_l |> List.sort_uniq String.compare + in + let lang_l = + List.map + (fun path -> + match Fpath.segs path with + | [] -> assert false + | [ dir; _file ] -> + if String.length dir <> 2 then + Fmt.failwith "invalid language directory: `%s`" dir + else dir + | _ -> Fmt.failwith "invalid file `%s`" (Fpath.to_string path)) + file_l + |> List.sort_uniq String.compare + in + let () = + get_ok + (if List.length file_l <> List.length ext_l * List.length lang_l then + Fmt.error_msg "invalid folder structure, missing files?" + else Ok ()) + in + (lang_l, ext_l) in - let terms_assoc = mk terms_dir in - let privacy_assoc = mk privacy_dir in - (terms_assoc, privacy_assoc) + let lang_l, ext_l = mk terms_dir in + let lang_l', ext_l' = mk privacy_dir in + assert ( + List.equal String.equal lang_l lang_l' + && List.equal String.equal ext_l ext_l'); + assert (not @@ List.is_empty lang_l); + assert (not @@ List.is_empty ext_l); + assert (List.mem default_lang lang_l); + assert (List.mem ".txt" ext_l); + assert (List.mem ".md" ext_l); + (lang_l, ext_l) -(* TODO rewrite as one find_opt *) (* assumes l ordered by preferrence *) (* O(n^2) ok because supported length is small *) -let preferred_lang ~supported l = - assert (List.length supported > 0); - assert (List.length l > 0); - let default_lang = List.nth supported 0 in - let l = - List.map (fun s -> if String.equal s "*" then default_lang else s) l - in - let l = List.filter (fun s -> List.mem s supported) l in - List.nth_opt l 0 - -(* - get_terms accept accept_language = - | ok v - | error: `No_mime | `No_lang | `Bad_headers? - *) +let select_preferred_lang l = + assert (not @@ List.is_empty l); + let opt = List.find_opt (fun v -> List.mem v supported_lang_l) l in + opt diff --git a/src/mte.ml b/src/mte.ml index 7945e570..58970c9a 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -14,70 +14,66 @@ You should have received a copy of the GNU Affero General Public License along with this program. If not, see . *) -module Assets = struct - let get path = - let path = Fpath.to_string path in - match Assets.read path with - | None -> Fmt.failwith "asset loading failure `%s`" path - | Some data -> data -end +let get_file path = + let path = Fpath.to_string path in + match Assets.read path with + | None -> Fmt.failwith "asset loading failure `%s`" path + | Some data -> data -let static _kind req _server _env = +let parse_accept_header headers = + let accept = Vif.Headers.get headers "accept" in + Cohttp.Accept.media_ranges accept + |> Cohttp.Accept.qsort + |> List.filter_map (fun (_q, (m, _p)) -> Config.media_to_ext m) + +let parse_accept_language_header headers = + let accept_language = Vif.Headers.get headers "accept-language" in + Cohttp.Accept.languages accept_language + |> Cohttp.Accept.qsort + |> List.map (fun (_q, lang) -> lang) + |> + (* ignore language subtags *) + List.map (function + | Cohttp.Accept.AnyLanguage -> Config.default_lang + | Language l -> ( + match l with + | [] -> + (* todo: is this a assert false? *) + Fmt.failwith "language subtags error" + | primary_tag :: _ -> primary_tag)) + +(* TODO handle errors: + - bad headers + - usupported lang or mimetypes *) +let select_file kind ~accept_l ~accept_language_l = + assert (not @@ List.is_empty accept_l); + assert (not @@ List.is_empty accept_language_l); + let lang, ext = + let opt = + List.find_map + (fun ext -> + match List.mem ext Config.supported_ext_l with + | false -> None + | true -> + Config.select_preferred_lang accept_language_l + |> Option.map (fun lang -> (lang, ext))) + accept_l + in + match opt with + | None -> Fmt.failwith "mimetype or language not supported" + | Some v -> v + in + match kind with + | `Terms -> Fpath.((Config.terms_dir / lang / Config.terms_etag) + ext) + | `Privacy -> Fpath.((Config.privacy_dir / lang / Config.privacy_etag) + ext) + +(* TODO add headers, handle errors etc *) +let static kind req _server _env = let open Vif.Response.Syntax in let headers = Vif.Request.headers req in - let media_l = - let accept = Vif.Headers.get headers "accept" in - Cohttp.Accept.media_ranges accept - |> Cohttp.Accept.qsort - |> List.map (fun (_q, (m, _p)) -> m) - in - let accept_language_l = - let accept_language = Vif.Headers.get headers "accept-language" in - Cohttp.Accept.languages accept_language - |> Cohttp.Accept.qsort - |> List.map (fun (_q, lang) -> lang) - |> - (* ignore language subtags *) - List.map (function - | Cohttp.Accept.AnyLanguage -> "*" - | Language l -> ( - match l with - | [] -> Fmt.failwith "language subtags error" - | primary_tag :: _ -> primary_tag)) - in - (* todo: not sure what to do if no accept-lenguage header *) - assert (List.length accept_language_l > 0); - (* find an approriate extension + supported lang_l *) - let opt = - media_l - |> List.find_map (fun media -> - match media with - | Cohttp.Accept.MediaType (m, m_sub) -> - List.assoc_opt (m, m_sub) Config.terms_assoc - | AnyMediaSubtype m -> - List.find_opt - (fun ((mm, _), _) -> String.equal m mm) - Config.terms_assoc - |> Option.map snd - | AnyMedia -> List.nth_opt Config.terms_assoc 0 |> Option.map snd) - in - let lang, ext = - match opt with - | None -> - (* todo respond with smthing approriate *) - Fmt.failwith "usuported mimetype" - | Some (ext, lang_l) -> ( - (* pick best language to use *) - match Config.preferred_lang ~supported:lang_l accept_language_l with - | None -> - (* todo respond with smthing approriate *) - Fmt.failwith "usuported accepted language" - | Some lang -> (lang, ext)) - in - (* todo add headers ... *) - let data = - Assets.get @@ Fpath.((Config.terms_dir / lang / Config.terms_etag) + ext) - in + let accept_l = parse_accept_header headers in + let accept_language_l = parse_accept_language_header headers in + let data = get_file @@ select_file kind ~accept_l ~accept_language_l in let* () = Vif.Response.with_string ~compression:`Gzip req data in let field = "content-type" in let* () = Vif.Response.add ~field "html; charset=utf-8" in