+ clean up tos
This commit is contained in:
parent
98ba917cfb
commit
28eb9fae55
3 changed files with 114 additions and 113 deletions
153
src/assets.ml
153
src/assets.ml
|
|
@ -1,62 +1,70 @@
|
|||
(* doc: https://docs.taler.net/design-documents/003-tos-rendering.html
|
||||
- must support `text/plain` and `text/markdown` *)
|
||||
(* https://docs.taler.net/design-documents/003-tos-rendering.html
|
||||
https://docs.taler.net/design-documents/003-tos-rendering.html
|
||||
|
||||
must support `text/plain` and `text/markdown` *)
|
||||
|
||||
type t =
|
||||
| Terms
|
||||
| Privacy
|
||||
|
||||
module Assets_config = struct
|
||||
(* hardcoded config just for static assets *)
|
||||
let default_lang = "en"
|
||||
let default_mimetype = ("text", "plain")
|
||||
let default_extension = ".txt"
|
||||
let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
|
||||
|
||||
(* TODO how to update ToS version? *)
|
||||
let terms_legal_version = "0"
|
||||
let privacy_legal_version = "0"
|
||||
|
||||
(* TODO config *)
|
||||
type t =
|
||||
| Terms
|
||||
| Privacy
|
||||
|
||||
let etag k =
|
||||
Result.get_ok
|
||||
@@ Headers_lib.Etag.of_crockford32
|
||||
@@ match k with Terms -> "0" | Privacy -> "0"
|
||||
|
||||
let legal_version = function
|
||||
| Terms -> terms_legal_version
|
||||
| Privacy -> privacy_legal_version
|
||||
|
||||
let base_dir = function Terms -> "terms" | Privacy -> "privacy"
|
||||
|
||||
(* TODO clean up this horror *)
|
||||
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
|
||||
(* TODO this should be in the config like terms_etag *)
|
||||
let terms_legal_version = "0"
|
||||
let privacy_legal_version = "0"
|
||||
end
|
||||
|
||||
let etag k =
|
||||
let etag =
|
||||
match k with Terms -> Config.terms_etag | Privacy -> Config.privacy_etag
|
||||
in
|
||||
etag |> Headers_lib.Etag.of_crockford32 |> Result.get_ok
|
||||
|
||||
let legal_version = function
|
||||
| Terms -> Assets_config.terms_legal_version
|
||||
| Privacy -> Assets_config.privacy_legal_version
|
||||
|
||||
let supported_lang_arr, supported_ext_arr =
|
||||
let aux t =
|
||||
let prefix = Fpath.v (base_dir t) in
|
||||
let path_l = path_l |> List.filter_map (Fpath.rem_prefix prefix) in
|
||||
let prefix = Fpath.v (Assets_config.base_dir t) in
|
||||
let path_l = List.map Fpath.v Assets_crunch.file_list in
|
||||
let path_l = List.filter_map (Fpath.rem_prefix prefix) path_l 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 ->
|
||||
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
|
||||
(Fpath.to_string Fpath.(prefix // path)))
|
||||
path_l
|
||||
in
|
||||
let () =
|
||||
let lang_l = List.sort_uniq String.compare lang_l in
|
||||
let etag = Headers_lib.Etag.to_raw_string (etag t) in
|
||||
List.iter
|
||||
(fun path ->
|
||||
let etag' = Fpath.to_string (Fpath.rem_ext (Fpath.base path)) in
|
||||
if not @@ String.equal etag etag' then
|
||||
Fmt.failwith
|
||||
"filename of file `%s` does not match configuration ETAG value `%s`"
|
||||
(Fpath.to_string Fpath.(prefix // path))
|
||||
etag)
|
||||
path_l;
|
||||
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 default_lang lang_l then
|
||||
Fmt.failwith "default language `%s` files not found" default_lang;
|
||||
if not @@ List.mem Assets_config.default_lang lang_l then
|
||||
Fmt.failwith "default language `%s` files not found"
|
||||
Assets_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";
|
||||
|
|
@ -69,23 +77,19 @@ let supported_lang_arr, supported_ext_arr =
|
|||
Fmt.failwith
|
||||
"invalid folder structure, all supported language must provide the \
|
||||
same set of file mimetype"
|
||||
in
|
||||
(lang_l, ext_l)
|
||||
else (lang_l, ext_l)
|
||||
in
|
||||
let lang_l, ext_l = aux Terms in
|
||||
let lang_l', ext_l' = aux Privacy in
|
||||
let () =
|
||||
if
|
||||
not
|
||||
@@ (List.equal String.equal lang_l lang_l'
|
||||
&& List.equal String.equal ext_l ext_l')
|
||||
then
|
||||
match
|
||||
List.equal String.equal lang_l lang_l'
|
||||
&& List.equal String.equal ext_l ext_l'
|
||||
with
|
||||
| false ->
|
||||
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)
|
||||
set of languages and mimetypes"
|
||||
| true -> (Array.of_list lang_l, Array.of_list ext_l)
|
||||
|
||||
module Mimetype = struct
|
||||
type t = string * string
|
||||
|
|
@ -107,30 +111,47 @@ module Mimetype = struct
|
|||
(("image", "gif"), ".gif");
|
||||
]
|
||||
|
||||
let all_supported, _ = List.split assoc
|
||||
let arr =
|
||||
let all_supported, all_supported_ext = List.split assoc in
|
||||
match
|
||||
Array.find_opt
|
||||
(fun ext -> not @@ List.exists (( = ) ext) all_supported_ext)
|
||||
supported_ext_arr
|
||||
with
|
||||
| Some ext -> Fmt.failwith "extension `%s` unsupported" ext
|
||||
| None -> Array.of_list all_supported
|
||||
|
||||
let of_cohttp_media = function
|
||||
let default =
|
||||
match
|
||||
List.mem
|
||||
(Assets_config.default_mimetype, Assets_config.default_extension)
|
||||
assoc
|
||||
with
|
||||
| false ->
|
||||
Fmt.failwith "default content type `%a` not supported" pp
|
||||
Assets_config.default_mimetype
|
||||
| true -> Assets_config.default_mimetype
|
||||
|
||||
let of_cohttp = function
|
||||
| Cohttp.Accept.MediaType (m, m_sub) ->
|
||||
List.find_opt (( = ) (m, m_sub)) all_supported
|
||||
| AnyMediaSubtype m ->
|
||||
List.find_opt (fun (m', _) -> String.equal m m') all_supported
|
||||
| AnyMedia -> Some default_mimetype
|
||||
Array.find_opt (( = ) (m, m_sub)) arr
|
||||
| AnyMediaSubtype m -> Array.find_opt (fun (m', _) -> String.equal m m') arr
|
||||
| AnyMedia -> Some default
|
||||
|
||||
let to_extension t =
|
||||
let to_extension_exn t =
|
||||
match List.assoc_opt t assoc with
|
||||
| None ->
|
||||
Fmt.failwith "Mimetype.to_extension failure: `%s/%s` unknown" (fst t)
|
||||
(snd t)
|
||||
| None -> Fmt.failwith "Mimetype.to_extension failure: `%a` unknown" pp t
|
||||
| Some ext -> ext
|
||||
|
||||
let is_supported mime = List.mem mime all_supported
|
||||
end
|
||||
|
||||
module Language = struct
|
||||
type t = string
|
||||
|
||||
let of_cohttp_language = function
|
||||
| Cohttp.Accept.AnyLanguage -> Some default_lang
|
||||
let arr = supported_lang_arr
|
||||
let default = Assets_config.default_lang
|
||||
|
||||
let of_cohttp = function
|
||||
| Cohttp.Accept.AnyLanguage -> Some default
|
||||
| Language language_range -> (
|
||||
(* ignore language subtags (e.g. "en-US" -> "en") *)
|
||||
match language_range with
|
||||
|
|
@ -142,8 +163,10 @@ end
|
|||
(* ! lang and mime must be supported *)
|
||||
let get_content ~lang ~mime t =
|
||||
let etag = Headers_lib.Etag.to_raw_string (etag t) in
|
||||
let ext = Mimetype.to_extension mime in
|
||||
let path = Fpath.to_string Fpath.((v (base_dir t) / lang / etag) + ext) in
|
||||
let ext = Mimetype.to_extension_exn mime in
|
||||
let path =
|
||||
Fpath.to_string Fpath.((v (Assets_config.base_dir t) / lang / etag) + ext)
|
||||
in
|
||||
match Assets_crunch.read path with
|
||||
| None -> Fmt.failwith "static file not found: `%s`" path
|
||||
| Some data -> data
|
||||
|
|
|
|||
|
|
@ -1,22 +1,18 @@
|
|||
(* TODO header
|
||||
Cohttp -> Http *)
|
||||
|
||||
let accept_header_value =
|
||||
let pp_list pp_item item = Fmt.list ~sep:(Fmt.any ", ") pp_item item in
|
||||
Fmt.str "%a" (pp_list Assets.Mimetype.pp) Assets.Mimetype.all_supported
|
||||
Fmt.str "%a"
|
||||
(Fmt.array ~sep:(Fmt.any ", ") Assets.Mimetype.pp)
|
||||
Assets.Mimetype.arr
|
||||
|
||||
let avail_languages_header_value =
|
||||
let pp_array pp_item item = Fmt.array ~sep:(Fmt.any ", ") pp_item item in
|
||||
let s = Fmt.str "%a" (pp_array Fmt.string) Assets.supported_lang_arr in
|
||||
s
|
||||
Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) Assets.Language.arr
|
||||
|
||||
let select_mimetype headers =
|
||||
let opt = Vif.Headers.get headers "accept" in
|
||||
Cohttp.Accept.media_ranges opt
|
||||
|> Cohttp.Accept.qsort
|
||||
|> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp_media m)
|
||||
|> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp m)
|
||||
|> function
|
||||
| None -> Assets.default_mimetype
|
||||
| None -> Assets.Mimetype.default
|
||||
| Some mime -> mime
|
||||
|
||||
let select_language headers =
|
||||
|
|
@ -24,9 +20,9 @@ let select_language headers =
|
|||
Cohttp.Accept.languages opt
|
||||
|> Cohttp.Accept.qsort
|
||||
|> List.map snd
|
||||
|> List.find_map Assets.Language.of_cohttp_language
|
||||
|> List.find_map Assets.Language.of_cohttp
|
||||
|> function
|
||||
| None -> Assets.default_lang
|
||||
| None -> Assets.Language.default
|
||||
| Some lang -> lang
|
||||
|
||||
let select_encoding headers =
|
||||
|
|
@ -38,7 +34,7 @@ let select_encoding headers =
|
|||
| Cohttp.Accept.Identity -> Some `Identity
|
||||
| Deflate -> Some `DEFLATE
|
||||
| Gzip -> Some `Gzip
|
||||
| AnyEncoding -> Some Assets.default_encoding
|
||||
| AnyEncoding -> Some Assets.Assets_config.default_encoding
|
||||
| Encoding _ | Compress -> (* unsupported *) None)
|
||||
|> function
|
||||
| None -> None
|
||||
|
|
|
|||
|
|
@ -26,14 +26,14 @@ module Respond_with = struct
|
|||
respond `Not_modified
|
||||
end
|
||||
|
||||
let _aux kind req _server _env =
|
||||
let etag = Assets.etag kind in
|
||||
let aux asset req _server _env =
|
||||
let etag = Assets.etag asset in
|
||||
let headers = Vif.Request.headers req in
|
||||
let has_matching_etag =
|
||||
match Vif.Headers.get headers "if-none-match" with
|
||||
| None -> Ok false
|
||||
| Some s ->
|
||||
Headers_lib.Etag.parse s |> Result.map (Headers_lib.Etag.evaluate etag)
|
||||
Result.map (Headers_lib.Etag.evaluate etag) (Headers_lib.Etag.parse s)
|
||||
in
|
||||
match has_matching_etag with
|
||||
| Error e ->
|
||||
|
|
@ -46,7 +46,7 @@ let _aux kind req _server _env =
|
|||
let mime = Headers.select_mimetype headers in
|
||||
let lang = Headers.select_language headers in
|
||||
let compression = Headers.select_encoding headers in
|
||||
let data = Assets.get_content ~mime ~lang kind in
|
||||
let data = Assets.get_content ~mime ~lang asset in
|
||||
(* -- *)
|
||||
let open Vif.Response in
|
||||
let open Syntax in
|
||||
|
|
@ -57,9 +57,8 @@ let _aux kind req _server _env =
|
|||
in
|
||||
let* () =
|
||||
(* todo: is it "taler-privacy-version" for /policy ? *)
|
||||
add ~field:"taler-terms-version" Assets.terms_legal_version
|
||||
add ~field:"taler-terms-version" (Assets.legal_version asset)
|
||||
in
|
||||
(* TODO add compression and mimetype headers too *)
|
||||
let* () =
|
||||
add ~field:"avail-languages" Headers.avail_languages_header_value
|
||||
in
|
||||
|
|
@ -69,23 +68,6 @@ let _aux kind req _server _env =
|
|||
in
|
||||
respond `OK
|
||||
|
||||
(* WIP DEBUG *)
|
||||
let aux _kind req _server _env =
|
||||
let open Vif.Response in
|
||||
let open Syntax in
|
||||
let data = "uhuh" in
|
||||
let etag = "0" in
|
||||
let content_type = "text/plain" in
|
||||
let* () = with_string req data in
|
||||
let* () = add ~field:"etag" etag in
|
||||
let* () =
|
||||
(* todo: is it "taler-privacy-version" for /policy ? *)
|
||||
add ~field:"taler-terms-version" Assets.terms_legal_version
|
||||
in
|
||||
let* () = add ~field:"avail-languages" Headers.avail_languages_header_value in
|
||||
let* () = add ~field:"content-type" content_type in
|
||||
respond `OK
|
||||
|
||||
let terms req _server _env =
|
||||
Logs.info (fun m -> m "GET /terms");
|
||||
aux Assets.Terms req _server _env
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue