diff --git a/GNUmakefile b/GNUmakefile index f367effb..3052f8ae 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -13,13 +13,14 @@ check-kvm: pins: #opam pin --no-action --yes "git+https://github.com/robur-coop/mcrunch.git#682ed63c03e3be5664f96c469a260e1d9e9df011" opam pin --no-action --yes "git+https://github.com/mirage/Zarith.git#zarith-1.14" - opam pin --no-action --yes "git+https://github.com/robur-coop/vif.git#8c6ac3fb97cb9a31bf6ad8ec63c942336dcfd03e" + opam pin --no-action --yes "git+https://github.com/robur-coop/vif.git#e8b3053476162d119dee8cefe38511d679d3ad55" opam pin --no-action --yes "git+https://github.com/robur-coop/mfat.git#5b1204d914e853f0139c6d2776511f530b753550" opam pin --no-action --yes "git+https://github.com/swrup/mirage-mtime.git#6a6bb4dd25624a3c43e6417dcdf73f3c689946a7" opam pin --no-action --yes add caqti "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0" opam pin --no-action --yes add caqti-miou "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0" opam pin --no-action --yes add caqti-mnet "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0" opam pin --no-action --yes add caqti-driver-pgx "git+https://github.com/swrup/ocaml-caqti.git#186650581efd9d247ced982cdefd74256905e3b0" + opam pin --no-action --yes "git+https://github.com/robur-coop/mnet.git#7e07437cda26f8efd3da0c4d14d76293d8fcbc78" installs: # opam install --yes mcrunch diff --git a/src/amount.ml b/src/amount.ml index 696ed9af..e2e3e4f2 100644 --- a/src/amount.ml +++ b/src/amount.ml @@ -40,7 +40,7 @@ let check_fraction v = if Int32.unsigned_compare v fraction_limit < 0 then Ok () else Fmt.error "fraction has more than %d digits" fraction_nb_digits -let make ~sign ~currency ~value ~fraction = +let make sign currency value fraction = let* () = check_currency currency in let* () = check_value value in let* () = check_fraction fraction in @@ -93,10 +93,7 @@ module Parser = struct return n) let amount = - lift4 - (fun sign currency value fraction -> - make ~sign ~currency ~value ~fraction) - sign letters + lift4 make sign letters (char ':' *> value) (option 0_l (char '.' *> fraction)) <* end_of_input @@ -105,8 +102,6 @@ module Parser = struct Angstrom.parse_string ~consume:Consume.All amount s |> Result.join end -let of_string = Parser.parse - let pp = let open Fmt in let pp_sign = @@ -133,31 +128,35 @@ let pp = pf ppf "%a%s:%Lu%a" pp_sign sign currency value pp_fraction fraction let to_string = Fmt.str "%a" pp +let of_string = Parser.parse (* - *) let jsont = Jsont.of_of_string ~kind:"Amount" of_string ~enc:to_string -let pad_currency_string s = - let len = String.length s in - match len < currency_length_limit with - | false -> Fmt.failwith "amount with invalid currency" - | true -> - let b = Bytes.make currency_length_limit '\x00' in - Bytes.blit_string s 0 b 0 len; - Bytes.unsafe_to_string b - -(* binary decoding never unused *) -let make_exn value fraction currency = - match make ~sign:None ~currency ~value ~fraction with - | Error _ -> Fmt.failwith "Amount of binary data failure" - | Ok v -> v +(* note: binary decoding never used, like for all signatures types *) +let decode_exn value fraction currency = + match make None currency value fraction with + | Error e -> Fmt.failwith "amount decode %s." e + | Ok t -> t let bin = let open Bin in - record make_exn + record decode_exn |+ field beint64 (fun t -> t.value) |+ field beint32 (fun t -> t.fraction) |+ field (bytes currency_length_limit) (fun t -> - pad_currency_string t.currency) + let len = String.length t.currency in + if not (len < currency_length_limit) then + Fmt.failwith "broken amount currency"; + let b = Bytes.make currency_length_limit '\x00' in + Bytes.blit_string t.currency 0 b 0 len; + Bytes.unsafe_to_string b) |> sealr + +let caqti ~currency = + let open Caqti_type in + custom + ~encode:(fun amount -> Ok (amount.value, amount.fraction)) + ~decode:(fun (value, fraction) -> make None currency value fraction) + (t2 int64 int32) diff --git a/src/amount.mli b/src/amount.mli index 01496ff5..98f902ff 100644 --- a/src/amount.mli +++ b/src/amount.mli @@ -9,17 +9,10 @@ type t = private { fraction: Int32.t; } -val make : - sign:sign option -> - currency:string -> - value:Int64.t -> - fraction:Int32.t -> - (t, string) result +val make : sign option -> string -> Int64.t -> Int32.t -> (t, string) result (* fail on differents currencies *) val compare : t -> t -> int - -(* TODO rename pp_dump *) val pp : Format.formatter -> t -> unit val to_string : t -> string val of_string : string -> (t, string) result @@ -27,4 +20,4 @@ val of_string : string -> (t, string) result (* - *) val jsont : t Jsont.t val bin : t Bin.t -(* [caqti] is in pg_type.ml *) +val caqti : currency:string -> t Caqti_type.t diff --git a/src/api.ml b/src/api.ml index 1cf8f3b5..40b1f386 100644 --- a/src/api.ml +++ b/src/api.ml @@ -8,11 +8,19 @@ - uri *) module DenominationHash = Hash.DenominationHash +module Bytes32 = Signatures.Bytes32 +module Bytes64 = Signatures.Bytes64 open Time open Signatures -let encode jsont v = Jsont_bytesrw.encode_string jsont v -let decode jsont v = Jsont_bytesrw.decode_string jsont v +let encode' jsont v = Jsont_bytesrw.encode_string jsont v +let decode' jsont v = Jsont_bytesrw.decode_string jsont v + +let encode jsont v = + encode' jsont v |> Result.map_error (fun e -> `Json_encode e) + +let decode jsont v = + decode' jsont v |> Result.map_error (fun e -> `Json_decode e) open Jsont.Object @@ -57,34 +65,6 @@ module B32 = struct ~decode:B32.decode Caqti_type.string end -module Bytes32 = struct - include Signatures.Bytes32 - - let jsont = - let decode s = Result.bind (B32.decode s) of_octets in - let encode b = to_octets b |> B32.encode in - Jsont.of_of_string ~kind:"Bytes32" decode ~enc:encode - - let caqti = - Caqti_type.custom - ~encode:(fun v -> Ok (to_octets v)) - ~decode:of_octets Caqti_type.octets -end - -module Bytes64 = struct - include Signatures.Bytes64 - - let jsont = - let decode s = Result.bind (B32.decode s) of_octets in - let encode b = to_octets b |> B32.encode in - Jsont.of_of_string ~kind:"Bytes64" decode ~enc:encode - - let caqti = - Caqti_type.custom - ~encode:(fun v -> Ok (to_octets v)) - ~decode:of_octets Caqti_type.octets -end - module ErrorDetail = struct type t = { code: int; diff --git a/src/assets.ml b/src/assets.ml index eb4bbe41..8208c0b7 100644 --- a/src/assets.ml +++ b/src/assets.ml @@ -1,6 +1,13 @@ (* https://docs.taler.net/design-documents/003-tos-rendering.html must support `text/plain` and `text/markdown` *) +let failure fmt = + Fmt.kstr + (fun s -> + Fmt.epr "Assets failure: %s.@." s; + exit 1) + fmt + type t = | Terms | Privacy @@ -35,7 +42,7 @@ let supported_lang_arr, supported_ext_arr = | [] -> assert false | [ dir; _file ] -> dir | _l -> - Fmt.failwith "invalid folder structure, file `%s` is misplaced" + failure "invalid folder structure, file `%s` is misplaced" (Fpath.to_string Fpath.(prefix // path))) path_l in @@ -45,25 +52,23 @@ let supported_lang_arr, supported_ext_arr = (fun path -> let etag' = Fpath.to_string (Fpath.rem_ext (Fpath.base path)) in if not @@ String.equal etag etag' then - Fmt.failwith - "filename `%s` does not match configuration ETAG value `%s`" + failure "filename `%s` does not match configuration ETAG value `%s`" (Fpath.to_string Fpath.(prefix // path)) etag) path_l; - if List.is_empty lang_l then Fmt.failwith "no language supported"; - if List.is_empty ext_l then Fmt.failwith "no mimetype supported"; + if List.is_empty lang_l then failure "no language supported"; + if List.is_empty ext_l then failure "no mimetype supported"; if not @@ List.mem Cfg.default_lang lang_l then - Fmt.failwith "default language `%s` files not found" Cfg.default_lang; - if not @@ List.mem ".txt" ext_l then - Fmt.failwith "plain text file not found"; - if not @@ List.mem ".md" ext_l then Fmt.failwith "markdown file not found"; + failure "default language `%s` files not found" Cfg.default_lang; + if not @@ List.mem ".txt" ext_l then failure "plain text file not found"; + if not @@ List.mem ".md" ext_l then failure "markdown file not found"; List.iter (fun dir -> if String.length dir <> 2 then - Fmt.failwith "language directory with invalid name: `%s`" dir) + failure "language directory with invalid name: `%s`" dir) lang_l; if List.length path_l <> List.length ext_l * List.length lang_l then - Fmt.failwith + failure "invalid folder structure, all supported language must provide the \ same set of file mimetype" else (lang_l, ext_l) @@ -75,7 +80,7 @@ let supported_lang_arr, supported_ext_arr = && List.equal String.equal ext_l ext_l' with | false -> - Fmt.failwith + failure "invalid folder structure, /terms and /privacy must support the same \ set of languages and mimetypes" | true -> (Array.of_list lang_l, Array.of_list ext_l) @@ -104,8 +109,7 @@ module Mimetype = struct let () = if not @@ List.mem (Cfg.default_mimetype, Cfg.default_extension) assoc then - Fmt.failwith "default content type `%a` not supported" pp - Cfg.default_mimetype + failure "default content type `%a` not supported" pp Cfg.default_mimetype let arr = let all_supported, all_supported_ext = List.split assoc in @@ -114,7 +118,7 @@ module Mimetype = struct (fun ext -> not @@ List.exists (( = ) ext) all_supported_ext) supported_ext_arr with - | Some ext -> Fmt.failwith "extension `%s` unsupported" ext + | Some ext -> failure "extension `%s` unsupported" ext | None -> Array.of_list all_supported let of_cohttp = function @@ -137,7 +141,7 @@ module Language = struct let () = if not @@ Array.mem default arr then - Fmt.failwith "default language `%s` not supported" Cfg.default_lang + failure "default language `%s` not supported" Cfg.default_lang let of_cohttp = function | Cohttp.Accept.AnyLanguage -> Some default diff --git a/src/b32.ml b/src/b32.ml index 6bd06400..7a412d24 100644 --- a/src/b32.ml +++ b/src/b32.ml @@ -33,6 +33,5 @@ let decode s = let n = 8 - (String.length s mod 8) in let pad = String.make n '=' in let s = s ^ pad in - match Base32.decode ~alphabet ~off:0 ~len:(String.length s) s with - | Error (`Msg e) -> Error e - | Ok v -> Ok v + Base32.decode ~alphabet ~off:0 ~len:(String.length s) s + |> Result.map_error (fun (`Msg e) -> e) diff --git a/src/bbin.ml b/src/bbin.ml new file mode 100644 index 00000000..1293fa5c --- /dev/null +++ b/src/bbin.ml @@ -0,0 +1,11 @@ +let encode bin t = + try Ok (Bin.to_string bin t) + with Invalid_argument e -> + Fmt.error "Bin encode error %s" e + |> Result.map_error (fun e -> `Bin_encode e) + +let decode bin o = + try Ok (Bin.decode bin o (ref 0)) + with Invalid_argument e -> + Fmt.error "Bin decode error %s" e + |> Result.map_error (fun e -> `Bin_decode e) diff --git a/src/config.ml b/src/config.ml index c7f23500..d80b284f 100644 --- a/src/config.ml +++ b/src/config.ml @@ -1,13 +1,12 @@ open Config_parser -let config_filename = "mte.conf" - -(* TODO config - read Fpath.t *) +module Cfg = struct + let config_filename = "mte.conf" +end let config_data = - match Assets_crunch.read config_filename with - | None -> fail "static file not found: `%s`" config_filename + match Assets_crunch.read Cfg.config_filename with + | None -> failure "static file `%s` not found" Cfg.config_filename | Some data -> let v = Config_section.parse data in v @@ -144,7 +143,7 @@ module Currency = struct alt_unit_names= get "alt_unit_names" |> Jsont_bytesrw.decode_string Alt_unit_names.jsont - |> unwrap; + |> unwrap_or_failure; } let all_currencies = List.map parse_currency currency_sections @@ -154,11 +153,12 @@ module Currency = struct List.find_opt (fun v -> v.code = Exchange.currency) all_currencies with | None -> - fail "section `[currency-%s]` not found, currency `%s` is not defined" + failure + "section `[currency-%s]` not found, currency `%s` is not defined" Exchange.currency Exchange.currency | Some v -> ( match v.enabled = `YES with - | false -> fail "currency `%s` is not enabled" Exchange.currency + | false -> failure "currency `%s` is not enabled" Exchange.currency | true -> v) end @@ -178,45 +178,36 @@ module Coin = struct age_restricted: [ (*`YES|*) `NO ]; } - let coin_sections = - List.filter - (fun v -> - (* note: here its a '_' not '-' *) - String.starts_with ~prefix:"coin_" v.header) - config_data - - let parse_coin section = - let get field = get config_data ~section:section.header ~field in - let section_name = - String.sub section.header 5 (String.length section.header - 5) - in - let rsa_keysize s = - let nbits = int s in - let len = ((nbits - 1) / 8) + 1 in - if 8 * len <> nbits then - (* because of [kdf_mod_n] *) - invalid_arg "RSA keysize must be multiple of 8" - else nbits - in - { - section_name; - value= get "value" |> amount; - duration_withdraw= get "duration_withdraw" |> duration; - duration_spend= get "duration_spend" |> duration; - duration_legal= get "duration_legal" |> duration; - fee_withdraw= get "fee_withdraw" |> amount; - fee_deposit= get "fee_deposit" |> amount; - fee_refresh= get "fee_refresh" |> amount; - fee_refund= get "fee_refund" |> amount; - cipher= (get "cipher" |> const_value "RSA" |> fun _s -> `RSA); - rsa_keysize= get "rsa_keysize" |> rsa_keysize; - age_restricted= - ( get "age_restricted" |> yes_no |> function - | `NO -> `NO - | `YES -> fail "`age_restricted = YES` is not supported" ); - } - - let all_coins = List.map parse_coin coin_sections + let all_coins = + (* ! '_' not '-' *) + let prefix = "coin_" in + let prefix_len = String.length prefix in + config_data + |> List.filter (fun v -> String.starts_with ~prefix v.header) + |> List.map (fun section -> + let get field = get config_data ~section:section.header ~field in + let section_name = + String.sub section.header prefix_len + (String.length section.header - prefix_len) + in + { + section_name; + value= get "value" |> amount; + duration_withdraw= get "duration_withdraw" |> duration; + duration_spend= get "duration_spend" |> duration; + duration_legal= get "duration_legal" |> duration; + fee_withdraw= get "fee_withdraw" |> amount; + fee_deposit= get "fee_deposit" |> amount; + fee_refresh= get "fee_refresh" |> amount; + fee_refund= get "fee_refund" |> amount; + cipher= (get "cipher" |> const_value "RSA" |> fun _s -> `RSA); + rsa_keysize= get "rsa_keysize" |> rsa_keysize; + age_restricted= + ( get "age_restricted" |> yes_no |> function + | `NO -> `NO + | `YES -> failure "age restriction is not supported" ); + }) + |> Iarray.of_list end module Exchange_secmod_rsa = struct diff --git a/src/config_parser.ml b/src/config_parser.ml index 40ebb04c..35289f71 100644 --- a/src/config_parser.ml +++ b/src/config_parser.ml @@ -3,6 +3,15 @@ do not support "$"-path expansion *) +let failure fmt = + Fmt.kstr + (fun s -> + Fmt.epr "Config failure: %s.@." s; + exit 1) + fmt + +let unwrap_or_failure = function Error e -> failure "`%s`" e | Ok v -> v + open Angstrom type item = { @@ -15,10 +24,6 @@ type section = { items: item list; } -let fail fmt = - let k _ppf = exit 1 in - Fmt.kpf k Fmt.stderr ("Configuration failure: " ^^ fmt ^^ ".@.") - let is_eol = function '\n' | '\r' -> true | _ -> false let is_whitespace = function ' ' | '\t' -> true | _ -> false let blanks = skip_while is_whitespace @@ -54,7 +59,7 @@ module Config_section = struct let quoted_value = char '"' *> take_till is_eol <* end_of_line >>= fun s -> match String.ends_with ~suffix:"\"" s && s <> "\"" with - | false -> fail "invalid quoted value" + | false -> failure "invalid quoted value `%s`" s | true -> let value = String.sub s 0 (String.length s - 1) in return value @@ -75,7 +80,7 @@ module Config_section = struct match l with | [] -> if List.is_empty item_l then section_l - else fail "invalid configuration structure" + else failure "invalid section structure" | Blank :: tl | Comment _ :: tl -> loop section_l item_l tl | Item item :: tl -> loop section_l (item :: item_l) tl | Header header :: tl -> @@ -86,7 +91,7 @@ module Config_section = struct let parse s = match parse_string ~consume:All config s with - | Error msg -> fail "parse error `%s`" msg + | Error msg -> failure "parse error `%s`" msg | Ok v -> fold_sections v end @@ -99,7 +104,7 @@ module Config_duration = struct let integer = take_while1 (function '0' .. '9' -> true | _ -> false) >>= fun s -> match int_of_string_opt s with - | None -> fail "expected integer, got `%s`" s + | None -> failure "expected integer, got `%s`" s | Some i -> return i let duration_element = @@ -113,7 +118,7 @@ module Config_duration = struct | "hour" | "hours" -> return `Hour | "minute" | "minutes" -> return `Minute | "second" | "seconds" | "s" -> return `Second - | s -> fail "expected a duration unit, got `%s`" s + | s -> failure "expected a duration unit, got `%s`" s in lift2 (fun number dunit -> { number; dunit }) number dunit @@ -140,12 +145,10 @@ module Config_duration = struct let parse s : duration_element list = match parse_string ~consume:All duration s with - | Error msg -> fail "duration parse error `%s`" msg + | Error msg -> failure "duration parse error `%s`" msg | Ok v -> v end -let unwrap = function Error e -> fail "`%s`." e | Ok v -> v - let get_opt t ~section ~field = match List.find_opt (fun v -> v.header = section) t with | None -> None @@ -156,33 +159,34 @@ let get_opt t ~section ~field = let get t ~section ~field = match get_opt t ~section ~field with - | None -> fail "option `[%s].%s` not found" section field + | None -> failure "option `[%s].%s` not found" section field | Some v -> v let int s = match int_of_string_opt s with - | None -> fail "expected int value, got `%s`" s + | None -> failure "expected int value, got `%s`" s | Some v -> v let float s = match float_of_string_opt s with - | None -> fail "expected float value, got `%s`" s + | None -> failure "expected float value, got `%s`" s | Some v -> v let const_value a b = - match a = b with false -> fail "unexpected value `%s`" b | true -> a + match a = b with false -> failure "unexpected value `%s`" b | true -> a let yes_no = function | "NO" -> `NO | "YES" -> `YES - | s -> fail "expected `YES`/`NO` value, got `%s`" s + | s -> failure "expected `YES`/`NO` value, got `%s`" s +let etag s = s let uri s = Uri.of_string s let amount = let currency = ref None in fun s -> - let amount = s |> Amount.of_string |> unwrap in + let amount = s |> Amount.of_string |> unwrap_or_failure in match !currency with | None -> currency := Some amount.currency; @@ -190,18 +194,19 @@ let amount = | Some cur -> ( match String.equal amount.currency cur with | false -> - fail "only one kind of currency is supported, found: `%s` and `%s`." + failure + "only one kind of currency is supported, found: `%s` and `%s`." amount.currency cur | true -> amount) let duration s = Config_duration.(s |> parse |> to_time_span) -let ed25519 s = - s - |> B32.decode - |> unwrap - |> Mirage_crypto_ec.Ed25519.pub_of_octets - |> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e) - |> unwrap +let rsa_keysize s = + let nbits = int s in + let len = ((nbits - 1) / 8) + 1 in + if 8 * len = nbits then nbits + else + (* because of [kdf_mod_n] *) + failure "RSA keysize must be multiple of 8, found `%d`" nbits -let etag s = s +let ed25519 s = Eddsa.pub_of_b32 s |> unwrap_or_failure diff --git a/src/denomination.ml b/src/denomination.ml index 3f013097..535be269 100644 --- a/src/denomination.ml +++ b/src/denomination.ml @@ -35,13 +35,11 @@ let verify_denomination_key_validity ~key dn = } let make_denom_group_sorted denominations = - let open Syntax in + (* IMPROVE: no need for hashtbl *) (* use hashtbl to re-group denoms *) let ht = Hashtbl.create 0xff in - List.iter - (fun coin -> - let open Config.Coin in - assert (coin.cipher = `RSA); + Iarray.iter + (fun (coin : Config.Coin.t) -> let k = ( coin.value, coin.fee_withdraw, @@ -52,43 +50,42 @@ let make_denom_group_sorted denominations = let v = [] in Hashtbl.replace ht k v) Config.Coin.all_coins; - let+ () = - list_iter - (fun { - pub; - value; - stamp_start; - stamp_expire_withdraw; - stamp_expire_deposit; - stamp_expire_legal; - fee_withdraw; - fee_deposit; - fee_refresh; - fee_refund; - age_mask= _; - h_pub= _; - master_sig; - } -> - let k = (value, fee_withdraw, fee_deposit, fee_refresh, fee_refund) in - let v = - Api.RsaDenom. - { - rsa_pub= pub; - master_sig; - stamp_start; - stamp_expire_withdraw; - stamp_expire_deposit; - stamp_expire_legal; - lost= None; - } - in - match Hashtbl.find_opt ht k with - | None -> Error "denomination does not match any coin in configuration" - | Some l -> - Hashtbl.replace ht k (v :: l); - Ok ()) - denominations - in + List.iter + (fun { + pub; + value; + stamp_start; + stamp_expire_withdraw; + stamp_expire_deposit; + stamp_expire_legal; + fee_withdraw; + fee_deposit; + fee_refresh; + fee_refund; + age_mask= _; + h_pub= _; + master_sig; + } -> + let k = (value, fee_withdraw, fee_deposit, fee_refresh, fee_refund) in + let v = + Api.RsaDenom. + { + rsa_pub= pub; + master_sig; + stamp_start; + stamp_expire_withdraw; + stamp_expire_deposit; + stamp_expire_legal; + lost= None; + } + in + match Hashtbl.find_opt ht k with + | None -> + Fmt.failwith "denomination does not match any coin in configuration" + | Some l -> + Hashtbl.replace ht k (v :: l); + ()) + denominations; let l = Hashtbl.to_seq ht |> List.of_seq in (* ! important for /keys .exchange_sig @@ -102,22 +99,21 @@ let make_denom_group_sorted denominations = let cmp_denom b a = Timestamp.compare a.stamp_start b.stamp_start in let cmp_group = fun (Rsa a) (Rsa b) -> Amount.compare a.value b.value in let l = - l - |> List.map - (fun - ((value, fee_withdraw, fee_deposit, fee_refresh, fee_refund), denoms) + List.map + (fun ((value, fee_withdraw, fee_deposit, fee_refresh, fee_refund), denoms) -> - Rsa - { - denoms= List.sort cmp_denom denoms; - value; - fee_withdraw; - fee_deposit; - fee_refresh; - fee_refund; - }) - |> List.sort cmp_group + Rsa + { + denoms= List.sort cmp_denom denoms; + value; + fee_withdraw; + fee_deposit; + fee_refresh; + fee_refund; + }) + l in + let l = List.sort cmp_group l in l let denoms_of_denomgroups l = @@ -150,7 +146,7 @@ let denoms_of_denomgroups l = lost= _; } -> - let h_pub = DenominationHash.hash_of_rsa rsa_pub in + let h_pub = DenominationHash.hash rsa_pub in { pub= rsa_pub; value; diff --git a/src/dune b/src/dune index b3e32408..5a5fed2d 100644 --- a/src/dune +++ b/src/dune @@ -45,7 +45,9 @@ (name mte) (wrapped false) (modules + result syntax + bbin amount libtool_version time diff --git a/src/eddsa.ml b/src/eddsa.ml index 9e7f2d6c..89bd5f19 100644 --- a/src/eddsa.ml +++ b/src/eddsa.ml @@ -1,7 +1,7 @@ open Syntax module Mirage_eddsa = Mirage_crypto_ec.Ed25519 -let pp_error = Mirage_crypto_ec.pp_error +let pp_mirage_error = Mirage_crypto_ec.pp_error type priv = Mirage_eddsa.priv type pub = Mirage_eddsa.pub @@ -9,50 +9,6 @@ type sig_ = S of string [@@unboxed] let generate = Mirage_eddsa.generate let pub_of_priv = Mirage_eddsa.pub_of_priv -let priv_to_octets t = Mirage_eddsa.priv_to_octets t - -let priv_of_octets t = - Mirage_eddsa.priv_of_octets t |> function - | Error err -> Fmt.error "%a" pp_error err - | Ok v -> Ok v - -let priv_bin = - let priv_of_octets_exn t = priv_of_octets t |> Result.get_ok in - Bin.map (Bin.bytes 32) priv_of_octets_exn priv_to_octets - -let priv_jsont = - let of_b32 s = - let* octets = B32.decode s in - priv_of_octets octets - in - let to_b32 t = B32.encode (priv_to_octets t) in - Jsont.of_of_string ~kind:"EddsaPrivateKey" of_b32 ~enc:to_b32 - -let pub_to_octets t = Mirage_eddsa.pub_to_octets t - -let pub_of_octets t = - Mirage_eddsa.pub_of_octets t |> function - | Error e -> Fmt.error "%a" pp_error e - | Ok v -> Ok v - -let pub_bin = - let pub_of_octets_exn t = pub_of_octets t |> Result.get_ok in - Bin.map (Bin.bytes 32) pub_of_octets_exn pub_to_octets - -let pub_of_b32 s = - let* octets = B32.decode s in - pub_of_octets octets - -let pub_to_b32 t = B32.encode (pub_to_octets t) - -let pub_jsont = - Jsont.of_of_string ~kind:"EddsaPublicKey" pub_of_b32 ~enc:pub_to_b32 - -let pub_caqti = - Caqti_type.custom - ~encode:(fun v -> Ok (pub_to_octets v)) - ~decode:(fun v -> pub_of_octets v) - Caqti_type.octets let sign ~key s = let sig_ = Mirage_eddsa.sign ~key s in @@ -60,29 +16,90 @@ let sign ~key s = let verify ~key (S s) ~msg = let b = Mirage_eddsa.verify ~key s ~msg in - match b with false -> Error "Eddsa verify: not valid" | true -> Ok () + if b then Ok () else Error `Invalid_signature_eddsa -let sig_to_octets (S s) = s +module Priv = struct + let priv_to_octets t = Mirage_eddsa.priv_to_octets t -let sig_of_octets s = - match String.length s = 64 with - | false -> Error "Eddsa decode signature (binary): invalid data" - | true -> Ok (S s) + let priv_of_octets o = + Mirage_eddsa.priv_of_octets o + |> Result.map_error (Fmt.str "%a" pp_mirage_error) -let sig_bin = - let sig_of_octets_exn t = sig_of_octets t |> Result.get_ok in - Bin.map (Bin.bytes 64) sig_of_octets_exn sig_to_octets + let priv_to_b32 t = priv_to_octets t |> B32.encode + + let priv_of_b32 s = + let* octets = B32.decode s in + priv_of_octets octets + + let priv_jsont = + Jsont.of_of_string ~kind:"EddsaPrivateKey" priv_of_b32 ~enc:priv_to_b32 + + let priv_bin = + let priv_of_octets_exn t = + match priv_of_octets t with Error e -> invalid_arg e | Ok v -> v + in + Bin.map (Bin.bytes 32) priv_of_octets_exn priv_to_octets +end + +module Pub = struct + let pub_to_octets t = Mirage_eddsa.pub_to_octets t + + let pub_of_octets t = + Mirage_eddsa.pub_of_octets t + |> Result.map_error (Fmt.str "%a" pp_mirage_error) + + let pub_to_b32 t = pub_to_octets t |> B32.encode + + let pub_of_b32 s = + let* octets = B32.decode s in + pub_of_octets octets + + let pub_jsont = + Jsont.of_of_string ~kind:"EddsaPublicKey" pub_of_b32 ~enc:pub_to_b32 + + let pub_bin = + let pub_of_octets_exn t = + match pub_of_octets t with Error e -> invalid_arg e | Ok v -> v + in + Bin.map (Bin.bytes 32) pub_of_octets_exn pub_to_octets + + let pub_caqti = + Caqti_type.custom + ~encode:(fun v -> Ok (pub_to_octets v)) + ~decode:pub_of_octets Caqti_type.octets +end + +module Sig_ = struct + let sig_to_octets (S s) = s + + let sig_of_octets s = + match String.length s = 64 with + | false -> Error "invalid eddsa signature length" + | true -> Ok (S s) -let sig_jsont = let sig_of_b32 s = let* s = B32.decode s in sig_of_octets s - in - let sig_to_b32 (S s) = B32.encode s in - Jsont.of_of_string ~kind:"EddsaSignature" sig_of_b32 ~enc:sig_to_b32 -let sig_caqti = - Caqti_type.custom - ~encode:(fun v -> Ok (sig_to_octets v)) - ~decode:(fun s -> sig_of_octets s) - Caqti_type.octets + let sig_to_b32 (S s) = B32.encode s + + let sig_jsont = + Jsont.of_of_string ~kind:"EddsaSignature" sig_of_b32 ~enc:sig_to_b32 + + let sig_bin = + let sig_of_octets_exn t = + match sig_of_octets t with Error e -> invalid_arg e | Ok v -> v + in + Bin.map (Bin.bytes 64) sig_of_octets_exn sig_to_octets + + let sig_caqti = + Caqti_type.custom + ~encode:(fun v -> Ok (sig_to_octets v)) + ~decode:sig_of_octets Caqti_type.octets +end + +include Priv +include Pub +include Sig_ + +let pp_pub ppf pub = Fmt.pf ppf "%s" (pub_to_b32 pub) diff --git a/src/fat.ml b/src/fat.ml index 4d1cada4..5d8a6214 100644 --- a/src/fat.ml +++ b/src/fat.ml @@ -19,6 +19,14 @@ module Path = struct let equal a b = 0 = compare a b end +type t = Mkernel.Block.t Mfat.t + +type entry = Mfat.entry = { + name: string; + is_dir: bool; + size: int32; +} + module Fat = Mfat.Make (struct include Mkernel.Block @@ -28,18 +36,21 @@ end) include Fat -type entry = Mfat.entry = { - name: string; - is_dir: bool; - size: int32; -} - let create blk = - match Fat.create blk with - | Error (`Msg e) -> Fmt.failwith "FAT file system failure: %s." e + match create blk with + | Error (`Msg e) -> + Fmt.epr "FAT file system initialization failure: %s@." e; + exit 1 | Ok fs -> fs -type t = Mkernel.Block.t Mfat.t +let map_err r = Result.map_error (fun (`Msg e) -> `Mfat e) r +let ls t p = ls t p |> map_err +let read t p = read t p |> map_err +let write t p s = write t p s |> map_err +let mkdir t p = mkdir t p |> map_err +let remove t p = remove t p |> map_err +let exists t p = exists t p +let stat t p = stat t p |> map_err module type FS = sig val t : t diff --git a/src/hash.ml b/src/hash.ml index 251c601c..aed0b3e7 100644 --- a/src/hash.ml +++ b/src/hash.ml @@ -1,77 +1,55 @@ -(* TODO hash over canonicalized json - https://docs.taler.net/design-documents/018-contract-json.html#canonicalized-hashing - https://datatracker.ietf.org/doc/html/rfc8785 *) -open Digestif +open Syntax module type S = sig type t + val hash : string -> t + val to_octets : t -> string + val to_b32 : t -> B32.t + val of_b32 : B32.t -> (t, string) result + val pp_hex : Format.formatter -> t -> unit + val pp : Format.formatter -> t -> unit val bin : t Bin.t val caqti : t Caqti_type.t val jsont : t Jsont.t - val hash : string -> t - val of_octets : string -> t - val to_octets : t -> string - val of_b32 : B32.t -> (t, string) result - val to_b32 : t -> B32.t end -module H32 : S = struct - type t = SHA256.t +module MK (H : Digestif.S) : S = struct + type t = H.t - let hash s = SHA256.(digest_string s) + let hash s = H.(digest_string s) let of_octets s = - match SHA256.of_raw_string_opt s with - | None -> Fmt.failwith "H32.of_octets failure" - | Some t -> t + match H.of_raw_string_opt s with + | None -> Error "invalid hash" + | Some t -> Ok t - let to_octets = SHA256.to_raw_string - let of_b32 s = Result.map of_octets (B32.decode s) + let to_octets = H.to_raw_string let to_b32 t = B32.encode (to_octets t) + let of_b32 s = + let* o = B32.decode s in + of_octets o + + let pp_hex = H.pp + let pp ppf t = Fmt.pf ppf "%s" (to_b32 t) + let bin = - let open Bin in - map (bytes 32) of_octets to_octets + let of_octets_exn s = + of_octets s |> function Error e -> invalid_arg e | Ok t -> t + in + Bin.map (Bin.bytes H.digest_size) of_octets_exn to_octets (* hashs are not b32 encoded in the database *) let caqti = let open Caqti_type in - custom - ~encode:(fun v -> Ok (to_octets v)) - ~decode:(fun v -> Ok (of_octets v)) - octets + custom ~encode:(fun v -> Ok (to_octets v)) ~decode:of_octets octets - let jsont = Jsont.of_of_string ~kind:"Hash 32" of_b32 ~enc:to_b32 + let jsont = Jsont.of_of_string ~kind:"hash" of_b32 ~enc:to_b32 end -module H64 : S = struct - type t = SHA512.t - - let hash s = SHA512.(digest_string s) - - let of_octets s = - match SHA512.of_raw_string_opt s with - | None -> Fmt.failwith "H64.of_octets failure" - | Some t -> t - - let to_octets = SHA512.to_raw_string - let of_b32 s = Result.map of_octets (B32.decode s) - let to_b32 t = B32.encode (to_octets t) - - let bin = - let open Bin in - map (bytes 64) of_octets to_octets - - let caqti = - let open Caqti_type in - custom - ~encode:(fun v -> Ok (to_octets v)) - ~decode:(fun v -> Ok (of_octets v)) - octets - - let jsont = Jsont.of_of_string ~kind:"Hash 64" of_b32 ~enc:to_b32 -end +module H32 = MK (Digestif.SHA256) +module H64 = MK (Digestif.SHA512) module H32_cstring : S = struct include H32 @@ -86,20 +64,11 @@ module H64_cstring : S = struct end module DenominationHash : sig - type t + include S - val bin : t Bin.t - val caqti : t Caqti_type.t - val jsont : t Jsont.t - val hash_of_rsa : Rsa.pub -> t - val of_octets : string -> t - val to_octets : t -> string - val of_b32 : B32.t -> (t, string) result - val to_b32 : t -> B32.t + val hash : Rsa.pub -> t end = struct - open Digestif - - type t = SHA512.t + include H64 type cipher = | RSA @@ -108,7 +77,7 @@ end = struct (* = GNUNET_CRYPTO_BSA_(RSA|CS) *) let cipher_to_int32 = function RSA -> 1_l | CS -> 2_l - let hash_of_rsa pub = + let hash pub = let age_mask = 0_l in let cipher = cipher_to_int32 RSA in let pub = Rsa.pub_to_octets pub in @@ -117,33 +86,9 @@ end = struct Bytes.set_int32_be buf 0 age_mask; Bytes.set_int32_be buf 4 cipher; Bytes.blit_string pub 0 buf 8 len; - SHA512.digest_bytes buf - - let of_octets s = - match SHA512.of_raw_string_opt s with - | None -> Fmt.failwith "H64.of_octets failure" - | Some t -> t - - let to_octets = SHA512.to_raw_string - let of_b32 s = Result.map of_octets (B32.decode s) - let to_b32 t = B32.encode (to_octets t) - - let bin = - let open Bin in - map (bytes 64) of_octets to_octets - - let caqti = - let open Caqti_type in - custom - ~encode:(fun v -> Ok (to_octets v)) - ~decode:(fun v -> Ok (of_octets v)) - octets - - let jsont = Jsont.of_of_string ~kind:"DenominationHash" of_b32 ~enc:to_b32 + hash (Bytes.unsafe_to_string buf) end -(* TODO - check which hash algorithm to use for each hash type *) module FullPaytoHash : S = H32 module NormalizedPaytoHash : S = H32 module PrivateContractHash : S = H64 @@ -154,3 +99,8 @@ module BlindedCoinHash : S = H64 module CoinPubHash : S = H64 module OutputCommitmentHash : S = H64 module HashPlanchetsP : S = H64 + +(* TODO + hash over canonicalized json + https://docs.taler.net/design-documents/018-contract-json.html#canonicalized-hashing + https://datatracker.ietf.org/doc/html/rfc8785 *) diff --git a/src/keys.ml b/src/keys.ml index d6fe5397..afc67476 100644 --- a/src/keys.ml +++ b/src/keys.ml @@ -2,31 +2,29 @@ open Syntax module DenominationHash = Hash.DenominationHash open Time -type 'a result = ('a, string) Result.t - module type S = sig val sign : Eddsa.pub -> string -> Eddsa.sig_ val sign_denom : DenominationHash.t -> string -> Rsa.sig_ - val find_signkey : Eddsa.pub -> Signkey.t option result - val find_denomination : DenominationHash.t -> Denomination.t option result - val signkeys : unit -> Signkey.t list result - val denominations : unit -> Denomination.t list result + val find_signkey : Eddsa.pub -> Signkey.t option Result.t + val find_denomination : DenominationHash.t -> Denomination.t option Result.t + val signkeys : unit -> Signkey.t list Result.t + val denominations : unit -> Denomination.t list Result.t val denominations_last_change : unit -> Timestamp.t (* future keys *) - val make_future_keys_response : unit -> Api.FutureKeysResponse.t result - val verify_future_signkey : Api.SignKeySignature.t -> unit result - val verify_future_denomination : Api.DenomSignature.t -> unit result - val certify_future_signkey : Api.SignKeySignature.t -> unit result - val certify_future_denomination : Api.DenomSignature.t -> unit result + val make_future_keys_response : unit -> Api.FutureKeysResponse.t Result.t + val verify_future_signkey : Api.SignKeySignature.t -> unit Result.t + val verify_future_denomination : Api.DenomSignature.t -> unit Result.t + val certify_future_signkey : Api.SignKeySignature.t -> unit Result.t + val certify_future_denomination : Api.DenomSignature.t -> unit Result.t val revoke_signkey : - Eddsa.pub -> Signatures.MasterSigningKeyRevocation.t -> unit result + Eddsa.pub -> Signatures.MasterSigningKeyRevocation.t -> unit Result.t val revoke_denomination : DenominationHash.t -> Signatures.MasterDenominationKeyRevocation.t -> - unit result + unit Result.t end module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct @@ -34,25 +32,12 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct module Sm_rsa = Secmod_rsa.Make (Fs) let conn = (module Conn : Pg.CONN) - - (* TODO better error - can only be "key not found", either: - - we tried to sign with a key that is not ours - - key was revoked - - bad keyring state *) - let sign pub s = - match Sm_eddsa.sign pub s with - | Error e -> Fmt.failwith "sign failure: %s." e - | Ok v -> v - - let sign_denom h_pub s = - match Sm_rsa.sign h_pub s with - | Error e -> Fmt.failwith "sign_denom failure: %s." e - | Ok v -> v + let sign = Sm_eddsa.sign + let sign_denom = Sm_rsa.sign (* - *) - let find_signkey pub = Pg.find_signkey conn pub |> unwrap_caqti - let find_denomination h_pub = Pg.find_denom conn h_pub |> unwrap_caqti + let find_signkey pub = Pg.find_signkey conn pub + let find_denomination h_pub = Pg.find_denom conn h_pub let warn_key_state = let first = ref true in @@ -65,9 +50,9 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct first := false; ()) - let signkeys () : Signkey.t list result = + let signkeys () : Signkey.t list Result.t = let now = Timestamp.of_ptime @@ Mirage_ptime.now () in - let+ l = Pg.get_signkeys conn ~now |> unwrap_caqti in + let+ l = Pg.get_signkeys conn ~now in let missing_l, l = List.partition (fun sk -> Option.is_none @@ Sm_eddsa.find_key sk.Signkey.pub) @@ -81,7 +66,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct l let denominations () = - let+ l = Pg.get_denominations conn () |> unwrap_caqti in + let+ l = Pg.get_denominations conn () in let missing_l, l = List.partition (fun dn -> Option.is_none @@ Sm_rsa.find_key dn.Denomination.h_pub) @@ -96,7 +81,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct l let make_future_sk (pub, (start, expire)) = - Logs.debug (fun m -> m "make_future_sk: `%s`" (Eddsa.pub_to_b32 pub)); + Logs.debug (fun m -> m "make_future_sk: `%a`" Eddsa.pp_pub pub); let open Time in let stamp_start = Timestamp.of_absolute start in let stamp_expire = Timestamp.of_absolute expire in @@ -114,35 +99,23 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct Api.FutureSignKey. { key= pub; stamp_start; stamp_expire; stamp_end; signkey_secmod_sig } - let coin_of_section_name section_name = - Config.Coin.all_coins - |> List.find_opt (fun coin -> coin.Config.Coin.section_name = section_name) - |> function - | None -> - Fmt.failwith "coin section `%s` not found in configuration" section_name - | Some v -> v - - let make_future_dn (h_pub, (section_name, pub, start)) = - Logs.debug (fun m -> - m "make_future_dn: `%s`" (DenominationHash.to_b32 h_pub)); - let open Time in - let Config.Coin. - { - section_name; - value; - duration_withdraw; - duration_spend; - duration_legal; - fee_withdraw; - fee_deposit; - fee_refresh; - fee_refund; - cipher= _; - rsa_keysize= _; - age_restricted= _; - } = - coin_of_section_name section_name + let make_future_dn (h_pub, (coin, pub, start)) = + let { + Config.Coin.section_name; + value; + duration_withdraw; + duration_spend; + duration_legal; + fee_withdraw; + fee_deposit; + fee_refresh; + fee_refund; + _; + } = + coin in + Logs.debug (fun m -> m "make_future_dn: `%a`" DenominationHash.pp h_pub); + let open Time in let stamp_start = Timestamp.of_absolute start in let stamp_expire_withdraw = Timestamp.of_absolute @@ TimeAbsolute.add start duration_withdraw @@ -186,22 +159,22 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct let find_future_signkey pub = match Sm_eddsa.find_key pub with - | None -> Error "future signkey not found" + | None -> Fmt.error_msg "future signkey not found" | Some (pub, (t1, t2)) -> let fsk = make_future_sk (pub, (t1, t2)) in Ok fsk let find_future_denomination h_pub = match Sm_rsa.find_key h_pub with - | None -> Error "future denomination not found" - | Some (h_pub, (section_name, pub, t1)) -> - let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in + | None -> Fmt.error_msg "future denomination not found" + | Some v -> + let future_dn = make_future_dn v in Ok future_dn let make_future_keys_response () = let now = Timestamp.of_ptime @@ Mirage_ptime.now () in (* get keys from database to filter out keys already certified *) - let* sk_db_l = Pg.get_signkeys conn ~now |> unwrap_caqti in + let* sk_db_l = Pg.get_signkeys conn ~now in let sk_ht = Hashtbl.create 0xff in List.iter (fun sk -> Hashtbl.replace sk_ht sk.Signkey.pub ()) sk_db_l; let future_signkeys = @@ -209,7 +182,7 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct |> List.filter (fun (pub, _) -> not @@ Hashtbl.mem sk_ht pub) |> List.map make_future_sk in - let* dn_db_l = Pg.get_denominations conn () |> unwrap_caqti in + let* dn_db_l = Pg.get_denominations conn () in let dn_ht = Hashtbl.create 0xff in List.iter (fun dn -> Hashtbl.replace dn_ht dn.Denomination.h_pub ()) dn_db_l; let future_denoms = @@ -296,60 +269,45 @@ module Make (Conn : Pg.CONN) (Fs : Fat.FS) : S = struct let certify_future_signkey Api.SignKeySignature.{ key= pub; master_sig } = match Sm_eddsa.find_key pub with - | None -> Error "future signkey not found" - | Some (pub, (t1, t2)) -> ( - let* opt = find_signkey pub in - match opt with - | Some _sk -> - Logs.info (fun m -> m "signkey already certified"); - Ok () - | None -> - (* rebuild it *) - let future_sk = make_future_sk (pub, (t1, t2)) in - let sk = sk_of_future_sk future_sk master_sig in - let+ () = Pg.insert_signkey conn sk |> unwrap_caqti in - Logs.info (fun m -> - m "certified signkey `%s`" (Eddsa.pub_to_b32 sk.pub)); - ()) + | None -> Error `Not_found + | Some (pub, (t1, t2)) -> + (* rebuild it *) + let future_sk = make_future_sk (pub, (t1, t2)) in + let sk = sk_of_future_sk future_sk master_sig in + let+ () = Pg.insert_signkey conn sk in + Logs.info (fun m -> m "certified signkey `%a`" Eddsa.pp_pub sk.pub); + () let certify_future_denomination Api.DenomSignature.{ h_denom_pub= h_pub; master_sig } = match Sm_rsa.find_key h_pub with - | None -> Error "future denomination not found" - | Some (h_pub, (section_name, pub, t1)) -> ( - let* opt = find_denomination h_pub in - match opt with - | Some _dn -> - Logs.info (fun m -> m "denomination already certified"); - Ok () - | None -> - let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in - let dn = dn_of_future_dn future_dn h_pub master_sig in - let+ () = Pg.insert_denom conn dn |> unwrap_caqti in - Logs.info (fun m -> - m "certified denomination `%s`" - (DenominationHash.to_b32 dn.h_pub)); - ()) + | None -> Error `Not_found + | Some (h_pub, (section_name, pub, t1)) -> + let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in + let dn = dn_of_future_dn future_dn h_pub master_sig in + let+ () = Pg.insert_denom conn dn in + Logs.info (fun m -> + m "certified denomination `%a`" DenominationHash.pp dn.h_pub); + () let revoke_signkey pub revoked_sig = let* opt = find_signkey pub in - let* _sk = Option.to_result ~none:"signkey not found" opt in - let* () = Sm_eddsa.revoke pub in - let+ () = - Pg.insert_signkey_revocation conn pub revoked_sig |> unwrap_caqti - in - Logs.info (fun m -> m "revoked signkey `%s`" (Eddsa.pub_to_b32 pub)); - () + match opt with + | None -> Fmt.error_msg "signkey not found" + | Some _sk -> + let* () = Sm_eddsa.revoke pub in + let+ () = Pg.insert_signkey_revocation conn pub revoked_sig in + Logs.info (fun m -> m "revoked signkey `%a`" Eddsa.pp_pub pub); + () let revoke_denomination h_pub revoked_sig = let* opt = find_denomination h_pub in - let* dn = Option.to_result ~none:"denomination not found" opt in - let* () = Sm_rsa.revoke dn.h_pub in - let+ () = - Pg.insert_denomination_revocation conn dn.h_pub revoked_sig - |> unwrap_caqti - in - Logs.info (fun m -> - m "revoked denomination `%s`" (DenominationHash.to_b32 h_pub)); - () + match opt with + | None -> Fmt.error_msg "denomination not found" + | Some dn -> + let* () = Sm_rsa.revoke dn.h_pub in + let+ () = Pg.insert_denomination_revocation conn dn.h_pub revoked_sig in + Logs.info (fun m -> + m "revoked denomination `%a`" DenominationHash.pp h_pub); + () end diff --git a/src/libtool_version.ml b/src/libtool_version.ml index 74c94dcd..7e19e666 100644 --- a/src/libtool_version.ml +++ b/src/libtool_version.ml @@ -25,7 +25,7 @@ let of_string s = in let* l = String.split_on_char ':' s |> Syntax.list_map to_int in match l with - | [] -> Fmt.failwith "not possible" + | [] -> assert false | [ current ] -> Ok { current; revision= None; age= None } | [ current; revision ] -> Ok { current; revision= Some revision; age= None } | [ current; revision; age ] -> @@ -39,10 +39,16 @@ let pp ppf v = Fmt.pf ppf "%d:%d" current revision | { current; revision= Some revision; age= Some age } -> Fmt.pf ppf "%d:%d:%d" current revision age - | _ -> Fmt.failwith "corrupt version data: has age with no revision" + | _ -> assert false let jsont = Jsont.of_of_string ~kind:"libtool version" of_string ~enc:(Fmt.str "%a" pp) +let mte_protocol_version = "31:0:0" + let mte_protocol_version = - "31:0:0" |> of_string |> function Error e -> Fmt.failwith "%s" e | Ok v -> v + match of_string mte_protocol_version with + | Error e -> + Fmt.epr "Invalid libtool version: %s" e; + exit 1 + | Ok v -> v diff --git a/src/libtool_version.mli b/src/libtool_version.mli new file mode 100644 index 00000000..6984a37f --- /dev/null +++ b/src/libtool_version.mli @@ -0,0 +1,7 @@ +type t + +val mte_protocol_version : t +val is_compatible : implementation:t -> t -> bool +val of_string : string -> (t, string) result +val pp : Format.formatter -> t -> unit +val jsont : t Jsont.t diff --git a/src/log_reporter.ml b/src/log_reporter.ml index 945ed21c..4b8c1240 100644 --- a/src/log_reporter.ml +++ b/src/log_reporter.ml @@ -56,6 +56,13 @@ let set_level_secmods lvl = let setup level = (* set_level_secmods level; *) + (* + let l = Logs.Src.list () in + let l = + List.filter (fun src -> Logs.Src.name src = "mnet.happy_eyeballs") l + in + List.iter (fun src -> Logs.Src.set_level src None) l; +*) Logs.set_level ~all:false level; Logs.Src.set_level Logs.default level; Logs.set_reporter reporter; diff --git a/src/mte.ml b/src/mte.ml index 3e2c6c85..66f9f595 100644 --- a/src/mte.ml +++ b/src/mte.ml @@ -71,9 +71,11 @@ let routes = module RNG = Mirage_crypto_rng.Fortuna +let log_level = Some Logs.Info + let () = let ( let@ ) finally fn = Fun.protect ~finally fn in - Log_reporter.setup (Some Logs.Info); + Log_reporter.setup log_level; let rng = let rng () = Mirage_crypto_rng_mkernel.initialize (module RNG) in Mkernel.map rng Mkernel.[] diff --git a/src/mte_info.ml b/src/mte_info.ml index 6b670c96..070734bf 100644 --- a/src/mte_info.ml +++ b/src/mte_info.ml @@ -42,11 +42,11 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date = let stefan_lin = Config.stefan_lin in (* type of the asset. "fiat", "crypto", "regional" or "stock". *) let asset_type = "fiat" in - let* accounts = Pg.get_wire_accounts db_conn () |> unwrap_caqti in + let* accounts = Pg.get_wire_accounts db_conn () in let* wire_fees = (* wire_methods? *) let wire_method = "x-taler-bank" in - let+ wire_fees = Pg.get_wire_fees db_conn ~wire_method |> unwrap_caqti in + let+ wire_fees = Pg.get_wire_fees db_conn ~wire_method in String_map.singleton wire_method wire_fees in let wads = [] in @@ -81,7 +81,7 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date = (fun v -> Timestamp.compare timestamp v.Denomination.stamp_start <= 0) denom_l in - let* denominations = Denomination.make_denom_group_sorted denom_l in + let denominations = Denomination.make_denom_group_sorted denom_l in let* signkeys = Keys.signkeys () in @@ -92,7 +92,7 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date = List.find_opt (fun sk -> Signkey.is_valid_at ~timestamp:now sk) signkeys in match opt with - | None -> Fmt.error "exchange has no active signkey" + | None -> Fmt.error_msg "exchange has no active signkey" | Some sk -> Ok sk.pub in let signkeys = List.map Api.SignKey.of_signkey signkeys in @@ -109,9 +109,7 @@ let mk_keys ~db_conn (module Keys : Keys.S) ~last_issue_date = in let recoup = (* /recoup *) [] in - let* global_fees = - Pg.get_global_fees db_conn ~start_date:Timestamp.zero |> unwrap_caqti - in + let* global_fees = Pg.get_global_fees db_conn ~start_date:Timestamp.zero in let* auditors = (* /auditors/$AUDITOR_PUB/$H_DENOM_PUB *) Pg.get_auditor_keys db_conn @@ -167,7 +165,8 @@ let keys req server _env = | [] -> Ok None | s :: _ -> ( match Int64.of_string_opt s with - | None -> Error "invalid `?last_issue_date` query param, not an int" + | None -> + Fmt.error_msg "invalid `?last_issue_date` query param, not an int" | Some n -> Ok (Some (Timestamp.of_s n))) in let* v = mk_keys ~db_conn keys ~last_issue_date in diff --git a/src/mte_management.ml b/src/mte_management.ml index 6f913d01..025d4bcc 100644 --- a/src/mte_management.ml +++ b/src/mte_management.ml @@ -3,6 +3,10 @@ open Api open Hash open Time +(* todo request.ml? *) +let request_of_json req = + Result.map_error (fun (`Msg e) -> `Json_decode e) (Vifu.Request.of_json req) + module Keys_get = struct let jsont = FutureKeysResponse.jsont @@ -34,7 +38,7 @@ module Keys_post = struct Logs.info (fun m -> m "POST /management/keys/"); let keys = Vifu.Server.device Global.keys server in let res = - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* v = request_of_json req in let* () = verify keys v in let* () = do_ keys v in Ok () @@ -59,8 +63,11 @@ module Denom_revoke = struct Logs.info (fun m -> m "POST /management/denominations/$H_DENOM_PUB/revoke/"); let keys = Vifu.Server.device Global.keys server in let res = - let* h_denom_pub = Hash.DenominationHash.of_b32 h_denom_pub in - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* h_denom_pub = + DenominationHash.of_b32 h_denom_pub + |> Result.map_error (fun e -> `Msg e) + in + let* v = request_of_json req in let* () = verify keys h_denom_pub v in let* () = do_ keys h_denom_pub v in Ok () @@ -85,8 +92,10 @@ module Signkey_revoke = struct Logs.info (fun m -> m "POST /management/signkeys/$EXCHANGE_PUB/revoke/"); let keys = Vifu.Server.device Global.keys server in let res = - let* exchange_pub = Eddsa.pub_of_b32 exchange_pub in - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* exchange_pub = + Eddsa.pub_of_b32 exchange_pub |> Result.map_error (fun e -> `Msg e) + in + let* v = request_of_json req in let* () = verify keys exchange_pub v in let* () = do_ keys exchange_pub v in Ok () @@ -109,24 +118,24 @@ module Auditors = struct { start_date= validity_start; auditor_pub; - h_auditor_url= Hash.H64_cstring.hash auditor_url; + h_auditor_url= H64_cstring.hash auditor_url; } let do_ ~db_conn v = let auditor_pub = v.AuditorSetupMessage.auditor_pub in let validity_start = v.AuditorSetupMessage.validity_start in - let* opt = Pg.find_auditor db_conn auditor_pub |> unwrap_caqti in + let* opt = Pg.find_auditor db_conn auditor_pub in match opt with | None -> let auditor = Pg_type.Auditor.of_setup_message v in - let+ () = Pg.update_auditor db_conn auditor |> unwrap_caqti in + let+ () = Pg.update_auditor db_conn auditor in Logs.info (fun m -> m "enabled auditor"); () | Some auditor -> if Timestamp.compare validity_start auditor.last_change <= 0 then - Error "replay detected on enable-auditor" + Error (`Conflict "replay detected on enable-auditor") else - let+ () = Pg.update_auditor db_conn auditor |> unwrap_caqti in + let+ () = Pg.update_auditor db_conn auditor in Logs.info (fun m -> m "updated auditor"); () @@ -137,7 +146,7 @@ module Auditors = struct let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in let res = - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* v = request_of_json req in let* () = verify keys v in let* () = do_ ~db_conn v in Ok () @@ -154,12 +163,12 @@ module Auditors_disable = struct let do_ ~db_conn auditor_pub AuditorTeardownMessage.{ master_sig= _; validity_end } = - let* opt = Pg.find_auditor db_conn auditor_pub |> unwrap_caqti in + let* opt = Pg.find_auditor db_conn auditor_pub in match opt with - | None -> Error "auditor not found" + | None -> Error `Not_found | Some auditor -> ( if Timestamp.compare validity_end auditor.last_change <= 0 then - Error "replay detected on disable-auditor" + Error (`Conflict "replay detected on disable-auditor") else match auditor.is_active with | false -> @@ -169,9 +178,9 @@ module Auditors_disable = struct let auditor = { auditor with last_change= validity_end; is_active= false } in - let+ () = Pg.update_auditor db_conn auditor |> unwrap_caqti in + let+ () = Pg.update_auditor db_conn auditor in Logs.info (fun m -> - m "revoked auditor `%s`" (Eddsa.pub_to_b32 auditor_pub)); + m "revoked auditor `%a`" Eddsa.pp_pub auditor_pub); ()) let jsont = AuditorTeardownMessage.jsont @@ -181,8 +190,10 @@ module Auditors_disable = struct let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in let res = - let* auditor_pub = Eddsa.pub_of_b32 auditor_pub in - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* auditor_pub = + Eddsa.pub_of_b32 auditor_pub |> Result.map_error (fun e -> `Msg e) + in + let* v = request_of_json req in let* () = verify keys auditor_pub v in let* () = do_ ~db_conn auditor_pub v in Ok () @@ -204,7 +215,7 @@ module Wire_fee = struct let open Signatures.MasterWireFee in verify Config.master_public_key master_sig_wire { - h_wire_method= Hash.H64_cstring.hash wire_method; + h_wire_method= H64_cstring.hash wire_method; start_date= fee_start; end_date= fee_end; wire_fee; @@ -215,22 +226,23 @@ module Wire_fee = struct let* wire_fees = Pg.get_wire_fees_by_time db_conn ~wire_method:v.wire_method ~start_date:v.fee_start ~end_date:v.fee_end - |> unwrap_caqti in match wire_fees with | [] -> - let+ () = Pg.insert_wire_fee db_conn v |> unwrap_caqti in + let+ () = Pg.insert_wire_fee db_conn v in Logs.info (fun m -> m "added wire fee"); () | [ vv ] -> ( match v.master_sig_wire = vv.sig_ with | false -> - Error "a different wire-fee was already setup for this time frame" + Error + (`Conflict + "a different wire-fee was already setup for this time frame") | true -> Logs.info (fun m -> m "an identical wire-fee was already setup"); Ok ()) | _ -> - Error + Fmt.error_msg "invalid database state, multiple wire-fee found in database for \ this time frame" @@ -241,7 +253,7 @@ module Wire_fee = struct let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in let res = - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* v = request_of_json req in let* () = verify keys v in let* () = do_ ~db_conn v in Ok () @@ -256,23 +268,24 @@ module Global_fees = struct let* global_fees = let start_date = v.GlobalFees.start_date in let end_date = v.GlobalFees.end_date in - Pg.get_global_fees_by_time db_conn ~start_date ~end_date |> unwrap_caqti + Pg.get_global_fees_by_time db_conn ~start_date ~end_date in match global_fees with | [] -> - let+ () = Pg.insert_global_fees db_conn v |> unwrap_caqti in + let+ () = Pg.insert_global_fees db_conn v in Logs.info (fun m -> m "added global fees"); () | [ vv ] -> ( match v.master_sig = vv.master_sig with | false -> Error - "a different global-fees was already setup for this time frame" + (`Conflict + "a different global-fees was already setup for this time frame") | true -> Logs.info (fun m -> m "an identical global-fees was already setup"); Ok ()) | _ -> - Error + Fmt.error_msg "invalid database state, multiple global-fees found in database for \ this time frame" @@ -286,7 +299,7 @@ module Global_fees = struct Logs.info (fun m -> m "POST /management/global-fees/"); let db_conn = Vifu.Server.device Global.db_conn server in let res = - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* v = request_of_json req in let* () = verify v in let* () = do_ ~db_conn v in Ok () @@ -314,16 +327,17 @@ module Wire = struct match (credit_restrictions, debit_restrictions) with | [], [] -> Ok () | _ -> - Fmt.error + Fmt.error_msg "wire setup: credit_restrictions and debit_restrictions are not \ supported" in - let h_wire_details = Hash.FullPaytoHash.hash payto_uri in + let h_wire_details = FullPaytoHash.hash payto_uri in let h_conversion_url = - Hash.H64_cstring.hash ((* ?? *) Option.value ~default:"" conversion_url) + let s = Option.value ~default:"" conversion_url in + H64_cstring.hash s in - let h_credit_restrictions = Hash.H64_cstring.hash "" in - let h_debit_restrictions = Hash.H64_cstring.hash "" in + let h_credit_restrictions = H64_cstring.hash "" in + let h_debit_restrictions = H64_cstring.hash "" in (* - *) let* () = let open Signatures.MasterWireDetails in @@ -361,7 +375,7 @@ module Wire = struct bank_label; priority; } = - let* opt = Pg.find_wire db_conn ~payto_uri |> unwrap_caqti in + let* opt = Pg.find_wire db_conn ~payto_uri in match opt with | None -> let wire = @@ -379,18 +393,16 @@ module Wire = struct let+ () = Pg.update_wire db_conn ~is_active:true ~last_change:validity_start wire - |> unwrap_caqti in Logs.info (fun m -> m "added wire method"); () | Some (wire, _is_active, last_change) -> if Timestamp.compare validity_start last_change <= 0 then - Error "replay detected on enable-wire" + Error (`Conflict "replay detected on enable-wire") else let+ () = Pg.update_wire db_conn ~is_active:true ~last_change:validity_start wire - |> unwrap_caqti in Logs.info (fun m -> m "updated wire method"); () @@ -402,7 +414,7 @@ module Wire = struct let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in let res = - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* v = request_of_json req in let* () = verify keys v in let* () = do_ ~db_conn v in Ok () @@ -419,17 +431,16 @@ module Wire_disable = struct let do_ ~db_conn WireTeardownMessage.{ payto_uri; master_sig_del= _; validity_end } = - let* opt = Pg.find_wire db_conn ~payto_uri |> unwrap_caqti in + let* opt = Pg.find_wire db_conn ~payto_uri in match opt with - | None -> Error "wire not found" + | None -> Error `Not_found | Some (wire, _is_active, last_change) -> if Timestamp.compare validity_end last_change <= 0 then - Error "replay detected on disable-wire" + Error (`Conflict "replay detected on disable-wire") else let+ () = Pg.update_wire db_conn ~is_active:false ~last_change:validity_end wire - |> unwrap_caqti in Logs.info (fun m -> m "disabled wire method"); () @@ -441,7 +452,7 @@ module Wire_disable = struct let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in let res = - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* v = request_of_json req in let* () = verify keys v in let* () = do_ ~db_conn v in Ok () @@ -466,20 +477,18 @@ module Drain = struct wtid; date; amount; - h_section= Hash.H64_cstring.hash debit_account_section; + h_section= H64_cstring.hash debit_account_section; h_payto= FullPaytoHash.hash credit_payto_uri; } let do_ ~db_conn v = - let* opt = - Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid |> unwrap_caqti - in + let* opt = Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid in match opt with | Some _ -> Logs.info (fun m -> m "drain profit message already added to database"); Ok () | None -> - let+ () = Pg.insert_drain_profit db_conn v |> unwrap_caqti in + let+ () = Pg.insert_drain_profit db_conn v in Logs.info (fun m -> m "added drain profit message to database"); () @@ -490,7 +499,7 @@ module Drain = struct let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in let res = - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* v = request_of_json req in let* () = verify keys v in let* () = do_ ~db_conn v in Ok () @@ -515,12 +524,12 @@ module AmlOfficer = struct { change_date; officer_pub; - h_officer_name= Hash.H64_cstring.hash officer_name; + h_officer_name= H64_cstring.hash officer_name; is_active; } let do_ ~db_conn v = - let+ _last_change = Pg.insert_aml_officer db_conn v |> unwrap_caqti in + let+ _last_change = Pg.insert_aml_officer db_conn v in () let jsont = AmlOfficerSetup.jsont @@ -530,7 +539,7 @@ module AmlOfficer = struct let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in let res = - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* v = request_of_json req in let* () = verify keys v in let* () = do_ ~db_conn v in Ok () @@ -558,11 +567,11 @@ module Partners = struct end_date; wad_frequency; wad_fee; - h_url= Hash.H64_cstring.hash partner_base_url; + h_url= H64_cstring.hash partner_base_url; } let do_ ~db_conn v = - let+ () = Pg.insert_partner db_conn v |> unwrap_caqti in + let+ () = Pg.insert_partner db_conn v in () let jsont = ExchangePartnerSetupRequest.jsont @@ -572,7 +581,7 @@ module Partners = struct let keys = Vifu.Server.device Global.keys server in let db_conn = Vifu.Server.device Global.db_conn server in let res = - let* v = Vifu.Request.of_json req |> unwrap_msg in + let* v = request_of_json req in let* () = verify keys v in let* () = do_ ~db_conn v in Ok () diff --git a/src/pg.ml b/src/pg.ml index 09949928..719b5f31 100644 --- a/src/pg.ml +++ b/src/pg.ml @@ -4,18 +4,23 @@ module type CONN = Caqti_miou.CONNECTION -module Caqti_type = struct - include Caqti_type - include Pg_type - include Caqti_request.Infix -end +let map_err r = + Result.map_error (Fmt.kstr (fun e -> `Caqti e) "%a" Caqti_error.pp) r +let exec (module Conn : CONN) req v = Conn.exec req v |> map_err +let find (module Conn : CONN) req v = Conn.find req v |> map_err +let find_opt (module Conn : CONN) req v = Conn.find_opt req v |> map_err +let collect_list (module Conn : CONN) req v = Conn.collect_list req v |> map_err +let disconnect (module Conn : CONN) () = Conn.disconnect () + +open Caqti_request.Infix +open Caqti_type +open Pg_type open Api let preflight = let l = - List.map - Caqti_type.(unit ->. unit) + List.map (unit ->. unit) [ "SET SESSION CHARACTERISTICS AS TRANSACTION ISOLATION LEVEL \ SERIALIZABLE;"; @@ -25,53 +30,52 @@ let preflight = "SET search_path TO exchange;"; ] in - fun (module Conn : CONN) -> - let r = Syntax.list_iter (fun p -> Conn.exec p ()) l in + fun conn -> + let r = Syntax.list_iter (fun p -> exec conn p ()) l in match r with | Error err -> - Fmt.failwith "Database preflight failure: %a." Caqti_error.pp err + Fmt.failwith "Database preflight failure: %a." Result.pp_err err | Ok () -> () let find_signkey = let req = - Caqti_type.(eddsa_pub ->? signkey) + (eddsa_pub ->? signkey) "SELECT exchange_pub, valid_from, expire_sign, expire_legal, master_sig \ FROM exchange_sign_keys WHERE exchange_pub=$1" in - fun (module Conn : CONN) (exchange_pub : Eddsa.pub) -> - Conn.find_opt req exchange_pub + fun conn (exchange_pub : Eddsa.pub) -> find_opt conn req exchange_pub let get_signkeys = let req = - Caqti_type.(time ->* signkey) + (time ->* signkey) "SELECT esk.exchange_pub, esk.valid_from, esk.expire_sign, \ esk.expire_legal, esk.master_sig FROM exchange_sign_keys esk WHERE \ esk.expire_sign > $1 AND NOT EXISTS (SELECT esk_serial FROM \ signkey_revocations AS skr WHERE esk.esk_serial = skr.esk_serial)" in - fun (module Conn : CONN) ~now -> Conn.collect_list req now + fun conn ~now -> collect_list conn req now let insert_signkey = let req = - Caqti_type.(signkey ->. unit) + (signkey ->. unit) "INSERT INTO exchange_sign_keys (exchange_pub, valid_from, expire_sign, \ expire_legal, master_sig) VALUES ($1, $2, $3, $4, $5)" in - fun (module Conn : CONN) v -> Conn.exec req v + fun conn v -> exec conn req v let find_denom = let req = - Caqti_type.(denom_hash ->? denom) + (denom_hash ->? denom) "SELECT denom_pub, (coin).*, valid_from, expire_withdraw, \ expire_deposit, expire_legal, (fee_withdraw).*, (fee_deposit).*, \ (fee_refresh).*, (fee_refund).*, age_mask, denom_pub_hash, master_sig \ FROM denominations WHERE denom_pub_hash=$1" in - fun (module Conn : CONN) h_denom_pub -> Conn.find_opt req h_denom_pub + fun conn h_denom_pub -> find_opt conn req h_denom_pub let get_denominations = let req = - Caqti_type.(unit ->* denom) + (unit ->* denom) "SELECT dn.denom_pub, (dn.coin).*, dn.valid_from, dn.expire_withdraw, \ dn.expire_deposit, dn.expire_legal, (dn.fee_withdraw).*, \ (dn.fee_deposit).*, (dn.fee_refresh).*, (dn.fee_refund).*, dn.age_mask, \ @@ -79,71 +83,69 @@ let get_denominations = EXISTS (SELECT dn.denominations_serial FROM denomination_revocations AS \ dnr WHERE dn.denominations_serial = dnr.denominations_serial)" in - fun (module Conn : CONN) () -> Conn.collect_list req () + fun conn () -> collect_list conn req () (* note: does not update revocation *) let insert_denom = let req = - Caqti_type.(denom ->. unit) + (denom ->. unit) "INSERT INTO denominations (denom_pub, coin, valid_from, \ expire_withdraw, expire_deposit, expire_legal, fee_withdraw, \ fee_deposit, fee_refresh, fee_refund, age_mask, denom_pub_hash, \ master_sig) VALUES ($1, ($2, $3), $4, $5, $6, $7, ($8,$9), ($10,$11), \ ($12,$13), ($14,$15), $16, $17, $18)" in - fun (module Conn : CONN) v -> Conn.exec req v + fun conn v -> exec conn req v let insert_denomination_revocation = let req = let master_sig = Signatures.MasterDenominationKeyRevocation.caqti in - Caqti_type.(t2 denom_hash master_sig ->. unit) + (t2 denom_hash master_sig ->. unit) "INSERT INTO denomination_revocations (denominations_serial, master_sig) \ SELECT denominations_serial, $2 FROM denominations WHERE \ denom_pub_hash=$1" in - fun (module Conn : CONN) h_denom_pub master_sig -> - Conn.exec req (h_denom_pub, master_sig) + fun conn h_denom_pub master_sig -> exec conn req (h_denom_pub, master_sig) let insert_signkey_revocation = let req = let master_sig = Signatures.MasterSigningKeyRevocation.caqti in - Caqti_type.(t2 eddsa_pub master_sig ->. unit) + (t2 eddsa_pub master_sig ->. unit) "INSERT INTO signkey_revocations (esk_serial, master_sig) SELECT \ esk_serial, $2 FROM exchange_sign_keys WHERE exchange_pub=$1" in - fun (module Conn : CONN) exchange_pub master_sig -> - Conn.exec req (exchange_pub, master_sig) + fun conn exchange_pub master_sig -> exec conn req (exchange_pub, master_sig) let find_auditor = let req = - Caqti_type.(eddsa_pub ->? auditor) + (eddsa_pub ->? auditor) "SELECT auditor_pub, auditor_name, auditor_url, last_change, is_active \ FROM auditors WHERE auditor_pub=$1" in - fun (module Conn : CONN) auditor_pub -> Conn.find_opt req auditor_pub + fun conn auditor_pub -> find_opt conn req auditor_pub let update_auditor = let req = - Caqti_type.(auditor ->. unit) + (auditor ->. unit) "INSERT INTO auditors (auditor_pub, auditor_name, auditor_url, \ last_change, is_active) VALUES ($1, $2, $3, $4, $5) ON CONFLICT \ (auditor_pub) DO UPDATE SET auditor_name=$2, auditor_url=$3, \ last_change=$4, is_active=$5" in - fun (module Conn : CONN) auditor -> Conn.exec req auditor + fun conn auditor -> exec conn req auditor let insert_auditor_denom_sig = let req = let auditor_sig = Signatures.ExchangeKeyValidity.caqti in - Caqti_type.(t3 eddsa_pub denom_hash auditor_sig ->. unit) + (t3 eddsa_pub denom_hash auditor_sig ->. unit) "WITH ax AS (SELECT auditor_uuid FROM auditors WHERE auditor_pub=$1) \ INSERT INTO auditor_denom_sigs (auditor_uuid, denominations_serial, \ auditor_sig) SELECT ax.auditor_uuid, denominations_serial, $3 FROM \ denominations CROSS JOIN ax WHERE denom_pub_hash=$2 ON CONFLICT DO \ NOTHING" in - fun (module Conn : CONN) ~auditor_pub ~h_denom_pub ~auditor_sig -> - Conn.exec req (auditor_pub, h_denom_pub, auditor_sig) + fun conn ~auditor_pub ~h_denom_pub ~auditor_sig -> + exec conn req (auditor_pub, h_denom_pub, auditor_sig) (* todo auditors map to Auditor.t record @@ -153,15 +155,15 @@ let insert_auditor_denom_sig = let get_auditor_keys = let req = let auditor_sig = Signatures.ExchangeKeyValidity.caqti in - Caqti_type.(unit ->* t5 eddsa_pub string string denom_hash auditor_sig) + (unit ->* t5 eddsa_pub string string denom_hash auditor_sig) "SELECT a.auditor_pub, a.auditor_url, a.auditor_name, dn.denom_pub_hash, \ ads.auditor_sig FROM auditor_denom_sigs AS ads JOIN auditors AS a USING \ (auditor_uuid) JOIN denominations AS dn USING (denominations_serial) \ WHERE a.is_active" in - fun (module Conn : CONN) -> + fun conn -> let open Syntax in - let* l = Conn.collect_list req () |> unwrap_caqti in + let* l = collect_list conn req () in let ht = Hashtbl.create 0xff in List.iter (fun (pub, url, name, denom_pub_h, auditor_sig) -> @@ -189,11 +191,11 @@ let get_auditor_keys = let insert_wire_fee = let req = let master_sig = Signatures.MasterWireFee.caqti in - Caqti_type.(t6 wire_method time time amount amount master_sig ->. unit) + (t6 wire_method time time amount amount master_sig ->. unit) "INSERT INTO wire_fee (wire_method, start_date, end_date, wire_fee, \ closing_fee, master_sig) VALUES ($1, $2, $3, ($4,$5), ($6,$7), $8)" in - fun (module Conn : CONN) + fun conn WireFeeSetupMessage. { wire_method; @@ -204,68 +206,67 @@ let insert_wire_fee = wire_fee; } -> - Conn.exec req + exec conn req (wire_method, fee_start, fee_end, wire_fee, closing_fee, master_sig_wire) let get_wire_fees_by_time = let req = - Caqti_type.(t3 wire_method time time ->* aggregate_transfer_fee) + (t3 wire_method time time ->* aggregate_transfer_fee) "SELECT (wire_fee).*, (closing_fee).*, start_date, end_date, master_sig \ FROM wire_fee WHERE wire_method=$1 AND end_date > $2 AND start_date < \ $3" in - fun (module Conn : CONN) ~wire_method ~start_date ~end_date -> - Conn.collect_list req (wire_method, start_date, end_date) + fun conn ~wire_method ~start_date ~end_date -> + collect_list conn req (wire_method, start_date, end_date) let get_wire_fees = let req = - Caqti_type.(string ->* aggregate_transfer_fee) + (string ->* aggregate_transfer_fee) "SELECT (wire_fee).*, (closing_fee).*, start_date, end_date, master_sig \ FROM wire_fee WHERE wire_method=$1" in - fun (module Conn : CONN) ~wire_method -> Conn.collect_list req wire_method + fun conn ~wire_method -> collect_list conn req wire_method let get_global_fees = let req = - Caqti_type.(time ->* global_fee) + (time ->* global_fee) "SELECT start_date, end_date, (history_fee).*, (account_fee).*, \ (purse_fee).*, history_expiration, purse_account_limit, purse_timeout, \ master_sig FROM global_fee WHERE start_date >= $1" in - fun (module Conn : CONN) ~start_date -> Conn.collect_list req start_date + fun conn ~start_date -> collect_list conn req start_date let get_global_fees_by_time = let req = - Caqti_type.(t2 time time ->* global_fee) + (t2 time time ->* global_fee) "SELECT start_date, end_date, (history_fee).*, (account_fee).*, \ (purse_fee).*, history_expiration, purse_account_limit, purse_timeout, \ master_sig FROM global_fee WHERE start_date >= $1 AND end_date <= $2" in - fun (module Conn : CONN) ~start_date ~end_date -> - Conn.collect_list req (start_date, end_date) + fun conn ~start_date ~end_date -> collect_list conn req (start_date, end_date) let insert_global_fees = let req = - Caqti_type.(global_fee ->. unit) + (global_fee ->. unit) "INSERT INTO global_fee (start_date, end_date, history_fee, account_fee, \ purse_fee, history_expiration, purse_account_limit, purse_timeout, \ master_sig) VALUES ($1, $2, ($3,$4), ($5,$6), ($7,$8), $9, $10, $11, \ $12)" in - fun (module Conn : CONN) v -> Conn.exec req v + fun conn v -> exec conn req v let find_wire = let req = - Caqti_type.(payto_uri ->? t3 exchange_wire_account bool time) + (payto_uri ->? t3 exchange_wire_account bool time) "SELECT payto_uri, conversion_url, debit_restrictions::TEXT, \ credit_restrictions::TEXT, master_sig, bank_label, priority, is_active, \ last_change FROM wire_accounts WHERE payto_uri=$1" in - fun (module Conn : CONN) ~payto_uri -> Conn.find_opt req payto_uri + fun conn ~payto_uri -> find_opt conn req payto_uri let update_wire = let req = - Caqti_type.(t3 exchange_wire_account bool time ->. unit) + (t3 exchange_wire_account bool time ->. unit) "INSERT INTO wire_accounts (payto_uri, conversion_url, \ credit_restrictions, debit_restrictions, master_sig, bank_label, \ priority, is_active, last_change) VALUES \ @@ -275,48 +276,47 @@ let update_wire = debit_restrictions=$4::TEXT::JSONB, master_sig=$5, bank_label=$6, \ priority=$7, is_active=$8, last_change=$9" in - fun (module Conn : CONN) ~is_active ~last_change v -> - Conn.exec req (v, is_active, last_change) + fun conn ~is_active ~last_change v -> exec conn req (v, is_active, last_change) let get_wire_accounts = let req = - Caqti_type.(unit ->* exchange_wire_account) + (unit ->* exchange_wire_account) "SELECT payto_uri, conversion_url, debit_restrictions::TEXT, \ credit_restrictions::TEXT, master_sig, bank_label, priority FROM \ wire_accounts WHERE is_active" in - fun (module Conn : CONN) () -> Conn.collect_list req () + fun conn () -> collect_list conn req () let find_drain_profit = let req = - Caqti_type.(Bytes32.caqti ->? drain_profit_message) + (Bytes32.caqti ->? drain_profit_message) "SELECT wtid, account_section, payto_uri, trigger_date, (amount).*, \ master_sig FROM profit_drains WHERE wtid=$1" in - fun (module Conn : CONN) wtid -> Conn.find_opt req wtid + fun conn wtid -> find_opt conn req wtid let insert_drain_profit = let req = - Caqti_type.(drain_profit_message ->. unit) + (drain_profit_message ->. unit) "INSERT INTO profit_drains (wtid, account_section, payto_uri, \ trigger_date, amount, master_sig) VALUES ($1::BYTEA, $2, $3, $4, \ ($5,$6), $7)" in - fun (module Conn : CONN) v -> Conn.exec req v + fun conn v -> exec conn req v let insert_aml_officer = let req = - Caqti_type.(aml_officer_setup ->! time) + (aml_officer_setup ->! time) "SELECT out_last_change FROM exchange_do_insert_aml_officer ($1, $2, $3, \ $4, $5, $6)" in - fun (module Conn : CONN) v -> Conn.find req v + fun conn v -> find conn req v let insert_partner = let req = - Caqti_type.(exchange_partner_setup ->. unit) + (exchange_partner_setup ->. unit) "INSERT INTO partners (partner_master_pub, start_date, end_date, \ wad_frequency, wad_fee, master_sig, partner_base_url) VALUES ($1, $2, \ $3, $4, ($5,$6), $7, $8) ON CONFLICT DO NOTHING" in - fun (module Conn : CONN) v -> Conn.exec req v + fun conn v -> exec conn req v diff --git a/src/pg_type.ml b/src/pg_type.ml index f092f010..0b801e23 100644 --- a/src/pg_type.ml +++ b/src/pg_type.ml @@ -1,24 +1,18 @@ (* this module defines caqti encoding/decodings *) open Caqti_type +open Time open Api -let amount : Amount.t t = - let open Amount in - custom - ~encode:(fun amount -> Ok (amount.value, amount.fraction)) - ~decode:(fun (value, fraction) -> - Amount.make ~sign:None ~currency:Config.currency ~value ~fraction) - (t2 int64 int32) - (* we want to use int64 timestamps, not postgresql built-in timestamp type *) let ptime : unit t = Caqti_type.unit -let time = Time.Timestamp.caqti -let time_span = Time.TimeRelative.caqti +let time = Timestamp.caqti +let time_span = TimeRelative.caqti let age_mask : int t = Caqti_type.int let rsa_pub = Rsa.pub_caqti let eddsa_pub = Eddsa.pub_caqti let eddsa_sig = Eddsa.sig_caqti +let amount : Amount.t t = Amount.caqti ~currency:Config.currency (* todo: enum type for wire_method? *) let wire_method = Caqti_type.string @@ -119,10 +113,10 @@ let denom = (t2 denom_hash master_sig)) let account_restrictions = - custom - ~encode:(fun l -> Api.encode (Jsont.list AccountRestriction.jsont) l) - ~decode:(fun s -> Api.decode (Jsont.list AccountRestriction.jsont) s) - string + let jsont = Jsont.list Api.AccountRestriction.jsont in + let encode = Api.encode' jsont in + let decode = Api.decode' jsont in + custom ~encode ~decode string let global_fee = let master_sig = Signatures.GlobalFees.caqti in @@ -355,7 +349,7 @@ module Auditor = struct auditor_pub: Eddsa.pub; auditor_url: string; auditor_name: string; - last_change: Time.Timestamp.t; + last_change: Timestamp.t; is_active: bool; } diff --git a/src/respond.ml b/src/respond.ml index 60fb46a3..c898874c 100644 --- a/src/respond.ml +++ b/src/respond.ml @@ -1,6 +1,7 @@ let encode_error_detail err = - match Api.(encode ErrorDetail.jsont err) with - | Error e -> Fmt.failwith "json encoding error on `ErrorDetail`: %s." e + match Api.encode Api.ErrorDetail.jsont err with + | Error e -> + Fmt.failwith "json encoding error on `ErrorDetail`: %a." Result.pp_err e | Ok s -> s let respond_json req content status = @@ -16,7 +17,8 @@ let mk_error_content ?hint _status = let err = ErrorDetail.make ?hint code in encode_error_detail err -let error ~hint req = +let error err req = + let hint = Fmt.str "%a" Result.pp_err err in Logs.err (fun m -> m "error: %s" hint); let body = mk_error_content ~hint `Internal_server_error in respond_json req body `Internal_server_error @@ -45,7 +47,7 @@ let not_modified () = respond `Not_modified let result res req = - match res with Error hint -> error ~hint req | Ok content -> ok content req + match res with Error e -> error e req | Ok content -> ok content req let result_no_content res req = - match res with Error hint -> error ~hint req | Ok () -> no_content () + match res with Error e -> error e req | Ok () -> no_content () diff --git a/src/result.ml b/src/result.ml new file mode 100644 index 00000000..5ccb32cc --- /dev/null +++ b/src/result.ml @@ -0,0 +1,39 @@ +include Stdlib.Result + +type err = + [ `Msg of string + | `Json_decode of string + | `Bin_decode of string + | `Invalid_signature_eddsa + | `Invalid_signature_rsa + | (* - *) + `Not_found + | `Conflict of string + | (* - server errors - *) + `Server_err of string + | `Caqti of string + | `Mfat of string + | `Json_encode of string + | `Bin_encode of string + ] + +type 'a t = ('a, err) Stdlib.Result.t + +let err_to_string : err -> string = function + | `Msg s -> s + | `Json_decode s -> Fmt.str "Json decode: %s" s + | `Json_encode s -> Fmt.str "Json encode: %s" s + | `Bin_decode s -> Fmt.str "Bin decode: %s" s + | `Bin_encode s -> Fmt.str "Bin encode: %s" s + | `Invalid_signature_eddsa -> Fmt.str "Invalid eddsa signature" + | `Invalid_signature_rsa -> Fmt.str "Invalid rsa signature" + (* - *) + | `Not_found -> Fmt.str "Not found" + | `Conflict s -> Fmt.str "Conflict: %s" s + (* - *) + | `Server_err s -> Fmt.str "Server error: %s" s + | `Caqti s -> Fmt.str "Caqti: %s" s + | `Mfat s -> Fmt.str "mFAT: %s" s + +let pp_err = Fmt.of_to_string err_to_string +let unwrap_err r = map_error err_to_string r diff --git a/src/rsa.ml b/src/rsa.ml index 3cbd369f..bc3555e8 100644 --- a/src/rsa.ml +++ b/src/rsa.ml @@ -2,21 +2,19 @@ open Syntax module Mirage_rsa = Mirage_crypto_pk.Rsa module Z_extra = Mirage_crypto_pk.Z_extra -module Binary_format_rsa = struct +module RSA_BIN = struct (* RSA public key binary format - https://www.gnupg.org/documentation/manuals/gcrypt/MPI-formats.html - := { uint16_be: n size; uint16_be: e size; n; e} - - integer in big-endian format (MSB first) - leading zeroes are stripped unless they are required to keep a value positive - no 0-termination *) + https://www.gnupg.org/documentation/manuals/gcrypt/MPI-formats.html + := { uint16_be: n size; uint16_be: e size; n; e} *) + (* [Z.t array] encoding, used to define Rsa.pub binary encoding + and also a custom Rsa.priv encoding *) let z_array_to_octets (arr : Z.t array) = let nb = Array.length arr in let bits_arr = Array.map Z_extra.to_octets_be arr in let len_arr = Array.map String.length bits_arr in let len = (2 * nb) + Array.fold_left ( + ) 0 len_arr in - let b = Bytes.make len '\x00' in + let b = Bytes.create len in let pos = ref 0 in Array.iter (fun len -> @@ -32,8 +30,9 @@ module Binary_format_rsa = struct Bytes.unsafe_to_string b let z_array_of_octets ~nb s = + let error = Error "invalid rsa data" in let s_len = String.length s in - if s_len <= 2 * nb then Error "rsa of_octets error" + if s_len <= 2 * nb then error else let pos = ref 0 in let len_arr = @@ -43,7 +42,7 @@ module Binary_format_rsa = struct len) in let len = (2 * nb) + Array.fold_left ( + ) 0 len_arr in - if s_len <> len then Error "rsa of_octets error" + if s_len <> len then error else let z_arr = Array.init nb (fun i -> @@ -60,12 +59,9 @@ module Binary_format_rsa = struct let pub_of_octets s = let* arr = z_array_of_octets ~nb:2 s in match arr with - | [| n; e |] -> - let+ pub = Mirage_rsa.pub ~n ~e |> unwrap_msg in - pub + | [| n; e |] -> Mirage_rsa.pub ~n ~e |> Result.map_error (fun (`Msg e) -> e) | _ -> assert false - (* custom private key binary format <> than gcrypt *) let priv_to_octets ({ e; d; n; p; q; dp; dq; q' } : Mirage_rsa.priv) = z_array_to_octets [| e; d; n; p; q; dp; dq; q' |] @@ -73,8 +69,8 @@ module Binary_format_rsa = struct let* arr = z_array_of_octets ~nb:8 s in match arr with | [| e; d; n; p; q; dp; dq; q' |] -> - let+ priv = Mirage_rsa.priv ~e ~d ~n ~p ~q ~dp ~dq ~q' |> unwrap_msg in - priv + Mirage_rsa.priv ~e ~d ~n ~p ~q ~dp ~dq ~q' + |> Result.map_error (fun (`Msg e) -> e) | _ -> assert false end @@ -88,55 +84,48 @@ let generate ~bits () = (priv, pub) let pub_of_priv = Mirage_rsa.pub_of_priv -let priv_of_octets = Binary_format_rsa.priv_of_octets -let priv_to_octets = Binary_format_rsa.priv_to_octets -let pub_to_octets = Binary_format_rsa.pub_to_octets -let pub_of_octets = Binary_format_rsa.pub_of_octets -(* we use Bin.cstring because size of key (~bits) can change depending on section_name - we also have to b32 encode/decode our octets because of null-char +module Priv = struct + (* NOTE: custom Rsa.priv encoding, will not match GNUnet one *) + let priv_of_octets = RSA_BIN.priv_of_octets + let priv_to_octets = RSA_BIN.priv_to_octets - enforce all to be of the same size instead? *) -let priv_bin = - let priv_of_octets_exn s = - let res = - let* s = B32.decode s in - priv_of_octets s - in - match res with - | Error e -> Fmt.failwith "RSA private key decoding failure: %s." e - | Ok t -> t - in - let priv_to_octets t = priv_to_octets t |> B32.encode in - Bin.map Bin.cstring priv_of_octets_exn priv_to_octets - -let pub_to_b32 t = B32.encode (pub_to_octets t) - -let pub_of_b32 s = - let* s = B32.decode s in - let+ v = pub_of_octets s in - v - -let pub_caqti = - Caqti_type.custom - ~encode:(fun v -> Ok (pub_to_octets v)) - ~decode:(fun v -> pub_of_octets v) - Caqti_type.octets - -let priv_jsont = let priv_of_b32 s = let* s = B32.decode s in priv_of_octets s - in - let priv_to_b32 t = B32.encode (priv_to_octets t) in - Jsont.of_of_string ~kind:"RsaPrivateKey" priv_of_b32 ~enc:priv_to_b32 -let pub_jsont = - Jsont.of_of_string ~kind:"RsaPublicKey" pub_of_b32 ~enc:pub_to_b32 + let priv_to_b32 t = B32.encode (priv_to_octets t) + + let priv_jsont = + Jsont.of_of_string ~kind:"RsaPrivateKey" priv_of_b32 ~enc:priv_to_b32 +end + +module Pub = struct + let pub_to_octets = RSA_BIN.pub_to_octets + let pub_of_octets = RSA_BIN.pub_of_octets + let pub_to_b32 t = B32.encode (pub_to_octets t) + + let pub_of_b32 s = + let* s = B32.decode s in + pub_of_octets s + + let pub_caqti = + Caqti_type.custom + ~encode:(fun v -> Ok (pub_to_octets v)) + ~decode:pub_of_octets Caqti_type.octets + + let pub_jsont = + Jsont.of_of_string ~kind:"RsaPublicKey" pub_of_b32 ~enc:pub_to_b32 +end + +include Priv +include Pub let sig_jsont = Jsont.of_of_string ~kind:"RsaSignature" B32.decode ~enc:B32.encode +(* ---- *) + (* WIP fdh-rsa full-domain-hash RSA based on libgnunetutil crypto_rsa.c *) @@ -212,11 +201,11 @@ let verify ~key (S s) ~msg = let msg_fdh = rsa_full_domain_hash key msg in let s1 = Z_extra.to_octets_be msg_fdh in let s2 = Mirage_rsa.encrypt ~key s in - match Eqaf.equal s1 s2 with - | false -> Fmt.error "RSA signature verification failed" - | true -> Ok () + if Eqaf.equal s1 s2 then Ok () else Error `Invalid_signature_rsa (* decrypt <=> sign *) let sign ~key bmsg : sig_ = let sig_ = Mirage_rsa.decrypt ~crt_hardening:true ~key bmsg in S sig_ + +let pp_pub ppf pub = Fmt.pf ppf "%s" (pub_to_b32 pub) diff --git a/src/secmod_eddsa.ml b/src/secmod_eddsa.ml index a19bf55f..60c3124b 100644 --- a/src/secmod_eddsa.ml +++ b/src/secmod_eddsa.ml @@ -1,11 +1,7 @@ (* TODO ! use lock - schedule tasks - sign: check timestamps before signing *) + schedule tasks *) (* IMPROVE - Bin encode/decode - - catch failure - - should use little-endian list_issue_date: save timestamp of key generation key validity period: more checks + do not exceed lookahead @@ -53,15 +49,15 @@ let key_bin = (* for sm_key only *) let read_eddsa fs spath = Log.debug (fun m -> m "reading key file `%s`" spath); - let* data = Fat.read fs spath |> unwrap_msg in - let* priv = Eddsa.priv_of_octets data in + let* data = Fat.read fs spath in + let* priv = Eddsa.priv_of_octets data |> Result.map_error (fun e -> `Msg e) in let pub = Eddsa.pub_of_priv priv in Ok (priv, pub) let write_eddsa fs spath priv = Log.debug (fun m -> m "writing key file `%s`" spath); let data = Eddsa.priv_to_octets priv in - Fat.write fs spath data |> unwrap_msg + Fat.write fs spath data let key_spath k = let sfn = String.sub (Eddsa.pub_to_b32 k.pub) 0 8 in @@ -69,26 +65,25 @@ let key_spath k = let read_key fs spath = Log.debug (fun m -> m "reading key file `%s`" spath); - let* data = Fat.read fs spath |> unwrap_msg in - (* todo: catch failure *) - let k = Bin.decode key_bin data (ref 0) in - Ok k + let* s = Fat.read fs spath in + let+ k = Bbin.decode key_bin s in + k let write_key fs k = let spath = key_spath k in Log.debug (fun m -> m "writing key file `%s`" spath); - let data = Bin.to_string key_bin k in - Fat.write fs spath data |> unwrap_msg + let* s = Bbin.encode key_bin k in + Fat.write fs spath s let delete_file fs spath = Log.debug (fun m -> m "delete key file `%s`" spath); - let+ () = Fat.remove fs spath |> unwrap_msg in + let+ () = Fat.remove fs spath in () let gen_key t1 t2 = let priv, pub = Eddsa.generate () in let k = { priv; pub; t1; t2 } in - Log.debug (fun m -> m "generated key `%s`" (Eddsa.pub_to_b32 pub)); + Log.debug (fun m -> m "generated key `%a`" Eddsa.pp_pub pub); k let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l @@ -123,10 +118,9 @@ let gen_additional_keys_until_lookahead ~now l = let load fs = let* () = - if Fat.exists fs Cfg.key_dir then Ok () - else Fat.mkdir fs Cfg.key_dir |> unwrap_msg + if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir in - let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in + let* l = Fat.ls fs Cfg.key_dir in let l = List.map (fun entry -> Fat.Path.add Cfg.key_dir entry.Fat.name) l in let l = List.filter (fun spath -> not @@ String.equal spath Cfg.sm_key) l in let* keys = list_map (read_key fs) l in @@ -145,8 +139,7 @@ let init fs = | Some t -> Ok t | None -> let sm_priv, sm_pub = Eddsa.generate () in - Log.debug (fun m -> - m "generated secmod key: `%s`" (Eddsa.pub_to_b32 sm_pub)); + Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub); let ht = Hashtbl.create 0xff in let t = { fs; sm_priv; sm_pub; ht } in let* () = write_eddsa fs Cfg.sm_key t.sm_priv in @@ -162,11 +155,21 @@ let init fs = module Make (Fs : Fat.FS) = struct let t = match init Fs.t with - | Error e -> Fmt.failwith "secmod_eddsa initialization failure: %s." e + | Error e -> + Fmt.failwith "secmod_eddsa initialization failure: %a." Result.pp_err e | Ok t -> t - let find pub = - Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found" + let find_exn pub = + Log.debug (fun m -> m "find_exn: `%a`" Eddsa.pp_pub pub); + match Hashtbl.find_opt t.ht pub with + | Some v -> v + | None -> + (* XXX ERR + either: + - we tried to sign with a key that is not ours + - key was revoked bywhile we were holding on it + - broken keyring state *) + Fmt.failwith "secmod_eddsa operation on unknown key" let add t1 t2 = let k = gen_key t1 t2 in @@ -175,7 +178,7 @@ module Make (Fs : Fat.FS) = struct () let delete pub = - let* k = find pub in + let k = find_exn pub in Hashtbl.remove t.ht k.pub; delete_file t.fs (key_spath k) @@ -192,13 +195,12 @@ module Make (Fs : Fat.FS) = struct let sign_secmod s = Eddsa.sign ~key:t.sm_priv s let sign pub s = - let+ k = find pub in - let data = Eddsa.sign ~key:k.priv s in - data + let k = find_exn pub in + Eddsa.sign ~key:k.priv s (* delete and replace *) let revoke pub = - let* k = find pub in + let k = find_exn pub in let* () = delete pub in let* () = add k.t1 k.t2 in Ok () diff --git a/src/secmod_rsa.ml b/src/secmod_rsa.ml index de386492..491b0619 100644 --- a/src/secmod_rsa.ml +++ b/src/secmod_rsa.ml @@ -6,41 +6,17 @@ module Log = (val Logs.src_log src : Logs.LOG) open Syntax open Time module DenominationHash = Hash.DenominationHash - -module Coin_config = struct - type t = { - name: string; - duration_withdraw: TimeRelative.t; - rsa_keysize: int; - } - - let of_coin (coin : Config.Coin.t) = - { - name= coin.section_name; - duration_withdraw= coin.duration_withdraw; - rsa_keysize= coin.rsa_keysize; - } -end +module Coin = Config.Coin module Cfg = struct include Config.Exchange_secmod_rsa let key_dir = "/RSA" let sm_key = "/SM_RSA" - let coin_config_list = List.map Coin_config.of_coin Config.Coin.all_coins - - let get_coin_config ~section_name = - coin_config_list - |> List.find_opt (fun (cfg : Coin_config.t) -> - String.equal cfg.name section_name) - |> function - | None -> - Fmt.failwith "secmod_rsa failure: section `%s` not found" section_name - | Some cfg -> cfg end type key = { - section_name: string; + coin: Coin.t; priv: Rsa.priv; pub: Rsa.pub; h_pub: DenominationHash.t; @@ -55,16 +31,39 @@ type t = { ht: (DenominationHash.t, key) Hashtbl.t; } +let find_exn h_pub section_name = + Coin.all_coins + |> Iarray.find_opt (fun coin -> + String.equal section_name coin.Coin.section_name) + |> function + | Some coin -> coin + | None -> + Fmt.failwith + "Secmod_rsa denomination key loading failure on key `%a`: unknown \ + section_name [%s]" + DenominationHash.pp h_pub section_name + +(* ? enforce all to be of the same size instead *) +(* we use Bin.cstring + b32 binary encoding because + rsa keysize is not known and then we have to escape '\x00' *) +let rsa_private_key_bin = + let decode_exn o = + Rsa.priv_of_b32 o |> function Error e -> invalid_arg e | Ok v -> v + in + let encode o = Rsa.priv_to_b32 o in + Bin.map Bin.cstring decode_exn encode + let key_bin = let open Bin in record (fun t1 t2 section_name priv -> let pub = Rsa.pub_of_priv priv in - let h_pub = DenominationHash.hash_of_rsa pub in - { section_name; t1; t2; priv; pub; h_pub }) + let h_pub = DenominationHash.hash pub in + let coin = find_exn h_pub section_name in + { coin; t1; t2; priv; pub; h_pub }) |+ field TimeAbsolute.bin (fun t -> t.t1) |+ field TimeAbsolute.bin (fun t -> t.t2) - |+ field cstring (fun t -> t.section_name) - |+ field Rsa.priv_bin (fun t -> t.priv) + |+ field cstring (fun t -> t.coin.section_name) + |+ field rsa_private_key_bin (fun t -> t.priv) |> sealr let key_spath k = @@ -73,61 +72,63 @@ let key_spath k = let read_eddsa fs spath = Log.debug (fun m -> m "reading key file `%s`" spath); - let* data = Fat.read fs spath |> unwrap_msg in - let* priv = Eddsa.priv_of_octets data in + let* data = Fat.read fs spath in + let* priv = Eddsa.priv_of_octets data |> Result.map_error (fun e -> `Msg e) in let pub = Eddsa.pub_of_priv priv in Ok (priv, pub) let write_eddsa fs spath priv = Log.debug (fun m -> m "writing key file `%s`" spath); let data = Eddsa.priv_to_octets priv in - Fat.write fs spath data |> unwrap_msg + Fat.write fs spath data let read_key fs spath = Log.debug (fun m -> m "reading key file `%s`" spath); - let* data = Fat.read fs spath |> unwrap_msg in - let k = Bin.decode key_bin data (ref 0) in - Ok k + let* s = Fat.read fs spath in + let+ k = Bbin.decode key_bin s in + k let write_key fs k = let spath = key_spath k in Log.debug (fun m -> m "writing key file `%s`" spath); - let data = Bin.to_string key_bin k in - Fat.write fs spath data |> unwrap_msg + let* s = Bbin.encode key_bin k in + Fat.write fs spath s let delete_file fs spath = Log.debug (fun m -> m "delete key file `%s`" spath); - let+ () = Fat.remove fs spath |> unwrap_msg in + let+ () = Fat.remove fs spath in () (* -- *) -let gen_key cfg t1 t2 = - let priv, pub = Rsa.generate ~bits:cfg.Coin_config.rsa_keysize () in - let h_pub = DenominationHash.hash_of_rsa pub in - let k = { section_name= cfg.name; priv; pub; h_pub; t1; t2 } in +let gen_key coin t1 t2 = + let bits = coin.Coin.rsa_keysize in + let priv, pub = Rsa.generate ~bits () in + let h_pub = DenominationHash.hash pub in + let k = { coin; priv; pub; h_pub; t1; t2 } in Log.debug (fun m -> - m "generated key %s `%s`" cfg.Coin_config.name - (DenominationHash.to_b32 k.h_pub)); + m "generated key for coin [%s]: `%a`" coin.section_name + DenominationHash.pp k.h_pub); k let sort_keys l = List.sort (fun a b -> TimeAbsolute.compare a.t2 b.t2) l -let split_in_periodes (cfg : Coin_config.t) ~start ~end_ = +let split_in_periodes coin ~start ~end_ = assert (start < end_); + let duration_withdraw = coin.Coin.duration_withdraw in (* no overlap on first periode *) let t1 = start in - let t2 = TimeAbsolute.add start cfg.duration_withdraw in + let t2 = TimeAbsolute.add start duration_withdraw in let acc = [ (t1, t2) ] in let start = t2 in let rec go acc start end_ = let t1 = TimeAbsolute.sub start Cfg.overlap_duration in - let t2 = TimeAbsolute.add start cfg.duration_withdraw in + let t2 = TimeAbsolute.add start duration_withdraw in if t2 > end_ then acc else go ((t1, t2) :: acc) t2 end_ in go acc start end_ -let gen_additional_keys_until_lookahead cfg ~now l = +let gen_additional_keys_until_lookahead coin ~now l = let start = match List.rev (sort_keys l) with | [] -> now @@ -136,16 +137,15 @@ let gen_additional_keys_until_lookahead cfg ~now l = let end_ = TimeAbsolute.add now Cfg.lookahead_sign in if TimeAbsolute.compare start end_ >= 0 then [] else - let periodes = split_in_periodes cfg ~start ~end_ in - let new_keys = List.map (fun (t1, t2) -> gen_key cfg t1 t2) periodes in + let periodes = split_in_periodes coin ~start ~end_ in + let new_keys = List.map (fun (t1, t2) -> gen_key coin t1 t2) periodes in new_keys let load fs = let* () = - if Fat.exists fs Cfg.key_dir then Ok () - else Fat.mkdir fs Cfg.key_dir |> unwrap_msg + if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir in - let* l = Fat.ls fs Cfg.key_dir |> unwrap_msg in + let* l = Fat.ls fs Cfg.key_dir in let l = List.map (fun entry -> Fat.Path.add Cfg.key_dir entry.Fat.name) l in let l = List.filter (fun spath -> not @@ String.equal Cfg.sm_key spath) l in let* keys = list_map (read_key fs) l in @@ -165,18 +165,22 @@ let init fs = | Some t -> Ok t | None -> let sm_priv, sm_pub = Eddsa.generate () in - Log.debug (fun m -> - m "generated secmod key: `%s`" (Eddsa.pub_to_b32 sm_pub)); + Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub); let* () = write_eddsa fs Cfg.sm_key sm_priv in let ht = Hashtbl.create 0xff in Ok { fs; sm_priv; sm_pub; ht } in let all_keys = List.of_seq @@ Hashtbl.to_seq_values t.ht in let new_keys_l = - Cfg.coin_config_list - |> List.map (fun (cfg : Coin_config.t) -> - let keys = List.filter (fun k -> k.section_name = cfg.name) all_keys in - gen_additional_keys_until_lookahead cfg ~now keys) + Coin.all_coins + |> Iarray.to_list + |> List.map (fun coin -> + let keys = + List.filter + (fun k -> String.equal coin.Coin.section_name k.coin.section_name) + all_keys + in + gen_additional_keys_until_lookahead coin ~now keys) in let new_keys = List.concat new_keys_l in List.iter (fun k -> Hashtbl.replace t.ht k.h_pub k) new_keys; @@ -186,14 +190,18 @@ let init fs = module Make (Fs : Fat.FS) = struct let t = match init Fs.t with - | Error e -> Fmt.failwith "secmod_rsa initialization failure: %s." e + | Error e -> + Fmt.failwith "secmod_rsa initialization failure: %a." Result.pp_err e | Ok t -> t - let find h_pub = - Hashtbl.find_opt t.ht h_pub |> Option.to_result ~none:"key not found" + let find_exn h_pub = + Log.debug (fun m -> m "find_exn: `%a`" DenominationHash.pp h_pub); + match Hashtbl.find_opt t.ht h_pub with + | Some v -> v + | None -> Fmt.failwith "secmod_rsa operation on unknown key" let delete h_pub = - let* k = find h_pub in + let k = find_exn h_pub in Hashtbl.remove t.ht h_pub; delete_file t.fs (key_spath k) @@ -204,8 +212,8 @@ module Make (Fs : Fat.FS) = struct |> List.map (fun (h_pub, _k) -> h_pub) |> list_iter delete - let add cfg t1 t2 = - let k = gen_key cfg t1 t2 in + let add coin t1 t2 = + let k = gen_key coin t1 t2 in let+ () = write_key t.fs k in Hashtbl.replace t.ht k.h_pub k; () @@ -214,23 +222,17 @@ module Make (Fs : Fat.FS) = struct let sign_secmod s = Eddsa.sign ~key:t.sm_priv s let sign h_pub msg = - let+ k = find h_pub in - let data = Rsa.sign ~key:k.priv msg in - data + let k = find_exn h_pub in + Rsa.sign ~key:k.priv msg let revoke h_pub = - Log.debug (fun m -> - m "revoke `%s`" (DenominationHash.to_octets h_pub |> B32.encode)); - let* k = find h_pub in + Log.debug (fun m -> m "revoke `%a`" DenominationHash.pp h_pub); + let k = find_exn h_pub in let* () = delete h_pub in - let cfg = Cfg.get_coin_config ~section_name:k.section_name in - let* () = add cfg k.t1 k.t2 in + let* () = add k.coin k.t1 k.t2 in Ok () - let conv = - fun { section_name; priv= _; pub; h_pub; t1; t2= _ } -> - (h_pub, (section_name, pub, t1)) - + let conv k = (k.h_pub, (k.coin, k.pub, k.t1)) let keys () = Hashtbl.to_seq_values t.ht |> List.of_seq |> List.map conv let find_key pub = Hashtbl.find_opt t.ht pub |> Option.map conv end diff --git a/src/signatures.ml b/src/signatures.ml index 8f3b5b7e..1bd22af7 100644 --- a/src/signatures.ml +++ b/src/signatures.ml @@ -51,8 +51,10 @@ let size_of_int32 = 4 module type BYTES = sig type t - val of_octets : string -> (t, string) result val to_octets : t -> string + val of_octets : string -> (t, string) result + val jsont : t Jsont.t + val caqti : t Caqti_type.t val bin : t Bin.t end @@ -61,13 +63,28 @@ module Bytes32 : BYTES = struct type t = string + let to_octets = Fun.id + let of_octets s = match String.length s = n with - | false -> Error "invalid bytes length" + | false -> Error "invalid bytes32 length" | true -> Ok s - let to_octets = Fun.id - let bin = Bin.bytes n + let jsont = + let decode s = Result.bind (B32.decode s) of_octets in + let encode b = to_octets b |> B32.encode in + Jsont.of_of_string ~kind:"Bytes32" decode ~enc:encode + + let caqti = + Caqti_type.custom + ~encode:(fun v -> Ok (to_octets v)) + ~decode:of_octets Caqti_type.octets + + let bin = + let of_octets_exn s = + of_octets s |> function Error e -> invalid_arg e | Ok t -> t + in + Bin.map (Bin.bytes n) of_octets_exn to_octets end module Bytes64 : BYTES = struct @@ -75,13 +92,28 @@ module Bytes64 : BYTES = struct type t = string + let to_octets = Fun.id + let of_octets s = match String.length s = n with - | false -> Error "invalid bytes length" + | false -> Error "invalid bytes64 length" | true -> Ok s - let to_octets = Fun.id - let bin = Bin.bytes n + let jsont = + let decode s = Result.bind (B32.decode s) of_octets in + let encode b = to_octets b |> B32.encode in + Jsont.of_of_string ~kind:"Bytes64" decode ~enc:encode + + let caqti = + Caqti_type.custom + ~encode:(fun v -> Ok (to_octets v)) + ~decode:of_octets Caqti_type.octets + + let bin = + let of_octets_exn s = + of_octets s |> function Error e -> invalid_arg e | Ok t -> t + in + Bin.map (Bin.bytes n) of_octets_exn to_octets end module TransferSecretP = Bytes64 @@ -116,7 +148,6 @@ end (* --- *) -(* EccSignaturePurpose *) module Purpose = struct type t = { size: int32; @@ -140,7 +171,8 @@ module Purpose = struct let open Bin in match Size.of_value (Size.size_of (f dummy)) with | Dynamic _ | Unknown -> - Fmt.failwith "size_of failure: size is not Static" + Fmt.failwith + "Signature Bin.t declaration, size_of failure: size is not Static" | Static n -> n in fun code f -> make ~size:(get_size f) code |> f @@ -163,7 +195,7 @@ end) : sig (* todo - type for unknown/verified signatures? (nk/ok) *) - val verify : Eddsa.pub -> t -> r -> (unit, string) result + val verify : Eddsa.pub -> t -> r -> unit Result.t val signf : (string -> Eddsa.sig_) -> r -> t val jsont : t Jsont.t val caqti : t Caqti_type.t @@ -175,6 +207,7 @@ end = struct type r = R.r type t = Eddsa.sig_ + (* TODO exn *) let to_string = Bin.to_string R.bin let verify key t r = Eddsa.verify ~key t ~msg:(to_string r) let signf f r = f (to_string r) @@ -191,7 +224,7 @@ module DenominationKeyAnnouncement = struct (* purpose = TALER_SIGNATURE_SM_RSA_DENOMINATION_KEY *) type r = { h_denom_pub: DenominationHash.t; - h_section_name: Hash.H64_cstring.t; + h_section_name: H64_cstring.t; anchor_time: Timestamp.t; duration_withdraw: TimeRelative.t; } @@ -206,7 +239,7 @@ module DenominationKeyAnnouncement = struct { h_denom_pub; h_section_name; anchor_time; duration_withdraw }) |+ Purpose.field purpose |+ field DenominationHash.bin (fun t -> t.h_denom_pub) - |+ field Hash.H64_cstring.bin (fun t -> t.h_section_name) + |+ field H64_cstring.bin (fun t -> t.h_section_name) |+ field Timestamp.bin (fun t -> t.anchor_time) |+ field TimeRelative.bin (fun t -> t.duration_withdraw) |> sealr @@ -376,7 +409,7 @@ module MasterAddAuditor = struct type r = { start_date: Timestamp.t; auditor_pub: AuditorPublicKeyP.t; - h_auditor_url: Hash.H64_cstring.t; + h_auditor_url: H64_cstring.t; } let bin = @@ -387,7 +420,7 @@ module MasterAddAuditor = struct |+ Purpose.field purpose |+ field Timestamp.bin (fun t -> t.start_date) |+ field AuditorPublicKeyP.bin (fun t -> t.auditor_pub) - |+ field Hash.H64_cstring.bin (fun t -> t.h_auditor_url) + |+ field H64_cstring.bin (fun t -> t.h_auditor_url) |> sealr end @@ -475,9 +508,9 @@ module MasterWireDetails = struct (* purpose = TALER_SIGNATURE_MASTER_WIRE_DETAILS *) type r = { h_wire_details: FullPaytoHash.t; - h_conversion_url: Hash.H64_cstring.t; - h_credit_restrictions: Hash.H64_cstring.t; - h_debit_restrictions: Hash.H64_cstring.t; + h_conversion_url: H64_cstring.t; + h_credit_restrictions: H64_cstring.t; + h_debit_restrictions: H64_cstring.t; } let bin = @@ -499,9 +532,9 @@ module MasterWireDetails = struct }) |+ Purpose.field purpose |+ field FullPaytoHash.bin (fun t -> t.h_wire_details) - |+ field Hash.H64_cstring.bin (fun t -> t.h_conversion_url) - |+ field Hash.H64_cstring.bin (fun t -> t.h_credit_restrictions) - |+ field Hash.H64_cstring.bin (fun t -> t.h_debit_restrictions) + |+ field H64_cstring.bin (fun t -> t.h_conversion_url) + |+ field H64_cstring.bin (fun t -> t.h_credit_restrictions) + |+ field H64_cstring.bin (fun t -> t.h_debit_restrictions) |> sealr end @@ -514,9 +547,9 @@ module MasterAddWire = struct type r = { start_date: Timestamp.t; h_wire: FullPaytoHash.t; - h_conversion_url: Hash.H64_cstring.t; - h_credit_restrictions: Hash.H64_cstring.t; - h_debit_restrictions: Hash.H64_cstring.t; + h_conversion_url: H64_cstring.t; + h_credit_restrictions: H64_cstring.t; + h_debit_restrictions: H64_cstring.t; } let bin = @@ -541,9 +574,9 @@ module MasterAddWire = struct |+ Purpose.field _purpose |+ field Timestamp.bin (fun t -> t.start_date) |+ field FullPaytoHash.bin (fun t -> t.h_wire) - |+ field Hash.H64_cstring.bin (fun t -> t.h_conversion_url) - |+ field Hash.H64_cstring.bin (fun t -> t.h_credit_restrictions) - |+ field Hash.H64_cstring.bin (fun t -> t.h_debit_restrictions) + |+ field H64_cstring.bin (fun t -> t.h_conversion_url) + |+ field H64_cstring.bin (fun t -> t.h_credit_restrictions) + |+ field H64_cstring.bin (fun t -> t.h_debit_restrictions) |> sealr end @@ -578,7 +611,7 @@ module MasterDrainProfit = struct wtid: WireTransferIdentifierRawP.t; date: Timestamp.t; amount: Amount.t; - h_section: Hash.H64_cstring.t; + h_section: H64_cstring.t; h_payto: FullPaytoHash.t; } @@ -591,7 +624,7 @@ module MasterDrainProfit = struct |+ field WireTransferIdentifierRawP.bin (fun t -> t.wtid) |+ field Timestamp.bin (fun t -> t.date) |+ field Amount.bin (fun t -> t.amount) - |+ field Hash.H64_cstring.bin (fun t -> t.h_section) + |+ field H64_cstring.bin (fun t -> t.h_section) |+ field FullPaytoHash.bin (fun t -> t.h_payto) |> sealr end @@ -605,7 +638,7 @@ module MasterAmlOfficerStatus = struct type r = { change_date: Timestamp.t; officer_pub: AmlOfficerPublicKeyP.t; - h_officer_name: Hash.H64_cstring.t; + h_officer_name: H64_cstring.t; is_active: int32; } @@ -617,7 +650,7 @@ module MasterAmlOfficerStatus = struct |+ Purpose.field _purpose |+ field Timestamp.bin (fun t -> t.change_date) |+ field AmlOfficerPublicKeyP.bin (fun t -> t.officer_pub) - |+ field Hash.H64_cstring.bin (fun t -> t.h_officer_name) + |+ field H64_cstring.bin (fun t -> t.h_officer_name) |+ field beint32 (fun t -> t.is_active) |> sealr end @@ -634,7 +667,7 @@ module PartnerConfiguration = struct end_date: Timestamp.t; wad_frequency: TimeRelative.t; wad_fee: Amount.t; - h_url: Hash.H64_cstring.t; + h_url: H64_cstring.t; } let bin = @@ -657,7 +690,7 @@ module PartnerConfiguration = struct |+ field Timestamp.bin (fun t -> t.end_date) |+ field TimeRelative.bin (fun t -> t.wad_frequency) |+ field Amount.bin (fun t -> t.wad_fee) - |+ field Hash.H64_cstring.bin (fun t -> t.h_url) + |+ field H64_cstring.bin (fun t -> t.h_url) |> sealr end @@ -668,7 +701,7 @@ module WadPartnerSignature = struct module R = struct (* purpose = TALER_SIGNATURE_MASTER_PARTNER_DETAILS *) type r = { - h_partner_base_url: Hash.H64_cstring.t; + h_partner_base_url: H64_cstring.t; master_public_key: MasterPublicKeyP.t; start_date: Timestamp.t; end_date: Timestamp.t; @@ -699,7 +732,7 @@ module WadPartnerSignature = struct wad_frequency; }) |+ Purpose.field _purpose - |+ field Hash.H64_cstring.bin (fun t -> t.h_partner_base_url) + |+ field H64_cstring.bin (fun t -> t.h_partner_base_url) |+ field MasterPublicKeyP.bin (fun t -> t.master_public_key) |+ field Timestamp.bin (fun t -> t.start_date) |+ field Timestamp.bin (fun t -> t.end_date) @@ -715,7 +748,7 @@ module MasterWireFee = struct module R = struct (* purpose = TALER_SIGNATURE_MASTER_WIRE_FEES *) type r = { - h_wire_method: Hash.H64_cstring.t; + h_wire_method: H64_cstring.t; start_date: Timestamp.t; end_date: Timestamp.t; wire_fee: Amount.t; @@ -729,7 +762,7 @@ module MasterWireFee = struct (fun _purpose h_wire_method start_date end_date wire_fee closing_fee -> { h_wire_method; start_date; end_date; wire_fee; closing_fee }) |+ Purpose.field _purpose - |+ field Hash.H64_cstring.bin (fun t -> t.h_wire_method) + |+ field H64_cstring.bin (fun t -> t.h_wire_method) |+ field Timestamp.bin (fun t -> t.start_date) |+ field Timestamp.bin (fun t -> t.end_date) |+ field Amount.bin (fun t -> t.wire_fee) @@ -744,7 +777,7 @@ module ExchangeKeyValidity = struct module R = struct (* purpose = TALER_SIGNATURE_AUDITOR_EXCHANGE_KEYS *) type r = { - auditor_url_hash: Hash.H64_cstring.t; + auditor_url_hash: H64_cstring.t; master: MasterPublicKeyP.t; start: Timestamp.t; expire_withdraw: Timestamp.t; @@ -789,7 +822,7 @@ module ExchangeKeyValidity = struct denom_hash; }) |+ Purpose.field _purpose - |+ field Hash.H64_cstring.bin (fun t -> t.auditor_url_hash) + |+ field H64_cstring.bin (fun t -> t.auditor_url_hash) |+ field MasterPublicKeyP.bin (fun t -> t.master) |+ field Timestamp.bin (fun t -> t.start) |+ field Timestamp.bin (fun t -> t.expire_withdraw) @@ -898,7 +931,7 @@ module DepositRequest = struct amount_with_fee: Amount.t; deposit_fee: Amount.t; merchant: MerchantPublicKeyP.t; - wallet_data_hash: Hash.H64_cstring.t; + wallet_data_hash: H64_cstring.t; } end @@ -961,7 +994,7 @@ module WireDepositData = struct wire_fee: Amount.t; merchant_pub: MerchantPublicKeyP.t; h_wire: MerchantWireHash.t; - h_details: Hash.H64_cstring.t; + h_details: H64_cstring.t; } end @@ -1022,7 +1055,7 @@ end module MerchantRefundConfirmation = struct (* purpose = TALER_SIGNATURE_MERCHANT_REFUND_OK *) (* Hash of the order ID (a string), hashed without the 0-termination. *) - type t = { h_order_id: Hash.H64_cstring.t } + type t = { h_order_id: H64_cstring.t } end module RecoupRequest = struct @@ -1147,7 +1180,7 @@ module PurseDepositSignature = struct h_denom_pub: DenominationHash.t; h_age_commitment: AgeCommitmentHash.t; purse_pub: PursePublicKey.t; - h_exchange_base_url: Hash.H64_cstring.t; + h_exchange_base_url: H64_cstring.t; } end @@ -1214,7 +1247,7 @@ module WadDataSignature = struct type t = { wad_execution_time: Timestamp.t; total_amount: Amount.t; - h_items: Hash.H64_cstring.t; + h_items: H64_cstring.t; wad_id: WadId.t; } end @@ -1247,11 +1280,11 @@ end module AmlDecision = struct (* purpose = TALER_SIGNATURE_AML_DECISION *) type t = { - h_justification: Hash.H64_cstring.t; + h_justification: H64_cstring.t; decision_time: Timestamp.t; new_threshold: Amount.t; h_payto: NormalizedPaytoHash.t; - h_kyc_requirements: Hash.H64_cstring.t; + h_kyc_requirements: H64_cstring.t; new_state: int; } end @@ -1278,7 +1311,7 @@ module ReserveAttestRequest = struct (* purpose = TALER_SIGNATURE_WALLET_ATTEST_REQUEST *) type t = { request_timestamp: Timestamp.t; - h_details: Hash.H64_cstring.t; + h_details: H64_cstring.t; } end @@ -1288,6 +1321,6 @@ module ExchangeAttest = struct attest_timestamp: Timestamp.t; expiration_time: Timestamp.t; reserve_pub: ReservePublicKeyP.t; - h_attributes: Hash.H64_cstring.t; + h_attributes: H64_cstring.t; } end diff --git a/src/syntax.ml b/src/syntax.ml index 5b4937bc..00029c1d 100644 --- a/src/syntax.ml +++ b/src/syntax.ml @@ -1,15 +1,6 @@ let ( let* ) o f = match o with Ok v -> f v | Error _ as e -> e let ( let+ ) o f = match o with Ok v -> Ok (f v) | Error _ as e -> e -(* TODO better errors - use polymorphic variant for errors - use GANA error codes: - https://git.gnunet.org/gana.git/tree/gnu-taler-error-codes/registry.rec *) -let unwrap_msg o = match o with Error (`Msg e) -> Error e | Ok v -> Ok v - -let unwrap_caqti o = - match o with Error err -> Fmt.error "%a" Caqti_error.pp err | Ok v -> Ok v - let list_iter f l = let err = ref None in try diff --git a/src/time.mli b/src/time.mli index 2f232148..6f4f6f3d 100644 --- a/src/time.mli +++ b/src/time.mli @@ -14,8 +14,6 @@ module TimeRelative : sig val bin : t Bin.t val caqti : t Caqti_type.t val jsont : t Jsont.t - - (* TODO rename pp_dump *) val pp : Format.formatter -> t -> unit end @@ -33,8 +31,6 @@ module TimeAbsolute : sig val of_s : int64 -> t val of_ptime : Ptime.t -> t val bin : t Bin.t - - (* TODO rename pp_dump *) val pp : Format.formatter -> t -> unit end @@ -59,7 +55,5 @@ module Timestamp : sig val bin : t Bin.t val caqti : t Caqti_type.t val jsont : t Jsont.t - - (* TODO rename pp_dump *) val pp : Format.formatter -> t -> unit end diff --git a/test/management.sh b/test/management.sh index 046ed9f8..34d58228 100755 --- a/test/management.sh +++ b/test/management.sh @@ -112,9 +112,6 @@ mte-offline-tool drain \ mte-offline-tool upload --input $b --url $url"/management/drain" echo "[OK] /management/drain" -demo_keys="test/keys.demo.taler.net.v31_0_9.json" -mte-validate keys $demo_keys -echo "[OK] exchange.demo.taler.net/keys validation" mte-offline-tool download --output $a --url $url"/keys" mte-validate keys $a echo "[OK] /keys validation" diff --git a/test/test.ml b/test/test.ml index 697ba7cf..48ca4720 100644 --- a/test/test.ml +++ b/test/test.ml @@ -16,9 +16,9 @@ let test_eddsa () = let open Eddsa in let priv, pub = generate () in let priv' = priv |> priv_to_octets |> priv_of_octets |> get_ok in - assert (priv_to_octets priv = priv_to_octets priv'); + assert (priv = priv'); let pub' = pub |> pub_to_octets |> pub_of_octets |> get_ok in - assert (pub_to_octets pub = pub_to_octets pub'); + assert (pub = pub'); () let test_rsa () = @@ -53,9 +53,7 @@ let test_json () = let test_amount () = let open Amount in let v = - make ~sign:(Some Sign_plus) ~currency:"KUDOS" ~value:(Int64.of_int 25) - ~fraction:(Int32.of_int 678) - |> get_ok + make (Some Sign_plus) "KUDOS" (Int64.of_int 25) (Int32.of_int 678) |> get_ok in let v' = v |> to_string |> of_string |> get_ok in assert (v = v'); @@ -86,8 +84,7 @@ module Test_crypto = struct |> Eddsa.priv_of_octets |> get_ok |> Eddsa.pub_of_priv - |> Eddsa.pub_to_octets - |> encode + |> Eddsa.pub_to_b32 in assert (pub = pub') @@ -174,7 +171,7 @@ module Test_crypto = struct rsa_pub |> Rsa.pub_of_b32 |> get_ok - |> DenominationHash.hash_of_rsa + |> DenominationHash.hash |> DenominationHash.to_b32 in assert (h_pub' = h_pub) diff --git a/test/validate.ml b/test/validate.ml index 567d13ad..d1e0f145 100644 --- a/test/validate.ml +++ b/test/validate.ml @@ -1,7 +1,6 @@ -open Syntax -open Hash - let keys content = + let open Syntax in + let open Hash in let open Api in let open ExchangeKeysResponse in let* v = Api.decode jsont content in @@ -10,7 +9,7 @@ let keys content = Libtool_version.is_compatible ~implementation:Libtool_version.mte_protocol_version v.version then Ok () - else Fmt.error "version incompatible" + else Fmt.error_msg "incompatible version" in (* TODO json hash @@ -51,7 +50,7 @@ let keys content = let* () = let opt = List.find_opt (fun sk -> sk.Signkey.pub = v.exchange_pub) sk_l in match opt with - | None -> Fmt.error "exchange_pub is not in signkeys list" + | None -> Fmt.error_msg "exchange_pub is not in signkeys list" | Some _sk -> (* todo add a --now option if we want to validate timestamps let now = Timestamp.of_ptime (Ptime_clock.now ()) in @@ -95,7 +94,7 @@ let keys content = let open Denomination in denom_l |> List.find_opt (fun dn -> dn.h_pub = denom_pub_h) |> function - | None -> Fmt.error "auditor denomination key not found" + | None -> Fmt.error_msg "auditor denomination key not found" | Some dn -> let open Signatures.ExchangeKeyValidity in verify auditor_pub auditor_sig @@ -129,9 +128,10 @@ let keys_cmd = Cmd.make (Cmd.info "keys" ~doc) @@ let+ file = file in - let* content = - Result.bind (Fpath.of_string file) Bos.OS.File.read |> unwrap_msg - in + let open Syntax in + Result.unwrap_err + @@ + let* content = Bos.OS.File.read (Fpath.v file) in keys content let cli = diff --git a/tools/offline.ml b/tools/offline.ml index 63d5c85f..a71328e5 100644 --- a/tools/offline.ml +++ b/tools/offline.ml @@ -43,30 +43,29 @@ module Arg = struct in Arg.Conv.make ~docv:"relative time argument" ~parser ~pp () + let amount = + Arg.Conv.make ~docv:"amount argument" ~parser:Amount.of_string ~pp:Amount.pp + () + let b32 = let pp fmt v = Fmt.pf fmt "%s" (B32.encode v) in Arg.Conv.make ~docv:"Crockford's Base32 encoded argument" ~parser:B32.decode ~pp () - let amount = - Arg.Conv.make ~docv:"amount argument" ~parser:Amount.of_string ~pp:Amount.pp - () - let eddsa_pub = - let parser s = Eddsa.pub_of_b32 s in let pp fmt key = let s = Eddsa.pub_to_b32 key in Fmt.pf fmt "%s" s in - Arg.Conv.make ~docv:"eddsa public key argument" ~parser ~pp () + Arg.Conv.make ~docv:"eddsa public key argument" ~parser:Eddsa.pub_of_b32 ~pp + () let rsa_pub = - let parser s = Rsa.pub_of_b32 s in let pp fmt key = let s = Rsa.pub_to_b32 key in Fmt.pf fmt "%s" s in - Arg.Conv.make ~docv:"rsa public key argument" ~parser ~pp () + Arg.Conv.make ~docv:"rsa public key argument" ~parser:Rsa.pub_of_b32 ~pp () end let master_key = @@ -151,10 +150,8 @@ let compute_denomination_hash_cmd = Cmd.make (Cmd.info "compute-denomination-hash" ~doc) @@ let+ rsa_pub = rsa_pub in - rsa_pub - |> Hash.DenominationHash.hash_of_rsa - |> Hash.DenominationHash.to_b32 - |> Fmt.pr "%s@."; + let open Hash.DenominationHash in + Fmt.pr "%a@." pp (hash rsa_pub); Ok () let revoke_signkey_cmd = @@ -322,11 +319,11 @@ let drain_cmd = and+ master_key = master_key and+ debit_account_section = debit_account_section and+ credit_payto_uri = credit_payto_uri - and+ wtid = wtid + and+ wtid_octets = wtid and+ date = date and+ amount = amount in - drain ~output ~master_key ~debit_account_section ~credit_payto_uri ~wtid ~date - ~amount + drain ~output ~master_key ~debit_account_section ~credit_payto_uri + ~wtid_octets ~date ~amount let cli = let info = diff --git a/tools/offline_impl.ml b/tools/offline_impl.ml index c8d02e97..5773dac6 100644 --- a/tools/offline_impl.ml +++ b/tools/offline_impl.ml @@ -2,6 +2,8 @@ open Syntax open Time open Hash +let () = Mirage_crypto_rng_unix.use_default () + let now_s () = let ns = Mtime_clock.now_ns () in Int64.unsigned_div ns 1_000_000_000L @@ -37,7 +39,7 @@ module Future_keys = struct let rsa_pub = match denom_pub with DenominationKey.Rsa denom -> denom.rsa_pub in - let h_denom_pub = DenominationHash.hash_of_rsa rsa_pub in + let h_denom_pub = DenominationHash.hash rsa_pub in let h_section_name = H64_cstring.hash section_name in let anchor_time = stamp_start in let duration_withdraw = @@ -60,7 +62,7 @@ module Future_keys = struct let* () = match master_pub = offline_master_public_key with | false -> - Fmt.error + Fmt.error_msg "master public key of the future key response does not match ours" | true -> Ok () in @@ -104,7 +106,7 @@ module Future_keys = struct let rsa_pub = match denom_pub with DenominationKey.Rsa denom -> denom.rsa_pub in - let h_denom_pub = DenominationHash.hash_of_rsa rsa_pub in + let h_denom_pub = DenominationHash.hash rsa_pub in let master_sig = let open Signatures.DenominationKeyValidity in let master = Eddsa.pub_of_priv master_key in @@ -149,16 +151,20 @@ end (* -- *) -let read_file fname = Bos.OS.File.read (Fpath.v fname) |> unwrap_msg +let read_file fname = Bos.OS.File.read (Fpath.v fname) +let write_file fname content = Bos.OS.File.write (Fpath.v fname) content -let write_file fname content = - Bos.OS.File.write (Fpath.v fname) content |> unwrap_msg +let write_json_file fname jsont v = + let* content = Api.encode jsont v in + write_file fname content let read_master_key_file filename = let* master_key = read_file filename in - Eddsa.priv_of_octets master_key + Eddsa.priv_of_octets master_key |> Result.map_error (fun e -> `Bin_decode e) let download ~output ~url = + Result.unwrap_err + @@ let open Bos in OS.Cmd.run Cmd.( @@ -171,9 +177,10 @@ let download ~output ~url = % "-X" % "GET" % url) - |> unwrap_msg let upload ~input ~url = + Result.unwrap_err + @@ let open Bos in OS.Cmd.run Cmd.( @@ -189,31 +196,35 @@ let upload ~input ~url = % "--data" % ("@" ^ input) % url) - |> unwrap_msg let setup ~output ~output_pubkey = - Mirage_crypto_rng_unix.use_default (); + Result.unwrap_err + @@ let priv, pub = Mirage_crypto_ec.Ed25519.generate () in let priv_data = Mirage_crypto_ec.Ed25519.priv_to_octets priv in - let* () = write_file output priv_data in let pub_data = Mirage_crypto_ec.Ed25519.pub_to_octets pub |> B32.encode in + let* () = write_file output priv_data in let* () = write_file output_pubkey pub_data in Ok () let sign ~master_key ~input ~output = + Result.unwrap_err + @@ let* master_key = read_master_key_file master_key in let* input = read_file input in let master_pub = Eddsa.pub_of_priv master_key in let* future_keys_response = Api.decode Api.FutureKeysResponse.jsont input in let* () = Future_keys.verify master_pub future_keys_response in let master_signatures = Future_keys.make ~master_key future_keys_response in - let* s = Api.encode Api.MasterSignatures.jsont master_signatures in - let* () = write_file output s in - Ok () + write_json_file output Api.MasterSignatures.jsont master_signatures let revoke_denom ~output ~master_key ~h_denom = + Result.unwrap_err + @@ let* key = read_master_key_file master_key in - let* h_denom_pub = DenominationHash.of_b32 h_denom in + let* h_denom_pub = + DenominationHash.of_b32 h_denom |> Result.map_error (fun e -> `Msg e) + in let denom_revoke = let master_sig = let open Signatures.MasterDenominationKeyRevocation in @@ -221,11 +232,11 @@ let revoke_denom ~output ~master_key ~h_denom = in Api.DenomRevocationSignature.{ master_sig } in - let* s = Api.encode Api.DenomRevocationSignature.jsont denom_revoke in - let* () = write_file output s in - Ok () + write_json_file output Api.DenomRevocationSignature.jsont denom_revoke let revoke_signkey ~output ~master_key ~signkey = + Result.unwrap_err + @@ let* key = read_master_key_file master_key in let signkey_revoke = let master_sig = @@ -234,20 +245,20 @@ let revoke_signkey ~output ~master_key ~signkey = in Api.SignkeyRevocationSignature.{ master_sig } in - let* s = Api.encode Api.SignkeyRevocationSignature.jsont signkey_revoke in - let* () = write_file output s in - Ok () + write_json_file output Api.SignkeyRevocationSignature.jsont signkey_revoke let global_fees ~output ~master_key ~start_date ~end_date ~history_fee ~account_fee ~purse_fee ~history_expiration ~purse_account_limit ~purse_timeout = + Result.unwrap_err + @@ let* key = read_master_key_file master_key in let* purse_account_limit = match purse_account_limit >= 0 && purse_account_limit <= Int32.to_int Int32.max_int with - | false -> Error "invalid purse_account_limit value" + | false -> Fmt.error_msg "invalid purse_account_limit value" | true -> Ok (Int32.of_int purse_account_limit) in let master_sig = @@ -278,11 +289,11 @@ let global_fees ~output ~master_key ~start_date ~end_date ~history_fee master_sig; } in - let* s = Api.encode Api.GlobalFees.jsont global_fees in - let* () = write_file output s in - Ok () + write_json_file output Api.GlobalFees.jsont global_fees let enable_auditor ~output ~master_key ~auditor_url ~auditor_name ~auditor_pub = + Result.unwrap_err + @@ let* key = read_master_key_file master_key in let validity_start = Timestamp.of_s (now_s ()) in let master_sig = @@ -298,11 +309,11 @@ let enable_auditor ~output ~master_key ~auditor_url ~auditor_name ~auditor_pub = Api.AuditorSetupMessage. { auditor_url; auditor_name; auditor_pub; master_sig; validity_start } in - let* s = Api.encode Api.AuditorSetupMessage.jsont v in - let* () = write_file output s in - Ok () + write_json_file output Api.AuditorSetupMessage.jsont v let disable_auditor ~output ~master_key ~auditor_pub = + Result.unwrap_err + @@ let* key = read_master_key_file master_key in let validity_end = TimeAbsolute.of_s (now_s ()) in (* hack for tests: +1sec to be sure it overwrite previous timestamp *) @@ -314,12 +325,12 @@ let disable_auditor ~output ~master_key ~auditor_pub = signf (Eddsa.sign ~key) { end_date= validity_end; auditor_pub } in let v = Api.AuditorTeardownMessage.{ master_sig; validity_end } in - let* s = Api.encode Api.AuditorTeardownMessage.jsont v in - let* () = write_file output s in - Ok () + write_json_file output Api.AuditorTeardownMessage.jsont v let wire_fee ~output ~master_key ~wire_method ~fee_start ~fee_end ~closing_fee ~wire_fee = + Result.unwrap_err + @@ let* key = read_master_key_file master_key in let master_sig_wire = let open Signatures.MasterWireFee in @@ -343,11 +354,11 @@ let wire_fee ~output ~master_key ~wire_method ~fee_start ~fee_end ~closing_fee master_sig_wire; } in - let* s = Api.encode Api.WireFeeSetupMessage.jsont v in - let* () = write_file output s in - Ok () + write_json_file output Api.WireFeeSetupMessage.jsont v let enable_wire ~output ~master_key ~payto_uri ~bank_label ~priority = + Result.unwrap_err + @@ (* TODO wire *) let conversion_url = None in let credit_restrictions = [] in @@ -396,11 +407,11 @@ let enable_wire ~output ~master_key ~payto_uri ~bank_label ~priority = priority; } in - let* s = Api.encode Api.WireSetupMessage.jsont v in - let* () = write_file output s in - Ok () + write_json_file output Api.WireSetupMessage.jsont v let disable_wire ~output ~master_key ~payto_uri = + Result.unwrap_err + @@ let* key = read_master_key_file master_key in let validity_end = TimeAbsolute.of_s (now_s ()) in (* hack for tests: +1sec to be sure it overwrite previous timestamp *) @@ -413,14 +424,16 @@ let disable_wire ~output ~master_key ~payto_uri = signf (Eddsa.sign ~key) { end_date= validity_end; h_wire } in let v = Api.WireTeardownMessage.{ payto_uri; master_sig_del; validity_end } in - let* s = Api.encode Api.WireTeardownMessage.jsont v in - let* () = write_file output s in - Ok () + write_json_file output Api.WireTeardownMessage.jsont v -let drain ~output ~master_key ~debit_account_section ~credit_payto_uri ~wtid - ~date ~amount = +let drain ~output ~master_key ~debit_account_section ~credit_payto_uri + ~wtid_octets ~date ~amount = + Result.unwrap_err + @@ let* key = read_master_key_file master_key in - let* wtid = Api.Bytes32.of_octets wtid in + let* wtid = + Api.Bytes32.of_octets wtid_octets |> Result.map_error (fun e -> `Msg e) + in let master_sig = let open Signatures.MasterDrainProfit in signf (Eddsa.sign ~key) @@ -443,6 +456,4 @@ let drain ~output ~master_key ~debit_account_section ~credit_payto_uri ~wtid amount; } in - let* s = Api.encode Api.DrainProfitsMessage.jsont v in - let* () = write_file output s in - Ok () + write_json_file output Api.DrainProfitsMessage.jsont v