swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

+ ToS stuff

Browse source
This commit is contained in:
Swrup 2025-09-23 20:58:34 +02:00
parent 2eb42f51cc
commit 6cdd1dcf9e
7 changed files with 140 additions and 114 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/assets/privacy/en/0.html
View file

@ -2,10 +2,10 @@
<html lang="en">
<head>
<meta charset="UTF-8">
<title>MTE privacy policy</title>
<title>MTE terms</title>
</head>
<body>
<h1>MTE privacy policy</h1>
<h1>MTE terms</h1>
TODO
</body>
</html>

1
src/assets/privacy/en/0.md Normal file
View file

@ -0,0 +1 @@
# TODO dummy ToS

1
src/assets/privacy/en/0.txt Normal file
View file

@ -0,0 +1 @@
# TODO dummy ToS

1
src/assets/terms/en/0.md Normal file
View file

@ -0,0 +1 @@
# TODO dummy ToS

1
src/assets/terms/en/0.txt Normal file
View file

@ -0,0 +1 @@
# TODO dummy ToS

118
src/config.ml
View file

@ -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 open Syntax in
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
in
let supported_lang_l, supported_ext_l =
let open Syntax 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 ext_l =
List.map Fpath.get_ext file_l |> List.sort_uniq String.compare
in
let lang_l =
List.filter (Fpath.has_ext ext) file_l
|> List.map Fpath.split_base
|> List.map fst
|> List.map Fpath.to_string
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
if List.is_empty lang_l then acc else (mime, (ext, lang_l)) :: acc)
[] supported_extensions_mimetype_assoc
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
let terms_assoc = mk terms_dir in
let privacy_assoc = mk privacy_dir in
(terms_assoc, privacy_assoc)
(lang_l, ext_l)
in
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

82
src/mte.ml
View file

@ -14,24 +14,19 @@
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>. *)
module Assets = struct
let get path =
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
end
let static _kind req _server _env =
let open Vif.Response.Syntax in
let headers = Vif.Request.headers req in
let media_l =
let parse_accept_header headers =
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 =
|> 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
@ -39,45 +34,46 @@ let static _kind req _server _env =
|>
(* ignore language subtags *)
List.map (function
| Cohttp.Accept.AnyLanguage -> "*"
| Cohttp.Accept.AnyLanguage -> Config.default_lang
| Language l -> (
match l with
| [] -> Fmt.failwith "language subtags error"
| [] ->
(* todo: is this a assert false? *)
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
(* 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 ->
(* 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)
| 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 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