Ledger: add deauth APDU support, better get-authorized-key support, and friendlier CLI

src/lib_clic/clic.ml

@@ -32,6 +32,26 @@ type ('p, 'ctx) parameter =
 let parameter ?autocomplete converter =
   { converter ; autocomplete }
 
+let compose_parameters { converter = c1; autocomplete = a1' } { converter = c2; autocomplete = a2' } =
+  { converter = (fun ctx s ->
+        c1 ctx s >>= function
+        | Ok r -> return r
+        | Error _ -> c2 ctx s);
+    autocomplete = match a1' with
+      | None -> a2'
+      | Some a1 -> match a2' with
+        | None -> a1'
+        | Some a2 -> Some (fun ctx ->
+            a1 ctx >>=? fun r1 ->
+            a2 ctx >>=? fun r2 ->
+            return (List.concat [r1; r2]))
+  }
+
+let map_parameter ~f { converter; autocomplete } =
+  { converter = (fun ctx s -> converter ctx s >>|? f);
+    autocomplete
+  }
+
 type label =
   { long : string ;
     short : char option }

src/lib_clic/clic.mli

@@ -58,6 +58,15 @@ val parameter :
   ('ctx -> string -> 'a tzresult Lwt.t) ->
   ('a, 'ctx) parameter
 
