Vendors: upgrade ocaml-ledger-wallet

* Use result instead of exceptions
* Support newer versions of the companion Tezos/TezBake Ledger apps

vendors/ocaml-ledger-wallet/ledgerwallet.opam

@@ -16,7 +16,7 @@ build: [ "jbuilder" "build" "-j" jobs "-p" name "@install" ]
 build-test: [ "jbuilder" "runtest" "-p" name "-j" jobs ]
 depends: [
   "jbuilder" {build & >= "1.0+beta16"}
-  "result" {>= "1.3"}
+  "rresult" {>= "0.5.0"}
   "cstruct" {>= "3.2.1"}
   "hidapi" {>= "1.0"}
 ]

vendors/ocaml-ledger-wallet/src/jbuild

@@ -5,7 +5,7 @@
   (public_name ledgerwallet)
   (modules     (Apdu Transport))
   (synopsis "Ledger wallet library for OCaml: common parts")
-  (libraries (result cstruct hidapi))))
+  (libraries (rresult cstruct hidapi))))
 
 (library
  ((name        ledgerwallet_tezos)

vendors/ocaml-ledger-wallet/src/ledgerwallet_tezos.ml

@@ -3,15 +3,75 @@
    Distributed under the ISC license, see terms at the end of the file.
   ---------------------------------------------------------------------------*)
 
+open Rresult
 open Ledgerwallet
 
+module Version = struct
+  type app_class = Tezos | TezBake
+  let pp_app_class ppf = function
+    | Tezos -> Format.pp_print_string ppf "Tezos"
+    | TezBake -> Format.pp_print_string ppf "TezBake"
+
+    let class_of_int = function
+    | 0 -> Tezos
+    | 1 -> TezBake
+    | _ -> invalid_arg "class_of_int"
+
+  type t = {
+    app_class : app_class ;
+    major : int ;
+    minor : int ;
+    patch : int ;
+  }
+
+  let pp ppf { app_class ; major ; minor ; patch } =
+    Format.fprintf ppf "%a.%d.%d.%d"
+      pp_app_class app_class major minor patch
+
+  let create ~app_class ~major ~minor ~patch = {
+    app_class ; major ; minor ; patch
+  }
+
+  type Transport.Status.t +=
+      Tezos_impossible_to_read_version
+
+  let () = Transport.Status.register_string_f begin function
+      | Tezos_impossible_to_read_version ->
+          Some "Impossible to read version"
+      | _ -> None
+    end
+
+  let read cs =
+    try
+      let app_class = class_of_int (Cstruct.get_uint8 cs 0) in
+      let major = Cstruct.get_uint8 cs 1 in
+      let minor = Cstruct.get_uint8 cs 2 in
+      let patch = Cstruct.get_uint8 cs 3 in
+      R.ok (create ~app_class ~major ~minor ~patch)
+    with _ ->
+      Transport.app_error
+        ~msg:"Version.read" (R.error Tezos_impossible_to_read_version)
+end
+
 type ins =
+  | Version
+  | Authorize_baking
   | Get_public_key
+  | Prompt_public_key
   | Sign
+  | Sign_unsafe
+  | Reset_high_watermark
+  | Query_high_watermark
 
 let int_of_ins = function
+  | Version -> 0x00
+  | Authorize_baking -> 0x01
   | Get_public_key -> 0x02
+  | Prompt_public_key -> 0x03
   | Sign -> 0x04
+  | Sign_unsafe -> 0x05
+  | Reset_high_watermark -> 0x06
+  | Query_high_watermark -> 0x08
 
 type curve =
   | Ed25519
@@ -26,13 +86,18 @@ let int_of_curve = function
 let wrap_ins cmd =
   Apdu.create_cmd ~cmd ~cla_of_cmd:(fun _ -> 0x80) ~ins_of_cmd:int_of_ins
 
+let get_version ?pp ?buf h =
+  let apdu = Apdu.create (wrap_ins Version) in
+  Transport.apdu ~msg:"get_version" ?pp ?buf h apdu >>=
+  Version.read
+
 let write_path cs path =
   ListLabels.fold_left path ~init:cs ~f:begin fun cs i ->
     Cstruct.BE.set_uint32 cs 0 i ;
     Cstruct.shift cs 4
   end
 
-let get_public_key ?pp ?buf h curve path =
+let get_public_key_like cmd ?pp ?buf h curve path =
   let nb_derivations = List.length path in
   if nb_derivations > 10 then invalid_arg "get_public_key: max 10 derivations" ;
   let lc = 1 + 4 * nb_derivations in
@@ -40,14 +105,32 @@ let get_public_key ?pp ?buf h curve path =
   Cstruct.set_uint8 data_init 0 nb_derivations ;
   let data = Cstruct.shift data_init 1 in
   let _data = write_path data path in
-  let msg = "Tezos.get_public_key" in
+  let msg = "get_public_key" in
-  let apdu =  Apdu.create ~p2:(int_of_curve curve)
+  let apdu = Apdu.create
-      ~lc ~data:data_init (wrap_ins Get_public_key) in
+      ~p2:(int_of_curve curve) ~lc ~data:data_init (wrap_ins cmd) in
-  let addr = Transport.apdu ~msg ?pp ?buf h apdu in
+  Transport.apdu ~msg ?pp ?buf h apdu >>| fun addr ->
   let keylen = Cstruct.get_uint8 addr 0 in
   Cstruct.sub addr 1 keylen
 
-let sign ?pp ?buf h curve path payload =
+let get_public_key ?(prompt=true) =
+  let cmd = if prompt then Prompt_public_key else Get_public_key in
+  get_public_key_like cmd
+
+let authorize_baking = get_public_key_like Authorize_baking
+
+let get_high_watermark ?pp ?buf h =
+  let apdu = Apdu.create (wrap_ins Query_high_watermark) in
+  Transport.apdu ~msg:"get_high_watermark" ?pp ?buf h apdu >>| fun hwm ->
+  Cstruct.BE.get_uint32 hwm 0
+
+let set_high_watermark ?pp ?buf h hwm =
+  let data = Cstruct.create 4 in
+  Cstruct.BE.set_uint32 data 0 hwm ;
+  let apdu = Apdu.create ~lc:4 ~data (wrap_ins Reset_high_watermark) in
+  Transport.apdu ~msg:"set_high_watermark" ?pp ?buf h apdu >>|
+  ignore
+
+let sign ?pp ?buf ?(hash_on_ledger=true) h curve path payload =
   let nb_derivations = List.length path in
   if nb_derivations > 10 then invalid_arg "get_public_key: max 10 derivations" ;
   let lc = 1 + 4 * nb_derivations in
@@ -55,8 +138,8 @@ let sign ?pp ?buf h curve path payload =
   Cstruct.set_uint8 data_init 0 nb_derivations ;
   let data = Cstruct.shift data_init 1 in
   let _data = write_path data path in
-  let cmd = wrap_ins Sign in
+  let cmd = wrap_ins (if hash_on_ledger then Sign else Sign_unsafe) in
-  let msg = "Tezos.sign" in
+  let msg = "sign" in
   let apdu = Apdu.create ~p2:(int_of_curve curve) ~lc ~data:data_init cmd in
   let _addr = Transport.apdu ~msg ?pp ?buf h apdu in
   Transport.write_payload ~mark_last:true ?pp ?buf ~msg ~cmd h ~p1:0x01 payload

vendors/ocaml-ledger-wallet/src/ledgerwallet_tezos.mli

@@ -3,22 +3,77 @@
    Distributed under the ISC license, see terms at the end of the file.
   ---------------------------------------------------------------------------*)
 
