From aceee178e10daf315479a7d441b1f36e188f8f83 Mon Sep 17 00:00:00 2001 From: Vincent Bernardoff Date: Thu, 28 Jun 2018 20:44:04 +0200 Subject: [PATCH] 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 | 2 +- vendors/ocaml-ledger-wallet/src/jbuild | 2 +- .../src/ledgerwallet_tezos.ml | 99 +++++- .../src/ledgerwallet_tezos.mli | 71 ++++- vendors/ocaml-ledger-wallet/src/transport.ml | 284 ++++++++++++------ vendors/ocaml-ledger-wallet/src/transport.mli | 50 ++- 6 files changed, 388 insertions(+), 120 deletions(-) diff --git a/vendors/ocaml-ledger-wallet/ledgerwallet.opam b/vendors/ocaml-ledger-wallet/ledgerwallet.opam index 02ba20e72..e4308cdae 100644 --- a/vendors/ocaml-ledger-wallet/ledgerwallet.opam +++ b/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"} ] diff --git a/vendors/ocaml-ledger-wallet/src/jbuild b/vendors/ocaml-ledger-wallet/src/jbuild index 80a3449a9..16346304b 100644 --- a/vendors/ocaml-ledger-wallet/src/jbuild +++ b/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) diff --git a/vendors/ocaml-ledger-wallet/src/ledgerwallet_tezos.ml b/vendors/ocaml-ledger-wallet/src/ledgerwallet_tezos.ml index 3c1f9c0ad..401f132d3 100644 --- a/vendors/ocaml-ledger-wallet/src/ledgerwallet_tezos.ml +++ b/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 apdu = Apdu.create ~p2:(int_of_curve curve) - ~lc ~data:data_init (wrap_ins Get_public_key) in - let addr = Transport.apdu ~msg ?pp ?buf h apdu in + let msg = "get_public_key" in + let apdu = Apdu.create + ~p2:(int_of_curve curve) ~lc ~data:data_init (wrap_ins cmd) 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 msg = "Tezos.sign" in + let cmd = wrap_ins (if hash_on_ledger then Sign else Sign_unsafe) 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 diff --git a/vendors/ocaml-ledger-wallet/src/ledgerwallet_tezos.mli b/vendors/ocaml-ledger-wallet/src/ledgerwallet_tezos.mli index d32c8dd08..e28d18c00 100644 --- a/vendors/ocaml-ledger-wallet/src/ledgerwallet_tezos.mli +++ b/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 -(** [get_public_key ?pp ?buf ledger curve path] is [0x02 || pk] from - [ledger] at [path] for curve [curve]. *) + Hidapi.t -> (Version.t, Transport.error) result +(** [get_version ?pp ?buf ledger] is the version information of the + 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 -> - Hidapi.t -> curve -> int32 list -> Cstruct.t -> Cstruct.t -(** [sign ?pp ?buf h curve path payload] is [signature], signed from - [ledger] with key from curve [curve] at [path]. *) + ?pp:Format.formatter -> + ?buf:Cstruct.t -> + ?hash_on_ledger:bool -> + 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 diff --git a/vendors/ocaml-ledger-wallet/src/transport.ml b/vendors/ocaml-ledger-wallet/src/transport.ml index 9ec1212b1..05cfa4c23 100644 --- a/vendors/ocaml-ledger-wallet/src/transport.ml +++ b/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 - if BE.get_uint16 cs 0 <> channel then - invalid_arg "Transport.read_header: invalid channel id" ; - let cmd = match get_uint8 cs 2 with - | 0x05 -> `Apdu - | 0x02 -> `Ping - | _ -> invalid_arg "Transport.read_header: invalid command tag" - in - let seq = BE.get_uint16 cs 3 in - { cmd ; seq }, Cstruct.shift cs 5 + let cslen = Cstruct.len cs in + begin if cslen < 5 then + fail_header_too_short cslen + else R.ok () + end >>= fun () -> + let channel_id = Cstruct.BE.get_uint16 cs 0 in + let cmd = Cstruct.get_uint8 cs 2 in + let seq = Cstruct.BE.get_uint16 cs 3 in + begin + 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 = - begin match cmd with - | None -> () - | Some expected -> - 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 + let check_seqnum t expected_seq = + if expected_seq <> t.seq then + fail_unexpected_seqnum ~actual:t.seq ~expected:expected_seq + else R.ok () 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 - | Error msg -> failwith msg - | Ok nb_written when nb_written <> packet_length -> failwith "Transport.write_ping" - | _ -> () + write_hidapi h buf 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 - | Error msg -> failwith msg - | Ok nb_written when nb_written <> packet_length -> - failwith "Transport.write_apdu" - | _ -> () - end ; + write_hidapi h buf >>= fun () -> apdu_p := !apdu_p + nb_to_write ; incr i ; (* write following packets *) - while !apdu_p < apdu_len do - memset buf 0 ; - BE.set_uint16 buf 0 channel ; - set_uint8 buf 2 apdu ; - BE.set_uint16 buf 3 !i ; - let nb_to_write = (min (apdu_len - !apdu_p) (packet_length - 5)) in - blit apdu_buf !apdu_p buf 5 nb_to_write ; - begin match Hidapi.write h (to_bigarray (sub buf 0 packet_length)) with - | Error err -> failwith err - | Ok nb_written when nb_written <> packet_length -> - failwith "Transport.write_apdu" - | _ -> () - end ; - apdu_p := !apdu_p + nb_to_write ; - incr i - done + let rec inner apdu_p = + if apdu_p >= apdu_len then R.ok () + else begin + memset buf 0 ; + BE.set_uint16 buf 0 channel ; + set_uint8 buf 2 apdu ; + BE.set_uint16 buf 3 !i ; + let nb_to_write = (min (apdu_len - apdu_p) (packet_length - 5)) in + blit apdu_buf apdu_p buf 5 nb_to_write ; + write_hidapi h buf >>= fun () -> + incr i ; + inner (apdu_p + nb_to_write) + end + in + inner !apdu_p -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 - (Cstruct.to_bigarray buf) packet_length with - | Error err -> failwith err - | Ok nb_read when nb_read <> packet_length -> - failwith (Printf.sprintf "Transport.read: read %d bytes" nb_read) - | _ -> () + read_hidapi ~timeout:600_000 h (Cstruct.to_bigarray buf) >>= fun () -> + begin match pp with + | None -> () + | Some pp -> + 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 - Header.check_exn ~seq:!expected_seq hdr ; + apdu_error (Header.read buf) >>= fun (hdr, buf) -> + 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 - if hdr.cmd = `Ping then Status.Ok, Cstruct.create 0 - else + match Cstruct.len !payload, hdr.cmd with + | 0, Ping -> R.ok (Status.Ok, Cstruct.create 0) + | 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)), - Cstruct.sub !full_payload 0 (payload_len - 2) - else inner () + let sw = Cstruct.BE.get_uint16 !full_payload (payload_len - 2) in + R.ok + (Status.of_int sw, + Cstruct.sub !full_payload 0 (payload_len - 2)) + | _ -> inner () in inner () -let ping ?buf h = - write_ping ?buf h ; - match read ?buf h with - | Status.Ok, _ -> () - | s, _ -> failwith ((Status.to_string s)) +let ping ?pp ?buf h = + write_ping ?buf h >>= fun () -> + read ?pp ?buf h >>| + ignore let apdu ?pp ?(msg="") ?buf h apdu = - write_apdu ?pp ?buf h apdu ; - match read ?buf h with - | Status.Ok, payload -> - begin match pp with - | None -> () - | Some pp -> - Format.fprintf pp "<- %a %a@." Status.pp Status.Ok Cstruct.hexdump_pp payload - end ; - payload - | s, payload -> - begin match pp with - | None -> () - | Some pp -> - Format.fprintf pp "<- %a %a@." Status.pp s Cstruct.hexdump_pp payload - end ; - failwith ((Status.to_string s) ^ " " ^ msg) + write_apdu ?pp ?buf h apdu >>= fun () -> + read ?pp ?buf h >>= fun (status, payload) -> + begin match pp with + | None -> () + | Some pp -> + Format.fprintf pp "<- RESP [%a] %a@." + Status.pp status Cstruct.hexdump_pp payload ; + Format.pp_print_flush pp () + end ; + match status with + | Status.Ok -> R.ok payload + | status -> app_error ~msg (R.error status) 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.(create ?p1 ?p2 ~lc ~data:(Cstruct.sub cs 0 lc) cmd) in - if last then response + apdu ?pp ~msg ?buf h + Apdu.(create ?p1 ?p2 ~lc + ~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 diff --git a/vendors/ocaml-ledger-wallet/src/transport.mli b/vendors/ocaml-ledger-wallet/src/transport.mli index 0c5d87326..4edc1467a 100644 --- a/vendors/ocaml-ledger-wallet/src/transport.mli +++ b/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 -(** [read ?buf ledger] reads from [ledger] a status response and a +val read : + ?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 -(** [ping ?buf ledger] writes a ping packet to [ledger], optionally - containing [buf]. *) +val ping : ?pp:Format.formatter -> ?buf:Cstruct.t -> + Hidapi.t -> (unit, error) result +(** [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. *)