Removes -force global argument

bin_client/main.ml

@@ -89,7 +89,6 @@ let main () =
         commands_for_version in
       let config : Client_commands.cfg = {
         base_dir = parsed_config_file.base_dir ;
-        force = parsed_args.force ;
         block = parsed_args.block ;
       } in
       let rpc_config =

lib_client_base/client_aliases.ml

@@ -26,6 +26,7 @@ end
 
 module type Alias = sig
   type t
+  type fresh_param
   val load :
     Client_commands.context ->
     (string * t) list tzresult Lwt.t
@@ -45,6 +46,7 @@ module type Alias = sig
     Client_commands.context ->
     string -> bool tzresult Lwt.t
   val add :
+    force:bool ->
     Client_commands.context ->
     string -> t -> unit tzresult Lwt.t
   val del :
@@ -71,7 +73,12 @@ module type Alias = sig
     ?name:string ->
     ?desc:string ->
     ('a, Client_commands.context, 'ret) Cli_entries.params ->
-    (string -> 'a, Client_commands.context, 'ret) Cli_entries.params
+    (fresh_param -> 'a, Client_commands.context, 'ret) Cli_entries.params
+  val of_fresh :
+    Client_commands.context ->
+    bool ->
+    fresh_param ->
+    string tzresult Lwt.t
   val source_param :
     ?name:string ->
     ?desc:string ->
@@ -152,11 +159,11 @@ module Alias = functor (Entity : Entity) -> struct
       (fun exn -> Lwt.return (error_exn exn))
     |> generic_trace "could not write the %s alias file." Entity.name
 
-  let add cctxt name value =
+  let add ~force cctxt name value =
     let keep = ref false in
     load cctxt >>=? fun list ->
     begin
-      if cctxt.config.force then
+      if force then
         return ()
       else
         iter_s (fun (n, v) ->
@@ -220,14 +227,11 @@ module Alias = functor (Entity : Entity) -> struct
            return (s, v)))
       next
 
-  let fresh_alias_param
+  type fresh_param = Fresh of string
-      ?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
+
-    param ~name ~desc
+  let of_fresh cctxt force (Fresh s) =
-      (parameter (fun cctxt s ->
-           begin
     load cctxt >>=? fun list ->
-             begin
+    begin if force then
-               if cctxt.config.force then
         return ()
       else
         iter_s
@@ -237,15 +241,19 @@ module Alias = functor (Entity : Entity) -> struct
                failwith
                  "@[<v 2>The %s alias %s already exists.@,\
                   The current value is %s.@,\
-                           Use -force true to update@]"
+                  Use -force to update@]"
                  Entity.name n
                  value
              else
                return ())
           list
-             end
     end >>=? fun () ->
-           return s))
+    return s
+
+  let fresh_alias_param
+      ?(name = "new") ?(desc = "new " ^ Entity.name ^ " alias") next =
+    param ~name ~desc
+      (parameter (fun _ s -> return @@ Fresh s))
       next
 
   let source_param ?(name = "src") ?(desc = "source " ^ Entity.name) next =

lib_client_base/client_aliases.mli

@@ -22,6 +22,7 @@ end
 
 module type Alias = sig
   type t
+  type fresh_param
   val load :
     Client_commands.context ->
     (string * t) list tzresult Lwt.t
@@ -41,6 +42,7 @@ module type Alias = sig
     Client_commands.context ->
     string -> bool tzresult Lwt.t
   val add :
+    force:bool ->
     Client_commands.context ->
     string -> t -> unit tzresult Lwt.t
   val del :
@@ -67,7 +69,12 @@ module type Alias = sig
     ?name:string ->
     ?desc:string ->
     ('a, Client_commands.context, 'ret) Cli_entries.params ->
-    (string -> 'a, Client_commands.context, 'ret) Cli_entries.params
+    (fresh_param -> 'a, Client_commands.context, 'ret) Cli_entries.params
+  val of_fresh :
+    Client_commands.context ->
+    bool ->
+    fresh_param ->
+    string tzresult Lwt.t
   val source_param :
     ?name:string ->
     ?desc:string ->

lib_client_base/client_commands.ml

@@ -12,7 +12,6 @@ type ('a, 'b) lwt_format =
 
 type cfg = {
   base_dir : string ;
-  force : bool ;
   block : Node_rpc_services.Blocks.block ;
 }
 
