src/assets.ml

@@ -24,7 +24,7 @@ let etag k =
   let etag =
     match k with Terms -> Config.terms_etag | Privacy -> Config.privacy_etag
   in
-  etag |> Headers_lib.Etag.of_crockford32 |> Result.get_ok
+  etag |> Headers_lib.Etag.parse |> Result.get_ok
 
 let legal_version = function
   | Terms -> Assets_config.terms_legal_version
@@ -50,7 +50,7 @@ let supported_lang_arr, supported_ext_arr =
         path_l
     in
     let lang_l = List.sort_uniq String.compare lang_l in
-    let etag = Headers_lib.Etag.to_raw_string (etag t) in
+    let etag = (etag t).value in
     List.iter
       (fun path ->
         let etag' = Fpath.to_string (Fpath.rem_ext (Fpath.base path)) in
@@ -162,10 +162,10 @@ end
 
 (* ! lang and mime must be supported *)
 let get_content ~lang ~mime t =
-  let etag = Headers_lib.Etag.to_raw_string (etag t) in
   let ext = Mimetype.to_extension_exn mime in
   let path =
-    Fpath.to_string Fpath.((v (Assets_config.base_dir t) / lang / etag) + ext)
+    Fpath.to_string
+      Fpath.((v (Assets_config.base_dir t) / lang / (etag t).value) + ext)
   in
   match Assets_crunch.read path with
   | None -> Fmt.failwith "static file not found: `%s`" path

src/headers.ml

@@ -6,6 +6,7 @@ let accept_header_value =
 let avail_languages_header_value =
   Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) Assets.Language.arr
 
+(* TODO Cohttp raises on invalid *)
 let select_mimetype headers =
   let opt = Vif.Headers.get headers "accept" in
   Cohttp.Accept.media_ranges opt

src/headers_lib.ml