+open Ledgerwallet
+
+module Version : sig
+  type app_class = Tezos | TezBake
+  val pp_app_class : Format.formatter -> app_class -> unit
+
+  type Transport.Status.t +=
+      Tezos_impossible_to_read_version
+
+  type t = {
+    app_class : app_class ;
+    major : int ;
+    minor : int ;
+    patch : int ;
+  }
+  val pp : Format.formatter -> t -> unit
+end
+
 type curve =
   | Ed25519
   | Secp256k1
   | Secp256r1
 
-val get_public_key :
+val get_version :
   ?pp:Format.formatter -> ?buf:Cstruct.t ->
-  Hidapi.t -> curve -> int32 list -> Cstruct.t
+  Hidapi.t -> (Version.t, Transport.error) result
-(** [get_public_key ?pp ?buf ledger curve path] is [0x02 || pk] from
+(** [get_version ?pp ?buf ledger] is the version information of the
-    [ledger] at [path] for curve [curve]. *)
+    Ledger app running at [ledger]. *)
+
+val get_public_key :
+  ?prompt:bool ->
+  ?pp:Format.formatter ->
+  ?buf:Cstruct.t ->
+  Hidapi.t -> curve -> int32 list -> (Cstruct.t, Transport.error) result
+(** [get_public_key ?pp ?buf ?prompt ledger curve path] is [0x02 ||
+    pk] from [ledger] at [path] for curve [curve]. If [prompt] is
+    [true] (the default), then a prompt on Ledger screen will ask user
+    confirmation. *)
+
+val authorize_baking :
+  ?pp:Format.formatter ->
+  ?buf:Cstruct.t ->
+  Hidapi.t -> curve -> int32 list -> (Cstruct.t, Transport.error) result
+(** [authorize_baking ?pp ?buf ?prompt ledger curve path] is like
+    [get_public_key] with [prompt = true], but only works with the
+    baking Ledger application and serves to indicate that the key from
+    [curve] at [path] is allowed to bake. *)
+
+val get_high_watermark :
+  ?pp:Format.formatter -> ?buf:Cstruct.t ->
+  Hidapi.t -> (int32, Transport.error) result
+(** [get_high_watermark ?pp ?buf ledger] is the current value of the
+    high water mark on [ledger]. This works with the baking app
+    only. *)
+
+val set_high_watermark :
+  ?pp:Format.formatter -> ?buf:Cstruct.t ->
+  Hidapi.t -> int32 -> (unit, Transport.error) result
+(** [get_high_watermark ?pp ?buf ledger hwm] reset the high water
+    mark on [ledger] to [hwm]. This works with the baking app only. *)
 
 val sign :
