add result.ml; polymorphic variant errors + refacto

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

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
+    lift4 make sign letters
-      (fun sign currency value fraction ->
-        make ~sign ~currency ~value ~fraction)
-      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 =
+(* note: binary decoding never used, like for all signatures types *)
-  let len = String.length s in
+let decode_exn value fraction currency =
-  match len < currency_length_limit with
+  match make None currency value fraction with
-  | false -> Fmt.failwith "amount with invalid currency"
+  | Error e -> Fmt.failwith "amount decode %s." e
-  | true ->
+  | Ok t -> t
-      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
 
 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)

src/amount.mli

@@ -9,17 +9,10 @@ type t = private {
   fraction: Int32.t;
 }
 
-val make :
+val make : sign option -> string -> Int64.t -> Int32.t -> (t, string) result
-  sign:sign option ->
-  currency:string ->
-  value:Int64.t ->
-  fraction: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

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 encode' jsont v = Jsont_bytesrw.encode_string jsont v
-let decode jsont v = Jsont_bytesrw.decode_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;

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
+          failure "filename `%s` does not match configuration ETAG value `%s`"
-            "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 lang_l then failure "no language supported";
-    if List.is_empty ext_l then Fmt.failwith "no mimetype 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;
+      failure "default language `%s` files not found" Cfg.default_lang;
-    if not @@ List.mem ".txt" ext_l then
+    if not @@ List.mem ".txt" ext_l then failure "plain text file not found";
-      Fmt.failwith "plain text file not found";
+    if not @@ List.mem ".md" ext_l then failure "markdown file not found";
-    if not @@ List.mem ".md" ext_l then Fmt.failwith "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
+      failure "default content type `%a` not supported" pp Cfg.default_mimetype
-        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

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
+  Base32.decode ~alphabet ~off:0 ~len:(String.length s) s
-  | Error (`Msg e) -> Error e
+  |> Result.map_error (fun (`Msg e) -> e)
-  | Ok v -> Ok v

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)

