add headers.ml

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,38 +28,39 @@ 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
-         should also include a “Avail-Languages” header which includes a
+       - When returning a full response (not a "304 Not Modified"), the server
+         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
 
   (* TODO add headers, handle errors etc
-   think on how to (not) mix error and vif monade well *)
+     think on how to (not) mix error and vif monade well *)
   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