From 4e707b080a2ed5d69a3479cac930382a3947bb6b Mon Sep 17 00:00:00 2001 From: swrup Date: Fri, 20 Mar 2026 01:13:21 +0100 Subject: [PATCH] rm headers_lib --- src/assets.ml | 41 ++++++++++++-------------- src/config_parser.ml | 9 +----- src/headers.ml | 2 +- src/headers_lib.ml | 69 -------------------------------------------- src/log_reporter.ml | 2 ++ src/mte_terms.ml | 19 ++++-------- test/test.ml | 36 ----------------------- 7 files changed, 29 insertions(+), 149 deletions(-) delete mode 100644 src/headers_lib.ml diff --git a/src/assets.ml b/src/assets.ml index 9313ee49..eb4bbe41 100644 --- a/src/assets.ml +++ b/src/assets.ml @@ -1,12 +1,11 @@ (* https://docs.taler.net/design-documents/003-tos-rendering.html - must support `text/plain` and `text/markdown` *) type t = | Terms | Privacy -module Assets_config = struct +module Cfg = struct (* hardcoded config just for static assets *) let default_lang = "en" let default_mimetype = ("text", "plain") @@ -23,7 +22,7 @@ let etag k = let supported_lang_arr, supported_ext_arr = let aux t = - let prefix = Fpath.v (Assets_config.base_dir t) in + let prefix = Fpath.v (Cfg.base_dir t) in let path_l = List.map Fpath.v Assets_crunch.file_list in let path_l = List.filter_map (Fpath.rem_prefix prefix) path_l in let ext_l = @@ -41,21 +40,20 @@ let supported_lang_arr, supported_ext_arr = path_l in let lang_l = List.sort_uniq String.compare lang_l in - let etag = (etag t).value in + let etag = etag t in List.iter (fun path -> let etag' = Fpath.to_string (Fpath.rem_ext (Fpath.base path)) in if not @@ String.equal etag etag' then Fmt.failwith - "filename of file `%s` does not match configuration ETAG value `%s`" + "filename `%s` does not match configuration ETAG value `%s`" (Fpath.to_string Fpath.(prefix // path)) etag) path_l; if List.is_empty lang_l then Fmt.failwith "no language supported"; if List.is_empty ext_l then Fmt.failwith "no mimetype supported"; - if not @@ List.mem Assets_config.default_lang lang_l then - Fmt.failwith "default language `%s` files not found" - Assets_config.default_lang; + if not @@ List.mem Cfg.default_lang lang_l then + Fmt.failwith "default language `%s` files not found" Cfg.default_lang; if not @@ List.mem ".txt" ext_l then Fmt.failwith "plain text file not found"; if not @@ List.mem ".md" ext_l then Fmt.failwith "markdown file not found"; @@ -102,6 +100,13 @@ module Mimetype = struct (("image", "gif"), ".gif"); ] + let default = Cfg.default_mimetype + + let () = + if not @@ List.mem (Cfg.default_mimetype, Cfg.default_extension) assoc then + Fmt.failwith "default content type `%a` not supported" pp + Cfg.default_mimetype + let arr = let all_supported, all_supported_ext = List.split assoc in match @@ -112,17 +117,6 @@ module Mimetype = struct | Some ext -> Fmt.failwith "extension `%s` unsupported" ext | None -> Array.of_list all_supported - let default = - match - List.mem - (Assets_config.default_mimetype, Assets_config.default_extension) - assoc - with - | false -> - Fmt.failwith "default content type `%a` not supported" pp - Assets_config.default_mimetype - | true -> Assets_config.default_mimetype - let of_cohttp = function | Cohttp.Accept.MediaType (m, m_sub) -> Array.find_opt (( = ) (m, m_sub)) arr @@ -139,7 +133,11 @@ module Language = struct type t = string let arr = supported_lang_arr - let default = Assets_config.default_lang + let default = Cfg.default_lang + + let () = + if not @@ Array.mem default arr then + Fmt.failwith "default language `%s` not supported" Cfg.default_lang let of_cohttp = function | Cohttp.Accept.AnyLanguage -> Some default @@ -155,8 +153,7 @@ end let get_content ~lang ~mime t = let ext = Mimetype.to_extension_exn mime in let path = - Fpath.to_string - Fpath.((v (Assets_config.base_dir t) / lang / (etag t).value) + ext) + Fpath.to_string Fpath.((v (Cfg.base_dir t) / lang / etag t) + ext) in match Assets_crunch.read path with | None -> Fmt.failwith "static file not found: `%s`" path diff --git a/src/config_parser.ml b/src/config_parser.ml index 83563448..40ebb04c 100644 --- a/src/config_parser.ml +++ b/src/config_parser.ml @@ -204,11 +204,4 @@ 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) +let etag s = s diff --git a/src/headers.ml b/src/headers.ml index 97678517..477059f8 100644 --- a/src/headers.ml +++ b/src/headers.ml @@ -36,7 +36,7 @@ let select_encoding headers = | Cohttp.Accept.Identity -> Some `Identity | Deflate -> Some `DEFLATE | Gzip -> Some `Gzip - | AnyEncoding -> Some Assets.Assets_config.default_encoding + | AnyEncoding -> Some Assets.Cfg.default_encoding | Encoding _ | Compress -> (* unsupported *) None) |> function | None -> None diff --git a/src/headers_lib.ml b/src/headers_lib.ml deleted file mode 100644 index e76a589a..00000000 --- a/src/headers_lib.ml +++ /dev/null @@ -1,69 +0,0 @@ -module Etag = struct - (* https://httpwg.org/specs/rfc9110.html#field.etag *) - - 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 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/log_reporter.ml b/src/log_reporter.ml index fa549ef3..945ed21c 100644 --- a/src/log_reporter.ml +++ b/src/log_reporter.ml @@ -47,10 +47,12 @@ let reporter : Logs.reporter = in { report } +(* let set_level_secmods lvl = let secmod_srcs = [ Secmod_rsa.src; Secmod_eddsa.src ] in List.iter (fun src -> Logs.Src.set_level src lvl) secmod_srcs; () +*) let setup level = (* set_level_secmods level; *) diff --git a/src/mte_terms.ml b/src/mte_terms.ml index a055b5e4..48e61e47 100644 --- a/src/mte_terms.ml +++ b/src/mte_terms.ml @@ -5,15 +5,12 @@ let aux asset req _server _env = let headers = Vifu.Request.headers req in let has_matching_etag = match Vifu.Headers.get headers "if-none-match" with - | None -> Ok false - | Some s -> - Headers_lib.If_none_match.parse s - |> Result.map (Headers_lib.If_none_match.evaluate etag) + | None -> false + | Some s -> String.equal etag s in match has_matching_etag with - | Error e -> Respond.bad_request ~hint:e req - | Ok true -> Respond.not_modified () - | Ok false -> + | true -> Respond.not_modified () + | false -> let mime = Headers.select_mimetype headers in let lang = Headers.select_language headers in let compression = Headers.select_encoding headers in @@ -22,13 +19,9 @@ let aux asset req _server _env = let open Vifu.Response in let open Syntax in let* () = with_string ?compression req data in + let* () = add ~field:"etag" etag in let* () = - let etag_field_value = Headers_lib.Etag.to_field_string etag in - add ~field:"etag" etag_field_value - in - let* () = - add ~field:"taler-terms-version" - Assets.Assets_config.terms_legal_version + add ~field:"taler-terms-version" Assets.Cfg.terms_legal_version in let* () = add ~field:"avail-languages" Headers.avail_languages_header_value diff --git a/test/test.ml b/test/test.ml index 53de5106..2baf4edf 100644 --- a/test/test.ml +++ b/test/test.ml @@ -54,42 +54,6 @@ let () = assert (Result.is_error r); () -let () = - 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; - - () - let () = let round_trip s = let s' = s |> B32.encode |> B32.decode |> Result.get_ok in