add headers.ml

src/dune

@@ -1,7 +1,7 @@
 (executable
  (public_name mte)
  (name mte)
- (modules assets assets_crunch mte config util syntax)
+ (modules assets assets_crunch headers mte config util syntax)
  (libraries vif fmt jsont cohttp))
 
 (rule

src/headers.ml

@@ -0,0 +1,109 @@
+let select_extension headers =
+  let accept = Vif.Headers.get headers "accept" in
+  Cohttp.Accept.media_ranges accept
+  |> Cohttp.Accept.qsort
+  |> List.filter_map (fun (_q, (m, _p)) -> Util.media_to_extension m)
+  |> List.find_opt Assets.is_supported_ext
+
+let select_language headers =
+  let accept_language = Vif.Headers.get headers "accept-language" in
+  Cohttp.Accept.languages accept_language
+  |> Cohttp.Accept.qsort
+  |> List.map (fun (_q, lang) -> lang)
+  |> List.map (function
+       | Cohttp.Accept.AnyLanguage -> Config.default_lang
+       | Language language_range -> (
+           (* ignore language subtags (e.g. "en-US" -> "en") *)
+           match language_range with
+           | [] -> assert false
+           | primary_tag :: _ -> primary_tag))
+  |> List.find_opt Assets.is_supported_lang
+
+let select_encoding headers =
+  Vif.Headers.get headers "accept-encoding"
+  |> Cohttp.Accept.encodings
+  |> Cohttp.Accept.qsort
+  |> List.map snd
+  |> List.filter_map (function
+       | Cohttp.Accept.Identity -> Some `Identity
+       | Deflate -> Some `DEFLATE
+       | Gzip -> Some `Gzip
+       | AnyEncoding -> Some Config.default_encoding
+       | Encoding _ | Compress -> (* unsupported *) None)
+  |> function
+  | [] -> assert false
+  | `Identity :: _ -> None
+  | `DEFLATE :: _ -> Some `DEFLATE
+  | `Gzip :: _ -> Some `Gzip
+
+(* TODO(etag)
+   - test
+   - don't ignore invalid_etag
+   - can still bypass this module and directly set Etag header
+     but its fine *)
+module Etag : sig
+  (* https://httpwg.org/specs/rfc9110.html#field.etag
+       module to parse < "*" / #entity-tag >,
+       used for If-Match and If-None-Match headers *)
+  type t
+
+  val parse : string -> t
+  val of_crockford32 : string -> (t, string) result
+  val to_field_value : t -> string
+end = struct
+  type etag = { weak: bool; value: string }
+  type t = Any_etag | Etag_list of etag list
+
+  let pp_etag ppf { weak; value } =
+    if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value
+
+  let pp_etag_list = Fmt.list ~sep:(Fmt.any ", ") pp_etag
+
+  let pp ppf = function
+    | Any_etag -> Fmt.pf ppf "*"
+    | Etag_list etags -> Fmt.pf ppf "%a" pp_etag_list etags
+
+  let to_field_value t = Fmt.str "%a" pp t
+  let invalid_etag = Error "invalid etag field"
+
+  let has_valid_charset s =
+    let f c =
+      let n = Char.code c in
+      (n >= 0x21 && n <= 0x7E && n <> 0x22) || (n >= 0x80 && n <= 0xFF)
+    in
+    String.for_all f s
+
+  let of_crockford32 s =
+    (* always weak comparison for If-None-Match header *)
+    let weak = true in
+    match has_valid_charset s with
+    | false -> invalid_etag
+    | true ->
+        let v = Etag_list [ { weak; value= s } ] in
+        Ok v
+
+  let trim_dquote s =
+    let len = String.length s in
+    if len >= 2 && s.[0] = '"' && s.[len - 1] = '"' then
+      Ok (String.sub s 1 (len - 2))
+    else invalid_etag
+
+  let parse s =
+    if String.trim s = "*" then Any_etag
+    else
+      String.split_on_char ',' s
+      |> List.map String.trim
+      |> List.filter (( <> ) "")
+      |> List.map (fun s ->
+             (* "W/" is the weak comparison indicator *)
+             let weak, s =
+               if String.starts_with ~prefix:"W/" s then
+                 (true, String.sub s 2 (String.length s - 2))
+               else (false, s)
+             in
+             Result.bind (trim_dquote s) (fun s ->
+                 if has_valid_charset s then Ok { weak; value= s }
+                 else invalid_etag))
+      |> List.filter_map Result.to_option
+      |> fun l -> Etag_list l
+end

src/mte.ml

@@ -14,122 +14,10 @@
     You should have received a copy of the GNU Affero General Public License
     along with this program.  If not, see <https://www.gnu.org/licenses/>. *)
 
-module Header_util = struct
-  let select_extension headers =
-    let accept = Vif.Headers.get headers "accept" in
-    Cohttp.Accept.media_ranges accept
-    |> Cohttp.Accept.qsort
-    |> List.filter_map (fun (_q, (m, _p)) -> Util.media_to_extension m)
-    |> List.find_opt Assets.is_supported_ext
-
-  let select_language headers =
-    let accept_language = Vif.Headers.get headers "accept-language" in
-    Cohttp.Accept.languages accept_language
-    |> Cohttp.Accept.qsort
-    |> List.map (fun (_q, lang) -> lang)
-    |> List.map (function
-         | Cohttp.Accept.AnyLanguage -> Config.default_lang
-         | Language language_range -> (
-             (* ignore language subtags (e.g. "en-US" -> "en") *)
-             match language_range with
-             | [] -> assert false
-             | primary_tag :: _ -> primary_tag))
-    |> List.find_opt Assets.is_supported_lang
-
-  let select_encoding headers =
-    Vif.Headers.get headers "accept-encoding"
-    |> Cohttp.Accept.encodings
-    |> Cohttp.Accept.qsort
-    |> List.map snd
-    |> List.filter_map (function
-         | Cohttp.Accept.Identity -> Some `Identity
-         | Deflate -> Some `DEFLATE
-         | Gzip -> Some `Gzip
-         | AnyEncoding -> Some Config.default_encoding
-         | Encoding _ | Compress -> (* unsupported *) None)
-    |> function
-    | [] -> assert false
-    | `Identity :: _ -> None
-    | `DEFLATE :: _ -> Some `DEFLATE
-    | `Gzip :: _ -> Some `Gzip
-
-  module Etag : sig
-    (* TODO
-       - test
-       - don't ignore broken etag format *)
-    [@@@ocaml.warning "-32"]
-
-    (* https://httpwg.org/specs/rfc9110.html#field.etag
-       module to parse < "*" / #entity-tag >
-       for If-Match and If-None-Match header value *)
-    type etag = private { weak: bool; value: string }
-    type t = Any_etag | Etag_list of etag list
-
-    val parse : string -> t
-    val of_crockford32 : string -> (t, string) result
-    val to_field_value : t -> string
-  end = struct
-    type etag = { weak: bool; value: string }
-    type t = Any_etag | Etag_list of etag list
-
-    let invalid_etag = Error "invalid Etag field"
-
-    let is_valid_etag_string s =
-      let f c =
-        let n = Char.code c in
-        (n >= 0x21 && n <= 0x7E && n <> 0x22) || (n >= 0x80 && n <= 0xFF)
-      in
-      String.for_all f s
-
-    let pp_etag ppf { weak; value } =
-      if weak then Fmt.pf ppf {|W/"%s"|} value else Fmt.pf ppf {|"%s"|} value
-
-    let pp_etag_list = Fmt.list ~sep:(Fmt.any ", ") pp_etag
-
-    let pp ppf = function
-      | Any_etag -> Fmt.pf ppf "*"
-      | Etag_list etags -> Fmt.pf ppf "%a" pp_etag_list etags
-
-    let to_field_value t = Fmt.str "%a" pp t
-
-    let of_crockford32 s =
-      (* always weak for If-None-Match *)
-      let weak = true in
-      match is_valid_etag_string s with
-      | false -> invalid_etag
-      | true ->
-          let v = Etag_list [ { weak; value= s } ] in
-          Ok v
-
-    let unquote s =
-      let len = String.length s in
-      if len >= 2 && s.[0] = '"' && s.[len - 1] = '"' then
-        Ok (String.sub s 1 (len - 2))
-      else invalid_etag
-
-    let parse s =
-      if String.trim s = "*" then Any_etag
-      else
-        String.split_on_char ',' s
-        |> List.map String.trim
-        |> List.filter (( <> ) "")
-        |> List.map (fun s ->
-               (* "W/" is the weak comparison indicator *)
-               let weak, s =
-                 if String.starts_with ~prefix:"W/" s then
-                   (true, String.sub s 2 (String.length s - 2))
-                 else (false, s)
-               in
-               Result.bind (unquote s) (fun s ->
-                   if is_valid_etag_string s then Ok { weak; value= s }
-                   else invalid_etag))
-        |> List.filter_map Result.to_option
-        |> fun l -> Etag_list l
-  end
-end
-
 module Static = struct
-  (* - try to find a response with an acceptable mime-type,
+  (* /terms + /privacy
+
+     - try to find a response with an acceptable mime-type,
      - then pick the version in the most preferred language of the user,
      - and finally apply compression if that is allowed by the client
      - set ETAG header
@@ -140,21 +28,20 @@ module Static = struct
        - If it did not change, a "304 Not Modified" response will be returned
        - The ETAG is encoded in Crockford base-32
        - A "Taler-Terms-Version" header is generated to indicate the legal version of the terms
-       - When returning a full response (not a “304 Not Modified”), the server
+       - When returning a full response (not a "304 Not Modified"), the server
-         should also include a “Avail-Languages” header which includes a
+         should also include a "Avail-Languages" header which includes a
          comma-separated list of the languages in which the terms of service are available in
-
   *)
 
   let select_file headers kind =
     let open Syntax in
     let* ext =
-      Header_util.select_extension headers
+      Option.to_result ~none:"no acceptable mimetype"
-      |> Option.to_result ~none:"no acceptable mimetype"
+        (Headers.select_extension headers)
     in
     let* lang =
-      Header_util.select_language headers
+      Option.to_result ~none:"no acceptable language"
-      |> Option.to_result ~none:"no acceptable language"
+        (Headers.select_language headers)
     in
     let content = Assets.get_content ~lang ~ext kind in
     content
@@ -164,14 +51,16 @@ module Static = struct
   let static kind req _server _env =
     let open Vif.Response.Syntax in
     let headers = Vif.Request.headers req in
+    (* TODO(etag) *)
     let _if_none_match = Vif.Headers.get headers "if-none-match" in
     let data =
       match select_file headers kind with
       | Error e -> Fmt.failwith "%s" e
       | Ok content -> content
     in
-    let compression = Header_util.select_encoding headers in
+    let compression = Headers.select_encoding headers in
     let* () = Vif.Response.with_string ?compression req data in
+    (* TODO(etag) *)
     let* () = Vif.Response.add ~field:"etag" (Assets.etag kind) in
     (* TODO content-type *)
     let* () = Vif.Response.add ~field:"content-type" "html; charset=utf-8" in