61 lines
2 KiB
OCaml
61 lines
2 KiB
OCaml
let pp_array pp_item item = Fmt.array ~sep:(Fmt.any ", ") pp_item item
|
|
|
|
let accept_header_value =
|
|
let s =
|
|
Fmt.str "%a"
|
|
(pp_array Assets.Mimetype.pp_mime)
|
|
Assets.supported_mimetype_arr
|
|
in
|
|
s
|
|
|
|
let avail_languages_header_value =
|
|
let s = Fmt.str "%a" (pp_array Fmt.string) Assets.supported_lang_arr in
|
|
s
|
|
|
|
let select_mimetype headers =
|
|
let opt = Vif.Headers.get headers "accept" in
|
|
Logs.err (fun m ->
|
|
let s = Option.value ~default:"none" opt in
|
|
m "Header accept: %s" s);
|
|
Cohttp.Accept.media_ranges opt
|
|
|> Cohttp.Accept.qsort
|
|
|> List.filter_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp_media m)
|
|
|> List.find_opt Assets.is_supported_mimetype
|
|
|
|
let select_language headers =
|
|
let opt = Vif.Headers.get headers "accept-language" in
|
|
Logs.err (fun m ->
|
|
let s = Option.value ~default:"none" opt in
|
|
m "Header accept-language: %s" s);
|
|
Cohttp.Accept.languages opt
|
|
|> Cohttp.Accept.qsort
|
|
|> List.map (fun (_q, lang) -> lang)
|
|
|> List.map (function
|
|
| Cohttp.Accept.AnyLanguage -> Assets.default_lang
|
|
| Language language_range -> (
|
|
(* ignore language subtags (e.g. "en-US" -> "en") *)
|
|
match language_range with
|
|
| [] -> assert false
|
|
| primary_tag :: _ -> primary_tag))
|
|
|> List.find_opt Assets.is_supported_lang
|
|
|> Option.value ~default:Assets.default_lang
|
|
|
|
let select_encoding headers =
|
|
let opt = Vif.Headers.get headers "accept-encoding" in
|
|
Logs.err (fun m ->
|
|
let s = Option.value ~default:"none" opt in
|
|
m "Header accept-encoding: %s" s);
|
|
Cohttp.Accept.encodings opt
|
|
|> Cohttp.Accept.qsort
|
|
|> List.map snd
|
|
|> List.filter_map (function
|
|
| Cohttp.Accept.Identity -> Some `Identity
|
|
| Deflate -> Some `DEFLATE
|
|
| Gzip -> Some `Gzip
|
|
| AnyEncoding -> Some Assets.default_encoding
|
|
| Encoding _ | Compress -> (* unsupported *) None)
|
|
|> function
|
|
| [] -> assert false
|
|
| `Identity :: _ -> None
|
|
| `DEFLATE :: _ -> Some `DEFLATE
|
|
| `Gzip :: _ -> Some `Gzip
|