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 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 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 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 add mfat "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 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 "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-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" 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: install-deps:
# opam install --yes mcrunch # opam install --yes mcrunch
opam install --yes dune utop merlin ocp-browser ocamlformat opam install --yes dune utop merlin ocp-browser ocamlformat
opam install --yes solo5 ocaml-solo5
opam install --yes crunch opam install --yes crunch
opam install --yes mirage-mtime
opam install --yes sqlite3 # needed for caqti even if not used opam install --yes sqlite3 # needed for caqti even if not used
opam install --yes caqti-driver-pgx opam install --yes caqti-driver-pgx
opam install --yes caqti-mnet
opam install --yes $(vendors_list) opam install --yes $(vendors_list)
.PHONY: vendors .PHONY: vendors
@ -45,7 +48,7 @@ clean:
rm -rf vendors/ rm -rf vendors/
assets: assets:
@cp default/assets ./ @cp -r default/assets ./
fat-image: fat-image:
@mkdir -p assets @mkdir -p assets

4
network.sh
View file

@ -1,9 +1,9 @@
#!/bin/bash #!/bin/bash
set -e 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 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 tap0 master br0
sudo ip link set br0 up sudo ip link set br0 up
sudo ip link set tap0 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 (* https://docs.taler.net/design-documents/003-tos-rendering.html
must support `text/plain` and `text/markdown` *) must support `text/plain` and `text/markdown` *)
module Cfg = struct
let config = "mte.conf"
end
let failure fmt = let failure fmt =
Fmt.kstr Fmt.kstr
(fun s -> (fun s ->
@ -8,157 +12,78 @@ let failure fmt =
exit 1) exit 1)
fmt fmt
type t = let config =
| Terms match Assets_crunch.read Cfg.config with
| Privacy | None -> failure "static configuration file `%s` not found" Cfg.config
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
| Some data -> data | 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 open Config_parser
module Cfg = struct let config = Config_section.parse Assets.config
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
module Exchange = struct module Exchange = struct
let get_opt field = get_opt config_data ~section:"exchange" ~field let get_opt field = get_opt config ~section:"exchange" ~field
let get field = get config_data ~section:"exchange" ~field let get field = get config ~section:"exchange" ~field
(* - *) (* - *)
let currency = (* todo: constraint on currency string *) get "currency" 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 aml_spa_dialect = get_opt "aml_spa_dialect"
let toplevel_redirect_url = get_opt "toplevel_redirect_url" let toplevel_redirect_url = get_opt "toplevel_redirect_url"
let tiny_amount = get_opt "tiny_amount" |> Option.map amount 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 end
module Exchangedb = struct 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 = let idle_reserve_expiration_time =
@ -81,8 +63,7 @@ module Exchangedb = struct
end end
module Exchangedb_postgres = struct module Exchangedb_postgres = struct
let config = let config = get config ~section:"exchangedb-postgres" ~field:"config" |> uri
get config_data ~section:"exchangedb-postgres" ~field:"config" |> uri
end end
module Currency = struct module Currency = struct
@ -99,10 +80,10 @@ module Currency = struct
let currency_sections = let currency_sections =
List.filter List.filter
(fun v -> String.starts_with ~prefix:"currency-" v.header) (fun v -> String.starts_with ~prefix:"currency-" v.header)
config_data config
let parse_currency section = 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; enabled= get "enabled" |> yes_no;
code= get "code"; code= get "code";
@ -160,10 +141,10 @@ module Coin = struct
(* ! '_' not '-' *) (* ! '_' not '-' *)
let prefix = "coin_" in let prefix = "coin_" in
let prefix_len = String.length prefix in let prefix_len = String.length prefix in
config_data config
|> List.filter (fun v -> String.starts_with ~prefix v.header) |> List.filter (fun v -> String.starts_with ~prefix v.header)
|> List.map (fun section -> |> 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 = let section_name =
String.sub section.header prefix_len String.sub section.header prefix_len
(String.length section.header - prefix_len) (String.length section.header - prefix_len)
@ -191,7 +172,7 @@ end
module Exchange_secmod_rsa = struct module Exchange_secmod_rsa = struct
let get field = let get field =
let section = "taler-exchange-secmod-" ^ "rsa" in let section = "taler-exchange-secmod-" ^ "rsa" in
get config_data ~section ~field get config ~section ~field
let lookahead = get "lookahead_sign" |> duration let lookahead = get "lookahead_sign" |> duration
let overlap = get "overlap_duration" |> duration let overlap = get "overlap_duration" |> duration
@ -200,7 +181,7 @@ end
module Exchange_secmod_eddsa = struct module Exchange_secmod_eddsa = struct
let get field = let get field =
let section = "taler-exchange-secmod-" ^ "eddsa" in let section = "taler-exchange-secmod-" ^ "eddsa" in
get config_data ~section ~field get config ~section ~field
let lookahead = get "lookahead_sign" |> duration let lookahead = get "lookahead_sign" |> duration
let overlap = get "overlap_duration" |> duration let overlap = get "overlap_duration" |> duration

6
src/denomination.ml
View file

@ -17,11 +17,11 @@ type t = {
master_sig: Signatures.DenominationKeyValidity.t; master_sig: Signatures.DenominationKeyValidity.t;
} }
let verify_denomination_key_validity ~key dn = let verify ~master_key dn =
let open Signatures.DenominationKeyValidity in 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; start= dn.stamp_start;
expire_withdraw= dn.stamp_expire_withdraw; expire_withdraw= dn.stamp_expire_withdraw;
expire_spend= dn.stamp_expire_deposit; expire_spend= dn.stamp_expire_deposit;

