120 lines
4 KiB
OCaml
120 lines
4 KiB
OCaml
|
(* /terms + /privacy *)
|
||
|
|
|
||
|
|
module Cfg = struct
|
||
|
|
let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
|
||
|
|
let default_mimetype = ("text", "plain")
|
||
|
|
let default_language = "en"
|
||
|
|
let terms_legal_version = "0"
|
||
|
|
let terms_dir = "terms"
|
||
|
|
let privacy_dir = "privacy"
|
||
|
|
end
|
||
|
|
|
||
|
|
let terms = Assets.load Cfg.terms_dir Config.terms_etag
|
||
|
|
let privacy = Assets.load Cfg.privacy_dir Config.privacy_etag
|
||
|
|
|
||
|
|
let asset_etag t =
|
||
|
|
match t with `Terms -> Config.terms_etag | `Privacy -> Config.privacy_etag
|
||
|
|
|
||
|
|
let asset_data t = match t with `Terms -> terms | `Privacy -> privacy
|
||
|
|
|
||
|
|
let has_matching_etag etag headers =
|
||
|
|
match Vifu.Headers.get headers "if-none-match" with
|
||
|
|
| None -> false
|
||
|
|
| Some s -> String.equal etag s
|
||
|
|
|
||
|
|
(* todo: should have a middleware for this *)
|
||
|
|
let select_encoding headers =
|
||
|
|
let opt = Vifu.Headers.get headers "accept-encoding" in
|
||
|
|
Cohttp.Accept.encodings opt
|
||
|
|
|> Cohttp.Accept.qsort
|
||
|
|
|> List.map snd
|
||
|
|
|> List.find_map (function
|
||
|
|
| Cohttp.Accept.Identity -> Some `Identity
|
||
|
|
| Deflate -> Some `DEFLATE
|
||
|
|
| Gzip -> Some `Gzip
|
||
|
|
| AnyEncoding -> Some Cfg.default_encoding
|
||
|
|
| Encoding _ | Compress -> None)
|
||
|
|
|> function
|
||
|
|
| None -> None
|
||
|
|
| Some `Identity -> None
|
||
|
|
| Some `DEFLATE -> Some `DEFLATE
|
||
|
|
| Some `Gzip -> Some `Gzip
|
||
|
|
|
||
|
|
let get_accept headers =
|
||
|
|
Vifu.Headers.get headers "accept"
|
||
|
|
|> Cohttp.Accept.media_ranges
|
||
|
|
|> Cohttp.Accept.qsort
|
||
|
|
|> List.map (fun (_q, (m, _p)) -> m)
|
||
|
|
|
||
|
|
let get_accept_language headers =
|
||
|
|
Vifu.Headers.get headers "accept-language"
|
||
|
|
|> Cohttp.Accept.languages
|
||
|
|
|> Cohttp.Accept.qsort
|
||
|
|
|> List.map snd
|
||
|
|
|
||
|
|
let avail_languages t =
|
||
|
|
let supported_languages, _, _ = asset_data t in
|
||
|
|
Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) supported_languages
|
||
|
|
|
||
|
|
let pp_mimetype fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime)
|
||
|
|
|
||
|
|
let accept t =
|
||
|
|
let _, supported_mimetypes, _ = asset_data t in
|
||
|
|
Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") pp_mimetype) supported_mimetypes
|
||
|
|
|
||
|
|
let get_content t accept accept_language =
|
||
|
|
let supported_languages, supported_mimetypes, content_matrix = asset_data t in
|
||
|
|
let find_lang_index = function
|
||
|
|
| Cohttp.Accept.AnyLanguage ->
|
||
|
|
Array.find_index
|
||
|
|
(fun mm' -> Cfg.default_language = mm')
|
||
|
|
supported_languages
|
||
|
|
| Language language_range -> (
|
||
|
|
(* ignore language subtags (e.g. "en-US" -> "en") *)
|
||
|
|
match language_range with
|
||
|
|
| [] -> assert false
|
||
|
|
| lang :: _ ->
|
||
|
|
Array.find_index (fun mm' -> lang = mm') supported_languages)
|
||
|
|
in
|
||
|
|
let find_mime_index = function
|
||
|
|
| Cohttp.Accept.AnyMedia ->
|
||
|
|
Array.find_index (( = ) Cfg.default_mimetype) supported_mimetypes
|
||
|
|
| MediaType (m, mm) -> Array.find_index (( = ) (m, mm)) supported_mimetypes
|
||
|
|
| AnyMediaSubtype m ->
|
||
|
|
Array.find_index (fun (m', _) -> m = m') supported_mimetypes
|
||
|
|
in
|
||
|
|
let i = List.find_map find_lang_index accept_language in
|
||
|
|
let j = List.find_map find_mime_index accept in
|
||
|
|
(* TODO *)
|
||
|
|
let i = Option.get i in
|
||
|
|
let j = Option.get j in
|
||
|
|
(supported_languages.(i), supported_mimetypes.(j), content_matrix.(i).(j))
|
||
|
|
|
||
|
|
let aux t req _server _env =
|
||
|
|
let headers = Vifu.Request.headers req in
|
||
|
|
if has_matching_etag (asset_etag t) headers then Respond.not_modified ()
|
||
|
|
else
|
||
|
|
let compression = select_encoding headers in
|
||
|
|
let language, mimetype, content =
|
||
|
|
get_content t (get_accept headers) (get_accept_language headers)
|
||
|
|
in
|
||
|
|
(* -- *)
|
||
|
|
let open Vifu.Response in
|
||
|
|
let open Syntax in
|
||
|
|
let* () = with_string ?compression req content in
|
||
|
|
let* () = add ~field:"etag" (asset_etag t) in
|
||
|
|
let* () = add ~field:"taler-terms-version" Cfg.terms_legal_version in
|
||
|
|
let* () = add ~field:"accept" (accept t) in
|
||
|
|
let* () = add ~field:"avail-languages" (avail_languages t) in
|
||
|
|
let* () = add ~field:"content-type" (Fmt.str "%a" pp_mimetype mimetype) in
|
||
|
|
let* () = add ~field:"content-language" language in
|
||
|
|
respond `OK
|
||
|
|
|
||
|
|
let terms req _server _env =
|
||
|
|
Logs.info (fun m -> m "GET /terms");
|
||
|
|
aux `Terms req _server _env
|
||
|
|
|
||
|
|
let privacy req _server _env =
|
||
|
|
Logs.info (fun m -> m "GET /privacy");
|
||
|
|
aux `Privacy req _server _env
|