add headers.ml
This commit is contained in:
parent
f7aaae9fb1
commit
9ecd61d0a9
3 changed files with 123 additions and 125 deletions
2
src/dune
2
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
|
||||
|
|
|
|||
109
src/headers.ml
Normal file
109
src/headers.ml
Normal file
|
|
@ -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
|
||||
135
src/mte.ml
135
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
|
||||
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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue