From 9ecd61d0a9c5c79a797dd644ad035cd5f5af751c Mon Sep 17 00:00:00 2001 From: Swrup Date: Sat, 27 Sep 2025 23:49:59 +0200 Subject: [PATCH] add headers.ml --- src/dune | 2 +- src/headers.ml | 109 +++++++++++++++++++++++++++++++++++++++ src/mte.ml | 137 +++++-------------------------------------------- 3 files changed, 123 insertions(+), 125 deletions(-) create mode 100644 src/headers.ml diff --git a/src/dune b/src/dune index 056d3d88..5abab20a 100644 --- a/src/dune +++ b/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 diff --git a/src/headers.ml b/src/headers.ml new file mode 100644 index 00000000..a068cf02 --- /dev/null +++ b/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 diff --git a/src/mte.ml b/src/mte.ml index 888a0048..3f8510e1 100644 --- a/src/mte.ml +++ b/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 . *) -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