mte/src/headers.ml

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 accept = Vif.Headers.get headers "accept" in
  Cohttp.Accept.media_ranges accept
  |> 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 accept_language = Vif.Headers.get headers "accept-language" in
  Cohttp.Accept.languages accept_language
  |> Cohttp.Accept.qsort
  |> List.map (fun (_q, lang) -> lang)
  |> List.map (function
       | Cohttp.Accept.AnyLanguage -> Assets.Config.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.Config.default_lang

let select_encoding headers =
  Vif.Headers.get headers "accept-encoding"
  |> Cohttp.Accept.encodings
  |> Cohttp.Accept.qsort
  |> List.map snd
  |> List.filter_map (function
       | Cohttp.Accept.Identity -> Some `Identity
       | Deflate -> Some `DEFLATE
       | Gzip -> Some `Gzip
       | AnyEncoding -> Some Assets.Config.default_encoding
       | Encoding _ | Compress -> (* unsupported *) None)
  |> function
  | [] -> assert false
  | `Identity :: _ -> None
  | `DEFLATE :: _ -> Some `DEFLATE
  | `Gzip :: _ -> Some `Gzip