add headers.ml

src/headers.ml

@@ -0,0 +1,109 @@
+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
+
+  val parse : string -> t
+  val of_crockford32 : string -> (t, string) result
+  val to_field_value : t -> string
+end = struct
+  type etag = { weak: bool; value: string }
+  type t = Any_etag | Etag_list of etag list
+
+  let pp_etag ppf { weak; value } =
+    if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value
+
+  let pp_etag_list = Fmt.list ~sep:(Fmt.any ", ") pp_etag
+
+  let pp ppf = function
+    | Any_etag -> Fmt.pf ppf "*"
+    | Etag_list etags -> Fmt.pf ppf "%a" pp_etag_list etags
+
+  let to_field_value t = Fmt.str "%a" pp t
+  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 =
+    (* always weak comparison for If-None-Match header *)
+    let weak = true in
+    match has_valid_charset s with
+    | false -> invalid_etag
+    | true ->
+        let v = Etag_list [ { weak; value= s } ] in
+        Ok v
+
+  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 Any_etag
+    else
+      String.split_on_char ',' s
+      |> List.map String.trim
+      |> List.filter (( <> ) "")
+      |> 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))
+      |> List.filter_map Result.to_option
+      |> fun l -> Etag_list l
+end