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

refacto

Browse source
This commit is contained in:
swrup 2026-04-11 20:35:15 +02:00 • committed by Swrup
parent 2596733033
commit 305818ae4a
20 changed files with 649 additions and 757 deletions
Download patch file Download diff file Expand all files Collapse all files

231
src/assets.ml
View file

@ -1,6 +1,10 @@
(* https://docs.taler.net/design-documents/003-tos-rendering.html
must support `text/plain` and `text/markdown` *)
module Cfg = struct
let config = "mte.conf"
end
let failure fmt =
Fmt.kstr
(fun s ->
@ -8,157 +12,78 @@ let failure fmt =
exit 1)
fmt
type t =
| Terms
| Privacy
module Cfg = struct
(* hardcoded config just for static assets *)
let default_lang = "en"
let default_mimetype = ("text", "plain")
let default_extension = ".txt"
let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
let base_dir = function Terms -> "terms" | Privacy -> "privacy"
(* TODO this should be in the config like terms_etag *)
let terms_legal_version = "0"
end
let etag k =
match k with Terms -> Config.terms_etag | Privacy -> Config.privacy_etag
let supported_lang_arr, supported_ext_arr =
let aux t =
let prefix = Fpath.v (Cfg.base_dir t) in
let path_l = List.map Fpath.v Assets_crunch.file_list in
let path_l = List.filter_map (Fpath.rem_prefix prefix) path_l in
let ext_l =
path_l |> List.map Fpath.get_ext |> List.sort_uniq String.compare
in
let lang_l =
List.map
(fun path ->
match Fpath.segs path with
| [] -> assert false
| [ dir; _file ] -> dir
| _l ->
failure "invalid folder structure, file `%s` is misplaced"
(Fpath.to_string Fpath.(prefix // path)))
path_l
in
let lang_l = List.sort_uniq String.compare lang_l in
let etag = etag t in
List.iter
(fun path ->
let etag' = Fpath.to_string (Fpath.rem_ext (Fpath.base path)) in
if not @@ String.equal etag etag' then
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 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
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
failure "language directory with invalid name: `%s`" dir)
lang_l;
if List.length path_l <> List.length ext_l * List.length lang_l then
failure
"invalid folder structure, all supported language must provide the \
same set of file mimetype"
else (lang_l, ext_l)
in
let lang_l, ext_l = aux Terms in
let lang_l', ext_l' = aux Privacy in
match
List.equal String.equal lang_l lang_l'
&& List.equal String.equal ext_l ext_l'
with
| false ->
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)
module Mimetype = struct
type t = string * string
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 default = Cfg.default_mimetype
let () =
if not @@ List.mem (Cfg.default_mimetype, Cfg.default_extension) assoc then
failure "default content type `%a` not supported" pp Cfg.default_mimetype
let arr =
let all_supported, all_supported_ext = List.split assoc in
match
Array.find_opt
(fun ext -> not @@ List.exists (( = ) ext) all_supported_ext)
supported_ext_arr
with
| Some ext -> failure "extension `%s` unsupported" ext
| None -> Array.of_list all_supported
let of_cohttp = function
| Cohttp.Accept.MediaType (m, m_sub) ->
Array.find_opt (( = ) (m, m_sub)) arr
| AnyMediaSubtype m -> Array.find_opt (fun (m', _) -> String.equal m m') arr
| AnyMedia -> Some default
let to_extension_exn t =
match List.assoc_opt t assoc with
| None -> Fmt.failwith "Mimetype.to_extension failure: `%a` unknown" pp t
| Some ext -> ext
end
module Language = struct
type t = string
let arr = supported_lang_arr
let default = Cfg.default_lang
let () =
if not @@ Array.mem default arr then
failure "default language `%s` not supported" Cfg.default_lang
let of_cohttp = function
| Cohttp.Accept.AnyLanguage -> Some default
| 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 ext = Mimetype.to_extension_exn mime in
let path =
Fpath.to_string Fpath.((v (Cfg.base_dir t) / lang / etag t) + ext)
in
match Assets_crunch.read path with
| None -> Fmt.failwith "static file not found: `%s`" path
let config =
match Assets_crunch.read Cfg.config with
| None -> failure "static configuration file `%s` not found" Cfg.config
| Some data -> data
let mimetype_of_ext ext =
List.assoc_opt ext
[
(".txt", ("text", "plain"));
(".md", ("text", "markdown"));
(".html", ("text", "html"));
(".htm", ("text", "html"));
(".pdf", ("application", "pdf"));
(".jpg", ("image", "jpeg"));
(".jpeg", ("image", "jpeg"));
(".png", ("image", "png"));
(".gif", ("image", "gif"));
]
let load asset_prefix asset_etag =
let asset_files =
Assets_crunch.file_list
|> List.map (String.split_on_char '/')
|> List.filter (function hd :: _tl -> hd = asset_prefix | _ -> false)
in
let lang_l, ext_l =
asset_files
|> List.map (function
| [ asset_prefix; dir; filename ] ->
if String.length dir <> 2 then
failure "invalid language directory name: `%s`" dir;
let etag, ext =
match String.split_on_char '.' filename with
| [ etag; ext ] -> (etag, "." ^ ext)
| _ -> failure "invalid filename: `%s`" filename
in
if not @@ String.equal asset_etag etag then
failure
"file `%s/%s/%s%s` does not match configuration ETAG value `%s`"
asset_prefix dir etag ext asset_etag;
(dir, ext)
| _ -> failure "invalid directory contents")
|> List.split
in
let lang_l = List.sort_uniq String.compare lang_l in
let ext_l = List.sort_uniq String.compare ext_l in
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 ".txt" ext_l then failure "plain text file not found";
if not @@ List.mem ".md" ext_l then failure "markdown file not found";
if List.length asset_files <> List.length ext_l * List.length lang_l then
failure
"invalid folder structure, all supported language must provide the same \
set of file mimetype";
let lang_arr = Array.of_list (List.sort compare lang_l) in
let ext_arr = Array.of_list (List.sort compare ext_l) in
let mime_arr =
Array.map
(fun ext ->
match mimetype_of_ext ext with
| None -> failure "unsupported extension: `%s`" ext
| Some mime -> mime)
ext_arr
in
let content_matrix =
Array.init (Array.length lang_arr) (fun i ->
Array.init (Array.length ext_arr) (fun j ->
let lang = lang_arr.(i) in
let ext = ext_arr.(j) in
let file = Fmt.str "%s/%s/%s%s" asset_prefix lang asset_etag ext in
match Assets_crunch.read file with
| None -> failure "static file not found: `%s`" file
| Some content_matrix -> content_matrix))
in
(lang_arr, mime_arr, content_matrix)

41
src/config.ml
View file

@ -1,19 +1,10 @@
open Config_parser
module Cfg = struct
let config_filename = "mte.conf"
end
let config_data =
match Assets_crunch.read Cfg.config_filename with
| None -> failure "static file `%s` not found" Cfg.config_filename
| Some data ->
let v = Config_section.parse data in
v
let config = Config_section.parse Assets.config
module Exchange = struct
let get_opt field = get_opt config_data ~section:"exchange" ~field
let get field = get config_data ~section:"exchange" ~field
let get_opt field = get_opt config ~section:"exchange" ~field
let get field = get config ~section:"exchange" ~field
(* - *)
let currency = (* todo: constraint on currency string *) get "currency"
@ -54,19 +45,10 @@ module Exchange = struct
let aml_spa_dialect = get_opt "aml_spa_dialect"
let toplevel_redirect_url = get_opt "toplevel_redirect_url"
let tiny_amount = get_opt "tiny_amount" |> Option.map amount
(* not implemented or not relevant to MTE:
let max_requests = get "max_requests" |> int
aggregator_shard_size
serve
unixpath
unixpath_mode
terms_dir
privacy_dir *)
end
module Exchangedb = struct
let get field = get config_data ~section:"exchangedb" ~field
let get field = get config ~section:"exchangedb" ~field
(* - *)
let idle_reserve_expiration_time =
@ -81,8 +63,7 @@ module Exchangedb = struct
end
module Exchangedb_postgres = struct
let config =
get config_data ~section:"exchangedb-postgres" ~field:"config" |> uri
let config = get config ~section:"exchangedb-postgres" ~field:"config" |> uri
end
module Currency = struct
@ -99,10 +80,10 @@ module Currency = struct
let currency_sections =
List.filter
(fun v -> String.starts_with ~prefix:"currency-" v.header)
config_data
config
let parse_currency section =
let get field = get config_data ~section:section.header ~field in
let get field = get config ~section:section.header ~field in
{
enabled= get "enabled" |> yes_no;
code= get "code";
@ -160,10 +141,10 @@ module Coin = struct
(* ! '_' not '-' *)
let prefix = "coin_" in
let prefix_len = String.length prefix in
config_data
config
|> List.filter (fun v -> String.starts_with ~prefix v.header)
|> List.map (fun section ->
let get field = get config_data ~section:section.header ~field in
let get field = get config ~section:section.header ~field in
let section_name =
String.sub section.header prefix_len
(String.length section.header - prefix_len)
@ -191,7 +172,7 @@ end
module Exchange_secmod_rsa = struct
let get field =
let section = "taler-exchange-secmod-" ^ "rsa" in
get config_data ~section ~field
get config ~section ~field
let lookahead = get "lookahead_sign" |> duration
let overlap = get "overlap_duration" |> duration
@ -200,7 +181,7 @@ end
module Exchange_secmod_eddsa = struct
let get field =
let section = "taler-exchange-secmod-" ^ "eddsa" in
get config_data ~section ~field
get config ~section ~field
let lookahead = get "lookahead_sign" |> duration
let overlap = get "overlap_duration" |> duration

6
src/denomination.ml
View file

@ -17,11 +17,11 @@ type t = {
master_sig: Signatures.DenominationKeyValidity.t;
}
let verify_denomination_key_validity ~key dn =
let verify ~master_key dn =
let open Signatures.DenominationKeyValidity in
verify key dn.master_sig
verify master_key dn.master_sig
{
R.master= key;
R.master= master_key;
start= dn.stamp_start;
expire_withdraw= dn.stamp_expire_withdraw;
expire_spend= dn.stamp_expire_deposit;

7
src/dune
View file

@ -2,7 +2,6 @@
(name mte)
(modules
fat
headers
respond
pg_type
pg
@ -10,8 +9,10 @@
mte_device
mte_handler
mte
mte_terms
mte_info
mte_tos
mte_seed
mte_config
mte_keys
mte_management
secmod_eddsa
secmod_rsa

45
src/headers.ml
View file

@ -1,45 +0,0 @@
let accept_header_value =
Fmt.str "%a"
(Fmt.array ~sep:(Fmt.any ", ") Assets.Mimetype.pp)
Assets.Mimetype.arr
let avail_languages_header_value =
Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) Assets.Language.arr
(* TODO better headers_lib
Cohttp raises on invalid *)
let select_mimetype headers =
let opt = Vifu.Headers.get headers "accept" in
Cohttp.Accept.media_ranges opt
|> Cohttp.Accept.qsort
|> List.find_map (fun (_q, (m, _p)) -> Assets.Mimetype.of_cohttp m)
|> function
| None -> Assets.Mimetype.default
| Some mime -> mime
let select_language headers =
let opt = Vifu.Headers.get headers "accept-language" in
Cohttp.Accept.languages opt
|> Cohttp.Accept.qsort
|> List.map snd
|> List.find_map Assets.Language.of_cohttp
|> function
| None -> Assets.Language.default
| Some lang -> lang
let select_encoding headers =
let opt = Vifu.Headers.get headers "accept-encoding" in
Cohttp.Accept.encodings opt
|> Cohttp.Accept.qsort
|> List.map snd
|> List.find_map (function
| Cohttp.Accept.Identity -> Some `Identity
| Deflate -> Some `DEFLATE
| Gzip -> Some `Gzip
| AnyEncoding -> Some Assets.Cfg.default_encoding
| Encoding _ | Compress -> (* unsupported *) None)
|> function
| None -> None
| Some `Identity -> None
| Some `DEFLATE -> Some `DEFLATE
| Some `Gzip -> Some `Gzip

79
src/mte.ml
View file

@ -13,61 +13,40 @@
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/>. *)
let hello req _server _env =
let open Vifu.Response in
let open Syntax in
let* () = with_string req "Hello~~\n" in
let* () = add ~field:"content-type" "text/plain" in
respond `OK
(* TODO nice routes typing
to enforce json verification
to specify handlers responses data and status codes
use Vif.Uri.conv *)
let routes =
let open Vifu.Uri in
let open Vifu.Route in
let get path = get (path /?? any) in
let post path jsont = post (Vifu.Type.json_encoding jsont) (path /?? any) in
let post path json_enc = post json_enc (path /?? any) in
let v s = rel / s in
let tos =
[
get rel --> hello;
get (v "terms") --> Mte_terms.terms;
get (v "privacy") --> Mte_terms.privacy;
]
in
let status_info =
[
get (v "seed") --> Mte_info.seed;
get (v "config") --> Mte_info.config;
get (v "keys") --> Mte_info.keys;
]
in
let management =
let open Mte_management in
let v s = v "management" / s in
[
get (v "keys") --> Keys_get.f;
post (v "keys") Keys_post.jsont --> Keys_post.f;
post (v "denominations" /% string `Path / "revoke") Denom_revoke.jsont
--> Denom_revoke.f;
post (v "signkeys" /% string `Path / "revoke") Signkey_revoke.jsont
--> Signkey_revoke.f;
post (v "auditors") Auditors.jsont --> Auditors.f;
post (v "auditors" /% string `Path / "disable") Auditors_disable.jsont
--> Auditors_disable.f;
post (v "wire-fee") Wire_fee.jsont --> Wire_fee.f;
post (v "global-fees") Global_fees.jsont --> Global_fees.f;
post (v "wire") Wire.jsont --> Wire.f;
post (v "wire" / "disable") Wire_disable.jsont --> Wire_disable.f;
post (v "drain") Drain.jsont --> Drain.f;
post (v "aml-officers") AmlOfficer.jsont --> AmlOfficer.f;
post (v "partners") Partners.jsont --> Partners.f;
]
in
tos @ status_info @ management
[
get (v "terms") --> Mte_tos.terms;
get (v "privacy") --> Mte_tos.privacy;
get (v "seed") --> Mte_seed.f;
get (v "config") --> Mte_config.f;
get (v "keys") --> Mte_keys.f;
]
@
let open Mte_management in
let v s = rel / "management" / s in
[
get (v "keys") --> Keys_get.f;
post (v "keys") Keys_post.json_enc --> Keys_post.f;
post (v "denominations" /% string `Path / "revoke") Denom_revoke.json_enc
--> Denom_revoke.f;
post (v "signkeys" /% string `Path / "revoke") Signkey_revoke.json_enc
--> Signkey_revoke.f;
post (v "auditors") Auditors.json_enc --> Auditors.f;
post (v "auditors" /% string `Path / "disable") Auditors_disable.json_enc
--> Auditors_disable.f;
post (v "wire-fee") Wire_fee.json_enc --> Wire_fee.f;
post (v "global-fees") Global_fees.json_enc --> Global_fees.f;
post (v "wire") Wire.json_enc --> Wire.f;
post (v "wire" / "disable") Wire_disable.json_enc --> Wire_disable.f;
post (v "drain") Drain.json_enc --> Drain.f;
post (v "aml-officers") AmlOfficer.json_enc --> AmlOfficer.f;
post (v "partners") Partners.json_enc --> Partners.f;
]
module RNG = Mirage_crypto_rng.Fortuna

14
src/mte_config.ml Normal file
View file

@ -0,0 +1,14 @@
let f req _server _env =
Logs.info (fun m -> m "GET /config");
let open Api.ExchangeVersionResponse in
Respond.ok req jsont
{
version= Libtool_version.mte_protocol_version;
name= "taler-exchange";
currency= Config.currency;
currency_specification= Config.Currency.specification;
implementation= None;
shopping_url= None;
open_banking_gateway= None;
aml_spa_dialect= None;
}

226
src/mte_info.ml
View file

@ -1,226 +0,0 @@
open Syntax
open Api
open Time
module String_map = Stdlib.Map.Make (Stdlib.String)
(* TODO mirage-crypto
is this ok?
maybe don't use the same RNG-initialization as the one used to generate keys *)
let seed req _server _env =
Logs.info (fun m -> m "GET /seed");
(* RNG is initialized by Vifu.run *)
let s = Mirage_crypto_rng.generate 64 in
let open Vifu.Response in
let open Syntax in
let* () = add ~field:"content-type" "application/octet-stream" in
let* () = with_string req s in
respond `OK
let config req _server _env =
Logs.info (fun m -> m "GET /config");
Respond.ok req ExchangeVersionResponse.jsont
ExchangeVersionResponse.
{
version= Libtool_version.mte_protocol_version;
name= "taler-exchange";
currency= Config.currency;
currency_specification= Config.Currency.specification;
implementation= None;
shopping_url= None;
open_banking_gateway= None;
aml_spa_dialect= None;
}
(* --- *)
(* TODO *)
let last_change = ref Timestamp.never
let get_denominations_last_change () = !last_change
let warn_once msg =
let b = ref true in
fun () ->
if !b then begin
b := false;
Logs.warn (fun m -> m "%s" msg)
end
let warn_keyring_state_mismatch =
warn_once
"keyring state mismatch: database and secmod have different active keys \
data"
let get_signkeys sm_eddsa pool =
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in
let missing_l, l =
List.partition
(fun sk -> Option.is_none (Secmod_eddsa.find_key sm_eddsa sk.Signkey.pub))
l
in
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let get_denominations sm_rsa pool =
let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn () in
let missing_l, l =
List.partition
(fun dn ->
Option.is_none @@ Secmod_rsa.find_key sm_rsa dn.Denomination.h_pub)
l
in
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let mk_keys sm_eddsa sm_rsa pool last_issue_date =
let version = Libtool_version.mte_protocol_version in
let base_url = Config.base_url in
let currency = Config.currency in
let shopping_url = Config.shopping_url in
let open_banking_gateway = Config.open_banking_gateway_url in
let bank_compliance_language = Config.bank_compliance_language in
let currency_specification = Config.Currency.specification in
let tiny_amount = Config.tiny_amount in
let stefan_abs = Config.stefan_abs in
let stefan_log = Config.stefan_log in
let stefan_lin = Config.stefan_lin in
(* type of the asset. "fiat", "crypto", "regional" or "stock". *)
let asset_type = "fiat" in
let* accounts =
Pg.use_pool pool @@ fun conn -> Pg.get_wire_accounts conn ()
in
let* wire_fees =
(* wire_methods? *)
let wire_method = "x-taler-bank" in
let+ wire_fees =
Pg.use_pool pool @@ fun conn -> Pg.get_wire_fees conn ~wire_method
in
String_map.singleton wire_method wire_fees
in
let wads = [] in
let kyc_enabled = false in
let disable_direct_deposit = false in
let master_public_key = Config.master_public_key in
let reserve_closing_delay = Config.Exchangedb.idle_reserve_expiration_time in
let wallet_balance_limit_without_kyc = None in
let hard_limits = [] in
let zero_limits = [] in
let* denom_l = get_denominations sm_rsa pool in
let list_issue_date = get_denominations_last_change () in
let denom_l =
(* if `?last_issue_date` query param does not exactly match the `stamp_start`
of one of the denomination keys, all keys are returned *)
let stamp_start_opt =
match last_issue_date with
| None -> None
| Some timestamp ->
List.find_map
(fun v ->
if Timestamp.equal v.Denomination.stamp_start timestamp then
Some v.stamp_start
else None)
denom_l
in
match stamp_start_opt with
| None -> denom_l
| Some timestamp ->
List.filter
(fun v -> Timestamp.compare timestamp v.Denomination.stamp_start <= 0)
denom_l
in
let denominations = Denomination.make_denom_group_sorted denom_l in
let* signkeys = get_signkeys sm_eddsa pool in
(* the eddsa pub key used to sign exchange_sig *)
let* exchange_pub =
let now = Timestamp.of_ptime (Mirage_ptime.now ()) in
let opt =
List.find_opt (fun sk -> Signkey.is_valid_at ~timestamp:now sk) signkeys
in
match opt with
| None -> Fmt.error_msg "exchange has no active signkey"
| Some sk -> Ok sk.pub
in
let signkeys = List.map Api.SignKey.of_signkey signkeys in
(* ! depends on denominations order *)
let exchange_sig =
let open Signatures.ExchangeKeySet in
signf
(Secmod_eddsa.sign sm_eddsa exchange_pub)
R.
{
list_issue_date;
hc= Denomination.hash_over_master_sigs denominations;
}
in
let recoup = (* /recoup *) [] in
let* global_fees =
Pg.use_pool pool @@ fun conn ->
Pg.get_global_fees conn ~start_date:Timestamp.zero
in
let* auditors =
(* /auditors/$AUDITOR_PUB/$H_DENOM_PUB *)
Pg.use_pool pool @@ fun conn -> Pg.get_auditor_keys conn
in
let extensions = None in
let extensions_sig = None in
Ok
ExchangeKeysResponse.
{
version;
base_url;
currency;
shopping_url;
open_banking_gateway;
bank_compliance_language;
currency_specification;
tiny_amount;
stefan_abs;
stefan_log;
stefan_lin;
asset_type;
accounts;
wire_fees;
wads;
kyc_enabled;
disable_direct_deposit;
master_public_key;
reserve_closing_delay;
wallet_balance_limit_without_kyc;
hard_limits;
zero_limits;
denominations;
exchange_sig;
exchange_pub;
recoup;
global_fees;
list_issue_date;
auditors;
signkeys;
extensions;
extensions_sig;
}
let jsont = ExchangeKeysResponse.jsont
let keys req server _env =
Logs.info (fun m -> m "GET /keys");
Respond.result req jsont
@@
let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in
let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in
let pool = Vifu.Server.device Mte_device.pool server in
let* last_issue_date =
match Vifu.Queries.get req "last_issue_date" with
| [] -> Ok None
| s :: _ -> (
match Int64.of_string_opt s with
| None ->
Fmt.error_msg "invalid `?last_issue_date` query param, not an int"
| Some n -> Ok (Some (Timestamp.of_s n)))
in
mk_keys sm_eddsa sm_rsa pool last_issue_date

194
src/mte_keys.ml Normal file
View file

@ -0,0 +1,194 @@
open Syntax
open Api
open Time
module String_map = Stdlib.Map.Make (Stdlib.String)
(* TODO *)
let last_change = ref Timestamp.never
let get_denominations_last_change () = !last_change
let warn_once msg =
let b = ref true in
fun () ->
if !b then begin
b := false;
Logs.warn (fun m -> m "%s" msg)
end
let warn_keyring_state_mismatch =
warn_once
"keyring state mismatch: database and secmod have different active keys \
data"
let get_signkeys sm_eddsa pool =
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in
let missing_l, l =
List.partition
(fun sk -> Option.is_none (Secmod_eddsa.find_key sm_eddsa sk.Signkey.pub))
l
in
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let get_denominations sm_rsa pool =
let+ l = Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn () in
let missing_l, l =
List.partition
(fun dn ->
Option.is_none @@ Secmod_rsa.find_key sm_rsa dn.Denomination.h_pub)
l
in
if missing_l <> [] then warn_keyring_state_mismatch ();
l
let mk sm_eddsa sm_rsa pool last_issue_date =
let version = Libtool_version.mte_protocol_version in
let base_url = Config.base_url in
let currency = Config.currency in
let shopping_url = Config.shopping_url in
let open_banking_gateway = Config.open_banking_gateway_url in
let bank_compliance_language = Config.bank_compliance_language in
let currency_specification = Config.Currency.specification in
let tiny_amount = Config.tiny_amount in
let stefan_abs = Config.stefan_abs in
let stefan_log = Config.stefan_log in
let stefan_lin = Config.stefan_lin in
(* type of the asset. "fiat", "crypto", "regional" or "stock". *)
let asset_type = "fiat" in
let* accounts =
Pg.use_pool pool @@ fun conn -> Pg.get_wire_accounts conn ()
in
let* wire_fees =
(* wire_methods? *)
let wire_method = "x-taler-bank" in
let+ wire_fees =
Pg.use_pool pool @@ fun conn -> Pg.get_wire_fees conn ~wire_method
in
String_map.singleton wire_method wire_fees
in
let wads = [] in
let kyc_enabled = false in
let disable_direct_deposit = false in
let master_public_key = Config.master_public_key in
let reserve_closing_delay = Config.Exchangedb.idle_reserve_expiration_time in
let wallet_balance_limit_without_kyc = None in
let hard_limits = [] in
let zero_limits = [] in
let* denom_l = get_denominations sm_rsa pool in
let list_issue_date = get_denominations_last_change () in
let denom_l =
(* if `?last_issue_date` query param does not exactly match the `stamp_start`
of one of the denomination keys, all keys are returned *)
let stamp_start_opt =
match last_issue_date with
| None -> None
| Some timestamp ->
List.find_map
(fun v ->
if Timestamp.equal v.Denomination.stamp_start timestamp then
Some v.stamp_start
else None)
denom_l
in
match stamp_start_opt with
| None -> denom_l
| Some timestamp ->
List.filter
(fun v -> Timestamp.compare timestamp v.Denomination.stamp_start <= 0)
denom_l
in
let denominations = Denomination.make_denom_group_sorted denom_l in
let* signkeys = get_signkeys sm_eddsa pool in
(* the eddsa pub key used to sign exchange_sig *)
let* exchange_pub =
let now = Timestamp.of_ptime (Mirage_ptime.now ()) in
let opt =
List.find_opt (fun sk -> Signkey.is_valid_at ~timestamp:now sk) signkeys
in
match opt with
| None -> Fmt.error_msg "exchange has no active signkey"
| Some sk -> Ok sk.pub
in
let signkeys = List.map Api.SignKey.of_signkey signkeys in
(* ! depends on denominations order *)
let exchange_sig =
let open Signatures.ExchangeKeySet in
signf
(Secmod_eddsa.sign sm_eddsa exchange_pub)
R.
{
list_issue_date;
hc= Denomination.hash_over_master_sigs denominations;
}
in
let recoup = (* /recoup *) [] in
let* global_fees =
Pg.use_pool pool @@ fun conn ->
Pg.get_global_fees conn ~start_date:Timestamp.zero
in
let* auditors =
(* /auditors/$AUDITOR_PUB/$H_DENOM_PUB *)
Pg.use_pool pool @@ fun conn -> Pg.get_auditor_keys conn
in
let extensions = None in
let extensions_sig = None in
Ok
ExchangeKeysResponse.
{
version;
base_url;
currency;
shopping_url;
open_banking_gateway;
bank_compliance_language;
currency_specification;
tiny_amount;
stefan_abs;
stefan_log;
stefan_lin;
asset_type;
accounts;
wire_fees;
wads;
kyc_enabled;
disable_direct_deposit;
master_public_key;
reserve_closing_delay;
wallet_balance_limit_without_kyc;
hard_limits;
zero_limits;
denominations;
exchange_sig;
exchange_pub;
recoup;
global_fees;
list_issue_date;
auditors;
signkeys;
extensions;
extensions_sig;
}
let f req server _env =
Logs.info (fun m -> m "GET /keys");
Respond.result req ExchangeKeysResponse.jsont
@@
let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in
let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in
let pool = Vifu.Server.device Mte_device.pool server in
let* last_issue_date =
match Vifu.Queries.get req "last_issue_date" with
| [] -> Ok None
| s :: _ -> (
match Int64.of_string_opt s with
| None ->
Fmt.error_msg "invalid `?last_issue_date` query param, not an int"
| Some n -> Ok (Some (Timestamp.of_s n)))
in
mk sm_eddsa sm_rsa pool last_issue_date

307
src/mte_management.ml
View file

@ -7,9 +7,8 @@ let request_of_json req =
Vifu.Request.of_json req |> Result.map_error (fun (`Msg e) -> `Json_decode e)
module Future_keys = struct
let make_future_sk sm_eddsa (pub, (start, expire)) =
Logs.debug (fun m -> m "make_future_sk: `%a`" Eddsa.pp_pub pub);
let open Time in
let make_fsk sm_eddsa (pub, (start, expire)) =
Logs.debug (fun m -> m "make_fsk: `%a`" Eddsa.pp_pub pub);
let stamp_start = Timestamp.of_absolute start in
let stamp_expire = Timestamp.of_absolute expire in
let stamp_end =
@ -25,10 +24,10 @@ module Future_keys = struct
(Secmod_eddsa.sign_secmod sm_eddsa)
{ exchange_pub; anchor_time; duration }
in
Api.FutureSignKey.
FutureSignKey.
{ key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }
let make_future_dn sm_rsa (h_pub, (coin, pub, start)) =
let make_fdn sm_rsa (h_pub, (coin, pub, start)) =
let {
Config.Coin.section_name;
value;
@ -43,8 +42,7 @@ module Future_keys = struct
} =
coin
in
Logs.debug (fun m -> m "make_future_dn: `%a`" DenominationHash.pp h_pub);
let open Time in
Logs.debug (fun m -> m "make_fdn: `%a`" DenominationHash.pp h_pub);
let stamp_start = Timestamp.of_absolute start in
let stamp_expire_withdraw =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_withdraw
@ -55,7 +53,6 @@ module Future_keys = struct
let stamp_expire_legal =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_legal
in
let open Api in
let rsa_denomination_key =
RsaDenominationKey.{ age_mask= 0; rsa_pub= pub }
in
@ -66,7 +63,7 @@ module Future_keys = struct
(Secmod_rsa.sign_secmod sm_rsa)
{
h_denom_pub= h_pub;
h_section_name= Hash.H64_cstring.hash section_name;
h_section_name= H64_cstring.hash section_name;
anchor_time= stamp_start;
duration_withdraw= Timestamp.diff stamp_start stamp_expire_withdraw;
}
@ -87,65 +84,14 @@ module Future_keys = struct
denom_secmod_sig;
}
let make_future_keys_response sm_eddsa sm_rsa pool =
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
(* get keys from database to filter out keys already certified *)
let* sk_db_l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in
let sk_ht = Hashtbl.create 0xff in
List.iter (fun sk -> Hashtbl.replace sk_ht sk.Signkey.pub ()) sk_db_l;
let future_signkeys =
Secmod_eddsa.keys sm_eddsa
|> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub)
|> List.map (make_future_sk sm_eddsa)
in
let* dn_db_l =
Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn ()
in
let dn_ht = Hashtbl.create 0xff in
List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub ()) dn_db_l;
let future_denoms =
Secmod_rsa.keys sm_rsa
|> List.filter (fun (h_pub, _) -> not @@ Hashtbl.mem dn_ht h_pub)
|> List.map (make_future_dn sm_rsa)
in
Logs.info (fun m ->
m "%d future signkey(s) and %d future denomination(s) to certify"
(List.length future_signkeys)
(List.length future_denoms));
let signkey_secmod_public_key = Secmod_eddsa.sm_pub sm_eddsa in
let denom_secmod_public_key = Secmod_rsa.sm_pub sm_rsa in
Ok
Api.FutureKeysResponse.
{
future_denoms;
future_signkeys;
master_pub= Config.Exchange.master_public_key;
denom_secmod_public_key;
signkey_secmod_public_key;
}
let find_future_signkey sm_eddsa pub =
match Secmod_eddsa.find_key sm_eddsa pub with
| None -> Fmt.error_msg "future signkey not found"
| Some (pub, (t1, t2)) ->
let fsk = make_future_sk sm_eddsa (pub, (t1, t2)) in
Ok fsk
let find_future_denomination sm_rsa h_pub =
match Secmod_rsa.find_key sm_rsa h_pub with
| None -> Fmt.error_msg "future denomination not found"
| Some v ->
let future_dn = make_future_dn sm_rsa v in
Ok future_dn
let sk_of_future_sk
Api.FutureSignKey.
let sk_of_fsk
FutureSignKey.
{ key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ }
master_sig =
Signkey.{ pub= key; stamp_start; stamp_expire; stamp_end; master_sig }
let dn_of_future_dn
Api.FutureDenom.
let dn_of_fdn
FutureDenom.
{
section_name= _;
value;
@ -160,7 +106,7 @@ module Future_keys = struct
fee_refund;
denom_secmod_sig= _;
} h_pub master_sig =
let (Rsa Api.RsaDenominationKey.{ age_mask= _; rsa_pub }) = denom_pub in
let (Rsa RsaDenominationKey.{ age_mask= _; rsa_pub }) = denom_pub in
Denomination.
{
pub= rsa_pub;
@ -178,110 +124,112 @@ module Future_keys = struct
master_sig;
}
let verify_future_signkey sm_eddsa Api.SignKeySignature.{ key; master_sig } =
let* fsk = find_future_signkey sm_eddsa key in
let sk = sk_of_future_sk fsk master_sig in
Signkey.verify_exchange_signing_key_validity ~key:Config.master_public_key
sk
let verify_future_denomination sm_rsa
Api.DenomSignature.{ h_denom_pub; master_sig } =
let* fdn = find_future_denomination sm_rsa h_denom_pub in
let dn = dn_of_future_dn fdn h_denom_pub master_sig in
Denomination.verify_denomination_key_validity ~key:Config.master_public_key
dn
let certify_future_signkey sm_eddsa pool
Api.SignKeySignature.{ key= pub; master_sig } =
let find_fsk sm_eddsa pub =
match Secmod_eddsa.find_key sm_eddsa pub with
| None -> Error (`Not_found "future eddsa key")
| Some (pub, (t1, t2)) ->
(* rebuild it *)
let future_sk = make_future_sk sm_eddsa (pub, (t1, t2)) in
let sk = sk_of_future_sk future_sk master_sig in
let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_signkey conn sk in
Logs.info (fun m -> m "certified signkey `%a`" Eddsa.pp_pub sk.pub);
()
let fsk = make_fsk sm_eddsa (pub, (t1, t2)) in
Ok fsk
let certify_future_denomination sm_rsa pool
Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } =
let find_fdn sm_rsa h_pub =
match Secmod_rsa.find_key sm_rsa h_pub with
| None -> Error (`Not_found "future rsa denomination key")
| Some (h_pub, (section_name, pub, t1)) ->
let future_dn =
make_future_dn sm_rsa (h_pub, (section_name, pub, t1))
in
let dn = dn_of_future_dn future_dn h_pub master_sig in
let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_denom conn dn in
Logs.info (fun m ->
m "certified denomination `%a`" DenominationHash.pp dn.h_pub);
()
let revoke_signkey sm_eddsa pool pub revoked_sig =
let* opt = Pg.use_pool pool @@ fun conn -> Pg.find_signkey conn pub in
match opt with
| None -> Fmt.error_msg "signkey not found"
| Some _sk ->
let* () = Secmod_eddsa.revoke sm_eddsa pub in
let+ () =
Pg.use_pool pool @@ fun conn ->
Pg.insert_signkey_revocation conn pub revoked_sig
in
Logs.info (fun m -> m "revoked signkey `%a`" Eddsa.pp_pub pub);
()
let revoke_denomination sm_rsa pool h_pub revoked_sig =
let* opt =
Pg.use_pool pool @@ fun conn -> Pg.find_denomination conn h_pub
in
match opt with
| None -> Fmt.error_msg "denomination not found"
| Some dn ->
let* () = Secmod_rsa.revoke sm_rsa dn.h_pub in
let+ () =
Pg.use_pool pool @@ fun conn ->
Pg.insert_denomination_revocation conn dn.h_pub revoked_sig
in
Logs.info (fun m ->
m "revoked denomination `%a`" DenominationHash.pp h_pub);
()
| Some v ->
let fdn = make_fdn sm_rsa v in
Ok fdn
end
module Keys_get = struct
let jsont = FutureKeysResponse.jsont
let process sm_eddsa sm_rsa pool =
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
(* get keys from database to filter out keys already certified *)
let* sk_db_l = Pg.use_pool pool @@ fun conn -> Pg.get_signkeys conn ~now in
let sk_ht = Hashtbl.create 0xff in
List.iter (fun sk -> Hashtbl.replace sk_ht sk.Signkey.pub ()) sk_db_l;
let future_signkeys =
Secmod_eddsa.keys sm_eddsa
|> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub)
|> List.map (Future_keys.make_fsk sm_eddsa)
in
let* dn_db_l =
Pg.use_pool pool @@ fun conn -> Pg.get_denominations conn ()
in
let dn_ht = Hashtbl.create 0xff in
List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub ()) dn_db_l;
let future_denoms =
Secmod_rsa.keys sm_rsa
|> List.filter (fun (h_pub, _) -> not @@ Hashtbl.mem dn_ht h_pub)
|> List.map (Future_keys.make_fdn sm_rsa)
in
Logs.info (fun m ->
m "%d future signkey(s) and %d future denomination(s) to certify"
(List.length future_signkeys)
(List.length future_denoms));
let signkey_secmod_public_key = Secmod_eddsa.sm_pub sm_eddsa in
let denom_secmod_public_key = Secmod_rsa.sm_pub sm_rsa in
Ok
FutureKeysResponse.
{
future_denoms;
future_signkeys;
master_pub= Config.Exchange.master_public_key;
denom_secmod_public_key;
signkey_secmod_public_key;
}
let f req server _env =
Logs.info (fun m -> m "GET /management/keys/");
let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in
let sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in
let pool = Vifu.Server.device Mte_device.pool server in
Respond.result req jsont
Respond.result req FutureKeysResponse.jsont
@@
let* v = Future_keys.make_future_keys_response sm_eddsa sm_rsa pool in
let* v = process sm_eddsa sm_rsa pool in
Ok v
end
module Keys_post = struct
let verify_sk sk = Signkey.verify ~master_key:Config.master_public_key sk
let verify_dn dn = Denomination.verify ~master_key:Config.master_public_key dn
let verify_fsk sm_eddsa SignKeySignature.{ key; master_sig } =
let* fsk = Future_keys.find_fsk sm_eddsa key in
let sk = Future_keys.sk_of_fsk fsk master_sig in
verify_sk sk
let verify_fdn sm_rsa DenomSignature.{ h_denom_pub= h_pub; master_sig } =
let* fdn = Future_keys.find_fdn sm_rsa h_pub in
let dn = Future_keys.dn_of_fdn fdn h_pub master_sig in
verify_dn dn
let certify_fsk sm_eddsa pool SignKeySignature.{ key; master_sig } =
let* fsk = Future_keys.find_fsk sm_eddsa key in
let sk = Future_keys.sk_of_fsk fsk master_sig in
let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_signkey conn sk in
Logs.info (fun m -> m "certified signkey `%a`" Eddsa.pp_pub sk.pub);
()
let certify_fdn sm_rsa pool DenomSignature.{ h_denom_pub= h_pub; master_sig }
=
let* fdn = Future_keys.find_fdn sm_rsa h_pub in
let dn = Future_keys.dn_of_fdn fdn h_pub master_sig in
let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_denom conn dn in
Logs.info (fun m ->
m "certified denomination `%a`" DenominationHash.pp dn.h_pub);
()
let verify sm_eddsa sm_rsa MasterSignatures.{ denom_sigs; signkey_sigs } =
let* () =
list_iter (Future_keys.verify_future_signkey sm_eddsa) signkey_sigs
in
let* () =
list_iter (Future_keys.verify_future_denomination sm_rsa) denom_sigs
in
let* () = list_iter (verify_fsk sm_eddsa) signkey_sigs in
let* () = list_iter (verify_fdn sm_rsa) denom_sigs in
Ok ()
let process sm_eddsa sm_rsa pool MasterSignatures.{ denom_sigs; signkey_sigs }
=
let* () =
list_iter (Future_keys.certify_future_signkey sm_eddsa pool) signkey_sigs
in
let* () =
list_iter (Future_keys.certify_future_denomination sm_rsa pool) denom_sigs
in
let* () = list_iter (certify_fsk sm_eddsa pool) signkey_sigs in
let* () = list_iter (certify_fdn sm_rsa pool) denom_sigs in
Ok ()
let jsont = MasterSignatures.jsont
let json_enc = Vifu.Type.json_encoding MasterSignatures.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/keys/");
@ -301,13 +249,23 @@ module Denom_revoke = struct
let open Signatures.MasterDenominationKeyRevocation in
verify Config.master_public_key master_sig { h_denom_pub }
let process sm_rsa pool h_denom_pub DenomRevocationSignature.{ master_sig } =
let+ () =
Future_keys.revoke_denomination sm_rsa pool h_denom_pub master_sig
let process sm_rsa pool h_pub DenomRevocationSignature.{ master_sig } =
let* opt =
Pg.use_pool pool @@ fun conn -> Pg.find_denomination conn h_pub
in
()
match opt with
| None -> Error (`Not_found "denomination not found")
| Some _dn ->
let* () = Secmod_rsa.revoke sm_rsa h_pub in
let+ () =
Pg.use_pool pool @@ fun conn ->
Pg.insert_denomination_revocation conn h_pub master_sig
in
Logs.info (fun m ->
m "revoked denomination `%a`" DenominationHash.pp h_pub);
()
let jsont = DenomRevocationSignature.jsont
let json_enc = Vifu.Type.json_encoding DenomRevocationSignature.jsont
let f req h_denom_pub server _env =
Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
@ -330,14 +288,20 @@ module Signkey_revoke = struct
let open Signatures.MasterSigningKeyRevocation in
verify Config.master_public_key master_sig { exchange_pub }
let process sm_eddsa pool exchange_pub
SignkeyRevocationSignature.{ master_sig } =
let+ () =
Future_keys.revoke_signkey sm_eddsa pool exchange_pub master_sig
in
()
let process sm_eddsa pool pub SignkeyRevocationSignature.{ master_sig } =
let* opt = Pg.use_pool pool @@ fun conn -> Pg.find_signkey conn pub in
match opt with
| None -> Error (`Not_found "signkey not found")
| Some _sk ->
let* () = Secmod_eddsa.revoke sm_eddsa pub in
let+ () =
Pg.use_pool pool @@ fun conn ->
Pg.insert_signkey_revocation conn pub master_sig
in
Logs.info (fun m -> m "revoked signkey `%a`" Eddsa.pp_pub pub);
()
let jsont = SignkeyRevocationSignature.jsont
let json_enc = Vifu.Type.json_encoding SignkeyRevocationSignature.jsont
let f req exchange_pub server _env =
Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
@ -388,7 +352,9 @@ module Auditors = struct
()
| Some auditor ->
if Timestamp.compare validity_start auditor.last_change <= 0 then
Error (`Conflict "replay detected on enable-auditor")
Error
(`Replay_attack
("/management/auditors/", auditor.last_change, validity_start))
else
let+ () =
Pg.use_pool pool @@ fun conn -> Pg.update_auditor conn auditor
@ -396,7 +362,7 @@ module Auditors = struct
Logs.info (fun m -> m "updated auditor");
()
let jsont = AuditorSetupMessage.jsont
let json_enc = Vifu.Type.json_encoding AuditorSetupMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/auditors/");
@ -424,7 +390,11 @@ module Auditors_disable = struct
| None -> Error (`Not_found "auditor pub key")
| Some auditor -> (
if Timestamp.compare validity_end auditor.last_change <= 0 then
Error (`Conflict "replay detected on disable-auditor")
Error
(`Replay_attack
( "/management/auditors/$AUDITOR_PUB/disable/",
auditor.last_change,
validity_end ))
else
match auditor.is_active with
| false ->
@ -441,7 +411,7 @@ module Auditors_disable = struct
m "revoked auditor `%a`" Eddsa.pp_pub auditor_pub);
())
let jsont = AuditorTeardownMessage.jsont
let json_enc = Vifu.Type.json_encoding AuditorTeardownMessage.jsont
let f req auditor_pub server _env =
Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/");
@ -503,7 +473,7 @@ module Wire_fee = struct
"invalid database state, multiple wire-fee found in database for \
this time frame"
let jsont = WireFeeSetupMessage.jsont
let json_enc = Vifu.Type.json_encoding WireFeeSetupMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/wire-fee/");
@ -547,7 +517,7 @@ module Global_fees = struct
"invalid database state, multiple global-fees found in database for \
this time frame"
let jsont = GlobalFees.jsont
let json_enc = Vifu.Type.json_encoding GlobalFees.jsont
(* TODO better global_fees
ensure it is defined for the current time.
@ -655,7 +625,8 @@ module Wire = struct
()
| Some (wire, _is_active, last_change) ->
if Timestamp.compare validity_start last_change <= 0 then
Error (`Conflict "replay detected on enable-wire")
Error
(`Replay_attack ("/management/wire/", last_change, validity_start))
else
let+ () =
Pg.use_pool pool @@ fun conn ->
@ -664,7 +635,7 @@ module Wire = struct
Logs.info (fun m -> m "updated wire method");
()
let jsont = WireSetupMessage.jsont
let json_enc = Vifu.Type.json_encoding WireSetupMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/wire/");
@ -690,7 +661,9 @@ module Wire_disable = struct
| None -> Error (`Not_found "wire payto-uri")
| Some (wire, _is_active, last_change) ->
if Timestamp.compare validity_end last_change <= 0 then
Error (`Conflict "replay detected on disable-wire")
Error
(`Replay_attack
("/management/wire/disable/", last_change, validity_end))
else
let+ () =
Pg.use_pool pool @@ fun conn ->
@ -699,7 +672,7 @@ module Wire_disable = struct
Logs.info (fun m -> m "disabled wire method");
()
let jsont = WireTeardownMessage.jsont
let json_enc = Vifu.Type.json_encoding WireTeardownMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/wire/disable/");
@ -749,7 +722,7 @@ module Drain = struct
Logs.info (fun m -> m "added drain profit message to database");
()
let jsont = DrainProfitsMessage.jsont
let json_enc = Vifu.Type.json_encoding DrainProfitsMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/drain/");
@ -789,7 +762,7 @@ module AmlOfficer = struct
in
()
let jsont = AmlOfficerSetup.jsont
let json_enc = Vifu.Type.json_encoding AmlOfficerSetup.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/aml-officers/");
@ -829,7 +802,7 @@ module Partners = struct
let+ () = Pg.use_pool pool @@ fun conn -> Pg.insert_partner conn v in
()
let jsont = ExchangePartnerSetupRequest.jsont
let json_enc = Vifu.Type.json_encoding ExchangePartnerSetupRequest.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/partners/");

10
src/mte_seed.ml Normal file
View file

@ -0,0 +1,10 @@
(* TODO crypto
is this ok?
maybe don't use the same RNG-initialization as the one used to generate keys *)
let f req _server _env =
Logs.info (fun m -> m "GET /seed");
let open Vifu.Response in
let open Syntax in
let* () = add ~field:"content-type" "application/octet-stream" in
let* () = with_string req (Mirage_crypto_rng.generate 64) in
respond `OK

42
src/mte_terms.ml
View file

@ -1,42 +0,0 @@
(* /terms + /privacy *)
let aux asset req _server _env =
let etag = Assets.etag asset in
let headers = Vifu.Request.headers req in
let has_matching_etag =
match Vifu.Headers.get headers "if-none-match" with
| None -> false
| Some s -> String.equal etag s
in
match has_matching_etag with
| true -> Respond.not_modified ()
| 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 asset in
(* -- *)
let open Vifu.Response in
let open Syntax in
let* () = with_string ?compression req data in
let* () = add ~field:"etag" etag in
let* () =
add ~field:"taler-terms-version" Assets.Cfg.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 in
add ~field:"content-type" content_type
in
let* () = add ~field:"content-language" lang in
respond `OK
let terms req _server _env =
Logs.info (fun m -> m "GET /terms");
aux Assets.Terms req _server _env
let privacy req _server _env =
Logs.info (fun m -> m "GET /privacy");
aux Assets.Privacy req _server _env

119
src/mte_tos.ml Normal file
View file

@ -0,0 +1,119 @@
(* /terms + /privacy *)
module Cfg = struct
let default_encoding : [< `Identity | `DEFLATE | `Gzip ] = `Identity
let default_mimetype = ("text", "plain")
let default_language = "en"
let terms_legal_version = "0"
let terms_dir = "terms"
let privacy_dir = "privacy"
end
let terms = Assets.load Cfg.terms_dir Config.terms_etag
let privacy = Assets.load Cfg.privacy_dir Config.privacy_etag
let asset_etag t =
match t with `Terms -> Config.terms_etag | `Privacy -> Config.privacy_etag
let asset_data t = match t with `Terms -> terms | `Privacy -> privacy
let has_matching_etag etag headers =
match Vifu.Headers.get headers "if-none-match" with
| None -> false
| Some s -> String.equal etag s
(* todo: should have a middleware for this *)
let select_encoding headers =
let opt = Vifu.Headers.get headers "accept-encoding" in
Cohttp.Accept.encodings opt
|> Cohttp.Accept.qsort
|> List.map snd
|> List.find_map (function
| Cohttp.Accept.Identity -> Some `Identity
| Deflate -> Some `DEFLATE
| Gzip -> Some `Gzip
| AnyEncoding -> Some Cfg.default_encoding
| Encoding _ | Compress -> None)
|> function
| None -> None
| Some `Identity -> None
| Some `DEFLATE -> Some `DEFLATE
| Some `Gzip -> Some `Gzip
let get_accept headers =
Vifu.Headers.get headers "accept"
|> Cohttp.Accept.media_ranges
|> Cohttp.Accept.qsort
|> List.map (fun (_q, (m, _p)) -> m)
let get_accept_language headers =
Vifu.Headers.get headers "accept-language"
|> Cohttp.Accept.languages
|> Cohttp.Accept.qsort
|> List.map snd
let avail_languages t =
let supported_languages, _, _ = asset_data t in
Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") Fmt.string) supported_languages
let pp_mimetype fmt mime = Fmt.pf fmt "%s/%s" (fst mime) (snd mime)
let accept t =
let _, supported_mimetypes, _ = asset_data t in
Fmt.str "%a" (Fmt.array ~sep:(Fmt.any ", ") pp_mimetype) supported_mimetypes
let get_content t accept accept_language =
let supported_languages, supported_mimetypes, content_matrix = asset_data t in
let find_lang_index = function
| Cohttp.Accept.AnyLanguage ->
Array.find_index
(fun mm' -> Cfg.default_language = mm')
supported_languages
| Language language_range -> (
(* ignore language subtags (e.g. "en-US" -> "en") *)
match language_range with
| [] -> assert false
| lang :: _ ->
Array.find_index (fun mm' -> lang = mm') supported_languages)
in
let find_mime_index = function
| Cohttp.Accept.AnyMedia ->
Array.find_index (( = ) Cfg.default_mimetype) supported_mimetypes
| MediaType (m, mm) -> Array.find_index (( = ) (m, mm)) supported_mimetypes
| AnyMediaSubtype m ->
Array.find_index (fun (m', _) -> m = m') supported_mimetypes
in
let i = List.find_map find_lang_index accept_language in
let j = List.find_map find_mime_index accept in
(* TODO *)
let i = Option.get i in
let j = Option.get j in
(supported_languages.(i), supported_mimetypes.(j), content_matrix.(i).(j))
let aux t req _server _env =
let headers = Vifu.Request.headers req in
if has_matching_etag (asset_etag t) headers then Respond.not_modified ()
else
let compression = select_encoding headers in
let language, mimetype, content =
get_content t (get_accept headers) (get_accept_language headers)
in
(* -- *)
let open Vifu.Response in
let open Syntax in
let* () = with_string ?compression req content in
let* () = add ~field:"etag" (asset_etag t) in
let* () = add ~field:"taler-terms-version" Cfg.terms_legal_version in
let* () = add ~field:"accept" (accept t) in
let* () = add ~field:"avail-languages" (avail_languages t) in
let* () = add ~field:"content-type" (Fmt.str "%a" pp_mimetype mimetype) in
let* () = add ~field:"content-language" language in
respond `OK
let terms req _server _env =
Logs.info (fun m -> m "GET /terms");
aux `Terms req _server _env
let privacy req _server _env =
Logs.info (fun m -> m "GET /privacy");
aux `Privacy req _server _env

1
src/respond.ml
View file

@ -31,6 +31,7 @@ let map_err_status err =
match err with
| `Json_decode _ | `Bin_decode _ -> `Bad_request
| `Invalid_signature_eddsa | `Invalid_signature_rsa -> `Forbidden
| `Replay_attack _ -> `Conflict
| `Not_found _ -> `Not_found
| `Conflict _ -> `Conflict
| `Caqti _s | `Mfat _s | `Json_encode _s | `Bin_encode _s | `Msg _s ->

5
src/result.ml
View file

@ -1,10 +1,12 @@
include Stdlib.Result
open Time
type err =
[ `Json_decode of string
| `Bin_decode of string
| `Invalid_signature_eddsa
| `Invalid_signature_rsa
| `Replay_attack of string * Timestamp.t * Timestamp.t
| (* - *)
`Not_found of string
| `Conflict of string
@ -25,6 +27,9 @@ let err_to_string : err -> string = function
| `Bin_encode s -> Fmt.str "Bin encode: %s" s
| `Invalid_signature_eddsa -> Fmt.str "Invalid eddsa signature"
| `Invalid_signature_rsa -> Fmt.str "Invalid rsa signature"
| `Replay_attack (url, ours, theirs) ->
Fmt.str "Replay attack detected on %s. Got `%a` but received `%a`" url
Timestamp.pp ours Timestamp.pp theirs
(* - *)
| `Not_found s -> Fmt.str "Not found: %s" s
| `Conflict s -> Fmt.str "Conflict: %s" s

4
src/signkey.ml
View file

@ -8,9 +8,9 @@ type t = {
master_sig: Signatures.ExchangeSigningKeyValidity.t;
}
let verify_exchange_signing_key_validity ~key sk =
let verify ~master_key sk =
let open Signatures.ExchangeSigningKeyValidity in
verify key sk.master_sig
verify master_key sk.master_sig
{
R.start= sk.stamp_start;
expire= sk.stamp_expire;