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"> <html lang="en">
<head> <head>
<meta charset="UTF-8"> <meta charset="UTF-8">
<title>MTE privacy policy</title> <title>MTE terms</title>
</head> </head>
<body> <body>
<h1>MTE privacy policy</h1> <h1>MTE terms</h1>
TODO TODO
</body> </body>
</html> </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

120
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") let terms_dir = Fpath.(v "terms")
(* ETAG is used in static files filenames *)
let terms_etag = "0" let terms_etag = "0"
let privacy_dir = Fpath.(v "privacy") let privacy_dir = Fpath.(v "privacy")
let privacy_etag = "0" let privacy_etag = "0"
(* todo: should be infered from folder structure? *) (* -- ToS stuff -- *)
let supported_languages = [| "en"; "fr" |]
(* (* docs:
let supported_extensions = https://docs.taler.net/manpages/taler-exchange.conf.5.html
[ "html"; "htm"; "txt"; "pdf"; "jpg"; "jpeg"; "png"; "gif" ] 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")) (("text", "plain"), "txt"); (("text", "markdown"), "md")
; ("htm", ("text", "html")); ("pdf", ("application", "pdf")) ; (("text", "html"), "html"); (("text", "html"), "htm")
; ("jpg", ("image", "jpeg")); ("jpeg", ("image", "jpeg")) ; (("application", "pdf"), "pdf"); (("image", "jpeg"), "jpg")
; ("png", ("image", "png")); ("gif", ("image", "gif")) ; (("image", "jpeg"), "jpeg"); (("image", "png"), "png")
; (("image", "gif"), "gif")
] ]
let terms_assoc, privacy_assoc = let media_to_ext media =
let open Syntax in match media with
let get_ok res = | 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 match res with
| Error (`Msg s) -> Fmt.failwith "static file error: `%s`" s | Error (`Msg s) -> Fmt.failwith "static file error: `%s`" s
| Ok l -> l | Ok l -> l
in
let supported_lang_l, supported_ext_l =
let open Syntax in
let l = Assets.file_list in let l = Assets.file_list in
List.iter (Fmt.pr "file: %s@.") l; List.iter (Fmt.pr "file: %s@.") l;
let l = get_ok (list_map (fun s -> Fpath.of_string s) l) in let l = get_ok (list_map (fun s -> Fpath.of_string s) l) in
let () = let () =
(* check that Assets only contains supported extensions *) (* check that Assets only contains supported extensions *)
let supported_extensions, _ = let _, supported_extensions = List.split mimetype_ext_assoc in
List.split supported_extensions_mimetype_assoc
in
get_ok get_ok
@@ list_iter @@ list_iter
(fun file -> (fun file ->
match Fpath.mem_ext supported_extensions file with match Fpath.mem_ext supported_extensions file with
| true -> Ok () | true -> Ok ()
| false -> | false ->
Fmt.error_msg "Assets contains ussuported file `%s`" Fmt.error_msg "Assets contains usupported file `%s`"
(Fpath.to_string file)) (Fpath.to_string file))
l l
in in
@ -50,36 +67,45 @@ let terms_assoc, privacy_assoc =
let file_l = let file_l =
List.filter_map (fun file -> Fpath.rem_prefix base_dir file) l List.filter_map (fun file -> Fpath.rem_prefix base_dir file) l
in in
List.fold_left let ext_l =
(fun acc (ext, mime) -> List.map Fpath.get_ext file_l |> List.sort_uniq String.compare
in
let lang_l = let lang_l =
List.filter (Fpath.has_ext ext) file_l List.map
|> List.map Fpath.split_base (fun path ->
|> List.map fst match Fpath.segs path with
|> List.map Fpath.to_string | [] -> 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 in
if List.is_empty lang_l then acc else (mime, (ext, lang_l)) :: acc) let () =
[] supported_extensions_mimetype_assoc 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 in
let terms_assoc = mk terms_dir in (lang_l, ext_l)
let privacy_assoc = mk privacy_dir in 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 *) (* assumes l ordered by preferrence *)
(* O(n^2) ok because supported length is small *) (* O(n^2) ok because supported length is small *)
let preferred_lang ~supported l = let select_preferred_lang l =
assert (List.length supported > 0); assert (not @@ List.is_empty l);
assert (List.length l > 0); let opt = List.find_opt (fun v -> List.mem v supported_lang_l) l in
let default_lang = List.nth supported 0 in opt
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?
*)

82
src/mte.ml
View file

@ -14,24 +14,19 @@
You should have received a copy of the GNU Affero General Public License 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/>. *) along with this program. If not, see <https://www.gnu.org/licenses/>. *)
module Assets = struct let get_file path =
let get path =
let path = Fpath.to_string path in let path = Fpath.to_string path in
match Assets.read path with match Assets.read path with
| None -> Fmt.failwith "asset loading failure `%s`" path | None -> Fmt.failwith "asset loading failure `%s`" path
| Some data -> data | Some data -> data
end
let static _kind req _server _env = let parse_accept_header headers =
let open Vif.Response.Syntax in
let headers = Vif.Request.headers req in
let media_l =
let accept = Vif.Headers.get headers "accept" in let accept = Vif.Headers.get headers "accept" in
Cohttp.Accept.media_ranges accept Cohttp.Accept.media_ranges accept
|> Cohttp.Accept.qsort |> Cohttp.Accept.qsort
|> List.map (fun (_q, (m, _p)) -> m) |> List.filter_map (fun (_q, (m, _p)) -> Config.media_to_ext m)
in
let accept_language_l = let parse_accept_language_header headers =
let accept_language = Vif.Headers.get headers "accept-language" in let accept_language = Vif.Headers.get headers "accept-language" in
Cohttp.Accept.languages accept_language Cohttp.Accept.languages accept_language
|> Cohttp.Accept.qsort |> Cohttp.Accept.qsort
@ -39,45 +34,46 @@ let static _kind req _server _env =
|> |>
(* ignore language subtags *) (* ignore language subtags *)
List.map (function List.map (function
| Cohttp.Accept.AnyLanguage -> "*" | Cohttp.Accept.AnyLanguage -> Config.default_lang
| Language l -> ( | Language l -> (
match l with match l with
| [] -> Fmt.failwith "language subtags error" | [] ->
(* todo: is this a assert false? *)
Fmt.failwith "language subtags error"
| primary_tag :: _ -> primary_tag)) | primary_tag :: _ -> primary_tag))
in
(* todo: not sure what to do if no accept-lenguage header *) (* TODO handle errors:
assert (List.length accept_language_l > 0); - bad headers
(* find an approriate extension + supported lang_l *) - usupported lang or mimetypes *)
let opt = let select_file kind ~accept_l ~accept_language_l =
media_l assert (not @@ List.is_empty accept_l);
|> List.find_map (fun media -> assert (not @@ List.is_empty accept_language_l);
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 = 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 match opt with
| None -> | None -> Fmt.failwith "mimetype or language not supported"
(* todo respond with smthing approriate *) | Some v -> v
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 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* () = Vif.Response.with_string ~compression:`Gzip req data in
let field = "content-type" in let field = "content-type" in
let* () = Vif.Response.add ~field "html; charset=utf-8" in let* () = Vif.Response.add ~field "html; charset=utf-8" in