From b49e3528484f73716173ebe368a8eeae6cd6d5a6 Mon Sep 17 00:00:00 2001 From: swrup Date: Thu, 12 Feb 2026 11:25:57 +0100 Subject: [PATCH] --- src/assets.ml | 8 +-- src/headers.ml | 1 + src/headers_lib.ml | 135 ++++++++++++++++++++++++--------------------- src/static.ml | 5 +- test/test.ml | 21 +++---- 5 files changed, 90 insertions(+), 80 deletions(-) diff --git a/src/assets.ml b/src/assets.ml index a7768350..f1ae4967 100644 --- a/src/assets.ml +++ b/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 diff --git a/src/headers.ml b/src/headers.ml index 0a71820e..fd6ebfc7 100644 --- a/src/headers.ml +++ b/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 diff --git a/src/headers_lib.ml b/src/headers_lib.ml index ce9c7257..8346315d 100644 --- a/src/headers_lib.ml +++ b/src/headers_lib.ml @@ -4,80 +4,87 @@ module Etag : sig (* https://httpwg.org/specs/rfc9110.html#field.etag *) - 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 = { + type t = private { weak: bool; value: string; } + val to_field_string : t -> string + val parse : string -> (t, string) result + val angstrom : t Angstrom.t +end = struct + type t = { + weak: bool; + value: string; + } + + let pp ppf { weak; value } = + match weak with + | false -> Fmt.pf ppf {|"%s"|} value + | true -> Fmt.pf ppf {|W/"%s"|} value + + let to_field_string t = Fmt.str "%a" pp t + + 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) + in + let quoted_string = char '"' *> take_while is_valid_char <* char '"' in + lift2 + (fun weak value -> { weak; value }) + (option false (string "W/" *> return true)) + quoted_string + + let parse s = + match Angstrom.parse_string ~consume:Angstrom.Consume.All angstrom s with + | Error _e -> Fmt.error "invalid etag: `%s`" s + | 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 pp_header_etag_item ppf { weak; value } = - if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value - - let to_raw_string t = 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 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 = - ws - *> lift2 - (fun weak value -> { weak; value }) - (option false (string "W/" *> return true)) - 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 = match header_value with | Any_etag -> false | Etag_list l -> not @@ List.exists (fun { weak= _; value } -> String.equal t value) l -end + *) diff --git a/src/static.ml b/src/static.ml index c2406f77..df77f366 100644 --- a/src/static.ml +++ b/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* () = diff --git a/test/test.ml b/test/test.ml index aa577b06..125e2694 100644 --- a/test/test.ml +++ b/test/test.ml @@ -62,18 +62,21 @@ let () = () let () = - let open Headers_lib.Etag in - let check input = assert (Result.is_ok (parse input)) in + let open Headers_lib.If_none_match 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 " \"one\" , \"two\" , \"three\" "; - check "W/\"a\""; - check " W/\"a\" , \"b\""; + check " , W/\"x\" , W/\"y\" , \"z\""; + check ", \"one\" , \"two\" , \"three\""; + check "W/\"a\" , "; + check "W/\"a\" , \"b\""; check_bad ""; check_bad "foo"; @@ -84,10 +87,8 @@ let () = 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\""; + check_bad " W/\"a\""; + check_bad "W/\"a\" "; () (*