swrup/mte
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

wip clean up ToS

Browse source
This commit is contained in:
swrup 2026-02-10 21:49:42 +01:00 • committed by Swrup
parent 7d7dd2400c
commit b0fa0b1780
10 changed files with 150 additions and 153 deletions
Download patch file Download diff file Expand all files Collapse all files

9
default/assets/privacy/en/0.md
View file

@ -1 +1,8 @@
# TODO dummy ToS
# Privacy Policy
Welcome!
This is a placeholder Privacy Policy file.
------------------------------------------
MTE - the MirageOS Taler Exchange

9
default/assets/privacy/en/0.txt
View file

@ -1 +1,8 @@
# TODO dummy ToS
# Privacy Policy
Welcome!
This is a placeholder Privacy Policy file.
------------------------------------------
MTE - the MirageOS Taler Exchange

9
default/assets/terms/en/0.md
View file

@ -1 +1,8 @@
# TODO dummy ToS
# Terms of Service
Welcome!
This is a placeholder Terms of Service file.
------------------------------------------
MTE - the MirageOS Taler Exchange

9
default/assets/terms/en/0.txt
View file

@ -1 +1,8 @@
# TODO dummy ToS
# Terms of Service
Welcome!
This is a placeholder Terms of Service file.
------------------------------------------
MTE - the MirageOS Taler Exchange

123
src/assets.ml
View file