+(** Build an argument parser by composing two other parsers. The
+    resulting parser will try the first parser and if it fails will
+    try the second. The auto-complete contents of the two will be
+    concatenated. *)
+val compose_parameters : ('a, 'ctx) parameter -> ('a, 'ctx) parameter -> ('a, 'ctx) parameter
+
+(** Map a pure function over the result of a parameter parser. *)
+val map_parameter : f:('a -> 'b) -> ('a, 'ctx) parameter -> ('b, 'ctx) parameter
+
 (** {2 Flags and Options } *)
 
 (** The type for optional arguments (and switches).

src/lib_client_base/client_aliases.ml

@@ -73,6 +73,7 @@ module type Alias = sig
     string -> t -> unit tzresult Lwt.t
   val of_source : string -> t tzresult Lwt.t
   val to_source : t -> string tzresult Lwt.t
+  val alias_parameter : unit -> (string * t, #Client_context.wallet) Clic.parameter
   val alias_param :
     ?name:string ->
     ?desc:string ->
@@ -200,15 +201,15 @@ module Alias = functor (Entity : Entity) -> struct
 
   include Entity
 
+  let alias_parameter () = parameter
+      ~autocomplete
+      (fun cctxt s ->
+         find cctxt s >>=? fun v ->
+         return (s, v))
+
   let alias_param
       ?(name = "name") ?(desc = "existing " ^ Entity.name ^ " alias") next =
-    param ~name ~desc
+    param ~name ~desc (alias_parameter ()) next
-      (parameter
-         ~autocomplete
-         (fun (cctxt : #Client_context.wallet) s ->
-            find cctxt s >>=? fun v ->
-            return (s, v)))
-      next
 
   type fresh_param = Fresh of string
 

src/lib_client_base/client_aliases.mli

@@ -69,6 +69,7 @@ module type Alias = sig
     string -> t -> unit tzresult Lwt.t
   val of_source : string -> t tzresult Lwt.t
   val to_source : t -> string tzresult Lwt.t
+  val alias_parameter : unit -> (string * t, #Client_context.wallet) Clic.parameter
   val alias_param :
     ?name:string ->
     ?desc:string ->

src/lib_client_base/client_keys.ml

@@ -78,6 +78,10 @@ let make_pk_uri x = x
 type sk_uri = Uri.t
 let make_sk_uri x = x
 
+let pk_uri_parameter () = Clic.parameter (fun _ s ->
+    try return (make_pk_uri @@ Uri.of_string s)
+    with Failure s -> failwith "Error while parsing URI: %s" s)
+
 let pk_uri_param ?name ?desc params =
   let name = Option.unopt ~default:"uri" name in
   let desc = Option.unopt
@@ -85,11 +89,11 @@ let pk_uri_param ?name ?desc params =
                 Varies from one scheme to the other.\n\
                 Use command `list signing schemes` for more \
                 information." desc in
-  let open Clic in
+  Clic.param ~name ~desc (pk_uri_parameter ()) params
-  param ~name ~desc (parameter (fun _ s ->
+
-      try return (make_pk_uri @@ Uri.of_string s)
+let sk_uri_parameter () = Clic.parameter (fun _ s ->
-      with Failure s -> failwith "Error while parsing uri: %s" s))
+    try return (make_sk_uri @@ Uri.of_string s)
-    params
+    with Failure s -> failwith "Error while parsing URI: %s" s)
 
 let sk_uri_param ?name ?desc params =
   let name = Option.unopt ~default:"uri" name in
@@ -98,12 +102,7 @@ let sk_uri_param ?name ?desc params =
                 Varies from one scheme to the other.\n\
                 Use command `list signing schemes` for more \
                 information." desc in
-  let open Clic in
+  Clic.param ~name ~desc (sk_uri_parameter ()) params
-  param ~name ~desc
-    (parameter (fun _ s ->
-         try return (make_sk_uri @@ Uri.of_string s)
-         with Failure s -> failwith "Error while parsing uri: %s" s))
-    params
 
 module Secret_key =
   Client_aliases.Alias (struct

src/lib_client_base/client_keys.mli

@@ -28,9 +28,11 @@
 type pk_uri = private Uri.t
 type sk_uri = private Uri.t
 
+val pk_uri_parameter : unit -> (pk_uri, 'a) Clic.parameter
 val pk_uri_param :
   ?name:string -> ?desc:string ->
   ('a, 'b) Clic.params -> (pk_uri -> 'a, 'b) Clic.params
+val sk_uri_parameter : unit -> (sk_uri, 'a) Clic.parameter
 val sk_uri_param :
   ?name:string -> ?desc:string ->
   ('a, 'b) Clic.params -> (sk_uri -> 'a, 'b) Clic.params

src/lib_signer_backends/ledger.ml

@@ -153,6 +153,17 @@ let pp_id ppf = function
            | Some a -> Format.fprintf fmt "/%a" Ledgerwallet_tezos.pp_curve a)
         curve
 
+let pp_animals_uri ppf (names, curve, path) =
+  let (root, path_without_root) = List.split_n (List.length tezos_root) path in
+  if root <> tezos_root then
+    Format.kasprintf Pervasives.failwith "BIP32 path is missing Tezos BIP32 prefix of %a: %a" Bip32_path.pp_path tezos_root Bip32_path.pp_path path
+  else
+    Format.fprintf ppf "ledger://%a%a" pp_id (Animals (names, Some curve))
+      (fun fmt -> function
+         | [] -> Format.fprintf fmt ""
+         | xs -> Format.fprintf fmt "/%a" Bip32_path.pp_path xs)
+      path_without_root
+
 let parse_animals animals =
   match String.split '-' animals with
   | [c; t; h; d] -> Some { Ledger_names.c ; t ; h ; d }
@@ -184,6 +195,20 @@ let id_of_uri uri =
 let id_of_pk_uri (uri : pk_uri) = id_of_uri (uri :> Uri.t)
 let id_of_sk_uri (uri : sk_uri) = id_of_uri (uri :> Uri.t)
 
+let sk_or_alias_param next =
+  let name = "account-alias-or-ledger-uri" in
+  let desc = "An imported ledger alias or a ledger URI (e.g. 'ledger://animal/curve/path')." in
+  let open Clic in
+  (* Order of parsers is important: The secret key parser accepts far more inputs so must come last. *)
+  param ~name ~desc (compose_parameters
+                       (map_parameter ~f:(fun (_, (x, _)) -> `Pk_uri x) (Public_key.alias_parameter ()))
+                       (map_parameter ~f:(fun x -> `Sk_uri x) (Client_keys.sk_uri_parameter ())))
+    next
+
+let id_of_sk_or_pk = function
+  | `Sk_uri sk -> id_of_sk_uri sk
+  | `Pk_uri pk -> id_of_pk_uri pk
+
 let wrap_ledger_cmd f =
   let buf = Buffer.create 100 in
   let pp = Format.formatter_of_buffer buf in
@@ -527,7 +552,7 @@ let commands =
            find_ledgers () >>=? function
            | [] ->
                cctxt#message "No device found." >>= fun () ->
-               cctxt#message "Make sure a Ledger Nano S is connected and in the Tezos Wallet app." >>= fun () ->
+               cctxt#message "Make sure a Ledger Nano S is connected and in the Tezos Wallet or Tezos Baking app." >>= fun () ->
                return_unit
            | ledgers ->
                iter_s begin fun { Ledger.device_info = { Hidapi.path ;
@@ -635,24 +660,45 @@ let commands =
         ~desc: "Query the path of the authorized key"
         no_options
         (prefixes [ "get" ; "ledger" ; "authorized" ; "path" ; "for" ]
-         @@ Public_key.alias_param
+         @@ sk_or_alias_param
          @@ stop)
-        (fun () (name, (pk_uri, _)) (cctxt : Client_context.full) ->
+        (fun () uri (cctxt : Client_context.full) ->
-           id_of_pk_uri pk_uri >>=? fun root_id ->
+           id_of_sk_or_pk uri >>=? fun root_id ->
-           with_ledger root_id begin fun h _version _of_curve _to_curve ->
+           with_ledger root_id begin fun h version _of_curve _to_curve ->
-             wrap_ledger_cmd begin fun pp ->
+             (if version.major < 2 then
-               Ledgerwallet_tezos.get_authorized_key ~pp h
+                wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_authorized_key ~pp h)
-             end >>=? function
+                >>|? fun path -> (path, None)
-             | [] ->
+              else
+                wrap_ledger_cmd (fun pp -> Ledgerwallet_tezos.get_authorized_path_and_curve ~pp h)
+                >>= function
+                | Error (LedgerError (AppError {status = Ledgerwallet.Transport.Status.Referenced_data_not_found; _}) :: _) -> return ([], None)
+                | Error _ as e -> Lwt.return e
+                | Ok (path, curve) -> return (path, Some curve))
+             >>=? function
+             | ([], _) ->
                  cctxt#message
-                   "@[<v 0>No baking key authorized for %s@]" name
+                   "@[<v 0>No baking key authorized for %a@]" pp_id root_id
                  >>= fun () ->
                  return_unit
-             | path ->
+             | (path, None) ->
                  cctxt#message
                    "@[<v 0>Authorized baking path: %a@]"
                    Bip32_path.pp_path path >>= fun () ->
                  return_unit
+             | (path, Some curve) ->
+                 cctxt#message
+                   "@[<v 0>Authorized baking path: %a@]"
+                   Bip32_path.pp_path path >>= fun () ->
+                 cctxt#message
+                   "@[<v 0>Authorized baking curve: %a@]"
+                   Ledgerwallet_tezos.pp_curve curve >>= fun () ->
+                 (match root_id with
+                  | Pkh _ -> cctxt#message "@[<v 0>Authorized baking PKH: %a@]"
+                               pp_id root_id
+                  | Animals (cthd, _) -> cctxt#message "@[<v 0>Authorized baking URI: %a@]"
+                                           pp_animals_uri (cthd, curve, path))
+                 >>= fun () ->
+                 return_unit
            end) ;
 
       Clic.command ~group
@@ -800,16 +846,39 @@ let commands =
             return_unit
           end) ;
 
+      Clic.command ~group
+        ~desc: "Deauthorize Ledger from baking"
+        no_options
+        (prefixes [ "deauthorize" ; "ledger" ; "baking" ; "for" ]
+         @@ sk_or_alias_param
+         @@ stop)
+        (fun () uri (_ : Client_context.full) ->
+           id_of_sk_or_pk uri >>=? fun id ->
+           with_ledger id begin fun h version _ _ ->
+             match version.app_class with
+             | Tezos ->
+                 failwith "Fatal: this operation is only valid with the \
+                           Tezos Baking application"
+             | TezBake when version.major < 2 ->
+                 failwith "Fatal: this operation is only available with \
+                           Tezos Baking application version 2 or higher"
+             | TezBake ->
+                 wrap_ledger_cmd begin fun pp ->
+                   Ledgerwallet_tezos.deauthorize_baking ~pp h
+                 end
+           end
+        );
+
       Clic.command ~group
         ~desc: "Get high water mark of a Ledger"
         (args1 (switch ~doc:"Prevent the fallback to the (deprecated) Ledger \
                              instructions (for 1.x.y versions of the Baking app)"
                   ~long:"no-legacy-instructions" ()))
         (prefixes [ "get" ; "ledger" ; "high" ; "watermark" ; "for" ]
-         @@ Client_keys.sk_uri_param
+         @@ sk_or_alias_param
          @@ stop)
-        (fun no_legacy_apdu sk_uri (cctxt : Client_context.full) ->
+        (fun no_legacy_apdu uri (cctxt : Client_context.full) ->
-           id_of_sk_uri sk_uri >>=? fun id ->
+           id_of_sk_or_pk uri >>=? fun id ->
            with_ledger id begin fun h version _ _ ->
              match version.app_class with
              | Tezos ->
@@ -847,7 +916,7 @@ let commands =
         ~desc: "Set high water mark of a Ledger"
         no_options
         (prefixes [ "set" ; "ledger" ; "high" ; "watermark" ; "for" ]
-         @@ Client_keys.sk_uri_param
+         @@ sk_or_alias_param
          @@ (prefix "to")
          @@ (param
                ~name: "high watermark"
@@ -856,8 +925,8 @@ let commands =
                     try return (Int32.of_string s)
                     with _ -> failwith "%s is not an int32 value" s)))
          @@ stop)
-        (fun () sk_uri hwm (cctxt : Client_context.full) ->
+        (fun () uri hwm (cctxt : Client_context.full) ->
-           id_of_sk_uri sk_uri >>=? fun id ->
+           id_of_sk_or_pk uri >>=? fun id ->
            with_ledger id begin fun h version _ _ ->
              match version.app_class with
              | Tezos ->

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

@@ -66,6 +66,8 @@ type ins =
   | Get_authorized_key
   | Setup
   | Query_all_high_watermarks
+  | Deauthorize_baking
+  | Get_authorized_path_and_curve
 
 let int_of_ins = function
   | Version -> 0x00
@@ -80,6 +82,8 @@ let int_of_ins = function
   | Get_authorized_key -> 0x07
   | Setup -> 0x0A
   | Query_all_high_watermarks -> 0x0B
+  | Deauthorize_baking -> 0x0C
+  | Get_authorized_path_and_curve -> 0x0D
 
 type curve =
   | Ed25519
@@ -108,6 +112,21 @@ let int_of_curve = function
   | Secp256k1 -> 0x01
   | Secp256r1 -> 0x02
 
+let curve_of_int = function
+  | 0x00 -> Some Ed25519
+  | 0x01 -> Some Secp256k1
+  | 0x02 -> Some Secp256r1
+  | _ -> None
+
+type Transport.Status.t +=
+    Tezos_invalid_curve_code of int
+
+let () = Transport.Status.register_string_f begin function
+    | Tezos_invalid_curve_code curve_code ->
+        Some ("Unrecognized curve code: " ^ string_of_int curve_code)
+    | _ -> None
+  end
+
 let wrap_ins cmd =
   Apdu.create_cmd ~cmd ~cla_of_cmd:(fun _ -> 0x80) ~ins_of_cmd:int_of_ins
 
@@ -121,15 +140,30 @@ let get_git_commit ?pp ?buf h =
   Transport.apdu ~msg:"get_git_commit" ?pp ?buf h apdu >>|
   Cstruct.to_string
 
+let read_path_with_length buf =
+  let length = Cstruct.get_uint8 buf 0 in
+  let rec go acc path =
+    if Cstruct.len path = 0 || List.length acc = length then List.rev acc
+    else
+      go (Cstruct.BE.get_uint32 path 0 :: acc)
+        (Cstruct.shift path 4) in
+  go [] (Cstruct.shift buf 1)
+
 let get_authorized_key ?pp ?buf h =
   let apdu = Apdu.create (wrap_ins Get_authorized_key) in
   Transport.apdu ~msg:"get_authorized_key" ?pp ?buf h apdu >>| fun path ->
-  let rec read_numbers acc path =
+  read_path_with_length path
-    if Cstruct.len path = 0 then List.rev acc
+
-    else
+let get_authorized_path_and_curve ?pp ?buf h =
-      read_numbers (Cstruct.BE.get_uint32 path 0 :: acc)
+  let apdu = Apdu.create (wrap_ins Get_authorized_path_and_curve) in
-        (Cstruct.shift path 4) in
+  Transport.apdu ~msg:"get_authorized_path_and_curve" ?pp ?buf h apdu >>= fun payload ->
-  read_numbers [] (Cstruct.shift path 1)
+  let curve_code = Cstruct.get_uint8 payload 0 in
+  match curve_of_int curve_code with
+  | None ->
+      Transport.app_error ~msg:"get_authorized_path_and_curve" (R.error (Tezos_invalid_curve_code curve_code))
+  | Some curve ->
+      let path_components = read_path_with_length (Cstruct.shift payload 1) in
+      R.ok (path_components, curve)
 
 let write_path cs path =
   ListLabels.fold_left path ~init:cs ~f:begin fun cs i ->
@@ -168,7 +202,7 @@ let setup_baking ?pp ?buf h ~main_chain_id ~main_hwm ~test_hwm curve path =
     (3 * 4) + 1 + (4 * nb_derivations) in
   let data_init = Cstruct.create lc in
   (* If the size of chain-ids changes, then all assumptions of this
-     binary format are broken (the ledger expects an int32). *)
+     binary format are broken (the ledger expects a uint32). *)
   assert (String.length main_chain_id = 4) ;
   for ith = 0 to 3 do
     Cstruct.set_uint8 data_init ith (int_of_char main_chain_id.[ith]) ;
@@ -187,6 +221,11 @@ let setup_baking ?pp ?buf h ~main_chain_id ~main_hwm ~test_hwm curve path =
   let keylen = Cstruct.get_uint8 addr 0 in
   Cstruct.sub addr 1 keylen
 
+let deauthorize_baking ?pp ?buf h =
+  let apdu = Apdu.create (wrap_ins Deauthorize_baking) in
+  Transport.apdu ~msg:"deauthorize_baking" ?pp ?buf h apdu >>| fun _ ->
+  ()
+
 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 ->

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

@@ -48,6 +48,14 @@ val get_authorized_key :
 (** [get_authorized_key ?pp ?buf ledger] is the BIP32 path of the key
     authorized to bake on the Ledger app running at [ledger]. *)
 
+val get_authorized_path_and_curve :
+  ?pp:Format.formatter -> ?buf:Cstruct.t ->
+  Hidapi.t -> (int32 list * curve, Transport.error) result
+(** [get_authorized_path_and_curve ?pp ?buf ledger] is the BIP32 path
+    and the curve code of the key authorized to bake on the Ledger app
+    running at [ledger]. *)
+
+
 val get_public_key :
   ?prompt:bool ->
   ?pp:Format.formatter ->
@@ -80,6 +88,11 @@ val setup_baking :
     indicates that the key at the given [curve/path] is authorized for
     baking. *)
 
+val deauthorize_baking :
+  ?pp:Format.formatter -> ?buf:Cstruct.t -> Hidapi.t -> (unit, Transport.error) result
+(** [deauthorize_baking ?pp ?buf ledger]
+    deauthorizes the Ledger's Baking application from baking for any address. *)
+
 val get_high_watermark :
   ?pp:Format.formatter -> ?buf:Cstruct.t ->
   Hidapi.t -> (int32, Transport.error) result

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

@@ -32,6 +32,7 @@ module Status = struct
     | Incorrect_class
     | Ins_not_supported
     | Memory_error
+    | Referenced_data_not_found
     | Technical_problem of int
     | Ok
     | Unknown of int
@@ -52,6 +53,7 @@ module Status = struct
     | 0x9000 -> Ok
     | 0x917e -> Incorrect_length_for_ins
     | 0x9200 -> Memory_error
+    | 0x6a88 -> Referenced_data_not_found
     | v when v >= 0x63c0 && v <= 0x63cf -> Invalid_pin (v land 0x0f)
     | v when v >= 0x6f00 && v <= 0x6fff -> Technical_problem (v land 0xff)
     | v -> Unknown v
@@ -71,6 +73,7 @@ module Status = struct
     | Incorrect_params -> "Incorrect params"
     | Ins_not_supported -> "Instruction not supported"
     | Technical_problem i -> "Technical problem " ^ string_of_int i
+    | Referenced_data_not_found -> "Referenced data not found"
     | Ok -> "Ok"
     | Unknown i -> Printf.sprintf "Unknown status code 0x%x" i
     | t ->

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

@@ -20,6 +20,7 @@ module Status : sig
     | Incorrect_class
     | Ins_not_supported
     | Memory_error
+    | Referenced_data_not_found
     | Technical_problem of int
     | Ok