-  ?pp:Format.formatter -> ?buf:Cstruct.t ->
+  ?pp:Format.formatter ->
-  Hidapi.t -> curve -> int32 list -> Cstruct.t -> Cstruct.t
+  ?buf:Cstruct.t ->
-(** [sign ?pp ?buf h curve path payload] is [signature], signed from
+  ?hash_on_ledger:bool ->
-    [ledger] with key from curve [curve] at [path]. *)
+  Hidapi.t -> curve -> int32 list ->
+  Cstruct.t -> (Cstruct.t, Transport.error) result
+(** [sign ?pp ?buf ?hash_on_ledger h curve path payload] is the
+    signature of [payload] (or its hash if [hash_on_ledger] is [true],
+    the default), signed on [ledger] with key from curve [curve] at
+    [path]. *)
 
 (*---------------------------------------------------------------------------
    Copyright (c) 2017 Vincent Bernardoff

vendors/ocaml-ledger-wallet/src/transport.ml

@@ -3,13 +3,21 @@
    Distributed under the ISC license, see terms at the end of the file.
   ---------------------------------------------------------------------------*)
 
+open Rresult
+
 let packet_length = 64
 let channel = 0x0101
 let apdu = 0x05
 let ping = 0x02
 
+let check_buflen cs =
+  let cslen = Cstruct.len cs in
+  if cslen < packet_length then invalid_arg
+      ("HID packets must be 64 bytes long, got " ^ string_of_int cslen)
+
 module Status = struct
