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

add result.ml; polymorphic variant errors + refacto

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

3
GNUmakefile
View file

@ -13,13 +13,14 @@ check-kvm:
pins:
#opam pin --no-action --yes "git+https://github.com/robur-coop/mcrunch.git#682ed63c03e3be5664f96c469a260e1d9e9df011"
opam pin --no-action --yes "git+https://github.com/mirage/Zarith.git#zarith-1.14"
opam pin --no-action --yes "git+https://github.com/robur-coop/vif.git#8c6ac3fb97cb9a31bf6ad8ec63c942336dcfd03e"
opam pin --no-action --yes "git+https://github.com/robur-coop/vif.git#e8b3053476162d119dee8cefe38511d679d3ad55"
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 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"
opam pin --no-action --yes add caqti-driver-pgx "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0"
opam pin --no-action --yes "git+https://github.com/robur-coop/mnet.git#7e07437cda26f8efd3da0c4d14d76293d8fcbc78"
installs:
# opam install --yes mcrunch

45
src/amount.ml
View file

@ -40,7 +40,7 @@ let check_fraction v =
if Int32.unsigned_compare v fraction_limit < 0 then Ok ()
else Fmt.error "fraction has more than %d digits" fraction_nb_digits
let make ~sign ~currency ~value ~fraction =
let make sign currency value fraction =
let* () = check_currency currency in
let* () = check_value value in
let* () = check_fraction fraction in
@ -93,10 +93,7 @@ module Parser = struct
return n)
let amount =
lift4
(fun sign currency value fraction ->
make ~sign ~currency ~value ~fraction)
sign letters
lift4 make sign letters
(char ':' *> value)
(option 0_l (char '.' *> fraction))
<* end_of_input
@ -105,8 +102,6 @@ module Parser = struct
Angstrom.parse_string ~consume:Consume.All amount s |> Result.join
end
let of_string = Parser.parse
let pp =
let open Fmt in
let pp_sign =
@ -133,31 +128,35 @@ let pp =
pf ppf "%a%s:%Lu%a" pp_sign sign currency value pp_fraction fraction
let to_string = Fmt.str "%a" pp
let of_string = Parser.parse
(* - *)
let jsont = Jsont.of_of_string ~kind:"Amount" of_string ~enc:to_string
let pad_currency_string s =
let len = String.length s in
match len < currency_length_limit with
| false -> Fmt.failwith "amount with invalid currency"
| true ->
let b = Bytes.make currency_length_limit '\x00' in
Bytes.blit_string s 0 b 0 len;
Bytes.unsafe_to_string b
(* binary decoding never unused *)
let make_exn value fraction currency =
match make ~sign:None ~currency ~value ~fraction with
| Error _ -> Fmt.failwith "Amount of binary data failure"
| Ok v -> v
(* note: binary decoding never used, like for all signatures types *)
let decode_exn value fraction currency =
match make None currency value fraction with
| Error e -> Fmt.failwith "amount decode %s." e
| Ok t -> t
let bin =
let open Bin in
record make_exn
record decode_exn
|+ field beint64 (fun t -> t.value)
|+ field beint32 (fun t -> t.fraction)
|+ field (bytes currency_length_limit) (fun t ->
pad_currency_string t.currency)
let len = String.length t.currency in
if not (len < currency_length_limit) then
Fmt.failwith "broken amount currency";
let b = Bytes.make currency_length_limit '\x00' in
Bytes.blit_string t.currency 0 b 0 len;
Bytes.unsafe_to_string b)
|> sealr
let caqti ~currency =
let open Caqti_type in
custom
~encode:(fun amount -> Ok (amount.value, amount.fraction))
~decode:(fun (value, fraction) -> make None currency value fraction)
(t2 int64 int32)

11
src/amount.mli
View file

@ -9,17 +9,10 @@ type t = private {
fraction: Int32.t;
}
val make :
sign:sign option ->
currency:string ->
value:Int64.t ->
fraction:Int32.t ->
(t, string) result
val make : sign option -> string -> Int64.t -> Int32.t -> (t, string) result
(* fail on differents currencies *)
val compare : t -> t -> int
(* TODO rename pp_dump *)
val pp : Format.formatter -> t -> unit
val to_string : t -> string
val of_string : string -> (t, string) result
@ -27,4 +20,4 @@ val of_string : string -> (t, string) result
(* - *)
val jsont : t Jsont.t
val bin : t Bin.t
(* [caqti] is in pg_type.ml *)
val caqti : currency:string -> t Caqti_type.t

40
src/api.ml
View file

@ -8,11 +8,19 @@
- uri *)
module DenominationHash = Hash.DenominationHash
module Bytes32 = Signatures.Bytes32
module Bytes64 = Signatures.Bytes64
open Time
open Signatures
let encode jsont v = Jsont_bytesrw.encode_string jsont v
let decode jsont v = Jsont_bytesrw.decode_string jsont v
let encode' jsont v = Jsont_bytesrw.encode_string jsont v
let decode' jsont v = Jsont_bytesrw.decode_string jsont v
let encode jsont v =
encode' jsont v |> Result.map_error (fun e -> `Json_encode e)
let decode jsont v =
decode' jsont v |> Result.map_error (fun e -> `Json_decode e)
open Jsont.Object
@ -57,34 +65,6 @@ module B32 = struct
~decode:B32.decode Caqti_type.string
end
module Bytes32 = struct
include Signatures.Bytes32
let jsont =
let decode s = Result.bind (B32.decode s) of_octets in
let encode b = to_octets b |> B32.encode in
Jsont.of_of_string ~kind:"Bytes32" decode ~enc:encode
let caqti =
Caqti_type.custom
~encode:(fun v -> Ok (to_octets v))
~decode:of_octets Caqti_type.octets
end
module Bytes64 = struct
include Signatures.Bytes64
let jsont =
let decode s = Result.bind (B32.decode s) of_octets in
let encode b = to_octets b |> B32.encode in
Jsont.of_of_string ~kind:"Bytes64" decode ~enc:encode
let caqti =
Caqti_type.custom
~encode:(fun v -> Ok (to_octets v))
~decode:of_octets Caqti_type.octets
end
module ErrorDetail = struct
type t = {
code: int;

36
src/assets.ml
View file

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

5
src/b32.ml
View file

@ -33,6 +33,5 @@ let decode s =
let n = 8 - (String.length s mod 8) in
let pad = String.make n '=' in
let s = s ^ pad in
match Base32.decode ~alphabet ~off:0 ~len:(String.length s) s with
| Error (`Msg e) -> Error e
| Ok v -> Ok v
Base32.decode ~alphabet ~off:0 ~len:(String.length s) s
|> Result.map_error (fun (`Msg e) -> e)

11
src/bbin.ml Normal file
View file

@ -0,0 +1,11 @@
let encode bin t =
try Ok (Bin.to_string bin t)
with Invalid_argument e ->
Fmt.error "Bin encode error %s" e
|> Result.map_error (fun e -> `Bin_encode e)
let decode bin o =
try Ok (Bin.decode bin o (ref 0))
with Invalid_argument e ->
Fmt.error "Bin decode error %s" e
|> Result.map_error (fun e -> `Bin_decode e)

87
src/config.ml
View file

@ -1,13 +1,12 @@
open Config_parser
let config_filename = "mte.conf"
(* TODO config
read Fpath.t *)
module Cfg = struct
let config_filename = "mte.conf"
end
let config_data =
match Assets_crunch.read config_filename with
| None -> fail "static file not found: `%s`" config_filename
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
@ -144,7 +143,7 @@ module Currency = struct
alt_unit_names=
get "alt_unit_names"
|> Jsont_bytesrw.decode_string Alt_unit_names.jsont
|> unwrap;
|> unwrap_or_failure;
}
let all_currencies = List.map parse_currency currency_sections
@ -154,11 +153,12 @@ module Currency = struct
List.find_opt (fun v -> v.code = Exchange.currency) all_currencies
with
| None ->
fail "section `[currency-%s]` not found, currency `%s` is not defined"
failure
"section `[currency-%s]` not found, currency `%s` is not defined"
Exchange.currency Exchange.currency
| Some v -> (
match v.enabled = `YES with
| false -> fail "currency `%s` is not enabled" Exchange.currency
| false -> failure "currency `%s` is not enabled" Exchange.currency
| true -> v)
end
@ -178,45 +178,36 @@ module Coin = struct
age_restricted: [ (*`YES|*) `NO ];
}
let coin_sections =
List.filter
(fun v ->
(* note: here its a '_' not '-' *)
String.starts_with ~prefix:"coin_" v.header)
config_data
let parse_coin section =
let get field = get config_data ~section:section.header ~field in
let section_name =
String.sub section.header 5 (String.length section.header - 5)
in
let rsa_keysize s =
let nbits = int s in
let len = ((nbits - 1) / 8) + 1 in
if 8 * len <> nbits then
(* because of [kdf_mod_n] *)
invalid_arg "RSA keysize must be multiple of 8"
else nbits
in
{
section_name;
value= get "value" |> amount;
duration_withdraw= get "duration_withdraw" |> duration;
duration_spend= get "duration_spend" |> duration;
duration_legal= get "duration_legal" |> duration;
fee_withdraw= get "fee_withdraw" |> amount;
fee_deposit= get "fee_deposit" |> amount;
fee_refresh= get "fee_refresh" |> amount;
fee_refund= get "fee_refund" |> amount;
cipher= (get "cipher" |> const_value "RSA" |> fun _s -> `RSA);
rsa_keysize= get "rsa_keysize" |> rsa_keysize;
age_restricted=
( get "age_restricted" |> yes_no |> function
| `NO -> `NO
| `YES -> fail "`age_restricted = YES` is not supported" );
}
let all_coins = List.map parse_coin coin_sections
let all_coins =
(* ! '_' not '-' *)
let prefix = "coin_" in
let prefix_len = String.length prefix in
config_data
|> 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 section_name =
String.sub section.header prefix_len
(String.length section.header - prefix_len)
in
{
section_name;
value= get "value" |> amount;
duration_withdraw= get "duration_withdraw" |> duration;
duration_spend= get "duration_spend" |> duration;
duration_legal= get "duration_legal" |> duration;
fee_withdraw= get "fee_withdraw" |> amount;
fee_deposit= get "fee_deposit" |> amount;
fee_refresh= get "fee_refresh" |> amount;
fee_refund= get "fee_refund" |> amount;
cipher= (get "cipher" |> const_value "RSA" |> fun _s -> `RSA);
rsa_keysize= get "rsa_keysize" |> rsa_keysize;
age_restricted=
( get "age_restricted" |> yes_no |> function
| `NO -> `NO
| `YES -> failure "age restriction is not supported" );
})
|> Iarray.of_list
end
module Exchange_secmod_rsa = struct

59
src/config_parser.ml
View file

@ -3,6 +3,15 @@
do not support "$"-path expansion *)
let failure fmt =
Fmt.kstr
(fun s ->
Fmt.epr "Config failure: %s.@." s;
exit 1)
fmt
let unwrap_or_failure = function Error e -> failure "`%s`" e | Ok v -> v
open Angstrom
type item = {
@ -15,10 +24,6 @@ type section = {
items: item list;
}
let fail fmt =
let k _ppf = exit 1 in
Fmt.kpf k Fmt.stderr ("Configuration failure: " ^^ fmt ^^ ".@.")
let is_eol = function '\n' | '\r' -> true | _ -> false
let is_whitespace = function ' ' | '\t' -> true | _ -> false
let blanks = skip_while is_whitespace
@ -54,7 +59,7 @@ module Config_section = struct
let quoted_value =
char '"' *> take_till is_eol <* end_of_line >>= fun s ->
match String.ends_with ~suffix:"\"" s && s <> "\"" with
| false -> fail "invalid quoted value"
| false -> failure "invalid quoted value `%s`" s
| true ->
let value = String.sub s 0 (String.length s - 1) in
return value
@ -75,7 +80,7 @@ module Config_section = struct
match l with
| [] ->
if List.is_empty item_l then section_l
else fail "invalid configuration structure"
else failure "invalid section structure"
| Blank :: tl | Comment _ :: tl -> loop section_l item_l tl
| Item item :: tl -> loop section_l (item :: item_l) tl
| Header header :: tl ->
@ -86,7 +91,7 @@ module Config_section = struct
let parse s =
match parse_string ~consume:All config s with
| Error msg -> fail "parse error `%s`" msg
| Error msg -> failure "parse error `%s`" msg
| Ok v -> fold_sections v
end
@ -99,7 +104,7 @@ module Config_duration = struct
let integer =
take_while1 (function '0' .. '9' -> true | _ -> false) >>= fun s ->
match int_of_string_opt s with
| None -> fail "expected integer, got `%s`" s
| None -> failure "expected integer, got `%s`" s
| Some i -> return i
let duration_element =
@ -113,7 +118,7 @@ module Config_duration = struct
| "hour" | "hours" -> return `Hour
| "minute" | "minutes" -> return `Minute
| "second" | "seconds" | "s" -> return `Second
| s -> fail "expected a duration unit, got `%s`" s
| s -> failure "expected a duration unit, got `%s`" s
in
lift2 (fun number dunit -> { number; dunit }) number dunit
@ -140,12 +145,10 @@ module Config_duration = struct
let parse s : duration_element list =
match parse_string ~consume:All duration s with
| Error msg -> fail "duration parse error `%s`" msg
| Error msg -> failure "duration parse error `%s`" msg
| Ok v -> v
end
let unwrap = function Error e -> fail "`%s`." e | Ok v -> v
let get_opt t ~section ~field =
match List.find_opt (fun v -> v.header = section) t with
| None -> None
@ -156,33 +159,34 @@ let get_opt t ~section ~field =
let get t ~section ~field =
match get_opt t ~section ~field with
| None -> fail "option `[%s].%s` not found" section field
| None -> failure "option `[%s].%s` not found" section field
| Some v -> v
let int s =
match int_of_string_opt s with
| None -> fail "expected int value, got `%s`" s
| None -> failure "expected int value, got `%s`" s
| Some v -> v
let float s =
match float_of_string_opt s with
| None -> fail "expected float value, got `%s`" s
| None -> failure "expected float value, got `%s`" s
| Some v -> v
let const_value a b =
match a = b with false -> fail "unexpected value `%s`" b | true -> a
match a = b with false -> failure "unexpected value `%s`" b | true -> a
let yes_no = function
| "NO" -> `NO
| "YES" -> `YES
| s -> fail "expected `YES`/`NO` value, got `%s`" s
| s -> failure "expected `YES`/`NO` value, got `%s`" s
let etag s = s
let uri s = Uri.of_string s
let amount =
let currency = ref None in
fun s ->
let amount = s |> Amount.of_string |> unwrap in
let amount = s |> Amount.of_string |> unwrap_or_failure in
match !currency with
| None ->
currency := Some amount.currency;
@ -190,18 +194,19 @@ let amount =
| Some cur -> (
match String.equal amount.currency cur with
| false ->
fail "only one kind of currency is supported, found: `%s` and `%s`."
failure
"only one kind of currency is supported, found: `%s` and `%s`."
amount.currency cur
| true -> amount)
let duration s = Config_duration.(s |> parse |> to_time_span)
let ed25519 s =
s
|> B32.decode
|> unwrap
|> Mirage_crypto_ec.Ed25519.pub_of_octets
|> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e)
|> unwrap
let rsa_keysize s =
let nbits = int s in
let len = ((nbits - 1) / 8) + 1 in
if 8 * len = nbits then nbits
else
(* because of [kdf_mod_n] *)
failure "RSA keysize must be multiple of 8, found `%d`" nbits
let etag s = s
let ed25519 s = Eddsa.pub_of_b32 s |> unwrap_or_failure

110
src/denomination.ml
View file

