rm headers_lib

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

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

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

src/headers_lib.ml

@@ -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

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; *)

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

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