better if-not-match

src/assets.ml

@@ -20,10 +20,7 @@ module Assets_config = struct
 end
 
 let etag k =
-  let etag =
+  match k with Terms -> Config.terms_etag | Privacy -> Config.privacy_etag
-    match k with Terms -> Config.terms_etag | Privacy -> Config.privacy_etag
-  in
-  etag |> Headers_lib.Etag.of_crockford32 |> Result.get_ok
 
 let supported_lang_arr, supported_ext_arr =
   let aux t =
@@ -45,7 +42,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
@@ -157,10 +154,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/config.ml

@@ -44,8 +44,8 @@ module Exchange = struct
   let signkey_legal_duration = get "signkey_legal_duration" |> duration
   let max_keys_caching = get "max_keys_caching" |> duration
   let enable_kyc = get "enable_kyc" |> yes_no
-  let terms_etag = get "terms_etag"
+  let terms_etag = get "terms_etag" |> etag
-  let privacy_etag = get "privacy_etag"
+  let privacy_etag = get "privacy_etag" |> etag
   let base_url = get "base_url"
   let shopping_url = get_opt "shopping_url"
   let open_banking_gateway_url = get_opt "open_banking_gateway_url"

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

@@ -1,83 +1,69 @@
-(* library for headers fields value *)
+module Etag = struct
-
-(* TODO clean up *)
-module Etag : sig
   (* https://httpwg.org/specs/rfc9110.html#field.etag *)
 
-  type t
+  type t = {
-  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 =
+  let pp ppf { weak; value } =
-    | Any_etag
+    match weak with
-    | Etag_list of header_etag_item list
+    | false -> Fmt.pf ppf {|"%s"|} value
+    | true -> Fmt.pf ppf {|W/"%s"|} value
 
-  let pp_header_etag_item ppf { weak; value } =
+  let to_field_string t = Fmt.str "%a" pp t
-    if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value
 
-  let to_raw_string t = t
+  let angstrom =
-
-  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 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 is_valid_char c =
-    let quoted_string =
+      let n = Char.code c in
-      char '"' *> take_till (fun c -> c = '"') <* char '"' >>= fun s ->
+      (n >= 0x21 && n <= 0x7E && n <> 0x22) || (n >= 0x80 && n <= 0xFF)
-      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 })
-           (fun weak value -> { weak; value })
+      (option false (string "W/" *> return true))
-           (option false (string "W/" *> return true))
+      quoted_string
-           quoted_string
-      <* ws
-    in
-    let comma = ws *> char ',' *> ws in
-    let list_of_items = sep_by1 comma item in
-    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
 
-  let evaluate t header_value =
+  let parse s =
-    match header_value with
+    match Angstrom.parse_string ~consume:Angstrom.Consume.All angstrom s with
-    | Any_etag -> false
+    | Error _e -> Fmt.error "invalid etag: `%s`" s
-    | Etag_list l ->
+    | Ok v -> Ok v
-        not @@ List.exists (fun { weak= _; value } -> String.equal t value) l
+end
+
+module If_none_match = struct
+  type t =
+    | Any
+    | List of Etag.t list
+
+  let pp ppf = function
+    | Any -> Fmt.pf ppf {|*|}
+    | List l -> Fmt.pf ppf {|%a|} (Fmt.list ~sep:(Fmt.any ", ") Etag.pp) l
+
+  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

src/parse_config.ml

@@ -189,6 +189,15 @@ let ed25519 s =
   |> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e)
   |> unwrap
 
+let etag s =
+  match Headers_lib.Etag.parse s with
+  | Ok etag -> etag
+  | Error e -> (
+      (* retry with quotes if needed *)
+      match Headers_lib.Etag.parse (Fmt.str "\"%s\"" s) with
+      | Ok etag -> etag
+      | Error _ -> fail "could not parse etag `%s`: %s" s e)
+
 (* TODO
    move to another module
    can we type the json as a Int_map directly? *)

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,32 +62,39 @@ 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 ok_l =
+    [
+      "*";
+      "\"foo\"";
+      "W/\"foo\"";
+      "\"foo\", \"bar\"";
+      " , W/\"x\" , W/\"y\" , \"z\"";
+      ",  \"one\" ,  \"two\"  ,  \"three\"";
+      "W/\"a\" , ";
+      "W/\"a\"   ,   \"b\"";
+    ]
+  in
+  let bad_l =
+    [
+      "";
+      "foo";
+      "W/foo";
+      "W/\"unterminated";
+      "\"foo\", W/";
+      "* , \"bar\"";
+      "\"a\" \"b\"";
+      "W/\"a\" W/\"b\"";
+      "\"fo\x7Fo\"";
+      "  W/\"a\"";
+      "W/\"a\"  ";
+    ]
+  in
+  let check_ok input = assert (Result.is_ok (parse input)) in
   let check_bad input = assert (Result.is_error (parse input)) in
+  List.iter check_ok ok_l;
+  List.iter check_bad bad_l;
 
-  check "*";
-  check "\"foo\"";
-  check "W/\"foo\"";
-  check "\"foo\", \"bar\"";
-  check " W/\"x\" , W/\"y\" , \"z\" ";
-  check "  \"one\" ,  \"two\"  ,  \"three\"  ";
-  check "W/\"a\"";
-  check "  W/\"a\" , \"b\"";
-
-  check_bad "";
-  check_bad "foo";
-  check_bad "W/foo";
-  check_bad "W/\"unterminated";
-  check_bad "\"foo\", W/";
-  check_bad "* , \"bar\"";
-  check_bad "\"a\" \"b\"";
-  check_bad "W/\"a\" W/\"b\"";
-  check_bad "\"fo\x7Fo\"";
-
-  (* TODO trailing comma are valid actually, I think *)
-  check_bad "\"foo\" ,";
-  check_bad ", \"foo\"";
   ()
 
 (*