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