-  type t =
+  type t = ..
+  type t +=
     | Invalid_pin of int
     | Incorrect_length
     | Incompatible_file_structure
@@ -21,6 +29,7 @@ module Status = struct
     | Ins_not_supported
     | Technical_problem of int
     | Ok
+    | Unknown of int
 
   let of_int = function
     | 0x6700 -> Incorrect_length
@@ -34,10 +43,14 @@ module Status = struct
     | 0x9000 -> Ok
     | v when v >= 0x63c0 && v <= 0x63cf -> Invalid_pin (v land 0x0f)
     | v when v >= 0x6f00 && v <= 0x6fff -> Technical_problem (v land 0xff)
-    | v -> invalid_arg (Printf.sprintf "Status.of_int: got 0x%x" v)
+    | v -> Unknown v
+
+  let string_fs = ref []
+  let register_string_f f =
+    string_fs := f :: !string_fs
 
   let to_string = function
-    | Invalid_pin i -> Printf.sprintf "Invalid pin %d" i
+    | Invalid_pin i -> "Invalid pin " ^  string_of_int i
     | Incorrect_length -> "Incorrect length"
     | Incompatible_file_structure -> "Incompatible file structure"
     | Security_status_unsatisfied -> "Security status unsatisfied"
@@ -46,8 +59,15 @@ module Status = struct
     | File_not_found -> "File not found"
     | Incorrect_params -> "Incorrect params"
     | Ins_not_supported -> "Instruction not supported"
-    | Technical_problem i -> Printf.sprintf "Technical problem %d" i
+    | Technical_problem i -> "Technical problem " ^ string_of_int i
     | Ok -> "Ok"
+    | Unknown i -> Printf.sprintf "Unknown status code 0x%x" i
+    | t ->
+        try
+          List.fold_left begin fun a f ->
+            match f t with Some s -> failwith s | None -> a
+          end "Unregistered status message" !string_fs
+        with Failure s -> s
 
   let show t = to_string t
 
@@ -56,58 +76,142 @@ module Status = struct
 end
 
 module Header = struct
+
   type t = {
-    cmd : [`Ping | `Apdu] ;
+    cmd : cmd ;
     seq : int ;
   }
+  and cmd = Ping | Apdu
+
+  let cmd_of_int = function
+    | 0x05 -> Some Apdu
+    | 0x02 -> Some Ping
+    | _ -> None
+
+  module Error = struct
+    type t =
+      | Header_too_short of int
+      | Invalid_channel of int
+      | Invalid_command_tag of int
+      | Unexpected_sequence_number of { expected : int ;
+                                        actual : int }
+
+    let pp ppf = function
+      | Header_too_short i ->
+          Format.fprintf ppf "Header too short (got %d bytes)" i
+      | Invalid_channel i ->
+          Format.fprintf ppf "Invalid channel (%d)" i
+      | Invalid_command_tag i ->
+          Format.fprintf ppf "Invalid command tag (%d)" i
+      | Unexpected_sequence_number { expected ; actual } ->
+          Format.fprintf ppf "Unexpected sequence number (expected %d, got %d)"
+            expected actual
+  end
+
+  let fail_header_too_short i = R.error (Error.Header_too_short i)
+  let fail_invalid_chan i = R.error (Error.Invalid_channel i)
+  let fail_invalid_cmd i = R.error (Error.Invalid_command_tag i)
+  let fail_unexpected_seqnum ~expected ~actual =
+    R.error (Error.Unexpected_sequence_number { expected ; actual })
 
   let read cs =