@@ -34,7 +33,6 @@ let (//) = Filename.concat
 
 let default_cfg_of_base_dir base_dir = {
   base_dir ;
-  force = false ;
   block = `Prevalidation ;
 }
 
@@ -93,3 +91,9 @@ let register name commands =
 let commands_for_version version =
   try Protocol_hash.Table.find versions version
   with Not_found -> raise Version_not_found
+
+let force_switch =
+  Cli_entries.switch
+    ~parameter:"-force"
+    ~doc:"Take an action that will overwrite data.\
+          This silences any warnings and some checks"

lib_client_base/client_commands.mli

@@ -12,7 +12,6 @@ type ('a, 'b) lwt_format =
 
 type cfg = {
   base_dir : string ;
-  force : bool ;
   block : Node_rpc_services.Blocks.block ;
 }
 
@@ -56,3 +55,7 @@ exception Version_not_found
 val register: Protocol_hash.t -> command list -> unit
 val commands_for_version: Protocol_hash.t -> command list
 val get_versions: unit -> (Protocol_hash.t * (command list)) list
+
+(** Have a command execute ignoring warnings.
+    This switch should be used when data will be overwritten. *)
+val force_switch : (bool, context) Cli_entries.arg

lib_client_base/client_config.ml

@@ -107,7 +107,6 @@ type cli_args = {
   protocol: Protocol_hash.t option ;
   print_timings: bool ;
   log_requests: bool ;
-  force: bool ;
 }
 
 let default_cli_args = {
@@ -115,7 +114,6 @@ let default_cli_args = {
   protocol = None ;
   print_timings = false ;
   log_requests = false ;
-  force = false ;
 }
 
 open Cli_entries
@@ -158,10 +156,6 @@ let timings_switch =
   switch
     ~parameter:"-timings"
     ~doc:"Show RPC request times if present."
-let force_switch =
-  switch
-    ~parameter:"-force"
-    ~doc:"Show less courtesy than the average user."
 let block_arg =
   default_arg
     ~parameter:"-block"
@@ -201,9 +195,8 @@ let tls_switch =
     ~doc:"Use TLS to connect to node."
 
 let global_options =
-  args10 base_dir_arg
+  args9 base_dir_arg
     config_file_arg
-    force_switch
     timings_switch
     block_arg
     protocol_arg
@@ -219,7 +212,6 @@ let parse_config_args (ctx : Client_commands.context) argv =
     argv >>|?
   fun ((base_dir,
         config_file,
-        force,
         timings,
         block,
         protocol,
@@ -278,4 +270,4 @@ let parse_config_args (ctx : Client_commands.context) argv =
   end ;
   Utils.mkdir config_dir ;
   if not (Sys.file_exists config_file) then Cfg_file.write config_file cfg ;
-  (cfg, { block ; print_timings = timings ; log_requests ; force ; protocol }, remaining)
+  (cfg, { block ; print_timings = timings ; log_requests ; protocol }, remaining)

lib_client_base/client_keys.ml

@@ -31,21 +31,21 @@ module Secret_key = Client_aliases.Alias (struct
     let name = "secret key"
   end)
 
-let gen_keys ?seed cctxt name =
+let gen_keys ?(force=false) ?seed cctxt name =
   let seed =
     match seed with
     | None -> Ed25519.Seed.generate ()
     | Some s -> s in
   let _, public_key, secret_key = Ed25519.generate_seeded_key seed in
-  Secret_key.add cctxt name secret_key >>=? fun () ->
+  Secret_key.add ~force cctxt name secret_key >>=? fun () ->
-  Public_key.add cctxt name public_key >>=? fun () ->
+  Public_key.add ~force cctxt name public_key >>=? fun () ->
-  Public_key_hash.add
+  Public_key_hash.add ~force
     cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () ->
   cctxt.message
     "I generated a brand new pair of keys under the name '%s'." name >>= fun () ->
   return ()
 
-let gen_keys_containing ?(prefix=false) ~containing ~name (cctxt : Client_commands.context) =
+let gen_keys_containing ?(prefix=false) ?(force=false) ~containing ~name (cctxt : Client_commands.context) =
   let unrepresentable =
     List.filter (fun s -> not @@ Base58.Alphabet.all_in_alphabet Base58.Alphabet.bitcoin s) containing in
   match unrepresentable with
@@ -59,7 +59,7 @@ let gen_keys_containing ?(prefix=false) ~containing ~name (cctxt : Client_comman
         unrepresentable >>= return
   | [] ->
       Public_key_hash.mem cctxt name >>=? fun name_exists ->
-      if name_exists && not cctxt.config.force
+      if name_exists && not force
       then
         cctxt.warning
           "Key for name '%s' already exists. Use -force to update." name >>= return
@@ -84,9 +84,9 @@ let gen_keys_containing ?(prefix=false) ~containing ~name (cctxt : Client_comman
             let hash = Ed25519.Public_key_hash.to_b58check @@ Ed25519.Public_key.hash public_key in
             if matches hash
             then
-              Secret_key.add cctxt name secret_key >>=? fun () ->
+              Secret_key.add ~force cctxt name secret_key >>=? fun () ->
-              Public_key.add cctxt name public_key >>=? fun () ->
+              Public_key.add ~force cctxt name public_key >>=? fun () ->
-              Public_key_hash.add cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () ->
+              Public_key_hash.add ~force cctxt name (Ed25519.Public_key.hash public_key) >>=? fun () ->
               return hash
             else begin if attempts mod 25_000 = 0
               then cctxt.message "Tried %d keys without finding a match" attempts
@@ -161,61 +161,56 @@ let commands () =
   [
 
     command ~group ~desc: "generate a pair of keys"
-      no_options
+      (args1 Client_commands.force_switch)
       (prefixes [ "gen" ; "keys" ]
        @@ Secret_key.fresh_alias_param
        @@ stop)
-      (fun () name cctxt -> gen_keys cctxt name) ;
+      (fun force name cctxt ->
+         Secret_key.of_fresh cctxt force name >>=? fun name ->
+         gen_keys ~force cctxt name) ;
 
     command ~group ~desc: "Generate keys including the given string"
-      (args1 (switch ~doc:"The key must begin with tz1[containing]" ~parameter:"-prefix"))
+      (args2 (switch ~doc:"The key must begin with tz1[containing]" ~parameter:"-prefix") force_switch)
       (prefixes [ "gen" ; "vanity" ; "keys" ]
        @@ Public_key_hash.fresh_alias_param
        @@ prefix "matching"
        @@ (seq_of_param @@ string ~name:"strs" ~desc:"String key must contain"))
-      (fun prefix name containing cctxt ->
+      (fun (prefix, force) name containing cctxt ->
-         gen_keys_containing ~prefix ~containing ~name cctxt) ;
+         Public_key_hash.of_fresh cctxt force name >>=? fun name ->
+         gen_keys_containing ~force ~prefix ~containing ~name cctxt) ;
 
     command ~group ~desc: "add a secret key to the wallet"
-      no_options
+      (args1 Client_commands.force_switch)
       (prefixes [ "add" ; "secret" ; "key" ]
        @@ Secret_key.fresh_alias_param
        @@ Secret_key.source_param
        @@ stop)
-      (fun () name sk cctxt ->
+      (fun force name sk cctxt ->
+         Secret_key.of_fresh cctxt force name >>=? fun name ->
          Public_key.find_opt cctxt name >>=? function
          | None ->
              let pk = Ed25519.Secret_key.to_public_key sk in
-             Public_key_hash.add cctxt
+             Public_key_hash.add ~force cctxt
                name (Ed25519.Public_key.hash pk) >>=? fun () ->
-             Public_key.add cctxt name pk >>=? fun () ->
+             Public_key.add ~force cctxt name pk >>=? fun () ->
-             Secret_key.add cctxt name sk
+             Secret_key.add ~force cctxt name sk
          | Some pk ->
              fail_unless
-               (check_keys_consistency pk sk || cctxt.config.force)
+               (check_keys_consistency pk sk || force)
                (failure
                   "public and secret keys '%s' don't correspond, \
                    please don't use -force" name) >>=? fun () ->
-             Secret_key.add cctxt name sk) ;
+             Secret_key.add ~force cctxt name sk) ;
 
     command ~group ~desc: "add a public key to the wallet"
-      no_options
+      (args1 Client_commands.force_switch)
-      (prefixes [ "add" ; "public" ; "key" ]
-       @@ Public_key.fresh_alias_param
-       @@ Public_key.source_param
-       @@ stop)
-      (fun () name key cctxt ->
-         Public_key_hash.add cctxt
-           name (Ed25519.Public_key.hash key) >>=? fun () ->
-         Public_key.add cctxt name key) ;
-
-    command ~group ~desc: "add an ID a public key hash to the wallet"
-      no_options
       (prefixes [ "add" ; "identity" ]
        @@ Public_key_hash.fresh_alias_param
        @@ Public_key_hash.source_param
        @@ stop)
-      (fun () name hash cctxt -> Public_key_hash.add cctxt name hash) ;
+      (fun force name hash cctxt ->
+         Public_key_hash.of_fresh cctxt force name >>=? fun name ->
+         Public_key_hash.add ~force cctxt name hash) ;
 
     command ~group ~desc: "list all public key hashes and associated keys"
       no_options
@@ -258,11 +253,11 @@ let commands () =
                  else return ()) ;
 
     command ~group ~desc: "forget all keys"
-      no_options
+      (args1 Client_commands.force_switch)
       (fixed [ "forget" ; "all" ; "keys" ])
-      (fun () cctxt ->
+      (fun force cctxt ->
-         fail_unless cctxt.config.force
+         fail_unless force
-           (failure "this can only used with option -force") >>=? fun () ->
+           (failure "this can only used with option -force true") >>=? fun () ->
          Public_key.save cctxt [] >>=? fun () ->
          Secret_key.save cctxt [] >>=? fun () ->
          Public_key_hash.save cctxt []) ;

lib_client_base/client_keys.mli

@@ -26,6 +26,7 @@ val list_keys:
   (string * Public_key_hash.t * bool * bool) list tzresult Lwt.t
 
 val gen_keys:
+  ?force:bool ->
   ?seed: Ed25519.Seed.t ->
   Client_commands.context ->
   string ->

lib_embedded_client_alpha/client_proto_context.ml

@@ -194,10 +194,10 @@ let message_injection cctxt ~force ?(contracts = []) oph =
 let message_added_contract cctxt name =
   cctxt.message "Contract memorized as %s." name
 
-let check_contract cctxt neu =
+let check_contract cctxt new_contract =
-  RawContractAlias.mem cctxt neu >>=? function
+  RawContractAlias.mem cctxt new_contract >>=? function
   | true ->
-      failwith "contract '%s' already exists" neu
+      failwith "contract '%s' already exists" new_contract
   | false ->
       return ()
 
@@ -323,7 +323,7 @@ let commands () =
        @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
        @@ prefix "to"
        @@ Public_key_hash.alias_param
-         ~name: "mgr" ~desc: "new delegate of the contract"
+         ~name: "mgr" ~desc: "New delegate of the contract"
        @@ stop)
       begin fun (fee, force) (_, contract) (_, delegate) cctxt ->
         get_manager cctxt contract >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
@@ -351,8 +351,9 @@ let commands () =
          ~name:"src" ~desc: "name of the source contract"
        @@ stop)
       begin fun (fee, delegate, delegatable, force)
-        neu (_, manager) balance (_, source) cctxt ->
+        new_contract (_, manager) balance (_, source) cctxt ->
-        check_contract cctxt neu >>=? fun () ->
+        RawContractAlias.of_fresh cctxt force new_contract >>=? fun new_contract ->
+        check_contract cctxt new_contract >>=? fun () ->
         get_delegate_pkh cctxt delegate >>=? fun delegate ->
         get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
         originate_account cctxt.rpc_config cctxt.config.block ~force:force
@@ -361,8 +362,8 @@ let commands () =
           () >>=? fun (oph, contract) ->
         message_injection cctxt
           ~force:force ~contracts:[contract] oph >>= fun () ->
-        RawContractAlias.add cctxt neu contract >>=? fun () ->
+        RawContractAlias.add ~force cctxt new_contract contract >>=? fun () ->
-        message_added_contract cctxt neu >>= fun () ->
+        message_added_contract cctxt new_contract >>= fun () ->
         return ()
       end ;
 
@@ -388,9 +389,10 @@ let commands () =
                              combine with -init if the storage type is not unit"
        @@ stop)
       begin fun (fee, delegate, force, delegatable, spendable, init, no_print_source)
-        neu (_, manager) balance (_, source) program cctxt ->
+        new_contract (_, manager) balance (_, source) program cctxt ->
+        RawContractAlias.of_fresh cctxt force new_contract >>=? fun new_contract ->
+        check_contract cctxt new_contract >>=? fun () ->
         Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun { expanded = code } ->
-        check_contract cctxt neu >>=? fun () ->
         get_delegate_pkh cctxt delegate >>=? fun delegate ->
         get_manager cctxt source >>=? fun (_src_name, _src_pkh, src_pk, src_sk) ->
         originate_contract cctxt.rpc_config cctxt.config.block ~force:force
@@ -409,8 +411,8 @@ let commands () =
         | Ok (oph, contract) ->
             message_injection cctxt
               ~force:force ~contracts:[contract] oph >>= fun () ->
-            RawContractAlias.add cctxt neu contract >>=? fun () ->
+            RawContractAlias.add ~force cctxt new_contract contract >>=? fun () ->
-            message_added_contract cctxt neu >>= fun () ->
+            message_added_contract cctxt new_contract >>= fun () ->
             return ()
       end ;
 
@@ -423,14 +425,15 @@ let commands () =
        @@ Public_key_hash.alias_param
          ~name: "mgr" ~desc: "manager of the new contract"
        @@ stop)
-      begin fun force neu (_, manager) cctxt ->
+      begin fun force new_contract (_, manager) cctxt ->
-        check_contract cctxt neu >>=? fun () ->
+        RawContractAlias.of_fresh cctxt force new_contract >>=? fun new_contract ->
+        check_contract cctxt new_contract >>=? fun () ->
         faucet cctxt.rpc_config cctxt.config.block
           ~force:force ~manager_pkh:manager () >>=? fun (oph, contract) ->
         message_injection cctxt
           ~force:force ~contracts:[contract] oph >>= fun () ->
-        RawContractAlias.add cctxt neu contract >>=? fun () ->
+        RawContractAlias.add ~force cctxt new_contract contract >>=? fun () ->
-        message_added_contract cctxt neu >>= fun () ->
+        message_added_contract cctxt new_contract >>= fun () ->
         return ()
       end;
 

lib_embedded_client_alpha/client_proto_contracts.ml

@@ -177,13 +177,14 @@ let commands  () =
   [
 
     command ~group ~desc: "add a contract to the wallet"
-      no_options
+      (args1 Client_commands.force_switch)
       (prefixes [ "remember" ; "contract" ]
        @@ RawContractAlias.fresh_alias_param
        @@ RawContractAlias.source_param
        @@ stop)
-      (fun () name hash cctxt ->
+      (fun force name hash cctxt ->
-         RawContractAlias.add cctxt name hash) ;
+         RawContractAlias.of_fresh cctxt force name >>=? fun name ->
+         RawContractAlias.add ~force cctxt name hash) ;
 
     command ~group ~desc: "remove a contract from the wallet"
       no_options
@@ -205,11 +206,11 @@ let commands  () =
            contracts) ;
 
     command ~group ~desc: "forget all known contracts"
-      no_options
+      (args1 Client_commands.force_switch)
       (fixed [ "forget" ; "all" ; "contracts" ])
-      (fun () cctxt ->
+      (fun force cctxt ->
          fail_unless
-           cctxt.config.force
+           force
            (failure "this can only used with option -force true") >>=? fun () ->
          RawContractAlias.save cctxt []) ;
 

lib_embedded_client_alpha/client_proto_programs.ml

@@ -62,14 +62,15 @@ let commands () =
          return ()) ;
 
     command ~group ~desc: "remember a program under some name"
-      no_options
+      (args1 Client_commands.force_switch)
       (prefixes [ "remember" ; "program" ]
        @@ Program.fresh_alias_param
        @@ Program.source_param
        @@ stop)
-      (fun () name program cctxt ->
+      (fun force name program cctxt ->
+         Program.of_fresh cctxt force name >>=? fun name ->
          Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
-         Program.add cctxt name (program, [])) ;
+         Program.add ~force cctxt name (program, [])) ;
 
     command ~group ~desc: "forget a remembered program"
       no_options