diff --git a/src/assets.ml b/src/assets.ml
new file mode 100644
index 00000000..50dc56bb
--- /dev/null
+++ b/src/assets.ml
@@ -0,0 +1,100 @@
+(* module to handle assets.
+ for now, assets are defined to all be in `src/assets/` folder.
+ crunched into the [Assets_crunch] module.
+
+ to keep it simple, we require that /terms and /privacy support the same
+ set of languages X mimetypes *)
+
+(* docs:
+ https://docs.taler.net/manpages/taler-exchange.conf.5.html
+ https://docs.taler.net/design-documents/003-tos-rendering.html *)
+
+type kind = Terms | Privacy
+
+(* TODO
+ better use of Fmt to have error prefix or smthing
+ use Logs *)
+(* does some checks on assets/ folder content and infer the set of supported languages and mimetype *)
+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
+ in
+ let aux kind =
+ let base_dir =
+ match kind with
+ | Terms -> Config.terms_dir
+ | Privacy -> Config.privacy_dir
+ in
+ let path_l = path_l |> List.filter_map (Fpath.rem_prefix base_dir) 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 ->
+ 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
+ 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 Config.default_lang lang_l then
+ Fmt.failwith "default language `%s` files not found" 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"
+ in
+ (lang_l, ext_l)
+ in
+ let lang_l, ext_l = aux Terms in
+ let lang_l', ext_l' = aux Privacy in
+ let () =
+ List.iter
+ (fun path ->
+ if not @@ Util.is_valid_filename path then
+ Fmt.failwith "file `%s` has an unsupported extension"
+ (Fpath.to_string path))
+ path_l;
+ if
+ not
+ @@ (List.equal String.equal lang_l lang_l'
+ && List.equal String.equal ext_l ext_l')
+ then
+ 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)
+
+let is_supported_lang lang = Array.mem lang supported_lang_arr
+let is_supported_ext ext = Array.mem ext supported_ext_arr
+
+let get_content ~lang ~ext kind =
+ let path =
+ let open Config in
+ match kind with
+ | Terms -> Fpath.((terms_dir / lang / terms_etag) + ext)
+ | Privacy -> Fpath.((privacy_dir / lang / privacy_etag) + ext)
+ in
+ let path_str = Fpath.to_string path in
+ match Assets_crunch.read path_str with
+ | None -> Fmt.error "static file not found: `%s`" path_str
+ | Some data -> Ok data
diff --git a/src/assets/privacy/en/0.html b/src/assets/privacy/en/0.html
deleted file mode 100644
index c9378279..00000000
--- a/src/assets/privacy/en/0.html
+++ /dev/null
@@ -1,11 +0,0 @@
-
-
-
-
- MTE privacy policy
-
-
- MTE privacy policy
- 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.html b/src/assets/terms/en/0.html
deleted file mode 100644
index 829f6b79..00000000
--- a/src/assets/terms/en/0.html
+++ /dev/null
@@ -1,11 +0,0 @@
-
-
-
-
- MTE terms
-
-
- MTE terms
- TODO
-
-
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..5540de6b 100644
--- a/src/config.ml
+++ b/src/config.ml
@@ -1,85 +1,12 @@
-(* https://docs.taler.net/manpages/taler-exchange.conf.5.html *)
+let default_lang = "en"
+
+(* TODO
+ generate `config.ml` from config file (virtual module)?
+ no relative path *)
let terms_dir = Fpath.(v "terms")
-let terms_etag = "0"
let privacy_dir = Fpath.(v "privacy")
+
+(* ETAG is used as filename *)
+let terms_etag = "0"
let privacy_etag = "0"
-
-(* todo: should be infered from folder structure? *)
-let supported_languages = [| "en"; "fr" |]
-
-(*
-let supported_extensions =
- [ "html"; "htm"; "txt"; "pdf"; "jpg"; "jpeg"; "png"; "gif" ]
- *)
-
-let supported_extensions_mimetype_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"))
- ]
-
-let terms_assoc, privacy_assoc =
- 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
- 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`"
- (Fpath.to_string file))
- l
- in
- let mk base_dir =
- 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
- in
- let terms_assoc = mk terms_dir in
- let privacy_assoc = mk privacy_dir in
- (terms_assoc, privacy_assoc)
-
-(* 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?
- *)
diff --git a/src/dune b/src/dune
index 397a7942..056d3d88 100644
--- a/src/dune
+++ b/src/dune
@@ -1,11 +1,11 @@
(executable
(public_name mte)
(name mte)
- (modules assets mte config syntax)
+ (modules assets assets_crunch mte config util syntax)
(libraries vif fmt jsont cohttp))
(rule
- (target assets.ml)
+ (target assets_crunch.ml)
(deps
(source_tree assets))
(action
diff --git a/src/mte.ml b/src/mte.ml
index 7945e570..15b479e9 100644
--- a/src/mte.ml
+++ b/src/mte.ml
@@ -14,82 +14,87 @@
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 static _kind req _server _env =
- let open Vif.Response.Syntax in
- let headers = Vif.Request.headers req in
- let media_l =
+module Header_util = struct
+ let parse_accept_header =
+ fun 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 =
+ |>
+ (* TODO check that its not in reverse order *)
+ Cohttp.Accept.qsort
+ |> List.filter_map (fun (_q, (m, _p)) -> Util.media_to_extension 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 -> "*"
- | 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* () = Vif.Response.with_string ~compression:`Gzip req data in
- let field = "content-type" in
- let* () = Vif.Response.add ~field "html; charset=utf-8" in
- Vif.Response.respond `OK
+ |> List.map (function
+ | Cohttp.Accept.AnyLanguage -> Config.default_lang
+ | Language language_range -> (
+ (* ignore language subtags (e.g. "en-US" -> "en") *)
+ match language_range with
+ | [] -> assert false
+ | primary_tag :: _ -> primary_tag))
+end
+
+module Static = struct
+ (* TODO handle errors:
+ - bad headers
+ - see what to do if usupported lang or ext *)
+ (* assumes accept_ext_l and accept_lang_l to be sorted by preference *)
+ let select_file ~accept_lang_l ~accept_ext_l kind =
+ let open Syntax in
+ let* () =
+ if List.is_empty accept_ext_l then Fmt.error "empty accept header"
+ else Ok ()
+ in
+ let* () =
+ if List.is_empty accept_lang_l then
+ Fmt.error "empty accept language header"
+ else Ok ()
+ in
+ let* ext =
+ accept_ext_l
+ |> List.find_opt Assets.is_supported_ext
+ |> Option.to_result ~none:"no acceptable mimetype"
+ in
+ let* lang =
+ accept_lang_l
+ |> List.find_opt Assets.is_supported_lang
+ |> Option.to_result ~none:"no acceptable language"
+ in
+ let content = Assets.get_content ~lang ~ext kind in
+ content
+
+ (* TODO add headers, handle errors etc
+ think on how to (not) mix error and vif monade well *)
+ let static kind req _server _env =
+ let open Vif.Response.Syntax in
+ let headers = Vif.Request.headers req in
+ let accept_ext_l = Header_util.parse_accept_header headers in
+ let accept_lang_l = Header_util.parse_accept_language_header headers in
+ let data =
+ match select_file ~accept_lang_l ~accept_ext_l kind with
+ | Error e -> Fmt.failwith "%s" e
+ | Ok content -> content
+ 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
+ Vif.Response.respond `OK
+
+ let terms = static Assets.Terms
+ let privacy = static Assets.Privacy
+end
let routes =
let open Vif.Uri in
let open Vif.Route in
(*let open Vif.Type in*)
[
- get (rel / "terms" /?? nil) --> static `Terms
- ; get (rel / "privacy" /?? nil) --> static `Privacy
+ get (rel / "terms" /?? nil) --> Static.terms
+ ; get (rel / "privacy" /?? nil) --> Static.privacy
]
let () =
diff --git a/src/util.ml b/src/util.ml
new file mode 100644
index 00000000..bc0b6afa
--- /dev/null
+++ b/src/util.ml
@@ -0,0 +1,29 @@
+(* 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 default_extension = "txt"
+
+let is_valid_filename, media_to_extension =
+ let mimetype_ext_assoc =
+ [
+ (("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")
+ ]
+ in
+ (* <> than the actual set of "supported" extension (depends on config files) *)
+ let all_known_extensions = mimetype_ext_assoc |> List.split |> snd in
+ let is_valid_filename path = Fpath.mem_ext all_known_extensions path in
+ let media_to_extension = function
+ | Cohttp.Accept.MediaType (m, m_sub) ->
+ List.assoc_opt (m, m_sub) mimetype_ext_assoc
+ | AnyMediaSubtype m ->
+ List.find_map
+ (fun ((m', _), ext) ->
+ match String.equal m m' with false -> None | true -> Some ext)
+ mimetype_ext_assoc
+ | AnyMedia -> Some default_extension
+ in
+ (is_valid_filename, media_to_extension)