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

~~~

Browse source
This commit is contained in:
swrup 2025-12-03 16:19:11 +01:00 • committed by Swrup
parent 099cd80670
commit b507d540ad
43 changed files with 5647 additions and 1808 deletions
Download patch file Download diff file Expand all files Collapse all files

6
.gitignore vendored
View file

@ -1,5 +1,3 @@
_build _build
data/secmod/*
# default output files of offline-tool !data/secmod/.gitkeep
response.json
request.json

1
data/assets/default.config
View file

@ -27,6 +27,7 @@ max_keys_caching = "4 weeks"
enable_kyc = NO enable_kyc = NO
terms_etag = "0" terms_etag = "0"
privacy_etag = "0" privacy_etag = "0"
base_url = localhost
[exchangedb] [exchangedb]
idle_reserve_expiration_time = "1 year 2 weeks 3 hours 4 minutes 5 seconds" idle_reserve_expiration_time = "1 year 2 weeks 3 hours 4 minutes 5 seconds"

1
data/auditor_private_key Normal file
View file

@ -0,0 +1 @@
Iî÷q¸àwÇ´Y—›gbÙ'R+5µ™â°ƒˆyë>

1
data/auditor_public_key Normal file
View file

@ -0,0 +1 @@
A17JXR3E6J4CXDPYT7S1H25PGJ3ABS26TQ38654QCX0TB59RPMF0====

0
data/secmod_denom/.gitkeep → data/secmod/.gitkeep
View file

0
data/secmod_signkey/.gitkeep
View file

2
src/amount.ml
View file

@ -117,3 +117,5 @@ let bin_nbo =
|+ field beint32 (fun t -> t.fraction) |+ field beint32 (fun t -> t.fraction)
|+ field (bytes currency_len) (fun t -> pad_currency t.currency) |+ field (bytes currency_len) (fun t -> pad_currency t.currency)
|> sealr |> sealr
let dummy_value = "DUMMY:0.0" |> of_string |> Result.get_ok

7
src/amount.mli
View file

@ -1,3 +1,6 @@
(* TODO
? have a currency agnostic amount_lib.ml and specialize amount.ml to Config.currency *)
type sign = type sign =
| Sign_plus | Sign_plus
| Sign_minus | Sign_minus
@ -25,3 +28,7 @@ val jsont : t Jsont.t
(* only for encoding *) (* only for encoding *)
val bin : t Bin.t val bin : t Bin.t
val bin_nbo : t Bin.t val bin_nbo : t Bin.t
(* TODO
dummy value to use as placeholder for WIP *)
val dummy_value : t

1230
src/api.ml
View file

File diff suppressed because it is too large Load diff

1243
src/bin_sig.ml Normal file
View file

File diff suppressed because it is too large Load diff

801
src/bin_signature.ml
View file

@ -1,801 +0,0 @@
(* Packed Signature *)
open Bin_type
open Bin_type.Aliases
(* EccSignaturePurpose *)
module Purpose = struct
type t = {
size: int32;
purpose: int32;
}
let bin =
let open Bin in
record (fun size purpose -> { size; purpose })
|+ field beint32 (fun t -> t.size)
|+ field beint32 (fun t -> t.purpose)
|> sealr
let make ~size purpose = { size= Int32.of_int size; purpose }
let dummy = make ~size:0 0_l
(* helper function to make ['signature Bin.t]
to compute [t.size], we first build a bin with a dummy purpose *)
let make_bin =
let get_size f =
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"
| Static n -> n
in
fun code f -> make ~size:(get_size f) code |> f
let field purpose = Bin.field bin (fun _t -> purpose)
end
module WithdrawRequestPS = struct
(* Purpose is #TALER_SIGNATURE_WALLET_RESERVE_WITHDRAW *)
type t = {
amount: Amount.t;
fee: Amount.t;
h_planchets: HashPlanchetsP.t;
blinding_seed: BlindingMasterSecret.t;
max_age_group: int32;
mask: AgeMask.t;
}
let bin =
let open Bin in
Purpose.make_bin Taler_signatures.wallet_reserve_withdraw @@ fun purpose ->
record
(fun _purpose amount fee h_planchets blinding_seed max_age_group mask ->
{ amount; fee; h_planchets; blinding_seed; max_age_group; mask })
|+ Purpose.field purpose
|+ field Amount.bin (fun t -> t.amount)
|+ field Amount.bin (fun t -> t.fee)
|+ field HashPlanchetsP.bin (fun t -> t.h_planchets)
|+ field BlindingMasterSecret.bin (fun t -> t.blinding_seed)
|+ field beint32 (fun t -> t.max_age_group)
|+ field AgeMask.bin (fun t -> t.mask)
|> sealr
end
module WithdrawConfirmationPS = struct
(* Purpose is #TALER_SIGNATURE_EXCHANGE_CONFIRM_WITHDRAW.
Signed by a `struct TALER_ExchangePrivateKeyP` using EdDSA. *)
type t = {
(* TODO TALER doc
missing TALER_HashBlindedPlanchetsP*)
h_planchets: HashPlanchetsP.t;
noreveal_index: int32;
}
let bin =
let open Bin in
Purpose.make_bin Taler_signatures.exchange_confirm_withdraw
@@ fun purpose ->
record (fun _purpose h_planchets noreveal_index ->
{ h_planchets; noreveal_index })
|+ Purpose.field purpose
|+ field HashPlanchetsP.bin (fun t -> t.h_planchets)
|+ field beint32 (fun t -> t.noreveal_index)
|> sealr
end
module DenominationKeyAnnouncementPS = struct
(* TODO taler_signatures purpose
we use TALER_SIGNATURE_SM_RSA_DENOMINATION_KEY instead here *)
(* purpose.purpose = TALER_SIGNATURE_SM_DENOMINATION_KEY *)
type r = {
h_denom_pub: DenominationHash.t;
h_section_name: Hash_64_cstr.t;
anchor_time: TimeAbsoluteNBO.t;
duration_withdraw: TimeRelativeNBO.t;
}
let bin =
let open Bin in
Purpose.make_bin Taler_signatures.sm_rsa_denomination_key @@ fun purpose ->
record
(fun _purpose h_denom_pub h_section_name anchor_time duration_withdraw ->
{ h_denom_pub; h_section_name; anchor_time; duration_withdraw })
|+ Purpose.field purpose
|+ field DenominationHash.bin (fun t -> t.h_denom_pub)
|+ field Hash_64_cstr.bin (fun t -> t.h_section_name)
|+ field TimeAbsoluteNBO.bin (fun t -> t.anchor_time)
|+ field TimeRelativeNBO.bin (fun t -> t.duration_withdraw)
|> sealr
module type SIG = sig
type t
val sign : (string -> string) -> r -> t
val verify : (string -> msg:string -> bool) -> t -> r -> bool
val jsont : t Jsont.t
end
module Sig : SIG = struct
type t = string
let sign f r = f @@ Bin.to_string bin r
let verify f s r = f s ~msg:(Bin.to_string bin r)
(* TODO B32.jsont, for others types too *)
let jsont = Jsont.string
end
end
module SigningKeyAnnouncementPS = struct
(* purpose.purpose = TALER_SIGNATURE_SM_SIGNING_KEY *)
type t = {
exchange_pub: ExchangePublicKeyP.t;
anchor_time: TimeAbsoluteNBO.t;
duration: TimeRelativeNBO.t;
}
let bin =
let open Bin in
Purpose.make_bin Taler_signatures.sm_signing_key @@ fun purpose ->
record (fun _purpose exchange_pub anchor_time duration ->
{ exchange_pub; anchor_time; duration })
|+ Purpose.field purpose
|+ field ExchangePublicKeyP.bin (fun t -> t.exchange_pub)
|+ field TimeAbsoluteNBO.bin (fun t -> t.anchor_time)
|+ field TimeRelativeNBO.bin (fun t -> t.duration)
|> sealr
end
module DenominationKeyValidityPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_DENOMINATION_KEY_VALIDITY *)
type t = {
master: MasterPublicKeyP.t;
start: TimeAbsoluteNBO.t;
expire_withdraw: TimeAbsoluteNBO.t;
expire_spend: TimeAbsoluteNBO.t;
expire_legal: TimeAbsoluteNBO.t;
value: AmountNBO.t;
fee_withdraw: AmountNBO.t;
fee_deposit: AmountNBO.t;
fee_refresh: AmountNBO.t;
denom_hash: DenominationHash.t;
}
let bin =
let open Bin in
Purpose.make_bin Taler_signatures.master_denomination_key_validity
@@ fun purpose ->
record
(fun
_purpose
master
start
expire_withdraw
expire_spend
expire_legal
value
fee_withdraw
fee_deposit
fee_refresh
denom_hash
->
{
master;
start;
expire_withdraw;
expire_spend;
expire_legal;
value;
fee_withdraw;
fee_deposit;
fee_refresh;
denom_hash;
})
|+ Purpose.field purpose
|+ field MasterPublicKeyP.bin (fun t -> t.master)
|+ field TimeAbsoluteNBO.bin (fun t -> t.start)
|+ field TimeAbsoluteNBO.bin (fun t -> t.expire_withdraw)
|+ field TimeAbsoluteNBO.bin (fun t -> t.expire_spend)
|+ field TimeAbsoluteNBO.bin (fun t -> t.expire_legal)
|+ field AmountNBO.bin (fun t -> t.value)
|+ field AmountNBO.bin (fun t -> t.fee_withdraw)
|+ field AmountNBO.bin (fun t -> t.fee_deposit)
|+ field AmountNBO.bin (fun t -> t.fee_refresh)
|+ field DenominationHash.bin (fun t -> t.denom_hash)
|> sealr
end
module ExchangeSigningKeyValidityPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_SIGNING_KEY_VALIDITY *)
type t = {
start: TimeAbsoluteNBO.t;
expire: TimeAbsoluteNBO.t;
end_: TimeAbsoluteNBO.t; (* "end" renamed to end_ *)
signkey_pub: ExchangePublicKeyP.t;
}
let bin =
let open Bin in
Purpose.make_bin Taler_signatures.master_signing_key_validity
@@ fun purpose ->
record (fun _purpose start expire end_ signkey_pub ->
{ start; expire; end_; signkey_pub })
|+ Purpose.field purpose
|+ field TimeAbsoluteNBO.bin (fun t -> t.start)
|+ field TimeAbsoluteNBO.bin (fun t -> t.expire)
|+ field TimeAbsoluteNBO.bin (fun t -> t.end_)
|+ field ExchangePublicKeyP.bin (fun t -> t.signkey_pub)
|> sealr
end
(* ### BIN IMPL END ### *)
module SingleWithdrawRequestPS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_RESERVE_WITHDRAW *)
type t = {
amount_with_fee: AmountNBO.t;
h_denomination_pub: DenominationHash.t;
h_coin_envelope: BlindedCoinHash.t;
}
end
module DepositRequestPS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_COIN_DEPOSIT *)
type t = {
h_contract_terms: PrivateContractHash.t;
h_age_commitment: AgeCommitmentHash.t;
h_policy: ExtensionsPolicyHash.t;
h_wire: MerchantWireHash.t;
h_denom_pub: DenominationHash.t;
timestamp: TimeAbsoluteNBO.t;
refund_deadline: TimeAbsoluteNBO.t;
amount_with_fee: AmountNBO.t;
deposit_fee: AmountNBO.t;
merchant: MerchantPublicKeyP.t;
wallet_data_hash: Hash_64_cstr.t;
}
end
module DepositConfirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_CONFIRM_DEPOSIT *)
type t = {
h_contract_terms: PrivateContractHash.t;
h_wire: MerchantWireHash.t;
h_policy: ExtensionsPolicyHash.t;
timestamp: TimeAbsoluteNBO.t;
refund_deadline: TimeAbsoluteNBO.t;
amount_without_fee: AmountNBO.t;
coin_pub: CoinSpendPublicKeyP.t;
merchant: MerchantPublicKeyP.t;
}
end
module RefreshMeltCoinAffirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_COIN_MELT *)
type t = {
session_hash: RefreshCommitmentP.t;
h_denom_pub: DenominationHash.t;
h_age_commitment: AgeCommitmentHash.t;
amount_with_fee: AmountNBO.t;
melt_fee: AmountNBO.t;
}
end
module RefreshMeltConfirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_CONFIRM_MELT *)
type t = {
session_hash: RefreshCommitmentP.t;
noreveal_index: int; (* uint16_t mapped to OCaml int *)
}
end
module ExchangeKeySetPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_KEY_SET *)
type t = {
list_issue_date: TimeAbsoluteNBO.t;
hc: Hash_64_cstr.t;
}
end
module MasterWireDetailsPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_WIRE_DETAILS *)
type t = {
h_wire_details: FullPaytoHash.t;
h_conversion_url: Hash_64_cstr.t;
h_credit_restrictions: Hash_64_cstr.t;
h_debit_restrictions: Hash_64_cstr.t;
}
end
module MasterWireFeePS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_WIRE_FEES *)
type t = {
h_wire_method: Hash_64_cstr.t;
start_date: TimeAbsoluteNBO.t;
end_date: TimeAbsoluteNBO.t;
wire_fee: AmountNBO.t;
closing_fee: AmountNBO.t;
}
end
module GlobalFeesPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_GLOBAL_FEES *)
type t = {
start_date: TimeAbsoluteNBO.t;
end_date: TimeAbsoluteNBO.t;
purse_timeout: TimeRelativeNBO.t;
kyc_timeout: TimeRelativeNBO.t;
history_expiration: TimeRelativeNBO.t;
history_fee: AmountNBO.t;
kyc_fee: AmountNBO.t;
account_fee: AmountNBO.t;
purse_fee: AmountNBO.t;
purse_account_limit: int; (* uint32_t → int *)
}
end
module MasterDrainProfitPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_DRAIN_PROFITS *)
type t = {
wtid: WireTransferIdentifierRawP.t;
date: TimeAbsoluteNBO.t;
amount: AmountNBO.t;
h_section: Hash_64_cstr.t;
h_payto: FullPaytoHash.t;
}
end
module DepositTrackPS = struct
(* purpose.purpose = TALER_SIGNATURE_MERCHANT_TRACK_TRANSACTION *)
type t = {
h_contract_terms: PrivateContractHash.t;
h_wire: MerchantWireHash.t;
coin_pub: CoinSpendPublicKeyP.t;
}
end
module WireDepositDetailP = struct
type t = {
h_contract_terms: PrivateContractHash.t;
execution_time: TimeAbsoluteNBO.t;
coin_pub: CoinSpendPublicKeyP.t;
deposit_value: AmountNBO.t;
deposit_fee: AmountNBO.t;
}
end
module WireDepositDataPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_CONFIRM_WIRE_DEPOSIT *)
type t = {
total: AmountNBO.t;
wire_fee: AmountNBO.t;
merchant_pub: MerchantPublicKeyP.t;
h_wire: MerchantWireHash.t;
h_details: Hash_64_cstr.t;
}
end
module ExchangeKeyValidityPS = struct
(* purpose.purpose = TALER_SIGNATURE_AUDITOR_EXCHANGE_KEYS *)
type t = {
auditor_url_hash: Hash_64_cstr.t;
master: MasterPublicKeyP.t;
start: TimeAbsoluteNBO.t;
expire_withdraw: TimeAbsoluteNBO.t;
expire_spend: TimeAbsoluteNBO.t;
expire_legal: TimeAbsoluteNBO.t;
value: AmountNBO.t;
fee_withdraw: AmountNBO.t;
fee_deposit: AmountNBO.t;
fee_refresh: AmountNBO.t;
denom_hash: DenominationHash.t;
}
end
module PaymentResponsePS = struct
(* purpose.purpose = TALER_SIGNATURE_MERCHANT_PAYMENT_OK *)
type t = { h_contract_terms: PrivateContractHash.t }
end
module ContractPS = struct
(* purpose.purpose = TALER_SIGNATURE_MERCHANT_CONTRACT *)
type t = { h_contract_terms: PrivateContractHash.t }
end
module ConfirmWirePS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_CONFIRM_WIRE *)
type t = {
h_wire: MerchantWireHash.t;
h_contract_terms: PrivateContractHash.t;
wtid: WireTransferIdentifierRawP.t;
coin_pub: CoinSpendPublicKeyP.t;
execution_time: TimeAbsoluteNBO.t;
coin_contribution: AmountNBO.t;
}
end
module RefundConfirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_CONFIRM_REFUND *)
type t = {
h_contract_terms: PrivateContractHash.t;
coin_pub: CoinSpendPublicKeyP.t;
merchant: MerchantPublicKeyP.t;
rtransaction_id: int64;
refund_amount: AmountNBO.t;
}
end
module DepositTrackPS2 = struct
(* purpose.purpose = TALER_SIGNATURE_MERCHANT_TRACK_TRANSACTION *)
type t = {
h_contract_terms: PrivateContractHash.t;
h_wire: MerchantWireHash.t;
merchant: MerchantPublicKeyP.t;
coin_pub: CoinSpendPublicKeyP.t;
}
end
module RefundRequestPS = struct
(* purpose.purpose = TALER_SIGNATURE_MERCHANT_REFUND *)
type t = {
h_contract_terms: PrivateContractHash.t;
coin_pub: CoinSpendPublicKeyP.t;
rtransaction_id: int64;
refund_amount: AmountNBO.t;
refund_fee: AmountNBO.t;
}
end
module MerchantRefundConfirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_MERCHANT_REFUND_OK *)
(* Hash of the order ID (a string), hashed without the 0-termination. *)
type t = { h_order_id: Hash_64_cstr.t }
end
module RecoupRequestPS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_COIN_RECOUP or TALER_SIGNATURE_WALLET_COIN_RECOUP_REFRESH *)
type t = {
h_denom_pub: DenominationHash.t;
coin_blind: DenominationBlindingKeyP.t;
}
end
module RecoupRefreshConfirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_CONFIRM_RECOUP_REFRESH *)
type t = {
timestamp: TimeAbsoluteNBO.t;
recoup_amount: AmountNBO.t;
coin_pub: CoinSpendPublicKeyP.t;
old_coin_pub: CoinSpendPublicKeyP.t;
}
end
module RecoupConfirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_CONFIRM_RECOUP *)
type t = {
timestamp: TimeAbsoluteNBO.t;
recoup_amount: AmountNBO.t;
coin_pub: CoinSpendPublicKeyP.t;
reserve_pub: ReservePublicKeyP.t;
}
end
module DenominationUnknownAffirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_AFFIRM_DENOM_UNKNOWN *)
type t = {
timestamp: TimeAbsoluteNBO.t;
h_denom_pub: DenominationHash.t;
}
end
module DenominationExpiredAffirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_GENERIC_DENOMINATIN_EXPIRED *)
type t = {
timestamp: TimeAbsoluteNBO.t;
operation: string; (* char[8] → string *)
h_denom_pub: DenominationHash.t;
}
end
module ReserveCloseConfirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_RESERVE_CLOSED *)
type t = {
timestamp: TimeAbsoluteNBO.t;
closing_amount: AmountNBO.t;
reserve_pub: ReservePublicKeyP.t;
h_wire: FullPaytoHash.t;
}
end
module CoinLinkSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_COIN_LINK *)
type t = {
h_denom_pub: DenominationHash.t;
old_coin_pub: CoinSpendPublicKeyP.t;
transfer_pub: TransferPublicKeyP.t;
coin_envelope_hash: BlindedCoinHash.t;
}
end
module RefreshNonceSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_COIN_LINK *)
type t = { nonce: PublicRefreshCoinNonceP.t }
end
module ReserveStatusRequestSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_RESERVE_STATUS_REQUEST *)
type t = { request_timestamp: TimeAbsoluteNBO.t }
end
module ReserveHistoryRequestSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_RESERVE_HISTORY_REQUEST *)
type t = {
history_fee: AmountNBO.t;
request_timestamp: TimeAbsoluteNBO.t;
}
end
module PurseStatusRequestSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_PURSE_STATUS_REQUEST *)
type t = unit
end
module PurseStatusResponseSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_PURSE_STATUS_RESPONSE *)
type t = {
total_purse_amount: AmountNBO.t;
total_deposit_amount: AmountNBO.t;
max_deposit_fees: AmountNBO.t;
purse_expiration: TimeAbsoluteNBO.t;
status_timestamp: TimeAbsoluteNBO.t;
h_contract_terms: PrivateContractHash.t;
}
end
module ReserveCloseRequestSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_RESERVE_CLOSE *)
type t = unit
end
module PurseRequestSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_PURSE_CREATE *)
type t = {
purse_expiration: TimeAbsoluteNBO.t;
merge_value_after_fees: AmountNBO.t;
h_contract_terms: PrivateContractHash.t;
min_age: int;
}
end
module PurseDepositSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_PURSE_DEPOSIT *)
type t = {
coin_contribution: AmountNBO.t;
h_denom_pub: DenominationHash.t;
h_age_commitment: AgeCommitmentHash.t;
purse_pub: PursePublicKey.t;
h_exchange_base_url: Hash_64_cstr.t;
}
end
module PurseDepositSignaturePS2 = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_RESERVE_OPEN_DEPOSIT *)
type t = {
reserve_sig: ReserveSignatureP.t;
coin_contribution: AmountNBO.t;
}
end
module PurseDepositConfirmedSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_PURSE_DEPOSIT_CONFIRMED *)
type t = {
total_purse_amount: AmountNBO.t;
total_deposit_fees: AmountNBO.t;
purse_pub: PursePublicKey.t;
purse_expiration: TimeAbsoluteNBO.t;
h_contract_terms: PrivateContractHash.t;
}
end
module PurseMergeSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_PURSE_MERGE *)
type t = {
merge_timestamp: TimeAbsoluteNBO.t;
h_wire: NormalizedPaytoHash.t;
}
end
module AccountMergeSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_ACCOUNT_MERGE *)
type t = {
reserve_pub: ReservePublicKeyP.t;
purse_pub: PursePublicKey.t;
merge_amount_after_fees: AmountNBO.t;
merge_timestamp: TimeAbsoluteNBO.t;
purse_expiration: TimeAbsoluteNBO.t;
h_contract_terms: PrivateContractHash.t;
min_age: int;
}
end
module AccountSetupRequestSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_ACCOUNT_SETUP *)
type t = { threshold: AmountNBO.t }
end
module PurseMergeSuccessSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_PURSE_MERGE_SUCCESS *)
type t = {
reserve_pub: ReservePublicKeyP.t;
purse_pub: PursePublicKey.t;
merge_amount_after_fees: AmountNBO.t;
contract_time: TimeAbsoluteNBO.t;
h_contract_terms: PrivateContractHash.t;
h_wire: NormalizedPaytoHash.t;
min_age: int;
}
end
module WadDataSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_WAD_DATA *)
type t = {
wad_execution_time: TimeAbsoluteNBO.t;
total_amount: AmountNBO.t;
h_items: Hash_64_cstr.t;
wad_id: WadId.t;
}
end
module WadPartnerSignaturePS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_PARTNER_DETAILS *)
type t = {
h_partner_base_url: Hash_64_cstr.t;
master_public_key: MasterPublicKeyP.t;
start_date: TimeAbsoluteNBO.t;
end_date: TimeAbsoluteNBO.t;
wad_fee: AmountNBO.t;
wad_frequency: TimeRelativeNBO.t;
}
end
module P2PFeesPS = struct
(* purpose.purpose = TALER_SIGNATURE_P2P_FEES *)
type t = {
start_date: TimeAbsoluteNBO.t;
end_date: TimeAbsoluteNBO.t;
kyc_fee: AmountNBO.t;
purse_fee: AmountNBO.t;
account_history_fee: AmountNBO.t;
account_annual_fee: AmountNBO.t;
account_kyc_timeout: TimeRelativeNBO.t;
purse_timeout: TimeRelativeNBO.t;
purse_account_limit: int;
}
end
module CoinPurseRefundConfirmationPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_CONFIRM_PURSE_REFUND *)
type t = {
purse_pub: PursePublicKey.t;
coin_pub: CoinSpendPublicKeyP.t;
refunded_amount: AmountNBO.t;
refund_fee: AmountNBO.t;
}
end
module MasterDenominationKeyRevocationPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_DENOMINATION_KEY_REVOKED *)
type t = { h_denom_pub: DenominationHash.t }
end
module MasterSigningKeyRevocationPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_SIGNING_KEY_REVOKED *)
type t = { exchange_pub: ExchangePublicKeyP.t }
end
module MasterAddAuditorPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_ADD_AUDITOR *)
type t = {
start_date: TimeAbsoluteNBO.t;
auditor_pub: AuditorPublicKeyP.t;
h_auditor_url: Hash_64_cstr.t;
}
end
module MasterDelAuditorPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_DEL_AUDITOR *)
type t = {
end_date: TimeAbsoluteNBO.t;
auditor_pub: AuditorPublicKeyP.t;
}
end
module MasterAddWirePS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_ADD_WIRE *)
type t = {
start_date: TimeAbsoluteNBO.t;
h_wire: FullPaytoHash.t;
h_conversion_url: Hash_64_cstr.t;
h_credit_restrictions: Hash_64_cstr.t;
h_debit_restrictions: Hash_64_cstr.t;
}
end
module MasterDelWirePS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_DEL_WIRE *)
type t = {
end_date: TimeAbsoluteNBO.t;
h_wire: FullPaytoHash.t;
}
end
module MasterAmlOfficerStatusPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_AML_KEY *)
type t = {
change_date: TimestampNBO.t;
officer_pub: AmlOfficerPublicKeyP.t;
h_officer_name: Hash_64_cstr.t;
is_active: int;
}
end
module AmlDecisionPS = struct
(* purpose.purpose = TALER_SIGNATURE_AML_DECISION *)
type t = {
h_justification: Hash_64_cstr.t;
decision_time: TimestampNBO.t;
new_threshold: AmountNBO.t;
h_payto: NormalizedPaytoHash.t;
h_kyc_requirements: Hash_64_cstr.t;
new_state: int;
}
end
module PartnerConfigurationPS = struct
(* purpose.purpose = TALER_SIGNATURE_MASTER_PARNTER_DETAILS *)
type t = {
partner_pub: MasterPublicKeyP.t;
start_date: TimestampNBO.t;
end_date: TimestampNBO.t;
wad_frequency: TimeRelativeNBO.t;
wad_fee: AmountNBO.t;
h_url: Hash_64_cstr.t;
}
end
module ReserveOpenPS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_RESERVE_OPEN *)
type t = {
reserve_payment: AmountNBO.t;
request_timestamp: TimestampNBO.t;
reserve_expiration: TimestampNBO.t;
purse_limit: int;
}
end
module ReserveClosePS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_RESERVE_CLOSE *)
type t = {
request_timestamp: TimestampNBO.t;
target_account_h_payto: FullPaytoHash.t;
}
end
module ReserveAttestRequestPS = struct
(* purpose.purpose = TALER_SIGNATURE_WALLET_ATTEST_REQUEST *)
type t = {
request_timestamp: TimestampNBO.t;
h_details: Hash_64_cstr.t;
}
end
module ExchangeAttestPS = struct
(* purpose.purpose = TALER_SIGNATURE_EXCHANGE_RESERVE_ATTEST_DETAILS *)
type t = {
attest_timestamp: TimestampNBO.t;
expiration_time: TimestampNBO.t;
reserve_pub: ReservePublicKeyP.t;
h_attributes: Hash_64_cstr.t;
}
end

80
src/bin_type.ml
View file

@ -41,7 +41,6 @@
*) *)
module Taler_signatures = Include.Taler_signatures module Taler_signatures = Include.Taler_signatures
open Crypto
let int32_size = 4 let int32_size = 4
let int64_size = 8 let int64_size = 8
@ -59,28 +58,29 @@ module Bytes_64 = struct
end end
(* -- Time -- *) (* -- Time -- *)
module type Time_S = sig module TimeAbsolute = struct
type t = Timestamp.t
val bin : t Bin.t
end
module TIME : Time_S = struct
type t = Timestamp.t type t = Timestamp.t
let bin = Timestamp.bin let bin = Timestamp.bin
end end
module TIME_NBO : Time_S = struct module TimeAbsoluteNBO = struct
type t = Timestamp.t type t = Timestamp.t
let bin = Timestamp.bin_nbo let bin = Timestamp.bin_nbo
end end
module TimeAbsolute : Time_S = TIME module TimeRelative = struct
module TimeAbsoluteNBO : Time_S = TIME_NBO type t = Timestamp.Span.t
module TimeRelative : Time_S = TIME
module TimeRelativeNBO : Time_S = TIME_NBO let bin = Timestamp.Span.bin
end
module TimeRelativeNBO = struct
type t = Timestamp.Span.t
let bin = Timestamp.Span.bin_nbo
end
(* -- Cryptographic primitives -- *) (* -- Cryptographic primitives -- *)
@ -97,17 +97,23 @@ module Hash_32 = struct
| true -> Digestif.SHA256.of_raw_string s | true -> Digestif.SHA256.of_raw_string s
let to_octets = Digestif.SHA256.to_raw_string let to_octets = Digestif.SHA256.to_raw_string
let of_b32 s = Result.map of_octets (B32.decode s)
let bin = let bin =
let open Bin in let open Bin in
map (bytes 32) of_octets to_octets map (bytes 32) of_octets to_octets
(* hashes are not b32 encoded in the database *)
let caqti : t Caqti_type.t = let caqti : t Caqti_type.t =
let open Caqti_type in let open Caqti_type in
custom custom
~encode:(fun v -> Ok (to_octets v)) ~encode:(fun v -> Ok (to_octets v))
~decode:(fun v -> Ok (of_octets v)) ~decode:(fun v -> Ok (of_octets v))
octets octets
let jsont =
let enc v = B32.encode (to_octets v) in
Jsont.of_of_string ~kind:"Hash 32" of_b32 ~enc
end end
module Hash_64 = struct module Hash_64 = struct
@ -126,16 +132,23 @@ module Hash_64 = struct
| false -> Fmt.failwith "Hash.to_octets failure: data is not 64 bytes" | false -> Fmt.failwith "Hash.to_octets failure: data is not 64 bytes"
| true -> s | true -> s
let of_b32 s = Result.map of_octets (B32.decode s)
let bin = let bin =
let open Bin in let open Bin in
map (bytes 64) of_octets to_octets map (bytes 64) of_octets to_octets
(* hashes are not b32 encoded in the database *)
let caqti : t Caqti_type.t = let caqti : t Caqti_type.t =
let open Caqti_type in let open Caqti_type in
custom custom
~encode:(fun v -> Ok (to_octets v)) ~encode:(fun v -> Ok (to_octets v))
~decode:(fun v -> Ok (of_octets v)) ~decode:(fun v -> Ok (of_octets v))
octets octets
let jsont =
let enc v = B32.encode (to_octets v) in
Jsont.of_of_string ~kind:"Hash 64" of_b32 ~enc
end end
(* Hash over string + '\0' *) (* Hash over string + '\0' *)
@ -160,9 +173,11 @@ module type Hash_S = sig
val bin : t Bin.t val bin : t Bin.t
val caqti : t Caqti_type.t val caqti : t Caqti_type.t
val jsont : t Jsont.t
val hash : string -> t val hash : string -> t
val of_octets : string -> t val of_octets : string -> t
val to_octets : t -> string val to_octets : t -> string
val of_b32 : B32.t -> (t, string) result
end end
module FullPaytoHash : Hash_S = Hash_32 module FullPaytoHash : Hash_S = Hash_32
@ -228,42 +243,3 @@ module AgeMask = struct
let open Bin in let open Bin in
record (fun mask -> { mask }) |+ field beint32 (fun t -> t.mask) |> sealr record (fun mask -> { mask }) |+ field beint32 (fun t -> t.mask) |> sealr
end end
(* TODO keep this?
some of those are actuall ecdhe, or union of eddsa|ecdhe *)
module Aliases = struct
module TimestampNBO : Time_S = struct
type t = Timestamp.t
let bin = Timestamp.bin_nbo
end
module AmountNBO = struct
type t = Amount.t
let bin = Amount.bin_nbo
end
(* - Keys - *)
module PursePublicKey = EddsaPublicKey
module AuditorPublicKeyP = EddsaPublicKey
module ReservePublicKeyP = EddsaPublicKey
module MerchantPublicKeyP = EddsaPublicKey
module TransferPublicKeyP = EddsaPublicKey
module AmlOfficerPublicKeyP = EddsaPublicKey
module ExchangePublicKeyP = EddsaPublicKey
module MasterPublicKeyP = EddsaPublicKey
module CoinSpendPublicKeyP = EddsaPublicKey
module TokenPublicKeyP = EddsaPublicKey
module ReservePrivateKeyP = EddsaPrivateKey
module MerchantPrivateKeyP = EddsaPrivateKey
module TransferPrivateKeyP = EddsaPrivateKey
module AmlOfficerPrivateKeyP = EddsaPrivateKey
module ExchangePrivateKeyP = EddsaPrivateKey
module MasterPrivateKeyP = EddsaPrivateKey
module CoinSpendPrivateKeyP = EddsaPrivateKey
module MasterSignatureP = EddsaSignature
module ReserveSignatureP = EddsaSignature
module ExchangeSignatureP = EddsaSignature
module CoinSpendSignatureP = EddsaSignature
end

24
src/config.ml
View file

@ -20,9 +20,13 @@ module Exchange = struct
let port = get "port" |> int let port = get "port" |> int
let bind_to = get "bind_to" let bind_to = get "bind_to"
let master_public_key = get "master_public_key" |> ed25519 let master_public_key = get "master_public_key" |> ed25519
(* TODO Defaults to 0.0 if not specified. *)
let stefan_abs = get "stefan_abs" |> amount let stefan_abs = get "stefan_abs" |> amount
let stefan_log = get "stefan_log" |> amount let stefan_log = get "stefan_log" |> amount
let stefan_lin = get_opt "stefan_lin" |> Option.map float
let stefan_lin =
get_opt "stefan_lin" |> Option.map float |> Option.value ~default:0.0
let aggregator_idle_sleep_interval = let aggregator_idle_sleep_interval =
get "aggregator_idle_sleep_interval" |> duration get "aggregator_idle_sleep_interval" |> duration
@ -40,17 +44,16 @@ module Exchange = struct
let enable_kyc = get "enable_kyc" |> yes_no let enable_kyc = get "enable_kyc" |> yes_no
let terms_etag = get "terms_etag" let terms_etag = get "terms_etag"
let privacy_etag = get "privacy_etag" let privacy_etag = get "privacy_etag"
let base_url = get "base_url"
let shopping_url = get_opt "shopping_url"
let open_banking_gateway_url = get_opt "open_banking_gateway_url"
let bank_compliance_language = get_opt "bank_compliance_language"
let aml_spa_dialect = get_opt "aml_spa_dialect"
let toplevel_redirect_url = get_opt "toplevel_redirect_url"
let tiny_amount = get_opt "tiny_amount" |> Option.map amount
(* optional:
tiny_amount
shopping_url
open_banking_gateway_url
aml_spa_dialect
bank_compliance_language
toplevel_redirect_url *)
(* not implemented or not relevant to MTE: (* not implemented or not relevant to MTE:
let max_requests = get "max_requests" |> int let max_requests = get "max_requests" |> int
base_url
aggregator_shard_size aggregator_shard_size
serve serve
unixpath unixpath
@ -105,7 +108,8 @@ module Currency = struct
fractional_normal_digits= get "fractional_normal_digits" |> int; fractional_normal_digits= get "fractional_normal_digits" |> int;
fractional_trailing_zero_digits= fractional_trailing_zero_digits=
get "fractional_trailing_zero_digits" |> int; get "fractional_trailing_zero_digits" |> int;
alt_unit_names= get "alt_unit_names" |> Parse_alt_unit_names.parse; alt_unit_names=
get "alt_unit_names" |> Alt_unit_names.decode |> Parse_config.unwrap_res;
} }
let all_currencies = List.map parse_currency currency_sections let all_currencies = List.map parse_currency currency_sections

151
src/crypto.ml
View file

@ -10,18 +10,32 @@ module EddsaPublicKey = struct
type t = pub type t = pub
let to_octets t = pub_to_octets t let to_octets t = pub_to_octets t
let of_octets t = pub_of_octets t |> Result.get_ok
let bin = Bin.map (Bin.bytes 32) of_octets to_octets let of_octets t =
pub_of_octets t |> function
| Error e -> Fmt.error "%a" Mirage_crypto_ec.pp_error e
| Ok v -> Ok v
let bin =
let of_octets o =
match of_octets o with Error e -> raise (Util.Bin_error e) | Ok v -> v
in
Bin.map (Bin.bytes 32) of_octets to_octets
let of_b32 s = let of_b32 s =
let open Syntax in let open Syntax in
let* octets = B32.decode s in let* octets = B32.decode s in
match pub_of_octets octets with let* pub = of_octets octets in
| Error e -> Fmt.error "%a" Mirage_crypto_ec.pp_error e Ok pub
| Ok pub -> Ok pub
let to_b32 t = B32.encode (to_octets t) let to_b32 t = B32.encode (to_octets t)
let jsont = Jsont.of_of_string ~kind:"EddsaPublicKey" of_b32 ~enc:to_b32 let jsont = Jsont.of_of_string ~kind:"EddsaPublicKey" of_b32 ~enc:to_b32
let caqti =
Caqti_type.custom
~encode:(fun v -> Ok (to_octets v))
~decode:(fun v -> of_octets v)
Caqti_type.octets
end end
module EddsaPrivateKey = struct module EddsaPrivateKey = struct
@ -34,69 +48,88 @@ module EddsaPrivateKey = struct
let pub_of_priv = pub_of_priv let pub_of_priv = pub_of_priv
let to_octets t = priv_to_octets t let to_octets t = priv_to_octets t
let of_octets t = priv_of_octets t |> Result.get_ok
let bin = Bin.map (Bin.bytes 32) of_octets to_octets
let of_octets t =
priv_of_octets t |> function
| Error err ->
let err = Fmt.str "%a" Mirage_crypto_ec.pp_error err in
Error err
| Ok v -> Ok v
let bin =
let of_octets_exn t = of_octets t |> Result.get_ok in
Bin.map (Bin.bytes 32) of_octets_exn to_octets
let jsont =
let of_b32 s = let of_b32 s =
let open Syntax in let open Syntax in
let* octets = B32.decode s in let* octets = B32.decode s in
match priv_of_octets octets with of_octets octets
| Error e -> Fmt.error "%a" Mirage_crypto_ec.pp_error e in
| Ok priv -> Ok priv let to_b32 t = B32.encode (to_octets t) in
Jsont.of_of_string ~kind:"EddsaPrivateKey" of_b32 ~enc:to_b32
let to_b32 t = B32.encode (to_octets t)
let jsont = Jsont.of_of_string ~kind:"EddsaPrivateKey" of_b32 ~enc:to_b32
end end
module EddsaSignature : sig module EddsaSignature : sig
type t type t
val sign : key:Mirage_crypto_ec.Ed25519.priv -> string -> t val sign : key:EddsaPrivateKey.t -> string -> t
val sign_as_string : key:Mirage_crypto_ec.Ed25519.priv -> string -> string
val of_b32 : string -> (t, string) result (* Ok () on verification success *)
val to_b32 : t -> string val verify : key:EddsaPublicKey.t -> t -> msg:string -> (unit, string) result
val to_octets : t -> string val to_octets : t -> string
val of_octets : string -> t val of_octets : string -> (t, string) result
val jsont : t Jsont.t val jsont : t Jsont.t
val bin : t Bin.t val bin : t Bin.t
val caqti : t Caqti_type.t
end = struct end = struct
(* TODO key format (* TODO key format
endianess issue? *) endianess issue? *)
(* EdDSA signatures are transmitted as 64-bytes base32 (* transmitted as 64-bytes base32
binary-encoded objects with just the R and S values (base32_ binary-only). binary-encoded objects with just the R and S values *)
They are signature over a c-struct like `TALER_xxxPS` + with a purpose *)
type t = string type t = string
(* mirage_crypto: "The result is the concatenation of r and s, as specified in RFC 8032." *)
let sign ~key s = Mirage_crypto_ec.Ed25519.sign ~key s
let verify ~key s ~msg =
let b = Mirage_crypto_ec.Ed25519.verify ~key s ~msg in
match b with
| false -> Error "signature verification failure: invalid signature"
| true -> Ok ()
let to_octets t = t let to_octets t = t
let of_octets v = let of_octets v =
match String.length v = 64 with match String.length v = 64 with
| false -> | false ->
Fmt.failwith "EddsaSignature.of_octets failure: data is not 64 bytes." Fmt.error "EddsaSignature.of_octets failure: data is not 64 bytes."
| true -> v | true -> Ok v
let bin = Bin.map (Bin.bytes 64) of_octets to_octets let bin =
let of_octets_exn t = of_octets t |> Result.get_ok in
let sign ~key s = Bin.map (Bin.bytes 64) of_octets_exn to_octets
(* mirage_crypto: "The result is the concatenation of r and s, as specified in RFC 8032." *)
Mirage_crypto_ec.Ed25519.sign ~key s
let sign_as_string ~key s = sign ~key s
let check_size t = let check_size t =
match String.length t = 64 with match String.length t = 64 with
| false -> Error "EddsaSignature: invalid string length" | false -> Error "EddsaSignature: invalid string length"
| true -> Ok () | true -> Ok ()
let jsont =
let of_b32 s = let of_b32 s =
let open Syntax in let open Syntax in
let* t = B32.decode s in let* t = B32.decode s in
let+ () = check_size t in let+ () = check_size t in
t t
in
let to_b32 = B32.encode in
Jsont.of_of_string ~kind:"EddsaSignature" of_b32 ~enc:to_b32
let to_b32 = B32.encode let caqti =
let jsont = Jsont.of_of_string ~kind:"EddsaSignature" of_b32 ~enc:to_b32 Caqti_type.custom
~encode:(fun v -> Ok (to_octets v))
~decode:(fun s -> of_octets s)
Caqti_type.octets
end end
module RsaPublicKey = struct module RsaPublicKey = struct
@ -104,18 +137,24 @@ module RsaPublicKey = struct
type t = Rsa.pub type t = Rsa.pub
let of_octets = Util.Bin_rsa.pub_of_octets
let to_octets = Util.Bin_rsa.pub_to_octets let to_octets = Util.Bin_rsa.pub_to_octets
let of_octets = Util.Bin_rsa.pub_of_octets
let jsont =
let of_b32 s = let of_b32 s =
let open Syntax in let open Syntax in
let* s = B32.decode s in let* s = B32.decode s in
let v = Util.Bin_rsa.pub_of_octets s in let+ v = of_octets s in
let+ v = Rsa.pub ~n:v.n ~e:v.e |> unwrap_err_msg in
v v
in
let to_b32 t = B32.encode (to_octets t) in
Jsont.of_of_string ~kind:"RsaPublicKey" of_b32 ~enc:to_b32
let to_b32 t = B32.encode (to_octets t) let caqti : t Caqti_type.t =
let jsont = Jsont.of_of_string ~kind:"RsaPublicKey" of_b32 ~enc:to_b32 Caqti_type.custom
~encode:(fun v -> Ok (to_octets v))
~decode:(fun v -> of_octets v)
Caqti_type.octets
end end
module RsaPrivateKey = struct module RsaPrivateKey = struct
@ -123,37 +162,49 @@ module RsaPrivateKey = struct
type t = priv type t = priv
let generate ~bits () =
let priv = generate ~bits () in
let pub = pub_of_priv priv in
(priv, pub)
let pub_of_priv = pub_of_priv let pub_of_priv = pub_of_priv
let of_octets = Util.Bin_rsa.priv_of_octets let of_octets = Util.Bin_rsa.priv_of_octets
let to_octets = Util.Bin_rsa.priv_to_octets let to_octets = Util.Bin_rsa.priv_to_octets
let jsont =
let of_b32 s = let of_b32 s =
let open Syntax in let open Syntax in
let* s = B32.decode s in let* s = B32.decode s in
Ok (of_octets s) let+ v = of_octets s in
v
let to_b32 t = B32.encode (to_octets t) in
let jsont = Jsont.of_of_string ~kind:"RsaPrivateKey" of_b32 ~enc:to_b32 let to_b32 t = B32.encode (to_octets t) in
Jsont.of_of_string ~kind:"RsaPrivateKey" of_b32 ~enc:to_b32
end end
module RsaSignature : sig module RsaSignature : sig
type t type t
val to_octets : t -> string
val sign : key:Mirage_crypto_pk.Rsa.priv -> string -> t val sign : key:Mirage_crypto_pk.Rsa.priv -> string -> t
val of_b32 : string -> (t, string) result
val to_b32 : t -> string
val jsont : t Jsont.t val jsont : t Jsont.t
end = struct end = struct
type t = string type t = string
let to_octets t = t
(* TODO rsa sign *) (* TODO rsa sign *)
let sign ~key s = let sign ~key s =
Mirage_crypto_pk.Rsa.decrypt ~crt_hardening:true ~mask:`Yes ~key s Mirage_crypto_pk.Rsa.decrypt ~crt_hardening:true ~mask:`Yes ~key s
let of_b32 s = B32.decode s let jsont =
let to_b32 t = B32.encode t let of_b32 s = B32.decode s in
let jsont = Jsont.of_of_string ~kind:"RsaSignature" of_b32 ~enc:to_b32 let to_b32 t = B32.encode t in
Jsont.of_of_string ~kind:"RsaSignature" of_b32 ~enc:to_b32
end end
(* some type aliases, just for prettier .mli *)
type eddsa_priv = EddsaPrivateKey.t
type eddsa_pub = EddsaPublicKey.t
type eddsa_sig = EddsaSignature.t
type rsa_priv = RsaPrivateKey.t
type rsa_pub = RsaPublicKey.t
type rsa_sig = RsaSignature.t
type denomination_hash = Bin_type.DenominationHash.t

98
src/data_file.ml
View file

@ -3,91 +3,33 @@ open Syntax
open Crypto open Crypto
let read fname = let read fname =
let* b = File.exists fname in let* b = File.exists fname |> Syntax.unwrap_err_msg in
match b with match b with
| false -> Ok None | false -> Ok None
| true -> | true ->
let+ content = File.read fname in let+ content = File.read fname |> Syntax.unwrap_err_msg in
Some content Some content
let write_eddsa fname priv =
EddsaPrivateKey.to_octets priv |> File.write fname |> Syntax.unwrap_err_msg
let write_rsa fname priv =
RsaPrivateKey.to_octets priv |> File.write fname |> Syntax.unwrap_err_msg
let read_eddsa fname = let read_eddsa fname =
let+ content_opt = read fname in let* opt = read fname in
Option.map EddsaPrivateKey.of_octets content_opt match opt with
| None -> Ok None
| Some data -> (
EddsaPrivateKey.of_octets data |> function
| Error e -> Error e
| Ok v -> Ok (Some v))
let read_rsa fname = let read_rsa fname =
let+ content_opt = read fname in let* opt = read fname in
Option.map RsaPrivateKey.of_octets content_opt
let write_eddsa fname priv = EddsaPrivateKey.to_octets priv |> File.write fname
let write_rsa fname priv = RsaPrivateKey.to_octets priv |> File.write fname
let load_signkey conn fname =
let* opt = read_eddsa fname in
match opt with match opt with
| None -> Ok None | None -> Ok None
| Some priv -> ( | Some data -> (
let pub = EddsaPrivateKey.pub_of_priv priv in RsaPrivateKey.of_octets data |> function
let* opt = Pg.lookup_signing_key conn pub in | Error e -> Error e
match opt with | Ok v -> Ok (Some v))
| None ->
Fmt.error_msg
"load_signkey error no associated metadata found in database for \
signkey `%s`."
(Fpath.to_string fname)
| Some (stamp_start, stamp_expire, stamp_end) ->
(* TODO master_sig *)
let master_sig = None in
let v =
Signkey.
{ pub; priv; stamp_start; stamp_expire; stamp_end; master_sig }
in
Ok (Some v))
let load_denom conn ~section_name fname =
let* opt = read_rsa fname in
match opt with
| None -> Ok None
| Some priv -> (
let pub = RsaPrivateKey.pub_of_priv priv in
let h_pub = Bin_type.DenominationHash.hash (RsaPublicKey.to_octets pub) in
let* opt = Pg.lookup_denomination_key conn h_pub in
match opt with
| None ->
Fmt.error_msg
"load_denom error no associated metadata found in database for \
denom `%s`."
(Fpath.to_string fname)
| Some
( stamp_start,
stamp_expire_withdraw,
stamp_expire_deposit,
stamp_expire_legal,
value,
fee_withdraw,
fee_deposit,
fee_refresh,
fee_refund,
age_mask ) ->
(* TODO master_sig *)
let master_sig = None in
let v =
Denomination.
{
pub;
priv;
section_name;
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;
}
in
Ok (Some v))

33
src/database.ml
View file

@ -1,33 +0,0 @@
(* TODO
- GNU Taler db-events?
it seems caqti/pgx does not support it *)
let on_ok req () =
let open Vif.Response.Syntax in
let* () =
Vif.Response.add ~field:"content-type" "text/plain; charset= utf-8"
in
let* () =
Vif.Response.with_string req (Fmt.str "activate_signing_key done~~@.")
in
Vif.Response.respond `OK
let on_error req err =
(* TODO be sure to not leak private data in error messages *)
let open Vif.Response.Syntax in
let str = Fmt.str "Database error: %a." Caqti_error.pp err in
Logs.err (fun m -> m "%s" str);
let* () = Vif.Response.with_string req str in
Vif.Response.respond `Internal_server_error
(* TODO master_sig *)
let dummy_master_sig =
Option.some @@ Crypto.EddsaSignature.of_octets (String.make 64 '\x00')
let test_activate req server _ =
let db_conn = Vif.Server.device Devices.db_connection server in
let secmod_signkey = Vif.Server.device Devices.secmod_signkey server in
let sm_key = secmod_signkey.sm_key in
let sm_key = { sm_key with master_sig= dummy_master_sig } in
let res = Pg.activate_signing_key db_conn sm_key in
Result.fold ~ok:(on_ok req) ~error:(on_error req) res

18
src/denom_data.ml Normal file
View file

@ -0,0 +1,18 @@
open Crypto
type t = {
pub: rsa_pub;
value: Amount.t;
stamp_start: Timestamp.t;
stamp_expire_withdraw: Timestamp.t;
stamp_expire_deposit: Timestamp.t;
stamp_expire_legal: Timestamp.t;
fee_withdraw: Amount.t;
fee_deposit: Amount.t;
fee_refresh: Amount.t;
fee_refund: Amount.t;
age_mask: int;
h_pub: denomination_hash;
master_sig: Bin_sig.DenominationKeyValidity.t option;
revoked_sig: Bin_sig.MasterDenominationKeyRevocation.t option;
}

71
src/denomination.ml
View file

@ -1,71 +0,0 @@
open Crypto
type t = {
pub: RsaPublicKey.t;
priv: RsaPrivateKey.t;
section_name: string;
value: Amount.t;
stamp_start: Timestamp.t;
stamp_expire_withdraw: Timestamp.t;
stamp_expire_deposit: Timestamp.t;
stamp_expire_legal: Timestamp.t;
fee_withdraw: Amount.t;
fee_deposit: Amount.t;
fee_refresh: Amount.t;
fee_refund: Amount.t;
age_mask: int;
h_pub: Bin_type.DenominationHash.t;
master_sig: EddsaSignature.t option;
}
let make
({
section_name;
value;
duration_withdraw;
duration_spend;
duration_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
cipher;
rsa_keysize;
age_restricted= _;
} :
Config.Coin.t) =
assert (cipher = `RSA);
let stamp_start = Ptime_clock.now () |> Option.some in
let stamp_expire_withdraw =
Timestamp.add_span_exn stamp_start (Some duration_withdraw)
in
let stamp_expire_deposit =
Timestamp.add_span_exn stamp_start (Some duration_spend)
in
let stamp_expire_legal =
Timestamp.add_span_exn stamp_start (Some duration_legal)
in
let open Mirage_crypto_pk.Rsa in
let priv = generate ~bits:rsa_keysize () in
let pub = pub_of_priv priv in
let h_pub = Bin_type.DenominationHash.hash (RsaPublicKey.to_octets pub) in
let master_sig = None in
{
pub;
priv;
section_name;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
age_mask= 0;
h_pub;
master_sig;
}

132
src/devices.ml
View file

@ -1,5 +1,3 @@
open Syntax
type env = { type env = {
caqti_switch: Caqti_miou.Switch.t; caqti_switch: Caqti_miou.Switch.t;
db_uri: Uri.t; db_uri: Uri.t;
@ -20,129 +18,9 @@ let db_connection : (env, Caqti_miou.connection) Vif.Device.device =
Logs.info (fun m -> m "database connection initialized"); Logs.info (fun m -> m "database connection initialized");
conn) conn)
module Secmod_signkey = struct let secmod =
(* TODO
- key rotation
- how many signkey to use?
we just use 1 for now *)
type t = {
sm_key: Signkey.t;
keys: Signkey.t list;
}
let dir = Fpath.(v "data" / "secmod_signkey")
let store_secmod_data t =
let* () = Data_file.write_eddsa Fpath.(dir / "sm_key") t.sm_key.priv in
t.keys
|> List.mapi (fun i key ->
let fname = Fpath.(dir / string_of_int i) in
(fname, key.Signkey.priv))
|> list_iter (fun (fname, key) -> Data_file.write_eddsa fname key)
let load conn =
let error_invalid_state =
Fmt.error_msg "secmod_signkey load error: invalid store state."
in
let* sm_key = Data_file.load_signkey conn Fpath.(dir / "sm_key") in
let* keys =
let l = List.init 1 (fun i -> Fpath.(dir / string_of_int i)) in
let* l =
Syntax.list_map (fun fname -> Data_file.load_signkey conn fname) l
in
match Syntax.opt_list l with
| Error () -> error_invalid_state
| Ok opt -> Ok opt
in
match (sm_key, keys) with
| None, None -> Ok None
| Some sm_key, Some keys -> Ok (Some { sm_key; keys })
| _, _ -> error_invalid_state
let generate_fresh_secmod_data () =
let sm_key = Signkey.generate () in
let keys = [ Signkey.generate () ] in
{ sm_key; keys }
let v =
let finally _key = () in let finally _key = () in
Vif.Device.v ~name:"secmod_signkey" ~finally Vif.Device.v ~name:"secmod" ~finally [ Vif.Device.value db_connection ]
[ Vif.Device.value db_connection ] @@ fun (module Conn : Pg.CONN) (_env : env) ->
@@ fun conn (_env : env) -> let sm : (module Secmod.S) = (module Secmod.Make (Conn)) in
match load conn with sm
| Ok None ->
let t = generate_fresh_secmod_data () in
Logs.info (fun m -> m "secmod_signkey initialized with fresh keys");
t
| Ok (Some v) ->
Logs.info (fun m -> m "secmod_signkey initialized from storage");
v
| Error _ ->
(* TODO error: pretty print *)
Fmt.failwith "secmod_signkey init failure."
end
module Secmod_denom = struct
type t = {
sm_key: Signkey.t;
keys: Denomination.t list;
}
let dir = Fpath.(v "data" / "secmod_signkey")
let store_secmod_data t =
let* () = Data_file.write_eddsa Fpath.(dir / "sm_key") t.sm_key.priv in
t.keys
|> List.mapi (fun i key ->
let fname = Fpath.(dir / string_of_int i) in
(fname, key.Denomination.priv))
|> list_iter (fun (fname, key) -> Data_file.write_rsa fname key)
let load conn =
let error_invalid_state =
Fmt.error_msg "secmod_denom load error: invalid store state."
in
let* sm_key = Data_file.load_signkey conn Fpath.(dir / "sm_key") in
let* keys =
let* l =
let open Config.Coin in
Syntax.list_map
(fun coin ->
let section_name = coin.section_name in
let fname = Fpath.(dir / section_name) in
(* todo: could check that coin config match db values *)
Data_file.load_denom conn ~section_name fname)
all_coins
in
match Syntax.opt_list l with
| Error () -> error_invalid_state
| Ok opt -> Ok opt
in
match (sm_key, keys) with
| None, None -> Ok None
| Some sm_key, Some keys -> Ok (Some { sm_key; keys })
| _, _ -> error_invalid_state
let generate_fresh_secmod_data () =
let sm_key = Signkey.generate () in
let keys = List.map Denomination.make Config.Coin.all_coins in
{ sm_key; keys }
let v =
let finally _key = () in
Vif.Device.v ~name:"secmod_denom" ~finally
[ Vif.Device.value db_connection ]
@@ fun conn (_env : env) ->
match load conn with
| Ok None ->
let t = generate_fresh_secmod_data () in
Logs.info (fun m -> m "secmod_denom initialized with fresh keys");
t
| Ok (Some v) ->
Logs.info (fun m -> m "secmod_denom initialized from storage");
v
| Error _ -> Fmt.failwith "secmod_denom init failure."
end
let secmod_signkey = Secmod_signkey.v
let secmod_denom = Secmod_denom.v

266
src/http_keys.ml Normal file
View file

@ -0,0 +1,266 @@
open Syntax
open Api
module String_map = Stdlib.Map.Make (Stdlib.String)
(* TODO
for now we only have one item in each "denom group"
change this once we have denom/signkey rotation *)
let denomgroup_of_denomdata
Denom_data.
{
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;
revoked_sig= _;
} =
let master_sig = match master_sig with None -> assert false | Some v -> v in
let denoms =
[
RsaDenom.
{
rsa_pub= pub;
master_sig;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
lost= None;
};
]
in
DenomGroup.Rsa
RsaDenomGroup.
{ denoms; value; fee_withdraw; fee_deposit; fee_refresh; fee_refund }
let mk_keys ~db_conn (module Sm : Secmod.S) ~last_issue_date =
let version = "0" in
let base_url = Config.base_url in
let currency = Config.currency in
let shopping_url = Config.shopping_url in
let open_banking_gateway = Config.open_banking_gateway_url in
let bank_compliance_language = Config.bank_compliance_language in
let currency_specification =
let v = Config.Currency.v in
let alt_unit_names =
Parse_config.Alt_unit_names.encode_exn v.alt_unit_names
in
CurrencySpecification.
{
name= v.name;
num_fractional_input_digits= v.fractional_input_digits;
num_fractional_normal_digits= v.fractional_normal_digits;
num_fractional_trailing_zero_digits= v.fractional_trailing_zero_digits;
alt_unit_names;
common_amounts= [];
}
in
let tiny_amount = Config.tiny_amount in
let stefan_abs = Config.stefan_abs in
let stefan_log = Config.stefan_log in
let stefan_lin = Config.stefan_lin in
(* todo asset_type
Type of the asset. "fiat", "crypto", "regional" or "stock". *)
let asset_type = "xxx" in
let* accounts = Pg.get_wire_accounts db_conn |> unwrap_err_caqti in
let* wire_fees =
(* todo
where does wire_methods comes from? *)
let wire_method = "xxx" in
let+ wire_fees =
Pg.get_wire_fees db_conn ~wire_method |> unwrap_err_caqti
in
String_map.singleton wire_method wire_fees
in
let wads =
(* TODO wads *)
[]
in
let rewards_allowed = false in
let kyc_enabled = false in
let disable_direct_deposit = (* todo *) false in
let master_public_key = Config.master_public_key in
let reserve_closing_delay =
Some Config.Exchangedb.idle_reserve_expiration_time
in
(* todo *)
let wallet_balance_limit_without_kyc = None in
let hard_limits = [] in
let zero_limits = [] in
let denom_data_l =
(* TODO sm-db *)
(*Pg.get_denominations db_conn |> unwrap_err_caqti *)
Sm.get_denoms_data ()
in
let denom_data_l =
(* reverse chronological order *)
List.sort
(fun a b -> Stdlib.compare b.Denom_data.stamp_start a.stamp_start)
denom_data_l
in
let list_issue_date =
match denom_data_l with [] -> None | v :: _ -> v.Denom_data.stamp_start
in
let denominations =
let open Denom_data in
(* TODO time
truncated timestamps to int for comparison *)
let timestamp_to_int = function
| None -> 0
| Some ptime -> ptime |> Ptime.to_float_s |> Int.of_float
in
(* if `?last_issue_date` query param does not exactly match the `stamp_start`
of one of the denomination keys, all keys are returned *)
let l =
match last_issue_date with
| None -> denom_data_l
| Some last_issue_date -> (
match
List.find_opt
(fun v -> timestamp_to_int v.stamp_start = last_issue_date)
denom_data_l
with
| None -> denom_data_l
| Some _ ->
List.filter
(fun v -> timestamp_to_int v.stamp_start >= last_issue_date)
denom_data_l)
in
List.map denomgroup_of_denomdata l
in
let signkeys =
(* TODO sm-db
use database signkey data / verify secmod and database are in sync *)
(*let+ signkey_data_l = Pg.get_active_signkeys db_conn |> unwrap_err_caqti in*)
let signkey_data_l = Sm.get_signkeys_data () in
let signkey_data_l =
List.sort
(fun a b ->
let open Signkey_data in
Stdlib.compare b.stamp_start a.stamp_start)
signkey_data_l
in
List.filter_map
(fun Signkey_data.
{
pub;
stamp_start;
stamp_expire;
stamp_end;
master_sig;
revoked_sig= _;
} ->
match master_sig with
| None -> None
| Some master_sig ->
Some
SignKey.
{ key= pub; stamp_start; stamp_expire; stamp_end; master_sig })
signkey_data_l
in
let exchange_pub =
(* the eddsa pub key used to sign exchange_sig *)
match signkeys with
| [] -> Fmt.failwith "exchange has no active signkey"
| v :: _ -> v.SignKey.key
in
let exchange_sig =
(* Compact EdDSA signature (binary-only) over the
contatentation of all of the master_sigs (in reverse
chronological order by group) in the arrays under "denominations". *)
let hc =
denom_data_l
|> List.filter_map (fun v -> v.Denom_data.master_sig)
|> List.map Bin_sig.DenominationKeyValidity.to_octets
|> String.concat ""
|> Bin_type.Hash_64.hash
in
let open Bin_sig.ExchangeKeySet in
sign_f ~f:(Sm.sign_with_signkey ~pub:exchange_pub) R.{ list_issue_date; hc }
in
let recoup = (* TODO /recoup *) [] in
let* global_fees =
Pg.get_global_fees db_conn ~start_date:Timestamp.epoch |> unwrap_err_caqti
in
let* auditors =
(* TODO /auditors/$AUDITOR_PUB/$H_DENOM_PUB *)
(* does not contains auditor_keys with empty denomination_keys *)
Pg.get_auditor_keys db_conn
in
let extensions = None in
let extensions_sig = None in
Ok
ExchangeKeysResponse.
{
version;
base_url;
currency;
shopping_url;
open_banking_gateway;
bank_compliance_language;
currency_specification;
tiny_amount;
stefan_abs;
stefan_log;
stefan_lin;
asset_type;
accounts;
wire_fees;
wads;
rewards_allowed;
kyc_enabled;
disable_direct_deposit;
master_public_key;
reserve_closing_delay;
wallet_balance_limit_without_kyc;
hard_limits;
zero_limits;
denominations;
exchange_sig;
exchange_pub;
recoup;
global_fees;
list_issue_date;
auditors;
signkeys;
extensions;
extensions_sig;
}
let jsont = ExchangeKeysResponse.jsont
(* TODO query param ?last_issue_date *)
let f req server _env =
Logs.info (fun m -> m "GET /keys/");
let db_conn = Vif.Server.device Devices.db_connection server in
let sm = Vif.Server.device Devices.secmod server in
let last_issue_date =
match Vif.Queries.get req "last_issue_date" with
| [] -> None
| v :: _ -> (
(* TODO time *)
match float_of_string_opt v with
| None ->
Fmt.failwith
"invalid `?last_issue_date` query param, float_of_string failure"
| Some v -> Some (Int.of_float v))
in
let res =
(*let last_issue_date = Ptime_clock.now () |> Option.some in*)
let* v = mk_keys ~db_conn sm ~last_issue_date in
let s = Api.encode_exn jsont v in
Ok s
in
Respond_util.respond_with_res res req

752
src/http_management.ml Normal file
View file

@ -0,0 +1,752 @@
open Syntax
open Api
module Keys_get = struct
let mk_future_denom (module Sm : Secmod.S) ~section_name
({
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= _;
revoked_sig= _;
} :
Denom_data.t) =
let denom_pub =
DenominationKey.of_rsa RsaDenominationKey.{ age_mask; rsa_pub= pub }
in
let denom_secmod_sig =
let open Bin_sig.DenominationKeyAnnouncement in
let h_denom_pub = h_pub in
let h_section_name = Bin_type.Hash_64_cstr.hash section_name in
let anchor_time = stamp_start in
let duration_withdraw =
Timestamp.diff stamp_start stamp_expire_withdraw
in
sign_f ~f:Sm.sign_with_sm_key
{ h_denom_pub; h_section_name; anchor_time; duration_withdraw }
in
FutureDenom.
{
section_name;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
denom_pub;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
denom_secmod_sig;
}
let mk_future_signkey (module Sm : Secmod.S)
({
pub;
stamp_start;
stamp_expire;
stamp_end;
master_sig= _;
revoked_sig= _;
} :
Signkey_data.t) =
let signkey_secmod_sig =
let open Bin_sig.SigningKeyAnnouncement in
let exchange_pub = pub in
let anchor_time = stamp_start in
let duration = Timestamp.diff stamp_start stamp_expire in
sign_f ~f:Sm.sign_with_sm_key { exchange_pub; anchor_time; duration }
in
FutureSignKey.
{ key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }
let mk_future_keys_response (module Sm : Secmod.S) =
let future_signkeys =
Sm.get_signkeys_data ()
|> List.filter (fun k -> Option.is_none k.Signkey_data.master_sig)
|> List.map (fun signkey -> mk_future_signkey (module Sm) signkey)
in
let future_denoms =
Sm.get_denoms_data ()
|> List.filter (fun k -> Option.is_none k.Denom_data.master_sig)
|> List.map (fun dn_data ->
let opt = Sm.find_denom_section_name dn_data.Denom_data.h_pub in
match opt with
| None -> Fmt.failwith "section_name not found."
| Some section_name ->
mk_future_denom (module Sm) ~section_name dn_data)
in
let master_pub = Config.Exchange.master_public_key in
let denom_secmod_public_key = Sm.get_sm_key_pub () in
let signkey_secmod_public_key = Sm.get_sm_key_pub () in
FutureKeysResponse.
{
future_denoms;
future_signkeys;
master_pub;
denom_secmod_public_key;
signkey_secmod_public_key;
}
let jsont = FutureKeysResponse.jsont
let f req server _env =
Logs.info (fun m -> m "GET /management/keys/");
let sm = Vif.Server.device Devices.secmod server in
let res =
let v = mk_future_keys_response sm in
let s = Api.encode_exn jsont v in
Ok s
in
Respond_util.respond_with_res res req
end
module Keys_post = struct
let verify_denom_signature (module Sm : Secmod.S)
DenomSignature.{ h_denom_pub; master_sig } =
let* denom =
match Sm.find_denom_data h_denom_pub with
| None ->
Fmt.error
"404 not found, One of the keys for which a signature was provided \
is unknown to the exchange."
| Some denom -> Ok denom
in
let open Bin_sig.DenominationKeyValidity in
let r : r =
{
master= Config.master_public_key;
start= denom.stamp_start;
expire_withdraw= denom.stamp_expire_withdraw;
expire_spend= denom.stamp_expire_deposit;
expire_legal= denom.stamp_expire_legal;
value= denom.value;
fee_withdraw= denom.fee_withdraw;
fee_deposit= denom.fee_deposit;
fee_refresh= denom.fee_refresh;
denom_hash= h_denom_pub;
}
in
verify_f ~f:Sm.verify_with_master_key master_sig r
let verify_signkey_signature (module Sm : Secmod.S)
SignKeySignature.{ key; master_sig } =
let* signkey =
match Sm.find_signkey_data key with
| None ->
Fmt.error
"404 not found, One of the keys for which a signature was provided \
is unknown to the exchange."
| Some signkey -> Ok signkey
in
let open Bin_sig.ExchangeSigningKeyValidity in
let r : r =
{
start= signkey.stamp_start;
expire= signkey.stamp_expire;
end_= signkey.stamp_end;
signkey_pub= signkey.pub;
}
in
verify_f ~f:Sm.verify_with_master_key master_sig r
let verify sm MasterSignatures.{ denom_sigs; signkey_sigs } =
let* () = list_iter (verify_denom_signature sm) denom_sigs in
let* () = list_iter (verify_signkey_signature sm) signkey_sigs in
Ok ()
(* TODO move to test *)
let check_master_signatures_update ~db_conn (module Sm : Secmod.S) =
Sm.get_denoms_data ()
|> list_iter (fun denom ->
let error = Error "update_master_signatures sanity check failure" in
let* opt =
Pg.find_denom db_conn denom.Denom_data.h_pub |> unwrap_err_caqti
in
let* v = match opt with None -> error | Some v -> Ok v in
let check = function false -> error | true -> Ok () in
let* () =
check (Timestamp.compare v.stamp_start denom.stamp_start = Some 0)
in
let* () = check (v.value = denom.value) in
let* () = check (v.fee_refund = denom.fee_refund) in
let* () = check (v.age_mask = denom.age_mask) in
Ok ())
let do_ ~db_conn (module Sm : Secmod.S)
MasterSignatures.{ denom_sigs; signkey_sigs } =
let* () =
signkey_sigs
|> List.map (fun SignKeySignature.{ key; master_sig } ->
(key, master_sig))
|> Sm.add_signkey_master_signatures
in
let* () =
denom_sigs
|> List.map (fun DenomSignature.{ h_denom_pub; master_sig } ->
(h_denom_pub, master_sig))
|> Sm.add_denom_master_signatures
in
let* () = Sm.store () in
let* () = check_master_signatures_update ~db_conn (module Sm) in
Ok ()
let jsont = MasterSignatures.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/keys/");
let db_conn = Vif.Server.device Devices.db_connection server in
let sm = Vif.Server.device Devices.secmod server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm v in
let* () = do_ ~db_conn sm v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Denom_revoke = struct
let verify (module Sm : Secmod.S) h_denom_pub
DenomRevocationSignature.{ master_sig } =
let open Bin_sig.MasterDenominationKeyRevocation in
verify_f ~f:Sm.verify_with_master_key master_sig { h_denom_pub }
let do_ ~db_conn (module Sm : Secmod.S) h_denom_pub
DenomRevocationSignature.{ master_sig } =
let* () = Sm.revoke_denomination h_denom_pub master_sig in
let+ () =
Pg.insert_denomination_revocation db_conn h_denom_pub master_sig
|> unwrap_err_caqti
in
()
let jsont = DenomRevocationSignature.jsont
let f req h_denom_pub server _env =
Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/");
let db_conn = Vif.Server.device Devices.db_connection server in
let sm = Vif.Server.device Devices.secmod server in
let res =
let* h_denom_pub = DenominationHash.of_b32 h_denom_pub in
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm h_denom_pub v in
let* () = do_ ~db_conn sm h_denom_pub v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Signkey_revoke = struct
let verify (module Sm : Secmod.S) exchange_pub
SignkeyRevocationSignature.{ master_sig } =
let open Bin_sig.MasterSigningKeyRevocation in
verify_f ~f:Sm.verify_with_master_key master_sig { exchange_pub }
let do_ ~db_conn (module Sm : Secmod.S) exchange_pub
SignkeyRevocationSignature.{ master_sig } =
let* () = Sm.revoke_signkey exchange_pub master_sig in
let+ () =
Pg.insert_signkey_revocation db_conn exchange_pub master_sig
|> unwrap_err_caqti
in
()
let jsont = SignkeyRevocationSignature.jsont
let f req exchange_pub server _env =
Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/");
let db_conn = Vif.Server.device Devices.db_connection server in
let sm = Vif.Server.device Devices.secmod server in
let res =
let* exchange_pub = Crypto.EddsaPublicKey.of_b32 exchange_pub in
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm exchange_pub v in
let* () = do_ ~db_conn sm exchange_pub v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Auditors = struct
let verify (module Sm : Secmod.S)
AuditorSetupMessage.
{
auditor_url;
auditor_name= _;
auditor_pub;
master_sig;
validity_start;
} =
let open Bin_sig.MasterAddAuditor in
verify_f ~f:Sm.verify_with_master_key master_sig
{
start_date= validity_start;
auditor_pub;
h_auditor_url= Bin_type.Hash_64_cstr.hash auditor_url;
}
(* TODO timestamps last_change +/- checks *)
(* todo: there is something about use of monotonic time
+ protection against replay attack that I don't understand *)
let do_ ~db_conn v =
let auditor_pub = v.AuditorSetupMessage.auditor_pub in
let validity_start = v.AuditorSetupMessage.validity_start in
let* last_date_opt =
Pg.get_auditor_timestamp db_conn auditor_pub |> unwrap_err_caqti
in
match last_date_opt with
| None ->
let+ () = Pg.insert_auditor db_conn v |> unwrap_err_caqti in
Logs.info (fun m -> m "enabled auditor");
()
| Some last_date ->
let cmp = Timestamp.compare last_date validity_start |> Option.get in
if cmp > 0 then
Error
"database has more recent auditor data for this auditor public key"
else
let+ () = Pg.update_auditor db_conn v |> unwrap_err_caqti in
Logs.info (fun m -> m "updated auditor");
()
let jsont = AuditorSetupMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/auditors/");
let sm = Vif.Server.device Devices.secmod server in
let db_conn = Vif.Server.device Devices.db_connection server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm v in
let* () = do_ ~db_conn v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Auditors_disable = struct
let verify (module Sm : Secmod.S) auditor_pub
AuditorTeardownMessage.{ master_sig; validity_end } =
let open Bin_sig.MasterDelAuditor in
verify_f ~f:Sm.verify_with_master_key master_sig
{ end_date= validity_end; auditor_pub }
let do_ ~db_conn auditor_pub
AuditorTeardownMessage.{ master_sig= _; validity_end } =
let* last_date_opt =
Pg.get_auditor_timestamp db_conn auditor_pub |> unwrap_err_caqti
in
match last_date_opt with
| None -> Error "auditor not found"
| Some last_date ->
let cmp = Timestamp.compare last_date validity_end |> Option.get in
if cmp > 0 then
Error
"database has more recent auditor data for this auditor public key"
else
let+ () =
Pg.disable_auditor db_conn ~auditor_pub ~change_date:validity_end
|> unwrap_err_caqti
in
()
let jsont = AuditorTeardownMessage.jsont
let f req auditor_pub server _env =
Logs.info (fun m -> m "POST /management/auditors/$AUDITOR_PUB/revoke/");
let sm = Vif.Server.device Devices.secmod server in
let db_conn = Vif.Server.device Devices.db_connection server in
let res =
let* auditor_pub = Crypto.EddsaPublicKey.of_b32 auditor_pub in
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm auditor_pub v in
let* () = do_ ~db_conn auditor_pub v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Wire_fee = struct
let verify (module Sm : Secmod.S)
WireFeeSetupMessage.
{
wire_method;
master_sig_wire;
fee_start;
fee_end;
closing_fee;
wire_fee;
} =
let open Bin_sig.MasterWireFee in
verify_f ~f:Sm.verify_with_master_key master_sig_wire
{
h_wire_method= Bin_type.Hash_64_cstr.hash wire_method;
start_date= fee_start;
end_date= fee_end;
wire_fee;
closing_fee;
}
let do_ ~db_conn (v : WireFeeSetupMessage.t) =
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_err_caqti
in
match wire_fees with
| [] ->
let+ () = Pg.insert_wire_fee db_conn v |> unwrap_err_caqti 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"
| true ->
Logs.info (fun m -> m "an identical wire-fee was already setup");
Ok ())
| _ ->
Error
"invalid database state, multiple wire-fee found in database for \
this time frame"
let jsont = WireFeeSetupMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/wire-fee/");
let sm = Vif.Server.device Devices.secmod server in
let db_conn = Vif.Server.device Devices.db_connection server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm v in
let* () = do_ ~db_conn v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Global_fees = struct
let verify (module Sm : Secmod.S)
GlobalFees.
{
start_date;
end_date;
history_fee;
account_fee;
purse_fee;
history_expiration;
purse_account_limit;
purse_timeout;
master_sig;
} =
(* TODO KYC
what is kyc_timeout, kyc_fee ? *)
let kyc_timeout = None in
let kyc_fee = Amount.dummy_value in
(* * *)
let open Bin_sig.GlobalFees in
verify_f ~f:Sm.verify_with_master_key master_sig
{
start_date;
end_date;
purse_timeout;
kyc_timeout;
history_expiration;
history_fee;
kyc_fee;
account_fee;
purse_fee;
purse_account_limit;
}
let do_ ~db_conn v =
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_err_caqti
in
match global_fees with
| [] ->
let+ () = Pg.insert_global_fees db_conn v |> unwrap_err_caqti 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"
| true ->
Logs.info (fun m -> m "an identical global-fees was already setup");
Ok ())
| _ ->
Error
"invalid database state, multiple global-fees found in database for \
this time frame"
let jsont = GlobalFees.jsont
(* TODO global_fees
ensure it is defined for the current time.
there should be only one global_fees for each moment in time
and once set for a timeframe, it should not change. *)
let f req server _env =
Logs.info (fun m -> m "POST /management/global-fees/");
let sm = Vif.Server.device Devices.secmod server in
let db_conn = Vif.Server.device Devices.db_connection server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm v in
let* () = do_ ~db_conn v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Wire = struct
let verify (module Sm : Secmod.S)
WireSetupMessage.
{
payto_uri;
master_sig_wire;
master_sig_add;
validity_start;
bank_label= _;
priority= _;
} =
(* TODO wire *)
let conversion_url = "" in
let credit_restrictions = "" in
let debit_restrictions = "" in
let open Bin_type in
let* () =
let open Bin_sig.MasterWireDetails in
verify_f ~f:Sm.verify_with_master_key master_sig_wire
{
h_wire_details= FullPaytoHash.hash payto_uri;
h_conversion_url= Hash_64_cstr.hash conversion_url;
h_credit_restrictions= Hash_64_cstr.hash credit_restrictions;
h_debit_restrictions= Hash_64_cstr.hash debit_restrictions;
}
in
let* () =
let open Bin_sig.MasterAddWire in
verify_f ~f:Sm.verify_with_master_key master_sig_add
{
start_date= validity_start;
h_wire= FullPaytoHash.hash payto_uri;
h_conversion_url= Hash_64_cstr.hash conversion_url;
h_credit_restrictions= Hash_64_cstr.hash credit_restrictions;
h_debit_restrictions= Hash_64_cstr.hash debit_restrictions;
}
in
Ok ()
let do_ ~db_conn v =
let* last_change_opt =
let payto_uri = v.WireSetupMessage.payto_uri in
Pg.get_wire_timestamp db_conn ~payto_uri |> unwrap_err_caqti
in
match last_change_opt with
| Some _ -> Error "wire already setup"
| None ->
(* TODO wire *)
let last_change = Ptime_clock.now () |> Option.some in
let v =
ExchangeWireAccount.
{
payto_uri= v.payto_uri;
conversion_url= None;
debit_restrictions= [];
credit_restrictions= [];
master_sig= v.master_sig_wire;
bank_label= v.bank_label;
priority= v.priority;
}
in
let+ () = Pg.insert_wire db_conn ~last_change v |> unwrap_err_caqti in
()
let jsont = WireSetupMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/wire/");
let sm = Vif.Server.device Devices.secmod server in
let db_conn = Vif.Server.device Devices.db_connection server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm v in
let* () = do_ ~db_conn v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Wire_disable = struct
let verify (module Sm : Secmod.S)
WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } =
let open Bin_sig.MasterDelWire in
verify_f ~f:Sm.verify_with_master_key master_sig_del
{ end_date= validity_end; h_wire= Bin_type.FullPaytoHash.hash payto_uri }
let do_ ~db_conn
WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } =
let* last_change_opt =
Pg.get_wire_timestamp db_conn ~payto_uri |> unwrap_err_caqti
in
match last_change_opt with
| None -> Error "wire not found"
| Some _ ->
let+ () =
Pg.disable_wire db_conn ~payto_uri ~validity_end |> unwrap_err_caqti
in
()
let jsont = WireTeardownMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/wire/disable/");
let sm = Vif.Server.device Devices.secmod server in
let db_conn = Vif.Server.device Devices.db_connection server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm v in
let* () = do_ ~db_conn v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Drain = struct
let verify (module Sm : Secmod.S)
DrainProfitsMessage.
{
debit_account_section;
credit_payto_uri;
wtid;
master_sig;
date;
amount;
} =
let open Bin_sig.MasterDrainProfit in
let open Bin_type in
verify_f ~f:Sm.verify_with_master_key master_sig
{
wtid;
date;
amount;
h_section= Hash_64_cstr.hash debit_account_section;
h_payto= FullPaytoHash.hash credit_payto_uri;
}
let do_ ~db_conn v =
let+ () = Pg.insert_drain_profit db_conn v |> unwrap_err_caqti in
()
let jsont = DrainProfitsMessage.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/drain/");
let sm = Vif.Server.device Devices.secmod server in
let db_conn = Vif.Server.device Devices.db_connection server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm v in
let* () = do_ ~db_conn v in
Ok ""
in
Respond_util.respond_with_res res req
end
module AmlOfficer = struct
let verify (module Sm : Secmod.S)
AmlOfficerSetup.
{
officer_pub;
officer_name;
is_active;
read_only= _;
master_sig;
change_date;
} =
let open Bin_sig.MasterAmlOfficerStatus in
let is_active = match is_active with true -> 1_l | false -> 0_l in
verify_f ~f:Sm.verify_with_master_key master_sig
{
change_date;
officer_pub;
h_officer_name= Bin_type.Hash_64_cstr.hash officer_name;
is_active;
}
let do_ ~db_conn v =
let+ _last_change = Pg.insert_aml_officer db_conn v |> unwrap_err_caqti in
()
let jsont = AmlOfficerSetup.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/aml-officers/");
let sm = Vif.Server.device Devices.secmod server in
let db_conn = Vif.Server.device Devices.db_connection server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm v in
let* () = do_ ~db_conn v in
Ok ""
in
Respond_util.respond_with_res res req
end
module Partners = struct
let verify (module Sm : Secmod.S)
ExchangePartnerSetupRequest.
{
partner_base_url;
partner_pub;
wad_frequency;
master_sig;
start_date;
end_date;
wad_fee;
} =
let open Bin_sig.PartnerConfiguration in
verify_f ~f:Sm.verify_with_master_key master_sig
{
partner_pub;
start_date;
end_date;
wad_frequency;
wad_fee;
h_url= Bin_type.Hash_64_cstr.hash partner_base_url;
}
let do_ ~db_conn v =
let+ () = Pg.insert_partner db_conn v |> unwrap_err_caqti in
()
let jsont = ExchangePartnerSetupRequest.jsont
let f req server _env =
Logs.info (fun m -> m "POST /management/partners/");
let sm = Vif.Server.device Devices.secmod server in
let db_conn = Vif.Server.device Devices.db_connection server in
let res =
let* v = Vif.Request.of_json req |> unwrap_err_msg in
let* () = verify sm v in
let* () = do_ ~db_conn v in
Ok ""
in
Respond_util.respond_with_res res req
end

112
src/management.ml
View file

@ -1,112 +0,0 @@
open Api
open Devices
let mk_future_denom denom_key_signf
({
pub;
priv= _;
section_name;
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= _;
} :
Denomination.t) =
let denom_pub =
DenominationKey.of_rsa RsaDenominationKey.{ age_mask; rsa_pub= pub }
in
let denom_secmod_sig =
let open Bin_signature.DenominationKeyAnnouncementPS in
let h_denom_pub = h_pub in
let h_section_name = Bin_type.Hash_64_cstr.hash section_name in
let anchor_time = stamp_start in
let duration_withdraw =
Timestamp.diff stamp_start stamp_expire_withdraw |> Timestamp.of_span_exn
in
Sig.sign denom_key_signf
{ h_denom_pub; h_section_name; anchor_time; duration_withdraw }
in
FutureDenom.
{
section_name;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
denom_pub;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
denom_secmod_sig;
}
let mk_future_signkey signkey_signf
({ pub; priv= _; stamp_start; stamp_expire; stamp_end; master_sig= _ } :
Signkey.t) =
let signkey_secmod_sig =
let open Bin_signature.SigningKeyAnnouncementPS in
let exchange_pub = pub in
let anchor_time = stamp_start in
let duration =
Timestamp.diff stamp_start stamp_expire |> Timestamp.of_span_exn
in
{ exchange_pub; anchor_time; duration }
|> Bin.to_string bin
|> signkey_signf
in
FutureSignKey.
{ key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig }
let mk_future_keys_response (secmod_signkey : Secmod_signkey.t)
(secmod_denom : Secmod_denom.t) =
let future_denoms =
secmod_denom.keys
|> List.filter (fun k -> Option.is_none k.Denomination.master_sig)
|> List.map (fun denom ->
let signf s =
Crypto.EddsaSignature.sign_as_string
~key:secmod_denom.sm_key.Signkey.priv s
in
mk_future_denom signf denom)
in
let future_signkeys =
secmod_signkey.keys
|> List.filter (fun k -> Option.is_none k.Signkey.master_sig)
|> List.map (fun signkey ->
let signf s =
Crypto.EddsaSignature.sign ~key:secmod_denom.sm_key.Signkey.priv s
in
mk_future_signkey signf signkey)
in
let master_pub = Config.Exchange.master_public_key in
let denom_secmod_public_key = secmod_denom.sm_key.pub in
let signkey_secmod_public_key = secmod_signkey.sm_key.pub in
FutureKeysResponse.
{
future_denoms;
future_signkeys;
master_pub;
denom_secmod_public_key;
signkey_secmod_public_key;
}
let keys_get req server _env =
let open Vif.Response in
let open Syntax in
let secmod_signkey = Vif.Server.device Devices.secmod_signkey server in
let secmod_denom = Vif.Server.device Devices.secmod_denom server in
let v = mk_future_keys_response secmod_signkey secmod_denom in
let s = Api.encode_exn Api.FutureKeysResponse.jsont v in
let* () = with_string req s in
let* () = add ~field:"content-type" "application/json" in
respond `OK

42
src/mte.ml
View file

@ -23,13 +23,40 @@ let hello req _server _env =
let routes = let routes =
let open Vif.Uri in let open Vif.Uri in
let open Vif.Route in let open Vif.Route in
(*let open Vif.Type in*) let get_ path = get (path /?? any) in
let post path jsont = post (Vif.Type.json_encoding jsont) (path /?? any) in
let tos =
let v s = rel / s in
[ [
get (rel /?? nil) --> hello; get_ rel --> hello;
get (rel / "terms" /?? nil) --> Static.terms; get_ (v "terms") --> Static.terms;
get (rel / "privacy" /?? nil) --> Static.privacy; get_ (v "privacy") --> Static.privacy;
get (rel / "management" / "keys" /?? nil) --> Management.keys_get;
] ]
in
let status_info = [ get_ (rel / "keys") --> Http_keys.f ] in
let management =
let open Http_management in
let v s = rel / "management" / s in
[
get_ (v "keys") --> Keys_get.f;
post (v "keys") Keys_post.jsont --> Keys_post.f;
post (v "denominations" /% string `Path / "revoke") Denom_revoke.jsont
--> Denom_revoke.f;
post (v "signkeys" /% string `Path / "revoke") Signkey_revoke.jsont
--> Signkey_revoke.f;
post (v "auditors") Auditors.jsont --> Auditors.f;
post (v "auditors" /% string `Path / "disable") Auditors_disable.jsont
--> Auditors_disable.f;
post (v "wire-fee") Wire_fee.jsont --> Wire_fee.f;
post (v "global-fees") Global_fees.jsont --> Global_fees.f;
post (v "wire") Wire.jsont --> Wire.f;
post (v "wire" / "disable") Wire_disable.jsont --> Wire_disable.f;
post (v "drain") Drain.jsont --> Drain.f;
post (v "aml-officers") AmlOfficer.jsont --> AmlOfficer.f;
post (v "partners") Partners.jsont --> Partners.f;
]
in
tos @ status_info @ management
let () = let () =
Util.Log_reporter.setup (); Util.Log_reporter.setup ();
@ -43,10 +70,7 @@ let () =
let env : Devices.env = let env : Devices.env =
{ caqti_switch; db_uri= Config.Exchangedb_postgres.config } { caqti_switch; db_uri= Config.Exchangedb_postgres.config }
in in
let devices = let devices = Vif.Devices.[ Devices.db_connection; Devices.secmod ] in
Vif.Devices.
[ Devices.db_connection; Devices.secmod_signkey; Devices.secmod_denom ]
in
let middlewares = Vif.Middlewares.[] in let middlewares = Vif.Middlewares.[] in
Logs.info (fun m -> Logs.info (fun m ->
m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server"); m ~tags:(Util.Log_reporter.detail "...") "Starting MTE server");

62
src/parse_config.ml
View file

@ -228,43 +228,35 @@ let ed25519 s =
|> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e) |> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e)
|> unwrap_res |> unwrap_res
module Parse_alt_unit_names = struct (* TODO
let rm_brackets s = move to another module
let s = String.trim s in can we type the json as a Int_map directly? *)
match module Alt_unit_names = struct
String.starts_with ~prefix:"{" s && String.ends_with ~suffix:"}" s open Syntax
with module String_map = Map.Make (String)
| false -> fail "expected json, got `%s`" s
| true ->
let s = String.sub s 1 (String.length s - 2) in
s
let rm_quotes s = let string_map_jsont = Jsont.Object.as_string_map Jsont.string
let s = String.trim s in
match
String.starts_with ~prefix:"\"" s && String.ends_with ~suffix:"\"" s
with
| false -> fail "expected quoted string, got `%s`" s
| true ->
let s = String.sub s 1 (String.length s - 2) in
s
let parse s = let decode s =
let s = rm_brackets s in let* string_map = Jsont_bytesrw.decode_string string_map_jsont s in
String.split_on_char ',' s let l = String_map.to_list string_map in
|> List.map (String.split_on_char ':') let* l =
|> List.map (function list_map
| [ k; v ] -> (k, v) (fun (k, v) ->
| _ -> fail "invalid json key-value map")
|> List.map (fun (k, v) ->
let k = rm_quotes k in
let v = rm_quotes v in
let k =
match int_of_string_opt k with match int_of_string_opt k with
| None -> | None -> Error "alt_unit_names has a non-integer key"
fail "invalid json key-value map, expected integer key, got `%s`" | Some k -> Ok (k, v))
k l
| Some k -> k
in in
(k, v)) match List.find_opt (fun (i, _) -> i = 0) l with
| None -> Error "alt_unit_names with no entry for base value \"0\""
| Some _ -> Ok l
let encode l =
let l = List.map (fun (k, v) -> (string_of_int k, v)) l in
let string_map = String_map.of_list l in
let+ s = Jsont_bytesrw.encode_string string_map_jsont string_map in
s
let encode_exn l = encode l |> Result.get_ok
end end

462
src/pg.ml
View file

@ -1,69 +1,32 @@
open Crypto (* TODO
module Caqti_type = struct check there is no issues with signed/unsigned integers
include Caqti_type
(* TODO add a dune stanza like for prelude: how to fix postgres/caqti tuple type?
"(flags (:standard -open Prelude))" *) try something with OID?
(* we want to use int64 timestamps, need to add boilerplate in each query for amounts
not postgresql built-in timestamp type *)
let ptime : Ptime.t option t = Timestamp.caqti
let time = Timestamp.caqti
let amount : Amount.t t = GNU Taler db-events?
let open Amount in it seems caqti/pgx does not support it
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)
let age_mask : int t = Caqti_type.int transaction
let rsa_public : RsaPublicKey.t t = should check validity of signatures got from db, for /management at least
let open RsaPublicKey in
custom
~encode:(fun v -> Ok (to_octets v))
~decode:(fun v -> Ok (of_octets v))
octets
let eddsa_public : EddsaPublicKey.t t = clean up caqti error type *)
let open EddsaPublicKey in (* TODO time
custom fix comparison with timestamp footgun *)
~encode:(fun v -> Ok (to_octets v))
~decode:(fun v -> Ok (of_octets v))
octets
let eddsa_signature : EddsaSignature.t t =
let open EddsaSignature in
custom
~encode:(fun v -> Ok (to_octets v))
~decode:(fun s -> Ok (of_octets s))
octets
include struct
(* alias for hash *)
open Bin_type
let fullpayto_hash = FullPaytoHash.caqti
let nomalizaedpayto_hash = NormalizedPaytoHash.caqti
let denomination_hash = DenominationHash.caqti
let privatecontract_hash = PrivateContractHash.caqti
let extensionspolicy_hash = ExtensionsPolicyHash.caqti
let merchantwire_hash = MerchantWireHash.caqti
let agecommitment_hash = AgeCommitmentHash.caqti
let blindedcoin_hash = BlindedCoinHash.caqti
let coinpub_hash = CoinPubHash.caqti
let outputcommitment_hash = OutputCommitmentHash.caqti
let planchets_hash = HashPlanchetsP.caqti
end
include Caqti_request.Infix
end
module type CONN = Caqti_miou.CONNECTION module type CONN = Caqti_miou.CONNECTION
open Bin_type module Caqti_type = struct
include Caqti_type
include Pg_type
include Caqti_request.Infix
end
open Crypto
open Api
let preflight = let preflight =
let l = let l =
@ -78,87 +41,336 @@ let preflight =
"SET search_path TO exchange;"; "SET search_path TO exchange;";
] ]
in in
fun (module Conn : Caqti_miou.CONNECTION) -> fun (module Conn : CONN) -> Syntax.list_iter (fun p -> Conn.exec p ()) l
Syntax.list_iter (fun p -> Conn.exec p ()) l
let lookup_signing_key = let find_signkey =
let lookup_signing_key = let find_signkey =
Caqti_type.(eddsa_public ->? t3 time time time) Caqti_type.(eddsa_pub ->? signkey_data)
"SELECT valid_from, expire_sign, expire_legal FROM exchange_sign_keys \ "SELECT esk.exchange_pub, esk.valid_from, esk.expire_sign, \
WHERE exchange_pub=$1" esk.expire_legal, esk.master_sig, skr.master_sig FROM \
exchange_sign_keys AS esk LEFT JOIN signkey_revocations AS skr ON \
esk.esk_serial = skr.esk_serial WHERE esk.exchange_pub=$1"
in in
fun (module Conn : CONN) (exchange_pub : EddsaPublicKey.t) -> fun (module Conn : CONN) (exchange_pub : EddsaPublicKey.t) ->
Conn.find_opt lookup_signing_key exchange_pub Conn.find_opt find_signkey exchange_pub
let activate_signing_key = let get_active_signkeys =
let get_active_signkeys =
Caqti_type.(time ->* signkey_data)
"SELECT esk.exchange_pub, esk.valid_from, esk.expire_sign, \
esk.expire_legal, esk.master_sig, NULL FROM exchange_sign_keys esk \
WHERE 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) ->
let now = Ptime_clock.now () |> Option.some in
Conn.collect_list get_active_signkeys now
(* note: does not update revocation *)
let insert_signkey = let insert_signkey =
Caqti_type.(t5 eddsa_public time time time eddsa_signature ->. unit) let insert_signkey =
Caqti_type.(signkey_data ->. unit)
"INSERT INTO exchange_sign_keys (exchange_pub, valid_from, expire_sign, \ "INSERT INTO exchange_sign_keys (exchange_pub, valid_from, expire_sign, \
expire_legal, master_sig) VALUES ($1, $2, $3, $4, $5)" expire_legal, master_sig) VALUES ($1, $2, $3, $4, $5)"
in in
fun (module Conn : CONN) v -> Conn.exec insert_signkey v
let find_denom =
let find_denom =
Caqti_type.(denomination_hash ->? denom_data)
"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, \
dn.denom_pub_hash, dn.master_sig, dnr.master_sig FROM denominations AS \
dn LEFT JOIN denomination_revocations AS dnr ON dn.denominations_serial \
= dnr.denominations_serial WHERE dn.denom_pub_hash=$1"
in
fun (module Conn : CONN) h_denom_pub -> Conn.find_opt find_denom h_denom_pub
let get_denominations =
let get_denominations =
Caqti_type.(unit ->* denom_data)
"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, \
dn.denom_pub_hash, dn.master_sig, dnr.master_sig FROM denominations AS \
dn LEFT JOIN denomination_revocations AS dnr ON dn.denominations_serial \
= dnr.denominations_serial"
in
fun (module Conn : CONN) -> Conn.collect_list get_denominations ()
(* note: does not update revocation *)
let insert_denom =
let insert_denom =
Caqti_type.(denom_data ->. 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 insert_denom v
let insert_denomination_revocation =
let denomination_revocation_insert =
let master_sig = Bin_sig.MasterDenominationKeyRevocation.caqti in
Caqti_type.(t2 denomination_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 denomination_revocation_insert (h_denom_pub, master_sig)
let insert_signkey_revocation =
let signkey_revocation_insert =
let master_sig = Bin_sig.MasterSigningKeyRevocation.caqti in
Caqti_type.(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 signkey_revocation_insert (exchange_pub, master_sig)
let get_auditor_timestamp =
let get_auditor_timestamp =
Caqti_type.(eddsa_pub ->? time)
"SELECT last_change FROM auditors WHERE auditor_pub=$1"
in
fun (module Conn : CONN) auditor_pub ->
Conn.find_opt get_auditor_timestamp auditor_pub
let insert_auditor =
let insert_auditor =
Caqti_type.(t4 eddsa_pub string string time ->. unit)
"INSERT INTO auditors (auditor_pub, auditor_name, auditor_url, \
is_active, last_change) VALUES ($1, $2, $3, true, $4)"
in
fun (module Conn : CONN) fun (module Conn : CONN)
Signkey.{ pub; priv= _; stamp_start; stamp_expire; stamp_end; master_sig } AuditorSetupMessage.
{ auditor_url; auditor_name; auditor_pub; master_sig= _; validity_start }
-> ->
(* TODO master_sig *) Conn.exec insert_auditor
let master_sig = master_sig |> Option.get in (auditor_pub, auditor_name, auditor_url, validity_start)
Conn.exec insert_signkey
(pub, stamp_start, stamp_expire, stamp_end, master_sig)
let lookup_denomination_key = let update_auditor =
let lookup_denomination_key = let update_auditor =
Caqti_type.( Caqti_type.(t5 eddsa_pub string string bool time ->. unit)
denomination_hash "UPDATE auditors SET auditor_url=$2, auditor_name=$3, is_active=$4, \
->? t10 time time time time amount amount amount amount amount age_mask) last_change=$5 WHERE auditor_pub=$1"
"SELECT valid_from, expire_withdraw, expire_deposit, expire_legal, coin, \
fee_withdraw, fee_deposit, fee_refresh, fee_refund, age_mask FROM \
denominations WHERE denom_pub_hash=$1"
in
fun (module Conn : CONN) (h_denom_pub : DenominationHash.t) ->
Conn.find_opt lookup_denomination_key h_denom_pub
let add_denomination_key =
let denomination_insert =
Caqti_type.(
t12 denomination_hash rsa_public eddsa_signature time time time time
amount amount amount amount (t2 amount age_mask)
->. unit)
"INSERT INTO denominations (denom_pub_hash, denom_pub, master_sig, \
valid_from, expire_withdraw, expire_deposit, expire_legal, coin, \
fee_withdraw, fee_deposit, fee_refresh, fee_refund, age_mask) VALUES \
($1, $2, $3, $4, $5, $6, $7, $8, $9, $10, $11, $12, $13)"
in in
fun (module Conn : CONN) fun (module Conn : CONN)
Denomination. AuditorSetupMessage.
{ auditor_url; auditor_name; auditor_pub; master_sig= _; validity_start }
->
Conn.exec update_auditor
(auditor_pub, auditor_url, auditor_name, true, validity_start)
let disable_auditor =
let update_auditor =
Caqti_type.(t5 eddsa_pub string string bool time ->. unit)
"UPDATE auditors SET auditor_url=$2, auditor_name=$3, is_active=$4, \
last_change=$5 WHERE auditor_pub=$1"
in
fun (module Conn : CONN) ~auditor_pub ~change_date ->
Conn.exec update_auditor (auditor_pub, "", "", false, change_date)
let insert_auditor_denom_sig =
let insert_auditor_denom_sig =
let auditor_sig = Bin_sig.ExchangeKeyValidity.caqti in
Caqti_type.(t3 eddsa_pub denomination_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 insert_auditor_denom_sig (auditor_pub, h_denom_pub, auditor_sig)
(* todo auditors
maybe check that url and name are unique/same for each auditor_pub
and do the ht logic out of pg.ml? *)
(* this does not return auditors that are not auditing any denom *)
let get_auditor_keys =
let get_auditor_keys =
let auditor_sig = Bin_sig.ExchangeKeyValidity.caqti in
Caqti_type.(
unit ->* t5 eddsa_pub string string denomination_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) ->
let open Syntax in
let* l = Conn.collect_list get_auditor_keys () |> unwrap_err_caqti in
let ht = Hashtbl.create 0xff in
List.iter
(fun (pub, url, name, denom_pub_h, auditor_sig) ->
let k = (pub, url, name) in
match Hashtbl.find_opt ht k with
| None -> Hashtbl.replace ht k [ (denom_pub_h, auditor_sig) ]
| Some l -> Hashtbl.replace ht k ((denom_pub_h, auditor_sig) :: l))
l;
let l = Hashtbl.to_seq ht |> List.of_seq in
let l =
List.map
(fun ((auditor_pub, auditor_url, auditor_name), auditor_denoms) ->
let denomination_keys =
List.map
(fun (denom_pub_h, auditor_sig) ->
AuditorDenominationKey.{ denom_pub_h; auditor_sig })
auditor_denoms
in
AuditorKeys.
{ auditor_pub; auditor_url; auditor_name; denomination_keys })
l
in
Ok l
let insert_wire_fee =
let insert_wire_fee =
let master_sig = Bin_sig.MasterWireFee.caqti in
Caqti_type.(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)
WireFeeSetupMessage.
{ {
pub; wire_method;
priv= _; master_sig_wire;
section_name= _; fee_start;
value; fee_end;
stamp_start; closing_fee;
stamp_expire_withdraw; wire_fee;
stamp_expire_deposit;
stamp_expire_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
age_mask;
h_pub;
master_sig;
} }
-> ->
(* TODO master_sig *) Conn.exec insert_wire_fee
let master_sig = master_sig |> Option.get in (wire_method, fee_start, fee_end, wire_fee, closing_fee, master_sig_wire)
Conn.exec denomination_insert
( h_pub, let get_wire_fees_by_time =
pub, let get_wire_fee_by_time =
master_sig, Caqti_type.(t3 wire_method time time ->* aggregate_transfer_fee)
stamp_start, "SELECT (wire_fee).*, (closing_fee).*, start_date, end_date, master_sig \
stamp_expire_withdraw, FROM wire_fee WHERE wire_method=$1 AND end_date > $2 AND start_date < \
stamp_expire_deposit, $3"
stamp_expire_legal, in
value, fun (module Conn : CONN) ~wire_method ~start_date ~end_date ->
fee_withdraw, Conn.collect_list get_wire_fee_by_time (wire_method, start_date, end_date)
fee_deposit,
fee_refresh, let get_wire_fees =
(fee_refund, age_mask) ) let get_wire_fees =
Caqti_type.(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 get_wire_fees wire_method
let get_global_fees =
let get_global_fees =
Caqti_type.(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 get_global_fees start_date
let get_global_fees_by_time =
let get_global_fees_by_time =
Caqti_type.(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 get_global_fees_by_time (start_date, end_date)
let insert_global_fees =
let insert_global_fees =
Caqti_type.(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 insert_global_fees v
let get_wire_timestamp =
let get_wire_timestamp =
Caqti_type.(payto_uri ->? time)
"SELECT last_change FROM wire_accounts WHERE payto_uri=$1"
in
fun (module Conn : CONN) ~payto_uri ->
Conn.find_opt get_wire_timestamp payto_uri
let insert_wire =
let insert_wire =
Caqti_type.(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 \
($1,$2,$3::TEXT::JSONB,$4::TEXT::JSONB,$5,$6,$7,true,$8)"
in
fun (module Conn : CONN) ~last_change v ->
let is_active = true in
Conn.exec insert_wire (v, is_active, last_change)
let update_wire =
let update_wire =
Caqti_type.(t3 exchange_wire_account bool time ->. unit)
"UPDATE wire_accounts SET conversion_url=$2, \
debit_restrictions=$3::TEXT::JSONB, \
credit_restrictions=$4::TEXT::JSONB, master_sig=$5, bank_label=$6, \
priority=$7, is_active=$8, last_change=$9 WHERE payto_uri=$1"
in
fun (module Conn : CONN) ~is_active ~last_change v ->
Conn.exec update_wire (v, is_active, last_change)
let disable_wire =
let disable_wire =
(* TODO check syntax on this *)
Caqti_type.(t2 payto_uri time ->. unit)
"UPDATE wire_accounts SET conversion_url=NULL, debit_restrictions=NULL, \
credit_restrictions=NULL, master_sig=NULL, bank_label=NULL, \
priority=NULL, is_active=FALSE, last_change=$2 WHERE payto_uri=$1"
in
fun (module Conn : CONN) ~payto_uri ~validity_end ->
Conn.exec disable_wire (payto_uri, validity_end)
let get_wire_accounts =
let get_wire_accounts =
Caqti_type.(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 get_wire_accounts ()
let insert_drain_profit =
let insert_drain_profit =
Caqti_type.(drain_profit_message ->. unit)
"INSERT INTO profit_drains (wtid, account_section, payto_uri, \
trigger_date, amount, master_sig) VALUES ($1, $2, $3, $4, ($5,$6), $7)"
in
fun (module Conn : CONN) v -> Conn.exec insert_drain_profit v
let insert_aml_officer =
let exchange_do_insert_aml_officer =
Caqti_type.(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 exchange_do_insert_aml_officer v
let insert_partner =
let insert_partner =
Caqti_type.(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 insert_partner v

377
src/pg_type.ml Normal file
View file

@ -0,0 +1,377 @@
(* this module defines caqti encoding/decodings *)
open Crypto
open Bin_type
open Api
open Caqti_type
(* TODO
check that we use Caqti_type.octets for binary data *)
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 : Ptime.t option t = Timestamp.caqti
let time = Timestamp.caqti
let time_span = Timestamp.Span.caqti
let age_mask : int t = Caqti_type.int
let rsa_pub = RsaPublicKey.caqti
let eddsa_pub = EddsaPublicKey.caqti
let eddsa_sig = EddsaSignature.caqti
(* todo: enum type for wire_method? *)
let wire_method = Caqti_type.string
let payto_uri = Caqti_type.string
let b32 = B32.caqti
include struct
(* alias for hash *)
let fullpayto_hash = FullPaytoHash.caqti
let nomalizaedpayto_hash = NormalizedPaytoHash.caqti
let denomination_hash = DenominationHash.caqti
let privatecontract_hash = PrivateContractHash.caqti
let extensionspolicy_hash = ExtensionsPolicyHash.caqti
let merchantwire_hash = MerchantWireHash.caqti
let agecommitment_hash = AgeCommitmentHash.caqti
let blindedcoin_hash = BlindedCoinHash.caqti
let coinpub_hash = CoinPubHash.caqti
let outputcommitment_hash = OutputCommitmentHash.caqti
let planchets_hash = HashPlanchetsP.caqti
end
let signkey_data =
let master_sig = Bin_sig.ExchangeSigningKeyValidity.caqti in
let revoked_sig = option Bin_sig.MasterSigningKeyRevocation.caqti in
custom
~encode:(fun
Signkey_data.
{ pub; stamp_start; stamp_expire; stamp_end; master_sig; revoked_sig }
->
match master_sig with
| None -> Error "signkey_data master_sig is none"
| Some master_sig ->
Ok (pub, stamp_start, stamp_expire, stamp_end, master_sig, revoked_sig))
~decode:(fun
(pub, stamp_start, stamp_expire, stamp_end, master_sig, revoked_sig) ->
Ok
{
pub;
stamp_start;
stamp_expire;
stamp_end;
master_sig= Some master_sig;
revoked_sig;
})
(t6 eddsa_pub time time time master_sig revoked_sig)
let denom_data =
let master_sig = Bin_sig.DenominationKeyValidity.caqti in
let revoked_sig = option Bin_sig.MasterDenominationKeyRevocation.caqti in
custom
~encode:(fun
Denom_data.
{
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;
revoked_sig;
}
->
match master_sig with
| None -> Error "denom_data master_sig is none"
| Some master_sig ->
Ok
( 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, revoked_sig) ))
~decode:(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, revoked_sig) )
->
Ok
{
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= Some master_sig;
revoked_sig;
})
(t12 rsa_pub amount time time time time amount amount amount amount int
(t3 denomination_hash master_sig revoked_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 global_fee =
let master_sig = Bin_sig.GlobalFees.caqti in
custom
~encode:(fun
GlobalFees.
{
start_date;
end_date;
history_fee;
account_fee;
purse_fee;
history_expiration;
purse_account_limit;
purse_timeout;
master_sig;
}
->
Ok
( start_date,
end_date,
history_fee,
account_fee,
purse_fee,
history_expiration,
purse_account_limit,
purse_timeout,
master_sig ))
~decode:(fun
( start_date,
end_date,
history_fee,
account_fee,
purse_fee,
history_expiration,
purse_account_limit,
purse_timeout,
master_sig )
->
Ok
{
start_date;
end_date;
history_fee;
account_fee;
purse_fee;
history_expiration;
purse_account_limit;
purse_timeout;
master_sig;
})
Caqti_type.(
t9 time time amount amount amount time_span int32 time_span master_sig)
let aggregate_transfer_fee =
let master_sig = Bin_sig.MasterWireFee.caqti in
Caqti_type.custom
~encode:(fun
AggregateTransferFee.
{ wire_fee; closing_fee; start_date; end_date; sig_ }
-> Ok (wire_fee, closing_fee, start_date, end_date, sig_))
~decode:(fun (wire_fee, closing_fee, start_date, end_date, sig_) ->
Ok
AggregateTransferFee.
{ wire_fee; closing_fee; start_date; end_date; sig_ })
Caqti_type.(t5 amount amount time time master_sig)
let exchange_wire_account =
let master_sig = Bin_sig.MasterWireDetails.caqti in
Caqti_type.custom
~encode:(fun
ExchangeWireAccount.
{
payto_uri;
conversion_url;
debit_restrictions;
credit_restrictions;
master_sig;
bank_label;
priority;
}
->
Ok
( payto_uri,
conversion_url,
debit_restrictions,
credit_restrictions,
master_sig,
bank_label,
priority ))
~decode:(fun
( payto_uri,
conversion_url,
debit_restrictions,
credit_restrictions,
master_sig,
bank_label,
priority )
->
Ok
{
payto_uri;
conversion_url;
debit_restrictions;
credit_restrictions;
master_sig;
bank_label;
priority;
})
Caqti_type.(
t7 payto_uri (option string) account_restrictions account_restrictions
master_sig (option string) (option int))
let drain_profit_message =
let master_sig = Bin_sig.MasterDrainProfit.caqti in
Caqti_type.custom
~encode:(fun
DrainProfitsMessage.
{
wtid;
debit_account_section;
credit_payto_uri;
date;
amount;
master_sig;
}
->
Ok
(wtid, debit_account_section, credit_payto_uri, date, amount, master_sig))
~decode:(fun
(wtid, debit_account_section, credit_payto_uri, date, amount, master_sig)
->
Ok
{
wtid;
debit_account_section;
credit_payto_uri;
date;
amount;
master_sig;
})
Caqti_type.(t6 b32 string string time amount master_sig)
let aml_officer_setup =
let master_sig = Bin_sig.MasterAmlOfficerStatus.caqti in
Caqti_type.custom
~encode:(fun
AmlOfficerSetup.
{
officer_pub;
master_sig;
officer_name;
is_active;
read_only;
change_date;
}
->
Ok
( officer_pub,
master_sig,
officer_name,
is_active,
read_only,
change_date ))
~decode:(fun
( officer_pub,
master_sig,
officer_name,
is_active,
read_only,
change_date )
->
Ok
{
officer_pub;
master_sig;
officer_name;
is_active;
read_only;
change_date;
})
Caqti_type.(t6 eddsa_pub master_sig string bool bool time)
let exchange_partner_setup =
let master_sig = Bin_sig.PartnerConfiguration.caqti in
Caqti_type.custom
~encode:(fun
ExchangePartnerSetupRequest.
{
partner_pub;
start_date;
end_date;
wad_frequency;
wad_fee;
master_sig;
partner_base_url;
}
->
Ok
( partner_pub,
start_date,
end_date,
wad_frequency,
wad_fee,
master_sig,
partner_base_url ))
~decode:(fun
( partner_pub,
start_date,
end_date,
wad_frequency,
wad_fee,
master_sig,
partner_base_url )
->
Ok
{
partner_base_url;
partner_pub;
wad_frequency;
master_sig;
start_date;
end_date;
wad_fee;
})
Caqti_type.(t7 eddsa_pub time time time_span amount master_sig string)

22
src/respond_util.ml Normal file
View file

@ -0,0 +1,22 @@
let respond_with_plain_text_error ?status e req =
let open Vif.Response in
let open Syntax in
let status = Option.value ~default:`Bad_request status in
let* () = add ~field:"content-type" "text/plain; charset=utf-8" in
let* () = with_string req e in
respond status
let respond_with_ok_json content req =
let open Vif.Response in
let open Syntax in
let* () = add ~field:"content-type" "application/json" in
let* () = with_string req content in
respond `OK
let respond_with_res res req =
match res with
| Error err ->
Logs.err (fun m -> m "%s." err);
let err = Fmt.str "%s@." err in
respond_with_plain_text_error err req
| Ok content -> respond_with_ok_json content req

401
src/secmod.ml Normal file
View file

@ -0,0 +1,401 @@
module type S = sig
open Crypto
val sign_with_sm_key : string -> eddsa_sig
val sign_with_signkey : pub:eddsa_pub -> string -> eddsa_sig
val verify_with_master_key : eddsa_sig -> msg:string -> (unit, string) result
val verify_with_sm_key : eddsa_sig -> msg:string -> (unit, string) result
val verify_with_signkey :
pub:eddsa_pub -> eddsa_sig -> msg:string -> (unit, string) result
(* TODO query database instead? *)
val get_sm_key_pub : unit -> eddsa_pub
val get_signkeys_data : unit -> Signkey_data.t list
val get_denoms_data : unit -> Denom_data.t list
val find_signkey_data : eddsa_pub -> Signkey_data.t option
val find_denom_data : denomination_hash -> Denom_data.t option
val find_denom_section_name : denomination_hash -> string option
(* - management operations - *)
(* TODO
problem of keeping db and secmod state syncronized
do db interaction from secmod? *)
val add_signkey_master_signatures :
(eddsa_pub * Bin_sig.ExchangeSigningKeyValidity.t) list ->
(unit, string) result
val add_denom_master_signatures :
(denomination_hash * Bin_sig.DenominationKeyValidity.t) list ->
(unit, string) result
val revoke_signkey :
eddsa_pub -> Bin_sig.MasterSigningKeyRevocation.t -> (unit, string) result
val revoke_denomination :
denomination_hash ->
Bin_sig.MasterDenominationKeyRevocation.t ->
(unit, string) result
val store : unit -> (unit, string) result
end
module Make (Conn : Pg.CONN) = struct
(* TODO
- key rotation
- how many signkey to use?
we just use 1 for now
- does the secmod's own key as metadata/expiration date?
- something to refer to valid sk/dn
- eddsa.ml with phantom type for key-kind + signed-data-kind *)
open Syntax
open Crypto
type signkey = {
priv: eddsa_priv;
sk_data: Signkey_data.t;
}
type denom = {
priv: rsa_priv;
dn_data: Denom_data.t;
}
type t = {
lock: Miou.Mutex.t;
sm_key_priv: eddsa_priv;
sm_key_pub: eddsa_pub;
sk_ht: (eddsa_pub, signkey) Hashtbl.t;
dn_ht: (denomination_hash, denom) Hashtbl.t;
dn_section_name_ht: (denomination_hash, string) Hashtbl.t;
}
let dir = Fpath.(v "data" / "secmod")
let db_lookup_signkey_data conn fname pub =
let* opt = Pg.find_signkey conn pub |> unwrap_err_caqti in
match opt with
| None ->
Fmt.error
"load_signkey error, no associated data found in database for \
signkey `%s`."
(Fpath.to_string fname)
| Some sk_data -> Ok sk_data
let db_lookup_denom_data conn ~section_name priv =
let pub = RsaPrivateKey.pub_of_priv priv in
let h_pub = Bin_type.DenominationHash.hash (RsaPublicKey.to_octets pub) in
let* opt = Pg.find_denom conn h_pub |> unwrap_err_caqti in
match opt with
| None ->
Fmt.error
"load_denom error no associated metadata found in database for \
denomination `%s`."
section_name
| Some dn_data -> Ok dn_data
let load_signkey conn fname =
let* opt = Data_file.read_eddsa fname in
match opt with
| None -> Ok None
| Some priv ->
let pub = EddsaPrivateKey.pub_of_priv priv in
let* sk_data = db_lookup_signkey_data conn fname pub in
let signkey = { priv; sk_data } in
Ok (Some signkey)
let load conn =
let error_invalid_state =
Fmt.error "secmod load error: invalid store state."
in
let* sm_key_priv = Data_file.read_eddsa Fpath.(dir / "sk_sm") in
let* signkeys =
let l = List.init 1 (fun i -> Fpath.(dir / Fmt.str "sk_%d" i)) in
let* l = list_map (fun fname -> load_signkey conn fname) l in
match opt_list l with Error () -> error_invalid_state | Ok opt -> Ok opt
in
let dn_section_name_ht = Hashtbl.create 0xff in
let* denoms =
let* l =
let open Config.Coin in
list_map
(fun coin ->
let section_name = coin.section_name in
let fname = Fpath.(dir / section_name) in
let* opt = Data_file.read_rsa fname in
match opt with
| None -> Ok None
| Some priv ->
(* todo: could check that coin config match db values *)
let* dn_data = db_lookup_denom_data conn ~section_name priv in
Hashtbl.replace dn_section_name_ht dn_data.h_pub section_name;
let denom = { priv; dn_data } in
Ok (Some denom))
all_coins
in
match Syntax.opt_list l with
| Error () -> error_invalid_state
| Ok opt -> Ok opt
in
match (sm_key_priv, signkeys, denoms) with
| None, None, None -> Ok None
| Some sm_key_priv, Some signkeys, Some denoms ->
let sm_key_pub = EddsaPrivateKey.pub_of_priv sm_key_priv in
let lock = Miou.Mutex.create () in
let sk_ht =
signkeys
|> List.map (fun v -> (v.sk_data.pub, v))
|> List.to_seq
|> Hashtbl.of_seq
in
let dn_ht =
denoms
|> List.map (fun v -> (v.dn_data.h_pub, v))
|> List.to_seq
|> Hashtbl.of_seq
in
Ok
(Some
{ lock; sm_key_priv; sm_key_pub; sk_ht; dn_ht; dn_section_name_ht })
| _, _, _ -> error_invalid_state
let make_new_signkey () =
let stamp_start = Ptime_clock.now () |> Option.some in
let stamp_expire =
Timestamp.add_span_exn stamp_start
(Some Config.Exchange.signkey_legal_duration)
in
let stamp_end = stamp_expire in
let priv, pub = Mirage_crypto_ec.Ed25519.generate () in
let master_sig = None in
let revoked_sig = None in
let sk_data =
Signkey_data.
{ pub; stamp_start; stamp_expire; stamp_end; master_sig; revoked_sig }
in
{ priv; sk_data }
let make_new_denom
Config.Coin.
{
section_name= _;
value;
duration_withdraw;
duration_spend;
duration_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
cipher;
rsa_keysize;
age_restricted= _;
} =
assert (cipher = `RSA);
let stamp_start = Ptime_clock.now () |> Option.some in
let stamp_expire_withdraw =
Timestamp.add_span_exn stamp_start (Some duration_withdraw)
in
let stamp_expire_deposit =
Timestamp.add_span_exn stamp_start (Some duration_spend)
in
let stamp_expire_legal =
Timestamp.add_span_exn stamp_start (Some duration_legal)
in
let priv, pub = RsaPrivateKey.generate ~bits:rsa_keysize () in
let h_pub = Bin_type.DenominationHash.hash (RsaPublicKey.to_octets pub) in
let master_sig = None in
let revoked_sig = None in
let dn_data =
Denom_data.
{
pub;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund;
age_mask= 0;
h_pub;
master_sig;
revoked_sig;
}
in
{ priv; dn_data }
let make_new () =
let lock = Miou.Mutex.create () in
let sm_key_priv, sm_key_pub = Mirage_crypto_ec.Ed25519.generate () in
let sk_ht =
[ make_new_signkey () ]
|> List.map (fun v -> (v.sk_data.pub, v))
|> List.to_seq
|> Hashtbl.of_seq
in
let dn_section_name_ht = Hashtbl.create 0xff in
let dn_ht =
Config.Coin.all_coins
|> List.map (fun coin ->
let denom = make_new_denom coin in
Hashtbl.replace dn_section_name_ht denom.dn_data.h_pub
coin.section_name;
(denom.dn_data.h_pub, denom))
|> List.to_seq
|> Hashtbl.of_seq
in
{ lock; sm_key_priv; sm_key_pub; sk_ht; dn_ht; dn_section_name_ht }
let t =
match load (module Conn) with
| Ok None ->
let t = make_new () in
Logs.info (fun m -> m "secmod initialized with fresh keys");
t
| Ok (Some t) ->
Logs.info (fun m -> m "secmod initialized from storage");
t
| Error e -> Fmt.failwith "secmod init failure: %s." e
(* note: don't expose a signing function if we want a real "security module" one day *)
let sign_with_sm_key s = EddsaSignature.sign ~key:t.sm_key_priv s
let verify_with_sm_key s ~msg = EddsaSignature.verify ~key:t.sm_key_pub s ~msg
let verify_with_master_key s ~msg =
EddsaSignature.verify ~key:Config.master_public_key s ~msg
(* TODO
- do something to force `pub` to be one of the valid signkey
how to handle revocation?
raise exn for now *)
let sign_with_signkey ~pub s =
Miou.Mutex.protect t.lock @@ fun () ->
match Hashtbl.find_opt t.sk_ht pub with
| None -> Fmt.failwith "secmod failure: public key not found."
| Some signkey ->
let v = EddsaSignature.sign ~key:signkey.priv s in
v
let verify_with_signkey ~pub s ~msg =
Miou.Mutex.protect t.lock @@ fun () ->
match Hashtbl.find_opt t.sk_ht pub with
| None -> Error "secmod failure: public key not found."
| Some signkey -> EddsaSignature.verify ~key:signkey.sk_data.pub s ~msg
let get_sm_key_pub () = t.sm_key_pub
let get_signkeys () =
Miou.Mutex.protect t.lock @@ fun () ->
Hashtbl.to_seq_values t.sk_ht |> List.of_seq
let get_denoms () =
Miou.Mutex.protect t.lock @@ fun () ->
Hashtbl.to_seq_values t.dn_ht |> List.of_seq
let find_signkey pub =
Miou.Mutex.protect t.lock @@ fun () -> Hashtbl.find_opt t.sk_ht pub
let find_denom h_denom =
Miou.Mutex.protect t.lock @@ fun () -> Hashtbl.find_opt t.dn_ht h_denom
let get_signkeys_data () = get_signkeys () |> List.map (fun v -> v.sk_data)
let get_denoms_data () = get_denoms () |> List.map (fun v -> v.dn_data)
let find_signkey_data pub =
find_signkey pub |> Option.map (fun v -> v.sk_data)
let find_denom_data h_denom =
find_denom h_denom |> Option.map (fun v -> v.dn_data)
let find_denom_section_name h_denom =
Miou.Mutex.protect t.lock @@ fun () ->
Hashtbl.find_opt t.dn_section_name_ht h_denom
let add_signkey_master_signatures l =
Miou.Mutex.protect t.lock @@ fun () ->
list_iter
(fun (pub, master_sig) ->
match Hashtbl.find_opt t.sk_ht pub with
| None -> Error "secmod failure: public key not found."
| Some signkey ->
let sk_data =
{ signkey.sk_data with master_sig= Some master_sig }
in
let signkey = { signkey with sk_data } in
let* () =
Pg.insert_signkey (module Conn) sk_data |> unwrap_err_caqti
in
Hashtbl.replace t.sk_ht pub signkey;
Ok ())
l
let add_denom_master_signatures l =
Miou.Mutex.protect t.lock @@ fun () ->
list_iter
(fun (h_denom_pub, master_sig) ->
match Hashtbl.find_opt t.dn_ht h_denom_pub with
| None -> Error "secmod failure: denomination hash not found."
| Some denom ->
let dn_data = { denom.dn_data with master_sig= Some master_sig } in
let denom = { denom with dn_data } in
let* () =
Pg.insert_denom (module Conn) dn_data |> unwrap_err_caqti
in
Hashtbl.replace t.dn_ht h_denom_pub denom;
Ok ())
l
let revoke_signkey exchange_pub revoked_sig =
Miou.Mutex.protect t.lock @@ fun () ->
match Hashtbl.find_opt t.sk_ht exchange_pub with
| None -> Error "secmod failure: denomination hash not found."
| Some signkey ->
let sk_data = { signkey.sk_data with revoked_sig= Some revoked_sig } in
let signkey = { signkey with sk_data } in
Hashtbl.replace t.sk_ht exchange_pub signkey;
Ok ()
let revoke_denomination h_denom_pub revoked_sig =
Miou.Mutex.protect t.lock @@ fun () ->
match Hashtbl.find_opt t.dn_ht h_denom_pub with
| None -> Error "secmod failure: denomination hash not found."
| Some denom ->
let dn_data = { denom.dn_data with revoked_sig= Some revoked_sig } in
let denom = { denom with dn_data } in
Hashtbl.replace t.dn_ht h_denom_pub denom;
Ok ()
let store () =
Miou.Mutex.protect t.lock @@ fun () ->
let* () = Data_file.write_eddsa Fpath.(dir / "sk_sm") t.sm_key_priv in
let* () =
Hashtbl.to_seq_values t.sk_ht
|> List.of_seq
|> List.mapi (fun i (key : signkey) ->
let fname = Fpath.(dir / Fmt.str "sk_%d" i) in
(fname, key.priv))
|> list_iter (fun (fname, key) -> Data_file.write_eddsa fname key)
in
let* () =
let* l =
Hashtbl.to_seq_values t.dn_ht
|> List.of_seq
|> Syntax.list_map (fun (key : denom) ->
let+ section_name =
match Hashtbl.find_opt t.dn_section_name_ht key.dn_data.h_pub with
| None -> Error "invalid state, section_name not found"
| Some s -> Ok s
in
let fname = Fpath.(dir / section_name) in
(fname, key.priv))
in
list_iter (fun (fname, key) -> Data_file.write_rsa fname key) l
in
Logs.info (fun m -> m "stored secmod data to file");
Ok ()
end

44
src/secmod.mli Normal file
View file

@ -0,0 +1,44 @@
module type S = sig
open Crypto
val sign_with_sm_key : string -> eddsa_sig
val sign_with_signkey : pub:eddsa_pub -> string -> eddsa_sig
val verify_with_master_key : eddsa_sig -> msg:string -> (unit, string) result
val verify_with_sm_key : eddsa_sig -> msg:string -> (unit, string) result
val verify_with_signkey :
pub:eddsa_pub -> eddsa_sig -> msg:string -> (unit, string) result
(* TODO query database instead? *)
val get_sm_key_pub : unit -> eddsa_pub
val get_signkeys_data : unit -> Signkey_data.t list
val get_denoms_data : unit -> Denom_data.t list
val find_signkey_data : eddsa_pub -> Signkey_data.t option
val find_denom_data : denomination_hash -> Denom_data.t option
val find_denom_section_name : denomination_hash -> string option
(* - management operations - *)
(* TODO
problem of keeping db and secmod state syncronized
do db interaction from secmod? *)
val add_signkey_master_signatures :
(eddsa_pub * Bin_sig.ExchangeSigningKeyValidity.t) list ->
(unit, string) result
val add_denom_master_signatures :
(denomination_hash * Bin_sig.DenominationKeyValidity.t) list ->
(unit, string) result
val revoke_signkey :
eddsa_pub -> Bin_sig.MasterSigningKeyRevocation.t -> (unit, string) result
val revoke_denomination :
denomination_hash ->
Bin_sig.MasterDenominationKeyRevocation.t ->
(unit, string) result
val store : unit -> (unit, string) result
end
module Make (_ : Pg.CONN) : S

29
src/signkey.ml
View file

@ -1,29 +0,0 @@
open Crypto
(* TODO master_sig
not sur how to handle master_sig initialization *)
type t = {
pub: EddsaPublicKey.t;
priv: EddsaPrivateKey.t;
stamp_start: Timestamp.t;
stamp_expire: Timestamp.t;
stamp_end: Timestamp.t;
(* signature of this key by offline master key *)
master_sig: EddsaSignature.t option;
}
let generate () =
(* TODO
- look if it exists
- if not, create it (TOFU initialization scheme)
- write it *)
let stamp_start = Ptime_clock.now () |> Option.some in
let stamp_expire =
Timestamp.add_span_exn stamp_start
(Some Config.Exchange.signkey_legal_duration)
in
let stamp_end = stamp_expire in
let priv, pub = Mirage_crypto_ec.Ed25519.generate () in
let master_sig = None in
{ pub; priv; stamp_start; stamp_expire; stamp_end; master_sig }

10
src/signkey_data.ml Normal file
View file

@ -0,0 +1,10 @@
open Crypto
type t = {
pub: eddsa_pub;
stamp_start: Timestamp.t;
stamp_expire: Timestamp.t;
stamp_end: Timestamp.t;
master_sig: Bin_sig.ExchangeSigningKeyValidity.t option;
revoked_sig: Bin_sig.MasterSigningKeyRevocation.t option;
}

3
src/static.ml
View file

@ -17,7 +17,8 @@ module Respond_with = struct
let error_detail ?hint _status = let error_detail ?hint _status =
let open Api in let open Api in
let code = -1 in let code = -1 in
let s = encode_exn ErrorDetail.jsont { code; hint } in let err = ErrorDetail.make ?hint code in
let s = encode_exn ErrorDetail.jsont err in
s s
end end

3
src/syntax.ml
View file

@ -4,6 +4,9 @@ let ( let+ ) o f = match o with Ok v -> Ok (f v) | Error _ as e -> e
(* TODO use polymorphic variant for errors *) (* TODO use polymorphic variant for errors *)
let unwrap_err_msg o = match o with Error (`Msg e) -> Error e | Ok v -> Ok v let unwrap_err_msg o = match o with Error (`Msg e) -> Error e | Ok v -> Ok v
let unwrap_err_caqti o =
match o with Error err -> Fmt.error "%a" Caqti_error.pp err | Ok v -> Ok v
let list_iter f l = let list_iter f l =
let err = ref None in let err = ref None in
try try

108
src/timestamp.ml
View file

@ -1,6 +1,8 @@
type t = Ptime.t option type t = Ptime.t option
type span = Ptime.Span.t option type span = Ptime.Span.t option
let epoch = Some Ptime.epoch
let diff a b = let diff a b =
match (a, b) with match (a, b) with
| None, _ | _, None -> None | None, _ | _, None -> None
@ -23,6 +25,23 @@ let of_span_exn = function
(* -- *) (* -- *)
(* TODO
this doesn't handle "never" value, and truncate time *)
let of_string s =
match Float.of_string_opt s with
| None -> Error "Timestamp.of_string failure: not a float"
| Some v -> (
match Ptime.of_float_s v with
| None -> Error "Timestamp.of_string failure"
| Some v -> Ok (Some v))
let pp fmt t =
match t with
| None -> Fmt.pf fmt {|"never"|}
| Some v ->
let v = Ptime.to_float_s v in
Fmt.pf fmt {|%f|} v
(* microseconds since the UNIX Epoch, or "never" if None *) (* microseconds since the UNIX Epoch, or "never" if None *)
let jsont = let jsont =
let number_or_never_jsont = let number_or_never_jsont =
@ -48,7 +67,6 @@ let jsont =
|> Jsont.Object.mem "t_s" number_or_never_jsont ~enc:Fun.id |> Jsont.Object.mem "t_s" number_or_never_jsont ~enc:Fun.id
|> Jsont.Object.finish |> Jsont.Object.finish
(* TODO exn *)
let ptime_to_int64 ptime = ptime |> Ptime.to_float_s |> Int64.of_float let ptime_to_int64 ptime = ptime |> Ptime.to_float_s |> Int64.of_float
let ptime_of_int64 i = let ptime_of_int64 i =
@ -63,7 +81,93 @@ let decode_int64 i = if i = Int64.max_int then None else Some (ptime_of_int64 i)
let bin = Bin.map Bin.neint64 decode_int64 encode_int64 let bin = Bin.map Bin.neint64 decode_int64 encode_int64
let bin_nbo = Bin.map Bin.beint64 decode_int64 encode_int64 let bin_nbo = Bin.map Bin.beint64 decode_int64 encode_int64
let caqti : Ptime.t option Caqti_type.t = let caqti : t Caqti_type.t =
let encode v = Ok (encode_int64 v) in let encode v = Ok (encode_int64 v) in
let decode v = Ok (decode_int64 v) in let decode v = Ok (decode_int64 v) in
Caqti_type.custom ~encode ~decode Caqti_type.int64 Caqti_type.custom ~encode ~decode Caqti_type.int64
let compare a b =
match (a, b) with
| None, None -> Some 0
| None, _ | _, None -> None
| Some a, Some b ->
let a = ptime_to_int64 a in
let b = ptime_to_int64 b in
let c = Int64.compare a b in
Some c
module Span = struct
type t = span
(* TODO
this doesn't handle "never" value, and truncate time *)
let of_string s =
match Float.of_string_opt s with
| None -> Error "Timestamp.Span.of_string failure: not a float"
| Some v -> (
match Ptime.Span.of_float_s v with
| None -> Error "Timestamp.Span.of_string failure"
| Some v -> Ok (Some v))
let pp fmt t =
match t with
| None -> Fmt.pf fmt {|"forever"|}
| Some v ->
let v = Ptime.Span.to_float_s v in
Fmt.pf fmt {|%f|} v
let to_int64 ptime = ptime |> Ptime.Span.to_float_s |> Int64.of_float
let of_int64 i =
match Ptime.Span.of_float_s (Int64.to_float i) with
| None ->
Fmt.failwith
"ptime_span_of_int64 error: `%Ld` is not a valid ptime span" i
| Some ts -> ts
let encode_int64 = function None -> Int64.max_int | Some p -> to_int64 p
let decode_int64 i = if i = Int64.max_int then None else Some (of_int64 i)
(* UINT64_MAX represents "forever" *)
let bin = Bin.map Bin.neint64 decode_int64 encode_int64
let bin_nbo = Bin.map Bin.beint64 decode_int64 encode_int64
let caqti : t Caqti_type.t =
let encode v = Ok (encode_int64 v) in
let decode v = Ok (decode_int64 v) in
Caqti_type.custom ~encode ~decode Caqti_type.int64
let jsont =
let number_or_forever_jsont =
let forever =
let dec s =
match s with
| "forever" -> None
| _ -> Jsont.Error.msg Jsont.Meta.none "unexpected string value"
in
let enc = function None -> "forever" | _ -> assert false in
Jsont.map ~dec ~enc Jsont.string
in
let number =
let dec n =
(* relative time is in us *)
let n = n /. 1_000_000. in
Ptime.Span.of_float_s n
in
let enc = function
| Some span ->
let n = Ptime.Span.to_float_s span in
n *. 1_000_000.
| _ -> assert false
in
Jsont.map ~dec ~enc Jsont.number
in
let enc = function None -> forever | Some _ -> number in
Jsont.any ~dec_string:forever ~dec_number:number ~enc ()
in
let make t_s = t_s in
Jsont.Object.map ~kind:"RelativeTime" make
|> Jsont.Object.mem "t_s" number_or_forever_jsont ~enc:Fun.id
|> Jsont.Object.finish
end

27
src/timestamp.mli
View file

@ -1,15 +1,38 @@
(* TODO time (* TODO time
not sure about this *) uhuh!
need to be int64 for binary/pg round trip
really need to fix this module
don't use option for never/forever *)
type t = Ptime.t option type t = Ptime.t option
type span = Ptime.Span.t option type span = Ptime.Span.t option
module Span : sig
type t = span
val of_string : string -> (t, string) result
val pp : Stdlib.Format.formatter -> t -> unit
(* - *)
val jsont : t Jsont.t
val bin : t Bin.t
val bin_nbo : t Bin.t
val caqti : t Caqti_type.t
end
val epoch : t
val diff : t -> t -> span val diff : t -> t -> span
val add_span_exn : t -> span -> t val add_span_exn : t -> span -> t
val of_span_exn : span -> t val of_span_exn : span -> t
val compare : t -> t -> int option
(* used for offline tool argument conversion *)
val of_string : string -> (t, string) result
val pp : Stdlib.Format.formatter -> t -> unit
(* - *) (* - *)
val jsont : t Jsont.t val jsont : t Jsont.t
val bin : t Bin.t val bin : t Bin.t
val bin_nbo : t Bin.t val bin_nbo : t Bin.t
val caqti : Ptime.t option Caqti_type.t val caqti : t Caqti_type.t

28
src/util.ml
View file

@ -1,3 +1,5 @@
exception Bin_error of string
(* TODO bin (* TODO bin
- no [Bin.of_string] ? *) - no [Bin.of_string] ? *)
let bin_of_string bin s = let bin_of_string bin s =
@ -31,8 +33,6 @@ module Bin_rsa = struct
let bits = Z.to_bits z in let bits = Z.to_bits z in
rev_string (String.length bits) bits rev_string (String.length bits) bits
let check = function false -> Error (`Msg "invalid data") | true -> Ok ()
let z_array_to_octets (arr : Z.t array) = let z_array_to_octets (arr : Z.t array) =
let nb = Array.length arr in let nb = Array.length arr in
let bits_arr = Array.map z_to_bits_be arr in let bits_arr = Array.map z_to_bits_be arr in
@ -53,6 +53,10 @@ module Bin_rsa = struct
bits_arr; bits_arr;
Bytes.unsafe_to_string b Bytes.unsafe_to_string b
let check = function
| false -> Error "rsa of_octets error, invalid data"
| true -> Ok ()
let z_array_of_octets ~nb s = let z_array_of_octets ~nb s =
let s_len = String.length s in let s_len = String.length s in
let* () = check (s_len > 2 * nb) in let* () = check (s_len > 2 * nb) in
@ -82,35 +86,27 @@ module Bin_rsa = struct
let pub_to_octets ({ n; e } : Mirage_crypto_pk.Rsa.pub) = let pub_to_octets ({ n; e } : Mirage_crypto_pk.Rsa.pub) =
z_array_to_octets [| n; e |] z_array_to_octets [| n; e |]
let pub_of_octets s =
let pub_of_octets s = let pub_of_octets s =
let* arr = z_array_of_octets ~nb:2 s in let* arr = z_array_of_octets ~nb:2 s in
match arr with match arr with
| [| n; e |] -> | [| n; e |] ->
let* pub = Mirage_crypto_pk.Rsa.pub ~n ~e in let+ pub = Mirage_crypto_pk.Rsa.pub ~n ~e |> unwrap_err_msg in
Ok pub pub
| _ -> assert false | _ -> assert false
in
match pub_of_octets s with
| Error (`Msg e) -> Fmt.failwith "rsa pub_of_octets failure: %s@." e
| Ok v -> v
let priv_to_octets ({ e; d; n; p; q; dp; dq; q' } : Mirage_crypto_pk.Rsa.priv) let priv_to_octets ({ e; d; n; p; q; dp; dq; q' } : Mirage_crypto_pk.Rsa.priv)
= =
z_array_to_octets [| e; d; n; p; q; dp; dq; q' |] z_array_to_octets [| e; d; n; p; q; dp; dq; q' |]
let priv_of_octets s =
let priv_of_octets s = let priv_of_octets s =
let* arr = z_array_of_octets ~nb:8 s in let* arr = z_array_of_octets ~nb:8 s in
match arr with match arr with
| [| e; d; n; p; q; dp; dq; q' |] -> | [| e; d; n; p; q; dp; dq; q' |] ->
let* priv = Mirage_crypto_pk.Rsa.priv ~e ~d ~n ~p ~q ~dp ~dq ~q' in let+ priv =
Ok priv Mirage_crypto_pk.Rsa.priv ~e ~d ~n ~p ~q ~dp ~dq ~q' |> unwrap_err_msg
| _ -> assert false
in in
match priv_of_octets s with priv
| Error (`Msg e) -> Fmt.failwith "rsa priv_of_octets failure: %s@." e | _ -> assert false
| Ok v -> v
end end
module Log_reporter = struct module Log_reporter = struct

44
test/offline_management.sh Executable file
View file

@ -0,0 +1,44 @@
#!/bin/bash
set -e
a="tmp_a.json"
b="tmp_b.json"
auditor_pub=$(<"./data/auditor_public_key")
dune exec offline -- download --output $a
dune exec offline -- sign --input $a --output $b
dune exec offline -- upload --input $b --url "/management/keys"
dune exec offline -- enable-auditor \
--output $b \
--auditor_url "auditor.example.com" \
--auditor_name "auditor example" \
--auditor_pub $auditor_pub \
--validity_start "0.0"
dune exec offline -- upload --input $b --url "/management/auditors"
dune exec offline -- wire-fee \
--output $b \
--wire_method "magic" \
--fee_start "0.0" \
--fee_end "99999999.9" \
--closing_fee "EUR:0.0" \
--wire_fee "EUR:0.0"
dune exec offline -- upload --input $b --url "/management/wire-fee"
dune exec offline -- global-fees \
--output $b \
--start_date "0.0" \
--end_date "99999999.9" \
--history_fee "EUR:0.0" \
--account_fee "EUR:0.0" \
--purse_fee "EUR:0.0" \
--history_expiration "9999999.0" \
--purse_account_limit 1 \
--purse_timeout "9999999.0"
dune exec offline -- upload --input $b --url "/management/global-fees"
rm $a
rm $b

7
test/test.ml
View file

@ -1,22 +1,21 @@
let () = Mirage_crypto_rng_unix.use_default () let () = Mirage_crypto_rng_unix.use_default ()
let get_ok = function Error e -> failwith e | Ok v -> v
let () = let () =
let priv = Mirage_crypto_pk.Rsa.generate ~bits:2048 () in let priv = Mirage_crypto_pk.Rsa.generate ~bits:2048 () in
let pub = Mirage_crypto_pk.Rsa.pub_of_priv priv in let pub = Mirage_crypto_pk.Rsa.pub_of_priv priv in
let () = let () =
let open Crypto.RsaPrivateKey in let open Crypto.RsaPrivateKey in
let priv' = priv |> to_octets |> of_octets in let priv' = priv |> to_octets |> of_octets |> get_ok in
assert (to_octets priv = to_octets priv') assert (to_octets priv = to_octets priv')
in in
let () = let () =
let open Crypto.RsaPublicKey in let open Crypto.RsaPublicKey in
let pub' = pub |> to_octets |> of_octets in let pub' = pub |> to_octets |> of_octets |> get_ok in
assert (to_octets pub = to_octets pub') assert (to_octets pub = to_octets pub')
in in
() ()
let get_ok = function Error e -> failwith e | Ok v -> v
let () = let () =
let open Api in let open Api in
let check jsont s = let check jsont s =

2
tools/dune
View file

@ -1,7 +1,7 @@
(executable (executable
(public_name offline) (public_name offline)
(name offline) (name offline)
(modules offline offline_impl offline_bin) (modules offline offline_impl offline_sig)
(libraries cmdliner bos fmt mirage-crypto ptime mte vif)) (libraries cmdliner bos fmt mirage-crypto ptime mte vif))
; todo depends on curl ; todo depends on curl

276
tools/offline.ml
View file

@ -1,17 +1,78 @@
(* TODO
all management operations:
/management/wire
/management/wire/disable
-> how to build WireSetupMessage?
we need additional data to craft master_sig
maybe supposed to be found in the full payto-uri?
/management/aml-officers
-> /aml
/management/partners
-> /wads *)
open Cmdliner open Cmdliner
open Cmdliner.Term.Syntax open Cmdliner.Term.Syntax
open Offline_impl open Offline_impl
module Arg = struct
include Arg
let timestamp =
Arg.Conv.make ~docv:"timestamp argument" ~parser:Timestamp.of_string
~pp:Timestamp.pp ()
let relative_time =
Arg.Conv.make ~docv:"relative time argument"
~parser:Timestamp.Span.of_string ~pp:Timestamp.Span.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 = Crypto.EddsaPublicKey.of_b32 s in
let pp fmt key =
let s = Crypto.EddsaPublicKey.to_b32 key in
Fmt.pf fmt "%s" s
in
Arg.Conv.make ~docv:"eddsa public key argument" ~parser ~pp ()
end
let default_master_offline_key_file = "data/master_offline_private_key" let default_master_offline_key_file = "data/master_offline_private_key"
(*
let default_response_file = "response.json" let default_response_file = "response.json"
let default_request_file = "request.json" let default_request_file = "request.json"
*)
(*let to_term_ret = function Error e -> `Error (false, e) | Ok () -> `Ok ()*) let master_key =
let to_term_ret = Fun.id let doc = "Master offline Eddsa private key file." in
Arg.(
value
& opt file default_master_offline_key_file
& info [ "master_key_file" ] ~doc)
let input =
let doc = "input file" in
Arg.(required & opt (some file) None & info [ "i"; "input" ] ~doc)
let output =
let doc = "output file" in
Arg.(required & opt (some filepath) None & info [ "o"; "output" ] ~doc)
let url =
let doc = "url" in
Arg.(required & opt (some string) None & info [ "url" ] ~doc)
let setup_cmd = let setup_cmd =
let doc = "Generate offline master keys" in let doc = "Generate offline master keys" in
let output = let output =
let doc = "output file" in
Arg.( Arg.(
value value
& opt filepath default_master_offline_key_file & opt filepath default_master_offline_key_file
@ -20,59 +81,212 @@ let setup_cmd =
Cmd.make (Cmd.info "setup" ~doc) Cmd.make (Cmd.info "setup" ~doc)
@@ @@
let+ output = output in let+ output = output in
setup ~output |> to_term_ret setup ~output
let download_cmd = let download_cmd =
let doc = "GET /management/keys/" in let doc = "GET /management/keys/" in
let man = let man =
[ `S Manpage.s_description; `P "$(cmd) download /management/keys." ] [ `S Manpage.s_description; `P "$(cmd) download /management/keys." ]
in in
let output =
Arg.(
value & opt filepath default_response_file & info [ "o"; "output" ] ~doc)
in
Cmd.make (Cmd.info "download" ~doc ~man) Cmd.make (Cmd.info "download" ~doc ~man)
@@ @@
let+ output = output in let+ output = output in
download ~output |> to_term_ret download ~output
let upload_cmd = let upload_cmd =
let doc = "POST /management/keys/" in let doc = "POST input.json data to url (default /management/keys)" in
let man = Cmd.make (Cmd.info "upload" ~doc)
[ `S Manpage.s_description; `P "$(cmd) upload /management/keys." ]
in
let input =
Arg.(value & opt file default_request_file & info [ "i"; "input" ] ~doc)
in
Cmd.make (Cmd.info "upload" ~doc ~man)
@@ @@
let+ input = input in let+ input = input and+ url = url in
upload ~input |> to_term_ret upload ~input ~url
let sign_cmd = let sign_cmd =
let doc = "Sign FutureKeysResponse." in let doc = "Sign FutureKeysResponse." in
let master_key =
let doc = "Master offline Eddsa private key file." in
Arg.(value & opt file default_master_offline_key_file & info [ "key" ] ~doc)
in
let input =
Arg.(value & opt file default_response_file & info [ "i"; "input" ] ~doc)
in
let output =
Arg.(
value & opt filepath default_request_file & info [ "o"; "output" ] ~doc)
in
Cmd.make (Cmd.info "sign" ~doc) Cmd.make (Cmd.info "sign" ~doc)
@@ @@
let+ input = input and+ output = output and+ master_key = master_key in let+ input = input and+ output = output and+ master_key = master_key in
sign ~input ~output ~master_key |> to_term_ret sign ~input ~output ~master_key
let revoke_denom_cmd =
let doc = "Revoke denomination." in
let h_denom =
let doc = "hash of denomination public key" in
Arg.(required & pos 0 (some string) None & info [] ~doc)
in
Cmd.make (Cmd.info "revoke-denom" ~doc)
@@
let+ output = output and+ master_key = master_key and+ h_denom = h_denom in
revoke_denom ~output ~master_key ~h_denom
let revoke_signkey_cmd =
let doc = "Revoke signkey." in
let signkey =
let doc = "public signing key" in
Arg.(required & pos 0 (some eddsa_pub) None & info [] ~doc)
in
Cmd.make (Cmd.info "revoke-signkey" ~doc)
@@
let+ output = output and+ master_key = master_key and+ signkey = signkey in
revoke_signkey ~output ~master_key ~signkey
let enable_auditor_cmd =
let doc = "Enable auditor." in
let auditor_url =
Arg.(required & opt (some string) None & info [ "auditor_url" ])
in
let auditor_name =
Arg.(required & opt (some string) None & info [ "auditor_name" ])
in
let auditor_pub =
Arg.(required & opt (some eddsa_pub) None & info [ "auditor_pub" ])
in
let validity_start =
Arg.(required & opt (some timestamp) None & info [ "validity_start" ])
in
Cmd.make (Cmd.info "enable-auditor" ~doc)
@@
let+ output = output
and+ master_key = master_key
and+ auditor_url = auditor_url
and+ auditor_name = auditor_name
and+ auditor_pub = auditor_pub
and+ validity_start = validity_start in
enable_auditor ~output ~master_key ~auditor_url ~auditor_name ~auditor_pub
~validity_start
let disable_auditor_cmd =
let doc = "Disable auditor." in
let auditor_pub =
Arg.(required & opt (some eddsa_pub) None & info [ "auditor_pub" ])
in
let validity_end =
Arg.(required & opt (some timestamp) None & info [ "validity_end" ])
in
Cmd.make (Cmd.info "disable-auditor" ~doc)
@@
let+ output = output
and+ master_key = master_key
and+ auditor_pub = auditor_pub
and+ validity_end = validity_end in
disable_auditor ~output ~master_key ~auditor_pub ~validity_end
let wire_fee_cmd =
let doc = "Provides wire fee configuration." in
let wire_method =
Arg.(required & opt (some string) None & info [ "wire_method" ])
in
let fee_start =
Arg.(required & opt (some timestamp) None & info [ "fee_start" ])
in
let fee_end =
Arg.(required & opt (some timestamp) None & info [ "fee_end" ])
in
let closing_fee =
Arg.(required & opt (some amount) None & info [ "closing_fee" ])
in
let wire_fee =
Arg.(required & opt (some amount) None & info [ "wire_fee" ])
in
Cmd.make (Cmd.info "wire-fee" ~doc)
@@
let+ output = output
and+ master_key = master_key
and+ wire_method = wire_method
and+ fee_start = fee_start
and+ fee_end = fee_end
and+ closing_fee = closing_fee
and+ wire_fee = wire_fee in
Offline_impl.wire_fee ~output ~master_key ~wire_method ~fee_start ~fee_end
~closing_fee ~wire_fee
let global_fees_cmd =
let doc = "Provides global fee configuration." in
let start_date =
Arg.(required & opt (some timestamp) None & info [ "start_date" ])
in
let end_date =
Arg.(required & opt (some timestamp) None & info [ "end_date" ])
in
let history_fee =
Arg.(required & opt (some amount) None & info [ "history_fee" ])
in
let account_fee =
Arg.(required & opt (some amount) None & info [ "account_fee" ])
in
let purse_fee =
Arg.(required & opt (some amount) None & info [ "purse_fee" ])
in
let history_expiration =
Arg.(
required & opt (some relative_time) None & info [ "history_expiration" ])
in
let purse_account_limit =
Arg.(required & opt (some int) None & info [ "purse_account_limit" ])
in
let purse_timeout =
Arg.(required & opt (some relative_time) None & info [ "purse_timeout" ])
in
Cmd.make (Cmd.info "global-fees" ~doc)
@@
let+ output = output
and+ master_key = master_key
and+ start_date = start_date
and+ end_date = end_date
and+ history_fee = history_fee
and+ account_fee = account_fee
and+ purse_fee = purse_fee
and+ history_expiration = history_expiration
and+ purse_account_limit = purse_account_limit
and+ purse_timeout = purse_timeout in
global_fees ~output ~master_key ~start_date ~end_date ~history_fee
~account_fee ~purse_fee ~history_expiration ~purse_account_limit
~purse_timeout
let drain_cmd =
let doc =
"Drain profits from the exchange. The actual drain requires running the \
`taler-exchange-drain` tool."
in
let debit_account_section =
Arg.(required & opt (some string) None & info [ "debit_account_section" ])
in
let credit_payto_uri =
Arg.(required & opt (some string) None & info [ "credit_payto_uri" ])
in
let wtid = Arg.(required & opt (some b32) None & info [ "wtid" ]) in
let date = Arg.(required & opt (some timestamp) None & info [ "date" ]) in
let amount = Arg.(required & opt (some amount) None & info [ "amount" ]) in
Cmd.make (Cmd.info "drain" ~doc)
@@
let+ output = output
and+ master_key = master_key
and+ debit_account_section = debit_account_section
and+ credit_payto_uri = credit_payto_uri
and+ wtid = wtid
and+ date = date
and+ amount = amount in
drain ~output ~master_key ~debit_account_section ~credit_payto_uri ~wtid ~date
~amount
let cli = let cli =
let info = let info =
let doc = "MTE Offline CLI tool" in let doc = "MTE Offline CLI tool" in
Cmd.info "mte-offline" ~doc Cmd.info "mte-offline" ~doc
in in
Cmd.group info [ setup_cmd; download_cmd; sign_cmd; upload_cmd ] Cmd.group info
[
setup_cmd;
download_cmd;
sign_cmd;
upload_cmd;
revoke_denom_cmd;
revoke_signkey_cmd;
enable_auditor_cmd;
disable_auditor_cmd;
wire_fee_cmd;
global_fees_cmd;
drain_cmd;
]
let main () = Cmd.eval_result cli let main () = Cmd.eval_result cli
let () = if !Sys.interactive then () else exit (main ()) let () = if !Sys.interactive then () else exit (main ())

84
tools/offline_bin.ml
View file

@ -1,84 +0,0 @@
open Crypto
open Bin_type
open Api
let denom_signature ~master_key
FutureDenom.
{
section_name= _;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
denom_pub;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund= _;
(* TODO check sigs *)
denom_secmod_sig= _;
} =
let octets = DenominationKey.to_octets denom_pub in
let h_denom_pub = HashCode.hash octets in
let master_sig =
let open Bin_signature.DenominationKeyValidityPS in
let master = EddsaPrivateKey.(pub_of_priv master_key) in
let denom_hash = DenominationHash.hash octets in
{
master;
start= stamp_start;
expire_withdraw= stamp_expire_withdraw;
expire_spend= stamp_expire_deposit;
expire_legal= stamp_expire_legal;
value;
fee_withdraw;
fee_deposit;
fee_refresh;
denom_hash;
}
|> Bin.to_string bin
|> EddsaSignature.sign ~key:master_key
in
DenomSignature.{ h_denom_pub; master_sig }
let signkey_signature ~master_key
FutureSignKey.
{
key;
stamp_start;
stamp_expire;
stamp_end;
(* TODO check sigs *)
signkey_secmod_sig= _;
} =
let master_sig =
let open Bin_signature.ExchangeSigningKeyValidityPS in
{
start= stamp_start;
expire= stamp_expire;
end_= stamp_end;
signkey_pub= key;
}
|> Bin.to_string bin
|> EddsaSignature.sign ~key:master_key
in
SignKeySignature.{ key; master_sig }
let make_master_signatures ~master_key
FutureKeysResponse.
{
future_denoms;
future_signkeys;
(* TODO check sigs *)
master_pub= _;
denom_secmod_public_key= _;
signkey_secmod_public_key= _;
} =
let denom_sigs = List.map (denom_signature ~master_key) future_denoms in
let signkey_sigs = List.map (signkey_signature ~master_key) future_signkeys in
MasterSignatures.{ denom_sigs; signkey_sigs }
let verify_future_key_response _future_key_response =
(* TODO *)
Ok ()

196
tools/offline_impl.ml
View file

@ -5,20 +5,22 @@ let read_file fname = Bos.OS.File.read (Fpath.v fname) |> unwrap_err_msg
let write_file fname content = let write_file fname content =
Bos.OS.File.write (Fpath.v fname) content |> unwrap_err_msg Bos.OS.File.write (Fpath.v fname) content |> unwrap_err_msg
let base_url = Uri.of_string "http://localhost:3434/" let read_master_key_file filename =
let* master_key = read_file filename in
Crypto.EddsaPrivateKey.of_octets master_key
let management_keys_url = let base_url = Uri.of_string "http://localhost:3434/"
Uri.with_path base_url "/management/keys/" |> Uri.to_string let full_url path = Uri.with_path base_url path |> Uri.to_string
let download ~output = let download ~output =
let open Bos in let open Bos in
let uri = management_keys_url in let uri = full_url "/management/keys/" in
OS.Cmd.run Cmd.(v "curl" % "-s" % "-o" % output % "-X" % "GET" % uri) OS.Cmd.run Cmd.(v "curl" % "-s" % "-o" % output % "-X" % "GET" % uri)
|> unwrap_err_msg |> unwrap_err_msg
let upload ~input = let upload ~input ~url =
let open Bos in let open Bos in
let uri = management_keys_url in let uri = full_url url in
OS.Cmd.run OS.Cmd.run
Cmd.( Cmd.(
v "curl" v "curl"
@ -42,14 +44,186 @@ let setup ~output =
let sign ~master_key ~input ~output = let sign ~master_key ~input ~output =
let open Crypto in let open Crypto in
let* master_key = read_master_key_file master_key in
let* input = read_file input in let* input = read_file input in
let* master_key = read_file master_key in let master_pub = EddsaPrivateKey.pub_of_priv master_key in
let master_key = EddsaPrivateKey.of_octets master_key in let* future_keys_response = Api.decode Api.FutureKeysResponse.jsont input in
let* future_key_response = Api.decode Api.FutureKeysResponse.jsont input in let* () =
let* () = Offline_bin.verify_future_key_response future_key_response in Offline_sig.verify_future_keys_response master_pub future_keys_response
in
let master_signatures = let master_signatures =
Offline_bin.make_master_signatures ~master_key future_key_response Offline_sig.mk_future_keys ~master_key future_keys_response
in in
let* s = Api.encode Api.MasterSignatures.jsont master_signatures in let* s = Api.encode Api.MasterSignatures.jsont master_signatures in
let* () = write_file output s in let* () = write_file output s in
Ok () Ok ()
let revoke_denom ~output ~master_key ~h_denom =
let* key = read_master_key_file master_key in
let* h_denom_pub = Bin_type.DenominationHash.of_b32 h_denom in
let denom_revoke =
let master_sig =
let open Bin_sig.MasterDenominationKeyRevocation in
sign_f ~f:(Crypto.EddsaSignature.sign ~key) { h_denom_pub }
in
Api.DenomRevocationSignature.{ master_sig }
in
let* s = Api.encode Api.DenomRevocationSignature.jsont denom_revoke in
let* () = write_file output s in
Ok ()
let revoke_signkey ~output ~master_key ~signkey =
let* key = read_master_key_file master_key in
let signkey_revoke =
let master_sig =
let open Bin_sig.MasterSigningKeyRevocation in
sign_f ~f:(Crypto.EddsaSignature.sign ~key) { exchange_pub= signkey }
in
Api.SignkeyRevocationSignature.{ master_sig }
in
let* s = Api.encode Api.SignkeyRevocationSignature.jsont signkey_revoke in
let* () = write_file output s in
Ok ()
let global_fees ~output ~master_key ~start_date ~end_date ~history_fee
~account_fee ~purse_fee ~history_expiration ~purse_account_limit
~purse_timeout =
let open Crypto in
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"
| true -> Ok (Int32.of_int purse_account_limit)
in
let master_sig =
let open Bin_sig.GlobalFees in
(* TODO KYC *)
let kyc_timeout = None in
let kyc_fee = Amount.dummy_value in
sign_f ~f:(EddsaSignature.sign ~key)
{
start_date;
end_date;
purse_timeout;
kyc_timeout;
history_expiration;
history_fee;
kyc_fee;
account_fee;
purse_fee;
purse_account_limit;
}
in
let global_fees =
Api.GlobalFees.
{
start_date;
end_date;
purse_timeout;
history_expiration;
history_fee;
account_fee;
purse_fee;
purse_account_limit;
master_sig;
}
in
let* s = Api.encode Api.GlobalFees.jsont global_fees in
let* () = write_file output s in
Ok ()
let enable_auditor ~output ~master_key ~auditor_url ~auditor_name ~auditor_pub
~validity_start =
let open Crypto in
let* key = read_master_key_file master_key in
let master_sig =
let open Bin_sig.MasterAddAuditor in
sign_f ~f:(EddsaSignature.sign ~key)
{
start_date= validity_start;
auditor_pub;
h_auditor_url= Bin_type.Hash_64_cstr.hash auditor_url;
}
in
let v =
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 ()
let disable_auditor ~output ~master_key ~auditor_pub ~validity_end =
let open Crypto in
let* key = read_master_key_file master_key in
let master_sig =
let open Bin_sig.MasterDelAuditor in
sign_f ~f:(EddsaSignature.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 ()
let wire_fee ~output ~master_key ~wire_method ~fee_start ~fee_end ~closing_fee
~wire_fee =
let open Crypto in
let* key = read_master_key_file master_key in
let master_sig_wire =
let open Bin_sig.MasterWireFee in
sign_f ~f:(EddsaSignature.sign ~key)
{
h_wire_method= Bin_type.Hash_64_cstr.hash wire_method;
start_date= fee_start;
end_date= fee_end;
closing_fee;
wire_fee;
}
in
let v =
Api.WireFeeSetupMessage.
{
wire_method;
fee_start;
fee_end;
closing_fee;
wire_fee;
master_sig_wire;
}
in
let* s = Api.encode Api.WireFeeSetupMessage.jsont v in
let* () = write_file output s in
Ok ()
let drain ~output ~master_key ~debit_account_section ~credit_payto_uri ~wtid
~date ~amount =
let open Crypto in
let* key = read_master_key_file master_key in
let master_sig =
let open Bin_sig.MasterDrainProfit in
sign_f ~f:(EddsaSignature.sign ~key)
{
wtid;
date;
amount;
h_section= Bin_type.Hash_64_cstr.hash debit_account_section;
h_payto= Bin_type.FullPaytoHash.hash credit_payto_uri;
}
in
let v =
Api.DrainProfitsMessage.
{
debit_account_section;
credit_payto_uri;
wtid;
master_sig;
date;
amount;
}
in
let* s = Api.encode Api.DrainProfitsMessage.jsont v in
let* () = write_file output s in
Ok ()

147
tools/offline_sig.ml Normal file
View file

@ -0,0 +1,147 @@
open Crypto
open Bin_type
open Api
let verify_future_keys_response =
let verify_future_denom ~sm_denom_pub
FutureDenom.
{
section_name;
value= _;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit= _;
stamp_expire_legal= _;
denom_pub;
fee_withdraw= _;
fee_deposit= _;
fee_refresh= _;
fee_refund= _;
denom_secmod_sig;
} =
let h_denom_pub =
DenominationHash.hash (DenominationKey.to_octets denom_pub)
in
let h_section_name = Hash_64_cstr.hash section_name in
let anchor_time = stamp_start in
let duration_withdraw = Timestamp.diff stamp_start stamp_expire_withdraw in
let open Bin_sig.DenominationKeyAnnouncement in
verify_f
~f:(EddsaSignature.verify ~key:sm_denom_pub)
denom_secmod_sig
{ h_denom_pub; h_section_name; anchor_time; duration_withdraw }
in
let verify_future_signkey ~sm_signkey_pub
FutureSignKey.
{ key; stamp_start; stamp_expire; stamp_end= _; signkey_secmod_sig } =
let exchange_pub = key in
let anchor_time = stamp_start in
let duration = Timestamp.diff stamp_start stamp_expire in
let open Bin_sig.SigningKeyAnnouncement in
verify_f
~f:(EddsaSignature.verify ~key:sm_signkey_pub)
signkey_secmod_sig
{ exchange_pub; anchor_time; duration }
in
fun our_master_public_key
FutureKeysResponse.
{
future_denoms;
future_signkeys;
master_pub;
denom_secmod_public_key;
signkey_secmod_public_key;
}
->
let open Syntax in
let* () =
match master_pub = our_master_public_key with
| false ->
Fmt.error
"master public key of the future key response does not match ours"
| true -> Ok ()
in
let* () =
list_iter
(verify_future_denom ~sm_denom_pub:denom_secmod_public_key)
future_denoms
in
let* () =
list_iter
(verify_future_signkey ~sm_signkey_pub:signkey_secmod_public_key)
future_signkeys
in
Ok ()
let mk_future_keys =
let denom_signature ~master_key
FutureDenom.
{
section_name= _;
value;
stamp_start;
stamp_expire_withdraw;
stamp_expire_deposit;
stamp_expire_legal;
denom_pub;
fee_withdraw;
fee_deposit;
fee_refresh;
fee_refund= _;
denom_secmod_sig= _;
} =
let octets = DenominationKey.to_octets denom_pub in
let h_denom_pub = DenominationHash.hash octets in
let master_sig =
let open Bin_sig.DenominationKeyValidity in
let master = EddsaPrivateKey.(pub_of_priv master_key) in
sign_f
~f:(EddsaSignature.sign ~key:master_key)
{
master;
start= stamp_start;
expire_withdraw= stamp_expire_withdraw;
expire_spend= stamp_expire_deposit;
expire_legal= stamp_expire_legal;
value;
fee_withdraw;
fee_deposit;
fee_refresh;
denom_hash= h_denom_pub;
}
in
DenomSignature.{ h_denom_pub; master_sig }
in
let signkey_signature ~master_key
FutureSignKey.
{ key; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig= _ } =
let master_sig =
let open Bin_sig.ExchangeSigningKeyValidity in
sign_f
~f:(EddsaSignature.sign ~key:master_key)
{
start= stamp_start;
expire= stamp_expire;
end_= stamp_end;
signkey_pub= key;
}
in
SignKeySignature.{ key; master_sig }
in
fun ~master_key
FutureKeysResponse.
{
future_denoms;
future_signkeys;
master_pub= _;
denom_secmod_public_key= _;
signkey_secmod_public_key= _;
}
->
let denom_sigs = List.map (denom_signature ~master_key) future_denoms in
let signkey_sigs =
List.map (signkey_signature ~master_key) future_signkeys
in
MasterSignatures.{ denom_sigs; signkey_sigs }