@ -35,13 +35,11 @@ let verify_denomination_key_validity ~key dn =
}
let make_denom_group_sorted denominations =
let open Syntax in
(* IMPROVE: no need for hashtbl *)
(* use hashtbl to re-group denoms *)
let ht = Hashtbl.create 0xff in
List.iter
(fun coin ->
let open Config.Coin in
assert (coin.cipher = `RSA);
Iarray.iter
(fun (coin : Config.Coin.t) ->
let k =
( coin.value,
coin.fee_withdraw,
@ -52,43 +50,42 @@ let make_denom_group_sorted denominations =
let v = [] in
Hashtbl.replace ht k v)
Config.Coin.all_coins;
let+ () =
list_iter
(fun {
pub;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
age_mask= _;
h_pub= _;
master_sig;
} ->
let k = (value, fee_withdraw, fee_deposit, fee_refresh, fee_refund) in
let v =
Api.RsaDenom.
{
rsa_pub= pub;
master_sig;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
lost= None;
}
in
match Hashtbl.find_opt ht k with
| None -> Error "denomination does not match any coin in configuration"
| Some l ->
Hashtbl.replace ht k (v :: l);
Ok ())
denominations
in
List.iter
(fun {
pub;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
age_mask= _;
h_pub= _;
master_sig;
} ->
let k = (value, fee_withdraw, fee_deposit, fee_refresh, fee_refund) in
let v =
Api.RsaDenom.
{
rsa_pub= pub;
master_sig;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
lost= None;
}
in
match Hashtbl.find_opt ht k with
| None ->
Fmt.failwith "denomination does not match any coin in configuration"
| Some l ->
Hashtbl.replace ht k (v :: l);
())
denominations;
let l = Hashtbl.to_seq ht |> List.of_seq in
(* ! important for /keys .exchange_sig
@ -102,22 +99,21 @@ let make_denom_group_sorted denominations =
let cmp_denom b a = Timestamp.compare a.stamp_start b.stamp_start in
let cmp_group = fun (Rsa a) (Rsa b) -> Amount.compare a.value b.value in
let l =
l
|> List.map
(fun
((value, fee_withdraw, fee_deposit, fee_refresh, fee_refund), denoms)
List.map
(fun ((value, fee_withdraw, fee_deposit, fee_refresh, fee_refund), denoms)
->
Rsa
{
denoms= List.sort cmp_denom denoms;
value;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
})
|> List.sort cmp_group
Rsa
{
denoms= List.sort cmp_denom denoms;
value;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
})
l
in
let l = List.sort cmp_group l in
l
let denoms_of_denomgroups l =
@ -150,7 +146,7 @@ let denoms_of_denomgroups l =
lost= _;
}
->
let h_pub = DenominationHash.hash_of_rsa rsa_pub in
let h_pub = DenominationHash.hash rsa_pub in
{
pub= rsa_pub;
value;

2
src/dune
View file

@ -45,7 +45,9 @@
(name mte)
(wrapped false)
(modules
result
syntax
bbin
amount
libtool_version
time

143
src/eddsa.ml
View file

@ -1,7 +1,7 @@
open Syntax
module Mirage_eddsa = Mirage_crypto_ec.Ed25519
let pp_error = Mirage_crypto_ec.pp_error
let pp_mirage_error = Mirage_crypto_ec.pp_error
type priv = Mirage_eddsa.priv
type pub = Mirage_eddsa.pub
@ -9,50 +9,6 @@ type sig_ = S of string [@@unboxed]
let generate = Mirage_eddsa.generate
let pub_of_priv = Mirage_eddsa.pub_of_priv
let priv_to_octets t = Mirage_eddsa.priv_to_octets t
let priv_of_octets t =
Mirage_eddsa.priv_of_octets t |> function
| Error err -> Fmt.error "%a" pp_error err
| Ok v -> Ok v
let priv_bin =
let priv_of_octets_exn t = priv_of_octets t |> Result.get_ok in
Bin.map (Bin.bytes 32) priv_of_octets_exn priv_to_octets
let priv_jsont =
let of_b32 s =
let* octets = B32.decode s in
priv_of_octets octets
in
let to_b32 t = B32.encode (priv_to_octets t) in
Jsont.of_of_string ~kind:"EddsaPrivateKey" of_b32 ~enc:to_b32
let pub_to_octets t = Mirage_eddsa.pub_to_octets t
let pub_of_octets t =
Mirage_eddsa.pub_of_octets t |> function
| Error e -> Fmt.error "%a" pp_error e
| Ok v -> Ok v
let pub_bin =
let pub_of_octets_exn t = pub_of_octets t |> Result.get_ok in
Bin.map (Bin.bytes 32) pub_of_octets_exn pub_to_octets
let pub_of_b32 s =
let* octets = B32.decode s in
pub_of_octets octets
let pub_to_b32 t = B32.encode (pub_to_octets t)
let pub_jsont =
Jsont.of_of_string ~kind:"EddsaPublicKey" pub_of_b32 ~enc:pub_to_b32
let pub_caqti =
Caqti_type.custom
~encode:(fun v -> Ok (pub_to_octets v))
~decode:(fun v -> pub_of_octets v)
Caqti_type.octets
let sign ~key s =
let sig_ = Mirage_eddsa.sign ~key s in
@ -60,29 +16,90 @@ let sign ~key s =
let verify ~key (S s) ~msg =
let b = Mirage_eddsa.verify ~key s ~msg in
match b with false -> Error "Eddsa verify: not valid" | true -> Ok ()
if b then Ok () else Error `Invalid_signature_eddsa
let sig_to_octets (S s) = s
module Priv = struct
let priv_to_octets t = Mirage_eddsa.priv_to_octets t
let sig_of_octets s =
match String.length s = 64 with
| false -> Error "Eddsa decode signature (binary): invalid data"
| true -> Ok (S s)
let priv_of_octets o =
Mirage_eddsa.priv_of_octets o
|> Result.map_error (Fmt.str "%a" pp_mirage_error)
let sig_bin =
let sig_of_octets_exn t = sig_of_octets t |> Result.get_ok in
Bin.map (Bin.bytes 64) sig_of_octets_exn sig_to_octets
let priv_to_b32 t = priv_to_octets t |> B32.encode
let priv_of_b32 s =
let* octets = B32.decode s in
priv_of_octets octets
let priv_jsont =
Jsont.of_of_string ~kind:"EddsaPrivateKey" priv_of_b32 ~enc:priv_to_b32
let priv_bin =
let priv_of_octets_exn t =
match priv_of_octets t with Error e -> invalid_arg e | Ok v -> v
in
Bin.map (Bin.bytes 32) priv_of_octets_exn priv_to_octets
end
module Pub = struct
let pub_to_octets t = Mirage_eddsa.pub_to_octets t
let pub_of_octets t =
Mirage_eddsa.pub_of_octets t
|> Result.map_error (Fmt.str "%a" pp_mirage_error)
let pub_to_b32 t = pub_to_octets t |> B32.encode
let pub_of_b32 s =
let* octets = B32.decode s in
pub_of_octets octets
let pub_jsont =
Jsont.of_of_string ~kind:"EddsaPublicKey" pub_of_b32 ~enc:pub_to_b32
let pub_bin =
let pub_of_octets_exn t =
match pub_of_octets t with Error e -> invalid_arg e | Ok v -> v
in
Bin.map (Bin.bytes 32) pub_of_octets_exn pub_to_octets
let pub_caqti =
Caqti_type.custom
~encode:(fun v -> Ok (pub_to_octets v))
~decode:pub_of_octets Caqti_type.octets
end
module Sig_ = struct
let sig_to_octets (S s) = s
let sig_of_octets s =
match String.length s = 64 with
| false -> Error "invalid eddsa signature length"
| true -> Ok (S s)
let sig_jsont =
let sig_of_b32 s =
let* s = B32.decode s in
sig_of_octets s
in
let sig_to_b32 (S s) = B32.encode s in
Jsont.of_of_string ~kind:"EddsaSignature" sig_of_b32 ~enc:sig_to_b32
let sig_caqti =
Caqti_type.custom
~encode:(fun v -> Ok (sig_to_octets v))
~decode:(fun s -> sig_of_octets s)
Caqti_type.octets
let sig_to_b32 (S s) = B32.encode s
let sig_jsont =
Jsont.of_of_string ~kind:"EddsaSignature" sig_of_b32 ~enc:sig_to_b32
let sig_bin =
let sig_of_octets_exn t =
match sig_of_octets t with Error e -> invalid_arg e | Ok v -> v
in
Bin.map (Bin.bytes 64) sig_of_octets_exn sig_to_octets
let sig_caqti =
Caqti_type.custom
~encode:(fun v -> Ok (sig_to_octets v))
~decode:sig_of_octets Caqti_type.octets
end
include Priv
include Pub
include Sig_
let pp_pub ppf pub = Fmt.pf ppf "%s" (pub_to_b32 pub)

29
src/fat.ml
View file

@ -19,6 +19,14 @@ module Path = struct
let equal a b = 0 = compare a b
end
type t = Mkernel.Block.t Mfat.t
type entry = Mfat.entry = {
name: string;
is_dir: bool;
size: int32;
}
module Fat = Mfat.Make (struct
include Mkernel.Block
@ -28,18 +36,21 @@ end)
include Fat
type entry = Mfat.entry = {
name: string;
is_dir: bool;
size: int32;
}
let create blk =
match Fat.create blk with
| Error (`Msg e) -> Fmt.failwith "FAT file system failure: %s." e
match create blk with
| Error (`Msg e) ->
Fmt.epr "FAT file system initialization failure: %s@." e;
exit 1
| Ok fs -> fs
type t = Mkernel.Block.t Mfat.t
let map_err r = Result.map_error (fun (`Msg e) -> `Mfat e) r
let ls t p = ls t p |> map_err
let read t p = read t p |> map_err
let write t p s = write t p s |> map_err
let mkdir t p = mkdir t p |> map_err
let remove t p = remove t p |> map_err
let exists t p = exists t p
let stat t p = stat t p |> map_err
module type FS = sig
val t : t

128
src/hash.ml
View file

@ -1,77 +1,55 @@
(* TODO hash over canonicalized json
https://docs.taler.net/design-documents/018-contract-json.html#canonicalized-hashing
https://datatracker.ietf.org/doc/html/rfc8785 *)
open Digestif
open Syntax
module type S = sig
type t
val hash : string -> t
val to_octets : t -> string
val to_b32 : t -> B32.t
val of_b32 : B32.t -> (t, string) result
val pp_hex : Format.formatter -> t -> unit
val pp : Format.formatter -> t -> unit
val bin : t Bin.t
val caqti : t Caqti_type.t
val jsont : t Jsont.t
val hash : string -> t
val of_octets : string -> t
val to_octets : t -> string
val of_b32 : B32.t -> (t, string) result
val to_b32 : t -> B32.t
end
module H32 : S = struct
type t = SHA256.t
module MK (H : Digestif.S) : S = struct
type t = H.t
let hash s = SHA256.(digest_string s)
let hash s = H.(digest_string s)
let of_octets s =
match SHA256.of_raw_string_opt s with
| None -> Fmt.failwith "H32.of_octets failure"
| Some t -> t
match H.of_raw_string_opt s with
| None -> Error "invalid hash"
| Some t -> Ok t
let to_octets = SHA256.to_raw_string
let of_b32 s = Result.map of_octets (B32.decode s)
let to_octets = H.to_raw_string
let to_b32 t = B32.encode (to_octets t)
let of_b32 s =
let* o = B32.decode s in
of_octets o
let pp_hex = H.pp
let pp ppf t = Fmt.pf ppf "%s" (to_b32 t)
let bin =
let open Bin in
map (bytes 32) of_octets to_octets
let of_octets_exn s =
of_octets s |> function Error e -> invalid_arg e | Ok t -> t
in
Bin.map (Bin.bytes H.digest_size) of_octets_exn to_octets
(* hashs are not b32 encoded in the database *)
let caqti =
let open Caqti_type in
custom
~encode:(fun v -> Ok (to_octets v))
~decode:(fun v -> Ok (of_octets v))
octets
custom ~encode:(fun v -> Ok (to_octets v)) ~decode:of_octets octets
let jsont = Jsont.of_of_string ~kind:"Hash 32" of_b32 ~enc:to_b32
let jsont = Jsont.of_of_string ~kind:"hash" of_b32 ~enc:to_b32
end
module H64 : S = struct
type t = SHA512.t
let hash s = SHA512.(digest_string s)
let of_octets s =
match SHA512.of_raw_string_opt s with
| None -> Fmt.failwith "H64.of_octets failure"
| Some t -> t
let to_octets = SHA512.to_raw_string
let of_b32 s = Result.map of_octets (B32.decode s)
let to_b32 t = B32.encode (to_octets t)
let bin =
let open Bin in
map (bytes 64) of_octets to_octets
let caqti =
let open Caqti_type in
custom
~encode:(fun v -> Ok (to_octets v))
~decode:(fun v -> Ok (of_octets v))
octets
let jsont = Jsont.of_of_string ~kind:"Hash 64" of_b32 ~enc:to_b32
end
module H32 = MK (Digestif.SHA256)
module H64 = MK (Digestif.SHA512)
module H32_cstring : S = struct
include H32
@ -86,20 +64,11 @@ module H64_cstring : S = struct
end
module DenominationHash : sig
type t
include S
val bin : t Bin.t
val caqti : t Caqti_type.t
val jsont : t Jsont.t
val hash_of_rsa : Rsa.pub -> t
val of_octets : string -> t
val to_octets : t -> string
val of_b32 : B32.t -> (t, string) result
val to_b32 : t -> B32.t
val hash : Rsa.pub -> t
end = struct
open Digestif
type t = SHA512.t
include H64
type cipher =
| RSA
@ -108,7 +77,7 @@ end = struct
(* = GNUNET_CRYPTO_BSA_(RSA|CS) *)
let cipher_to_int32 = function RSA -> 1_l | CS -> 2_l
let hash_of_rsa pub =
let hash pub =
let age_mask = 0_l in
let cipher = cipher_to_int32 RSA in
let pub = Rsa.pub_to_octets pub in
@ -117,33 +86,9 @@ end = struct
Bytes.set_int32_be buf 0 age_mask;
Bytes.set_int32_be buf 4 cipher;
Bytes.blit_string pub 0 buf 8 len;
SHA512.digest_bytes buf
let of_octets s =
match SHA512.of_raw_string_opt s with
| None -> Fmt.failwith "H64.of_octets failure"
| Some t -> t
let to_octets = SHA512.to_raw_string
let of_b32 s = Result.map of_octets (B32.decode s)
let to_b32 t = B32.encode (to_octets t)
let bin =
let open Bin in
map (bytes 64) of_octets to_octets
let caqti =
let open Caqti_type in
custom
~encode:(fun v -> Ok (to_octets v))
~decode:(fun v -> Ok (of_octets v))
octets
let jsont = Jsont.of_of_string ~kind:"DenominationHash" of_b32 ~enc:to_b32
hash (Bytes.unsafe_to_string buf)
end
(* TODO
check which hash algorithm to use for each hash type *)
module FullPaytoHash : S = H32
module NormalizedPaytoHash : S = H32
module PrivateContractHash : S = H64
@ -154,3 +99,8 @@ module BlindedCoinHash : S = H64
module CoinPubHash : S = H64
module OutputCommitmentHash : S = H64
module HashPlanchetsP : S = H64
(* TODO
hash over canonicalized json
https://docs.taler.net/design-documents/018-contract-json.html#canonicalized-hashing
https://datatracker.ietf.org/doc/html/rfc8785 *)

186
src/keys.ml
View file

@ -2,31 +2,29 @@ open Syntax
module DenominationHash = Hash.DenominationHash
open Time
type 'a result = ('a, string) Result.t
module type S = sig
val sign : Eddsa.pub -> string -> Eddsa.sig_
val sign_denom : DenominationHash.t -> string -> Rsa.sig_
val find_signkey : Eddsa.pub -> Signkey.t option result
val find_denomination : DenominationHash.t -> Denomination.t option result
val signkeys : unit -> Signkey.t list result
val denominations : unit -> Denomination.t list result
val find_signkey : Eddsa.pub -> Signkey.t option Result.t
val find_denomination : DenominationHash.t -> Denomination.t option Result.t
val signkeys : unit -> Signkey.t list Result.t
val denominations : unit -> Denomination.t list Result.t
val denominations_last_change : unit -> Timestamp.t
(* future keys *)
val make_future_keys_response : unit -> Api.FutureKeysResponse.t result
val verify_future_signkey : Api.SignKeySignature.t -> unit result
val verify_future_denomination : Api.DenomSignature.t -> unit result
val certify_future_signkey : Api.SignKeySignature.t -> unit result
val certify_future_denomination : Api.DenomSignature.t -> unit result
val make_future_keys_response : unit -> Api.FutureKeysResponse.t Result.t
val verify_future_signkey : Api.SignKeySignature.t -> unit Result.t
val verify_future_denomination : Api.DenomSignature.t -> unit Result.t
val certify_future_signkey : Api.SignKeySignature.t -> unit Result.t
val certify_future_denomination : Api.DenomSignature.t -> unit Result.t
val revoke_signkey :
Eddsa.pub -> Signatures.MasterSigningKeyRevocation.t -> unit result
Eddsa.pub -> Signatures.MasterSigningKeyRevocation.t -> unit Result.t
val revoke_denomination :
DenominationHash.t ->
Signatures.MasterDenominationKeyRevocation.t ->
unit result
unit Result.t
end
module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
@ -34,25 +32,12 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
module Sm_rsa = Secmod_rsa.Make (Fs)
let conn = (module Conn : Pg.CONN)
(* TODO better error
can only be "key not found", either:
- we tried to sign with a key that is not ours
- key was revoked
- bad keyring state *)
let sign pub s =
match Sm_eddsa.sign pub s with
| Error e -> Fmt.failwith "sign failure: %s." e
| Ok v -> v
let sign_denom h_pub s =
match Sm_rsa.sign h_pub s with
| Error e -> Fmt.failwith "sign_denom failure: %s." e
| Ok v -> v
let sign = Sm_eddsa.sign
let sign_denom = Sm_rsa.sign
(* - *)
let find_signkey pub = Pg.find_signkey conn pub |> unwrap_caqti
let find_denomination h_pub = Pg.find_denom conn h_pub |> unwrap_caqti
let find_signkey pub = Pg.find_signkey conn pub
let find_denomination h_pub = Pg.find_denom conn h_pub
let warn_key_state =
let first = ref true in
@ -65,9 +50,9 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
first := false;
())
let signkeys () : Signkey.t list result =
let signkeys () : Signkey.t list Result.t =
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
let+ l = Pg.get_signkeys conn ~now |> unwrap_caqti in
let+ l = Pg.get_signkeys conn ~now in
let missing_l, l =
List.partition
(fun sk -> Option.is_none @@ Sm_eddsa.find_key sk.Signkey.pub)
@ -81,7 +66,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
l
let denominations () =
let+ l = Pg.get_denominations conn () |> unwrap_caqti in
let+ l = Pg.get_denominations conn () in
let missing_l, l =
List.partition
(fun dn -> Option.is_none @@ Sm_rsa.find_key dn.Denomination.h_pub)
@ -96,7 +81,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
l
let make_future_sk (pub, (start, expire)) =
Logs.debug (fun m -> m "make_future_sk: `%s`" (Eddsa.pub_to_b32 pub));
Logs.debug (fun m -> m "make_future_sk: `%a`" Eddsa.pp_pub pub);
let open Time in
let stamp_start = Timestamp.of_absolute start in
let stamp_expire = Timestamp.of_absolute expire in
@ -114,35 +99,23 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
Api.FutureSignKey.
{ key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }
let coin_of_section_name section_name =
Config.Coin.all_coins
|> List.find_opt (fun coin -> coin.Config.Coin.section_name = section_name)
|> function
| None ->
Fmt.failwith "coin section `%s` not found in configuration" section_name
| Some v -> v
let make_future_dn (h_pub, (section_name, pub, start)) =
Logs.debug (fun m ->
m "make_future_dn: `%s`" (DenominationHash.to_b32 h_pub));
let open Time in
let Config.Coin.
{
section_name;
value;
duration_withdraw;
duration_spend;
duration_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
cipher= _;
rsa_keysize= _;
age_restricted= _;
} =
coin_of_section_name section_name
let make_future_dn (h_pub, (coin, pub, start)) =
let {
Config.Coin.section_name;
value;
duration_withdraw;
duration_spend;
duration_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
_;
} =
coin
in
Logs.debug (fun m -> m "make_future_dn: `%a`" DenominationHash.pp h_pub);
let open Time in
let stamp_start = Timestamp.of_absolute start in
let stamp_expire_withdraw =
Timestamp.of_absolute @@ TimeAbsolute.add start duration_withdraw
@ -186,22 +159,22 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
let find_future_signkey pub =
match Sm_eddsa.find_key pub with
| None -> Error "future signkey not found"
| None -> Fmt.error_msg "future signkey not found"
| Some (pub, (t1, t2)) ->
let fsk = make_future_sk (pub, (t1, t2)) in
Ok fsk
let find_future_denomination h_pub =
match Sm_rsa.find_key h_pub with
| None -> Error "future denomination not found"
| Some (h_pub, (section_name, pub, t1)) ->
let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in
| None -> Fmt.error_msg "future denomination not found"
| Some v ->
let future_dn = make_future_dn v in
Ok future_dn
let make_future_keys_response () =
let now = Timestamp.of_ptime @@ Mirage_ptime.now () in
(* get keys from database to filter out keys already certified *)
let* sk_db_l = Pg.get_signkeys conn ~now |> unwrap_caqti in
let* sk_db_l = 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 =
@ -209,7 +182,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
|> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub)
|> List.map make_future_sk
in
let* dn_db_l = Pg.get_denominations conn () |> unwrap_caqti in
let* dn_db_l = 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 =
@ -296,60 +269,45 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct
let certify_future_signkey Api.SignKeySignature.{ key= pub; master_sig } =
match Sm_eddsa.find_key pub with
| None -> Error "future signkey not found"
| Some (pub, (t1, t2)) -> (
let* opt = find_signkey pub in
match opt with
| Some _sk ->
Logs.info (fun m -> m "signkey already certified");
Ok ()
| None ->
(* rebuild it *)
let future_sk = make_future_sk (pub, (t1, t2)) in
let sk = sk_of_future_sk future_sk master_sig in
let+ () = Pg.insert_signkey conn sk |> unwrap_caqti in
Logs.info (fun m ->
m "certified signkey `%s`" (Eddsa.pub_to_b32 sk.pub));
())
| None -> Error `Not_found
| Some (pub, (t1, t2)) ->
(* rebuild it *)
let future_sk = make_future_sk (pub, (t1, t2)) in
let sk = sk_of_future_sk future_sk master_sig in
let+ () = Pg.insert_signkey conn sk in
Logs.info (fun m -> m "certified signkey `%a`" Eddsa.pp_pub sk.pub);
()
let certify_future_denomination
Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } =
match Sm_rsa.find_key h_pub with
| None -> Error "future denomination not found"
| Some (h_pub, (section_name, pub, t1)) -> (
let* opt = find_denomination h_pub in
match opt with
| Some _dn ->
Logs.info (fun m -> m "denomination already certified");
Ok ()
| None ->
let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in
let dn = dn_of_future_dn future_dn h_pub master_sig in
let+ () = Pg.insert_denom conn dn |> unwrap_caqti in
Logs.info (fun m ->
m "certified denomination `%s`"
(DenominationHash.to_b32 dn.h_pub));
())
| None -> Error `Not_found
| Some (h_pub, (section_name, pub, t1)) ->
let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in
let dn = dn_of_future_dn future_dn h_pub master_sig in
let+ () = Pg.insert_denom conn dn in
Logs.info (fun m ->
m "certified denomination `%a`" DenominationHash.pp dn.h_pub);
()
let revoke_signkey pub revoked_sig =
let* opt = find_signkey pub in
let* _sk = Option.to_result ~none:"signkey not found" opt in
let* () = Sm_eddsa.revoke pub in
let+ () =
Pg.insert_signkey_revocation conn pub revoked_sig |> unwrap_caqti
in
Logs.info (fun m -> m "revoked signkey `%s`" (Eddsa.pub_to_b32 pub));
()
match opt with
| None -> Fmt.error_msg "signkey not found"
| Some _sk ->
let* () = Sm_eddsa.revoke pub in
let+ () = Pg.insert_signkey_revocation conn pub revoked_sig in
Logs.info (fun m -> m "revoked signkey `%a`" Eddsa.pp_pub pub);
()
let revoke_denomination h_pub revoked_sig =
let* opt = find_denomination h_pub in
let* dn = Option.to_result ~none:"denomination not found" opt in
let* () = Sm_rsa.revoke dn.h_pub in
let+ () =
Pg.insert_denomination_revocation conn dn.h_pub revoked_sig
|> unwrap_caqti
in
Logs.info (fun m ->
m "revoked denomination `%s`" (DenominationHash.to_b32 h_pub));
()
match opt with
| None -> Fmt.error_msg "denomination not found"
| Some dn ->
let* () = Sm_rsa.revoke dn.h_pub in
let+ () = Pg.insert_denomination_revocation conn dn.h_pub revoked_sig in
Logs.info (fun m ->
m "revoked denomination `%a`" DenominationHash.pp h_pub);
()
end

12
src/libtool_version.ml
View file

@ -25,7 +25,7 @@ let of_string s =
in
let* l = String.split_on_char ':' s |> Syntax.list_map to_int in
match l with
| [] -> Fmt.failwith "not possible"
| [] -> assert false
| [ current ] -> Ok { current; revision= None; age= None }
| [ current; revision ] -> Ok { current; revision= Some revision; age= None }
| [ current; revision; age ] ->
@ -39,10 +39,16 @@ let pp ppf v =
Fmt.pf ppf "%d:%d" current revision
| { current; revision= Some revision; age= Some age } ->
Fmt.pf ppf "%d:%d:%d" current revision age
| _ -> Fmt.failwith "corrupt version data: has age with no revision"
| _ -> assert false
let jsont =
Jsont.of_of_string ~kind:"libtool version" of_string ~enc:(Fmt.str "%a" pp)
let mte_protocol_version = "31:0:0"
let mte_protocol_version =
"31:0:0" |> of_string |> function Error e -> Fmt.failwith "%s" e | Ok v -> v
match of_string mte_protocol_version with
| Error e ->
Fmt.epr "Invalid libtool version: %s" e;
exit 1
| Ok v -> v

7
src/libtool_version.mli Normal file
View file

@ -0,0 +1,7 @@
type t
val mte_protocol_version : t
val is_compatible : implementation:t -> t -> bool
val of_string : string -> (t, string) result
val pp : Format.formatter -> t -> unit
val jsont : t Jsont.t

7
src/log_reporter.ml
View file

@ -56,6 +56,13 @@ let set_level_secmods lvl =
let setup level =
(* set_level_secmods level; *)
(*
let l = Logs.Src.list () in
let l =
List.filter (fun src -> Logs.Src.name src = "mnet.happy_eyeballs") l
in
List.iter (fun src -> Logs.Src.set_level src None) l;
*)
Logs.set_level ~all:false level;
Logs.Src.set_level Logs.default level;
Logs.set_reporter reporter;

4
src/mte.ml
View file

@ -71,9 +71,11 @@ let routes =
module RNG = Mirage_crypto_rng.Fortuna
let log_level = Some Logs.Info
let () =
let ( let@ ) finally fn = Fun.protect ~finally fn in
Log_reporter.setup (Some Logs.Info);
Log_reporter.setup log_level;
let rng =
let rng () = Mirage_crypto_rng_mkernel.initialize (module RNG) in
Mkernel.map rng Mkernel.[]

15
src/mte_info.ml
View file

@ -42,11 +42,11 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
let stefan_lin = Config.stefan_lin in
(* type of the asset. "fiat", "crypto", "regional" or "stock". *)
let asset_type = "fiat" in
let* accounts = Pg.get_wire_accounts db_conn () |> unwrap_caqti in
let* accounts = Pg.get_wire_accounts db_conn () in
let* wire_fees =
(* wire_methods? *)
let wire_method = "x-taler-bank" in
let+ wire_fees = Pg.get_wire_fees db_conn ~wire_method |> unwrap_caqti in
let+ wire_fees = Pg.get_wire_fees db_conn ~wire_method in
String_map.singleton wire_method wire_fees
in
let wads = [] in
@ -81,7 +81,7 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
(fun v -> Timestamp.compare timestamp v.Denomination.stamp_start <= 0)
denom_l
in
let* denominations = Denomination.make_denom_group_sorted denom_l in
let denominations = Denomination.make_denom_group_sorted denom_l in
let* signkeys = Keys.signkeys () in
@ -92,7 +92,7 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
List.find_opt (fun sk -> Signkey.is_valid_at ~timestamp:now sk) signkeys
in
match opt with
| None -> Fmt.error "exchange has no active signkey"
| 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
@ -109,9 +109,7 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date =
in
let recoup = (* /recoup *) [] in
let* global_fees =
Pg.get_global_fees db_conn ~start_date:Timestamp.zero |> unwrap_caqti
in
let* global_fees = Pg.get_global_fees db_conn ~start_date:Timestamp.zero in
let* auditors =
(* /auditors/$AUDITOR_PUB/$H_DENOM_PUB *)
Pg.get_auditor_keys db_conn
@ -167,7 +165,8 @@ let keys req server _env =
| [] -> Ok None
| s :: _ -> (
match Int64.of_string_opt s with
| None -> Error "invalid `?last_issue_date` query param, not an int"
| None ->
Fmt.error_msg "invalid `?last_issue_date` query param, not an int"
| Some n -> Ok (Some (Timestamp.of_s n)))
in
let* v = mk_keys ~db_conn keys ~last_issue_date in

121
src/mte_management.ml
View file

@ -3,6 +3,10 @@ open Api
open Hash
open Time
(* todo request.ml? *)
let request_of_json req =
Result.map_error (fun (`Msg e) -> `Json_decode e) (Vifu.Request.of_json req)
module Keys_get = struct
let jsont = FutureKeysResponse.jsont
@ -34,7 +38,7 @@ module Keys_post = struct
Logs.info (fun m -> m "POST /management/keys/");
let keys = Vifu.Server.device Global.keys server in
let res =
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* v = request_of_json req in
let* () = verify keys v in
let* () = do_ keys v in
Ok ()
@ -59,8 +63,11 @@ module Denom_revoke = struct
Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
let keys = Vifu.Server.device Global.keys server in
let res =
let* h_denom_pub = Hash.DenominationHash.of_b32 h_denom_pub in
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* h_denom_pub =
DenominationHash.of_b32 h_denom_pub
|> Result.map_error (fun e -> `Msg e)
in
let* v = request_of_json req in
let* () = verify keys h_denom_pub v in
let* () = do_ keys h_denom_pub v in
Ok ()
@ -85,8 +92,10 @@ module Signkey_revoke = struct
Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
let keys = Vifu.Server.device Global.keys server in
let res =
let* exchange_pub = Eddsa.pub_of_b32 exchange_pub in
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* exchange_pub =
Eddsa.pub_of_b32 exchange_pub |> Result.map_error (fun e -> `Msg e)
in
let* v = request_of_json req in
let* () = verify keys exchange_pub v in
let* () = do_ keys exchange_pub v in
Ok ()
@ -109,24 +118,24 @@ module Auditors = struct
{
start_date= validity_start;
auditor_pub;
h_auditor_url= Hash.H64_cstring.hash auditor_url;
h_auditor_url= H64_cstring.hash auditor_url;
}
let do_ ~db_conn v =
let auditor_pub = v.AuditorSetupMessage.auditor_pub in
let validity_start = v.AuditorSetupMessage.validity_start in
let* opt = Pg.find_auditor db_conn auditor_pub |> unwrap_caqti in
let* opt = Pg.find_auditor db_conn auditor_pub in
match opt with
| None ->
let auditor = Pg_type.Auditor.of_setup_message v in
let+ () = Pg.update_auditor db_conn auditor |> unwrap_caqti in
let+ () = Pg.update_auditor db_conn auditor in
Logs.info (fun m -> m "enabled auditor");
()
| Some auditor ->
if Timestamp.compare validity_start auditor.last_change <= 0 then
Error "replay detected on enable-auditor"
Error (`Conflict "replay detected on enable-auditor")
else
let+ () = Pg.update_auditor db_conn auditor |> unwrap_caqti in
let+ () = Pg.update_auditor db_conn auditor in
Logs.info (fun m -> m "updated auditor");
()
@ -137,7 +146,7 @@ module Auditors = struct
let keys = Vifu.Server.device Global.keys server in
let db_conn = Vifu.Server.device Global.db_conn server in
let res =
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* v = request_of_json req in
let* () = verify keys v in
let* () = do_ ~db_conn v in
Ok ()
@ -154,12 +163,12 @@ module Auditors_disable = struct
let do_ ~db_conn auditor_pub
AuditorTeardownMessage.{ master_sig= _; validity_end } =
let* opt = Pg.find_auditor db_conn auditor_pub |> unwrap_caqti in
let* opt = Pg.find_auditor db_conn auditor_pub in
match opt with
| None -> Error "auditor not found"
| None -> Error `Not_found
| Some auditor -> (
if Timestamp.compare validity_end auditor.last_change <= 0 then
Error "replay detected on disable-auditor"
Error (`Conflict "replay detected on disable-auditor")
else
match auditor.is_active with
| false ->
@ -169,9 +178,9 @@ module Auditors_disable = struct
let auditor =
{ auditor with last_change= validity_end; is_active= false }
in
let+ () = Pg.update_auditor db_conn auditor |> unwrap_caqti in
let+ () = Pg.update_auditor db_conn auditor in
Logs.info (fun m ->
m "revoked auditor `%s`" (Eddsa.pub_to_b32 auditor_pub));
m "revoked auditor `%a`" Eddsa.pp_pub auditor_pub);
())
let jsont = AuditorTeardownMessage.jsont
@ -181,8 +190,10 @@ module Auditors_disable = struct
let keys = Vifu.Server.device Global.keys server in
let db_conn = Vifu.Server.device Global.db_conn server in
let res =
let* auditor_pub = Eddsa.pub_of_b32 auditor_pub in
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* auditor_pub =
Eddsa.pub_of_b32 auditor_pub |> Result.map_error (fun e -> `Msg e)
in
let* v = request_of_json req in
let* () = verify keys auditor_pub v in
let* () = do_ ~db_conn auditor_pub v in
Ok ()
@ -204,7 +215,7 @@ module Wire_fee = struct
let open Signatures.MasterWireFee in
verify Config.master_public_key master_sig_wire
{
h_wire_method= Hash.H64_cstring.hash wire_method;
h_wire_method= H64_cstring.hash wire_method;
start_date= fee_start;
end_date= fee_end;
wire_fee;
@ -215,22 +226,23 @@ module Wire_fee = struct
let* wire_fees =
Pg.get_wire_fees_by_time db_conn ~wire_method:v.wire_method
~start_date:v.fee_start ~end_date:v.fee_end
|> unwrap_caqti
in
match wire_fees with
| [] ->
let+ () = Pg.insert_wire_fee db_conn v |> unwrap_caqti in
let+ () = Pg.insert_wire_fee db_conn v in
Logs.info (fun m -> m "added wire fee");
()
| [ vv ] -> (
match v.master_sig_wire = vv.sig_ with
| false ->
Error "a different wire-fee was already setup for this time frame"
Error
(`Conflict
"a different wire-fee was already setup for this time frame")
| true ->
Logs.info (fun m -> m "an identical wire-fee was already setup");
Ok ())
| _ ->
Error
Fmt.error_msg
"invalid database state, multiple wire-fee found in database for \
this time frame"
@ -241,7 +253,7 @@ module Wire_fee = struct
let keys = Vifu.Server.device Global.keys server in
let db_conn = Vifu.Server.device Global.db_conn server in
let res =
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* v = request_of_json req in
let* () = verify keys v in
let* () = do_ ~db_conn v in
Ok ()
@ -256,23 +268,24 @@ module Global_fees = struct
let* global_fees =
let start_date = v.GlobalFees.start_date in
let end_date = v.GlobalFees.end_date in
Pg.get_global_fees_by_time db_conn ~start_date ~end_date |> unwrap_caqti
Pg.get_global_fees_by_time db_conn ~start_date ~end_date
in
match global_fees with
| [] ->
let+ () = Pg.insert_global_fees db_conn v |> unwrap_caqti in
let+ () = Pg.insert_global_fees db_conn v in
Logs.info (fun m -> m "added global fees");
()
| [ vv ] -> (
match v.master_sig = vv.master_sig with
| false ->
Error
"a different global-fees was already setup for this time frame"
(`Conflict
"a different global-fees was already setup for this time frame")
| true ->
Logs.info (fun m -> m "an identical global-fees was already setup");
Ok ())
| _ ->
Error
Fmt.error_msg
"invalid database state, multiple global-fees found in database for \
this time frame"
@ -286,7 +299,7 @@ module Global_fees = struct
Logs.info (fun m -> m "POST /management/global-fees/");
let db_conn = Vifu.Server.device Global.db_conn server in
let res =
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* v = request_of_json req in
let* () = verify v in
let* () = do_ ~db_conn v in
Ok ()
@ -314,16 +327,17 @@ module Wire = struct
match (credit_restrictions, debit_restrictions) with
| [], [] -> Ok ()
| _ ->
Fmt.error
Fmt.error_msg
"wire setup: credit_restrictions and debit_restrictions are not \
supported"
in
let h_wire_details = Hash.FullPaytoHash.hash payto_uri in
let h_wire_details = FullPaytoHash.hash payto_uri in
let h_conversion_url =
Hash.H64_cstring.hash ((* ?? *) Option.value ~default:"" conversion_url)
let s = Option.value ~default:"" conversion_url in
H64_cstring.hash s
in
let h_credit_restrictions = Hash.H64_cstring.hash "" in
let h_debit_restrictions = Hash.H64_cstring.hash "" in
let h_credit_restrictions = H64_cstring.hash "" in
let h_debit_restrictions = H64_cstring.hash "" in
(* - *)
let* () =
let open Signatures.MasterWireDetails in
@ -361,7 +375,7 @@ module Wire = struct
bank_label;
priority;
} =
let* opt = Pg.find_wire db_conn ~payto_uri |> unwrap_caqti in
let* opt = Pg.find_wire db_conn ~payto_uri in
match opt with
| None ->
let wire =
@ -379,18 +393,16 @@ module Wire = struct
let+ () =
Pg.update_wire db_conn ~is_active:true ~last_change:validity_start
wire
|> unwrap_caqti
in
Logs.info (fun m -> m "added wire method");
()
| Some (wire, _is_active, last_change) ->
if Timestamp.compare validity_start last_change <= 0 then
Error "replay detected on enable-wire"
Error (`Conflict "replay detected on enable-wire")
else
let+ () =
Pg.update_wire db_conn ~is_active:true ~last_change:validity_start
wire
|> unwrap_caqti
in
Logs.info (fun m -> m "updated wire method");
()
@ -402,7 +414,7 @@ module Wire = struct
let keys = Vifu.Server.device Global.keys server in
let db_conn = Vifu.Server.device Global.db_conn server in
let res =
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* v = request_of_json req in
let* () = verify keys v in
let* () = do_ ~db_conn v in
Ok ()
@ -419,17 +431,16 @@ module Wire_disable = struct
let do_ ~db_conn
WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } =
let* opt = Pg.find_wire db_conn ~payto_uri |> unwrap_caqti in
let* opt = Pg.find_wire db_conn ~payto_uri in
match opt with
| None -> Error "wire not found"
| None -> Error `Not_found
| Some (wire, _is_active, last_change) ->
if Timestamp.compare validity_end last_change <= 0 then
Error "replay detected on disable-wire"
Error (`Conflict "replay detected on disable-wire")
else
let+ () =
Pg.update_wire db_conn ~is_active:false ~last_change:validity_end
wire
|> unwrap_caqti
in
Logs.info (fun m -> m "disabled wire method");
()
@ -441,7 +452,7 @@ module Wire_disable = struct
let keys = Vifu.Server.device Global.keys server in
let db_conn = Vifu.Server.device Global.db_conn server in
let res =
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* v = request_of_json req in
let* () = verify keys v in
let* () = do_ ~db_conn v in
Ok ()
@ -466,20 +477,18 @@ module Drain = struct
wtid;
date;
amount;
h_section= Hash.H64_cstring.hash debit_account_section;
h_section= H64_cstring.hash debit_account_section;
h_payto= FullPaytoHash.hash credit_payto_uri;
}
let do_ ~db_conn v =
let* opt =
Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid |> unwrap_caqti
in
let* opt = Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid in
match opt with
| Some _ ->
Logs.info (fun m -> m "drain profit message already added to database");
Ok ()
| None ->
let+ () = Pg.insert_drain_profit db_conn v |> unwrap_caqti in
let+ () = Pg.insert_drain_profit db_conn v in
Logs.info (fun m -> m "added drain profit message to database");
()
@ -490,7 +499,7 @@ module Drain = struct
let keys = Vifu.Server.device Global.keys server in
let db_conn = Vifu.Server.device Global.db_conn server in
let res =
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* v = request_of_json req in
let* () = verify keys v in
let* () = do_ ~db_conn v in
Ok ()
@ -515,12 +524,12 @@ module AmlOfficer = struct
{
change_date;
officer_pub;
h_officer_name= Hash.H64_cstring.hash officer_name;
h_officer_name= H64_cstring.hash officer_name;
is_active;
}
let do_ ~db_conn v =
let+ _last_change = Pg.insert_aml_officer db_conn v |> unwrap_caqti in
let+ _last_change = Pg.insert_aml_officer db_conn v in
()
let jsont = AmlOfficerSetup.jsont
@ -530,7 +539,7 @@ module AmlOfficer = struct
let keys = Vifu.Server.device Global.keys server in
let db_conn = Vifu.Server.device Global.db_conn server in
let res =
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* v = request_of_json req in
let* () = verify keys v in
let* () = do_ ~db_conn v in
Ok ()
@ -558,11 +567,11 @@ module Partners = struct
end_date;
wad_frequency;
wad_fee;
h_url= Hash.H64_cstring.hash partner_base_url;
h_url= H64_cstring.hash partner_base_url;
}
let do_ ~db_conn v =
let+ () = Pg.insert_partner db_conn v |> unwrap_caqti in
let+ () = Pg.insert_partner db_conn v in
()
let jsont = ExchangePartnerSetupRequest.jsont
@ -572,7 +581,7 @@ module Partners = struct
let keys = Vifu.Server.device Global.keys server in
let db_conn = Vifu.Server.device Global.db_conn server in
let res =
let* v = Vifu.Request.of_json req |> unwrap_msg in
let* v = request_of_json req in
let* () = verify keys v in
let* () = do_ ~db_conn v in
Ok ()

138
src/pg.ml
View file

@ -4,18 +4,23 @@
module type CONN = Caqti_miou.CONNECTION
module Caqti_type = struct
include Caqti_type
include Pg_type
include Caqti_request.Infix
end
let map_err r =
Result.map_error (Fmt.kstr (fun e -> `Caqti e) "%a" Caqti_error.pp) r
let exec (module Conn : CONN) req v = Conn.exec req v |> map_err
let find (module Conn : CONN) req v = Conn.find req v |> map_err
let find_opt (module Conn : CONN) req v = Conn.find_opt req v |> map_err
let collect_list (module Conn : CONN) req v = Conn.collect_list req v |> map_err
let disconnect (module Conn : CONN) () = Conn.disconnect ()
open Caqti_request.Infix
open Caqti_type
open Pg_type
open Api
let preflight =
let l =
List.map
Caqti_type.(unit ->. unit)
List.map (unit ->. unit)
[
"SET SESSION CHARACTERISTICS AS TRANSACTION ISOLATION LEVEL \
SERIALIZABLE;";
@ -25,53 +30,52 @@ let preflight =
"SET search_path TO exchange;";
]
in
fun (module Conn : CONN) ->
let r = Syntax.list_iter (fun p -> Conn.exec p ()) l in
fun conn ->
let r = Syntax.list_iter (fun p -> exec conn p ()) l in
match r with
| Error err ->
Fmt.failwith "Database preflight failure: %a." Caqti_error.pp err
Fmt.failwith "Database preflight failure: %a." Result.pp_err err
| Ok () -> ()
let find_signkey =
let req =
Caqti_type.(eddsa_pub ->? signkey)
(eddsa_pub ->? signkey)
"SELECT exchange_pub, valid_from, expire_sign, expire_legal, master_sig \
FROM exchange_sign_keys WHERE exchange_pub=$1"
in
fun (module Conn : CONN) (exchange_pub : Eddsa.pub) ->
Conn.find_opt req exchange_pub
fun conn (exchange_pub : Eddsa.pub) -> find_opt conn req exchange_pub
let get_signkeys =
let req =
Caqti_type.(time ->* signkey)
(time ->* signkey)
"SELECT esk.exchange_pub, esk.valid_from, esk.expire_sign, \
esk.expire_legal, esk.master_sig FROM exchange_sign_keys esk WHERE \
esk.expire_sign > $1 AND NOT EXISTS (SELECT esk_serial FROM \
signkey_revocations AS skr WHERE esk.esk_serial = skr.esk_serial)"
in
fun (module Conn : CONN) ~now -> Conn.collect_list req now
fun conn ~now -> collect_list conn req now
let insert_signkey =
let req =
Caqti_type.(signkey ->. unit)
(signkey ->. unit)
"INSERT INTO exchange_sign_keys (exchange_pub, valid_from, expire_sign, \
expire_legal, master_sig) VALUES ($1, $2, $3, $4, $5)"
in
fun (module Conn : CONN) v -> Conn.exec req v
fun conn v -> exec conn req v
let find_denom =
let req =
Caqti_type.(denom_hash ->? denom)
(denom_hash ->? denom)
"SELECT denom_pub, (coin).*, valid_from, expire_withdraw, \
expire_deposit, expire_legal, (fee_withdraw).*, (fee_deposit).*, \
(fee_refresh).*, (fee_refund).*, age_mask, denom_pub_hash, master_sig \
FROM denominations WHERE denom_pub_hash=$1"
in
fun (module Conn : CONN) h_denom_pub -> Conn.find_opt req h_denom_pub
fun conn h_denom_pub -> find_opt conn req h_denom_pub
let get_denominations =
let req =
Caqti_type.(unit ->* denom)
(unit ->* denom)
"SELECT dn.denom_pub, (dn.coin).*, dn.valid_from, dn.expire_withdraw, \
dn.expire_deposit, dn.expire_legal, (dn.fee_withdraw).*, \
(dn.fee_deposit).*, (dn.fee_refresh).*, (dn.fee_refund).*, dn.age_mask, \
@ -79,71 +83,69 @@ let get_denominations =
EXISTS (SELECT dn.denominations_serial FROM denomination_revocations AS \
dnr WHERE dn.denominations_serial = dnr.denominations_serial)"
in
fun (module Conn : CONN) () -> Conn.collect_list req ()
fun conn () -> collect_list conn req ()
(* note: does not update revocation *)
let insert_denom =
let req =
Caqti_type.(denom ->. unit)
(denom ->. unit)
"INSERT INTO denominations (denom_pub, coin, valid_from, \
expire_withdraw, expire_deposit, expire_legal, fee_withdraw, \
fee_deposit, fee_refresh, fee_refund, age_mask, denom_pub_hash, \
master_sig) VALUES ($1, ($2, $3), $4, $5, $6, $7, ($8,$9), ($10,$11), \
($12,$13), ($14,$15), $16, $17, $18)"
in
fun (module Conn : CONN) v -> Conn.exec req v
fun conn v -> exec conn req v
let insert_denomination_revocation =
let req =
let master_sig = Signatures.MasterDenominationKeyRevocation.caqti in
Caqti_type.(t2 denom_hash master_sig ->. unit)
(t2 denom_hash master_sig ->. unit)
"INSERT INTO denomination_revocations (denominations_serial, master_sig) \
SELECT denominations_serial, $2 FROM denominations WHERE \
denom_pub_hash=$1"
in
fun (module Conn : CONN) h_denom_pub master_sig ->
Conn.exec req (h_denom_pub, master_sig)
fun conn h_denom_pub master_sig -> exec conn req (h_denom_pub, master_sig)
let insert_signkey_revocation =
let req =
let master_sig = Signatures.MasterSigningKeyRevocation.caqti in
Caqti_type.(t2 eddsa_pub master_sig ->. unit)
(t2 eddsa_pub master_sig ->. unit)
"INSERT INTO signkey_revocations (esk_serial, master_sig) SELECT \
esk_serial, $2 FROM exchange_sign_keys WHERE exchange_pub=$1"
in
fun (module Conn : CONN) exchange_pub master_sig ->
Conn.exec req (exchange_pub, master_sig)
fun conn exchange_pub master_sig -> exec conn req (exchange_pub, master_sig)
let find_auditor =
let req =
Caqti_type.(eddsa_pub ->? auditor)
(eddsa_pub ->? auditor)
"SELECT auditor_pub, auditor_name, auditor_url, last_change, is_active \
FROM auditors WHERE auditor_pub=$1"
in
fun (module Conn : CONN) auditor_pub -> Conn.find_opt req auditor_pub
fun conn auditor_pub -> find_opt conn req auditor_pub
let update_auditor =
let req =
Caqti_type.(auditor ->. unit)
(auditor ->. unit)
"INSERT INTO auditors (auditor_pub, auditor_name, auditor_url, \
last_change, is_active) VALUES ($1, $2, $3, $4, $5) ON CONFLICT \
(auditor_pub) DO UPDATE SET auditor_name=$2, auditor_url=$3, \
last_change=$4, is_active=$5"
in
fun (module Conn : CONN) auditor -> Conn.exec req auditor
fun conn auditor -> exec conn req auditor
let insert_auditor_denom_sig =
let req =
let auditor_sig = Signatures.ExchangeKeyValidity.caqti in
Caqti_type.(t3 eddsa_pub denom_hash auditor_sig ->. unit)
(t3 eddsa_pub denom_hash auditor_sig ->. unit)
"WITH ax AS (SELECT auditor_uuid FROM auditors WHERE auditor_pub=$1) \
INSERT INTO auditor_denom_sigs (auditor_uuid, denominations_serial, \
auditor_sig) SELECT ax.auditor_uuid, denominations_serial, $3 FROM \
denominations CROSS JOIN ax WHERE denom_pub_hash=$2 ON CONFLICT DO \
NOTHING"
in
fun (module Conn : CONN) ~auditor_pub ~h_denom_pub ~auditor_sig ->
Conn.exec req (auditor_pub, h_denom_pub, auditor_sig)
fun conn ~auditor_pub ~h_denom_pub ~auditor_sig ->
exec conn req (auditor_pub, h_denom_pub, auditor_sig)
(* todo auditors
map to Auditor.t record
@ -153,15 +155,15 @@ let insert_auditor_denom_sig =
let get_auditor_keys =
let req =
let auditor_sig = Signatures.ExchangeKeyValidity.caqti in
Caqti_type.(unit ->* t5 eddsa_pub string string denom_hash auditor_sig)
(unit ->* t5 eddsa_pub string string denom_hash auditor_sig)
"SELECT a.auditor_pub, a.auditor_url, a.auditor_name, dn.denom_pub_hash, \
ads.auditor_sig FROM auditor_denom_sigs AS ads JOIN auditors AS a USING \
(auditor_uuid) JOIN denominations AS dn USING (denominations_serial) \
WHERE a.is_active"
in
fun (module Conn : CONN) ->
fun conn ->
let open Syntax in
let* l = Conn.collect_list req () |> unwrap_caqti in
let* l = collect_list conn req () in
let ht = Hashtbl.create 0xff in
List.iter
(fun (pub, url, name, denom_pub_h, auditor_sig) ->
@ -189,11 +191,11 @@ let get_auditor_keys =
let insert_wire_fee =
let req =
let master_sig = Signatures.MasterWireFee.caqti in
Caqti_type.(t6 wire_method time time amount amount master_sig ->. unit)
(t6 wire_method time time amount amount master_sig ->. unit)
"INSERT INTO wire_fee (wire_method, start_date, end_date, wire_fee, \
closing_fee, master_sig) VALUES ($1, $2, $3, ($4,$5), ($6,$7), $8)"
in
fun (module Conn : CONN)
fun conn
WireFeeSetupMessage.
{
wire_method;
@ -204,68 +206,67 @@ let insert_wire_fee =
wire_fee;
}
->
Conn.exec req
exec conn req
(wire_method, fee_start, fee_end, wire_fee, closing_fee, master_sig_wire)
let get_wire_fees_by_time =
let req =
Caqti_type.(t3 wire_method time time ->* aggregate_transfer_fee)
(t3 wire_method time time ->* aggregate_transfer_fee)
"SELECT (wire_fee).*, (closing_fee).*, start_date, end_date, master_sig \
FROM wire_fee WHERE wire_method=$1 AND end_date > $2 AND start_date < \
$3"
in
fun (module Conn : CONN) ~wire_method ~start_date ~end_date ->
Conn.collect_list req (wire_method, start_date, end_date)
fun conn ~wire_method ~start_date ~end_date ->
collect_list conn req (wire_method, start_date, end_date)
let get_wire_fees =
let req =
Caqti_type.(string ->* aggregate_transfer_fee)
(string ->* aggregate_transfer_fee)
"SELECT (wire_fee).*, (closing_fee).*, start_date, end_date, master_sig \
FROM wire_fee WHERE wire_method=$1"
in
fun (module Conn : CONN) ~wire_method -> Conn.collect_list req wire_method
fun conn ~wire_method -> collect_list conn req wire_method
let get_global_fees =
let req =
Caqti_type.(time ->* global_fee)
(time ->* global_fee)
"SELECT start_date, end_date, (history_fee).*, (account_fee).*, \
(purse_fee).*, history_expiration, purse_account_limit, purse_timeout, \
master_sig FROM global_fee WHERE start_date >= $1"
in
fun (module Conn : CONN) ~start_date -> Conn.collect_list req start_date
fun conn ~start_date -> collect_list conn req start_date
let get_global_fees_by_time =
let req =
Caqti_type.(t2 time time ->* global_fee)
(t2 time time ->* global_fee)
"SELECT start_date, end_date, (history_fee).*, (account_fee).*, \
(purse_fee).*, history_expiration, purse_account_limit, purse_timeout, \
master_sig FROM global_fee WHERE start_date >= $1 AND end_date <= $2"
in
fun (module Conn : CONN) ~start_date ~end_date ->
Conn.collect_list req (start_date, end_date)
fun conn ~start_date ~end_date -> collect_list conn req (start_date, end_date)
let insert_global_fees =
let req =
Caqti_type.(global_fee ->. unit)
(global_fee ->. unit)
"INSERT INTO global_fee (start_date, end_date, history_fee, account_fee, \
purse_fee, history_expiration, purse_account_limit, purse_timeout, \
master_sig) VALUES ($1, $2, ($3,$4), ($5,$6), ($7,$8), $9, $10, $11, \
$12)"
in
fun (module Conn : CONN) v -> Conn.exec req v
fun conn v -> exec conn req v
let find_wire =
let req =
Caqti_type.(payto_uri ->? t3 exchange_wire_account bool time)
(payto_uri ->? t3 exchange_wire_account bool time)
"SELECT payto_uri, conversion_url, debit_restrictions::TEXT, \
credit_restrictions::TEXT, master_sig, bank_label, priority, is_active, \
last_change FROM wire_accounts WHERE payto_uri=$1"
in
fun (module Conn : CONN) ~payto_uri -> Conn.find_opt req payto_uri
fun conn ~payto_uri -> find_opt conn req payto_uri
let update_wire =
let req =
Caqti_type.(t3 exchange_wire_account bool time ->. unit)
(t3 exchange_wire_account bool time ->. unit)
"INSERT INTO wire_accounts (payto_uri, conversion_url, \
credit_restrictions, debit_restrictions, master_sig, bank_label, \
priority, is_active, last_change) VALUES \
@ -275,48 +276,47 @@ let update_wire =
debit_restrictions=$4::TEXT::JSONB, master_sig=$5, bank_label=$6, \
priority=$7, is_active=$8, last_change=$9"
in
fun (module Conn : CONN) ~is_active ~last_change v ->
Conn.exec req (v, is_active, last_change)
fun conn ~is_active ~last_change v -> exec conn req (v, is_active, last_change)
let get_wire_accounts =
let req =
Caqti_type.(unit ->* exchange_wire_account)
(unit ->* exchange_wire_account)
"SELECT payto_uri, conversion_url, debit_restrictions::TEXT, \
credit_restrictions::TEXT, master_sig, bank_label, priority FROM \
wire_accounts WHERE is_active"
in
fun (module Conn : CONN) () -> Conn.collect_list req ()
fun conn () -> collect_list conn req ()
let find_drain_profit =
let req =
Caqti_type.(Bytes32.caqti ->? drain_profit_message)
(Bytes32.caqti ->? drain_profit_message)
"SELECT wtid, account_section, payto_uri, trigger_date, (amount).*, \
master_sig FROM profit_drains WHERE wtid=$1"
in
fun (module Conn : CONN) wtid -> Conn.find_opt req wtid
fun conn wtid -> find_opt conn req wtid
let insert_drain_profit =
let req =
Caqti_type.(drain_profit_message ->. unit)
(drain_profit_message ->. unit)
"INSERT INTO profit_drains (wtid, account_section, payto_uri, \
trigger_date, amount, master_sig) VALUES ($1::BYTEA, $2, $3, $4, \
($5,$6), $7)"
in
fun (module Conn : CONN) v -> Conn.exec req v
fun conn v -> exec conn req v
let insert_aml_officer =
let req =
Caqti_type.(aml_officer_setup ->! time)
(aml_officer_setup ->! time)
"SELECT out_last_change FROM exchange_do_insert_aml_officer ($1, $2, $3, \
$4, $5, $6)"
in
fun (module Conn : CONN) v -> Conn.find req v
fun conn v -> find conn req v
let insert_partner =
let req =
Caqti_type.(exchange_partner_setup ->. unit)
(exchange_partner_setup ->. unit)
"INSERT INTO partners (partner_master_pub, start_date, end_date, \
wad_frequency, wad_fee, master_sig, partner_base_url) VALUES ($1, $2, \
$3, $4, ($5,$6), $7, $8) ON CONFLICT DO NOTHING"
in
fun (module Conn : CONN) v -> Conn.exec req v
fun conn v -> exec conn req v

24
src/pg_type.ml
View file

@ -1,24 +1,18 @@
(* this module defines caqti encoding/decodings *)
open Caqti_type
open Time
open Api
let amount : Amount.t t =
let open Amount in
custom
~encode:(fun amount -> Ok (amount.value, amount.fraction))
~decode:(fun (value, fraction) ->
Amount.make ~sign:None ~currency:Config.currency ~value ~fraction)
(t2 int64 int32)
(* we want to use int64 timestamps,
not postgresql built-in timestamp type *)
let ptime : unit t = Caqti_type.unit
let time = Time.Timestamp.caqti
let time_span = Time.TimeRelative.caqti
let time = Timestamp.caqti
let time_span = TimeRelative.caqti
let age_mask : int t = Caqti_type.int
let rsa_pub = Rsa.pub_caqti
let eddsa_pub = Eddsa.pub_caqti
let eddsa_sig = Eddsa.sig_caqti
let amount : Amount.t t = Amount.caqti ~currency:Config.currency
(* todo: enum type for wire_method? *)
let wire_method = Caqti_type.string
@ -119,10 +113,10 @@ let denom =
(t2 denom_hash master_sig))
let account_restrictions =
custom
~encode:(fun l -> Api.encode (Jsont.list AccountRestriction.jsont) l)
~decode:(fun s -> Api.decode (Jsont.list AccountRestriction.jsont) s)
string
let jsont = Jsont.list Api.AccountRestriction.jsont in
let encode = Api.encode' jsont in
let decode = Api.decode' jsont in
custom ~encode ~decode string
let global_fee =
let master_sig = Signatures.GlobalFees.caqti in
@ -355,7 +349,7 @@ module Auditor = struct
auditor_pub: Eddsa.pub;
auditor_url: string;
auditor_name: string;
last_change: Time.Timestamp.t;
last_change: Timestamp.t;
is_active: bool;
}

12
src/respond.ml
View file

@ -1,6 +1,7 @@
let encode_error_detail err =
match Api.(encode ErrorDetail.jsont err) with
| Error e -> Fmt.failwith "json encoding error on `ErrorDetail`: %s." e
match Api.encode Api.ErrorDetail.jsont err with
| Error e ->
Fmt.failwith "json encoding error on `ErrorDetail`: %a." Result.pp_err e
| Ok s -> s
let respond_json req content status =
@ -16,7 +17,8 @@ let mk_error_content ?hint _status =
let err = ErrorDetail.make ?hint code in
encode_error_detail err
let error ~hint req =
let error err req =
let hint = Fmt.str "%a" Result.pp_err err in
Logs.err (fun m -> m "error: %s" hint);
let body = mk_error_content ~hint `Internal_server_error in
respond_json req body `Internal_server_error
@ -45,7 +47,7 @@ let not_modified () =
respond `Not_modified
let result res req =
match res with Error hint -> error ~hint req | Ok content -> ok content req
match res with Error e -> error e req | Ok content -> ok content req
let result_no_content res req =
match res with Error hint -> error ~hint req | Ok () -> no_content ()
match res with Error e -> error e req | Ok () -> no_content ()

39
src/result.ml Normal file
View file

@ -0,0 +1,39 @@
include Stdlib.Result
type err =
[ `Msg of string
| `Json_decode of string
| `Bin_decode of string
| `Invalid_signature_eddsa
| `Invalid_signature_rsa
| (* - *)
`Not_found
| `Conflict of string
| (* - server errors - *)
`Server_err of string
| `Caqti of string
| `Mfat of string
| `Json_encode of string
| `Bin_encode of string
]
type 'a t = ('a, err) Stdlib.Result.t
let err_to_string : err -> string = function
| `Msg s -> s
| `Json_decode s -> Fmt.str "Json decode: %s" s
| `Json_encode s -> Fmt.str "Json encode: %s" s
| `Bin_decode s -> Fmt.str "Bin decode: %s" s
| `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"
(* - *)
| `Not_found -> Fmt.str "Not found"
| `Conflict s -> Fmt.str "Conflict: %s" s
(* - *)
| `Server_err s -> Fmt.str "Server error: %s" s
| `Caqti s -> Fmt.str "Caqti: %s" s
| `Mfat s -> Fmt.str "mFAT: %s" s
let pp_err = Fmt.of_to_string err_to_string
let unwrap_err r = map_error err_to_string r

105
src/rsa.ml
View file

@ -2,21 +2,19 @@ open Syntax
module Mirage_rsa = Mirage_crypto_pk.Rsa
module Z_extra = Mirage_crypto_pk.Z_extra
module Binary_format_rsa = struct
module RSA_BIN = struct
(* RSA public key binary format
https://www.gnupg.org/documentation/manuals/gcrypt/MPI-formats.html
:= { uint16_be: n size; uint16_be: e size; n; e}
integer in big-endian format (MSB first)
leading zeroes are stripped unless they are required to keep a value positive
no 0-termination *)
https://www.gnupg.org/documentation/manuals/gcrypt/MPI-formats.html
:= { uint16_be: n size; uint16_be: e size; n; e} *)
(* [Z.t array] encoding, used to define Rsa.pub binary encoding
and also a custom Rsa.priv encoding *)
let z_array_to_octets (arr : Z.t array) =
let nb = Array.length arr in
let bits_arr = Array.map Z_extra.to_octets_be arr in
let len_arr = Array.map String.length bits_arr in
let len = (2 * nb) + Array.fold_left ( + ) 0 len_arr in
let b = Bytes.make len '\x00' in
let b = Bytes.create len in
let pos = ref 0 in
Array.iter
(fun len ->
@ -32,8 +30,9 @@ module Binary_format_rsa = struct
Bytes.unsafe_to_string b
let z_array_of_octets ~nb s =
let error = Error "invalid rsa data" in
let s_len = String.length s in
if s_len <= 2 * nb then Error "rsa of_octets error"
if s_len <= 2 * nb then error
else
let pos = ref 0 in
let len_arr =
@ -43,7 +42,7 @@ module Binary_format_rsa = struct
len)
in
let len = (2 * nb) + Array.fold_left ( + ) 0 len_arr in
if s_len <> len then Error "rsa of_octets error"
if s_len <> len then error
else
let z_arr =
Array.init nb (fun i ->
@ -60,12 +59,9 @@ module Binary_format_rsa = struct
let pub_of_octets s =
let* arr = z_array_of_octets ~nb:2 s in
match arr with
| [| n; e |] ->
let+ pub = Mirage_rsa.pub ~n ~e |> unwrap_msg in
pub
| [| n; e |] -> Mirage_rsa.pub ~n ~e |> Result.map_error (fun (`Msg e) -> e)
| _ -> assert false
(* custom private key binary format <> than gcrypt *)
let priv_to_octets ({ e; d; n; p; q; dp; dq; q' } : Mirage_rsa.priv) =
z_array_to_octets [| e; d; n; p; q; dp; dq; q' |]
@ -73,8 +69,8 @@ module Binary_format_rsa = struct
let* arr = z_array_of_octets ~nb:8 s in
match arr with
| [| e; d; n; p; q; dp; dq; q' |] ->
let+ priv = Mirage_rsa.priv ~e ~d ~n ~p ~q ~dp ~dq ~q' |> unwrap_msg in
priv
Mirage_rsa.priv ~e ~d ~n ~p ~q ~dp ~dq ~q'
|> Result.map_error (fun (`Msg e) -> e)
| _ -> assert false
end
@ -88,55 +84,48 @@ let generate ~bits () =
(priv, pub)
let pub_of_priv = Mirage_rsa.pub_of_priv
let priv_of_octets = Binary_format_rsa.priv_of_octets
let priv_to_octets = Binary_format_rsa.priv_to_octets
let pub_to_octets = Binary_format_rsa.pub_to_octets
let pub_of_octets = Binary_format_rsa.pub_of_octets
(* we use Bin.cstring because size of key (~bits) can change depending on section_name
we also have to b32 encode/decode our octets because of null-char
module Priv = struct
(* NOTE: custom Rsa.priv encoding, will not match GNUnet one *)
let priv_of_octets = RSA_BIN.priv_of_octets
let priv_to_octets = RSA_BIN.priv_to_octets
enforce all to be of the same size instead? *)
let priv_bin =
let priv_of_octets_exn s =
let res =
let* s = B32.decode s in
priv_of_octets s
in
match res with
| Error e -> Fmt.failwith "RSA private key decoding failure: %s." e
| Ok t -> t
in
let priv_to_octets t = priv_to_octets t |> B32.encode in
Bin.map Bin.cstring priv_of_octets_exn priv_to_octets
let pub_to_b32 t = B32.encode (pub_to_octets t)
let pub_of_b32 s =
let* s = B32.decode s in
let+ v = pub_of_octets s in
v
let pub_caqti =
Caqti_type.custom
~encode:(fun v -> Ok (pub_to_octets v))
~decode:(fun v -> pub_of_octets v)
Caqti_type.octets
let priv_jsont =
let priv_of_b32 s =
let* s = B32.decode s in
priv_of_octets s
in
let priv_to_b32 t = B32.encode (priv_to_octets t) in
Jsont.of_of_string ~kind:"RsaPrivateKey" priv_of_b32 ~enc:priv_to_b32
let pub_jsont =
Jsont.of_of_string ~kind:"RsaPublicKey" pub_of_b32 ~enc:pub_to_b32
let priv_to_b32 t = B32.encode (priv_to_octets t)
let priv_jsont =
Jsont.of_of_string ~kind:"RsaPrivateKey" priv_of_b32 ~enc:priv_to_b32
end
module Pub = struct
let pub_to_octets = RSA_BIN.pub_to_octets
let pub_of_octets = RSA_BIN.pub_of_octets
let pub_to_b32 t = B32.encode (pub_to_octets t)
let pub_of_b32 s =
let* s = B32.decode s in
pub_of_octets s
let pub_caqti =
Caqti_type.custom
~encode:(fun v -> Ok (pub_to_octets v))
~decode:pub_of_octets Caqti_type.octets
let pub_jsont =
Jsont.of_of_string ~kind:"RsaPublicKey" pub_of_b32 ~enc:pub_to_b32
end
include Priv
include Pub
let sig_jsont =
Jsont.of_of_string ~kind:"RsaSignature" B32.decode ~enc:B32.encode
(* ---- *)
(* WIP fdh-rsa
full-domain-hash RSA
based on libgnunetutil crypto_rsa.c *)
@ -212,11 +201,11 @@ let verify ~key (S s) ~msg =
let msg_fdh = rsa_full_domain_hash key msg in
let s1 = Z_extra.to_octets_be msg_fdh in
let s2 = Mirage_rsa.encrypt ~key s in
match Eqaf.equal s1 s2 with
| false -> Fmt.error "RSA signature verification failed"
| true -> Ok ()
if Eqaf.equal s1 s2 then Ok () else Error `Invalid_signature_rsa
(* decrypt <=> sign *)
let sign ~key bmsg : sig_ =
let sig_ = Mirage_rsa.decrypt ~crt_hardening:true ~key bmsg in
S sig_
let pp_pub ppf pub = Fmt.pf ppf "%s" (pub_to_b32 pub)

60
src/secmod_eddsa.ml
View file

@ -1,11 +1,7 @@
(* TODO
! use lock
schedule tasks
sign: check timestamps before signing *)
schedule tasks *)
(* IMPROVE
Bin encode/decode
- catch failure
- should use little-endian
list_issue_date: save timestamp of key generation
key validity period:
more checks + do not exceed lookahead
@ -53,15 +49,15 @@ let key_bin =
(* for sm_key only *)
let read_eddsa fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* data = Fat.read fs spath |> unwrap_msg in
let* priv = Eddsa.priv_of_octets data in
let* data = Fat.read fs spath in
let* priv = Eddsa.priv_of_octets data |> Result.map_error (fun e -> `Msg e) in
let pub = Eddsa.pub_of_priv priv in
Ok (priv, pub)
let write_eddsa fs spath priv =
Log.debug (fun m -> m "writing key file `%s`" spath);
let data = Eddsa.priv_to_octets priv in
Fat.write fs spath data |> unwrap_msg
Fat.write fs spath data
let key_spath k =
let sfn = String.sub (Eddsa.pub_to_b32 k.pub) 0 8 in
@ -69,26 +65,25 @@ let key_spath k =
let read_key fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* data = Fat.read fs spath |> unwrap_msg in
(* todo: catch failure *)
let k = Bin.decode key_bin data (ref 0) in
Ok k
let* s = Fat.read fs spath in
let+ k = Bbin.decode key_bin s in
k
let write_key fs k =
let spath = key_spath k in
Log.debug (fun m -> m "writing key file `%s`" spath);
let data = Bin.to_string key_bin k in
Fat.write fs spath data |> unwrap_msg
let* s = Bbin.encode key_bin k in
Fat.write fs spath s
let delete_file fs spath =
Log.debug (fun m -> m "delete key file `%s`" spath);
let+ () = Fat.remove fs spath |> unwrap_msg in
let+ () = Fat.remove fs spath in
()
let gen_key t1 t2 =
let priv, pub = Eddsa.generate () in
let k = { priv; pub; t1; t2 } in
Log.debug (fun m -> m "generated key `%s`" (Eddsa.pub_to_b32 pub));
Log.debug (fun m -> m "generated key `%a`" Eddsa.pp_pub pub);
k
let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
@ -123,10 +118,9 @@ let gen_additional_keys_until_lookahead ~now l =
let load fs =
let* () =
if Fat.exists fs Cfg.key_dir then Ok ()
else Fat.mkdir fs Cfg.key_dir |> unwrap_msg
if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir
in
let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in
let* l = Fat.ls fs Cfg.key_dir in
let l = List.map (fun entry -> Fat.Path.add Cfg.key_dir entry.Fat.name) l in
let l = List.filter (fun spath -> not @@ String.equal spath Cfg.sm_key) l in
let* keys = list_map (read_key fs) l in
@ -145,8 +139,7 @@ let init fs =
| Some t -> Ok t
| None ->
let sm_priv, sm_pub = Eddsa.generate () in
Log.debug (fun m ->
m "generated secmod key: `%s`" (Eddsa.pub_to_b32 sm_pub));
Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub);
let ht = Hashtbl.create 0xff in
let t = { fs; sm_priv; sm_pub; ht } in
let* () = write_eddsa fs Cfg.sm_key t.sm_priv in
@ -162,11 +155,21 @@ let init fs =
module Make (Fs : Fat.FS) = struct
let t =
match init Fs.t with
| Error e -> Fmt.failwith "secmod_eddsa initialization failure: %s." e
| Error e ->
Fmt.failwith "secmod_eddsa initialization failure: %a." Result.pp_err e
| Ok t -> t
let find pub =
Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found"
let find_exn pub =
Log.debug (fun m -> m "find_exn: `%a`" Eddsa.pp_pub pub);
match Hashtbl.find_opt t.ht pub with
| Some v -> v
| None ->
(* XXX ERR
either:
- we tried to sign with a key that is not ours
- key was revoked bywhile we were holding on it
- broken keyring state *)
Fmt.failwith "secmod_eddsa operation on unknown key"
let add t1 t2 =
let k = gen_key t1 t2 in
@ -175,7 +178,7 @@ module Make (Fs : Fat.FS) = struct
()
let delete pub =
let* k = find pub in
let k = find_exn pub in
Hashtbl.remove t.ht k.pub;
delete_file t.fs (key_spath k)
@ -192,13 +195,12 @@ module Make (Fs : Fat.FS) = struct
let sign_secmod s = Eddsa.sign ~key:t.sm_priv s
let sign pub s =
let+ k = find pub in
let data = Eddsa.sign ~key:k.priv s in
data
let k = find_exn pub in
Eddsa.sign ~key:k.priv s
(* delete and replace *)
let revoke pub =
let* k = find pub in
let k = find_exn pub in
let* () = delete pub in
let* () = add k.t1 k.t2 in
Ok ()

158
src/secmod_rsa.ml
View file

@ -6,41 +6,17 @@ module Log = (val Logs.src_log src : Logs.LOG)
open Syntax
open Time
module DenominationHash = Hash.DenominationHash
module Coin_config = struct
type t = {
name: string;
duration_withdraw: TimeRelative.t;
rsa_keysize: int;
}
let of_coin (coin : Config.Coin.t) =
{
name= coin.section_name;
duration_withdraw= coin.duration_withdraw;
rsa_keysize= coin.rsa_keysize;
}
end
module Coin = Config.Coin
module Cfg = struct
include Config.Exchange_secmod_rsa
let key_dir = "/RSA"
let sm_key = "/SM_RSA"
let coin_config_list = List.map Coin_config.of_coin Config.Coin.all_coins
let get_coin_config ~section_name =
coin_config_list
|> List.find_opt (fun (cfg : Coin_config.t) ->
String.equal cfg.name section_name)
|> function
| None ->
Fmt.failwith "secmod_rsa failure: section `%s` not found" section_name
| Some cfg -> cfg
end
type key = {
section_name: string;
coin: Coin.t;
priv: Rsa.priv;
pub: Rsa.pub;
h_pub: DenominationHash.t;
@ -55,16 +31,39 @@ type t = {
ht: (DenominationHash.t, key) Hashtbl.t;
}
let find_exn h_pub section_name =
Coin.all_coins
|> Iarray.find_opt (fun coin ->
String.equal section_name coin.Coin.section_name)
|> function
| Some coin -> coin
| None ->
Fmt.failwith
"Secmod_rsa denomination key loading failure on key `%a`: unknown \
section_name [%s]"
DenominationHash.pp h_pub section_name
(* ? enforce all to be of the same size instead *)
(* we use Bin.cstring + b32 binary encoding because
rsa keysize is not known and then we have to escape '\x00' *)
let rsa_private_key_bin =
let decode_exn o =
Rsa.priv_of_b32 o |> function Error e -> invalid_arg e | Ok v -> v
in
let encode o = Rsa.priv_to_b32 o in
Bin.map Bin.cstring decode_exn encode
let key_bin =
let open Bin in
record (fun t1 t2 section_name priv ->
let pub = Rsa.pub_of_priv priv in
let h_pub = DenominationHash.hash_of_rsa pub in
{ section_name; t1; t2; priv; pub; h_pub })
let h_pub = DenominationHash.hash pub in
let coin = find_exn h_pub section_name in
{ coin; t1; t2; priv; pub; h_pub })
|+ field TimeAbsolute.bin (fun t -> t.t1)
|+ field TimeAbsolute.bin (fun t -> t.t2)
|+ field cstring (fun t -> t.section_name)
|+ field Rsa.priv_bin (fun t -> t.priv)
|+ field cstring (fun t -> t.coin.section_name)
|+ field rsa_private_key_bin (fun t -> t.priv)
|> sealr
let key_spath k =
@ -73,61 +72,63 @@ let key_spath k =
let read_eddsa fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* data = Fat.read fs spath |> unwrap_msg in
let* priv = Eddsa.priv_of_octets data in
let* data = Fat.read fs spath in
let* priv = Eddsa.priv_of_octets data |> Result.map_error (fun e -> `Msg e) in
let pub = Eddsa.pub_of_priv priv in
Ok (priv, pub)
let write_eddsa fs spath priv =
Log.debug (fun m -> m "writing key file `%s`" spath);
let data = Eddsa.priv_to_octets priv in
Fat.write fs spath data |> unwrap_msg
Fat.write fs spath data
let read_key fs spath =
Log.debug (fun m -> m "reading key file `%s`" spath);
let* data = Fat.read fs spath |> unwrap_msg in
let k = Bin.decode key_bin data (ref 0) in
Ok k
let* s = Fat.read fs spath in
let+ k = Bbin.decode key_bin s in
k
let write_key fs k =
let spath = key_spath k in
Log.debug (fun m -> m "writing key file `%s`" spath);
let data = Bin.to_string key_bin k in
Fat.write fs spath data |> unwrap_msg
let* s = Bbin.encode key_bin k in
Fat.write fs spath s
let delete_file fs spath =
Log.debug (fun m -> m "delete key file `%s`" spath);
let+ () = Fat.remove fs spath |> unwrap_msg in
let+ () = Fat.remove fs spath in
()
(* -- *)
let gen_key cfg t1 t2 =
let priv, pub = Rsa.generate ~bits:cfg.Coin_config.rsa_keysize () in
let h_pub = DenominationHash.hash_of_rsa pub in
let k = { section_name= cfg.name; priv; pub; h_pub; t1; t2 } in
let gen_key coin t1 t2 =
let bits = coin.Coin.rsa_keysize in
let priv, pub = Rsa.generate ~bits () in
let h_pub = DenominationHash.hash pub in
let k = { coin; priv; pub; h_pub; t1; t2 } in
Log.debug (fun m ->
m "generated key %s `%s`" cfg.Coin_config.name
(DenominationHash.to_b32 k.h_pub));
m "generated key for coin [%s]: `%a`" coin.section_name
DenominationHash.pp k.h_pub);
k
let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l
let split_in_periodes (cfg : Coin_config.t) ~start ~end_ =
let split_in_periodes coin ~start ~end_ =
assert (start < end_);
let duration_withdraw = coin.Coin.duration_withdraw in
(* no overlap on first periode *)
let t1 = start in
let t2 = TimeAbsolute.add start cfg.duration_withdraw in
let t2 = TimeAbsolute.add start duration_withdraw in
let acc = [ (t1, t2) ] in
let start = t2 in
let rec go acc start end_ =
let t1 = TimeAbsolute.sub start Cfg.overlap_duration in
let t2 = TimeAbsolute.add start cfg.duration_withdraw in
let t2 = TimeAbsolute.add start duration_withdraw in
if t2 > end_ then acc else go ((t1, t2) :: acc) t2 end_
in
go acc start end_
let gen_additional_keys_until_lookahead cfg ~now l =
let gen_additional_keys_until_lookahead coin ~now l =
let start =
match List.rev (sort_keys l) with
| [] -> now
@ -136,16 +137,15 @@ let gen_additional_keys_until_lookahead cfg ~now l =
let end_ = TimeAbsolute.add now Cfg.lookahead_sign in
if TimeAbsolute.compare start end_ >= 0 then []
else
let periodes = split_in_periodes cfg ~start ~end_ in
let new_keys = List.map (fun (t1, t2) -> gen_key cfg t1 t2) periodes in
let periodes = split_in_periodes coin ~start ~end_ in
let new_keys = List.map (fun (t1, t2) -> gen_key coin t1 t2) periodes in
new_keys
let load fs =
let* () =
if Fat.exists fs Cfg.key_dir then Ok ()
else Fat.mkdir fs Cfg.key_dir |> unwrap_msg
if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir
in
let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in
let* l = Fat.ls fs Cfg.key_dir in
let l = List.map (fun entry -> Fat.Path.add Cfg.key_dir entry.Fat.name) l in
let l = List.filter (fun spath -> not @@ String.equal Cfg.sm_key spath) l in
let* keys = list_map (read_key fs) l in
@ -165,18 +165,22 @@ let init fs =
| Some t -> Ok t
| None ->
let sm_priv, sm_pub = Eddsa.generate () in
Log.debug (fun m ->
m "generated secmod key: `%s`" (Eddsa.pub_to_b32 sm_pub));
Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub);
let* () = write_eddsa fs Cfg.sm_key sm_priv in
let ht = Hashtbl.create 0xff in
Ok { fs; sm_priv; sm_pub; ht }
in
let all_keys = List.of_seq @@ Hashtbl.to_seq_values t.ht in
let new_keys_l =
Cfg.coin_config_list
|> List.map (fun (cfg : Coin_config.t) ->
let keys = List.filter (fun k -> k.section_name = cfg.name) all_keys in
gen_additional_keys_until_lookahead cfg ~now keys)
Coin.all_coins
|> Iarray.to_list
|> List.map (fun coin ->
let keys =
List.filter
(fun k -> String.equal coin.Coin.section_name k.coin.section_name)
all_keys
in
gen_additional_keys_until_lookahead coin ~now keys)
in
let new_keys = List.concat new_keys_l in
List.iter (fun k -> Hashtbl.replace t.ht k.h_pub k) new_keys;
@ -186,14 +190,18 @@ let init fs =
module Make (Fs : Fat.FS) = struct
let t =
match init Fs.t with
| Error e -> Fmt.failwith "secmod_rsa initialization failure: %s." e
| Error e ->
Fmt.failwith "secmod_rsa initialization failure: %a." Result.pp_err e
| Ok t -> t
let find h_pub =
Hashtbl.find_opt t.ht h_pub |> Option.to_result ~none:"key not found"
let find_exn h_pub =
Log.debug (fun m -> m "find_exn: `%a`" DenominationHash.pp h_pub);
match Hashtbl.find_opt t.ht h_pub with
| Some v -> v
| None -> Fmt.failwith "secmod_rsa operation on unknown key"
let delete h_pub =
let* k = find h_pub in
let k = find_exn h_pub in
Hashtbl.remove t.ht h_pub;
delete_file t.fs (key_spath k)
@ -204,8 +212,8 @@ module Make (Fs : Fat.FS) = struct
|> List.map (fun (h_pub, _k) -> h_pub)
|> list_iter delete
let add cfg t1 t2 =
let k = gen_key cfg t1 t2 in
let add coin t1 t2 =
let k = gen_key coin t1 t2 in
let+ () = write_key t.fs k in
Hashtbl.replace t.ht k.h_pub k;
()
@ -214,23 +222,17 @@ module Make (Fs : Fat.FS) = struct
let sign_secmod s = Eddsa.sign ~key:t.sm_priv s
let sign h_pub msg =
let+ k = find h_pub in
let data = Rsa.sign ~key:k.priv msg in
data
let k = find_exn h_pub in
Rsa.sign ~key:k.priv msg
let revoke h_pub =
Log.debug (fun m ->
m "revoke `%s`" (DenominationHash.to_octets h_pub |> B32.encode));
let* k = find h_pub in
Log.debug (fun m -> m "revoke `%a`" DenominationHash.pp h_pub);
let k = find_exn h_pub in
let* () = delete h_pub in
let cfg = Cfg.get_coin_config ~section_name:k.section_name in
let* () = add cfg k.t1 k.t2 in
let* () = add k.coin k.t1 k.t2 in
Ok ()
let conv =
fun { section_name; priv= _; pub; h_pub; t1; t2= _ } ->
(h_pub, (section_name, pub, t1))
let conv k = (k.h_pub, (k.coin, k.pub, k.t1))
let keys () = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv
let find_key pub = Hashtbl.find_opt t.ht pub |> Option.map conv
end

127
src/signatures.ml
View file

@ -51,8 +51,10 @@ let size_of_int32 = 4
module type BYTES = sig
type t
val of_octets : string -> (t, string) result
val to_octets : t -> string
val of_octets : string -> (t, string) result
val jsont : t Jsont.t
val caqti : t Caqti_type.t
val bin : t Bin.t
end
@ -61,13 +63,28 @@ module Bytes32 : BYTES = struct
type t = string
let to_octets = Fun.id
let of_octets s =
match String.length s = n with
| false -> Error "invalid bytes length"
| false -> Error "invalid bytes32 length"
| true -> Ok s
let to_octets = Fun.id
let bin = Bin.bytes n
let jsont =
let decode s = Result.bind (B32.decode s) of_octets in
let encode b = to_octets b |> B32.encode in
Jsont.of_of_string ~kind:"Bytes32" decode ~enc:encode
let caqti =
Caqti_type.custom
~encode:(fun v -> Ok (to_octets v))
~decode:of_octets Caqti_type.octets
let bin =
let of_octets_exn s =
of_octets s |> function Error e -> invalid_arg e | Ok t -> t
in
Bin.map (Bin.bytes n) of_octets_exn to_octets
end
module Bytes64 : BYTES = struct
@ -75,13 +92,28 @@ module Bytes64 : BYTES = struct
type t = string
let to_octets = Fun.id
let of_octets s =
match String.length s = n with
| false -> Error "invalid bytes length"
| false -> Error "invalid bytes64 length"
| true -> Ok s
let to_octets = Fun.id
let bin = Bin.bytes n
let jsont =
let decode s = Result.bind (B32.decode s) of_octets in
let encode b = to_octets b |> B32.encode in
Jsont.of_of_string ~kind:"Bytes64" decode ~enc:encode
let caqti =
Caqti_type.custom
~encode:(fun v -> Ok (to_octets v))
~decode:of_octets Caqti_type.octets
let bin =
let of_octets_exn s =
of_octets s |> function Error e -> invalid_arg e | Ok t -> t
in
Bin.map (Bin.bytes n) of_octets_exn to_octets
end
module TransferSecretP = Bytes64
@ -116,7 +148,6 @@ end
(* --- *)
(* EccSignaturePurpose *)
module Purpose = struct
type t = {
size: int32;
@ -140,7 +171,8 @@ module Purpose = struct
let open Bin in
match Size.of_value (Size.size_of (f dummy)) with
| Dynamic _ | Unknown ->
Fmt.failwith "size_of failure: size is not Static"
Fmt.failwith
"Signature Bin.t declaration, size_of failure: size is not Static"
| Static n -> n
in
fun code f -> make ~size:(get_size f) code |> f
@ -163,7 +195,7 @@ end) : sig
(* todo
- type for unknown/verified signatures? (nk/ok) *)
val verify : Eddsa.pub -> t -> r -> (unit, string) result
val verify : Eddsa.pub -> t -> r -> unit Result.t
val signf : (string -> Eddsa.sig_) -> r -> t
val jsont : t Jsont.t
val caqti : t Caqti_type.t
@ -175,6 +207,7 @@ end = struct
type r = R.r
type t = Eddsa.sig_
(* TODO exn *)
let to_string = Bin.to_string R.bin
let verify key t r = Eddsa.verify ~key t ~msg:(to_string r)
let signf f r = f (to_string r)
@ -191,7 +224,7 @@ module DenominationKeyAnnouncement = struct
(* purpose = TALER_SIGNATURE_SM_RSA_DENOMINATION_KEY *)
type r = {
h_denom_pub: DenominationHash.t;
h_section_name: Hash.H64_cstring.t;
h_section_name: H64_cstring.t;
anchor_time: Timestamp.t;
duration_withdraw: TimeRelative.t;
}
@ -206,7 +239,7 @@ module DenominationKeyAnnouncement = struct
{ h_denom_pub; h_section_name; anchor_time; duration_withdraw })
|+ Purpose.field purpose
|+ field DenominationHash.bin (fun t -> t.h_denom_pub)
|+ field Hash.H64_cstring.bin (fun t -> t.h_section_name)
|+ field H64_cstring.bin (fun t -> t.h_section_name)
|+ field Timestamp.bin (fun t -> t.anchor_time)
|+ field TimeRelative.bin (fun t -> t.duration_withdraw)
|> sealr
@ -376,7 +409,7 @@ module MasterAddAuditor = struct
type r = {
start_date: Timestamp.t;
auditor_pub: AuditorPublicKeyP.t;
h_auditor_url: Hash.H64_cstring.t;
h_auditor_url: H64_cstring.t;
}
let bin =
@ -387,7 +420,7 @@ module MasterAddAuditor = struct
|+ Purpose.field purpose
|+ field Timestamp.bin (fun t -> t.start_date)
|+ field AuditorPublicKeyP.bin (fun t -> t.auditor_pub)
|+ field Hash.H64_cstring.bin (fun t -> t.h_auditor_url)
|+ field H64_cstring.bin (fun t -> t.h_auditor_url)
|> sealr
end
@ -475,9 +508,9 @@ module MasterWireDetails = struct
(* purpose = TALER_SIGNATURE_MASTER_WIRE_DETAILS *)
type r = {
h_wire_details: FullPaytoHash.t;
h_conversion_url: Hash.H64_cstring.t;
h_credit_restrictions: Hash.H64_cstring.t;
h_debit_restrictions: Hash.H64_cstring.t;
h_conversion_url: H64_cstring.t;
h_credit_restrictions: H64_cstring.t;
h_debit_restrictions: H64_cstring.t;
}
let bin =
@ -499,9 +532,9 @@ module MasterWireDetails = struct
})
|+ Purpose.field purpose
|+ field FullPaytoHash.bin (fun t -> t.h_wire_details)
|+ field Hash.H64_cstring.bin (fun t -> t.h_conversion_url)
|+ field Hash.H64_cstring.bin (fun t -> t.h_credit_restrictions)
|+ field Hash.H64_cstring.bin (fun t -> t.h_debit_restrictions)
|+ field H64_cstring.bin (fun t -> t.h_conversion_url)
|+ field H64_cstring.bin (fun t -> t.h_credit_restrictions)
|+ field H64_cstring.bin (fun t -> t.h_debit_restrictions)
|> sealr
end
@ -514,9 +547,9 @@ module MasterAddWire = struct
type r = {
start_date: Timestamp.t;
h_wire: FullPaytoHash.t;
h_conversion_url: Hash.H64_cstring.t;
h_credit_restrictions: Hash.H64_cstring.t;
h_debit_restrictions: Hash.H64_cstring.t;
h_conversion_url: H64_cstring.t;
h_credit_restrictions: H64_cstring.t;
h_debit_restrictions: H64_cstring.t;
}
let bin =
@ -541,9 +574,9 @@ module MasterAddWire = struct
|+ Purpose.field _purpose
|+ field Timestamp.bin (fun t -> t.start_date)
|+ field FullPaytoHash.bin (fun t -> t.h_wire)
|+ field Hash.H64_cstring.bin (fun t -> t.h_conversion_url)
|+ field Hash.H64_cstring.bin (fun t -> t.h_credit_restrictions)
|+ field Hash.H64_cstring.bin (fun t -> t.h_debit_restrictions)
|+ field H64_cstring.bin (fun t -> t.h_conversion_url)
|+ field H64_cstring.bin (fun t -> t.h_credit_restrictions)
|+ field H64_cstring.bin (fun t -> t.h_debit_restrictions)
|> sealr
end
@ -578,7 +611,7 @@ module MasterDrainProfit = struct
wtid: WireTransferIdentifierRawP.t;
date: Timestamp.t;
amount: Amount.t;
h_section: Hash.H64_cstring.t;
h_section: H64_cstring.t;
h_payto: FullPaytoHash.t;
}
@ -591,7 +624,7 @@ module MasterDrainProfit = struct
|+ field WireTransferIdentifierRawP.bin (fun t -> t.wtid)
|+ field Timestamp.bin (fun t -> t.date)
|+ field Amount.bin (fun t -> t.amount)
|+ field Hash.H64_cstring.bin (fun t -> t.h_section)
|+ field H64_cstring.bin (fun t -> t.h_section)
|+ field FullPaytoHash.bin (fun t -> t.h_payto)
|> sealr
end
@ -605,7 +638,7 @@ module MasterAmlOfficerStatus = struct
type r = {
change_date: Timestamp.t;
officer_pub: AmlOfficerPublicKeyP.t;
h_officer_name: Hash.H64_cstring.t;
h_officer_name: H64_cstring.t;
is_active: int32;
}
@ -617,7 +650,7 @@ module MasterAmlOfficerStatus = struct
|+ Purpose.field _purpose
|+ field Timestamp.bin (fun t -> t.change_date)
|+ field AmlOfficerPublicKeyP.bin (fun t -> t.officer_pub)
|+ field Hash.H64_cstring.bin (fun t -> t.h_officer_name)
|+ field H64_cstring.bin (fun t -> t.h_officer_name)
|+ field beint32 (fun t -> t.is_active)
|> sealr
end
@ -634,7 +667,7 @@ module PartnerConfiguration = struct
end_date: Timestamp.t;
wad_frequency: TimeRelative.t;
wad_fee: Amount.t;
h_url: Hash.H64_cstring.t;
h_url: H64_cstring.t;
}
let bin =
@ -657,7 +690,7 @@ module PartnerConfiguration = struct
|+ field Timestamp.bin (fun t -> t.end_date)
|+ field TimeRelative.bin (fun t -> t.wad_frequency)
|+ field Amount.bin (fun t -> t.wad_fee)
|+ field Hash.H64_cstring.bin (fun t -> t.h_url)
|+ field H64_cstring.bin (fun t -> t.h_url)
|> sealr
end
@ -668,7 +701,7 @@ module WadPartnerSignature = struct
module R = struct
(* purpose = TALER_SIGNATURE_MASTER_PARTNER_DETAILS *)
type r = {
h_partner_base_url: Hash.H64_cstring.t;
h_partner_base_url: H64_cstring.t;
master_public_key: MasterPublicKeyP.t;
start_date: Timestamp.t;
end_date: Timestamp.t;
@ -699,7 +732,7 @@ module WadPartnerSignature = struct
wad_frequency;
})
|+ Purpose.field _purpose
|+ field Hash.H64_cstring.bin (fun t -> t.h_partner_base_url)
|+ field H64_cstring.bin (fun t -> t.h_partner_base_url)
|+ field MasterPublicKeyP.bin (fun t -> t.master_public_key)
|+ field Timestamp.bin (fun t -> t.start_date)
|+ field Timestamp.bin (fun t -> t.end_date)
@ -715,7 +748,7 @@ module MasterWireFee = struct
module R = struct
(* purpose = TALER_SIGNATURE_MASTER_WIRE_FEES *)
type r = {
h_wire_method: Hash.H64_cstring.t;
h_wire_method: H64_cstring.t;
start_date: Timestamp.t;
end_date: Timestamp.t;
wire_fee: Amount.t;
@ -729,7 +762,7 @@ module MasterWireFee = struct
(fun _purpose h_wire_method start_date end_date wire_fee closing_fee ->
{ h_wire_method; start_date; end_date; wire_fee; closing_fee })
|+ Purpose.field _purpose
|+ field Hash.H64_cstring.bin (fun t -> t.h_wire_method)
|+ field H64_cstring.bin (fun t -> t.h_wire_method)
|+ field Timestamp.bin (fun t -> t.start_date)
|+ field Timestamp.bin (fun t -> t.end_date)
|+ field Amount.bin (fun t -> t.wire_fee)
@ -744,7 +777,7 @@ module ExchangeKeyValidity = struct
module R = struct
(* purpose = TALER_SIGNATURE_AUDITOR_EXCHANGE_KEYS *)
type r = {
auditor_url_hash: Hash.H64_cstring.t;
auditor_url_hash: H64_cstring.t;
master: MasterPublicKeyP.t;
start: Timestamp.t;
expire_withdraw: Timestamp.t;
@ -789,7 +822,7 @@ module ExchangeKeyValidity = struct
denom_hash;
})
|+ Purpose.field _purpose
|+ field Hash.H64_cstring.bin (fun t -> t.auditor_url_hash)
|+ field H64_cstring.bin (fun t -> t.auditor_url_hash)
|+ field MasterPublicKeyP.bin (fun t -> t.master)
|+ field Timestamp.bin (fun t -> t.start)
|+ field Timestamp.bin (fun t -> t.expire_withdraw)
@ -898,7 +931,7 @@ module DepositRequest = struct
amount_with_fee: Amount.t;
deposit_fee: Amount.t;
merchant: MerchantPublicKeyP.t;
wallet_data_hash: Hash.H64_cstring.t;
wallet_data_hash: H64_cstring.t;
}
end
@ -961,7 +994,7 @@ module WireDepositData = struct
wire_fee: Amount.t;
merchant_pub: MerchantPublicKeyP.t;
h_wire: MerchantWireHash.t;
h_details: Hash.H64_cstring.t;
h_details: H64_cstring.t;
}
end
@ -1022,7 +1055,7 @@ end
module MerchantRefundConfirmation = struct
(* purpose = TALER_SIGNATURE_MERCHANT_REFUND_OK *)
(* Hash of the order ID (a string), hashed without the 0-termination. *)
type t = { h_order_id: Hash.H64_cstring.t }
type t = { h_order_id: H64_cstring.t }
end
module RecoupRequest = struct
@ -1147,7 +1180,7 @@ module PurseDepositSignature = struct
h_denom_pub: DenominationHash.t;
h_age_commitment: AgeCommitmentHash.t;
purse_pub: PursePublicKey.t;
h_exchange_base_url: Hash.H64_cstring.t;
h_exchange_base_url: H64_cstring.t;
}
end
@ -1214,7 +1247,7 @@ module WadDataSignature = struct
type t = {
wad_execution_time: Timestamp.t;
total_amount: Amount.t;
h_items: Hash.H64_cstring.t;
h_items: H64_cstring.t;
wad_id: WadId.t;
}
end
@ -1247,11 +1280,11 @@ end
module AmlDecision = struct
(* purpose = TALER_SIGNATURE_AML_DECISION *)
type t = {
h_justification: Hash.H64_cstring.t;
h_justification: H64_cstring.t;
decision_time: Timestamp.t;
new_threshold: Amount.t;
h_payto: NormalizedPaytoHash.t;
h_kyc_requirements: Hash.H64_cstring.t;
h_kyc_requirements: H64_cstring.t;
new_state: int;
}
end
@ -1278,7 +1311,7 @@ module ReserveAttestRequest = struct
(* purpose = TALER_SIGNATURE_WALLET_ATTEST_REQUEST *)
type t = {
request_timestamp: Timestamp.t;
h_details: Hash.H64_cstring.t;
h_details: H64_cstring.t;
}
end
@ -1288,6 +1321,6 @@ module ExchangeAttest = struct
attest_timestamp: Timestamp.t;
expiration_time: Timestamp.t;
reserve_pub: ReservePublicKeyP.t;
h_attributes: Hash.H64_cstring.t;
h_attributes: H64_cstring.t;
}
end

