Client: add method prompt to context and cleanup Unix context

src/lib_client_base/client_context.ml

@@ -18,6 +18,11 @@ class type logger_sig = object
   method log : string -> ('a, unit) lwt_format -> 'a
 end
 
+class type prompter_sig = object
+  method prompt : ('a, string) lwt_format -> 'a
+  method prompt_password : ('a, string) lwt_format -> 'a
+end
+
 class logger log =
   let message =
     (fun x ->
@@ -48,17 +53,24 @@ class type block = object
 end
 
 class type logging_wallet = object
-  inherit logger
+  inherit logger_sig
+  inherit wallet
+end
+
+class type io_wallet = object
+  inherit logger_sig
+  inherit prompter_sig
   inherit wallet
 end
 
 class type logging_rpcs = object
-  inherit logger
+  inherit logger_sig
   inherit RPC_context.json
 end
 
 class type full_context = object
-  inherit logger
+  inherit logger_sig
+  inherit prompter_sig
   inherit wallet
   inherit RPC_context.json
   inherit block
@@ -84,4 +96,6 @@ class proxy_context (obj : full_context) = object
   method message : type a. (a, unit) lwt_format -> a = obj#message
   method warning : type a. (a, unit) lwt_format -> a  = obj#warning
   method write : type a. string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t = obj#write
+  method prompt : type a. (a, string) lwt_format -> a = obj#prompt
+  method prompt_password : type a. (a, string) lwt_format -> a = obj#prompt_password
 end

src/lib_client_base/client_context.mli

@@ -18,6 +18,11 @@ class type logger_sig = object
   method log : string -> ('a, unit) lwt_format -> 'a
 end
 
+class type prompter_sig = object
+  method prompt : ('a, string) lwt_format -> 'a
+  method prompt_password : ('a, string) lwt_format -> 'a
+end
+
 class logger : (string -> string -> unit Lwt.t) -> logger_sig
 
 class type wallet = object
@@ -34,6 +39,12 @@ class type logging_wallet = object
   inherit wallet
 end
 
+class type io_wallet = object
+  inherit logger_sig
+  inherit prompter_sig
+  inherit wallet
+end
+
 class type logging_rpcs = object
   inherit logger_sig
   inherit RPC_context.json
@@ -41,6 +52,7 @@ end
 
 class type full_context = object
   inherit logger_sig
+  inherit prompter_sig
   inherit wallet
   inherit RPC_context.json
   inherit block

src/lib_client_base_unix/client_context_unix.ml

@@ -9,10 +9,10 @@
 
 open Client_context
 
-class file_wallet dir : wallet = object (self)
+class unix_wallet ~base_dir : wallet = object (self)
   method private filename alias_name =
     Filename.concat
-      dir
+      base_dir
       (Str.(global_replace (regexp_string " ") "_" alias_name) ^ "s")
 
   method load : type a. string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
@@ -35,7 +35,7 @@ class file_wallet dir : wallet = object (self)
     fun alias_name list encoding ->
       Lwt.catch
         (fun () ->
-           Lwt_utils_unix.create_dir dir >>= fun () ->
+           Lwt_utils_unix.create_dir base_dir >>= fun () ->
            let filename = self#filename alias_name in
            let json = Data_encoding.Json.construct encoding list in
            Lwt_utils_unix.Json.write_file filename json)
@@ -43,50 +43,51 @@ class file_wallet dir : wallet = object (self)
       |> generic_trace "could not write the %s alias file." alias_name
 end
 
-(* Default config *)
+class unix_prompter = object
+  method prompt : type a. (a, string) lwt_format -> a =
+    Format.kasprintf begin fun msg ->
+      print_string msg ;
+      let line = read_line () in
+      Lwt.return line
+    end
 
-let (//) = Filename.concat
+  method prompt_password : type a. (a, string) lwt_format -> a =
+    Format.kasprintf begin fun msg ->
+      print_string msg ;
+      let line = Lwt_utils_unix.getpass () in
+      Lwt.return line
+    end
+end
 
-let home =
+class unix_logger ~base_dir =
-  try Sys.getenv "HOME"
-  with Not_found -> "/root"
-
-let default_base_dir = home // ".tezos-client"
-
-let default_block = `Prevalidation
-
-let default_log ~base_dir channel msg =
   let startup =
     CalendarLib.Printer.Precise_Calendar.sprint
       "%Y-%m-%dT%H:%M:%SZ"
       (CalendarLib.Calendar.Precise.now ()) in
-  match channel with
+  let log channel msg = match channel with
-  | "stdout" ->
+    | "stdout" ->
-      print_endline msg ;
+        print_endline msg ;
-      Lwt.return ()
+        Lwt.return ()
-  | "stderr" ->
+    | "stderr" ->
-      prerr_endline msg ;
+        prerr_endline msg ;
-      Lwt.return ()
+        Lwt.return ()
-  | log ->
+    | log ->
-      let (//) = Filename.concat in
+        let (//) = Filename.concat in
-      Lwt_utils_unix.create_dir (base_dir // "logs" // log) >>= fun () ->
+        Lwt_utils_unix.create_dir (base_dir // "logs" // log) >>= fun () ->
-      Lwt_io.with_file
+        Lwt_io.with_file
-        ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
+          ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
-        ~mode: Lwt_io.Output
+          ~mode: Lwt_io.Output
-        (base_dir // "logs" // log // startup)
+          (base_dir // "logs" // log // startup)
-        (fun chan -> Lwt_io.write chan msg)
+          (fun chan -> Lwt_io.write chan msg) in
-
-let make_context
-    ?(base_dir = default_base_dir)
-    ?(block = default_block)
-    ?(rpc_config = RPC_client.default_config)
-    log =
   object
     inherit Client_context.logger log
-    inherit file_wallet base_dir
+  end
+
+class unix_full_context ~base_dir ~block ~rpc_config : Client_context.full_context =
+  object
+    inherit unix_logger ~base_dir
+    inherit unix_prompter
+    inherit unix_wallet ~base_dir
     inherit RPC_client.http_ctxt rpc_config Media_type.all_media_types
     method block = block
   end
-
-let ignore_context =
-  make_context (fun _ _ -> Lwt.return ())

src/lib_client_base_unix/client_context_unix.mli

@@ -7,20 +7,16 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val make_context :
+class unix_wallet :
-  ?base_dir:string ->
+  base_dir:string ->
-  ?block:Block_services.block ->
+  Client_context.wallet
-  ?rpc_config:RPC_client.config ->
+class unix_prompter :
-  (string -> string -> unit Lwt.t) -> Client_context.full_context
+  Client_context.prompter_sig
-(** [make_context ?config log_fun] builds a context whose logging
+class unix_logger :
-    callbacks call [log_fun section msg], and whose [error] function
+  base_dir:string ->
-    fails with [Failure] and the given message. If not passed,
+  Client_context.logger_sig
-    [config] is {!default_cfg}. *)
+class unix_full_context :
-
+  base_dir:string ->
-val ignore_context : Client_context.full_context
+  block:Block_services.block ->
-(** [ignore_context] is a context whose logging callbacks do nothing,
+  rpc_config:RPC_client.config ->
-    and whose [error] function calls [Lwt.fail_with]. *)
+  Client_context.full_context
-
-val default_log : base_dir:string -> string -> string -> unit Lwt.t
-val default_base_dir : string
-val default_block : Block_services.block

src/lib_client_base_unix/client_main_run.ml

@@ -9,71 +9,7 @@
 
 (* Tezos Command line interface - Main Program *)
 
-open Client_context
+open Client_context_unix
-
-class file_wallet dir : wallet = object (self)
-  method private filename alias_name =
-    Filename.concat
-      dir
-      (Str.(global_replace (regexp_string " ") "_" alias_name) ^ "s")
-
-  method load : type a. string -> default:a -> a Data_encoding.encoding -> a tzresult Lwt.t =
-    fun alias_name ~default encoding ->
-      let filename = self#filename alias_name in
-      if not (Sys.file_exists filename) then
-        return default
-      else
-        Lwt_utils_unix.Json.read_file filename
-        |> generic_trace
-          "couldn't to read the %s file" alias_name >>=? fun json ->
-        match Data_encoding.Json.destruct encoding json with
-        | exception _ -> (* TODO print_error *)
-            failwith "didn't understand the %s file" alias_name
-        | data ->
-            return data
-
-  method write :
-    type a. string -> a -> a Data_encoding.encoding -> unit tzresult Lwt.t =
-    fun alias_name list encoding ->
-      Lwt.catch
-        (fun () ->
-           Lwt_utils_unix.create_dir dir >>= fun () ->
-           let filename = self#filename alias_name in
-           let json = Data_encoding.Json.construct encoding list in
-           Lwt_utils_unix.Json.write_file filename json)
-        (fun exn -> Lwt.return (error_exn exn))
-      |> generic_trace "could not write the %s alias file." alias_name
-end
-
-let default_log ~base_dir channel msg =
-  let startup =
-    CalendarLib.Printer.Precise_Calendar.sprint
-      "%Y-%m-%dT%H:%M:%SZ"
-      (CalendarLib.Calendar.Precise.now ()) in
-  match channel with
-  | "stdout" ->
-      print_endline msg ;
-      Lwt.return ()
-  | "stderr" ->
-      prerr_endline msg ;
-      Lwt.return ()
-  | log ->
-      let (//) = Filename.concat in
-      Lwt_utils_unix.create_dir (base_dir // "logs" // log) >>= fun () ->
-      Lwt_io.with_file
-        ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
-        ~mode: Lwt_io.Output
-        (base_dir // "logs" // log // startup)
-        (fun chan -> Lwt_io.write chan msg)
-
-
-let make_context block base_dir rpc_config =
-  object
-    inherit Client_context.logger (default_log ~base_dir)
-    inherit file_wallet base_dir
-    inherit RPC_client.http_ctxt rpc_config Media_type.all_media_types
-    method block = block
-  end
 
 let builtin_commands =
   let open Cli_entries in
@@ -111,10 +47,10 @@ let main select_commands =
                         (if Unix.isatty Unix.stderr then Ansi else Plain) Short) ;
   Lwt.catch begin fun () -> begin
       Client_config.parse_config_args
-        (make_context
+        (new unix_full_context
-           Client_config.default_block
+          ~block:Client_config.default_block
-           Client_config.default_base_dir
+          ~base_dir:Client_config.default_base_dir
-           RPC_client.default_config)
+          ~rpc_config:RPC_client.default_config)
         original_args
       >>=? fun (parsed_config_file, parsed_args, config_commands, remaining) ->
       let rpc_config : RPC_client.config = {
@@ -141,10 +77,10 @@ let main select_commands =
         else rpc_config
       in
       let client_config =
-        make_context
+        new unix_full_context
-          parsed_args.block
+          ~block:parsed_args.block
-          parsed_config_file.base_dir
+          ~base_dir:parsed_config_file.base_dir
-          rpc_config in
+          ~rpc_config:rpc_config in
       begin match autocomplete with
         | Some (prev_arg, cur_arg, script) ->
             Cli_entries.autocompletion

src/proto_alpha/lib_baking/test/proto_alpha_helpers.ml

@@ -28,7 +28,7 @@ let build_rpc_context config =
 let rpc_ctxt = ref (build_rpc_context !rpc_config)
 
 (* Context that does not write to alias files *)
-let no_write_context config block : #Client_context.full_context = object
+let no_write_context ?(block = `Prevalidation) config : #Client_context.full_context = object
   inherit RPC_client.http_ctxt config Media_type.all_media_types
   inherit Client_context.logger (fun _ _ -> Lwt.return_unit)
   method load : type a. string -> default:a -> a Data_encoding.encoding -> a Error_monad.tzresult Lwt.t =
@@ -38,6 +38,10 @@ let no_write_context config block : #Client_context.full_context = object
     a Data_encoding.encoding -> unit Error_monad.tzresult Lwt.t =
     fun _ _ _ -> return ()
   method block = block
+  method prompt : type a. (a, string) Client_context.lwt_format -> a =
+    Format.kasprintf (fun _ -> Lwt.return "")
+  method prompt_password : type a. (a, string) Client_context.lwt_format -> a =
+    Format.kasprintf (fun _ -> Lwt.return "")
 end
 
 let activate_alpha () =
@@ -46,7 +50,7 @@ let activate_alpha () =
       ~scheme:"unencrypted"
       ~location:"edsk31vznjHSSpGExDMHYASz45VZqXN4DPxvsa4hAyY8dHM28cZzp6" in
   Tezos_client_genesis.Client_proto_main.bake
-    !rpc_ctxt (`Head 0)
+    (no_write_context ~block:(`Head 0) !rpc_config) (`Head 0)
     (Activate  { protocol = Proto_alpha.hash ;
                  fitness })
     dictator_sk
@@ -172,7 +176,8 @@ module Account = struct
     let src_sk = Client_keys.Secret_key_locator.create
         ~scheme:"unencrypted"
         ~location:(Ed25519.Secret_key.to_b58check account.sk) in
-    Client_proto_context.transfer !rpc_ctxt
+    Client_proto_context.transfer
+      (new wrap_full_context (no_write_context !rpc_config ~block))
       block
       ~source:account.contract
       ~src_pk:account.pk
@@ -205,7 +210,7 @@ module Account = struct
       ?delegate
       ~fee
       block
-      !rpc_ctxt
+      (new wrap_full_context (no_write_context !rpc_config))
       ()
 
   let set_delegate
@@ -216,7 +221,7 @@ module Account = struct
       ~src_pk
       delegate_opt =
     Client_proto_context.set_delegate
-      !rpc_ctxt
+      (new wrap_full_context (no_write_context ~block !rpc_config))
       block
       ~fee
       contract
@@ -437,7 +442,7 @@ module Baking = struct
         ~scheme:"unencrypted"
         ~location:(Ed25519.Secret_key.to_b58check contract.sk) in
     Client_baking_forge.forge_block
-      !rpc_ctxt
+      (new wrap_full_context (no_write_context ~block !rpc_config))
       block
       ~operations
       ~force:true