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

9
GNUmakefile
View file

@ -16,8 +16,8 @@ pin-deps:
opam pin --no-action --yes add mhttp "git+https://github.com/robur-coop/mhttp.git#b2e55ae693b07ad3ef87c26c37c8f5d14c2e205c"
opam pin --no-action --yes add vif "git+https://github.com/swrup/vif.git#1b16040ba06c6af82019f02811e781e81084d269"
opam pin --no-action --yes add vifu "git+https://github.com/swrup/vif.git#1b16040ba06c6af82019f02811e781e81084d269"
opam pin --no-action --yes "git+https://github.com/robur-coop/mfat.git#5b1204d914e853f0139c6d2776511f530b753550"
opam pin --no-action --yes "git+https://github.com/swrup/mirage-mtime.git#6a6bb4dd25624a3c43e6417dcdf73f3c689946a7"
opam pin --no-action --yes add mfat "git+https://github.com/robur-coop/mfat.git#5b1204d914e853f0139c6d2776511f530b753550"
opam pin --no-action --yes add mirage-mtime "git+https://github.com/swrup/mirage-mtime.git#6a6bb4dd25624a3c43e6417dcdf73f3c689946a7"
opam pin --no-action --yes add caqti "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0"
opam pin --no-action --yes add caqti-miou "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0"
opam pin --no-action --yes add caqti-mnet "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0"
@ -27,9 +27,12 @@ pin-deps:
install-deps:
# opam install --yes mcrunch
opam install --yes dune utop merlin ocp-browser ocamlformat
opam install --yes solo5 ocaml-solo5
opam install --yes crunch
opam install --yes mirage-mtime
opam install --yes sqlite3 # needed for caqti even if not used
opam install --yes caqti-driver-pgx
opam install --yes caqti-mnet
opam install --yes $(vendors_list)
.PHONY: vendors
@ -45,7 +48,7 @@ clean:
rm -rf vendors/
assets:
@cp default/assets ./
@cp -r default/assets ./
fat-image:
@mkdir -p assets

4
network.sh
View file

@ -1,9 +1,9 @@
#!/bin/bash
set -e
sudo ip link add br0 type bridge
sudo ip link add name br0 type bridge
sudo ip addr add 10.0.0.1/24 dev br0
sudo ip tuntap add tap0 mode tap
sudo ip tuntap add name tap0 mode tap
sudo ip link set tap0 master br0
sudo ip link set br0 up
sudo ip link set tap0 up

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;

58
test/validate.ml
View file

@ -42,9 +42,7 @@ let keys content =
let sk_l = List.map SignKey.to_signkey v.signkeys in
let* () =
sk_l
|> list_iter
(Signkey.verify_exchange_signing_key_validity ~key:v.master_public_key)
sk_l |> list_iter (Signkey.verify ~master_key:v.master_public_key)
in
let* () =
@ -71,13 +69,12 @@ let keys content =
let denom_l = v.denominations |> Denomination.denoms_of_denomgroups in
let* () =
denom_l
|> list_iter
(Denomination.verify_denomination_key_validity ~key:v.master_public_key)
denom_l |> list_iter (Denomination.verify ~master_key:v.master_public_key)
in
let* () =
(* TODO O(n^2) *)
let dn_ht = Hashtbl.create 0xff in
List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub dn) denom_l;
v.auditors
|> List.concat_map
(fun
@ -87,30 +84,29 @@ let keys content =
let auditor_url_hash = H64_cstring.hash auditor_url in
denomination_keys
|> List.map
(fun AuditorDenominationKey.{ denom_pub_h; auditor_sig } ->
(denom_pub_h, auditor_url_hash, auditor_pub, auditor_sig)))
|> list_iter
(fun (denom_pub_h, auditor_url_hash, auditor_pub, auditor_sig) ->
let open Denomination in
denom_l |> List.find_opt (fun dn -> dn.h_pub = denom_pub_h)
|> function
| None -> Fmt.error_msg "auditor denomination key not found"
| Some dn ->
let open Signatures.ExchangeKeyValidity in
verify auditor_pub auditor_sig
{
auditor_url_hash;
master= auditor_pub;
start= dn.stamp_start;
expire_withdraw= dn.stamp_expire_withdraw;
expire_spend= dn.stamp_expire_deposit;
expire_legal= dn.stamp_expire_legal;
value= dn.value;
fee_withdraw= dn.fee_withdraw;
fee_deposit= dn.fee_deposit;
fee_refresh= dn.fee_refresh;
denom_hash= dn.h_pub;
})
(fun
AuditorDenominationKey.{ denom_pub_h= h_pub; auditor_sig } ->
(h_pub, (auditor_url_hash, auditor_pub, auditor_sig))))
|> list_iter (fun (h_pub, (auditor_url_hash, auditor_pub, auditor_sig)) ->
Hashtbl.find_opt dn_ht h_pub |> function
| None -> Fmt.error_msg "auditor denomination key not found"
| Some dn ->
let open Denomination in
let open Signatures.ExchangeKeyValidity in
verify auditor_pub auditor_sig
{
auditor_url_hash;
master= auditor_pub;
start= dn.stamp_start;
expire_withdraw= dn.stamp_expire_withdraw;
expire_spend= dn.stamp_expire_deposit;
expire_legal= dn.stamp_expire_legal;
value= dn.value;
fee_withdraw= dn.fee_withdraw;
fee_deposit= dn.fee_deposit;
fee_refresh= dn.fee_refresh;
denom_hash= dn.h_pub;
})
in
Ok ()

4
tools/offline_impl.ml
View file

@ -4,6 +4,10 @@ open Hash
let () = Mirage_crypto_rng_unix.use_default ()
(* TODO monotonic time:
add something for tests / broken monotonic time
https://docs.taler.net/manpages/taler-exchange-offline.1.html#security-considerations *)
let now_s () =
let ns = Mtime_clock.now_ns () in
Int64.unsigned_div ns 1_000_000_000L