@ -1,55 +1,15 @@
(* TODO clean up *)
(* docs: https://docs.taler.net/manpages/taler-exchange.conf.5.html
https://docs.taler.net/design-documents/003-tos-rendering.html *)
(* doc: https://docs.taler.net/design-documents/003-tos-rendering.html
- must support `text/plain` and `text/markdown` *)
(* hardcoded config just for static assets *)
let default_lang = "en"
let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
(* todo: Taler documentation markdown mimetype should be the prefered one, and be
supported, according to DD we take text/plain as default instead for now *)
let default_mimetype = ("text", "plain")
let default_extension = ".txt"
let terms_legal_version = "1"
let privacy_legal_version = "1"
let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
module Mimetype = struct
let mimetype_extension_assoc =
[
(("text", "plain"), ".txt");
(("text", "markdown"), ".md");
(("text", "html"), ".html");
(("text", "html"), ".htm");
(("application", "pdf"), ".pdf");
(("image", "jpeg"), ".jpg");
(("image", "jpeg"), ".jpeg");
(("image", "png"), ".png");
(("image", "gif"), ".gif");
]
let mimetype_l, _ = List.split mimetype_extension_assoc
let of_cohttp_media = function
| Cohttp.Accept.MediaType (m, m_sub) ->
List.find_opt (( = ) (m, m_sub)) mimetype_l
| AnyMediaSubtype m ->
List.find_opt (fun (m', _) -> String.equal m m') mimetype_l
| AnyMedia -> Some default_mimetype
let to_extension (m, m_sub) =
assert (m <> "*");
assert (m_sub <> "*");
List.assoc_opt (m, m_sub) mimetype_extension_assoc
let of_extension ext =
List.find_map
(fun (mime, ext') ->
match String.equal ext ext' with false -> None | true -> Some mime)
mimetype_extension_assoc
let pp_mime fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime)
end
(* TODO how to update ToS version? *)
let terms_legal_version = "0"
let privacy_legal_version = "0"
(* TODO config *)
type t =
@ -65,11 +25,9 @@ let legal_version = function
| Terms -> terms_legal_version
| Privacy -> privacy_legal_version
let base_dir = function
| Terms -> Fpath.v "terms"
| Privacy -> Fpath.v "privacy"
let base_dir = function Terms -> "terms" | Privacy -> "privacy"
(* does some checks on assets/ folder content and infer the set of supported languages and mimetype *)
(* TODO clean up this horror *)
let supported_lang_arr, supported_ext_arr =
let open Syntax in
let path_l =
@ -78,7 +36,7 @@ let supported_lang_arr, supported_ext_arr =
| Ok x -> x
in
let aux t =
let prefix = base_dir t in
let prefix = Fpath.v (base_dir t) in
let path_l = path_l |> List.filter_map (Fpath.rem_prefix prefix) in
let ext_l =
path_l |> List.map Fpath.get_ext |> List.sort_uniq String.compare
@ -129,22 +87,63 @@ let supported_lang_arr, supported_ext_arr =
in
(Array.of_list lang_l, Array.of_list ext_l)
let supported_mimetype_arr =
Array.map Mimetype.of_extension supported_ext_arr |> Array.map Option.get
module Mimetype = struct
type t = string * string
let is_supported_lang lang = Array.mem lang supported_lang_arr
let is_supported_ext ext = Array.mem ext supported_ext_arr
let is_supported_mimetype mime = Array.mem mime supported_mimetype_arr
let pp fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime)
let assoc =
List.filter
(fun (_mime, ext) -> Array.mem ext supported_ext_arr)
[
(("text", "plain"), ".txt");
(("text", "markdown"), ".md");
(("text", "html"), ".html");
(("text", "html"), ".htm");
(("application", "pdf"), ".pdf");
(("image", "jpeg"), ".jpg");
(("image", "jpeg"), ".jpeg");
(("image", "png"), ".png");
(("image", "gif"), ".gif");
]
let all_supported, _ = List.split assoc
let of_cohttp_media = function
| Cohttp.Accept.MediaType (m, m_sub) ->
List.find_opt (( = ) (m, m_sub)) all_supported
| AnyMediaSubtype m ->
List.find_opt (fun (m', _) -> String.equal m m') all_supported
| AnyMedia -> Some default_mimetype
let to_extension t =
match List.assoc_opt t assoc with
| None ->
Fmt.failwith "Mimetype.to_extension failure: `%s/%s` unknown" (fst t)
(snd t)
| Some ext -> ext
let is_supported mime = List.mem mime all_supported
end
module Language = struct
type t = string
let of_cohttp_language = function
| Cohttp.Accept.AnyLanguage -> Some default_lang
| Language language_range -> (
(* ignore language subtags (e.g. "en-US" -> "en") *)
match language_range with
| [] -> assert false
| lang :: _ when Array.mem lang supported_lang_arr -> Some lang
| _ -> None)
end
(* ! lang and mime must be supported *)
let get_content ~lang ~mime t =
let etag = Headers_lib.Etag.to_raw_string (etag t) in
let ext =
match Mimetype.to_extension mime with
| None -> Fmt.failwith "mimetype `%s/%s` unknown" (fst mime) (snd mime)
| Some ext -> ext
in
let path = Fpath.to_string Fpath.((base_dir t / lang / etag) + ext) in
let ext = Mimetype.to_extension mime in
let path = Fpath.to_string Fpath.((v (base_dir t) / lang / etag) + ext) in
match Assets_crunch.read path with
| None -> Fmt.failwith "static file not found: `%s`" path
| Some data -> data

52
src/headers.ml
View file

@ -1,61 +1,47 @@
let pp_array pp_item item = Fmt.array ~sep:(Fmt.any ", ") pp_item item
(* TODO header
Cohttp -> Http *)
let accept_header_value =
let s =
Fmt.str "%a"
(pp_array Assets.Mimetype.pp_mime)
Assets.supported_mimetype_arr
in
s
let pp_list pp_item item = Fmt.list ~sep:(Fmt.any ", ") pp_item item in
Fmt.str "%a" (pp_list Assets.Mimetype.pp) Assets.Mimetype.all_supported
let avail_languages_header_value =
let pp_array pp_item item = Fmt.array ~sep:(Fmt.any ", ") pp_item item in
let s = Fmt.str "%a" (pp_array Fmt.string) Assets.supported_lang_arr in
s
let select_mimetype headers =
let opt = Vif.Headers.get headers "accept" in
Logs.err (fun m ->
let s = Option.value ~default:"none" opt in
m "Header accept: %s" s);
Cohttp.Accept.media_ranges opt
|> Cohttp.Accept.qsort
|> List.filter_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp_media m)
|> List.find_opt Assets.is_supported_mimetype
|> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp_media m)
|> function
| None -> Assets.default_mimetype
| Some mime -> mime
let select_language headers =
let opt = Vif.Headers.get headers "accept-language" in
Logs.err (fun m ->
let s = Option.value ~default:"none" opt in
m "Header accept-language: %s" s);
Cohttp.Accept.languages opt
|> Cohttp.Accept.qsort
|> List.map (fun (_q, lang) -> lang)
|> List.map (function
| Cohttp.Accept.AnyLanguage -> Assets.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
|> Option.value ~default:Assets.default_lang
|> List.map snd
|> List.find_map Assets.Language.of_cohttp_language
|> function
| None -> Assets.default_lang
| Some lang -> lang
let select_encoding headers =
let opt = Vif.Headers.get headers "accept-encoding" in
Logs.err (fun m ->
let s = Option.value ~default:"none" opt in
m "Header accept-encoding: %s" s);
Cohttp.Accept.encodings opt
|> Cohttp.Accept.qsort
|> List.map snd
|> List.filter_map (function
|> List.find_map (function
| Cohttp.Accept.Identity -> Some `Identity
| Deflate -> Some `DEFLATE
| Gzip -> Some `Gzip
| AnyEncoding -> Some Assets.default_encoding
| Encoding _ | Compress -> (* unsupported *) None)
|> function
| [] -> assert false
| `Identity :: _ -> None
| `DEFLATE :: _ -> Some `DEFLATE
| `Gzip :: _ -> Some `Gzip
| None -> None
| Some `Identity -> None
| Some `DEFLATE -> Some `DEFLATE
| Some `Gzip -> Some `Gzip

9
src/headers_lib.ml
View file

@ -1,12 +1,9 @@
(* independent library for headers fields value *)
(* library for headers fields value *)
(* TODO - test - can still bypass this module and directly set Etag header, but
its fine *)
(* TODO clean up *)
module Etag : sig
(* module to parse etags header fields used by If-Match and If-None-Match
headers
(* https://httpwg.org/specs/rfc9110.html#field.etag *)
https://httpwg.org/specs/rfc9110.html#field.etag *)
type t
type header_value

3
src/respond_util.ml
View file

@ -1,3 +1,6 @@
(* TODO response
use ErrorDetail *)
let respond_with_plain_text_error ?status e req =
let open Vif.Response in
let open Syntax in

76
src/static.ml
View file

@ -1,14 +1,6 @@
(* TODO check for mathcing ETAG with a middleware instead? *)
(* /terms + /privacy
- try to find a response with an acceptable mime-type
- pick the version in the most preferred language of the user
- apply compression if that is allowed by the client
- set ETAG header
- If it did not change, a "304 Not Modified" response will be returned
- 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"),
include a "Avail-Languages" header: a comma-separated list of the languages available *)
(* /terms + /privacy *)
(* TODO response *)
module Respond_with = struct
open Vif.Response
open Syntax
@ -32,15 +24,6 @@ module Respond_with = struct
let not_modified () =
let* () = empty in
respond `Not_modified
let unsupported_media_type req =
let body =
error_detail ~hint:"no acceptable mimetype" `Unsupported_media_type
in
let* () = add ~field:"content-type" "application/json" in
let* () = add ~field:"accept" Headers.accept_header_value in
let* () = with_string ?compression:None req body in
respond `Unsupported_media_type
end
let _aux kind req _server _env =
@ -59,35 +42,32 @@ let _aux kind req _server _env =
| Ok true ->
Logs.err (fun m -> m "not modified");
Respond_with.not_modified ()
| Ok false -> (
match Headers.select_mimetype headers with
| None ->
Logs.err (fun m -> m "unsupported_media_type");
Respond_with.unsupported_media_type req
| Some mime ->
let lang = Headers.select_language headers in
let compression = Headers.select_encoding headers in
let data = Assets.get_content ~mime ~lang kind in
(* -- *)
let open Vif.Response in
let open Syntax in
let* () = with_string ?compression req data in
let* () =
let etag_field_value = Headers_lib.Etag.to_field_value etag in
add ~field:"etag" etag_field_value
in
let* () =
(* todo: is it "taler-privacy-version" for /policy ? *)
add ~field:"taler-terms-version" Assets.terms_legal_version
in
let* () =
add ~field:"avail-languages" Headers.avail_languages_header_value
in
let* () =
let content_type = Fmt.str "%a" Assets.Mimetype.pp_mime mime in
add ~field:"content-type" content_type
in
respond `OK)
| Ok false ->
let mime = Headers.select_mimetype headers in
let lang = Headers.select_language headers in
let compression = Headers.select_encoding headers in
let data = Assets.get_content ~mime ~lang kind in
(* -- *)
let open Vif.Response in
let open Syntax in
let* () = with_string ?compression req data in
let* () =
let etag_field_value = Headers_lib.Etag.to_field_value etag in
add ~field:"etag" etag_field_value
in
let* () =
(* todo: is it "taler-privacy-version" for /policy ? *)
add ~field:"taler-terms-version" Assets.terms_legal_version
in
(* TODO add compression and mimetype headers too *)
let* () =
add ~field:"avail-languages" Headers.avail_languages_header_value
in
let* () =
let content_type = Fmt.str "%a" Assets.Mimetype.pp mime in
add ~field:"content-type" content_type
in
respond `OK
(* WIP DEBUG *)
let aux _kind req _server _env =

4
test/crypto.ml
View file

@ -10,6 +10,10 @@ let () =
let s_l = List.init 0x0f (fun i -> String.init i Char.chr) in
List.iter round_trip s_l; ()
(* TODO *)
(* test vectors from:
https://git.gnunet.org/gnunet/gnunet/file/src/cli/util/crypto-test-vectors.json.html *)
let () =
let input = "91JPRV3F5GG4EKJNDSJQ8" in
let expected =