mte/src/headers.ml

let select_extension headers =
  let accept = Vif.Headers.get headers "accept" in
  Cohttp.Accept.media_ranges accept
  |> Cohttp.Accept.qsort
  |> List.filter_map (fun (_q, (m, _p)) -> Util.media_to_extension m)
  |> List.find_opt Assets.is_supported_ext

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

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 Config.default_encoding
       | Encoding _ | Compress -> (* unsupported *) None)
  |> function
  | [] -> assert false
  | `Identity :: _ -> None
  | `DEFLATE :: _ -> Some `DEFLATE
  | `Gzip :: _ -> Some `Gzip

(* TODO(etag)
   - test
   - don't ignore invalid_etag
   - can still bypass this module and directly set Etag header
     but its fine *)
module Etag : sig
  (* https://httpwg.org/specs/rfc9110.html#field.etag
       module to parse < "*" / #entity-tag >,
       used for If-Match and If-None-Match headers *)
  type t
  type header_value

  val parse : string -> (header_value, string) result
  val of_crockford32 : string -> (t, string) result
  val to_field_value : t -> string
  val evaluate : t -> header_value -> bool
end = struct
  (* raw etag *)
  type t = string

  (* type for the value of header field *)
  type header_etag_item = { weak: bool; value: string }
  type header_value = Any_etag | Etag_list of header_etag_item list

  let pp_header_etag_item ppf { weak; value } =
    if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value

  let to_field_value t =
    (* always weak comparison for If-None-Match header *)
    let v = { weak= true; value= t } in
    Fmt.str "%a" pp_header_etag_item v

  let invalid_etag = Error "invalid etag field"

  let has_valid_charset s =
    let f c =
      let n = Char.code c in
      (n >= 0x21 && n <= 0x7E && n <> 0x22) || (n >= 0x80 && n <= 0xFF)
    in
    String.for_all f s

  let of_crockford32 s =
    match has_valid_charset s with false -> invalid_etag | true -> Ok s

  let trim_dquote s =
    let len = String.length s in
    if len >= 2 && s.[0] = '"' && s.[len - 1] = '"' then
      Ok (String.sub s 1 (len - 2))
    else invalid_etag

  let parse s =
    if String.trim s = "*" then Ok Any_etag
    else
      String.split_on_char ',' s
      |> List.map String.trim
      |> List.filter (( <> ) "")
      |> Syntax.list_map (fun s ->
             (* "W/" is the weak comparison indicator *)
             let weak, s =
               if String.starts_with ~prefix:"W/" s then
                 (true, String.sub s 2 (String.length s - 2))
               else (false, s)
             in
             Result.bind (trim_dquote s) (fun s ->
                 if has_valid_charset s then Ok { weak; value= s }
                 else invalid_etag))
      |> Result.map (fun l -> Etag_list l)

  (* To evaluate a received If-None-Match header field:
     - If the field value is "*", the condition is false
       if the origin server has a current representation for the target resource.
     - If the field value is a list of entity tags, the condition is false
       if one of the listed tags matches the entity tag of the selected representation.
     - Otherwise, the condition is true. *)
  let evaluate t header_value =
    match header_value with
    | Any_etag -> false
    | Etag_list l ->
        not @@ List.exists (fun { weak= _; value } -> String.equal t value) l
end