diff --git a/src/assets.ml b/src/assets.ml index a7768350..ead25ffc 100644 --- a/src/assets.ml +++ b/src/assets.ml @@ -21,10 +21,7 @@ module Assets_config = struct end 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 + match k with Terms -> Config.terms_etag | Privacy -> Config.privacy_etag let legal_version = function | Terms -> Assets_config.terms_legal_version @@ -50,7 +47,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 +159,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/config.ml b/src/config.ml index d6222c6b..3ccc104b 100644 --- a/src/config.ml +++ b/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 privacy_etag = get "privacy_etag" + let terms_etag = get "terms_etag" |> 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" 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..e76a589a 100644 --- a/src/headers_lib.ml +++ b/src/headers_lib.ml @@ -1,83 +1,69 @@ -(* library for headers fields value *) - -(* TODO clean up *) -module Etag : sig +module Etag = struct (* 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 = { weak: bool; value: string; } - type header_value = - | Any_etag - | Etag_list of header_etag_item list + let pp ppf { weak; value } = + match weak with + | false -> Fmt.pf ppf {|"%s"|} value + | true -> Fmt.pf ppf {|W/"%s"|} value - 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_string t = Fmt.str "%a" pp t - 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 angstrom = 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" + let is_valid_char c = + let n = Char.code c in + (n >= 0x21 && n <= 0x7E && n <> 0x22) || (n >= 0x80 && n <= 0xFF) 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 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 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 + 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 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 diff --git a/src/parse_config.ml b/src/parse_config.ml index b93e0149..86254830 100644 --- a/src/parse_config.ml +++ b/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? *) 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..b1c2810b 100644 --- a/test/test.ml +++ b/test/test.ml @@ -62,32 +62,39 @@ 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 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\""; () (*