@@ -4,80 +4,87 @@
 module Etag : sig
   (* https://httpwg.org/specs/rfc9110.html#field.etag *)
 
-  type t
+  type t = private {
-  type header_value
-
-  val parse : string -> (header_value, string) result
-  val of_crockford32 : string -> (t, string) result
-  val to_raw_string : t -> string
-  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 =
+  val to_field_string : t -> string
-    | Any_etag
+  val parse : string -> (t, string) result
-    | Etag_list of header_etag_item list
+  val angstrom : t Angstrom.t
+end = struct
+  type t = {
+    weak: bool;
+    value: string;
+  }
 
-  let pp_header_etag_item ppf { weak; value } =
+  let pp ppf { weak; value } =
-    if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value
+    match weak with
+    | false -> Fmt.pf ppf {|"%s"|} value
+    | true -> Fmt.pf ppf {|W/"%s"|} value
 
-  let to_raw_string t = t
+  let to_field_string t = Fmt.str "%a" pp t
-
-  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 angstrom =
+    let open Angstrom in
     let is_valid_char c =
       let n = Char.code c in
       (n >= 0x21 && n <= 0x7E && n <> 0x22) || (n >= 0x80 && n <= 0xFF)
-
-  let has_valid_charset s = String.for_all is_valid_char s
-
-  let of_crockford32 s =
-    match has_valid_charset s with
-    | false -> Error "invalid etag"
-    | true -> Ok s
-
-  let parse =
-    let open Angstrom in
-    let ws = skip_while (function ' ' -> true | _ -> false) in
-    let quoted_string =
-      char '"' *> take_till (fun c -> c = '"') <* char '"' >>= fun s ->
-      if String.for_all is_valid_char s then return s
-      else fail "found illegal char"
     in
-    let item =
+    let quoted_string = char '"' *> take_while is_valid_char <* char '"' in
-      ws
+    lift2
-      *> lift2
       (fun weak value -> { weak; value })
       (option false (string "W/" *> return true))
       quoted_string
-      <* ws
+
-    in
+  let parse s =
-    let comma = ws *> char ',' *> ws in
+    match Angstrom.parse_string ~consume:Angstrom.Consume.All angstrom s with
-    let list_of_items = sep_by1 comma item in
+    | Error _e -> Fmt.error "invalid etag: `%s`" s
-    let parse_header_value =
-      char '*' *> return Any_etag
-      <|> (list_of_items >>| fun items -> Etag_list items)
-      <* end_of_input
-    in
-    fun s ->
-      match parse_string ~consume:Consume.All parse_header_value s with
-      | Error e -> Fmt.error "invalid etag: %s" e
     | Ok v -> Ok v
+end
+
+module If_none_match = struct
+  type t =
+    | Any
+    | List of Etag.t list
+
+  let angstrom =
+    let open Angstrom in
+    let ows = skip_while (function ' ' | '\t' -> true | _ -> false) in
+    let comma = ows *> char ',' *> ows in
+    (* A recipient MUST parse and ignore a reasonable number of empty list elements *)
+    let etag_opt = Etag.angstrom >>| Option.some <|> return None in
+    let etags =
+      etag_opt >>= fun hd ->
+      many (comma *> etag_opt) >>= fun tl ->
+      let l = List.filter_map Fun.id (hd :: tl) in
+      match l with [] -> fail "empty etag list" | l -> return (List l)
+    in
+    let any = char '*' *> return Any in
+    any <|> etags
+
+  let parse s =
+    match Angstrom.parse_string ~consume:Angstrom.Consume.All angstrom s with
+    | Error _e -> Fmt.error "invalid if-none-match field: `%s`" s
+    | Ok v -> Ok v
+
+  let evaluate etag t =
+    match t with
+    | Any -> false
+    | List l ->
+        not
+        @@ List.exists (fun e -> String.equal etag.Etag.value e.Etag.value) l
+end
+(*
+    fun s ->
+
+  type header_value =
+    | Any_etag
+    | Etag_list of header_etag_item list
 
   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
+        *)

src/static.ml

@@ -33,7 +33,8 @@ let aux asset req _server _env =
     match Vif.Headers.get headers "if-none-match" with
     | None -> Ok false
     | Some s ->
-        Result.map (Headers_lib.Etag.evaluate etag) (Headers_lib.Etag.parse s)
+        Headers_lib.If_none_match.parse s
+        |> Result.map (Headers_lib.If_none_match.evaluate etag)
   in
   match has_matching_etag with
   | Error e ->
@@ -52,7 +53,7 @@ let aux asset req _server _env =
       let open Syntax in
       let* () = with_string ?compression req data in
       let* () =
-        let etag_field_value = Headers_lib.Etag.to_field_value etag in
+        let etag_field_value = Headers_lib.Etag.to_field_string etag in
         add ~field:"etag" etag_field_value
       in
       let* () =

test/test.ml

@@ -62,17 +62,20 @@ let () =
   ()
 
 let () =
-  let open Headers_lib.Etag in
+  let open Headers_lib.If_none_match in
-  let check input = assert (Result.is_ok (parse input)) in
+  (*let check input = assert (Result.is_ok (parse input)) in*)
+  let check input =
+    match parse input with Error e -> Fmt.failwith "%s" e | Ok _ -> ()
+  in
   let check_bad input = assert (Result.is_error (parse input)) in
 
   check "*";
   check "\"foo\"";
   check "W/\"foo\"";
   check "\"foo\", \"bar\"";
-  check " W/\"x\" , W/\"y\" , \"z\" ";
+  check " , W/\"x\" , W/\"y\" , \"z\"";
-  check "  \"one\" ,  \"two\"  ,  \"three\"  ";
+  check ",  \"one\" ,  \"two\"  ,  \"three\"";
-  check "W/\"a\"";
+  check "W/\"a\" , ";
   check "W/\"a\"   ,   \"b\"";
 
   check_bad "";
@@ -84,10 +87,8 @@ let () =
   check_bad "\"a\" \"b\"";
   check_bad "W/\"a\" W/\"b\"";
   check_bad "\"fo\x7Fo\"";
-
+  check_bad "  W/\"a\"";
-  (* TODO trailing comma are valid actually, I think *)
+  check_bad "W/\"a\"  ";
-  check_bad "\"foo\" ,";
-  check_bad ", \"foo\"";
   ()
 
 (*