src/config.ml

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

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 =
+let rsa_keysize s =
-  s
+  let nbits = int s in
-  |> B32.decode
+  let len = ((nbits - 1) / 8) + 1 in
-  |> unwrap
+  if 8 * len = nbits then nbits
-  |> Mirage_crypto_ec.Ed25519.pub_of_octets
+  else
-  |> Result.map_error (fun e -> Fmt.str "%a" Mirage_crypto_ec.pp_error e)
+    (* because of [kdf_mod_n] *)
-  |> unwrap
+    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

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
+  Iarray.iter
-    (fun coin ->
+    (fun (coin : Config.Coin.t) ->
-      let open Config.Coin in
-      assert (coin.cipher = `RSA);
       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
-    list_iter
+    (fun {
-      (fun {
+           pub;
-             pub;
+           value;
-             value;
+           stamp_start;
-             stamp_start;
+           stamp_expire_withdraw;
-             stamp_expire_withdraw;
+           stamp_expire_deposit;
-             stamp_expire_deposit;
+           stamp_expire_legal;
-             stamp_expire_legal;
+           fee_withdraw;
-             fee_withdraw;
+           fee_deposit;
-             fee_deposit;
+           fee_refresh;
-             fee_refresh;
+           fee_refund;
-             fee_refund;
+           age_mask= _;
-             age_mask= _;
+           h_pub= _;
-             h_pub= _;
+           master_sig;
-             master_sig;
+         } ->
-           } ->
+      let k = (value, fee_withdraw, fee_deposit, fee_refresh, fee_refund) in
-        let k = (value, fee_withdraw, fee_deposit, fee_refresh, fee_refund) in
+      let v =
-        let v =
+        Api.RsaDenom.
-          Api.RsaDenom.
+          {
-            {
+            rsa_pub= pub;
-              rsa_pub= pub;
+            master_sig;
-              master_sig;
+            stamp_start;
-              stamp_start;
+            stamp_expire_withdraw;
-              stamp_expire_withdraw;
+            stamp_expire_deposit;
-              stamp_expire_deposit;
+            stamp_expire_legal;
-              stamp_expire_legal;
+            lost= None;
-              lost= None;
+          }
-            }
+      in
-        in
+      match Hashtbl.find_opt ht k with
-        match Hashtbl.find_opt ht k with
+      | None ->
-        | None -> Error "denomination does not match any coin in configuration"
+          Fmt.failwith "denomination does not match any coin in configuration"
-        | Some l ->
+      | Some l ->
-            Hashtbl.replace ht k (v :: l);
+          Hashtbl.replace ht k (v :: l);
-            Ok ())
+          ())
-      denominations
+    denominations;
-  in
   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
-    |> List.map
+      (fun ((value, fee_withdraw, fee_deposit, fee_refresh, fee_refund), denoms)
-         (fun
-           ((value, fee_withdraw, fee_deposit, fee_refresh, fee_refund), denoms)
          ->
-           Rsa
+        Rsa
-             {
+          {
-               denoms= List.sort cmp_denom denoms;
+            denoms= List.sort cmp_denom denoms;
-               value;
+            value;
-               fee_withdraw;
+            fee_withdraw;
-               fee_deposit;
+            fee_deposit;
-               fee_refresh;
+            fee_refresh;
-               fee_refund;
+            fee_refund;
-             })
+          })
-    |> List.sort cmp_group
+      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;

src/dune

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

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 =
+  let priv_of_octets o =
-  match String.length s = 64 with
+    Mirage_eddsa.priv_of_octets o
-  | false -> Error "Eddsa decode signature (binary): invalid data"
+    |> Result.map_error (Fmt.str "%a" pp_mirage_error)
-  | true -> Ok (S s)
 
-let sig_bin =
+  let priv_to_b32 t = priv_to_octets t |> B32.encode
-  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_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 =
+  let sig_to_b32 (S s) = B32.encode s
-  Caqti_type.custom
+
-    ~encode:(fun v -> Ok (sig_to_octets v))
+  let sig_jsont =
-    ~decode:(fun s -> sig_of_octets s)
+    Jsont.of_of_string ~kind:"EddsaSignature" sig_of_b32 ~enc:sig_to_b32
-    Caqti_type.octets
+
+  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)

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
+  match create blk with
-  | Error (`Msg e) -> Fmt.failwith "FAT file system failure: %s." e
+  | 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

src/hash.ml

@@ -1,77 +1,55 @@
-(* TODO hash over canonicalized json
+open Syntax
-   https://docs.taler.net/design-documents/018-contract-json.html#canonicalized-hashing
-   https://datatracker.ietf.org/doc/html/rfc8785 *)
-open Digestif
 
 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
+module MK (H : Digestif.S) : S = struct
-  type t = SHA256.t
+  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
+    match H.of_raw_string_opt s with
-    | None -> Fmt.failwith "H32.of_octets failure"
+    | None -> Error "invalid hash"
-    | Some t -> t
+    | Some t -> Ok t
 
-  let to_octets = SHA256.to_raw_string
+  let to_octets = H.to_raw_string
-  let of_b32 s = Result.map of_octets (B32.decode s)
   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
+    let of_octets_exn s =
-    map (bytes 32) of_octets to_octets
+      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
+    custom ~encode:(fun v -> Ok (to_octets v)) ~decode:of_octets octets
-      ~encode:(fun v -> Ok (to_octets v))
-      ~decode:(fun v -> Ok (of_octets v))
-      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
+module H32 = MK (Digestif.SHA256)
-  type t = SHA512.t
+module H64 = MK (Digestif.SHA512)
-
-  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_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 hash : Rsa.pub -> 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
 end = struct
-  open Digestif
+  include H64
-
-  type t = SHA512.t
 
   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
+    hash (Bytes.unsafe_to_string 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
 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 *)

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_signkey : Eddsa.pub -> Signkey.t option Result.t
-  val find_denomination : DenominationHash.t -> Denomination.t option result
+  val find_denomination : DenominationHash.t -> Denomination.t option Result.t
-  val signkeys : unit -> Signkey.t list result
+  val signkeys : unit -> Signkey.t list Result.t
-  val denominations : unit -> Denomination.t list result
+  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 make_future_keys_response : unit -> Api.FutureKeysResponse.t Result.t
-  val verify_future_signkey : Api.SignKeySignature.t -> unit result
+  val verify_future_signkey : Api.SignKeySignature.t -> unit Result.t
-  val verify_future_denomination : Api.DenomSignature.t -> unit result
+  val verify_future_denomination : Api.DenomSignature.t -> unit Result.t
-  val certify_future_signkey : Api.SignKeySignature.t -> unit result
+  val certify_future_signkey : Api.SignKeySignature.t -> unit Result.t
-  val certify_future_denomination : Api.DenomSignature.t -> unit result
+  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)
-
+  let sign = Sm_eddsa.sign
-  (* TODO better error
+  let sign_denom = Sm_rsa.sign
-     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 find_signkey pub = Pg.find_signkey conn pub |> unwrap_caqti
+  let find_signkey pub = Pg.find_signkey conn pub
-  let find_denomination h_pub = Pg.find_denom conn h_pub |> unwrap_caqti
+  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 =
+  let make_future_dn (h_pub, (coin, pub, start)) =
-    Config.Coin.all_coins
+    let {
-    |> List.find_opt (fun coin -> coin.Config.Coin.section_name = section_name)
+      Config.Coin.section_name;
-    |> function
+      value;
-    | None ->
+      duration_withdraw;
-        Fmt.failwith "coin section `%s` not found in configuration" section_name
+      duration_spend;
-    | Some v -> v
+      duration_legal;
-
+      fee_withdraw;
-  let make_future_dn (h_pub, (section_name, pub, start)) =
+      fee_deposit;
-    Logs.debug (fun m ->
+      fee_refresh;
-        m "make_future_dn: `%s`" (DenominationHash.to_b32 h_pub));
+      fee_refund;
-    let open Time in
+      _;
-    let Config.Coin.
+    } =
-          {
+      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
     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"
+    | None -> Fmt.error_msg "future denomination not found"
-    | Some (h_pub, (section_name, pub, t1)) ->
+    | Some v ->
-        let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in
+        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"
+    | None -> Error `Not_found
-    | Some (pub, (t1, t2)) -> (
+    | Some (pub, (t1, t2)) ->
-        let* opt = find_signkey pub in
+        (* rebuild it *)
-        match opt with
+        let future_sk = make_future_sk (pub, (t1, t2)) in
-        | Some _sk ->
+        let sk = sk_of_future_sk future_sk master_sig in
-            Logs.info (fun m -> m "signkey already certified");
+        let+ () = Pg.insert_signkey conn sk in
-            Ok ()
+        Logs.info (fun m -> m "certified signkey `%a`" Eddsa.pp_pub sk.pub);
-        | 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));
-            ())
 
   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"
+    | None -> Error `Not_found
-    | Some (h_pub, (section_name, pub, t1)) -> (
+    | Some (h_pub, (section_name, pub, t1)) ->
-        let* opt = find_denomination h_pub in
+        let future_dn = make_future_dn (h_pub, (section_name, pub, t1)) in
-        match opt with
+        let dn = dn_of_future_dn future_dn h_pub master_sig in
-        | Some _dn ->
+        let+ () = Pg.insert_denom conn dn in
-            Logs.info (fun m -> m "denomination already certified");
+        Logs.info (fun m ->
-            Ok ()
+            m "certified denomination `%a`" DenominationHash.pp dn.h_pub);
-        | 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));
-            ())
 
   let revoke_signkey pub revoked_sig =
     let* opt = find_signkey pub in
-    let* _sk = Option.to_result ~none:"signkey not found" opt in
+    match opt with
-    let* () = Sm_eddsa.revoke pub in
+    | None -> Fmt.error_msg "signkey not found"
-    let+ () =
+    | Some _sk ->
-      Pg.insert_signkey_revocation conn pub revoked_sig |> unwrap_caqti
+        let* () = Sm_eddsa.revoke pub in
-    in
+        let+ () = Pg.insert_signkey_revocation conn pub revoked_sig in
-    Logs.info (fun m -> m "revoked signkey `%s`" (Eddsa.pub_to_b32 pub));
+        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
+    match opt with
-    let* () = Sm_rsa.revoke dn.h_pub in
+    | None -> Fmt.error_msg "denomination not found"
-    let+ () =
+    | Some dn ->
-      Pg.insert_denomination_revocation conn dn.h_pub revoked_sig
+        let* () = Sm_rsa.revoke dn.h_pub in
-      |> unwrap_caqti
+        let+ () = Pg.insert_denomination_revocation conn dn.h_pub revoked_sig in
-    in
+        Logs.info (fun m ->
-    Logs.info (fun m ->
+            m "revoked denomination `%a`" DenominationHash.pp h_pub);
-        m "revoked denomination `%s`" (DenominationHash.to_b32 h_pub));
+        ()
-    ()
 end

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

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

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;

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.[]

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 =
+  let* global_fees = Pg.get_global_fees db_conn ~start_date:Timestamp.zero in
-    Pg.get_global_fees db_conn ~start_date:Timestamp.zero |> unwrap_caqti
-  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

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* h_denom_pub =
-      let* v = Vifu.Request.of_json req |> unwrap_msg in
+        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* exchange_pub =
-      let* v = Vifu.Request.of_json req |> unwrap_msg in
+        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* auditor_pub =
-      let* v = Vifu.Request.of_json req |> unwrap_msg in
+        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_credit_restrictions = H64_cstring.hash "" in
-    let h_debit_restrictions = Hash.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 =
+    let* opt = Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid in
-      Pg.find_drain_profit db_conn v.DrainProfitsMessage.wtid |> unwrap_caqti
-    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 ()

src/pg.ml

@@ -4,18 +4,23 @@
 
 module type CONN = Caqti_miou.CONNECTION
 
-module Caqti_type = struct
+let map_err r =
-  include Caqti_type
+  Result.map_error (Fmt.kstr (fun e -> `Caqti e) "%a" Caqti_error.pp) r
-  include Pg_type
-  include Caqti_request.Infix
-end
 
+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
+    List.map (unit ->. unit)
-      Caqti_type.(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) ->
+  fun conn ->
-    let r = Syntax.list_iter (fun p -> Conn.exec p ()) l in
+    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) ->
+  fun conn (exchange_pub : Eddsa.pub) -> find_opt conn req exchange_pub
-    Conn.find_opt 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 ->
+  fun conn h_denom_pub master_sig -> exec conn req (h_denom_pub, master_sig)
-    Conn.exec 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 ->
+  fun conn exchange_pub master_sig -> exec conn req (exchange_pub, master_sig)
-    Conn.exec 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 ->
+  fun conn ~auditor_pub ~h_denom_pub ~auditor_sig ->
-    Conn.exec req (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 ->
+  fun conn ~wire_method ~start_date ~end_date ->
-    Conn.collect_list req (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 ->
+  fun conn ~start_date ~end_date -> collect_list conn req (start_date, end_date)
-    Conn.collect_list 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 ->
+  fun conn ~is_active ~last_change v -> exec conn req (v, is_active, last_change)
-    Conn.exec 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

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 = Timestamp.caqti
-let time_span = Time.TimeRelative.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
+  let jsont = Jsont.list Api.AccountRestriction.jsont in
-    ~encode:(fun l -> Api.encode (Jsont.list AccountRestriction.jsont) l)
+  let encode = Api.encode' jsont in
-    ~decode:(fun s -> Api.decode (Jsont.list AccountRestriction.jsont) s)
+  let decode = Api.decode' jsont in
-    string
+  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;
   }
 

src/respond.ml

@@ -1,6 +1,7 @@
 let encode_error_detail err =
-  match Api.(encode ErrorDetail.jsont err) with
+  match Api.encode Api.ErrorDetail.jsont err with
-  | Error e -> Fmt.failwith "json encoding error on `ErrorDetail`: %s." e
+  | 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 ()

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

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
+     https://www.gnupg.org/documentation/manuals/gcrypt/MPI-formats.html
-       := { uint16_be: n size; uint16_be: e size; n; e}
+     := { 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 *)
 
+  (* [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 |] ->
+    | [| n; e |] -> Mirage_rsa.pub ~n ~e |> Result.map_error (fun (`Msg e) -> e)
-        let+ pub = Mirage_rsa.pub ~n ~e |> unwrap_msg in
-        pub
     | _ -> 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
+        Mirage_rsa.priv ~e ~d ~n ~p ~q ~dp ~dq ~q'
-        priv
+        |> 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
+module Priv = struct
-     we also have to b32 encode/decode our octets because of null-char
+  (* 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 =
+  let priv_to_b32 t = B32.encode (priv_to_octets t)
-  Jsont.of_of_string ~kind:"RsaPublicKey" pub_of_b32 ~enc:pub_to_b32
+
+  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
+  if Eqaf.equal s1 s2 then Ok () else Error `Invalid_signature_rsa
-  | false -> Fmt.error "RSA signature verification failed"
-  | true -> Ok ()
 
 (* 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)

src/secmod_eddsa.ml

@@ -1,11 +1,7 @@
 (* TODO
    ! use lock
-   schedule tasks
+   schedule tasks *)
-   sign: check timestamps before signing *)
 (* 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* data = Fat.read fs spath in
-  let* priv = Eddsa.priv_of_octets data 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
+  let* s = Fat.read fs spath in
-  (* todo: catch failure *)
+  let+ k = Bbin.decode key_bin s in
-  let k = Bin.decode key_bin data (ref 0) in
+  k
-  Ok 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
+  let* s = Bbin.encode key_bin k in
-  Fat.write fs spath data |> unwrap_msg
+  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 ()
+    if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir
-    else Fat.mkdir fs Cfg.key_dir |> unwrap_msg
   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 ->
+        Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub);
-            m "generated secmod key: `%s`" (Eddsa.pub_to_b32 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 =
+  let find_exn pub =
-    Hashtbl.find_opt t.ht pub |> Option.to_result ~none:"key not found"
+    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 k = find_exn pub in
-    let data = Eddsa.sign ~key:k.priv s in
+    Eddsa.sign ~key:k.priv s
-    data
 
   (* 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 ()

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.Coin
-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 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
+      let h_pub = DenominationHash.hash pub in
-      { section_name; t1; t2; priv; pub; h_pub })
+      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 cstring (fun t -> t.coin.section_name)
-  |+ field Rsa.priv_bin (fun t -> t.priv)
+  |+ 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* data = Fat.read fs spath in
-  let* priv = Eddsa.priv_of_octets data 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* s = Fat.read fs spath in
-  let k = Bin.decode key_bin data (ref 0) in
+  let+ k = Bbin.decode key_bin s in
-  Ok k
+  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
+  let* s = Bbin.encode key_bin k in
-  Fat.write fs spath data |> unwrap_msg
+  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 gen_key coin t1 t2 =
-  let priv, pub = Rsa.generate ~bits:cfg.Coin_config.rsa_keysize () in
+  let bits = coin.Coin.rsa_keysize in
-  let h_pub = DenominationHash.hash_of_rsa pub in
+  let priv, pub = Rsa.generate ~bits () in
-  let k = { section_name= cfg.name; priv; pub; h_pub; t1; t2 } 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
+      m "generated key for coin [%s]: `%a`" coin.section_name
-        (DenominationHash.to_b32 k.h_pub));
+        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 periodes = split_in_periodes coin ~start ~end_ in
-    let new_keys = List.map (fun (t1, t2) -> gen_key cfg t1 t2) periodes 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 ()
+    if Fat.exists fs Cfg.key_dir then Ok () else Fat.mkdir fs Cfg.key_dir
-    else Fat.mkdir fs Cfg.key_dir |> unwrap_msg
   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 ->
+        Log.debug (fun m -> m "generated secmod key: `%a`" Eddsa.pp_pub sm_pub);
-            m "generated secmod key: `%s`" (Eddsa.pub_to_b32 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
+    Coin.all_coins
-    |> List.map (fun (cfg : Coin_config.t) ->
+    |> Iarray.to_list
-        let keys = List.filter (fun k -> k.section_name = cfg.name) all_keys in
+    |> List.map (fun coin ->
-        gen_additional_keys_until_lookahead cfg ~now keys)
+        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 =
+  let find_exn h_pub =
-    Hashtbl.find_opt t.ht h_pub |> Option.to_result ~none:"key not found"
+    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 add coin t1 t2 =
-    let k = gen_key cfg t1 t2 in
+    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 k = find_exn h_pub in
-    let data = Rsa.sign ~key:k.priv msg in
+    Rsa.sign ~key:k.priv msg
-    data
 
   let revoke h_pub =
-    Log.debug (fun m ->
+    Log.debug (fun m -> m "revoke `%a`" DenominationHash.pp h_pub);
-        m "revoke `%s`" (DenominationHash.to_octets h_pub |> B32.encode));
+    let k = find_exn h_pub in
-    let* k = find h_pub in
     let* () = delete h_pub in
-    let cfg = Cfg.get_coin_config ~section_name:k.section_name in
+    let* () = add k.coin k.t1 k.t2 in
-    let* () = add cfg k.t1 k.t2 in
     Ok ()
 
-  let conv =
+  let conv k = (k.h_pub, (k.coin, k.pub, k.t1))
-   fun { section_name; priv= _; pub; h_pub; t1; t2= _ } ->
-    (h_pub, (section_name, pub, 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

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 jsont =
-  let bin = Bin.bytes n
+    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 jsont =
-  let bin = Bin.bytes n
+    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_conversion_url: H64_cstring.t;
-      h_credit_restrictions: Hash.H64_cstring.t;
+      h_credit_restrictions: H64_cstring.t;
-      h_debit_restrictions: Hash.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 H64_cstring.bin (fun t -> t.h_conversion_url)
-      |+ field Hash.H64_cstring.bin (fun t -> t.h_credit_restrictions)
+      |+ field 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_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_conversion_url: H64_cstring.t;
-      h_credit_restrictions: Hash.H64_cstring.t;
+      h_credit_restrictions: H64_cstring.t;
-      h_debit_restrictions: Hash.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 H64_cstring.bin (fun t -> t.h_conversion_url)
-      |+ field Hash.H64_cstring.bin (fun t -> t.h_credit_restrictions)
+      |+ field 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_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

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

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

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"

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)
+    make (Some Sign_plus) "KUDOS" (Int64.of_int 25) (Int32.of_int 678) |> get_ok
-      ~fraction:(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
+      |> Eddsa.pub_to_b32
-      |> encode
     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)

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 =
+  let open Syntax in
-    Result.bind (Fpath.of_string file) Bos.OS.File.read |> unwrap_msg
+  Result.unwrap_err
-  in
+  @@
+  let* content = Bos.OS.File.read (Fpath.v file) in
   keys content
 
 let cli =

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
+  let open Hash.DenominationHash in
-  |> Hash.DenominationHash.hash_of_rsa
+  Fmt.pr "%a@." pp (hash rsa_pub);
-  |> Hash.DenominationHash.to_b32
-  |> Fmt.pr "%s@.";
   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
+  drain ~output ~master_key ~debit_account_section ~credit_payto_uri
-    ~amount
+    ~wtid_octets ~date ~amount
 
 let cli =
   let info =

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 =
+let write_json_file fname jsont v =
-  Bos.OS.File.write (Fpath.v fname) content |> unwrap_msg
+  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
+  write_json_file output Api.MasterSignatures.jsont master_signatures
-  let* () = write_file output s in
-  Ok ()
 
 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
+  write_json_file output Api.DenomRevocationSignature.jsont denom_revoke
-  let* () = write_file output s in
-  Ok ()
 
 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
+  write_json_file output Api.SignkeyRevocationSignature.jsont signkey_revoke
-  let* () = write_file output s in
-  Ok ()
 
 let global_fees ~output ~master_key ~start_date ~end_date ~history_fee
     ~account_fee ~purse_fee ~history_expiration ~purse_account_limit
     ~purse_timeout =
+  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
+  write_json_file output Api.GlobalFees.jsont global_fees
-  let* () = write_file output s in
-  Ok ()
 
 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
+  write_json_file output Api.AuditorSetupMessage.jsont v
-  let* () = write_file output s in
-  Ok ()
 
 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
+  write_json_file output Api.AuditorTeardownMessage.jsont v
-  let* () = write_file output s in
-  Ok ()
 
 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
+  write_json_file output Api.WireFeeSetupMessage.jsont v
-  let* () = write_file output s in
-  Ok ()
 
 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
+  write_json_file output Api.WireSetupMessage.jsont v
-  let* () = write_file output s in
-  Ok ()
 
 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
+  write_json_file output Api.WireTeardownMessage.jsont v
-  let* () = write_file output s in
-  Ok ()
 
-let drain ~output ~master_key ~debit_account_section ~credit_payto_uri ~wtid
+let drain ~output ~master_key ~debit_account_section ~credit_payto_uri
-    ~date ~amount =
+    ~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
+  write_json_file output Api.DrainProfitsMessage.jsont v
-  let* () = write_file output s in
-  Ok ()