-    let open Cstruct in
+    let cslen = Cstruct.len cs in
-    if BE.get_uint16 cs 0 <> channel then
+    begin if cslen < 5 then
-      invalid_arg "Transport.read_header: invalid channel id" ;
+      fail_header_too_short cslen
-    let cmd = match get_uint8 cs 2 with
+      else R.ok ()
-      | 0x05 -> `Apdu
+    end >>= fun () ->
-      | 0x02 -> `Ping
+    let channel_id = Cstruct.BE.get_uint16 cs 0 in
-      | _ -> invalid_arg "Transport.read_header: invalid command tag"
+    let cmd = Cstruct.get_uint8 cs 2 in
-    in
+    let seq = Cstruct.BE.get_uint16 cs 3 in
-    let seq = BE.get_uint16 cs 3 in
+    begin
-    { cmd ; seq }, Cstruct.shift cs 5
+      if channel_id <> channel then
+        fail_invalid_chan channel_id
+      else R.ok ()
+    end >>= fun () ->
+    begin match cmd_of_int cmd with
+    | Some cmd -> R.ok cmd
+    | None -> fail_invalid_cmd cmd
+    end >>= fun cmd ->
+    R.ok ({ cmd ; seq }, Cstruct.shift cs 5)
 
-  let check_exn ?cmd ?seq t =
+  let check_seqnum t expected_seq =
-    begin match cmd with
+    if expected_seq <> t.seq then
-      | None -> ()
+      fail_unexpected_seqnum ~actual:t.seq ~expected:expected_seq
-      | Some expected ->
+    else R.ok ()
-        if expected <> t.cmd then failwith "Header.check: unexpected command"
-    end ;
-    begin match seq with
-      | None -> ()
-      | Some expected ->
-        if expected <> t.seq then failwith "Header.check: unexpected seq num"
-    end
 end
 
+type transport_error =
+  | Hidapi of string
+  | Incomplete_write of int
+  | Incomplete_read of int
+
+let pp_transport_error ppf = function
+  | Hidapi s -> Format.pp_print_string ppf s
+  | Incomplete_write i ->
+      Format.fprintf ppf "wrote %d bytes, expected to write 64 \
+                          bytes" i
+  | Incomplete_read i ->
+      Format.fprintf ppf "read %d bytes, expected to read 64 \
+                          bytes" i
+
+type error =
+  | AppError of { status : Status.t ; msg : string }
+  | ApduError of Header.Error.t
+  | TransportError of transport_error
+
+let app_error ~msg r =
+  R.reword_error (fun status -> AppError { status ; msg }) r
+let apdu_error r =
+  R.reword_error (fun e -> ApduError e) r
+
+let pp_error ppf = function
+  | AppError { status ; msg } ->
+      Format.fprintf ppf "Application level error (%s): %a"
+        msg Status.pp status
+  | ApduError e ->
+      Format.fprintf ppf "APDU level error: %a" Header.Error.pp e
+  | TransportError e ->
+      Format.fprintf ppf "Transport level error: %a" pp_transport_error e
+
+let check_nbwritten = function
+  | n when n = packet_length -> R.ok ()
+  | n -> R.error (TransportError (Incomplete_write n))
+let check_nbread = function
+  | n when n = packet_length -> R.ok ()
+  | n -> R.error (TransportError (Incomplete_read n))
+
+let write_hidapi h ?len buf =
+  R.reword_error (fun s -> TransportError (Hidapi s))
+    (Hidapi.write h ?len Cstruct.(to_bigarray (sub buf 0 packet_length))) >>=
+  check_nbwritten
+
+let read_hidapi ?timeout h buf =
+  R.reword_error (fun s -> TransportError (Hidapi s))
+    (Hidapi.read ?timeout h buf packet_length) >>=
+  check_nbread
+
 let write_ping ?(buf=Cstruct.create packet_length) h =
+  check_buflen buf ;
   let open Cstruct in
   BE.set_uint16 buf 0 channel ;
   set_uint8 buf 2 ping ;
   BE.set_uint16 buf 3 0 ;
   memset (sub buf 5 59) 0 ;