7
src/dune
View file

@ -2,7 +2,6 @@
(name mte) (name mte)
(modules (modules
fat fat
headers
respond respond
pg_type pg_type
pg pg
@ -10,8 +9,10 @@
mte_device mte_device
mte_handler mte_handler
mte mte
mte_terms mte_tos
mte_info mte_seed
mte_config
mte_keys
mte_management mte_management
secmod_eddsa secmod_eddsa
secmod_rsa 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 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/>. *) 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 routes =
let open Vifu.Uri in let open Vifu.Uri in
let open Vifu.Route in let open Vifu.Route in
let get path = get (path /?? any) 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 v s = rel / s in
let tos = [
[ get (v "terms") --> Mte_tos.terms;
get rel --> hello; get (v "privacy") --> Mte_tos.privacy;
get (v "terms") --> Mte_terms.terms; get (v "seed") --> Mte_seed.f;
get (v "privacy") --> Mte_terms.privacy; get (v "config") --> Mte_config.f;
] get (v "keys") --> Mte_keys.f;
in ]
let status_info = @
[ let open Mte_management in
get (v "seed") --> Mte_info.seed; let v s = rel / "management" / s in
get (v "config") --> Mte_info.config; [
get (v "keys") --> Mte_info.keys; get (v "keys") --> Keys_get.f;
] post (v "keys") Keys_post.json_enc --> Keys_post.f;
in post (v "denominations" /% string `Path / "revoke") Denom_revoke.json_enc
let management = --> Denom_revoke.f;
let open Mte_management in post (v "signkeys" /% string `Path / "revoke") Signkey_revoke.json_enc
let v s = v "management" / s in --> Signkey_revoke.f;
[ post (v "auditors") Auditors.json_enc --> Auditors.f;
get (v "keys") --> Keys_get.f; post (v "auditors" /% string `Path / "disable") Auditors_disable.json_enc
post (v "keys") Keys_post.jsont --> Keys_post.f; --> Auditors_disable.f;
post (v "denominations" /% string `Path / "revoke") Denom_revoke.jsont post (v "wire-fee") Wire_fee.json_enc --> Wire_fee.f;
--> Denom_revoke.f; post (v "global-fees") Global_fees.json_enc --> Global_fees.f;
post (v "signkeys" /% string `Path / "revoke") Signkey_revoke.jsont post (v "wire") Wire.json_enc --> Wire.f;
--> Signkey_revoke.f; post (v "wire" / "disable") Wire_disable.json_enc --> Wire_disable.f;
post (v "auditors") Auditors.jsont --> Auditors.f; post (v "drain") Drain.json_enc --> Drain.f;
post (v "auditors" /% string `Path / "disable") Auditors_disable.jsont post (v "aml-officers") AmlOfficer.json_enc --> AmlOfficer.f;
--> Auditors_disable.f; post (v "partners") Partners.json_enc --> Partners.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
module RNG = Mirage_crypto_rng.Fortuna 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) Vifu.Request.of_json req |> Result.map_error (fun (`Msg e) -> `Json_decode e)
module Future_keys = struct module Future_keys = struct
let make_future_sk sm_eddsa (pub, (start, expire)) = let make_fsk sm_eddsa (pub, (start, expire)) =
Logs.debug (fun m -> m "make_future_sk: `%a`" Eddsa.pp_pub pub); Logs.debug (fun m -> m "make_fsk: `%a`" Eddsa.pp_pub pub);
let open Time in
let stamp_start = Timestamp.of_absolute start in let stamp_start = Timestamp.of_absolute start in
let stamp_expire = Timestamp.of_absolute expire in let stamp_expire = Timestamp.of_absolute expire in
let stamp_end = let stamp_end =
@ -25,10 +24,10 @@ module Future_keys = struct
(Secmod_eddsa.sign_secmod sm_eddsa) (Secmod_eddsa.sign_secmod sm_eddsa)
{ exchange_pub; anchor_time; duration } { exchange_pub; anchor_time; duration }
in in
Api.FutureSignKey. FutureSignKey.
{ key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig } { 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 { let {
Config.Coin.section_name; Config.Coin.section_name;
value; value;
@ -43,8 +42,7 @@ module Future_keys = struct
} = } =
coin coin
in in
Logs.debug (fun m -> m "make_future_dn: `%a`" DenominationHash.pp h_pub); Logs.debug (fun m -> m "make_fdn: `%a`" DenominationHash.pp h_pub);
let open Time in
let stamp_start = Timestamp.of_absolute start in let stamp_start = Timestamp.of_absolute start in
let stamp_expire_withdraw = let stamp_expire_withdraw =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_withdraw Timestamp.of_absolute @@ TimeAbsolute.add start duration_withdraw
@ -55,7 +53,6 @@ module Future_keys = struct
let stamp_expire_legal = let stamp_expire_legal =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_legal Timestamp.of_absolute @@ TimeAbsolute.add start duration_legal
in in
let open Api in
let rsa_denomination_key = let rsa_denomination_key =
RsaDenominationKey.{ age_mask= 0; rsa_pub= pub } RsaDenominationKey.{ age_mask= 0; rsa_pub= pub }
in in
@ -66,7 +63,7 @@ module Future_keys = struct
(Secmod_rsa.sign_secmod sm_rsa) (Secmod_rsa.sign_secmod sm_rsa)
{ {
h_denom_pub= h_pub; 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; anchor_time= stamp_start;
duration_withdraw= Timestamp.diff stamp_start stamp_expire_withdraw; duration_withdraw= Timestamp.diff stamp_start stamp_expire_withdraw;
} }
@ -87,65 +84,14 @@ module Future_keys = struct
denom_secmod_sig; denom_secmod_sig;
} }
let make_future_keys_response sm_eddsa sm_rsa pool = let sk_of_fsk
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in FutureSignKey.
(* 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.
{ key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ } { key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ }
master_sig = master_sig =
Signkey.{ pub= key; stamp_start; stamp_expire; stamp_end; master_sig } Signkey.{ pub= key; stamp_start; stamp_expire; stamp_end; master_sig }
let dn_of_future_dn let dn_of_fdn
Api.FutureDenom. FutureDenom.
{ {
section_name= _; section_name= _;
value; value;
@ -160,7 +106,7 @@ module Future_keys = struct
fee_refund; fee_refund;
denom_secmod_sig= _; denom_secmod_sig= _;
} h_pub master_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. Denomination.
{ {
pub= rsa_pub; pub= rsa_pub;
@ -178,110 +124,112 @@ module Future_keys = struct
master_sig; master_sig;
} }
let verify_future_signkey sm_eddsa Api.SignKeySignature.{ key; master_sig } = let find_fsk sm_eddsa pub =
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 } =
match Secmod_eddsa.find_key sm_eddsa pub with match Secmod_eddsa.find_key sm_eddsa pub with
| None -> Error (`Not_found "future eddsa key") | None -> Error (`Not_found "future eddsa key")
| Some (pub, (t1, t2)) -> | Some (pub, (t1, t2)) ->
(* rebuild it *) let fsk = make_fsk sm_eddsa (pub, (t1, t2)) in
let future_sk = make_future_sk sm_eddsa (pub, (t1, t2)) in Ok fsk
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 certify_future_denomination sm_rsa pool let find_fdn sm_rsa h_pub =
Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } =
match Secmod_rsa.find_key sm_rsa h_pub with match Secmod_rsa.find_key sm_rsa h_pub with
| None -> Error (`Not_found "future rsa denomination key") | None -> Error (`Not_found "future rsa denomination key")
| Some (h_pub, (section_name, pub, t1)) -> | Some v ->
let future_dn = let fdn = make_fdn sm_rsa v in
make_future_dn sm_rsa (h_pub, (section_name, pub, t1)) Ok fdn
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);
()
end end
module Keys_get = struct 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 = let f req server _env =
Logs.info (fun m -> m "GET /management/keys/"); Logs.info (fun m -> m "GET /management/keys/");
let sm_eddsa = Vifu.Server.device Mte_device.sm_eddsa server in 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 sm_rsa = Vifu.Server.device Mte_device.sm_rsa server in
let pool = Vifu.Server.device Mte_device.pool 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 Ok v
end end
module Keys_post = struct 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 verify sm_eddsa sm_rsa MasterSignatures.{ denom_sigs; signkey_sigs } =
let* () = let* () = list_iter (verify_fsk sm_eddsa) signkey_sigs in
list_iter (Future_keys.verify_future_signkey sm_eddsa) signkey_sigs let* () = list_iter (verify_fdn sm_rsa) denom_sigs in
in
let* () =
list_iter (Future_keys.verify_future_denomination sm_rsa) denom_sigs
in
Ok () Ok ()
let process sm_eddsa sm_rsa pool MasterSignatures.{ denom_sigs; signkey_sigs } let process sm_eddsa sm_rsa pool MasterSignatures.{ denom_sigs; signkey_sigs }
= =
let* () = let* () = list_iter (certify_fsk sm_eddsa pool) signkey_sigs in
list_iter (Future_keys.certify_future_signkey sm_eddsa pool) signkey_sigs let* () = list_iter (certify_fdn sm_rsa pool) denom_sigs in
in
let* () =
list_iter (Future_keys.certify_future_denomination sm_rsa pool) denom_sigs
in
Ok () Ok ()
let jsont = MasterSignatures.jsont let json_enc = Vifu.Type.json_encoding MasterSignatures.jsont
let f req server _env = let f req server _env =
Logs.info (fun m -> m "POST /management/keys/"); Logs.info (fun m -> m "POST /management/keys/");
@ -301,13 +249,23 @@ module Denom_revoke = struct
let open Signatures.MasterDenominationKeyRevocation in let open Signatures.MasterDenominationKeyRevocation in
verify Config.master_public_key master_sig { h_denom_pub } verify Config.master_public_key master_sig { h_denom_pub }
let process sm_rsa pool h_denom_pub DenomRevocationSignature.{ master_sig } = let process sm_rsa pool h_pub DenomRevocationSignature.{ master_sig } =
let+ () = let* opt =
Future_keys.revoke_denomination sm_rsa pool h_denom_pub master_sig Pg.use_pool pool @@ fun conn -> Pg.find_denomination conn h_pub
in 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 = let f req h_denom_pub server _env =
Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/"); 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 let open Signatures.MasterSigningKeyRevocation in
verify Config.master_public_key master_sig { exchange_pub } verify Config.master_public_key master_sig { exchange_pub }
let process sm_eddsa pool exchange_pub let process sm_eddsa pool pub SignkeyRevocationSignature.{ master_sig } =
SignkeyRevocationSignature.{ master_sig } = let* opt = Pg.use_pool pool @@ fun conn -> Pg.find_signkey conn pub in
let+ () = match opt with
Future_keys.revoke_signkey sm_eddsa pool exchange_pub master_sig | None -> Error (`Not_found "signkey not found")
in | 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 = let f req exchange_pub server _env =
Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/"); Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
@ -388,7 +352,9 @@ module Auditors = struct
() ()
| Some auditor -> | Some auditor ->
if Timestamp.compare validity_start auditor.last_change <= 0 then 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 else
let+ () = let+ () =
Pg.use_pool pool @@ fun conn -> Pg.update_auditor conn auditor 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"); 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 = let f req server _env =
Logs.info (fun m -> m "POST /management/auditors/"); Logs.info (fun m -> m "POST /management/auditors/");
@ -424,7 +390,11 @@ module Auditors_disable = struct
| None -> Error (`Not_found "auditor pub key") | None -> Error (`Not_found "auditor pub key")
| Some auditor -> ( | Some auditor -> (
if Timestamp.compare validity_end auditor.last_change <= 0 then 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 else
match auditor.is_active with match auditor.is_active with
| false -> | false ->
@ -441,7 +411,7 @@ module Auditors_disable = struct
m "revoked auditor `%a`" Eddsa.pp_pub auditor_pub); 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 = let f req auditor_pub server _env =
Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/disable/"); 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 \ "invalid database state, multiple wire-fee found in database for \
this time frame" this time frame"
let jsont = WireFeeSetupMessage.jsont let json_enc = Vifu.Type.json_encoding WireFeeSetupMessage.jsont
let f req server _env = let f req server _env =
Logs.info (fun m -> m "POST /management/wire-fee/"); 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 \ "invalid database state, multiple global-fees found in database for \
this time frame" this time frame"
let jsont = GlobalFees.jsont let json_enc = Vifu.Type.json_encoding GlobalFees.jsont
(* TODO better global_fees (* TODO better global_fees
ensure it is defined for the current time. ensure it is defined for the current time.
@ -655,7 +625,8 @@ module Wire = struct
() ()
| Some (wire, _is_active, last_change) -> | Some (wire, _is_active, last_change) ->
if Timestamp.compare validity_start last_change <= 0 then 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 else
let+ () = let+ () =
Pg.use_pool pool @@ fun conn -> Pg.use_pool pool @@ fun conn ->
@ -664,7 +635,7 @@ module Wire = struct
Logs.info (fun m -> m "updated wire method"); 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 = let f req server _env =
Logs.info (fun m -> m "POST /management/wire/"); Logs.info (fun m -> m "POST /management/wire/");
@ -690,7 +661,9 @@ module Wire_disable = struct
| None -> Error (`Not_found "wire payto-uri") | None -> Error (`Not_found "wire payto-uri")
| Some (wire, _is_active, last_change) -> | Some (wire, _is_active, last_change) ->
if Timestamp.compare validity_end last_change <= 0 then 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 else
let+ () = let+ () =
Pg.use_pool pool @@ fun conn -> Pg.use_pool pool @@ fun conn ->
@ -699,7 +672,7 @@ module Wire_disable = struct
Logs.info (fun m -> m "disabled wire method"); 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 = let f req server _env =
Logs.info (fun m -> m "POST /management/wire/disable/"); 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"); 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 = let f req server _env =
Logs.info (fun m -> m "POST /management/drain/"); Logs.info (fun m -> m "POST /management/drain/");
@ -789,7 +762,7 @@ module AmlOfficer = struct
in in
() ()
let jsont = AmlOfficerSetup.jsont let json_enc = Vifu.Type.json_encoding AmlOfficerSetup.jsont
let f req server _env = let f req server _env =
Logs.info (fun m -> m "POST /management/aml-officers/"); 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+ () = 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 = let f req server _env =
Logs.info (fun m -> m "POST /management/partners/"); 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 match err with
| `Json_decode _ | `Bin_decode _ -> `Bad_request | `Json_decode _ | `Bin_decode _ -> `Bad_request
| `Invalid_signature_eddsa | `Invalid_signature_rsa -> `Forbidden | `Invalid_signature_eddsa | `Invalid_signature_rsa -> `Forbidden
| `Replay_attack _ -> `Conflict
| `Not_found _ -> `Not_found | `Not_found _ -> `Not_found
| `Conflict _ -> `Conflict | `Conflict _ -> `Conflict
| `Caqti _s | `Mfat _s | `Json_encode _s | `Bin_encode _s | `Msg _s -> | `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 include Stdlib.Result
open Time
type err = type err =
[ `Json_decode of string [ `Json_decode of string
| `Bin_decode of string | `Bin_decode of string
| `Invalid_signature_eddsa | `Invalid_signature_eddsa
| `Invalid_signature_rsa | `Invalid_signature_rsa
| `Replay_attack of string * Timestamp.t * Timestamp.t
| (* - *) | (* - *)
`Not_found of string `Not_found of string
| `Conflict 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 | `Bin_encode s -> Fmt.str "Bin encode: %s" s
| `Invalid_signature_eddsa -> Fmt.str "Invalid eddsa signature" | `Invalid_signature_eddsa -> Fmt.str "Invalid eddsa signature"
| `Invalid_signature_rsa -> Fmt.str "Invalid rsa 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 | `Not_found s -> Fmt.str "Not found: %s" s
| `Conflict s -> Fmt.str "Conflict: %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; master_sig: Signatures.ExchangeSigningKeyValidity.t;
} }
let verify_exchange_signing_key_validity ~key sk = let verify ~master_key sk =
let open Signatures.ExchangeSigningKeyValidity in let open Signatures.ExchangeSigningKeyValidity in
verify key sk.master_sig verify master_key sk.master_sig
{ {
R.start= sk.stamp_start; R.start= sk.stamp_start;
expire= sk.stamp_expire; 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.map SignKey.to_signkey v.signkeys in
let* () = let* () =
sk_l sk_l |> list_iter (Signkey.verify ~master_key:v.master_public_key)
|> list_iter
(Signkey.verify_exchange_signing_key_validity ~key:v.master_public_key)
in in
let* () = let* () =
@ -71,13 +69,12 @@ let keys content =
let denom_l = v.denominations |> Denomination.denoms_of_denomgroups in let denom_l = v.denominations |> Denomination.denoms_of_denomgroups in
let* () = let* () =
denom_l denom_l |> list_iter (Denomination.verify ~master_key:v.master_public_key)
|> list_iter
(Denomination.verify_denomination_key_validity ~key:v.master_public_key)
in in
let* () = 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 v.auditors
|> List.concat_map |> List.concat_map
(fun (fun
@ -87,30 +84,29 @@ let keys content =
let auditor_url_hash = H64_cstring.hash auditor_url in let auditor_url_hash = H64_cstring.hash auditor_url in
denomination_keys denomination_keys
|> List.map |> List.map
(fun AuditorDenominationKey.{ denom_pub_h; auditor_sig } -> (fun
(denom_pub_h, auditor_url_hash, auditor_pub, auditor_sig))) AuditorDenominationKey.{ denom_pub_h= h_pub; auditor_sig } ->
|> list_iter (h_pub, (auditor_url_hash, auditor_pub, auditor_sig))))
(fun (denom_pub_h, auditor_url_hash, auditor_pub, auditor_sig) -> |> list_iter (fun (h_pub, (auditor_url_hash, auditor_pub, auditor_sig)) ->
let open Denomination in Hashtbl.find_opt dn_ht h_pub |> function
denom_l |> List.find_opt (fun dn -> dn.h_pub = denom_pub_h) | None -> Fmt.error_msg "auditor denomination key not found"
|> function | Some dn ->
| None -> Fmt.error_msg "auditor denomination key not found" let open Denomination in
| Some dn -> let open Signatures.ExchangeKeyValidity in
let open Signatures.ExchangeKeyValidity in verify auditor_pub auditor_sig
verify auditor_pub auditor_sig {
{ auditor_url_hash;
auditor_url_hash; master= auditor_pub;
master= auditor_pub; start= dn.stamp_start;
start= dn.stamp_start; expire_withdraw= dn.stamp_expire_withdraw;
expire_withdraw= dn.stamp_expire_withdraw; expire_spend= dn.stamp_expire_deposit;
expire_spend= dn.stamp_expire_deposit; expire_legal= dn.stamp_expire_legal;
expire_legal= dn.stamp_expire_legal; value= dn.value;
value= dn.value; fee_withdraw= dn.fee_withdraw;
fee_withdraw= dn.fee_withdraw; fee_deposit= dn.fee_deposit;
fee_deposit= dn.fee_deposit; fee_refresh= dn.fee_refresh;
fee_refresh= dn.fee_refresh; denom_hash= dn.h_pub;
denom_hash= dn.h_pub; })
})
in in
Ok () Ok ()

4
tools/offline_impl.ml
View file

@ -4,6 +4,10 @@ open Hash
let () = Mirage_crypto_rng_unix.use_default () 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 now_s () =
let ns = Mtime_clock.now_ns () in let ns = Mtime_clock.now_ns () in
Int64.unsigned_div ns 1_000_000_000L Int64.unsigned_div ns 1_000_000_000L