9
src/syntax.ml
View file

@ -1,15 +1,6 @@
let ( let* ) o f = match o with Ok v -> f v | Error _ as e -> e
let ( let+ ) o f = match o with Ok v -> Ok (f v) | Error _ as e -> e
(* TODO better errors
use polymorphic variant for errors
use GANA error codes:
https://git.gnunet.org/gana.git/tree/gnu-taler-error-codes/registry.rec *)
let unwrap_msg o = match o with Error (`Msg e) -> Error e | Ok v -> Ok v
let unwrap_caqti o =
match o with Error err -> Fmt.error "%a" Caqti_error.pp err | Ok v -> Ok v
let list_iter f l =
let err = ref None in
try

6
src/time.mli
View file

@ -14,8 +14,6 @@ module TimeRelative : sig
val bin : t Bin.t
val caqti : t Caqti_type.t
val jsont : t Jsont.t
(* TODO rename pp_dump *)
val pp : Format.formatter -> t -> unit
end
@ -33,8 +31,6 @@ module TimeAbsolute : sig
val of_s : int64 -> t
val of_ptime : Ptime.t -> t
val bin : t Bin.t
(* TODO rename pp_dump *)
val pp : Format.formatter -> t -> unit
end
@ -59,7 +55,5 @@ module Timestamp : sig
val bin : t Bin.t
val caqti : t Caqti_type.t
val jsont : t Jsont.t
(* TODO rename pp_dump *)
val pp : Format.formatter -> t -> unit
end

3
test/management.sh
View file

@ -112,9 +112,6 @@ mte-offline-tool drain \
mte-offline-tool upload --input $b --url $url"/management/drain"
echo "[OK] /management/drain"
demo_keys="test/keys.demo.taler.net.v31_0_9.json"
mte-validate keys $demo_keys
echo "[OK] exchange.demo.taler.net/keys validation"
mte-offline-tool download --output $a --url $url"/keys"
mte-validate keys $a
echo "[OK] /keys validation"

13
test/test.ml
View file

@ -16,9 +16,9 @@ let test_eddsa () =
let open Eddsa in
let priv, pub = generate () in
let priv' = priv |> priv_to_octets |> priv_of_octets |> get_ok in
assert (priv_to_octets priv = priv_to_octets priv');
assert (priv = priv');
let pub' = pub |> pub_to_octets |> pub_of_octets |> get_ok in
assert (pub_to_octets pub = pub_to_octets pub');
assert (pub = pub');
()
let test_rsa () =
@ -53,9 +53,7 @@ let test_json () =
let test_amount () =
let open Amount in
let v =
make ~sign:(Some Sign_plus) ~currency:"KUDOS" ~value:(Int64.of_int 25)
~fraction:(Int32.of_int 678)
|> get_ok
make (Some Sign_plus) "KUDOS" (Int64.of_int 25) (Int32.of_int 678) |> get_ok
in
let v' = v |> to_string |> of_string |> get_ok in
assert (v = v');
@ -86,8 +84,7 @@ module Test_crypto = struct
|> Eddsa.priv_of_octets
|> get_ok
|> Eddsa.pub_of_priv
|> Eddsa.pub_to_octets
|> encode
|> Eddsa.pub_to_b32
in
assert (pub = pub')
@ -174,7 +171,7 @@ module Test_crypto = struct
rsa_pub
|> Rsa.pub_of_b32
|> get_ok
|> DenominationHash.hash_of_rsa
|> DenominationHash.hash
|> DenominationHash.to_b32
in
assert (h_pub' = h_pub)

18
test/validate.ml
View file

@ -1,7 +1,6 @@
open Syntax
open Hash
let keys content =
let open Syntax in
let open Hash in
let open Api in
let open ExchangeKeysResponse in
let* v = Api.decode jsont content in
@ -10,7 +9,7 @@ let keys content =
Libtool_version.is_compatible
~implementation:Libtool_version.mte_protocol_version v.version
then Ok ()
else Fmt.error "version incompatible"
else Fmt.error_msg "incompatible version"
in
(* TODO json hash
@ -51,7 +50,7 @@ let keys content =
let* () =
let opt = List.find_opt (fun sk -> sk.Signkey.pub = v.exchange_pub) sk_l in
match opt with
| None -> Fmt.error "exchange_pub is not in signkeys list"
| None -> Fmt.error_msg "exchange_pub is not in signkeys list"
| Some _sk ->
(* todo add a --now option if we want to validate timestamps
let now = Timestamp.of_ptime (Ptime_clock.now ()) in
@ -95,7 +94,7 @@ let keys content =
let open Denomination in
denom_l |> List.find_opt (fun dn -> dn.h_pub = denom_pub_h)
|> function
| None -> Fmt.error "auditor denomination key not found"
| None -> Fmt.error_msg "auditor denomination key not found"
| Some dn ->
let open Signatures.ExchangeKeyValidity in
verify auditor_pub auditor_sig
@ -129,9 +128,10 @@ let keys_cmd =
Cmd.make (Cmd.info "keys" ~doc)
@@
let+ file = file in
let* content =
Result.bind (Fpath.of_string file) Bos.OS.File.read |> unwrap_msg
in
let open Syntax in
Result.unwrap_err
@@
let* content = Bos.OS.File.read (Fpath.v file) in
keys content
let cli =

27
tools/offline.ml
View file

@ -43,30 +43,29 @@ module Arg = struct
in
Arg.Conv.make ~docv:"relative time argument" ~parser ~pp ()
let amount =
Arg.Conv.make ~docv:"amount argument" ~parser:Amount.of_string ~pp:Amount.pp
()
let b32 =
let pp fmt v = Fmt.pf fmt "%s" (B32.encode v) in
Arg.Conv.make ~docv:"Crockford's Base32 encoded argument" ~parser:B32.decode
~pp ()
let amount =
Arg.Conv.make ~docv:"amount argument" ~parser:Amount.of_string ~pp:Amount.pp
()
let eddsa_pub =
let parser s = Eddsa.pub_of_b32 s in
let pp fmt key =
let s = Eddsa.pub_to_b32 key in
Fmt.pf fmt "%s" s
in
Arg.Conv.make ~docv:"eddsa public key argument" ~parser ~pp ()
Arg.Conv.make ~docv:"eddsa public key argument" ~parser:Eddsa.pub_of_b32 ~pp
()
let rsa_pub =
let parser s = Rsa.pub_of_b32 s in
let pp fmt key =
let s = Rsa.pub_to_b32 key in
Fmt.pf fmt "%s" s
in
Arg.Conv.make ~docv:"rsa public key argument" ~parser ~pp ()
Arg.Conv.make ~docv:"rsa public key argument" ~parser:Rsa.pub_of_b32 ~pp ()
end
let master_key =
@ -151,10 +150,8 @@ let compute_denomination_hash_cmd =
Cmd.make (Cmd.info "compute-denomination-hash" ~doc)
@@
let+ rsa_pub = rsa_pub in
rsa_pub
|> Hash.DenominationHash.hash_of_rsa
|> Hash.DenominationHash.to_b32
|> Fmt.pr "%s@.";
let open Hash.DenominationHash in
Fmt.pr "%a@." pp (hash rsa_pub);
Ok ()
let revoke_signkey_cmd =
@ -322,11 +319,11 @@ let drain_cmd =
and+ master_key = master_key
and+ debit_account_section = debit_account_section
and+ credit_payto_uri = credit_payto_uri
and+ wtid = wtid
and+ wtid_octets = wtid
and+ date = date
and+ amount = amount in
drain ~output ~master_key ~debit_account_section ~credit_payto_uri ~wtid ~date
~amount
drain ~output ~master_key ~debit_account_section ~credit_payto_uri
~wtid_octets ~date ~amount
let cli =
let info =

103
tools/offline_impl.ml
View file

@ -2,6 +2,8 @@ open Syntax
open Time
open Hash
let () = Mirage_crypto_rng_unix.use_default ()
let now_s () =
let ns = Mtime_clock.now_ns () in
Int64.unsigned_div ns 1_000_000_000L
@ -37,7 +39,7 @@ module Future_keys = struct
let rsa_pub =
match denom_pub with DenominationKey.Rsa denom -> denom.rsa_pub
in
let h_denom_pub = DenominationHash.hash_of_rsa rsa_pub in
let h_denom_pub = DenominationHash.hash rsa_pub in
let h_section_name = H64_cstring.hash section_name in
let anchor_time = stamp_start in
let duration_withdraw =
@ -60,7 +62,7 @@ module Future_keys = struct
let* () =
match master_pub = offline_master_public_key with
| false ->
Fmt.error
Fmt.error_msg
"master public key of the future key response does not match ours"
| true -> Ok ()
in
@ -104,7 +106,7 @@ module Future_keys = struct
let rsa_pub =
match denom_pub with DenominationKey.Rsa denom -> denom.rsa_pub
in
let h_denom_pub = DenominationHash.hash_of_rsa rsa_pub in
let h_denom_pub = DenominationHash.hash rsa_pub in
let master_sig =
let open Signatures.DenominationKeyValidity in
let master = Eddsa.pub_of_priv master_key in
@ -149,16 +151,20 @@ end
(* -- *)
let read_file fname = Bos.OS.File.read (Fpath.v fname) |> unwrap_msg
let read_file fname = Bos.OS.File.read (Fpath.v fname)
let write_file fname content = Bos.OS.File.write (Fpath.v fname) content
let write_file fname content =
Bos.OS.File.write (Fpath.v fname) content |> unwrap_msg
let write_json_file fname jsont v =
let* content = Api.encode jsont v in
write_file fname content
let read_master_key_file filename =
let* master_key = read_file filename in
Eddsa.priv_of_octets master_key
Eddsa.priv_of_octets master_key |> Result.map_error (fun e -> `Bin_decode e)
let download ~output ~url =
Result.unwrap_err
@@
let open Bos in
OS.Cmd.run
Cmd.(
@ -171,9 +177,10 @@ let download ~output ~url =
% "-X"
% "GET"
% url)
|> unwrap_msg
let upload ~input ~url =
Result.unwrap_err
@@
let open Bos in
OS.Cmd.run
Cmd.(
@ -189,31 +196,35 @@ let upload ~input ~url =
% "--data"
% ("@" ^ input)
% url)
|> unwrap_msg
let setup ~output ~output_pubkey =
Mirage_crypto_rng_unix.use_default ();
Result.unwrap_err
@@
let priv, pub = Mirage_crypto_ec.Ed25519.generate () in
let priv_data = Mirage_crypto_ec.Ed25519.priv_to_octets priv in
let* () = write_file output priv_data in
let pub_data = Mirage_crypto_ec.Ed25519.pub_to_octets pub |> B32.encode in
let* () = write_file output priv_data in
let* () = write_file output_pubkey pub_data in
Ok ()
let sign ~master_key ~input ~output =
Result.unwrap_err
@@
let* master_key = read_master_key_file master_key in
let* input = read_file input in
let master_pub = Eddsa.pub_of_priv master_key in
let* future_keys_response = Api.decode Api.FutureKeysResponse.jsont input in
let* () = Future_keys.verify master_pub future_keys_response in
let master_signatures = Future_keys.make ~master_key future_keys_response in
let* s = Api.encode Api.MasterSignatures.jsont master_signatures in
let* () = write_file output s in
Ok ()
write_json_file output Api.MasterSignatures.jsont master_signatures
let revoke_denom ~output ~master_key ~h_denom =
Result.unwrap_err
@@
let* key = read_master_key_file master_key in
let* h_denom_pub = DenominationHash.of_b32 h_denom in
let* h_denom_pub =
DenominationHash.of_b32 h_denom |> Result.map_error (fun e -> `Msg e)
in
let denom_revoke =
let master_sig =
let open Signatures.MasterDenominationKeyRevocation in
@ -221,11 +232,11 @@ let revoke_denom ~output ~master_key ~h_denom =
in
Api.DenomRevocationSignature.{ master_sig }
in
let* s = Api.encode Api.DenomRevocationSignature.jsont denom_revoke in
let* () = write_file output s in
Ok ()
write_json_file output Api.DenomRevocationSignature.jsont denom_revoke
let revoke_signkey ~output ~master_key ~signkey =
Result.unwrap_err
@@
let* key = read_master_key_file master_key in
let signkey_revoke =
let master_sig =
@ -234,20 +245,20 @@ let revoke_signkey ~output ~master_key ~signkey =
in
Api.SignkeyRevocationSignature.{ master_sig }
in
let* s = Api.encode Api.SignkeyRevocationSignature.jsont signkey_revoke in
let* () = write_file output s in
Ok ()
write_json_file output Api.SignkeyRevocationSignature.jsont signkey_revoke
let global_fees ~output ~master_key ~start_date ~end_date ~history_fee
~account_fee ~purse_fee ~history_expiration ~purse_account_limit
~purse_timeout =
Result.unwrap_err
@@
let* key = read_master_key_file master_key in
let* purse_account_limit =
match
purse_account_limit >= 0
&& purse_account_limit <= Int32.to_int Int32.max_int
with
| false -> Error "invalid purse_account_limit value"
| false -> Fmt.error_msg "invalid purse_account_limit value"
| true -> Ok (Int32.of_int purse_account_limit)
in
let master_sig =
@ -278,11 +289,11 @@ let global_fees ~output ~master_key ~start_date ~end_date ~history_fee
master_sig;
}
in
let* s = Api.encode Api.GlobalFees.jsont global_fees in
let* () = write_file output s in
Ok ()
write_json_file output Api.GlobalFees.jsont global_fees
let enable_auditor ~output ~master_key ~auditor_url ~auditor_name ~auditor_pub =
Result.unwrap_err
@@
let* key = read_master_key_file master_key in
let validity_start = Timestamp.of_s (now_s ()) in
let master_sig =
@ -298,11 +309,11 @@ let enable_auditor ~output ~master_key ~auditor_url ~auditor_name ~auditor_pub =
Api.AuditorSetupMessage.
{ auditor_url; auditor_name; auditor_pub; master_sig; validity_start }
in
let* s = Api.encode Api.AuditorSetupMessage.jsont v in
let* () = write_file output s in
Ok ()
write_json_file output Api.AuditorSetupMessage.jsont v
let disable_auditor ~output ~master_key ~auditor_pub =
Result.unwrap_err
@@
let* key = read_master_key_file master_key in
let validity_end = TimeAbsolute.of_s (now_s ()) in
(* hack for tests: +1sec to be sure it overwrite previous timestamp *)
@ -314,12 +325,12 @@ let disable_auditor ~output ~master_key ~auditor_pub =
signf (Eddsa.sign ~key) { end_date= validity_end; auditor_pub }
in
let v = Api.AuditorTeardownMessage.{ master_sig; validity_end } in
let* s = Api.encode Api.AuditorTeardownMessage.jsont v in
let* () = write_file output s in
Ok ()
write_json_file output Api.AuditorTeardownMessage.jsont v
let wire_fee ~output ~master_key ~wire_method ~fee_start ~fee_end ~closing_fee
~wire_fee =
Result.unwrap_err
@@
let* key = read_master_key_file master_key in
let master_sig_wire =
let open Signatures.MasterWireFee in
@ -343,11 +354,11 @@ let wire_fee ~output ~master_key ~wire_method ~fee_start ~fee_end ~closing_fee
master_sig_wire;
}
in
let* s = Api.encode Api.WireFeeSetupMessage.jsont v in
let* () = write_file output s in
Ok ()
write_json_file output Api.WireFeeSetupMessage.jsont v
let enable_wire ~output ~master_key ~payto_uri ~bank_label ~priority =
Result.unwrap_err
@@
(* TODO wire *)
let conversion_url = None in
let credit_restrictions = [] in
@ -396,11 +407,11 @@ let enable_wire ~output ~master_key ~payto_uri ~bank_label ~priority =
priority;
}
in
let* s = Api.encode Api.WireSetupMessage.jsont v in
let* () = write_file output s in
Ok ()
write_json_file output Api.WireSetupMessage.jsont v
let disable_wire ~output ~master_key ~payto_uri =
Result.unwrap_err
@@
let* key = read_master_key_file master_key in
let validity_end = TimeAbsolute.of_s (now_s ()) in
(* hack for tests: +1sec to be sure it overwrite previous timestamp *)
@ -413,14 +424,16 @@ let disable_wire ~output ~master_key ~payto_uri =
signf (Eddsa.sign ~key) { end_date= validity_end; h_wire }
in
let v = Api.WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } in
let* s = Api.encode Api.WireTeardownMessage.jsont v in
let* () = write_file output s in
Ok ()
write_json_file output Api.WireTeardownMessage.jsont v
let drain ~output ~master_key ~debit_account_section ~credit_payto_uri ~wtid
~date ~amount =
let drain ~output ~master_key ~debit_account_section ~credit_payto_uri
~wtid_octets ~date ~amount =
Result.unwrap_err
@@
let* key = read_master_key_file master_key in
let* wtid = Api.Bytes32.of_octets wtid in
let* wtid =
Api.Bytes32.of_octets wtid_octets |> Result.map_error (fun e -> `Msg e)
in
let master_sig =
let open Signatures.MasterDrainProfit in
signf (Eddsa.sign ~key)
@ -443,6 +456,4 @@ let drain ~output ~master_key ~debit_account_section ~credit_payto_uri ~wtid
amount;
}
in
let* s = Api.encode Api.DrainProfitsMessage.jsont v in
let* () = write_file output s in
Ok ()
write_json_file output Api.DrainProfitsMessage.jsont v