-  match Hidapi.write h (to_bigarray (sub buf 0 packet_length)) with
+  write_hidapi h buf
-  | Error msg -> failwith msg
-  | Ok nb_written when nb_written <> packet_length -> failwith "Transport.write_ping"
-  | _ -> ()
 
 let write_apdu
     ?pp
     ?(buf=Cstruct.create packet_length)
     h p =
+  check_buflen buf ;
   let apdu_len = Apdu.length p in
   let apdu_buf = Cstruct.create apdu_len in
   let _nb_written = Apdu.write apdu_buf p in
   begin match pp with
     | None -> ()
     | Some pp ->
-      Format.fprintf pp "-> %a@." Cstruct.hexdump_pp apdu_buf
+        Format.fprintf pp "-> REQ %a@." Cstruct.hexdump_pp apdu_buf ;
+        Format.pp_print_flush pp ()
   end ;
   let apdu_p = ref 0 in (* pos in the apdu buf *)
   let i = ref 0 in (* packet id *)
@@ -120,48 +224,44 @@ let write_apdu
   BE.set_uint16 buf 5 apdu_len ;
   let nb_to_write = (min apdu_len (packet_length - 7)) in
   blit apdu_buf 0 buf 7 nb_to_write ;
-  begin match Hidapi.write h (to_bigarray (sub buf 0 packet_length)) with
+  write_hidapi h buf >>= fun () ->
-    | Error msg -> failwith msg
-    | Ok nb_written when nb_written <> packet_length ->
-      failwith "Transport.write_apdu"
-    | _ -> ()
-  end ;
   apdu_p := !apdu_p + nb_to_write ;
   incr i ;
 
   (* write following packets *)
-  while !apdu_p < apdu_len do
+  let rec inner apdu_p =
-    memset buf 0 ;
+    if apdu_p >= apdu_len then R.ok ()
-    BE.set_uint16 buf 0 channel ;
+    else begin
-    set_uint8 buf 2 apdu ;
+      memset buf 0 ;
-    BE.set_uint16 buf 3 !i ;
+      BE.set_uint16 buf 0 channel ;
-    let nb_to_write = (min (apdu_len - !apdu_p) (packet_length - 5)) in
+      set_uint8 buf 2 apdu ;
-    blit apdu_buf !apdu_p buf 5 nb_to_write ;
+      BE.set_uint16 buf 3 !i ;
-    begin match Hidapi.write h (to_bigarray (sub buf 0 packet_length)) with
+      let nb_to_write = (min (apdu_len - apdu_p) (packet_length - 5)) in
-      | Error err -> failwith err
+      blit apdu_buf apdu_p buf 5 nb_to_write ;
-      | Ok nb_written when nb_written <> packet_length ->
+      write_hidapi h buf >>= fun () ->
-        failwith "Transport.write_apdu"
+      incr i ;
-      | _ -> ()
+      inner (apdu_p + nb_to_write)
-    end ;
+    end
-    apdu_p := !apdu_p + nb_to_write ;
+  in
-    incr i
+  inner !apdu_p
-  done
 
-let read ?(buf=Cstruct.create packet_length) h =
+let read ?pp ?(buf=Cstruct.create packet_length) h =
+  check_buflen buf ;
   let expected_seq = ref 0 in
   let full_payload = ref (Cstruct.create 0) in
   let payload = ref (Cstruct.create 0) in
   (* let pos = ref 0 in *)
   let rec inner () =
-    begin match Hidapi.read ~timeout:600000 h
+    read_hidapi ~timeout:600_000 h (Cstruct.to_bigarray buf) >>= fun () ->
-                  (Cstruct.to_bigarray buf) packet_length with
+    begin match pp with
-      | Error err -> failwith err
+      | None -> ()
-      | Ok nb_read when nb_read <> packet_length ->
+      | Some pp ->
-        failwith (Printf.sprintf "Transport.read: read %d bytes" nb_read)
+          Format.fprintf pp "<- RAW PKT %a@."
-      | _ -> ()
+            Cstruct.hexdump_pp (Cstruct.sub buf 0 packet_length) ;
+          Format.pp_print_flush pp ()
     end ;
