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