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

add result.ml; polymorphic variant errors + refacto

Browse source
This commit is contained in:
swrup 2026-03-26 06:23:42 +01:00 • committed by Swrup
parent 9fd3b5a3cc
commit 42b0ec1445
36 changed files with 949 additions and 954 deletions
Download patch file Download diff file Expand all files Collapse all files

36
src/assets.ml
View file

@ -1,6 +1,13 @@
(* https://docs.taler.net/design-documents/003-tos-rendering.html
must support `text/plain` and `text/markdown` *)
let failure fmt =
Fmt.kstr
(fun s ->
Fmt.epr "Assets failure: %s.@." s;
exit 1)
fmt
type t =
| Terms
| Privacy
@ -35,7 +42,7 @@ let supported_lang_arr, supported_ext_arr =
| [] -> assert false
| [ dir; _file ] -> dir
| _l ->
Fmt.failwith "invalid folder structure, file `%s` is misplaced"
failure "invalid folder structure, file `%s` is misplaced"
(Fpath.to_string Fpath.(prefix // path)))
path_l
in
@ -45,25 +52,23 @@ let supported_lang_arr, supported_ext_arr =
(fun path ->
let etag' = Fpath.to_string (Fpath.rem_ext (Fpath.base path)) in
if not @@ String.equal etag etag' then
Fmt.failwith
"filename `%s` does not match configuration ETAG value `%s`"
failure "filename `%s` does not match configuration ETAG value `%s`"
(Fpath.to_string Fpath.(prefix // path))
etag)
path_l;
if List.is_empty lang_l then Fmt.failwith "no language supported";
if List.is_empty ext_l then Fmt.failwith "no mimetype supported";
if List.is_empty lang_l then failure "no language supported";
if List.is_empty ext_l then failure "no mimetype supported";
if not @@ List.mem Cfg.default_lang lang_l then
Fmt.failwith "default language `%s` files not found" Cfg.default_lang;
if not @@ List.mem ".txt" ext_l then
Fmt.failwith "plain text file not found";
if not @@ List.mem ".md" ext_l then Fmt.failwith "markdown file not found";
failure "default language `%s` files not found" Cfg.default_lang;
if not @@ List.mem ".txt" ext_l then failure "plain text file not found";
if not @@ List.mem ".md" ext_l then failure "markdown file not found";
List.iter
(fun dir ->
if String.length dir <> 2 then
Fmt.failwith "language directory with invalid name: `%s`" dir)
failure "language directory with invalid name: `%s`" dir)
lang_l;
if List.length path_l <> List.length ext_l * List.length lang_l then
Fmt.failwith
failure
"invalid folder structure, all supported language must provide the \
same set of file mimetype"
else (lang_l, ext_l)
@ -75,7 +80,7 @@ let supported_lang_arr, supported_ext_arr =
&& List.equal String.equal ext_l ext_l'
with
| false ->
Fmt.failwith
failure
"invalid folder structure, /terms and /privacy must support the same \
set of languages and mimetypes"
| true -> (Array.of_list lang_l, Array.of_list ext_l)
@ -104,8 +109,7 @@ module Mimetype = struct
let () =
if not @@ List.mem (Cfg.default_mimetype, Cfg.default_extension) assoc then
Fmt.failwith "default content type `%a` not supported" pp
Cfg.default_mimetype
failure "default content type `%a` not supported" pp Cfg.default_mimetype
let arr =
let all_supported, all_supported_ext = List.split assoc in
@ -114,7 +118,7 @@ module Mimetype = struct
(fun ext -> not @@ List.exists (( = ) ext) all_supported_ext)
supported_ext_arr
with
| Some ext -> Fmt.failwith "extension `%s` unsupported" ext
| Some ext -> failure "extension `%s` unsupported" ext
| None -> Array.of_list all_supported
let of_cohttp = function
@ -137,7 +141,7 @@ module Language = struct
let () =
if not @@ Array.mem default arr then
Fmt.failwith "default language `%s` not supported" Cfg.default_lang
failure "default language `%s` not supported" Cfg.default_lang
let of_cohttp = function
| Cohttp.Accept.AnyLanguage -> Some default