-    let hdr, buf = Header.read buf in
+    apdu_error (Header.read buf) >>= fun (hdr, buf) ->
-    Header.check_exn ~seq:!expected_seq hdr ;
+    apdu_error (Header.check_seqnum hdr !expected_seq) >>= fun () ->
     if hdr.seq = 0 then begin (* first frame *)
       let len = Cstruct.BE.get_uint16 buf 0 in
       let cs = Cstruct.shift buf 2 in
@@ -180,40 +280,37 @@ let read ?(buf=Cstruct.create packet_length) h =
       (* pos := !pos + nb_to_read ; *)
       expected_seq := !expected_seq + 1
     end ;
-    if Cstruct.len !payload = 0 then
+    match Cstruct.len !payload, hdr.cmd with
-      if hdr.cmd = `Ping then Status.Ok, Cstruct.create 0
+    | 0, Ping -> R.ok (Status.Ok, Cstruct.create 0)
-      else
+    | 0, Apdu ->
         (* let sw_pos = Bytes.length !payload - 2 in *)
         let payload_len = Cstruct.len !full_payload in
-        Status.of_int Cstruct.(BE.get_uint16 !full_payload (payload_len - 2)),
+        let sw = Cstruct.BE.get_uint16 !full_payload (payload_len - 2) in
-        Cstruct.sub !full_payload 0 (payload_len - 2)
+        R.ok
-    else inner ()
+          (Status.of_int sw,
+           Cstruct.sub !full_payload 0 (payload_len - 2))
+    | _ -> inner ()
   in
   inner ()
 
-let ping ?buf h =
+let ping ?pp ?buf h =
-  write_ping ?buf h ;
+  write_ping ?buf h >>= fun () ->
-  match read ?buf h with
+  read ?pp ?buf h >>|
-  | Status.Ok, _ -> ()
+  ignore
-  | s, _ -> failwith ((Status.to_string s))
 
 let apdu ?pp ?(msg="") ?buf h apdu =
-  write_apdu ?pp ?buf h apdu ;
+  write_apdu ?pp ?buf h apdu >>= fun () ->
-  match read ?buf h with
+  read ?pp ?buf h >>= fun (status, payload) ->
-  | Status.Ok, payload ->
+  begin match pp with
-    begin match pp with
+    | None -> ()
-      | None -> ()
+    | Some pp ->
-      | Some pp ->
+        Format.fprintf pp "<- RESP [%a] %a@."
-        Format.fprintf pp "<- %a %a@." Status.pp Status.Ok Cstruct.hexdump_pp payload
+          Status.pp status Cstruct.hexdump_pp payload ;
-    end ;
+        Format.pp_print_flush pp ()
-    payload
+  end ;
-  | s, payload ->
+  match status with
-    begin match pp with
+  | Status.Ok -> R.ok payload
-      | None -> ()
+  | status -> app_error ~msg (R.error status)
-      | Some pp ->
-        Format.fprintf pp "<- %a %a@." Status.pp s Cstruct.hexdump_pp payload
-    end ;
-    failwith ((Status.to_string s) ^ " " ^ msg)
 
 let write_payload
     ?pp ?(msg="write_payload") ?buf ?(mark_last=false) ~cmd ?p1 ?p2 h cs =
@@ -225,11 +322,12 @@ let write_payload
       | true, true, None -> Some 0x80
       | true, true, Some p1 -> Some (0x80 lor p1)
       | _ -> p1 in
-    let response = apdu ?pp ~msg ?buf h
+    apdu ?pp ~msg ?buf h
-        Apdu.(create ?p1 ?p2 ~lc ~data:(Cstruct.sub cs 0 lc) cmd) in
+      Apdu.(create ?p1 ?p2 ~lc
-    if last then response
+              ~data:(Cstruct.sub cs 0 lc) cmd) >>= fun response ->
+    if last then R.ok response
     else inner (Cstruct.shift cs lc) in
-  if Cstruct.len cs = 0 then cs else inner cs
+  if Cstruct.len cs = 0 then R.ok cs else inner cs
 
 (*---------------------------------------------------------------------------
    Copyright (c) 2017 Vincent Bernardoff

vendors/ocaml-ledger-wallet/src/transport.mli

@@ -4,7 +4,8 @@
   ---------------------------------------------------------------------------*)
 
 module Status : sig
-  type t =
+  type t = ..
+  type t +=
     | Invalid_pin of int
     | Incorrect_length
     | Incompatible_file_structure
@@ -17,34 +18,65 @@ module Status : sig
     | Technical_problem of int
     | Ok
 
+  val register_string_f : (t -> string option) -> unit
+
   val to_string : t -> string
   val show : t -> string
   val pp : Format.formatter -> t -> unit
 end
 
+module Header : sig
+  module Error : sig
+    type t =
+      | Header_too_short of int
+      | Invalid_channel of int
+      | Invalid_command_tag of int
+      | Unexpected_sequence_number of { expected : int ;
+                                        actual : int }
+  end
+end
+
+type transport_error =
+  | Hidapi of string
+  | Incomplete_write of int
+  | Incomplete_read of int
+
+type error =
+  | AppError of { status : Status.t ; msg : string }
+  | ApduError of Header.Error.t
+  | TransportError of transport_error
+
+val app_error :
+  msg:string -> ('a, Status.t) result -> ('a, error) result
+
+val pp_error : Format.formatter -> error -> unit
+
 val write_apdu :
   ?pp:Format.formatter -> ?buf:Cstruct.t ->
-  Hidapi.t -> Apdu.t -> unit
+  Hidapi.t -> Apdu.t -> (unit, error) result
 (** [write_apdu ?pp ?buf ledger apdu] writes [apdu] to [ledger]. *)
 
-val read : ?buf:Cstruct.t -> Hidapi.t -> Status.t * Cstruct.t
+val read :
-(** [read ?buf ledger] reads from [ledger] a status response and a
+  ?pp:Format.formatter -> ?buf:Cstruct.t ->
+  Hidapi.t -> (Status.t * Cstruct.t, error) result
+(** [read ?pp ?buf ledger] reads from [ledger] a status response and a
     payload. *)
 
-val ping : ?buf:Cstruct.t -> Hidapi.t -> unit
+val ping : ?pp:Format.formatter -> ?buf:Cstruct.t ->
-(** [ping ?buf ledger] writes a ping packet to [ledger], optionally
+  Hidapi.t -> (unit, error) result
-    containing [buf]. *)
+(** [ping ?pp ?buf ledger] writes a ping packet to [ledger],
+    optionally containing [buf]. *)
 
 val apdu :
   ?pp:Format.formatter -> ?msg:string -> ?buf:Cstruct.t ->
-  Hidapi.t -> Apdu.t -> Cstruct.t
+  Hidapi.t -> Apdu.t -> (Cstruct.t, error) result
 (** [apdu ?pp ?msg ?buf ledger apdu] writes [apdu] to [ledger] and
     returns the response. *)
 
 val write_payload :
   ?pp:Format.formatter -> ?msg:string -> ?buf:Cstruct.t ->
   ?mark_last:bool -> cmd:Apdu.cmd -> ?p1:int -> ?p2:int ->
-  Hidapi.t -> Cstruct.t -> Cstruct.t
+  Hidapi.t -> Cstruct.t -> (Cstruct.t, error) result
 (** [write_payload ?pp ?msg ?buf ?mark_last ~cmd ?p1 ?p2 ledger
     payload] writes the [payload] of [cmd] into [ledger] and returns
     the response. *)