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

add assets.ml

Browse source
This commit is contained in:
Swrup 2025-09-23 20:58:34 +02:00
parent 2eb42f51cc
commit 2828e171aa
11 changed files with 212 additions and 169 deletions
Download patch file Download diff file Expand all files Collapse all files

100
src/assets.ml Normal file
View file

@ -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

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

@ -1,11 +0,0 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="UTF-8">
<title>MTE privacy policy</title>
</head>
<body>
<h1>MTE privacy policy</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

11
src/assets/terms/en/0.html
View file

@ -1,11 +0,0 @@
<!DOCTYPE html>
<html lang="en">
<head>
<meta charset="UTF-8">
<title>MTE terms</title>
</head>
<body>
<h1>MTE terms</h1>
TODO
</body>
</html>

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

89
src/config.ml
View file

@ -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?
*)

4
src/dune
View file

@ -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

113
src/mte.ml
View file

@ -14,82 +14,87 @@
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 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"
|> 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
(* 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)
let* () =
if List.is_empty accept_lang_l then
Fmt.error "empty accept language header"
else Ok ()
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))
let* ext =
accept_ext_l
|> List.find_opt Assets.is_supported_ext
|> Option.to_result ~none:"no acceptable mimetype"
in
(* todo add headers ... *)
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 =
Assets.get @@ Fpath.((Config.terms_dir / lang / Config.terms_etag) + ext)
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 () =

29
src/util.ml Normal file
View file

@ -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)