Client: add a context to command evaluation.

src/Makefile

@@ -383,7 +383,7 @@ clean::
 ############################################################################
 
 CLIENT_LIB_INTFS := \
-  client/client_version.mli \
+  client/client_commands.mli \
   client/client_node_rpcs.mli \
   client/client_generic_rpcs.mli \
   client/client_helpers.mli \
@@ -392,7 +392,7 @@ CLIENT_LIB_INTFS := \
   client/client_protocols.mli \
 
 CLIENT_LIB_IMPLS := \
-  client/client_version.ml \
+  client/client_commands.ml \
   client/client_config.ml \
   client/client_node_rpcs.ml \
   client/client_generic_rpcs.ml \

src/client/client_aliases.ml

@@ -15,36 +15,62 @@ open Cli_entries
 module type Entity = sig
   type t
   val encoding : t Data_encoding.t
-  val of_source : string -> t Lwt.t
-  val to_source : t -> string Lwt.t
+  val of_source :
+    Client_commands.context ->
+    string -> t Lwt.t
+  val to_source :
+    Client_commands.context ->
+    t -> string Lwt.t
   val name : string
 end
 
 module type Alias = sig
   type t
-  val load : unit -> (Lwt_io.file_name * t) list Lwt.t
-  val find : Lwt_io.file_name -> t Lwt.t
-  val find_opt : Lwt_io.file_name -> t option Lwt.t
-  val rev_find : t -> Lwt_io.file_name option Lwt.t
-  val name : t -> string Lwt.t
-  val mem : Lwt_io.file_name -> bool Lwt.t
-  val add : Lwt_io.file_name -> t -> unit Lwt.t
-  val del : Lwt_io.file_name -> unit Lwt.t
-  val save : (Lwt_io.file_name * t) list -> unit Lwt.t
-  val to_source : t -> string Lwt.t
+  val load :
+    Client_commands.context ->
+    (string * t) list Lwt.t
+  val find :
+    Client_commands.context ->
+    string -> t Lwt.t
+  val find_opt :
+    Client_commands.context ->
+    string -> t option Lwt.t
+  val rev_find :
+    Client_commands.context ->
+    t -> string option Lwt.t
+  val name :
+    Client_commands.context ->
+    t -> string Lwt.t
+  val mem :
+    Client_commands.context ->
+    string -> bool Lwt.t
+  val add :
+    Client_commands.context ->
+    string -> t -> unit Lwt.t
+  val del :
+    Client_commands.context ->
+    string -> unit Lwt.t
+  val save :
+    Client_commands.context ->
+    (string * t) list -> unit Lwt.t
+  val to_source :
+    Client_commands.context ->
+    t -> string Lwt.t
   val alias_param :
     ?name:string ->
     ?desc:string ->
-    'a Cli_entries.params ->
-    (Lwt_io.file_name * t -> 'a) Cli_entries.params
+    ('a, Client_commands.context, 'ret) Cli_entries.params ->
+    (string * t -> 'a, Client_commands.context, 'ret) Cli_entries.params
   val fresh_alias_param :
     ?name:string ->
     ?desc:string ->
-    'a Cli_entries.params -> (string -> 'a) Cli_entries.params
+    ('a, Client_commands.context, 'ret) Cli_entries.params ->
+    (string -> 'a, Client_commands.context, 'ret) Cli_entries.params
   val source_param :
     ?name:string ->
     ?desc:string ->
-    'a Cli_entries.params -> (t -> 'a) Cli_entries.params
+    ('a, Client_commands.context, 'ret) Cli_entries.params ->
+    (t -> 'a, Client_commands.context, 'ret) Cli_entries.params
 end
 
 module Alias = functor (Entity : Entity) -> struct
@@ -58,43 +84,46 @@ module Alias = functor (Entity : Entity) -> struct
   let filename () =
     Client_config.(base_dir#get // Entity.name ^ "s")
 
-  let load () =
+  let load cctxt =
     let filename = filename () in
     if not (Sys.file_exists filename) then return [] else
       Data_encoding_ezjsonm.read_file filename >>= function
       | None ->
-          error "couldn't to read the %s alias file" Entity.name
+          cctxt.Client_commands.error
+            "couldn't to read the %s alias file" Entity.name
       | Some json ->
           match Data_encoding.Json.destruct encoding json with
           | exception _ -> (* TODO print_error *)
-              error "didn't understand the %s alias file" Entity.name
+              cctxt.Client_commands.error
+                "didn't understand the %s alias file" Entity.name
           | list ->
               return list
 
-  let find_opt name =
-    load () >>= fun list ->
+  let find_opt cctxt name =
+    load cctxt >>= fun list ->
     try return (Some (List.assoc name list))
     with Not_found -> return None
 
-  let find name =
-    load () >>= fun list ->
+  let find cctxt name =
+    load cctxt >>= fun list ->
     try return (List.assoc name list)
-    with Not_found -> error "no %s alias named %s" Entity.name name
+    with Not_found ->
+      cctxt.Client_commands.error "no %s alias named %s" Entity.name name
 
-  let rev_find v =
-    load () >>= fun list ->
+  let rev_find cctxt v =
+    load cctxt >>= fun list ->
     try return (Some (List.find (fun (_, v') -> v = v') list |> fst))
     with Not_found -> return None
 
-  let mem name =
-    load () >>= fun list ->
+  let mem cctxt name =
+    load cctxt >>= fun list ->
     try
       ignore (List.assoc name list) ;
       Lwt.return true
     with
     | Not_found -> Lwt.return false
 
-  let save list =
+  let save cctxt list =
     catch
       (fun () ->
          let dirname = Client_config.base_dir#get in
@@ -106,21 +135,25 @@ module Alias = functor (Entity : Entity) -> struct
          | false -> fail (Failure "Json.write_file")
          | true -> return ())
       (fun exn ->
-         error "could not write the %s alias file: %s."
+         cctxt.Client_commands.error
+           "could not write the %s alias file: %s."
            Entity.name (Printexc.to_string exn))
 
-  let add name value =
+  let add cctxt name value =
     let keep = ref false in
-    load () >>= fun list ->
+    load cctxt >>= fun list ->
     (if not Client_config.force#get then
        Lwt_list.iter_s (fun (n, v) ->
            if n = name && v = value then
              (keep := true ;
-              message "The %s alias %s already exists with the same value." Entity.name n)
+              cctxt.Client_commands.message
+                "The %s alias %s already exists with the same value." Entity.name n)
            else if n = name && v <> value then
-             error "another %s is already aliased as %s, use -force true to update" Entity.name n
+             cctxt.Client_commands.error
+               "another %s is already aliased as %s, use -force true to update" Entity.name n
            else if n <> name && v = value then
-             error "this %s is already aliased as %s, use -force true to insert duplicate" Entity.name n
+             cctxt.Client_commands.error
+               "this %s is already aliased as %s, use -force true to insert duplicate" Entity.name n
            else return ())
          list else return ()) >>= fun () ->
     let list = List.filter (fun (n, _) -> n <> name) list in
@@ -128,33 +161,36 @@ module Alias = functor (Entity : Entity) -> struct
     if !keep then
       return ()
     else
-      save list >>= fun () ->
-      message "New %s alias '%s' saved." Entity.name name
+      save cctxt list >>= fun () ->
+      cctxt.Client_commands.message
+        "New %s alias '%s' saved." Entity.name name
 
-  let del name =
-    load () >>= fun list ->
+  let del cctxt name =
+    load cctxt >>= fun list ->
     let list = List.filter (fun (n, _) -> n <> name) list in
-    save list
+    save cctxt list
 
-  let save list =
-    save list >>= fun () ->
-    message "Successful update of the %s alias file." Entity.name
+  let save cctxt list =
+    save cctxt  list >>= fun () ->
+    cctxt.Client_commands.message
+      "Successful update of the %s alias file." Entity.name
 
   include Entity
 
   let alias_param ?(name = "name") ?(desc = "existing " ^ name ^ " alias") next =
     param ~name ~desc
-      (fun s -> find s >>= fun v -> return (s, v))
+      (fun cctxt s -> find cctxt s >>= fun v -> return (s, v))
       next
 
   let fresh_alias_param ?(name = "new") ?(desc = "new " ^ name ^ " alias") next =
     param ~name ~desc
-      (fun s ->
-         load () >>= fun list ->
+      (fun cctxt s ->
+         load cctxt >>= fun list ->
          if not Client_config.force#get then
            Lwt_list.iter_s (fun (n, _v) ->
                if n = name then
-                 error "the %s alias %s already exists, use -force true to update" Entity.name n
+                 cctxt.Client_commands.error
+                   "the %s alias %s already exists, use -force true to update" Entity.name n
                else return ())
              list >>= fun () ->
            return s
@@ -167,31 +203,31 @@ module Alias = functor (Entity : Entity) -> struct
       ^ "can be an alias, file or literal (autodetected in this order)\n\
          use 'file:path', 'text:literal' or 'alias:name' to force" in
     param ~name ~desc
-      (fun s ->
+      (fun cctxt s ->
          let read path =
            catch
              (fun () -> Lwt_io.(with_file ~mode:Input path read))
              (fun exn -> Lwt.fail_with @@ Format.asprintf "cannot read file (%s)" (Printexc.to_string exn))
-           >>= of_source in
+           >>= of_source cctxt in
          match Utils.split ~limit:1 ':' s with
          | [ "alias" ; alias ]->
-             find alias
+             find cctxt alias
          | [ "text" ; text ] ->
-             of_source text
+             of_source cctxt text
          | [ "file" ; path ] ->
              read path
          | _ ->
              catch
-               (fun () -> find s)
+               (fun () -> find cctxt s)
                (fun _ ->
                   catch
                     (fun () -> read s)
-                    (fun _ -> of_source s)))
+                    (fun _ -> of_source cctxt s)))
       next
 
-   let name d =
-     rev_find d >>= function
-     | None -> Entity.to_source d
+   let name cctxt d =
+     rev_find cctxt d >>= function
+     | None -> Entity.to_source cctxt d
      | Some name -> Lwt.return name
 
 end

src/client/client_aliases.mli

@@ -11,35 +11,61 @@
 module type Entity = sig
   type t
   val encoding : t Data_encoding.t
-  val of_source : string -> t Lwt.t
-  val to_source : t -> string Lwt.t
+  val of_source :
+    Client_commands.context ->
+    string -> t Lwt.t
+  val to_source :
+    Client_commands.context ->
+    t -> string Lwt.t
   val name : string
 end
 
 module type Alias = sig
   type t
-  val load : unit -> (Lwt_io.file_name * t) list Lwt.t
-  val find : Lwt_io.file_name -> t Lwt.t
-  val find_opt : Lwt_io.file_name -> t option Lwt.t
-  val rev_find : t -> Lwt_io.file_name option Lwt.t
-  val name : t -> string Lwt.t
-  val mem : Lwt_io.file_name -> bool Lwt.t
-  val add : Lwt_io.file_name -> t -> unit Lwt.t
-  val del : Lwt_io.file_name -> unit Lwt.t
-  val save : (Lwt_io.file_name * t) list -> unit Lwt.t
-  val to_source : t -> string Lwt.t
+  val load :
+    Client_commands.context ->
+    (string * t) list Lwt.t
+  val find :
+    Client_commands.context ->
+    string -> t Lwt.t
+  val find_opt :
+    Client_commands.context ->
+    string -> t option Lwt.t
+  val rev_find :
+    Client_commands.context ->
+    t -> string option Lwt.t
+  val name :
+    Client_commands.context ->
+    t -> string Lwt.t
+  val mem :
+    Client_commands.context ->
+    string -> bool Lwt.t
+  val add :
+    Client_commands.context ->
+    string -> t -> unit Lwt.t
+  val del :
+    Client_commands.context ->
+    string -> unit Lwt.t
+  val save :
+    Client_commands.context ->
+    (string * t) list -> unit Lwt.t
+  val to_source  :
+    Client_commands.context ->
+    t -> string Lwt.t
   val alias_param :
     ?name:string ->
     ?desc:string ->
-    'a Cli_entries.params ->
-    (Lwt_io.file_name * t -> 'a) Cli_entries.params
+    ('a, Client_commands.context, 'ret) Cli_entries.params ->
+    (string * t -> 'a, Client_commands.context, 'ret) Cli_entries.params
   val fresh_alias_param :
     ?name:string ->
     ?desc:string ->
-    'a Cli_entries.params -> (string -> 'a) Cli_entries.params
+    ('a, Client_commands.context, 'ret) Cli_entries.params ->
+    (string -> 'a, Client_commands.context, 'ret) Cli_entries.params
   val source_param :
     ?name:string ->
     ?desc:string ->
-    'a Cli_entries.params -> (t -> 'a) Cli_entries.params
+    ('a, Client_commands.context, 'ret) Cli_entries.params ->
+    (t -> 'a, Client_commands.context, 'ret) Cli_entries.params
 end
 module Alias (Entity : Entity) : Alias with type t = Entity.t

src/client/client_commands.ml

@@ -7,8 +7,42 @@
 (*                                                                        *)
 (**************************************************************************)
 
+type ('a, 'b) lwt_format =
+  ('a, Format.formatter, unit, 'b Lwt.t) format4
 
-(* A global store for version indexed commands. *)
+type context =
+  { error : 'a 'b. ('a, 'b) lwt_format -> 'a ;
+    warning : 'a. ('a, unit) lwt_format -> 'a ;
+    message : 'a. ('a, unit) lwt_format -> 'a ;
+    answer : 'a. ('a, unit) lwt_format -> 'a ;
+    log : 'a. string -> ('a, unit) lwt_format -> 'a }
+
+type command = (context, unit) Cli_entries.command
+
+let make_context log =
+  let error fmt =
+    Format.kasprintf
+      (fun msg ->
+         Lwt.fail (Failure msg))
+      fmt in
+  let warning fmt =
+    Format.kasprintf
+      (fun msg -> log "stderr" msg)
+      fmt in
+  let message fmt =
+    Format.kasprintf
+      (fun msg -> log "stdout" msg)
+      fmt in
+  let answer =
+    message in
+  let log name fmt =
+    Format.kasprintf
+      (fun msg -> log name msg)
+      fmt in
+  { error ; warning ; message ; answer ; log }
+
+let ignore_context =
+  make_context (fun _ _ -> Lwt.return ())
 
 exception Version_not_found
 

src/client/client_commands.mli

@@ -7,7 +7,21 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Cli_entries
+type ('a, 'b) lwt_format =
+  ('a, Format.formatter, unit, 'b Lwt.t) format4
+
+type context =
+  { error : 'a 'b. ('a, 'b) lwt_format -> 'a ;
+    warning : 'a. ('a, unit) lwt_format -> 'a ;
+    message : 'a. ('a, unit) lwt_format -> 'a ;
+    answer : 'a. ('a, unit) lwt_format -> 'a ;
+    log : 'a. string -> ('a, unit) lwt_format -> 'a }
+
+val make_context : (string -> string -> unit Lwt.t) -> context
+
+val ignore_context : context
+
+type command = (context, unit) Cli_entries.command
 
 exception Version_not_found
 

src/client/client_config.ml

@@ -102,7 +102,7 @@ let register_config_option version option =
 
 (* Entry point *)
 
-let parse_args ?version usage dispatcher argv =
+let parse_args ?version usage dispatcher argv cctxt =
   let open Lwt in
   catch
     (fun () ->
@@ -129,7 +129,7 @@ let parse_args ?version usage dispatcher argv =
                ~current:(ref 0) argv args (anon dispatch) "\000" ;
              Lwt.return ()
            with Sys_error msg ->
-             Cli_entries.error
+             cctxt.Client_commands.error
                "Error: can't read the configuration file: %s\n%!" msg
          end else begin
           try
@@ -140,7 +140,7 @@ let parse_args ?version usage dispatcher argv =
             file_group#write config_file#get ;
             Lwt.return ()
           with Sys_error msg ->
-            Cli_entries.warning
+            cctxt.Client_commands.warning
               "Warning: can't create the default configuration file: %s\n%!" msg
         end) >>= fun () ->
        begin match dispatch `End with
@@ -171,7 +171,7 @@ let preparse name argv =
     None
   with Found s -> Some s
 
-let preparse_args argv : Node_rpc_services.Blocks.block Lwt.t =
+let preparse_args argv cctxt : Node_rpc_services.Blocks.block Lwt.t =
   begin
     match preparse "-base-dir" argv with
     | None -> ()
@@ -187,7 +187,7 @@ let preparse_args argv : Node_rpc_services.Blocks.block Lwt.t =
       (file_group#read config_file#get ;
       Lwt.return ())
     with Sys_error msg ->
-      Cli_entries.error
+      cctxt.Client_commands.error
         "Error: can't read the configuration file: %s\n%!" msg
     else Lwt.return ()
   end >>= fun () ->
@@ -204,7 +204,7 @@ let preparse_args argv : Node_rpc_services.Blocks.block Lwt.t =
           incoming_port#set (int_of_string port) ;
           Lwt.return ()
         with _ ->
-          Cli_entries.error
+          cctxt.Client_commands.error
             "Error: can't parse the -port option: %S.\n%!" port
   end >>= fun () ->
   match preparse "-block" Sys.argv with
@@ -212,6 +212,6 @@ let preparse_args argv : Node_rpc_services.Blocks.block Lwt.t =
   | Some x ->
       match Node_rpc_services.Blocks.parse_block x with
       | Error _ ->
-          Cli_entries.error
+          cctxt.Client_commands.error
             "Error: can't parse the -block option: %S.\n%!" x
       | Ok b -> Lwt.return b

src/client/client_generic_rpcs.ml

@@ -192,9 +192,9 @@ let rec count =
 
 (*-- Commands ---------------------------------------------------------------*)
 
-let list url () =
+let list url cctxt =
   let args = Utils.split '/' url in
-  Client_node_rpcs.describe ~recurse:true args >>= fun tree ->
+  Client_node_rpcs.describe cctxt ~recurse:true args >>= fun tree ->
   let open RPC.Description in
   let collected_args = ref [] in
   let collect arg =
@@ -272,24 +272,24 @@ let list url () =
     Format.pp_print_list
       (fun ppf (n,t) -> display ppf ([ n ], tpath @ [ n ], t))
   in
-  Cli_entries.message "@ @[<v 2>Available services:@ @ %a@]@."
+  cctxt.message "@ @[<v 2>Available services:@ @ %a@]@."
     display (args, args, tree) >>= fun () ->
   if !collected_args <> [] then
-    Cli_entries.message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
+    cctxt.message "@,@[<v 2>Dynamic parameter description:@ @ %a@]@."
       (Format.pp_print_list display_arg) !collected_args
   else Lwt.return ()
 
 
-let schema url () =
+let schema url cctxt =
   let args = Utils.split '/' url in
   let open RPC.Description in
-  Client_node_rpcs.describe ~recurse:false args >>= function
+  Client_node_rpcs.describe cctxt ~recurse:false args >>= function
   | Static { service = Some { input ; output } } ->
-      Cli_entries.message "Input schema:\n%s\nOutput schema:\n%s\n%!"
+      cctxt.message "Input schema:\n%s\nOutput schema:\n%s\n%!"
         (Data_encoding_ezjsonm.to_string (Json_schema.to_json input))
         (Data_encoding_ezjsonm.to_string (Json_schema.to_json output))
   | _ ->
-      Cli_entries.message
+      cctxt.message
         "No service found at this URL (but this is a valid prefix)\n%!"
 
 let fill_in schema =
@@ -299,60 +299,43 @@ let fill_in schema =
   | Any | Object { properties = [] } -> Lwt.return (Ok (`O []))
   | _ -> editor_fill_in schema
 
-let call url () =
+let call url cctxt =
   let args = Utils.split '/' url in
   let open RPC.Description in
-  Client_node_rpcs.describe ~recurse:false args >>= function
+  Client_node_rpcs.describe cctxt ~recurse:false args >>= function
   | Static { service = Some { input } } -> begin
       fill_in input >>= function
       | Error msg ->
-          error "%s" msg
+          cctxt.error "%s" msg
       | Ok json ->
-          Client_node_rpcs.get_json args json >>= fun json ->
-          Cli_entries.message "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json)
+          Client_node_rpcs.get_json cctxt args json >>= fun json ->
+          cctxt.message "Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json)
     end
   | _ ->
-      Cli_entries.message
+      cctxt.message
         "No service found at this URL (but this is a valid prefix)\n%!"
 
-let () =
-  let open Cli_entries in
-  register_tag "low-level" "low level commands for advanced users" ;
-  register_tag "local" "commands that do not require a running node" ;
-  register_tag "debug" "commands mostly useful for debugging" ;
-  register_group "rpc" "Commands for the low level RPC layer"
+let group =
+  { Cli_entries.name = "rpc" ;
+    title = "Commands for the low level RPC layer" }
 
-let commands = Cli_entries.([
-    command
-      ~tags: [ "local" ]
-      ~desc: "list all understood protocol versions"
+let commands = [
+  command ~desc: "list all understood protocol versions"
     (fixed [ "list" ; "versions" ])
-      (fun () ->
+    (fun cctxt ->
        Lwt_list.iter_s
-           (fun (ver, _) -> message "%a" Protocol_hash.pp_short ver)
-           (Client_version.get_versions ())) ;
-    command
-      ~tags: [ "low-level" ; "local" ]
-      ~group: "rpc"
-      ~desc: "list available RPCs (low level command for advanced users)"
+         (fun (ver, _) -> cctxt.Client_commands.message "%a" Protocol_hash.pp_short ver)
+         (Client_commands.get_versions ())) ;
+  command ~group ~desc: "list available RPCs (low level command for advanced users)"
     (prefixes [ "rpc" ; "list" ] @@ stop)
     (list "/");
-    command
-      ~tags: [ "low-level" ; "local" ]
-      ~group: "rpc"
-      ~desc: "list available RPCs (low level command for advanced users)"
-      (prefixes [ "rpc" ; "list" ] @@ string "url" "the RPC's prefix to be described" @@ stop)
+  command ~group ~desc: "list available RPCs (low level command for advanced users)"
+    (prefixes [ "rpc" ; "list" ] @@ string ~name:"url" ~desc: "the RPC's prefix to be described" @@ stop)
     list ;
-    command
-      ~tags: [ "low-level" ; "local" ]
-      ~group: "rpc"
-      ~desc: "get the schemas of an RPC"
-      (prefixes [ "rpc" ; "schema" ] @@ string "url" "the RPC's URL" @@ stop)
+  command ~group ~desc: "get the schemas of an RPC"
+    (prefixes [ "rpc" ; "schema" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop)
     schema ;
-    command
-      ~tags: [ "low-level" ; "local" ]
-      ~group: "rpc"
-      ~desc: "call an RPC (low level command for advanced users)"
-      (prefixes [ "rpc" ; "call" ] @@ string "url" "the RPC's URL" @@ stop)
+  command ~group ~desc: "call an RPC (low level command for advanced users)"
+    (prefixes [ "rpc" ; "call" ] @@ string ~name: "url" ~desc: "the RPC's URL" @@ stop)
     call
-  ])
+]

src/client/client_generic_rpcs.mli

@@ -7,4 +7,4 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val commands: Cli_entries.command list
+val commands: Client_commands.command list

src/client/client_helpers.ml

@@ -9,10 +9,6 @@
 
 open Client_config
 
-let () =
-  let open Cli_entries in
-  register_group "helpers" "Various helpers"
-
 let unique = ref false
 let unique_arg =
   "-unique",
@@ -26,9 +22,13 @@ let commands () = Cli_entries.[
               works only for blocks, operations, public key and contract \
               identifiers."
       ~args: [unique_arg]
-      (prefixes [ "complete" ] @@ string "prefix" "the prefix of the Base48Check-encoded hash to be completed" @@ stop)
-      (fun prefix () ->
-         Client_node_rpcs.complete ~block:(block ()) prefix >>= fun completions ->
+      (prefixes [ "complete" ] @@
+       string
+         ~name: "prefix"
+         ~desc: "the prefix of the Base48Check-encoded hash to be completed" @@
+       stop)
+      (fun prefix cctxt ->
+         Client_node_rpcs.complete cctxt ~block:(block ()) prefix >>= fun completions ->
          match completions with
          | [] -> Pervasives.exit 3
          | _ :: _ :: _ when !unique -> Pervasives.exit 3

src/client/client_helpers.mli

@@ -7,4 +7,4 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val commands: unit -> Cli_entries.command list
+val commands: unit -> Client_commands.command list

src/client/client_keys.ml

@@ -12,18 +12,18 @@ module Ed25519 = Environment.Ed25519
 module Public_key_hash = Client_aliases.Alias (struct
     type t = Ed25519.Public_key_hash.t
     let encoding = Ed25519.Public_key_hash.encoding
-    let of_source s = Lwt.return (Ed25519.Public_key_hash.of_b48check s)
-    let to_source p = Lwt.return (Ed25519.Public_key_hash.to_b48check p)
+    let of_source _ s = Lwt.return (Ed25519.Public_key_hash.of_b48check s)
+    let to_source _ p = Lwt.return (Ed25519.Public_key_hash.to_b48check p)
     let name = "public key hash"
   end)
 
 module Public_key = Client_aliases.Alias (struct
     type t = Ed25519.public_key
     let encoding = Ed25519.public_key_encoding
-    let of_source s =
+    let of_source _ s =
       Lwt.return (Sodium.Sign.Bytes.to_public_key
                 (Bytes.of_string B64.(decode ~alphabet:uri_safe_alphabet s)))
-    let to_source p =
+    let to_source _ p =
       Lwt.return B64.(encode ~alphabet:uri_safe_alphabet
                     (Bytes.to_string (Sodium.Sign.Bytes.of_public_key p)))
     let name = "public key"
@@ -32,106 +32,99 @@ module Public_key = Client_aliases.Alias (struct
 module Secret_key = Client_aliases.Alias (struct
     type t = Ed25519.secret_key
     let encoding = Ed25519.secret_key_encoding
-    let of_source s =
+    let of_source _ s =
       Lwt.return (Sodium.Sign.Bytes.to_secret_key
                 (Bytes.of_string B64.(decode ~alphabet:uri_safe_alphabet s)))
-    let to_source p =
+    let to_source _ p =
       Lwt.return B64.(encode ~alphabet:uri_safe_alphabet
                     (Bytes.to_string (Sodium.Sign.Bytes.of_secret_key p)))
     let name = "secret key"
   end)
 
-let gen_keys name =
+let gen_keys cctxt name =
   let secret_key, public_key = Sodium.Sign.random_keypair () in
-  Secret_key.add name secret_key >>= fun () ->
-  Public_key.add name public_key >>= fun () ->
-  Public_key_hash.add name (Ed25519.hash public_key) >>= fun () ->
-  Cli_entries.message "I generated a brand new pair of keys under the name '%s'." name
+  Secret_key.add cctxt name secret_key >>= fun () ->
+  Public_key.add cctxt name public_key >>= fun () ->
+  Public_key_hash.add cctxt name (Ed25519.hash public_key) >>= fun () ->
+  cctxt.message "I generated a brand new pair of keys under the name '%s'." name
 
 let check_keys_consistency pk sk =
   let message = MBytes.of_string "Voulez-vous coucher avec moi, ce soir ?" in
   let signature = Ed25519.sign sk message in
   Ed25519.check_signature pk signature message
 
-let get_key pkh =
-  Public_key_hash.rev_find pkh >>= function
-  | None -> Cli_entries.error "no keys for the source contract manager"
+let get_key cctxt pkh =
+  Public_key_hash.rev_find cctxt pkh >>= function
+  | None -> cctxt.error "no keys for the source contract manager"
   | Some n ->
-      Public_key.find n >>= fun pk ->
-      Secret_key.find n >>= fun sk ->
+      Public_key.find cctxt n >>= fun pk ->
+      Secret_key.find cctxt n >>= fun sk ->
       return (n, pk, sk)
 
+let group =
+  { Cli_entries.name = "keys" ;
+    title = "Commands for managing cryptographic keys" }
+
 let commands () =
   let open Cli_entries in
-  register_group "keys" "Commands for managing cryptographic keys" ;
-  [ command
-      ~group: "keys"
-      ~desc: "generate a pair of keys"
+  [ command ~group ~desc: "generate a pair of keys"
       (prefixes [ "gen" ; "keys" ]
        @@ Secret_key.fresh_alias_param
        @@ stop)
-      (fun name () -> gen_keys name) ;
-    command
-      ~group: "keys"
-      ~desc: "add a secret key to the wallet"
+      (fun name cctxt -> gen_keys cctxt name) ;
+    command ~group ~desc: "add a secret key to the wallet"
       (prefixes [ "add" ; "secret" ; "key" ]
        @@ Secret_key.fresh_alias_param
        @@ Secret_key.source_param
        @@ stop)
-      (fun name sk () ->
+      (fun name sk cctxt ->
          Lwt.catch (fun () ->
-             Public_key.find name >>= fun pk ->
+             Public_key.find cctxt name >>= fun pk ->
              if check_keys_consistency pk sk || Client_config.force#get then
-               Secret_key.add name sk
+               Secret_key.add cctxt name sk
              else
-               error "public and secret keys '%s' don't correspond, \
+               cctxt.error
+                 "public and secret keys '%s' don't correspond, \
                   please don't use -force true" name)
            (function
              | Not_found ->
-                 error "no public key named '%s', add it before adding the secret key" name
+                 cctxt.error
+                   "no public key named '%s', add it before adding the secret key" name
              | exn -> Lwt.fail exn)) ;
-    command
-      ~group: "keys"
-      ~desc: "add a public key to the wallet"
+    command ~group ~desc: "add a public key to the wallet"
       (prefixes [ "add" ; "public" ; "key" ]
        @@ Public_key.fresh_alias_param
        @@ Public_key.source_param
        @@ stop)
-      (fun name key () ->
-         Public_key_hash.add name (Ed25519.hash key) >>= fun () ->
-         Public_key.add name key) ;
-    command
-      ~group: "keys"
-      ~desc: "add an ID a public key hash to the wallet"
+      (fun name key cctxt ->
+         Public_key_hash.add cctxt name (Ed25519.hash key) >>= fun () ->
+         Public_key.add cctxt name key) ;
+    command ~group ~desc: "add an ID a public key hash to the wallet"
       (prefixes [ "add" ; "identity" ]
        @@ Public_key_hash.fresh_alias_param
        @@ Public_key_hash.source_param
        @@ stop)
-      (fun name hash () ->
-         Public_key_hash.add name hash) ;
-    command
-      ~group: "keys"
-      ~desc: "list all public key hashes and associated keys"
+      (fun name hash cctxt ->
+         Public_key_hash.add cctxt name hash) ;
+    command ~group ~desc: "list all public key hashes and associated keys"
       (fixed [ "list" ; "known" ; "identities" ])
-      (fun () ->
-         Public_key_hash.load () >>= fun l ->
+      (fun cctxt ->
+         Public_key_hash.load cctxt >>= fun l ->
          Lwt_list.iter_s (fun (name, pkh) ->
-             Public_key.mem name >>= fun pkm ->
-             Secret_key.mem name >>= fun pks ->
-             Public_key_hash.to_source pkh >>= fun v ->
-             message "%s: %s%s%s" name v
+             Public_key.mem cctxt name >>= fun pkm ->
+             Secret_key.mem cctxt name >>= fun pks ->
+             Public_key_hash.to_source cctxt pkh >>= fun v ->
+             cctxt.message "%s: %s%s%s" name v
                (if pkm then " (public key known)" else "")
                (if pks then " (secret key known)" else ""))
            l) ;
-    command
-      ~group: "keys"
-      ~desc: "forget all keys"
+    command ~group ~desc: "forget all keys"
       (fixed [ "forget" ; "all" ; "keys" ])
-      (fun () ->
+      (fun cctxt ->
          if not Client_config.force#get then
-           error "this can only used with option -force true"
+           cctxt.Client_commands.error "this can only used with option -force true"
          else
-           Public_key.save [] >>= fun () ->
-           Secret_key.save [] >>= fun () ->
-           Public_key_hash.save []) ;
+           Public_key.save cctxt [] >>= fun () ->
+           Secret_key.save cctxt [] >>= fun () ->
+           Public_key_hash.save cctxt []) ;
      ]

src/client/client_keys.mli

@@ -15,8 +15,9 @@ module Public_key : Client_aliases.Alias with type t = Ed25519.public_key
 module Secret_key : Client_aliases.Alias with type t = Ed25519.secret_key
 
 val get_key:
+  Client_commands.context ->
   Public_key_hash.t ->
   ( string * Public_key.t * Secret_key.t ) tzresult Lwt.t
 
 
-val commands: unit -> Cli_entries.command list
+val commands: unit -> Client_commands.command list

src/client/client_node_rpcs.ml

@@ -11,18 +11,17 @@
 
 open Lwt
 open Cli_entries
+open Client_commands
 open Logging.RPC
 
-let log_request cpt url req =
-  Cli_entries.log "requests"
-    ">>>>%d: %s\n%s\n" cpt url req
+let log_request { log } cpt url req =
+  log "requests" ">>>>%d: %s\n%s\n" cpt url req
 
-let log_response cpt code ans =
-  Cli_entries.log "requests"
-    "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans
+let log_response { log } cpt code ans =
+  log "requests" "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans
 
 let cpt = ref 0
-let make_request service json =
+let make_request cctxt service json =
   incr cpt ;
   let cpt = !cpt in
   let serv = "http://" ^ Client_config.incoming_addr#get
@@ -35,22 +34,22 @@ let make_request service json =
     (fun () ->
        let body = Cohttp_lwt_body.of_string reqbody in
        Cohttp_lwt_unix.Client.post ~body uri >>= fun (code, ansbody) ->
-       log_request cpt string_uri reqbody >>= fun () ->
+       log_request cctxt cpt string_uri reqbody >>= fun () ->
        return (cpt, Unix.gettimeofday () -. tzero,
                code.Cohttp.Response.status, ansbody))
     (fun e ->
        let msg = match e with
          | Unix.Unix_error (e, _, _) -> Unix.error_message e
          | e -> Printexc.to_string e in
-       error "cannot connect to the RPC server (%s)" msg)
+       cctxt.error "cannot connect to the RPC server (%s)" msg)
 
-let get_streamed_json service json =
-  make_request service json >>= fun (_cpt, time, code, ansbody) ->
+let get_streamed_json cctxt service json =
+  make_request cctxt service json >>= fun (_cpt, time, code, ansbody) ->
   let ansbody = Cohttp_lwt_body.to_stream ansbody in
   match code, ansbody with
   | #Cohttp.Code.success_status, ansbody ->
       (if Client_config.print_timings#get then
-        message "Request to /%s succeeded in %gs"
+         cctxt.message "Request to /%s succeeded in %gs"
            (String.concat "/" service) time
        else Lwt.return ()) >>= fun () ->
       Lwt.return (
@@ -64,88 +63,92 @@ let get_streamed_json service json =
           (Data_encoding_ezjsonm.from_stream ansbody))
   | err, _ansbody ->
       (if Client_config.print_timings#get then
-        message "Request to /%s failed in %gs"
+         cctxt.message "Request to /%s failed in %gs"
            (String.concat "/" service) time
        else Lwt.return ()) >>= fun () ->
-      message "Request to /%s failed, server returned %s"
+      cctxt.message "Request to /%s failed, server returned %s"
         (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () ->
-      error "the RPC server returned a non-success status (%s)"
+      cctxt.error "the RPC server returned a non-success status (%s)"
         (Cohttp.Code.string_of_status err)
 
-let get_json service json =
-  make_request service json >>= fun (cpt, time, code, ansbody) ->
+let get_json cctxt service json =
+  make_request cctxt service json >>= fun (cpt, time, code, ansbody) ->
   Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
   match code, ansbody with
   | #Cohttp.Code.success_status, ansbody -> begin
       (if Client_config.print_timings#get then
-         message "Request to /%s succeeded in %gs"
+         cctxt.message "Request to /%s succeeded in %gs"
            (String.concat "/" service) time
        else Lwt.return ()) >>= fun () ->
-      log_response cpt code ansbody >>= fun () ->
+      log_response cctxt cpt code ansbody >>= fun () ->
       if ansbody = "" then Lwt.return `Null
       else match Data_encoding_ezjsonm.from_string ansbody with
-        | Error _ -> error "the RPC server returned malformed JSON"
+        | Error _ -> cctxt.error "the RPC server returned malformed JSON"
         | Ok res -> Lwt.return res
     end
   | err, _ansbody ->
       (if Client_config.print_timings#get then
-         message "Request to /%s failed in %gs"
+         cctxt.message "Request to /%s failed in %gs"
            (String.concat "/" service) time
        else Lwt.return ()) >>= fun () ->
-      message "Request to /%s failed, server returned %s"
+      cctxt.message "Request to /%s failed, server returned %s"
         (String.concat "/" service) (Cohttp.Code.string_of_status err) >>= fun () ->
-      error "the RPC server returned a non-success status (%s)"
+      cctxt.error "the RPC server returned a non-success status (%s)"
         (Cohttp.Code.string_of_status err)
 
 exception Unknown_error of Data_encoding.json
 
-let parse_answer service path json =
+let parse_answer cctxt service path json =
   match RPC.read_answer service json with
   | Error msg -> (* TODO print_error *)
-      error "request to /%s returned wrong JSON (%s)\n%s"
+      cctxt.error "request to /%s returned wrong JSON (%s)\n%s"
         (String.concat "/" path) msg (Data_encoding_ezjsonm.to_string json)
   | Ok v -> return v
 
-let call_service0 service arg =
+let call_service0 cctxt service arg =
   let path, arg = RPC.forge_request service () arg in
-  get_json path arg >>= parse_answer service path
+  get_json cctxt path arg >>= fun json ->
+  parse_answer cctxt service path json
 
-let call_service1 service a1 arg =
+let call_service1 cctxt service a1 arg =
   let path, arg = RPC.forge_request service ((), a1) arg in
-  get_json path arg >>= parse_answer service path
+  get_json cctxt path arg >>= fun json ->
+  parse_answer cctxt service path json
 
-let call_service2 service a1 a2 arg =
+let call_service2 cctxt service a1 a2 arg =
   let path, arg = RPC.forge_request service (((), a1), a2) arg in
-  get_json path arg >>= parse_answer service path
+  get_json cctxt path arg >>= fun json ->
+  parse_answer cctxt service path json
 
-let call_streamed_service0 service arg =
+let call_streamed_service0 cctxt service arg =
   let path, arg = RPC.forge_request service () arg in
-  get_streamed_json path arg >|= fun st ->
-  Lwt_stream.map_s (parse_answer service path) st
+  get_streamed_json cctxt path arg >|= fun st ->
+  Lwt_stream.map_s (parse_answer cctxt service path) st
 
 module Services = Node_rpc_services
-let errors = call_service0 Services.Error.service
-let forge_block ?net ?predecessor ?timestamp fitness ops header =
-  call_service0 Services.forge_block
+let errors cctxt =
+  call_service0 cctxt Services.Error.service ()
+let forge_block cctxt ?net ?predecessor ?timestamp fitness ops header =
+  call_service0 cctxt Services.forge_block
     (net, predecessor, timestamp, fitness, ops, header)
-let validate_block net block =
-  call_service0 Services.validate_block (net, block)
-let inject_block ?(wait = true) ?force block =
-  call_service0 Services.inject_block (block, wait, force)
-let inject_operation ?(wait = true) ?force operation =
-  call_service0 Services.inject_operation (operation, wait, force)
-let inject_protocol ?(wait = true) ?force protocol =
-  call_service0 Services.inject_protocol (protocol, wait, force)
-let complete ?block prefix =
+let validate_block cctxt net block =
+  call_service0 cctxt Services.validate_block (net, block)
+let inject_block cctxt ?(wait = true) ?force block =
+  call_service0 cctxt Services.inject_block (block, wait, force)
+let inject_operation cctxt ?(wait = true) ?force operation =
+  call_service0 cctxt Services.inject_operation (operation, wait, force)
+let inject_protocol cctxt ?(wait = true) ?force protocol =
+  call_service0 cctxt Services.inject_protocol (protocol, wait, force)
+let complete cctxt ?block prefix =
   match block with
   | None ->
-      call_service1 Services.complete prefix ()
+      call_service1 cctxt Services.complete prefix ()
   | Some block ->
-      call_service2 Services.Blocks.complete block prefix ()
-let describe ?recurse path =
+      call_service2 cctxt Services.Blocks.complete block prefix ()
+let describe cctxt ?recurse path =
   let prefix, arg = RPC.forge_request Services.describe () recurse in
-  get_json (prefix @ path) arg >>=
-  parse_answer Services.describe prefix
+  get_json cctxt (prefix @ path) arg >>=
+  parse_answer cctxt Services.describe prefix
 
 type net = Services.Blocks.net = Net of Block_hash.t
 
@@ -173,42 +176,42 @@ module Blocks = struct
     fitness: MBytes.t list ;
     timestamp: Time.t ;
   }
-  let net h = call_service1 Services.Blocks.net h ()
-  let predecessor h = call_service1 Services.Blocks.predecessor h ()
-  let hash h = call_service1 Services.Blocks.hash h ()
-  let timestamp h = call_service1 Services.Blocks.timestamp h ()
-  let fitness h = call_service1 Services.Blocks.fitness h ()
-  let operations h = call_service1 Services.Blocks.operations h ()
-  let protocol h = call_service1 Services.Blocks.protocol h ()
-  let test_protocol h = call_service1 Services.Blocks.test_protocol h ()
-  let test_network h = call_service1 Services.Blocks.test_network h ()
-  let preapply h ?timestamp ?(sort = false) operations =
-    call_service1 Services.Blocks.preapply h { operations ; sort ; timestamp }
-  let pending_operations block =
-    call_service1 Services.Blocks.pending_operations block ()
-  let info ?(operations = false) h =
-    call_service1 Services.Blocks.info h operations
-  let complete block prefix =
-    call_service2 Services.Blocks.complete block prefix ()
-  let list ?operations ?length ?heads ?delay ?min_date ?min_heads () =
-    call_service0 Services.Blocks.list
+  let net cctxt h = call_service1 cctxt Services.Blocks.net h ()
+  let predecessor cctxt h = call_service1 cctxt Services.Blocks.predecessor h ()
+  let hash cctxt h = call_service1 cctxt Services.Blocks.hash h ()
+  let timestamp cctxt h = call_service1 cctxt Services.Blocks.timestamp h ()
+  let fitness cctxt h = call_service1 cctxt Services.Blocks.fitness h ()
+  let operations cctxt h = call_service1 cctxt Services.Blocks.operations h ()
+  let protocol cctxt h = call_service1 cctxt Services.Blocks.protocol h ()
+  let test_protocol cctxt h = call_service1 cctxt Services.Blocks.test_protocol h ()
+  let test_network cctxt h = call_service1 cctxt Services.Blocks.test_network h ()
+  let preapply cctxt h ?timestamp ?(sort = false) operations =
+    call_service1 cctxt Services.Blocks.preapply h { operations ; sort ; timestamp }
+  let pending_operations cctxt block =
+    call_service1 cctxt Services.Blocks.pending_operations block ()
+  let info cctxt ?(operations = false) h =
+    call_service1 cctxt Services.Blocks.info h operations
+  let complete cctxt block prefix =
+    call_service2 cctxt Services.Blocks.complete block prefix ()
+  let list cctxt ?operations ?length ?heads ?delay ?min_date ?min_heads () =
+    call_service0 cctxt Services.Blocks.list
       { operations; length ; heads ; monitor = Some false ; delay ;
         min_date ; min_heads }
-  let monitor ?operations ?length ?heads ?delay ?min_date ?min_heads () =
-    call_streamed_service0 Services.Blocks.list
+  let monitor cctxt ?operations ?length ?heads ?delay ?min_date ?min_heads () =
+    call_streamed_service0 cctxt Services.Blocks.list
       { operations; length ; heads ; monitor = Some true ; delay ;
         min_date ; min_heads }
 end
 
 module Operations = struct
-  let monitor ?contents () =
-    call_streamed_service0 Services.Operations.list
+  let monitor cctxt ?contents () =
+    call_streamed_service0 cctxt Services.Operations.list
       { monitor = Some true ; contents }
 end
 
 module Protocols = struct
-  let bytes hash =
-    call_service1 Services.Protocols.bytes hash ()
-  let list ?contents () =
-    call_service0 Services.Protocols.list { contents; monitor = Some false }
+  let bytes cctxt hash =
+    call_service1 cctxt Services.Protocols.bytes hash ()
+  let list cctxt ?contents () =
+    call_service0 cctxt Services.Protocols.list { contents; monitor = Some false }
 end

src/client/client_node_rpcs.mli

@@ -9,8 +9,12 @@
 
 type net = State.net_id = Net of Block_hash.t
 
-val errors: unit -> Json_schema.schema Lwt.t
+val errors:
+  Client_commands.context ->
+  Json_schema.schema Lwt.t
+
 val forge_block:
+  Client_commands.context ->
   ?net:Updater.net_id ->
   ?predecessor:Block_hash.t ->
   ?timestamp:Time.t ->
@@ -19,14 +23,28 @@ val forge_block:
   MBytes.t ->
   MBytes.t Lwt.t
 
-val validate_block: net -> Block_hash.t -> unit tzresult Lwt.t
+val validate_block:
+  Client_commands.context ->
+  net -> Block_hash.t ->
+  unit tzresult Lwt.t
+
 val inject_block:
-  ?wait:bool -> ?force:bool -> MBytes.t ->
+  Client_commands.context ->
+  ?wait:bool -> ?force:bool ->
+  MBytes.t ->
   Block_hash.t tzresult Lwt.t
+
 val inject_operation:
-  ?wait:bool -> ?force:bool -> MBytes.t -> Operation_hash.t tzresult Lwt.t
+  Client_commands.context ->
+  ?wait:bool -> ?force:bool ->
+  MBytes.t ->
+  Operation_hash.t tzresult Lwt.t
+
 val inject_protocol:
-  ?wait:bool -> ?force:bool -> Tezos_compiler.Protocol.t -> Protocol_hash.t tzresult Lwt.t
+  Client_commands.context ->
+  ?wait:bool -> ?force:bool ->
+  Tezos_compiler.Protocol.t ->
+  Protocol_hash.t tzresult Lwt.t
 
 module Blocks : sig
 
@@ -37,17 +55,36 @@ module Blocks : sig
     | `Hash of Block_hash.t
     ]
 
-  val net: block -> net Lwt.t
-  val predecessor: block -> Block_hash.t Lwt.t
-  val hash: block -> Block_hash.t Lwt.t
-  val timestamp: block -> Time.t Lwt.t
-  val fitness: block -> MBytes.t list Lwt.t
-  val operations: block -> Operation_hash.t list Lwt.t
-  val protocol: block -> Protocol_hash.t Lwt.t
-  val test_protocol: block -> Protocol_hash.t option Lwt.t
-  val test_network: block -> (net * Time.t) option Lwt.t
+  val net:
+    Client_commands.context ->
+    block -> net Lwt.t
+  val predecessor:
+    Client_commands.context ->
+    block -> Block_hash.t Lwt.t
+  val hash:
+    Client_commands.context ->
+    block -> Block_hash.t Lwt.t
+  val timestamp:
+    Client_commands.context ->
+    block -> Time.t Lwt.t
+  val fitness:
+    Client_commands.context ->
+    block -> MBytes.t list Lwt.t
+  val operations:
+    Client_commands.context ->
+    block -> Operation_hash.t list Lwt.t
+  val protocol:
+    Client_commands.context ->
+    block -> Protocol_hash.t Lwt.t
+  val test_protocol:
+    Client_commands.context ->
+    block -> Protocol_hash.t option Lwt.t
+  val test_network:
+    Client_commands.context ->
+    block -> (net * Time.t) option Lwt.t
 
   val pending_operations:
+    Client_commands.context ->
     block -> (error Updater.preapply_result * Operation_hash_set.t) Lwt.t
 
   type block_info = {
@@ -63,14 +100,17 @@ module Blocks : sig
   }
 
   val info:
+    Client_commands.context ->
     ?operations:bool -> block -> block_info Lwt.t
 
   val list:
+    Client_commands.context ->
     ?operations:bool -> ?length:int -> ?heads:Block_hash.t list ->
     ?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
     unit -> block_info list list Lwt.t
 
   val monitor:
+    Client_commands.context ->
     ?operations:bool -> ?length:int -> ?heads:Block_hash.t list ->
     ?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
     unit -> block_info list list Lwt_stream.t Lwt.t
@@ -82,6 +122,7 @@ module Blocks : sig
   }
 
   val preapply:
+    Client_commands.context ->
     block ->
     ?timestamp:Time.t ->
     ?sort:bool ->
@@ -91,30 +132,42 @@ end
 
 module Operations : sig
   val monitor:
+    Client_commands.context ->
     ?contents:bool -> unit ->
     (Operation_hash.t * Store.operation option) list Lwt_stream.t Lwt.t
 end
 
 module Protocols : sig
   val bytes:
+    Client_commands.context ->
     Protocol_hash.t -> Store.protocol tzresult Time.timed_data Lwt.t
 
   val list:
+    Client_commands.context ->
     ?contents:bool -> unit ->
     (Protocol_hash.t * Store.protocol option) list Lwt.t
 end
 
-val complete: ?block:Blocks.block -> string -> string list Lwt.t
+val complete:
+  Client_commands.context ->
+  ?block:Blocks.block -> string -> string list Lwt.t
 
-val describe: ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t
+val describe:
+  Client_commands.context ->
+  ?recurse:bool -> string list -> RPC.Description.directory_descr Lwt.t
 
 (** Low-level *)
 
-val get_json: string list -> Data_encoding.json -> Data_encoding.json Lwt.t
+val get_json:
+  Client_commands.context ->
+  string list -> Data_encoding.json -> Data_encoding.json Lwt.t
 
 val call_service0:
+  Client_commands.context ->
   (unit, unit, 'i, 'o) RPC.service -> 'i -> 'o Lwt.t
 val call_service1:
+  Client_commands.context ->
   (unit, unit * 'a, 'i, 'o) RPC.service -> 'a -> 'i -> 'o Lwt.t
 val call_service2:
+  Client_commands.context ->
   (unit, (unit * 'a) * 'b, 'i, 'o) RPC.service -> 'a -> 'b -> 'i -> 'o Lwt.t

src/client/client_protocols.ml

@@ -1,51 +1,60 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+let group =
+  { Cli_entries.name = "protocols" ;
+    title = "Commands for managing protocols" }
+
 let commands () =
   let open Cli_entries in
-  let check_dir dn =
-    if Sys.is_directory dn then Lwt.return dn else Lwt.fail_invalid_arg "not a directory"
-  in
-  let check_hash ph = Lwt.wrap1 Protocol_hash.of_b48check ph in
-  register_group "protocols" "Commands for managing protocols" ;
+  let check_dir _ dn =
+    if Sys.is_directory dn then
+      Lwt.return dn
+    else
+      Lwt.fail_with (dn ^ " is not a directory") in
+  let check_hash _ ph =
+    Lwt.wrap1 Protocol_hash.of_b48check ph in
   [
-    command
-      ~group: "protocols"
-      ~desc: "list known protocols"
+    command ~group ~desc: "list known protocols"
       (prefixes [ "list" ; "protocols" ] stop)
-      (fun () ->
-         Client_node_rpcs.Protocols.list ~contents:false () >>= fun protos ->
-         Lwt_list.iter_s (fun (ph, _p) -> message "%a" Protocol_hash.pp ph) protos
+      (fun cctxt ->
+         Client_node_rpcs.Protocols.list cctxt ~contents:false () >>= fun protos ->
+         Lwt_list.iter_s (fun (ph, _p) -> cctxt.message "%a" Protocol_hash.pp ph) protos
       );
-    command
-      ~group: "protocols"
-      ~desc: "inject a new protocol to the shell database"
+    command ~group ~desc: "inject a new protocol to the shell database"
       (prefixes [ "inject" ; "protocol" ]
-       @@ param ~name:"directory containing a protocol" ~desc:"" check_dir
+       @@ param ~name:"dir" ~desc:"directory containing a protocol" check_dir
        @@ stop)
-      (fun dirname () ->
+      (fun dirname cctxt ->
          Lwt.catch
            (fun () ->
               let proto = Tezos_compiler.Protocol.of_dir dirname in
-              Client_node_rpcs.inject_protocol proto >>= function
+              Client_node_rpcs.inject_protocol cctxt proto >>= function
               | Ok hash ->
-                  message "Injected protocol %a successfully" Protocol_hash.pp_short hash
+                  cctxt.message "Injected protocol %a successfully" Protocol_hash.pp_short hash
               | Error err ->
-                  error "Error while injecting protocol from %s: %a"
+                  cctxt.error "Error while injecting protocol from %s: %a"
                     dirname Error_monad.pp_print_error err)
            (fun exn ->
-              error "Error while injecting protocol from %s: %a"
+              cctxt.error "Error while injecting protocol from %s: %a"
                 dirname Error_monad.pp_print_error [Error_monad.Exn exn])
       );
-    command
-      ~group: "protocols"
-      ~desc: "dump a protocol from the shell database"
+    command ~group ~desc: "dump a protocol from the shell database"
       (prefixes [ "dump" ; "protocol" ]
        @@ param ~name:"protocol hash" ~desc:"" check_hash
        @@ stop)
-      (fun ph () ->
-         Client_node_rpcs.Protocols.bytes ph >>= fun { data } -> match data with
+      (fun ph cctxt ->
+         Client_node_rpcs.Protocols.bytes cctxt ph >>= fun { data } -> match data with
          | Ok proto ->
              Updater.extract "" ph proto >>= fun () ->
-             message "Extracted protocol %a" Protocol_hash.pp_short ph
+             cctxt.message "Extracted protocol %a" Protocol_hash.pp_short ph
          | Error err ->
-             error "Error while dumping protocol %a: %a"
+             cctxt.error "Error while dumping protocol %a: %a"
                Protocol_hash.pp_short ph Error_monad.pp_print_error err);
   ]

src/client/client_protocols.mli

@@ -1,2 +1,10 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
 
-val commands: unit -> Cli_entries.command list
+val commands: unit -> Client_commands.command list

src/client/embedded/bootstrap/client_proto_args.ml

@@ -86,7 +86,7 @@ let tez_param ~name ~desc next =
     name
     (desc ^ " in \xEA\x9C\xA9\n\
              text format: D,DDD,DDD.DD (centiles and comas are optional)")
-    (fun s ->
+    (fun _ s ->
        try Lwt.return (tez_of_string s)
        with _ -> Lwt.fail_with "invalid \xEA\x9C\xA9 notation")
     next

src/client/embedded/bootstrap/client_proto_args.mli

@@ -25,7 +25,8 @@ val endorsement_delay_arg: string * Arg.spec * string
 val tez_param :
   name:string ->
   desc:string ->
-  'a Cli_entries.params -> (Tez.t -> 'a) Cli_entries.params
+  ('a, Client_commands.context, unit) Cli_entries.params ->
+  (Tez.t -> 'a, Client_commands.context, unit) Cli_entries.params
 
 val delegate: string option ref
 val source: string option ref

src/client/embedded/bootstrap/client_proto_context.ml

@@ -13,43 +13,40 @@ open Client_proto_programs
 open Client_keys
 module Ed25519 = Environment.Ed25519
 
-let handle_error f () =
-    f () >>= Client_proto_rpcs.handle_error
-
-let check_contract neu =
-  RawContractAlias.mem neu >>= function
+let check_contract cctxt neu =
+  RawContractAlias.mem cctxt neu >>= function
   | true ->
-      Cli_entries.error "contract '%s' already exists" neu
+      cctxt.error "contract '%s' already exists" neu
   | false ->
       Lwt.return ()
 
-let get_delegate_pkh = function
+let get_delegate_pkh cctxt = function
   | None -> Lwt.return None
   | Some delegate ->
       Lwt.catch
         (fun () ->
-           Public_key_hash.find delegate >>= fun r ->
+           Public_key_hash.find cctxt delegate >>= fun r ->
            Lwt.return (Some r))
         (fun _ -> Lwt.return None)
 
-let get_timestamp block () =
-  Client_node_rpcs.Blocks.timestamp block >>= fun v ->
-  Cli_entries.message "%s" (Time.to_notation v)
+let get_timestamp cctxt block =
+  Client_node_rpcs.Blocks.timestamp cctxt block >>= fun v ->
+  cctxt.message "%s" (Time.to_notation v)
 
-let list_contracts block () =
-  Client_proto_rpcs.Context.Contract.list block >>=? fun contracts ->
+let list_contracts cctxt block =
+  Client_proto_rpcs.Context.Contract.list cctxt block >>=? fun contracts ->
   iter_s (fun h ->
       begin match Contract.is_default h with
         | Some m -> begin
-            Public_key_hash.rev_find m >>= function
+            Public_key_hash.rev_find cctxt m >>= function
             | None -> Lwt.return ""
             | Some nm ->
-                RawContractAlias.find_opt nm >|= function
+                RawContractAlias.find_opt cctxt nm >|= function
                 | None -> " (known as " ^ nm ^ ")"
                 | Some _ -> " (known as key:" ^ nm ^ ")"
           end
         | None -> begin
-            RawContractAlias.rev_find h >|= function
+            RawContractAlias.rev_find cctxt h >|= function
             | None -> ""
             | Some nm ->  " (known as " ^ nm ^ ")"
           end
@@ -57,134 +54,129 @@ let list_contracts block () =
       let kind = match Contract.is_default h with
         | Some _ -> " (default)"
         | None -> "" in
-      Cli_entries.message "%s%s%s" (Contract.to_b48check h) kind nm >>= fun () ->
+      cctxt.message "%s%s%s" (Contract.to_b48check h) kind nm >>= fun () ->
       return ())
     contracts
 
-let transfer block ?force
+let transfer cctxt
+    block ?force
     ~source ~src_pk ~src_sk ~destination ?arg ~amount ~fee () =
   let open Cli_entries in
-  Client_node_rpcs.Blocks.net block >>= fun net ->
+  Client_node_rpcs.Blocks.net cctxt block >>= fun net ->
   begin match arg with
     | Some arg ->
-        Client_proto_programs.parse_data arg >>= fun arg ->
+        Client_proto_programs.parse_data cctxt arg >>= fun arg ->
         Lwt.return (Some arg)
     | None -> Lwt.return None
   end >>= fun parameters ->
-  Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter ->
+  Client_proto_rpcs.Context.Contract.counter cctxt block source >>=? fun pcounter ->
   let counter = Int32.succ pcounter in
-  message "Acquired the source's sequence counter (%ld -> %ld)."
+  cctxt.message "Acquired the source's sequence counter (%ld -> %ld)."
     pcounter counter >>= fun () ->
-  Client_proto_rpcs.Helpers.Forge.Manager.transaction block
+  Client_proto_rpcs.Helpers.Forge.Manager.transaction cctxt block
     ~net ~source ~sourcePubKey:src_pk ~counter ~amount
     ~destination ?parameters ~fee () >>=? fun bytes ->
-  message "Forged the raw transaction frame." >>= fun () ->
+  cctxt.message "Forged the raw transaction frame." >>= fun () ->
   let signed_bytes = Ed25519.append_signature src_sk bytes in
-  Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph ->
-  answer "Operation successfully injected in the node." >>= fun () ->
-  answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
+  Client_node_rpcs.inject_operation cctxt ?force ~wait:true signed_bytes >>=? fun oph ->
+  cctxt.answer "Operation successfully injected in the node." >>= fun () ->
+  cctxt.answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
   return ()
 
-let originate_account block ?force
+let originate_account cctxt
+    block ?force
     ~source ~src_pk ~src_sk ~manager_pkh ?delegatable ?spendable ?delegate ~balance ~fee () =
   let open Cli_entries in
-  Client_node_rpcs.Blocks.net block >>= fun net ->
-  Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter ->
+  Client_node_rpcs.Blocks.net cctxt block >>= fun net ->
+  Client_proto_rpcs.Context.Contract.counter cctxt block source >>=? fun pcounter ->
   let counter = Int32.succ pcounter in
-  message "Acquired the source's sequence counter (%ld -> %ld)."
+  cctxt.message "Acquired the source's sequence counter (%ld -> %ld)."
     pcounter counter >>= fun () ->
-  Client_proto_rpcs.Helpers.Forge.Manager.origination block
+  Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt block
     ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
     ~counter ~balance ?spendable
     ?delegatable ?delegatePubKey:delegate ~fee () >>=? fun (contract, bytes) ->
-  message "Forged the raw origination frame." >>= fun () ->
+  cctxt.message "Forged the raw origination frame." >>= fun () ->
   let signed_bytes = Ed25519.append_signature src_sk bytes in
-  Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph ->
-  message "Operation successfully injected in the node." >>= fun () ->
-  message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
+  Client_node_rpcs.inject_operation cctxt ?force ~wait:true signed_bytes >>=? fun oph ->
+  cctxt.message "Operation successfully injected in the node." >>= fun () ->
+  cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
   return contract
 
-let originate_contract
+let originate_contract cctxt
     block ?force
     ~source ~src_pk ~src_sk ~manager_pkh ~balance ?delegatable ?delegatePubKey
     ~(code:Script.code) ~init ~fee () =
   let open Cli_entries in
-  Client_proto_programs.parse_data init >>= fun storage ->
+  Client_proto_programs.parse_data cctxt init >>= fun storage ->
   let init = Script.{ storage ; storage_type = code.storage_type } in
-  Client_proto_rpcs.Context.Contract.counter block source >>=? fun pcounter ->
+  Client_proto_rpcs.Context.Contract.counter cctxt block source >>=? fun pcounter ->
   let counter = Int32.succ pcounter in
-  message "Acquired the source's sequence counter (%ld -> %ld)."
+  cctxt.message "Acquired the source's sequence counter (%ld -> %ld)."
     pcounter counter >>= fun () ->
-  Client_node_rpcs.Blocks.net block >>= fun net ->
-  Client_proto_rpcs.Helpers.Forge.Manager.origination block
+  Client_node_rpcs.Blocks.net cctxt block >>= fun net ->
+  Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt block
     ~net ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh
     ~counter ~balance ~spendable:!spendable
     ?delegatable ?delegatePubKey
     ~script:(code, init) ~fee () >>=? fun (contract, bytes) ->
-  message "Forged the raw origination frame." >>= fun () ->
+  cctxt.message "Forged the raw origination frame." >>= fun () ->
   let signed_bytes = Ed25519.append_signature src_sk bytes in
-  Client_node_rpcs.inject_operation ?force ~wait:true signed_bytes >>=? fun oph ->
-  message "Operation successfully injected in the node." >>= fun () ->
-  message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
+  Client_node_rpcs.inject_operation cctxt ?force ~wait:true signed_bytes >>=? fun oph ->
+  cctxt.message "Operation successfully injected in the node." >>= fun () ->
+  cctxt.message "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
   return contract
 
+let group =
+  { Cli_entries.name = "context" ;
+    title = "Block contextual commands (see option -block)" }
+
 let commands () =
   let open Cli_entries in
-  register_group "context" "Block contextual commands (see option -block)" ;
-  [ command
-      ~group: "context"
-      ~desc: "access the timestamp of the block"
+  [ command ~group ~desc: "access the timestamp of the block"
       (fixed [ "get" ; "timestamp" ])
-      (get_timestamp (block ())) ;
-    command
-      ~group: "context"
-      ~desc: "lists all non empty contracts of the block"
+      (fun cctxt -> get_timestamp cctxt (block ())) ;
+    command ~group ~desc: "lists all non empty contracts of the block"
       (fixed [ "list" ; "contracts" ])
-      (handle_error (list_contracts (block ()))) ;
-    command
-      ~group: "context"
-      ~desc: "get the bootstrap keys and bootstrap contract handle"
+      (fun cctxt ->
+         list_contracts cctxt (block ()) >>= fun res ->
+         Client_proto_rpcs.handle_error cctxt res) ;
+    command ~group ~desc: "get the bootstrap keys and bootstrap contract handle"
       (fixed [ "bootstrap" ])
-      (fun () ->
-         Client_proto_rpcs.Constants.bootstrap `Genesis >>= fun accounts ->
+      (fun cctxt ->
+         Client_proto_rpcs.Constants.bootstrap cctxt `Genesis >>= fun accounts ->
          let cpt = ref 0 in
          Lwt_list.iter_s
            (fun { Bootstrap.public_key_hash = pkh ;
                   public_key = pk ; secret_key = sk } ->
              incr cpt ;
              let name = Printf.sprintf "bootstrap%d" !cpt in
-             Public_key_hash.add name pkh >>= fun () ->
-             Public_key.add name pk >>= fun () ->
-             Secret_key.add name sk >>= fun () ->
-             message "Bootstrap keys added under the name '%s'." name)
+             Public_key_hash.add cctxt name pkh >>= fun () ->
+             Public_key.add cctxt name pk >>= fun () ->
+             Secret_key.add cctxt name sk >>= fun () ->
+             cctxt.message "Bootstrap keys added under the name '%s'." name)
            accounts >>= fun () ->
          Lwt.return_unit) ;
-    command
-      ~group: "context"
-      ~desc: "get the balance of a contract"
+    command ~group ~desc: "get the balance of a contract"
       (prefixes [ "get" ; "balance" ]
        @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
        @@ stop)
-      (fun (_, contract) () ->
-         Client_proto_rpcs.Context.Contract.balance (block ()) contract
-         >>= Client_proto_rpcs.handle_error >>= fun amount ->
-         answer "%a %s" Tez.pp amount tez_sym);
-    command
-      ~group: "context"
-      ~desc: "get the manager of a block"
+      (fun (_, contract) cctxt ->
+         Client_proto_rpcs.Context.Contract.balance cctxt (block ()) contract
+         >>= Client_proto_rpcs.handle_error cctxt >>= fun amount ->
+         cctxt.answer "%a %s" Tez.pp amount tez_sym);
+    command ~group ~desc: "get the manager of a block"
       (prefixes [ "get" ; "manager" ]
        @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract"
        @@ stop)
-      (fun (_, contract) () ->
-         Client_proto_rpcs.Context.Contract.manager (block ()) contract
-         >>= Client_proto_rpcs.handle_error >>= fun manager ->
-         Public_key_hash.rev_find manager >>= fun mn ->
-         Public_key_hash.to_source manager >>= fun m ->
-         message "%s (%s)" m
+      (fun (_, contract) cctxt ->
+         Client_proto_rpcs.Context.Contract.manager cctxt (block ()) contract
+         >>= Client_proto_rpcs.handle_error cctxt >>= fun manager ->
+         Public_key_hash.rev_find cctxt manager >>= fun mn ->
+         Public_key_hash.to_source cctxt manager >>= fun m ->
+         cctxt.message "%s (%s)" m
            (match mn with None -> "unknown" | Some n -> "known as " ^ n));
-    command
-      ~group: "context"
-      ~desc: "open a new account"
+    command ~group ~desc: "open a new account"
       ~args: ([ fee_arg ; delegate_arg ; force_arg ]
               @ delegatable_args @ spendable_args)
       (prefixes [ "originate" ; "account" ]
@@ -200,22 +192,18 @@ let commands () =
        @@ ContractAlias.alias_param
          ~name:"src" ~desc: "name of the source contract"
        @@ stop)
-      (fun neu (_, manager) balance (_, source) ->
-         handle_error @@ fun () ->
-         check_contract neu >>= fun () ->
-         get_delegate_pkh !delegate >>= fun delegate ->
-         Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh ->
-         Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) ->
-         message "Got the source's manager keys (%s)." src_name >>= fun () ->
-         originate_account (block ()) ~force:!force
+      (fun neu (_, manager) balance (_, source) cctxt ->
+         check_contract cctxt neu >>= fun () ->
+         get_delegate_pkh cctxt !delegate >>= fun delegate ->
+         (Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh ->
+          Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) ->
+          cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () ->
+          originate_account cctxt (block ()) ~force:!force
             ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
             ~delegatable:!delegatable ~spendable:!spendable ?delegate:delegate
-           () >>=? fun contract ->
-         RawContractAlias.add neu contract >>= fun () ->
-         return ()) ;
-    command
-      ~group: "context"
-      ~desc: "open a new scripted account"
+            ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract ->
+         RawContractAlias.add cctxt neu contract) ;
+    command ~group ~desc: "open a new scripted account"
       ~args: ([ fee_arg ; delegate_arg ; force_arg ] @
               delegatable_args @ spendable_args @ [ init_arg ])
       (prefixes [ "originate" ; "contract" ]
@@ -235,22 +223,18 @@ let commands () =
          ~name:"prg" ~desc: "script of the account\n\
                              combine with -init if the storage type is non void"
        @@ stop)
-      (fun neu (_, manager) balance (_, source) code ->
-         handle_error @@ fun () ->
-         check_contract neu >>= fun () ->
-         get_delegate_pkh !delegate >>= fun delegate ->
-         Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh ->
-         Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) ->
-         message "Got the source's manager keys (%s)." src_name >>= fun () ->
-         originate_contract (block ()) ~force:!force
+      (fun neu (_, manager) balance (_, source) code cctxt ->
+         check_contract cctxt neu >>= fun () ->
+         get_delegate_pkh cctxt !delegate >>= fun delegate ->
+         (Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh ->
+          Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) ->
+          cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () ->
+          originate_contract cctxt (block ()) ~force:!force
             ~source ~src_pk ~src_sk ~manager_pkh:manager ~balance ~fee:!fee
-           ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init ()
-         >>=? fun contract ->
-         RawContractAlias.add neu contract >>= fun () ->
-         return ()) ;
-    command
-      ~group: "context"
-      ~desc: "transfer tokens"
+            ~delegatable:!delegatable ?delegatePubKey:delegate ~code ~init:!init
+            ()) >>= Client_proto_rpcs.handle_error cctxt >>= fun contract ->
+         RawContractAlias.add cctxt neu contract) ;
+    command ~group ~desc: "transfer tokens"
       ~args: [ fee_arg ; arg_arg ; force_arg ]
       (prefixes [ "transfer" ]
        @@ tez_param
@@ -262,11 +246,11 @@ let commands () =
        @@ ContractAlias.destination_param
          ~name: "dst" ~desc: "name/literal of the destination contract"
        @@ stop)
-      (fun amount (_, source) (_, destination) ->
-         handle_error @@ fun () ->
-         Client_proto_contracts.get_manager (block ()) source >>=? fun src_pkh ->
-         Client_keys.get_key src_pkh >>=? fun (src_name, src_pk, src_sk) ->
-         message "Got the source's manager keys (%s)." src_name >>= fun () ->
-         transfer (block ()) ~force:!force
-           ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ())
+      (fun amount (_, source) (_, destination) cctxt ->
+         (Client_proto_contracts.get_manager cctxt (block ()) source >>=? fun src_pkh ->
+         Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) ->
+         cctxt.message "Got the source's manager keys (%s)." src_name >>= fun () ->
+         transfer cctxt (block ()) ~force:!force
+           ~source ~src_pk ~src_sk ~destination ?arg:!arg ~amount ~fee:!fee ()) >>=
+         Client_proto_rpcs.handle_error cctxt)
   ]

src/client/embedded/bootstrap/client_proto_context.mli

@@ -8,6 +8,7 @@
 (**************************************************************************)
 
 val transfer:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?force:bool ->
   source:Contract.t ->
@@ -20,6 +21,7 @@ val transfer:
   unit -> unit tzresult Lwt.t
 
 val originate_account:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?force:bool ->
   source:Contract.t ->
@@ -34,6 +36,7 @@ val originate_account:
   unit -> Contract.t tzresult Lwt.t
 
 val originate_contract:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?force:bool ->
   source:Contract.t ->
@@ -48,4 +51,4 @@ val originate_contract:
   fee:Tez.t ->
   unit -> Contract.t tzresult Lwt.t
 
-val commands: unit -> Cli_entries.command list
+val commands: unit -> Client_commands.command list

src/client/embedded/bootstrap/client_proto_contracts.ml

@@ -12,44 +12,44 @@ module Ed25519 = Environment.Ed25519
 module RawContractAlias = Client_aliases.Alias (struct
     type t = Contract.t
     let encoding = Contract.encoding
-    let of_source s =
+    let of_source _ s =
       match Contract.of_b48check s with
       | Error _ -> Lwt.fail (Failure "bad contract notation")
       | Ok s -> Lwt.return s
-    let to_source s =
+    let to_source _ s =
       Lwt.return (Contract.to_b48check s)
     let name = "contract"
   end)
 
 module ContractAlias = struct
-  let find s =
-    RawContractAlias.find_opt s >>= function
+  let find cctxt s =
+    RawContractAlias.find_opt cctxt s >>= function
     | Some v -> Lwt.return (s, v)
     | None ->
-        Client_keys.Public_key_hash.find_opt s >>= function
+        Client_keys.Public_key_hash.find_opt cctxt s >>= function
         | Some v ->
             Lwt.return (s, Contract.default_contract v)
         | None ->
-            Cli_entries.error
+            cctxt.error
               "no contract alias nor key alias names %s" s
-  let find_key  name =
-    Client_keys.Public_key_hash.find name >>= fun v ->
+  let find_key cctxt name =
+    Client_keys.Public_key_hash.find cctxt name >>= fun v ->
     Lwt.return (name, Contract.default_contract v)
 
-  let rev_find c =
+  let rev_find cctxt c =
     match Contract.is_default c with
     | Some hash -> begin
-        Client_keys.Public_key_hash.rev_find hash >>= function
+        Client_keys.Public_key_hash.rev_find cctxt hash >>= function
         | Some name -> Lwt.return (Some ("key:" ^ name))
         | None -> Lwt.return_none
       end
-    | None -> RawContractAlias.rev_find c
+    | None -> RawContractAlias.rev_find cctxt c
 
-  let get_contract s =
+  let get_contract cctxt s =
     match Utils.split ~limit:1 ':' s with
     | [ "key" ; key ]->
-        find_key key
-    | _ -> find s
+        find_key cctxt key
+    | _ -> find cctxt s
 
   let alias_param ?(name = "name") ?(desc = "existing contract alias") next =
     let desc =
@@ -64,42 +64,42 @@ module ContractAlias = struct
       ^ "can be an alias, a key alias, or a literal (autodetected in this order)\n\
          use 'text:literal', 'alias:name', 'key:name' to force" in
     Cli_entries.param ~name ~desc
-      (fun s ->
+      (fun cctxt s ->
          match Utils.split ~limit:1 ':' s with
          | [ "alias" ; alias ]->
-             find alias
+             find cctxt alias
          | [ "key" ; text ] ->
-             Client_keys.Public_key_hash.find text >>= fun v ->
+             Client_keys.Public_key_hash.find cctxt text >>= fun v ->
              Lwt.return (s, Contract.default_contract v)
          | _ ->
              Lwt.catch
-               (fun () -> find s)
+               (fun () -> find cctxt s)
                (fun _ ->
                   match Contract.of_b48check s with
                   | Error _ -> Lwt.fail (Failure "bad contract notation")
                   | Ok v -> Lwt.return (s, v)))
       next
 
-   let name contract =
-     rev_find contract >|= function
+   let name cctxt contract =
+     rev_find cctxt contract >|= function
      | None -> Contract.to_b48check contract
      | Some name -> name
 
 end
 
-let get_manager block source =
+let get_manager cctxt block source =
   match Contract.is_default source with
   | Some hash -> return hash
-  | None -> Client_proto_rpcs.Context.Contract.manager block source
+  | None -> Client_proto_rpcs.Context.Contract.manager cctxt block source
 
-let get_delegate block source =
+let get_delegate cctxt block source =
   let open Client_keys in
   match Contract.is_default source with
   | Some hash -> return hash
   | None ->
-      Client_proto_rpcs.Context.Contract.delegate block source >>=? function
+      Client_proto_rpcs.Context.Contract.delegate cctxt block source >>=? function
       | Some delegate -> return delegate
-      | None -> Client_proto_rpcs.Context.Contract.manager block source
+      | None -> Client_proto_rpcs.Context.Contract.manager cctxt block source
 
 let may_check_key sourcePubKey sourcePubKeyHash =
   match sourcePubKey with
@@ -111,8 +111,8 @@ let may_check_key sourcePubKey sourcePubKeyHash =
         return ()
   | None -> return ()
 
-let check_public_key block ?src_pk src_pk_hash =
-  Client_proto_rpcs.Context.Key.get block src_pk_hash >>= function
+let check_public_key cctxt block ?src_pk src_pk_hash =
+  Client_proto_rpcs.Context.Key.get cctxt block src_pk_hash >>= function
   | Error errors ->
       begin
         match src_pk with
@@ -125,59 +125,51 @@ let check_public_key block ?src_pk src_pk_hash =
       end
   | Ok _ -> return None
 
+let group =
+  { Cli_entries.name = "contracts" ;
+    title = "Commands for managing the record of known contracts" }
+
 let commands  () =
   let open Cli_entries in
-  register_group "contracts"
-    "Commands for managing the record of known contracts" ;
   [
-    command
-      ~group: "contracts"
-      ~desc: "add a contract to the wallet"
+    command ~group ~desc: "add a contract to the wallet"
       (prefixes [ "remember" ; "contract" ]
        @@ RawContractAlias.fresh_alias_param
        @@ RawContractAlias.source_param
        @@ stop)
-      (fun name hash () -> RawContractAlias.add name hash) ;
-    command
-      ~group: "contracts"
-      ~desc: "remove a contract from the wallet"
+      (fun name hash cctxt -> RawContractAlias.add cctxt name hash) ;
+    command ~group ~desc: "remove a contract from the wallet"
       (prefixes [ "forget" ; "contract" ]
        @@ RawContractAlias.alias_param
        @@ stop)
-      (fun (name, _) () -> RawContractAlias.del name) ;
-    command
-      ~group: "contracts"
-      ~desc: "lists all known contracts"
+      (fun (name, _) cctxt -> RawContractAlias.del cctxt name) ;
+    command ~group ~desc: "lists all known contracts"
       (fixed [ "list" ; "known" ; "contracts" ])
-      (fun () ->
-         RawContractAlias.load () >>= fun list ->
+      (fun cctxt ->
+         RawContractAlias.load cctxt >>= fun list ->
          Lwt_list.iter_s (fun (n, v) ->
              let v = Contract.to_b48check v in
-             message "%s: %s" n v)
+             cctxt.message "%s: %s" n v)
            list >>= fun () ->
-         Client_keys.Public_key_hash.load () >>= fun list ->
+         Client_keys.Public_key_hash.load cctxt >>= fun list ->
          Lwt_list.iter_s (fun (n, v) ->
-             RawContractAlias.mem n >>= fun mem ->
+             RawContractAlias.mem cctxt n >>= fun mem ->
              let p = if mem then "key:" else "" in
              let v = Contract.to_b48check (Contract.default_contract v) in
-             message "%s%s: %s" p n v)
+             cctxt.message "%s%s: %s" p n v)
            list >>= fun () ->
          Lwt.return ()) ;
-    command
-      ~group: "contracts"
-      ~desc: "forget all known contracts"
+    command ~group ~desc: "forget all known contracts"
       (fixed [ "forget" ; "all" ; "contracts" ])
-      (fun () ->
+      (fun cctxt ->
          if not Client_config.force#get then
-           error "this can only used with option -force true"
+            cctxt.Client_commands.error "this can only used with option -force true"
          else
-           RawContractAlias.save []) ;
-    command
-      ~group: "contracts"
-      ~desc: "display a contract from the wallet"
+           RawContractAlias.save cctxt []) ;
+    command ~group ~desc: "display a contract from the wallet"
       (prefixes [ "show" ; "known" ; "contract" ]
        @@ RawContractAlias.alias_param
        @@ stop)
-      (fun (_, contract) () ->
-         Cli_entries.message "%a\n%!" Contract.pp contract) ;
+      (fun (_, contract) cctxt ->
+         cctxt.message "%a\n%!" Contract.pp contract) ;
   ]

src/client/embedded/bootstrap/client_proto_contracts.mli

@@ -11,35 +11,44 @@ module RawContractAlias :
   Client_aliases.Alias with type t = Contract.t
 
 module ContractAlias : sig
-  val get_contract: string -> (string * Contract.t) Lwt.t
+  val get_contract:
+    Client_commands.context ->
+    string -> (string * Contract.t) Lwt.t
   val alias_param:
     ?name:string ->
     ?desc:string ->
-    'a Cli_entries.params ->
-    (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params
+    ('a, Client_commands.context, unit) Cli_entries.params ->
+    (Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, unit) Cli_entries.params
   val destination_param:
     ?name:string ->
     ?desc:string ->
-    'a Cli_entries.params ->
-    (Lwt_io.file_name * Contract.t -> 'a) Cli_entries.params
-  val rev_find: Contract.t -> string option Lwt.t
-  val name: Contract.t -> string Lwt.t
+    ('a, Client_commands.context, unit) Cli_entries.params ->
+    (Lwt_io.file_name * Contract.t -> 'a, Client_commands.context, unit) Cli_entries.params
+  val rev_find:
+    Client_commands.context ->
+    Contract.t -> string option Lwt.t
+  val name:
+    Client_commands.context ->
+    Contract.t -> string Lwt.t
 end
 
 val get_manager:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   Contract.t ->
   public_key_hash tzresult Lwt.t
 
 val get_delegate:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   Contract.t ->
   public_key_hash tzresult Lwt.t
 
 val check_public_key :
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?src_pk:public_key ->
   public_key_hash ->
   public_key option tzresult Lwt.t
 
-val commands: unit -> Cli_entries.command list
+val commands: unit -> Client_commands.command list

src/client/embedded/bootstrap/client_proto_main.ml

@@ -12,7 +12,7 @@ let protocol =
     "4p64VagsbXchSF88eaPy5XrkqMLEjBCaSnaGv2vQkhv8e37Nnqmrd"
 
 let () =
-  Client_version.register protocol @@
+  Client_commands.register protocol @@
   Client_proto_programs.commands () @
   Client_proto_contracts.commands () @
   Client_proto_context.commands ()

src/client/embedded/bootstrap/client_proto_nonces.ml

@@ -23,17 +23,17 @@ let encoding : t Data_encoding.t =
 let filename () =
   Client_config.(base_dir#get // "nonces")
 
-let load () =
+let load cctxt =
   let filename = filename () in
   if not (Sys.file_exists filename) then
     Lwt.return []
   else
     Data_encoding_ezjsonm.read_file filename >>= function
-    | None -> error "couldn't to read the nonces file"
+    | None -> cctxt.Client_commands.error "couldn't to read the nonces file"
     | Some json ->
         match Data_encoding.Json.destruct encoding json with
         | exception _ -> (* TODO print_error *)
-            error "didn't understand the nonces file"
+            cctxt.Client_commands.error "didn't understand the nonces file"
         | list ->
             Lwt.return list
 
@@ -43,7 +43,7 @@ let check_dir dirname =
   else
     Lwt.return ()
 
-let save list =
+let save cctxt list =
   Lwt.catch
     (fun () ->
        let dirname = Client_config.base_dir#get in
@@ -54,29 +54,30 @@ let save list =
        | false -> failwith "Json.write_file"
        | true -> return ())
     (fun exn ->
-       error "could not write the nonces file: %s." (Printexc.to_string exn))
+       cctxt.Client_commands.error
+         "could not write the nonces file: %s." (Printexc.to_string exn))
 
-let mem block_hash =
-  load () >|= fun data ->
+let mem cctxt block_hash =
+  load cctxt >|= fun data ->
   List.mem_assoc block_hash data
 
-let find block_hash =
-  load () >|= fun data ->
+let find cctxt block_hash =
+  load cctxt >|= fun data ->
   try Some (List.assoc block_hash data)
   with Not_found -> None
 
-let add block_hash nonce =
-  load () >>= fun data ->
-  save ((block_hash, nonce) ::
+let add cctxt block_hash nonce =
+  load cctxt >>= fun data ->
+  save cctxt ((block_hash, nonce) ::
         List.remove_assoc block_hash data)
 
-let del block_hash =
-  load () >>= fun data ->
-  save (List.remove_assoc block_hash data)
+let del cctxt block_hash =
+  load cctxt >>= fun data ->
+  save cctxt (List.remove_assoc block_hash data)
 
-let dels hashes =
-  load () >>= fun data ->
-  save @@
+let dels cctxt hashes =
+  load cctxt >>= fun data ->
+  save cctxt @@
   List.fold_left
     (fun data hash -> List.remove_assoc hash data)
     data hashes

src/client/embedded/bootstrap/client_proto_nonces.mli

@@ -7,8 +7,18 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val mem: Block_hash.t -> bool Lwt.t
-val find: Block_hash.t -> Nonce.t option Lwt.t
-val add: Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
-val del: Block_hash.t -> unit tzresult Lwt.t
-val dels: Block_hash.t list -> unit tzresult Lwt.t
+val mem:
+  Client_commands.context ->
+  Block_hash.t -> bool Lwt.t
+val find:
+  Client_commands.context ->
+  Block_hash.t -> Nonce.t option Lwt.t
+val add:
+  Client_commands.context ->
+  Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
+val del:
+  Client_commands.context ->
+  Block_hash.t -> unit tzresult Lwt.t
+val dels:
+  Client_commands.context ->
+  Block_hash.t list -> unit tzresult Lwt.t

src/client/embedded/bootstrap/client_proto_programs.ml

@@ -10,7 +10,7 @@
 module Ed25519 = Environment.Ed25519
 open Client_proto_args
 
-let report_parse_error _prefix exn _lexbuf =
+let report_parse_error cctxt _prefix exn _lexbuf =
   let open Lexing in
   let open Script_located_ir in
   let print_loc ppf ((sl, sc), (el, ec)) =
@@ -29,17 +29,17 @@ let report_parse_error _prefix exn _lexbuf =
         sl sc el ec in
   match exn with
   | Missing_program_field n ->
-      Cli_entries.error "missing script %s" n
+      cctxt.Client_commands.error "missing script %s" n
   | Illegal_character (loc, c) ->
-      Cli_entries.error "%a, illegal character %C" print_loc loc c
+      cctxt.Client_commands.error "%a, illegal character %C" print_loc loc c
   | Illegal_escape (loc, c) ->
-      Cli_entries.error "%a, illegal escape sequence %S" print_loc loc c
+      cctxt.Client_commands.error "%a, illegal escape sequence %S" print_loc loc c
   | Failure s ->
-      Cli_entries.error "%s" s
+      cctxt.Client_commands.error "%s" s
   | exn ->
-      Cli_entries.error "%s" @@ Printexc.to_string exn
+      cctxt.Client_commands.error "%s" @@ Printexc.to_string exn
 
-let parse_program s =
+let parse_program cctxt s =
   let lexbuf = Lexing.from_string s in
   try
     Lwt.return
@@ -55,7 +55,7 @@ let parse_program s =
                 storage_type = get_field "storage" fields }
       )
   with
-  | exn -> report_parse_error "program: " exn lexbuf
+  | exn -> report_parse_error cctxt "program: " exn lexbuf
 
 let rec print_ir locations ppf node =
   let open Script in
@@ -99,23 +99,23 @@ let print_program locations ppf c =
     "@[<v 2>code@,%a@]"
     (print_ir locations) (c : Script.code).Script.code
 
-let parse_data s =
+let parse_data cctxt s =
   let lexbuf = Lexing.from_string s in
   try
     match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with
     | [node] -> Lwt.return (Script_located_ir.strip_locations node)
-    | _ -> Cli_entries.error "single data expression expected"
+    | _ -> cctxt.Client_commands.error "single data expression expected"
   with
-  | exn -> report_parse_error "data: " exn lexbuf
+  | exn -> report_parse_error cctxt "data: " exn lexbuf
 
-let parse_data_type s =
+let parse_data_type cctxt s =
   let lexbuf = Lexing.from_string s in
   try
     match Concrete_parser.tree Concrete_lexer.(token (init_state ())) lexbuf with
     | [node] -> Lwt.return (Script_located_ir.strip_locations node)
-    | _ -> Cli_entries.error "single type expression expected"
+    | _ -> cctxt.Client_commands.error "single type expression expected"
   with
-  | exn -> report_parse_error "data_type: " exn lexbuf
+  | exn -> report_parse_error cctxt "data_type: " exn lexbuf
 
 let unexpand_macros type_map program =
   let open Script in
@@ -159,11 +159,15 @@ let unexpand_macros type_map program =
 module Program = Client_aliases.Alias (struct
     type t = Script.code
     let encoding = Script.code_encoding
-    let of_source s = parse_program s
-    let to_source p = Lwt.return (Format.asprintf "%a" (print_program (fun _ -> false)) p)
+    let of_source cctxt s = parse_program cctxt s
+    let to_source _ p = Lwt.return (Format.asprintf "%a" (print_program (fun _ -> false)) p)
     let name = "program"
   end)
 
+let group =
+  { Cli_entries.name = "programs" ;
+    title = "Commands for managing the record of known programs" }
+
 let commands () =
   let open Cli_entries in
   let show_types = ref false in
@@ -176,41 +180,32 @@ let commands () =
     "-trace-stack",
     Arg.Set trace_stack,
     "Show the stack after each step" in
-  register_group "programs" "Commands for managing the record of known programs" ;
   [
-    command
-      ~group: "programs"
-      ~desc: "lists all known programs"
+    command ~group ~desc: "lists all known programs"
       (fixed [ "list" ; "known" ; "programs" ])
-      (fun () -> Program.load () >>= fun list ->
-        Lwt_list.iter_s (fun (n, _) -> message "%s" n) list) ;
-    command
-      ~group: "programs"
-      ~desc: "remember a program under some name"
+      (fun cctxt -> Program.load cctxt >>= fun list ->
+        Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list) ;
+    command ~group ~desc: "remember a program under some name"
       (prefixes [ "remember" ; "program" ]
        @@ Program.fresh_alias_param
        @@ Program.source_param
        @@ stop)
-      (fun name hash () -> Program.add name hash) ;
-    command
-      ~group: "programs"
-      ~desc: "forget a remembered program"
+      (fun name hash cctxt ->
+         Program.add cctxt name hash) ;
+    command ~group ~desc: "forget a remembered program"
       (prefixes [ "forget" ; "program" ]
        @@ Program.alias_param
        @@ stop)
-      (fun (name, _) () -> Program.del name) ;
-    command
-      ~group: "programs"
-      ~desc: "display a program"
+      (fun (name, _) cctxt ->
+         Program.del cctxt name) ;
+    command ~group ~desc: "display a program"
       (prefixes [ "show" ; "known" ; "program" ]
        @@ Program.alias_param
        @@ stop)
-      (fun (_, program) () ->
-         Program.to_source program >>= fun source ->
-         Cli_entries.message "%s\n" source) ;
-    command
-      ~group: "programs"
-      ~desc: "ask the node to run a program"
+      (fun (_, program) cctxt ->
+         Program.to_source cctxt program >>= fun source ->
+         cctxt.message "%s\n" source) ;
+    command ~group ~desc: "ask the node to run a program"
       ~args: [ trace_stack_arg ]
       (prefixes [ "run" ; "program" ]
        @@ Program.source_param
@@ -219,12 +214,13 @@ let commands () =
        @@ prefixes [ "and" ; "input" ]
        @@ Cli_entries.param ~name:"storage" ~desc:"the untagged input data" parse_data
        @@ stop)
-      (fun program storage input () ->
+      (fun program storage input cctxt ->
          let open Data_encoding in
          if !trace_stack then
-           Client_proto_rpcs.Helpers.trace_code (block ()) program (storage, input) >>= function
+           Client_proto_rpcs.Helpers.trace_code cctxt
+             (block ()) program (storage, input) >>= function
            | Ok (storage, output, trace) ->
-               Cli_entries.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
+               cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
                  (print_ir (fun _ -> false)) storage
                  (print_ir (fun _ -> false)) output
                  (Format.pp_print_list
@@ -237,37 +233,36 @@ let commands () =
                  trace
            | Error errs ->
                pp_print_error Format.err_formatter errs ;
-               error "error running program"
+               cctxt.error "error running program"
          else
-           Client_proto_rpcs.Helpers.run_code (block ()) program (storage, input) >>= function
+           Client_proto_rpcs.Helpers.run_code cctxt
+             (block ()) program (storage, input) >>= function
            | Ok (storage, output) ->
-               Cli_entries.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
+               cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
                  (print_ir (fun _ -> false)) storage
                  (print_ir (fun _ -> false)) output
            | Error errs ->
                pp_print_error Format.err_formatter errs ;
-               error "error running program") ;
-    command
-      ~group: "programs"
-      ~desc: "ask the node to typecheck a program"
+               cctxt.error "error running program") ;
+    command ~group ~desc: "ask the node to typecheck a program"
       ~args: [ show_types_arg ]
       (prefixes [ "typecheck" ; "program" ]
        @@ Program.source_param
        @@ stop)
-      (fun program () ->
+      (fun program cctxt ->
          let open Data_encoding in
-         Client_proto_rpcs.Helpers.typecheck_code (block ()) program >>= function
+         Client_proto_rpcs.Helpers.typecheck_code cctxt (block ()) program >>= function
          | Ok type_map ->
              let type_map, program = unexpand_macros type_map program in
-             message "Well typed" >>= fun () ->
+             cctxt.message "Well typed" >>= fun () ->
              if !show_types then begin
                print_program
                  (fun l -> List.mem_assoc l type_map)
                  Format.std_formatter program ;
-               Cli_entries.message "@." >>= fun () ->
+               cctxt.message "@." >>= fun () ->
                Lwt_list.iter_s
                  (fun (loc, (before, after)) ->
-                    Cli_entries.message
+                    cctxt.message
                       "%3d@[<v 0> : [ @[<v 0>%a ]@]@,-> [ @[<v 0>%a ]@]@]@."
                       loc
                       (Format.pp_print_list (print_ir (fun _ -> false)))
@@ -279,41 +274,38 @@ let commands () =
              else Lwt.return ()
          | Error errs ->
              pp_print_error Format.err_formatter errs ;
-             error "ill-typed program") ;
-    command
-      ~group: "programs"
-      ~desc: "ask the node to typecheck a tagged data expression"
+             cctxt.error "ill-typed program") ;
+    command ~group ~desc: "ask the node to typecheck a tagged data expression"
       (prefixes [ "typecheck" ; "data" ]
        @@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck" parse_data
        @@ prefixes [ "against" ; "type" ]
        @@ Cli_entries.param ~name:"type" ~desc:"the expected type" parse_data
        @@ stop)
-      (fun data exp_ty () ->
+      (fun data exp_ty cctxt ->
          let open Data_encoding in
-         Client_proto_rpcs.Helpers.typecheck_untagged_data
+         Client_proto_rpcs.Helpers.typecheck_untagged_data cctxt
            (block ()) (data, exp_ty) >>= function
          | Ok () ->
-             message "Well typed"
+             cctxt.message "Well typed"
          | Error errs ->
              pp_print_error Format.err_formatter errs ;
-             error "ill-typed data") ;
-    command
-      ~group: "programs"
+             cctxt.error "ill-typed data") ;
+    command ~group
       ~desc: "ask the node to compute the hash of an untagged data expression \
               using the same algorithm as script instruction H"
       (prefixes [ "hash" ; "data" ]
        @@ Cli_entries.param ~name:"data" ~desc:"the data to hash" parse_data
        @@ stop)
-      (fun data () ->
+      (fun data cctxt ->
          let open Data_encoding in
-         Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function
+         Client_proto_rpcs.Helpers.hash_data cctxt
+           (block ()) data >>= function
          | Ok hash ->
-             message "%S" hash
+             cctxt.message "%S" hash
          | Error errs ->
              pp_print_error Format.err_formatter errs ;
-             error "ill-formed data") ;
-    command
-      ~group: "programs"
+             cctxt.error "ill-formed data") ;
+    command ~group
       ~desc: "ask the node to compute the hash of an untagged data expression \
               using the same algorithm as script instruction H, sign it using \
               a given secret key, and display it using the format expected by \
@@ -323,17 +315,18 @@ let commands () =
        @@ prefixes [ "for" ]
        @@ Client_keys.Secret_key.alias_param
        @@ stop)
-      (fun data (_, key) () ->
+      (fun data (_, key) cctxt ->
          let open Data_encoding in
-         Client_proto_rpcs.Helpers.hash_data (block ()) data >>= function
+         Client_proto_rpcs.Helpers.hash_data cctxt
+           (block ()) data >>= function
          | Ok hash ->
              let signature = Ed25519.sign key (MBytes.of_string hash) in
-             message "Hash: %S@.Signature: %S"
+             cctxt.message "Hash: %S@.Signature: %S"
                hash
                (signature |>
                 Data_encoding.Binary.to_bytes Ed25519.signature_encoding |>
                 Hex_encode.hex_of_bytes)
          | Error errs ->
              pp_print_error Format.err_formatter errs ;
-             error "ill-formed data") ;
+             cctxt.error "ill-formed data") ;
   ]

src/client/embedded/bootstrap/client_proto_programs.mli

@@ -7,10 +7,16 @@
 (*                                                                        *)
 (**************************************************************************)
 
-val parse_program: string -> Script.code Lwt.t
-val parse_data: string -> Script.expr Lwt.t
-val parse_data_type: string -> Script.expr Lwt.t
+val parse_program:
+  Client_commands.context ->
+  string -> Script.code Lwt.t
+val parse_data:
+  Client_commands.context ->
+  string -> Script.expr Lwt.t
+val parse_data_type:
+  Client_commands.context ->
+  string -> Script.expr Lwt.t
 
 module Program : Client_aliases.Alias with type t = Script.code
 
-val commands: unit -> Cli_entries.command list
+val commands: unit -> Client_commands.command list

src/client/embedded/bootstrap/client_proto_rpcs.ml

@@ -10,11 +10,11 @@
 let string_of_errors exns =
   Format.asprintf "  @[<v>%a@]" pp_print_error exns
 
-let handle_error = function
+let handle_error cctxt = function
   | Ok res -> Lwt.return res
   | Error exns ->
       pp_print_error Format.err_formatter exns ;
-      Cli_entries.error "cannot continue"
+      cctxt.Client_commands.error "%s" "cannot continue"
 
 type net = State.net_id = Net of Block_hash.t
 type block = [
@@ -24,42 +24,46 @@ type block = [
   | `Hash of Block_hash.t
 ]
 
-let call_service1 s block a1 =
-  Client_node_rpcs.call_service1
+let call_service1 cctxt s block a1 =
+  Client_node_rpcs.call_service1 cctxt
     (s Node_rpc_services.Blocks.proto_path) block a1
-let call_error_service1 s block a1 =
-  call_service1 s block a1 >|= wrap_error
-let call_service2 s block a1 a2 =
-  Client_node_rpcs.call_service2
+let call_error_service1 cctxt s block a1 =
+  call_service1 cctxt s block a1 >|= wrap_error
+let call_service2 cctxt s block a1 a2 =
+  Client_node_rpcs.call_service2 cctxt
     (s Node_rpc_services.Blocks.proto_path) block a1 a2
-let call_error_service2 s block a1 a2 =
-  call_service2 s block a1 a2 >|= wrap_error
+let call_error_service2 cctxt s block a1 a2 =
+  call_service2 cctxt s block a1 a2 >|= wrap_error
 
 module Constants = struct
-  let bootstrap block = call_service1 Services.Constants.bootstrap block ()
-  let errors block = call_service1 Services.Constants.errors block ()
-  let cycle_length block =
-    call_error_service1 Services.Constants.cycle_length block ()
-  let voting_period_length block =
-    call_error_service1 Services.Constants.voting_period_length block ()
-  let time_before_reward block =
-    call_error_service1 Services.Constants.time_before_reward block ()
-  let time_between_slots block =
-    call_error_service1 Services.Constants.time_between_slots block ()
-  let first_free_mining_slot block =
-    call_error_service1 Services.Constants.first_free_mining_slot block ()
-  let max_signing_slot block =
-    call_error_service1 Services.Constants.max_signing_slot block ()
-  let instructions_per_transaction block =
-    call_error_service1 Services.Constants.instructions_per_transaction block ()
-  let stamp_threshold block =
-    call_error_service1 Services.Constants.proof_of_work_threshold block ()
+  let bootstrap cctxt block =
+    call_service1 cctxt Services.Constants.bootstrap block ()
+  let errors cctxt block =
+    call_service1 cctxt Services.Constants.errors block ()
+  let cycle_length cctxt block =
+    call_error_service1 cctxt Services.Constants.cycle_length block ()
+  let voting_period_length cctxt block =
+    call_error_service1 cctxt Services.Constants.voting_period_length block ()
+  let time_before_reward cctxt block =
+    call_error_service1 cctxt Services.Constants.time_before_reward block ()
+  let time_between_slots cctxt block =
+    call_error_service1 cctxt Services.Constants.time_between_slots block ()
+  let first_free_mining_slot cctxt block =
+    call_error_service1 cctxt Services.Constants.first_free_mining_slot block ()
+  let max_signing_slot cctxt block =
+    call_error_service1 cctxt Services.Constants.max_signing_slot block ()
+  let instructions_per_transaction cctxt block =
+    call_error_service1 cctxt Services.Constants.instructions_per_transaction block ()
+  let stamp_threshold cctxt block =
+    call_error_service1 cctxt Services.Constants.proof_of_work_threshold block ()
 end
 
 module Context = struct
 
-  let level block = call_error_service1 Services.Context.level block ()
-  let next_level block = call_error_service1 Services.Context.next_level block ()
+  let level cctxt block =
+    call_error_service1 cctxt Services.Context.level block ()
+  let next_level cctxt block =
+    call_error_service1 cctxt Services.Context.next_level block ()
 
   module Nonce = struct
 
@@ -68,27 +72,27 @@ module Context = struct
       | Missing of Nonce_hash.t
       | Forgotten
 
-    let get block level =
-      call_error_service2 Services.Context.Nonce.get block level ()
+    let get cctxt block level =
+      call_error_service2 cctxt Services.Context.Nonce.get block level ()
 
-    let hash block =
-      call_error_service1 Services.Context.Nonce.hash block ()
+    let hash cctxt block =
+      call_error_service1 cctxt Services.Context.Nonce.hash block ()
 
   end
 
   module Key = struct
 
-    let get block pk_h =
-      call_error_service2 Services.Context.Key.get block pk_h ()
+    let get cctxt block pk_h =
+      call_error_service2 cctxt Services.Context.Key.get block pk_h ()
 
-    let list block =
-      call_error_service1 Services.Context.Key.list block ()
+    let list cctxt block =
+      call_error_service1 cctxt Services.Context.Key.list block ()
 
   end
 
   module Contract = struct
-    let list b =
-      call_error_service1 Services.Context.Contract.list b ()
+    let list cctxt b =
+      call_error_service1 cctxt Services.Context.Contract.list b ()
     type info = Services.Context.Contract.info = {
       manager: public_key_hash ;
       balance: Tez.t ;
@@ -98,64 +102,68 @@ module Context = struct
       assets: Asset.Map.t ;
       counter: int32 ;
     }
-    let get b c =
-      call_error_service2 Services.Context.Contract.get b c ()
-    let balance b c =
-      call_error_service2 Services.Context.Contract.balance b c ()
-    let manager b c =
-      call_error_service2 Services.Context.Contract.manager b c ()
-    let delegate b c =
-      call_error_service2 Services.Context.Contract.delegate b c ()
-    let counter b c =
-      call_error_service2 Services.Context.Contract.counter b c ()
-    let spendable b c =
-      call_error_service2 Services.Context.Contract.spendable b c ()
-    let delegatable b c =
-      call_error_service2 Services.Context.Contract.delegatable b c ()
-    let script b c =
-      call_error_service2 Services.Context.Contract.script b c ()
-    let assets b c =
-      call_error_service2 Services.Context.Contract.assets b c ()
+    let get cctxt b c =
+      call_error_service2 cctxt Services.Context.Contract.get b c ()
+    let balance cctxt b c =
+      call_error_service2 cctxt Services.Context.Contract.balance b c ()
+    let manager cctxt b c =
+      call_error_service2 cctxt Services.Context.Contract.manager b c ()
+    let delegate cctxt b c =
+      call_error_service2 cctxt Services.Context.Contract.delegate b c ()
+    let counter cctxt b c =
+      call_error_service2 cctxt Services.Context.Contract.counter b c ()
+    let spendable cctxt b c =
+      call_error_service2 cctxt Services.Context.Contract.spendable b c ()
+    let delegatable cctxt b c =
+      call_error_service2 cctxt Services.Context.Contract.delegatable b c ()
+    let script cctxt b c =
+      call_error_service2 cctxt Services.Context.Contract.script b c ()
+    let assets cctxt b c =
+      call_error_service2 cctxt Services.Context.Contract.assets b c ()
   end
 
 end
 
 module Helpers = struct
 
-  let minimal_time block ?prio () =
-    call_error_service1 Services.Helpers.minimal_timestamp block prio
+  let minimal_time cctxt block ?prio () =
+    call_error_service1 cctxt Services.Helpers.minimal_timestamp block prio
 
-  let typecheck_code = call_error_service1 Services.Helpers.typecheck_code
+  let typecheck_code cctxt =
+    call_error_service1 cctxt Services.Helpers.typecheck_code
 
-  let run_code block code (storage, input) =
-    call_error_service1 Services.Helpers.run_code
+  let run_code cctxt block code (storage, input) =
+    call_error_service1 cctxt Services.Helpers.run_code
       block (code, storage, input, None, None)
 
-  let trace_code block code (storage, input) =
-    call_error_service1 Services.Helpers.trace_code
+  let trace_code cctxt block code (storage, input) =
+    call_error_service1 cctxt Services.Helpers.trace_code
       block (code, storage, input, None, None)
 
-  let typecheck_tagged_data = call_error_service1 Services.Helpers.typecheck_tagged_data
+  let typecheck_tagged_data cctxt =
+    call_error_service1 cctxt Services.Helpers.typecheck_tagged_data
 
-  let typecheck_untagged_data = call_error_service1 Services.Helpers.typecheck_untagged_data
+  let typecheck_untagged_data cctxt =
+    call_error_service1 cctxt Services.Helpers.typecheck_untagged_data
 
-  let hash_data = call_error_service1 Services.Helpers.hash_data
+  let hash_data cctxt =
+    call_error_service1 cctxt Services.Helpers.hash_data
 
-  let level block ?offset lvl =
-    call_error_service2 Services.Helpers.level block lvl offset
+  let level cctxt block ?offset lvl =
+    call_error_service2 cctxt Services.Helpers.level block lvl offset
 
-  let levels block cycle =
-    call_error_service2 Services.Helpers.levels block cycle ()
+  let levels cctxt block cycle =
+    call_error_service2 cctxt Services.Helpers.levels block cycle ()
 
   module Rights = struct
     type slot = Raw_level.t * int * Time.t option
-    let mining_rights_for_delegate
+    let mining_rights_for_delegate cctxt
         b c ?max_priority ?first_level ?last_level () =
-      call_error_service2 Services.Helpers.Rights.mining_rights_for_delegate
+      call_error_service2 cctxt Services.Helpers.Rights.mining_rights_for_delegate
       b c (max_priority, first_level, last_level)
-    let endorsement_rights_for_delegate
+    let endorsement_rights_for_delegate cctxt
         b c ?max_priority ?first_level ?last_level () =
-    call_error_service2 Services.Helpers.Rights.endorsement_rights_for_delegate
+    call_error_service2 cctxt Services.Helpers.Rights.endorsement_rights_for_delegate
       b c (max_priority, first_level, last_level)
   end
 
@@ -168,24 +176,24 @@ module Helpers = struct
     open Operation
 
     module Manager = struct
-      let operations
+      let operations cctxt
           block ~net ~source ?sourcePubKey ~counter ~fee operations =
         let ops =
           Manager_operations { source ; public_key = sourcePubKey ;
                                counter ; operations ; fee } in
-        (call_error_service1 Services.Helpers.Forge.operations block
+        (call_error_service1 cctxt Services.Helpers.Forge.operations block
            ({net_id=net}, Sourced_operations ops))
         >>=? fun (bytes, contracts) ->
         return (bytes, match contracts with None -> [] | Some l -> l)
-      let transaction
+      let transaction cctxt
           block ~net ~source ?sourcePubKey ~counter
           ~amount ~destination ?parameters ~fee ()=
-        operations block ~net ~source ?sourcePubKey ~counter ~fee
+        operations cctxt block ~net ~source ?sourcePubKey ~counter ~fee
           Tezos_context.[Transaction { amount ; parameters ; destination }]
         >>=? fun (bytes, contracts) ->
         assert (contracts = []) ;
         return bytes
-      let origination
+      let origination cctxt
           block ~net
           ~source ?sourcePubKey ~counter
           ~managerPubKey ~balance
@@ -193,7 +201,7 @@ module Helpers = struct
           ?(delegatable = true)
           ?delegatePubKey ?script ~fee () =
         let script = script_of_option script in
-        operations block ~net ~source ?sourcePubKey ~counter ~fee
+        operations cctxt block ~net ~source ?sourcePubKey ~counter ~fee
           Tezos_context.[
             Origination { manager = managerPubKey ;
                           delegate = delegatePubKey ;
@@ -206,54 +214,56 @@ module Helpers = struct
         match contracts with
         | [contract] -> return (contract, bytes)
         | _ -> assert false
-      let issuance
+      let issuance cctxt
           block ~net ~source ?sourcePubKey ~counter ~assetType ~quantity ~fee ()=
-        operations block ~net ~source ?sourcePubKey ~counter ~fee
+        operations cctxt block ~net ~source ?sourcePubKey ~counter ~fee
           Tezos_context.[Issuance { asset = assetType ; amount = quantity }]
         >>=? fun (bytes, contracts) ->
         assert (contracts = []) ;
         return bytes
-      let delegation
+      let delegation cctxt
           block ~net ~source ?sourcePubKey ~counter ~fee delegate =
-        operations block ~net ~source ?sourcePubKey ~counter ~fee
+        operations cctxt block ~net ~source ?sourcePubKey ~counter ~fee
           Tezos_context.[Delegation delegate]
         >>=? fun (bytes, contracts) ->
         assert (contracts = []) ;
         return bytes
     end
     module Delegate = struct
-      let operations
+      let operations cctxt
           block ~net ~source operations =
         let ops = Delegate_operations { source ; operations } in
-        (call_error_service1 Services.Helpers.Forge.operations block
+        (call_error_service1 cctxt Services.Helpers.Forge.operations block
            ({net_id=net}, Sourced_operations ops))
         >>=? fun (hash, _contracts) ->
         return hash
-      let endorsement b ~net ~source ~block ~slot () =
-        operations b ~net ~source
+      let endorsement cctxt
+          b ~net ~source ~block ~slot () =
+        operations cctxt b ~net ~source
           Tezos_context.[Endorsement { block ; slot }]
     end
     module Anonymous = struct
-      let operations block ~net operations =
-        (call_error_service1 Services.Helpers.Forge.operations block
+      let operations cctxt block ~net operations =
+        (call_error_service1 cctxt Services.Helpers.Forge.operations block
            ({net_id=net}, Anonymous_operations operations))
         >>=? fun (hash, _contracts) ->
         return hash
-      let seed_nonce_revelation
+      let seed_nonce_revelation cctxt
           block ~net ~level ~nonce () =
-        operations block ~net [Seed_nonce_revelation { level ; nonce }]
+        operations cctxt block ~net [Seed_nonce_revelation { level ; nonce }]
     end
-    let block
+    let block cctxt
         block ~net ~predecessor ~timestamp ~fitness ~operations
         ~level ~priority ~seed_nonce_hash ~proof_of_work_nonce () =
-      call_error_service1 Services.Helpers.Forge.block block
+      call_error_service1 cctxt Services.Helpers.Forge.block block
         (net, predecessor, timestamp, fitness, operations,
          level, priority, seed_nonce_hash, proof_of_work_nonce)
   end
 
   module Parse = struct
-    let operations block ?check shell bytes =
-      call_error_service1 Services.Helpers.Parse.operations block (shell, bytes, check)
+    let operations cctxt
+        block ?check shell bytes =
+      call_error_service1 cctxt Services.Helpers.Parse.operations block (shell, bytes, check)
   end
 
 end

src/client/embedded/bootstrap/client_proto_rpcs.mli

@@ -8,7 +8,7 @@
 (**************************************************************************)
 
 val string_of_errors: error list -> string
-val handle_error: 'a tzresult -> 'a Lwt.t
+val handle_error: Client_commands.context -> 'a tzresult -> 'a Lwt.t
 
 type net = State.net_id = Net of Block_hash.t
 
@@ -20,39 +20,71 @@ type block = [
 ]
 
 module Constants : sig
-  val errors: block -> Json_schema.schema Lwt.t
-  val bootstrap: block -> Bootstrap.account list Lwt.t
-  val cycle_length: block -> int32 tzresult Lwt.t
-  val voting_period_length: block -> int32 tzresult Lwt.t
-  val time_before_reward: block -> Period.t tzresult Lwt.t
-  val time_between_slots: block -> Period.t tzresult Lwt.t
-  val first_free_mining_slot: block -> int32 tzresult Lwt.t
-  val max_signing_slot: block -> int tzresult Lwt.t
-  val instructions_per_transaction: block -> int tzresult Lwt.t
-  val stamp_threshold: block -> int64 tzresult Lwt.t
+  val errors:
+    Client_commands.context ->
+    block -> Json_schema.schema Lwt.t
+  val bootstrap:
+    Client_commands.context ->
+    block -> Bootstrap.account list Lwt.t
+  val cycle_length:
+    Client_commands.context ->
+    block -> int32 tzresult Lwt.t
+  val voting_period_length:
+    Client_commands.context ->
+    block -> int32 tzresult Lwt.t
+  val time_before_reward:
+    Client_commands.context ->
+    block -> Period.t tzresult Lwt.t
+  val time_between_slots:
+    Client_commands.context ->
+    block -> Period.t tzresult Lwt.t
+  val first_free_mining_slot:
+    Client_commands.context ->
+    block -> int32 tzresult Lwt.t
+  val max_signing_slot:
+    Client_commands.context ->
+    block -> int tzresult Lwt.t
+  val instructions_per_transaction:
+    Client_commands.context ->
+    block -> int tzresult Lwt.t
+  val stamp_threshold:
+    Client_commands.context ->
+    block -> int64 tzresult Lwt.t
 end
 
 module Context : sig
-  val level: block -> Level.t tzresult Lwt.t
-  val next_level: block -> Level.t tzresult Lwt.t
+  val level:
+    Client_commands.context ->
+    block -> Level.t tzresult Lwt.t
+  val next_level:
+    Client_commands.context ->
+    block -> Level.t tzresult Lwt.t
   module Nonce : sig
-    val hash: block -> Nonce_hash.t tzresult Lwt.t
+    val hash:
+    Client_commands.context ->
+    block -> Nonce_hash.t tzresult Lwt.t
     type nonce_info =
       | Revealed of Nonce.t
       | Missing of Nonce_hash.t
       | Forgotten
-    val get: block -> Raw_level.t -> nonce_info tzresult Lwt.t
+    val get:
+    Client_commands.context ->
+    block -> Raw_level.t -> nonce_info tzresult Lwt.t
   end
   module Key : sig
     val get :
+      Client_commands.context ->
       block ->
       public_key_hash -> (public_key_hash * public_key) tzresult Lwt.t
     val list :
+      Client_commands.context ->
       block ->
       ((public_key_hash * public_key) list) tzresult Lwt.t
   end
   module Contract : sig
-    val list: block -> Contract.t list tzresult Lwt.t
+    val list:
+    Client_commands.context ->
+    block -> Contract.t list tzresult Lwt.t
     type info = {
       manager: public_key_hash ;
       balance: Tez.t ;
@@ -62,28 +94,38 @@ module Context : sig
       assets: Asset.Map.t ;
       counter: int32 ;
     }
-    val get: block -> Contract.t -> info tzresult Lwt.t
+    val get:
+      Client_commands.context ->
+      block -> Contract.t -> info tzresult Lwt.t
     val balance:
+      Client_commands.context ->
       block -> Contract.t ->
       Tez.t tzresult Lwt.t
     val manager:
+      Client_commands.context ->
       block -> Contract.t ->
       public_key_hash tzresult Lwt.t
     val delegate:
+      Client_commands.context ->
       block -> Contract.t ->
       public_key_hash option tzresult Lwt.t
     val counter:
+      Client_commands.context ->
       block -> Contract.t ->
       int32 tzresult Lwt.t
     val spendable:
+      Client_commands.context ->
       block -> Contract.t ->
       bool tzresult Lwt.t
     val delegatable:
+      Client_commands.context ->
       block -> Contract.t ->
       bool tzresult Lwt.t
     val script:
+      Client_commands.context ->
       block -> Contract.t -> Script.t tzresult Lwt.t
     val assets:
+      Client_commands.context ->
       block -> Contract.t ->
       Asset.Map.t tzresult Lwt.t
   end
@@ -91,29 +133,48 @@ end
 
 module Helpers : sig
   val minimal_time:
+    Client_commands.context ->
     block -> ?prio:int -> unit -> Time.t tzresult Lwt.t
-  val run_code: block -> Script.code ->
+  val run_code:
+    Client_commands.context ->
+    block -> Script.code ->
     (Script.expr * Script.expr) ->
     (Script.expr * Script.expr) tzresult Lwt.t
-  val trace_code: block -> Script.code ->
+  val trace_code:
+    Client_commands.context ->
+    block -> Script.code ->
     (Script.expr * Script.expr) ->
     (Script.expr * Script.expr *
      (Script.location * int * Script.expr list) list) tzresult Lwt.t
-  val typecheck_code: block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t
-  val typecheck_tagged_data: block -> Script.expr -> unit tzresult Lwt.t
-  val typecheck_untagged_data: block -> Script.expr * Script.expr -> unit tzresult Lwt.t
-  val hash_data: block -> Script.expr -> string tzresult Lwt.t
-  val level: block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t
-  val levels: block -> Cycle.t -> Level.t list tzresult Lwt.t
+  val typecheck_code:
+    Client_commands.context ->
+    block -> Script.code -> Script_ir_translator.type_map tzresult Lwt.t
+  val typecheck_tagged_data:
+    Client_commands.context ->
+    block -> Script.expr -> unit tzresult Lwt.t
+  val typecheck_untagged_data:
+    Client_commands.context ->
+    block -> Script.expr * Script.expr -> unit tzresult Lwt.t
+  val hash_data:
+    Client_commands.context ->
+    block -> Script.expr -> string tzresult Lwt.t
+  val level:
+    Client_commands.context ->
+    block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t
+  val levels:
+    Client_commands.context ->
+    block -> Cycle.t -> Level.t list tzresult Lwt.t
 
   module Rights : sig
     type slot = Raw_level.t * int * Time.t option
     val mining_rights_for_delegate:
+      Client_commands.context ->
       block -> public_key_hash ->
       ?max_priority:int -> ?first_level:Raw_level.t ->
       ?last_level:Raw_level.t -> unit ->
       (slot list) tzresult Lwt.t
     val endorsement_rights_for_delegate:
+      Client_commands.context ->
       block -> public_key_hash ->
       ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit ->
       (slot list) tzresult Lwt.t
@@ -122,6 +183,7 @@ module Helpers : sig
   module Forge : sig
     module Manager : sig
       val operations:
+        Client_commands.context ->
         block ->
         net:net ->
         source:Contract.t ->
@@ -131,6 +193,7 @@ module Helpers : sig
         manager_operation list ->
         (MBytes.t * Contract.t list) tzresult Lwt.t
       val transaction:
+        Client_commands.context ->
         block ->
         net:net ->
         source:Contract.t ->
@@ -142,6 +205,7 @@ module Helpers : sig
         fee:Tez.t ->
         unit -> MBytes.t tzresult Lwt.t
       val origination:
+        Client_commands.context ->
         block ->
         net:net ->
         source:Contract.t ->
@@ -157,6 +221,7 @@ module Helpers : sig
         unit ->
         (Contract.t * MBytes.t) tzresult Lwt.t
       val issuance:
+        Client_commands.context ->
         block ->
         net:net ->
         source:Contract.t ->
@@ -167,6 +232,7 @@ module Helpers : sig
         fee:Tez.t ->
         unit -> MBytes.t tzresult Lwt.t
       val delegation:
+        Client_commands.context ->
         block ->
         net:net ->
         source:Contract.t ->
@@ -178,12 +244,14 @@ module Helpers : sig
     end
     module Delegate : sig
       val operations:
+        Client_commands.context ->
         block ->
         net:net ->
         source:public_key ->
         delegate_operation list ->
         MBytes.t tzresult Lwt.t
       val endorsement:
+        Client_commands.context ->
         block ->
         net:net ->
         source:public_key ->
@@ -193,11 +261,13 @@ module Helpers : sig
     end
     module Anonymous : sig
       val operations:
+        Client_commands.context ->
         block ->
         net:net ->
         anonymous_operation list ->
         MBytes.t tzresult Lwt.t
       val seed_nonce_revelation:
+        Client_commands.context ->
         block ->
         net:net ->
         level:Raw_level.t ->
@@ -205,6 +275,7 @@ module Helpers : sig
         unit -> MBytes.t tzresult Lwt.t
     end
     val block:
+      Client_commands.context ->
       block ->
       net:net ->
       predecessor:Block_hash.t ->
@@ -220,6 +291,7 @@ module Helpers : sig
 
   module Parse : sig
     val operations:
+      Client_commands.context ->
       block -> ?check:bool -> Updater.shell_operation -> MBytes.t ->
       proto_operation tzresult Lwt.t
   end

src/client/embedded/bootstrap/mining/client_mining_blocks.ml

@@ -16,25 +16,25 @@ type block_info = {
   level: Level.t ;
 }
 
-let convert_block_info
+let convert_block_info cctxt
     ( { hash ; predecessor ; fitness ; timestamp ; protocol }
       : Client_node_rpcs.Blocks.block_info ) =
-  Client_proto_rpcs.Context.level (`Hash hash) >>= function
+  Client_proto_rpcs.Context.level cctxt (`Hash hash) >>= function
   | Ok level ->
       Lwt.return (Some { hash ; predecessor ; fitness ; timestamp ; protocol ; level })
   | Error _ ->
       (* TODO log error *)
       Lwt.return_none
 
-let convert_block_info_err
+let convert_block_info_err cctxt
     ( { hash ; predecessor ; fitness ; timestamp ; protocol }
       : Client_node_rpcs.Blocks.block_info ) =
-  Client_proto_rpcs.Context.level (`Hash hash) >>=? fun level ->
+  Client_proto_rpcs.Context.level cctxt (`Hash hash) >>=? fun level ->
   return { hash ; predecessor ; fitness ; timestamp ; protocol ; level }
 
-let info ?operations block =
-  Client_node_rpcs.Blocks.info ?operations block >>= fun block ->
-  convert_block_info_err block
+let info cctxt ?operations block =
+  Client_node_rpcs.Blocks.info cctxt ?operations block >>= fun block ->
+  convert_block_info_err cctxt block
 
 let compare (bi1 : block_info) (bi2 : block_info) =
   match Fitness.compare bi1.fitness bi2.fitness with
@@ -49,29 +49,29 @@ let compare (bi1 : block_info) (bi2 : block_info) =
     end
   | x -> x
 
-let sort_blocks ?(compare = compare) blocks =
-  Lwt_list.map_p convert_block_info blocks >|= fun blocks ->
+let sort_blocks cctxt ?(compare = compare) blocks =
+  Lwt_list.map_p (convert_block_info cctxt) blocks >|= fun blocks ->
   let blocks = Utils.unopt_list blocks in
   List.sort compare blocks
 
-let monitor
+let monitor cctxt
     ?operations ?length ?heads ?delay
     ?min_date ?min_heads ?compare () =
-  Client_node_rpcs.Blocks.monitor
+  Client_node_rpcs.Blocks.monitor cctxt
     ?operations ?length ?heads ?delay ?min_date ?min_heads
     () >>= fun block_stream ->
-  let convert blocks = sort_blocks ?compare (List.flatten blocks) in
+  let convert blocks = sort_blocks cctxt ?compare (List.flatten blocks) in
   Lwt.return (Lwt_stream.map_s convert block_stream)
 
-let blocks_from_cycle block cycle =
+let blocks_from_cycle cctxt block cycle =
   let block =
     match block with
     | `Prevalidation -> `Head 0
     | `Test_prevalidation -> `Test_head 0
     | _ -> block in
-  Client_node_rpcs.Blocks.hash block >>= fun block_hash ->
-  Client_proto_rpcs.Context.level block >>=? fun level ->
-  Client_proto_rpcs.Helpers.levels block cycle >>=? fun block_levels ->
+  Client_node_rpcs.Blocks.hash cctxt block >>= fun block_hash ->
+  Client_proto_rpcs.Context.level cctxt block >>=? fun level ->
+  Client_proto_rpcs.Helpers.levels cctxt block cycle >>=? fun block_levels ->
   begin
     match List.sort Level.compare block_levels with
     | [] -> failwith "Internal error"
@@ -79,11 +79,11 @@ let blocks_from_cycle block cycle =
   end >>=? fun min_level ->
   let length = 1 + Int32.to_int (Level.diff level min_level) in
   begin
-    Client_node_rpcs.Blocks.list ~length ~heads:[block_hash] () >>= function
+    Client_node_rpcs.Blocks.list cctxt ~length ~heads:[block_hash] () >>= function
     | [] | _::_::_ -> failwith "Unexpected RPC result"
     | [blocks] -> return blocks
   end >>=? fun block_infos ->
   let block_infos =
     Utils.remove_elem_from_list (length - List.length block_levels) block_infos in
-  map_s convert_block_info_err block_infos >>=? fun block_res ->
+  map_s (convert_block_info_err cctxt) block_infos >>=? fun block_res ->
   return block_res

src/client/embedded/bootstrap/mining/client_mining_blocks.mli

@@ -17,17 +17,21 @@ type block_info = {
 }
 
 val info:
+  Client_commands.context ->
   ?operations:bool -> Client_node_rpcs.Blocks.block -> block_info tzresult Lwt.t
 
-val compare: block_info -> block_info -> int
+val compare:
+  block_info -> block_info -> int
 
 val monitor:
+  Client_commands.context ->
   ?operations:bool -> ?length:int -> ?heads:Block_hash.t list ->
   ?delay:int -> ?min_date:Time.t -> ?min_heads:int ->
   ?compare:(block_info -> block_info -> int) ->
   unit -> block_info list Lwt_stream.t Lwt.t
 
 val blocks_from_cycle:
+  Client_commands.context ->
   Client_node_rpcs.Blocks.block ->
   Cycle.t ->
   block_info list tzresult Lwt.t

src/client/embedded/bootstrap/mining/client_mining_daemon.ml

@@ -9,27 +9,27 @@
 
 open Logging.Client.Mining
 
-let run ?max_priority ~delay ?min_date delegates =
+let run cctxt ?max_priority ~delay ?min_date delegates =
   (* TODO really detach... *)
   let endorsement =
     if Client_proto_args.Daemon.(!all || !endorsement) then
-      Client_mining_blocks.monitor ?min_date () >>= fun block_stream ->
-      Client_mining_endorsement.create ~delay delegates block_stream
+      Client_mining_blocks.monitor cctxt ?min_date () >>= fun block_stream ->
+      Client_mining_endorsement.create cctxt ~delay delegates block_stream
     else
       Lwt.return_unit
   in
   let denunciation =
     if Client_proto_args.Daemon.(!all || !denunciation) then
-      Client_mining_operations.monitor_endorsement () >>= fun endorsement_stream ->
-      Client_mining_denunciation.create endorsement_stream
+      Client_mining_operations.monitor_endorsement cctxt >>= fun endorsement_stream ->
+      Client_mining_denunciation.create cctxt endorsement_stream
     else
       Lwt.return_unit
   in
   let forge =
-    Client_mining_blocks.monitor ?min_date () >>= fun block_stream ->
-    Client_mining_operations.monitor_endorsement () >>= fun endorsement_stream ->
+    Client_mining_blocks.monitor cctxt ?min_date () >>= fun block_stream ->
+    Client_mining_operations.monitor_endorsement cctxt >>= fun endorsement_stream ->
     if Client_proto_args.Daemon.(!all || !mining) then
-      Client_mining_forge.create
+      Client_mining_forge.create cctxt
         ?max_priority delegates block_stream endorsement_stream
     else
       Lwt.return_unit

src/client/embedded/bootstrap/mining/client_mining_daemon.mli

@@ -8,6 +8,7 @@
 (**************************************************************************)
 
 val run:
+  Client_commands.context ->
   ?max_priority: int ->
   delay: int ->
   ?min_date: Time.t ->

src/client/embedded/bootstrap/mining/client_mining_denunciation.ml

@@ -9,7 +9,7 @@
 
 open Logging.Client.Denunciation
 
-let create endorsement_stream =
+let create cctxt endorsement_stream =
   let last_get_endorsement = ref None in
   let get_endorsement () =
     match !last_get_endorsement with
@@ -28,7 +28,7 @@ let create endorsement_stream =
         Lwt.return_unit
     | `Endorsement (Some e) ->
         last_get_endorsement := None ;
-        Client_keys.Public_key_hash.name
+        Client_keys.Public_key_hash.name cctxt
           e.Client_mining_operations.source >>= fun source ->
         lwt_debug
           "Discovered endorsement for block %a by %s (slot @[<h>%a@])"

src/client/embedded/bootstrap/mining/client_mining_denunciation.mli

@@ -8,5 +8,6 @@
 (**************************************************************************)
 
 val create:
+  Client_commands.context ->
   Client_mining_operations.valid_endorsement Lwt_stream.t ->
   unit Lwt.t

src/client/embedded/bootstrap/mining/client_mining_endorsement.ml

@@ -15,11 +15,13 @@ module Ed25519 = Environment.Ed25519
 module State : sig
 
   val get_endorsement:
+    Client_commands.context ->
     Raw_level.t ->
     int ->
     (Block_hash.t * Operation_hash.t) option tzresult Lwt.t
 
   val record_endorsement:
+    Client_commands.context ->
     Raw_level.t ->
     Block_hash.t ->
     int -> Operation_hash.t -> unit tzresult Lwt.t
@@ -45,20 +47,20 @@ end = struct
   let filename () =
     Client_config.(base_dir#get // "endorsements")
 
-  let load () =
+  let load cctxt =
     let filename = filename () in
     if not (Sys.file_exists filename) then return LevelMap.empty else
       Data_encoding_ezjsonm.read_file filename >>= function
       | None ->
-          error "couldn't to read the endorsement file"
+          cctxt.Client_commands.error "couldn't to read the endorsement file"
       | Some json ->
           match Data_encoding.Json.destruct encoding json with
           | exception _ -> (* TODO print_error *)
-              error "didn't understand the endorsement file"
+              cctxt.Client_commands.error "didn't understand the endorsement file"
           | map ->
               return map
 
-  let save map =
+  let save cctxt map =
     Lwt.catch
       (fun () ->
          let dirname = Client_config.base_dir#get in
@@ -70,15 +72,15 @@ end = struct
          | false -> failwith "Json.write_file"
          | true -> return ())
       (fun exn ->
-         error "could not write the endorsement file: %s."
+         cctxt.Client_commands.error "could not write the endorsement file: %s."
            (Printexc.to_string exn))
 
   let lock = Lwt_mutex.create ()
 
-  let get_endorsement level slot =
+  let get_endorsement cctxt level slot =
     Lwt_mutex.with_lock lock
       (fun () ->
-         load () >>=? fun map ->
+         load cctxt >>=? fun map ->
          try
            let _, block, op =
              LevelMap.find level map
@@ -86,27 +88,27 @@ end = struct
            return (Some (block, op))
          with Not_found -> return None)
 
-  let record_endorsement level hash slot oph =
+  let record_endorsement cctxt level hash slot oph =
     Lwt_mutex.with_lock lock
       (fun () ->
-         load () >>=? fun map ->
+         load cctxt >>=? fun map ->
          let previous =
            try LevelMap.find level map
            with Not_found -> [] in
-         save
+         save cctxt
            (LevelMap.add level ((slot, hash, oph) :: previous) map))
 
 end
 
-let get_block_hash = function
+let get_block_hash cctxt = function
   | `Hash hash -> Lwt.return hash
   | `Genesis | `Head _ | `Test_head _ as block ->
-      Client_node_rpcs.Blocks.hash block
-  | `Prevalidation -> Client_node_rpcs.Blocks.hash (`Head 0)
-  | `Test_prevalidation -> Client_node_rpcs.Blocks.hash (`Test_head 0)
+      Client_node_rpcs.Blocks.hash cctxt block
+  | `Prevalidation -> Client_node_rpcs.Blocks.hash cctxt (`Head 0)
+  | `Test_prevalidation -> Client_node_rpcs.Blocks.hash cctxt (`Test_head 0)
 
-let get_signing_slots ?max_priority block delegate level =
-  Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate
+let get_signing_slots cctxt ?max_priority block delegate level =
+  Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate cctxt
     ?max_priority ~first_level:level ~last_level:level
     block delegate () >>=? fun possibilities ->
   let slots =
@@ -114,12 +116,12 @@ let get_signing_slots ?max_priority block delegate level =
     @@ List.filter (fun (l, _, _) -> l = level) possibilities in
   return slots
 
-let inject_endorsement
+let inject_endorsement cctxt
     block level ?wait ?force
     src_sk source slot =
-  get_block_hash block >>= fun block_hash ->
-  Client_node_rpcs.Blocks.net block >>= fun net ->
-  Client_proto_rpcs.Helpers.Forge.Delegate.endorsement
+  get_block_hash cctxt block >>= fun block_hash ->
+  Client_node_rpcs.Blocks.net cctxt block >>= fun net ->
+  Client_proto_rpcs.Helpers.Forge.Delegate.endorsement cctxt
     block
     ~net
     ~source
@@ -127,41 +129,41 @@ let inject_endorsement
     ~slot:slot
     () >>=? fun bytes ->
   let signed_bytes = Ed25519.append_signature src_sk bytes in
-  Client_node_rpcs.inject_operation ?force ?wait signed_bytes >>=? fun oph ->
-  State.record_endorsement level block_hash slot oph >>=? fun () ->
+  Client_node_rpcs.inject_operation cctxt ?force ?wait signed_bytes >>=? fun oph ->
+  State.record_endorsement cctxt level block_hash slot oph >>=? fun () ->
   return oph
 
 
-let previously_endorsed_slot level slot =
-  State.get_endorsement level slot >>=? function
+let previously_endorsed_slot cctxt level slot =
+  State.get_endorsement cctxt level slot >>=? function
   | None -> return false
   | Some _ -> return true
 
-let check_endorsement level slot =
-  State.get_endorsement level slot >>=? function
+let check_endorsement cctxt level slot =
+  State.get_endorsement cctxt level slot >>=? function
   | None -> return ()
   | Some (block, _) ->
-      failwith
+      Error_monad.failwith
         "Already signed block %a at level %a, slot %d"
         Block_hash.pp_short block Raw_level.pp level slot
 
 
-let forge_endorsement
+let forge_endorsement cctxt
     block ?(force = false)
     ~src_sk ?slot ?max_priority src_pk =
   let src_pkh = Ed25519.hash src_pk in
-  Client_proto_rpcs.Context.next_level block >>=? fun level ->
+  Client_proto_rpcs.Context.next_level cctxt block >>=? fun level ->
   let level = Raw_level.succ @@ level.level in
   begin
     match slot with
     | Some slot -> return slot
     | None ->
-        get_signing_slots ?max_priority block src_pkh level >>=? function
+        get_signing_slots cctxt ?max_priority block src_pkh level >>=? function
         | slot::_ -> return slot
-        | [] -> error "No slot found at level %a" Raw_level.pp level
+        | [] -> cctxt.error "No slot found at level %a" Raw_level.pp level
   end >>=? fun slot ->
-  (if force then return () else check_endorsement level slot) >>=? fun () ->
-  inject_endorsement
+  (if force then return () else check_endorsement cctxt level slot) >>=? fun () ->
+  inject_endorsement cctxt
     block level ~wait:true ~force
     src_sk src_pk slot
 
@@ -194,19 +196,19 @@ let rec insert ({time} as e) = function
       e :: l
   | e' :: l -> e' :: insert e l
 
-let schedule_endorsements state bis =
+let schedule_endorsements cctxt state bis =
   let may_endorse (block: Client_mining_blocks.block_info) delegate time =
-    Client_keys.Public_key_hash.name delegate >>= fun name ->
+    Client_keys.Public_key_hash.name cctxt delegate >>= fun name ->
     lwt_log_info "May endorse block %a for %s"
       Block_hash.pp_short block.hash name >>= fun () ->
     let b = `Hash block.hash in
     let level = Raw_level.succ block.level.level in
-    get_signing_slots b delegate level >>=? fun slots ->
+    get_signing_slots cctxt b delegate level >>=? fun slots ->
     lwt_debug "Found slots for %a/%s (%d)"
       Block_hash.pp_short block.hash name (List.length slots) >>= fun () ->
     iter_p
       (fun slot ->
-         previously_endorsed_slot level slot >>=? function
+         previously_endorsed_slot cctxt level slot >>=? function
          | true ->
              lwt_debug "slot %d: previously endorsed." slot >>= fun () ->
              return ()
@@ -270,23 +272,23 @@ let pop_endorsements state =
   state.to_endorse <- future_endorsement ;
   to_endorse
 
-let endorse state =
+let endorse cctxt state =
   let to_endorse = pop_endorsements state in
   iter_p
     (fun {delegate;block;slot} ->
        let hash = block.hash in
        let b = `Hash hash in
        let level = Raw_level.succ block.level.level in
-       previously_endorsed_slot level slot >>=? function
+       previously_endorsed_slot cctxt level slot >>=? function
        | true -> return ()
        | false ->
-           Client_keys.get_key delegate >>=? fun (name, pk, sk) ->
+           Client_keys.get_key cctxt delegate >>=? fun (name, pk, sk) ->
            lwt_debug "Endorsing %a for %s (slot %d)!"
              Block_hash.pp_short hash name slot >>= fun () ->
-           inject_endorsement
+           inject_endorsement cctxt
              b level ~wait:false ~force:true
              sk pk slot >>=? fun oph ->
-           message
+           cctxt.message
              "Injected endorsement for block '%a' \
              \ (level %a, slot %d, contract %s) '%a'"
              Block_hash.pp_short hash
@@ -306,11 +308,11 @@ let compute_timeout state =
       else
         Lwt_unix.sleep (Int64.to_float delay)
 
-let create ~delay contracts block_stream =
+let create cctxt ~delay contracts block_stream =
   lwt_log_info "Starting endorsement daemon" >>= fun () ->
   Lwt_stream.get block_stream >>= function
   | None | Some [] ->
-      error "Can't fetch the current block head."
+      cctxt.Client_commands.error "Can't fetch the current block head."
   | Some ({ Client_mining_blocks.fitness } :: _ as initial_heads) ->
       let last_get_block = ref None in
       let get_block () =
@@ -330,11 +332,11 @@ let create ~delay contracts block_stream =
         | `Hash (Some bis) ->
             Lwt.cancel timeout ;
             last_get_block := None ;
-            schedule_endorsements state bis >>= fun () ->
+            schedule_endorsements cctxt state bis >>= fun () ->
             worker_loop ()
         | `Timeout ->
             begin
-              endorse state >>= function
+              endorse cctxt state >>= function
               | Ok () -> Lwt.return_unit
               | Error errs ->
                   lwt_log_error "Error while endorsing:\n%a"
@@ -343,5 +345,5 @@ let create ~delay contracts block_stream =
                   Lwt.return_unit
             end >>= fun () ->
             worker_loop () in
-      schedule_endorsements state initial_heads >>= fun () ->
+      schedule_endorsements cctxt state initial_heads >>= fun () ->
       worker_loop ()

src/client/embedded/bootstrap/mining/client_mining_endorsement.mli

@@ -8,6 +8,7 @@
 (**************************************************************************)
 
 val forge_endorsement:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?force:bool ->
   src_sk:secret_key ->
@@ -17,6 +18,7 @@ val forge_endorsement:
   Operation_hash.t tzresult Lwt.t
 
 val create:
+  Client_commands.context ->
   delay: int ->
   public_key_hash list ->
   Client_mining_blocks.block_info list Lwt_stream.t ->

src/client/embedded/bootstrap/mining/client_mining_forge.ml

@@ -19,8 +19,8 @@ let generate_seed_nonce () =
   | Error _ -> assert false
   | Ok nonce -> nonce
 
-let rec compute_stamp block delegate_sk shell mining_slot seed_nonce_hash =
-  Client_proto_rpcs.Constants.stamp_threshold block >>=? fun stamp_threshold ->
+let rec compute_stamp cctxt block delegate_sk shell mining_slot seed_nonce_hash =
+  Client_proto_rpcs.Constants.stamp_threshold cctxt block >>=? fun stamp_threshold ->
   let rec loop () =
     let proof_of_work_nonce = generate_proof_of_work_nonce () in
     let unsigned_header =
@@ -35,21 +35,21 @@ let rec compute_stamp block delegate_sk shell mining_slot seed_nonce_hash =
       loop () in
   return (loop ())
 
-let inject_block block
+let inject_block cctxt block
     ?force
     ~priority ~timestamp ~fitness ~seed_nonce
     ~src_sk operations =
   let block = match block with `Prevalidation -> `Head 0 | block -> block in
-  Client_node_rpcs.Blocks.info block >>= fun bi ->
+  Client_node_rpcs.Blocks.info cctxt block >>= fun bi ->
   let seed_nonce_hash = Nonce.hash seed_nonce in
-  Client_proto_rpcs.Context.next_level block >>=? fun level ->
+  Client_proto_rpcs.Context.next_level cctxt block >>=? fun level ->
   let shell =
     { Store.net_id = bi.net ; predecessor = bi.hash ;
       timestamp ; fitness ; operations } in
   let slot = level.level, Int32.of_int priority in
-  compute_stamp block
+  compute_stamp cctxt block
     src_sk shell slot seed_nonce_hash >>=? fun proof_of_work_nonce ->
-  Client_proto_rpcs.Helpers.Forge.block
+  Client_proto_rpcs.Helpers.Forge.block cctxt
     block
     ~net:bi.net
     ~predecessor:bi.hash
@@ -62,11 +62,11 @@ let inject_block block
     ~proof_of_work_nonce
     () >>=? fun unsigned_header ->
   let signed_header = Ed25519.append_signature src_sk unsigned_header in
-  Client_node_rpcs.inject_block
+  Client_node_rpcs.inject_block cctxt
     ~wait:true ?force signed_header >>=? fun block_hash ->
   return block_hash
 
-let forge_block block
+let forge_block cctxt block
     ?force
     ?operations ?(best_effort = operations = None) ?(sort = best_effort)
     ?timestamp ?max_priority ?priority
@@ -76,12 +76,12 @@ let forge_block block
     | `Prevalidation -> `Head 0
     | `Test_prevalidation -> `Test_head 0
     | block -> block in
-  Client_proto_rpcs.Context.level block >>=? fun level ->
+  Client_proto_rpcs.Context.level cctxt block >>=? fun level ->
   let level = Raw_level.succ level.level in
   begin
     match operations with
     | None ->
-        Client_node_rpcs.Blocks.pending_operations block >|= fun (ops, pendings) ->
+        Client_node_rpcs.Blocks.pending_operations cctxt block >|= fun (ops, pendings) ->
         Operation_hash_set.elements @@
         Operation_hash_set.union (Updater.operations ops) pendings
     | Some operations -> Lwt.return operations
@@ -89,11 +89,11 @@ let forge_block block
   begin
     match priority with
     | Some prio -> begin
-        Client_proto_rpcs.Helpers.minimal_time block ~prio () >>=? fun time ->
+        Client_proto_rpcs.Helpers.minimal_time cctxt block ~prio () >>=? fun time ->
         return (prio, Some time)
       end
     | None ->
-        Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate
+        Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate cctxt
           ?max_priority
           ~first_level:level
           ~last_level:level
@@ -103,7 +103,7 @@ let forge_block block
             List.find (fun (l,_,_) -> l = level) possibilities in
           return (prio, time)
         with Not_found ->
-          failwith "No slot found at level %a" Raw_level.pp level
+          Error_monad.failwith "No slot found at level %a" Raw_level.pp level
   end >>=? fun (priority, minimal_timestamp) ->
   lwt_log_info "Mining block at level %a prio %d"
     Raw_level.pp level priority >>= fun () ->
@@ -113,7 +113,7 @@ let forge_block block
     | None, timestamp | timestamp, None -> return timestamp
     | Some timestamp, Some minimal_timestamp ->
         if timestamp < minimal_timestamp then
-          failwith
+          Error_monad.failwith
             "Proposed timestamp %a is earlier than minimal timestamp %a"
             Time.pp_hum timestamp
             Time.pp_hum minimal_timestamp
@@ -121,7 +121,7 @@ let forge_block block
           return (Some timestamp)
   end >>=? fun timestamp ->
   let request = List.length operations in
-  Client_node_rpcs.Blocks.preapply block ?timestamp ~sort operations >>=?
+  Client_node_rpcs.Blocks.preapply cctxt block ?timestamp ~sort operations >>=?
   fun { operations ; fitness ; timestamp } ->
   let valid = List.length operations.applied in
   lwt_log_info "Found %d valid operations (%d refused) for timestamp %a"
@@ -132,7 +132,7 @@ let forge_block block
      || ( Operation_hash_map.is_empty operations.refused
           && Operation_hash_map.is_empty operations.branch_refused
           && Operation_hash_map.is_empty operations.branch_delayed ) then
-    inject_block ?force ~src_sk
+    inject_block cctxt ?force ~src_sk
        ~priority ~timestamp ~fitness ~seed_nonce block operations.applied
   else
     failwith "Cannot (fully) validate the given operations."
@@ -143,9 +143,11 @@ let forge_block block
 module State : sig
 
   val get_block:
+    Client_commands.context ->
     Raw_level.t -> Block_hash.t list tzresult Lwt.t
 
   val record_block:
+    Client_commands.context ->
     Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
 
 end = struct
@@ -190,13 +192,13 @@ end = struct
          | false -> failwith "Json.write_file"
          | true -> return ())
       (fun exn ->
-         failwith
+         Error_monad.failwith
            "could not write the block file: %s."
            (Printexc.to_string exn))
 
   let lock = Lwt_mutex.create ()
 
-  let get_block level =
+  let get_block cctxt level =
     Lwt_mutex.with_lock lock
       (fun () ->
          load () >>=? fun map ->
@@ -205,7 +207,7 @@ end = struct
            return blocks
          with Not_found -> return [])
 
-  let record_block level hash nonce =
+  let record_block cctxt level hash nonce =
     Lwt_mutex.with_lock lock
       (fun () ->
          load () >>=? fun map ->
@@ -214,17 +216,17 @@ end = struct
            with Not_found -> [] in
          save
            (LevelMap.add level (hash :: previous) map)) >>=? fun () ->
-    Client_proto_nonces.add hash nonce
+    Client_proto_nonces.add cctxt hash nonce
 
 end
 
-let get_mining_slot
+let get_mining_slot cctxt
     ?max_priority (bi: Client_mining_blocks.block_info) delegates =
   let block = `Hash bi.hash in
   let level = Raw_level.succ bi.level.level in
   Lwt_list.filter_map_p
     (fun delegate ->
-       Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate
+       Client_proto_rpcs.Helpers.Rights.mining_rights_for_delegate cctxt
          ?max_priority
          ~first_level:level
          ~last_level:level
@@ -278,16 +280,16 @@ let compute_timeout { future_slots } =
       else
         Lwt_unix.sleep (Int64.to_float delay)
 
-let insert_block ?max_priority state (bi: Client_mining_blocks.block_info) =
+let insert_block cctxt ?max_priority state (bi: Client_mining_blocks.block_info) =
   if Fitness.compare state.best_fitness bi.fitness < 0 then
     state.best_fitness <- bi.fitness ;
-  get_mining_slot ?max_priority bi state.delegates >>= function
+  get_mining_slot cctxt ?max_priority bi state.delegates >>= function
   | None ->
       lwt_debug
         "Can't compute slot for %a" Block_hash.pp_short bi.hash >>= fun () ->
       Lwt.return_unit
   | Some ((timestamp, (_,_,delegate)) as slot) ->
-      Client_keys.Public_key_hash.name delegate >>= fun name ->
+      Client_keys.Public_key_hash.name cctxt delegate >>= fun name ->
       lwt_log_info "New mining slot at %a for %s after %a"
         Time.pp_hum timestamp
         name
@@ -306,10 +308,10 @@ let pop_mining_slots state =
   state.future_slots <- future_slots ;
   slots
 
-let insert_blocks ?max_priority state bis =
-  Lwt_list.iter_s (insert_block ?max_priority state) bis
+let insert_blocks cctxt ?max_priority state bis =
+  Lwt_list.iter_s (insert_block cctxt ?max_priority state) bis
 
-let mine state =
+let mine cctxt state =
   let slots = pop_mining_slots state in
   Lwt_list.map_p
     (fun (timestamp, (bi, prio, delegate)) ->
@@ -319,17 +321,17 @@ let mine state =
            Time.now ()
          else
            timestamp in
-       Client_keys.Public_key_hash.name delegate >>= fun name ->
+       Client_keys.Public_key_hash.name cctxt delegate >>= fun name ->
        lwt_debug "Try mining after %a (slot %d) for %s (%a)"
          Block_hash.pp_short bi.hash
          prio name Time.pp_hum timestamp >>= fun () ->
-       Client_node_rpcs.Blocks.pending_operations
+       Client_node_rpcs.Blocks.pending_operations cctxt
          block >>= fun (res, ops) ->
        let operations =
          let open Operation_hash_set in
          elements (union ops (Updater.operations res)) in
        let request = List.length operations in
-       Client_node_rpcs.Blocks.preapply block
+       Client_node_rpcs.Blocks.preapply cctxt block
          ~timestamp ~sort:true operations >>= function
        | Error errs ->
            lwt_log_error "Error while prevalidating operations:\n%a"
@@ -359,14 +361,14 @@ let mine state =
         Block_hash.pp_short bi.hash priority
         Fitness.pp fitness >>= fun () ->
       let seed_nonce = generate_seed_nonce () in
-      Client_keys.get_key delegate >>=? fun (_,_,src_sk) ->
-      inject_block ~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce
+      Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) ->
+      inject_block cctxt ~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce
         (`Hash bi.hash) operations.applied
       |> trace_exn (Failure "Error while injecting block") >>=? fun block_hash ->
-      State.record_block level block_hash seed_nonce
+      State.record_block cctxt level block_hash seed_nonce
       |> trace_exn (Failure "Error while recording block") >>=? fun () ->
-      Client_keys.Public_key_hash.name delegate >>= fun name ->
-      Cli_entries.message
+      Client_keys.Public_key_hash.name cctxt delegate >>= fun name ->
+      cctxt.message
         "Injected block %a for %s after %a \
         \ (level %a, slot %d, fitness %a, operations %d)"
         Block_hash.pp_short block_hash
@@ -381,14 +383,14 @@ let mine state =
       lwt_debug "No valid candidates." >>= fun () ->
       return ()
 
-let create ?max_priority delegates
+let create cctxt ?max_priority delegates
     (block_stream: Client_mining_blocks.block_info list Lwt_stream.t)
     (endorsement_stream: Client_mining_operations.valid_endorsement Lwt_stream.t) =
   Lwt_stream.get block_stream >>= function
   | None | Some [] ->
-      Cli_entries.error "Can't fetch the current block head."
+      cctxt.Client_commands.error "Can't fetch the current block head."
   | Some ({ Client_mining_blocks.fitness } :: _ as initial_heads) ->
-      Client_node_rpcs.Blocks.hash `Genesis >>= fun genesis_hash ->
+      Client_node_rpcs.Blocks.hash cctxt `Genesis >>= fun genesis_hash ->
       let last_get_block = ref None in
       let get_block () =
         match !last_get_block with
@@ -406,7 +408,7 @@ let create ?max_priority delegates
             t
         | Some t -> t in
       let state = create_state genesis_hash delegates fitness in
-      insert_blocks ?max_priority state initial_heads >>= fun () ->
+      insert_blocks cctxt ?max_priority state initial_heads >>= fun () ->
       let rec worker_loop () =
         let timeout = compute_timeout state in
         Lwt.choose [ (timeout >|= fun () -> `Timeout) ;
@@ -426,20 +428,20 @@ let create ?max_priority delegates
                     Block_hash.pp_short ppf bi.Client_mining_blocks.hash))
               bis
               >>= fun () ->
-              insert_blocks ?max_priority state bis >>= fun () ->
+              insert_blocks cctxt ?max_priority state bis >>= fun () ->
               worker_loop ()
           end
         | `Endorsement (Some e) ->
             Lwt.cancel timeout ;
             last_get_endorsement := None ;
-            Client_keys.Public_key_hash.name
+            Client_keys.Public_key_hash.name cctxt
               e.Client_mining_operations.source >>= fun _source ->
             (* TODO *)
             worker_loop ()
         | `Timeout ->
             lwt_debug "Waking up for mining..." >>= fun () ->
             begin
-              mine state >>= function
+              mine cctxt state >>= function
               | Ok () -> Lwt.return_unit
               | Error errs ->
                   lwt_log_error "Error while mining:\n%a"

src/client/embedded/bootstrap/mining/client_mining_forge.mli

@@ -10,6 +10,7 @@
 val generate_seed_nonce: unit -> Nonce.t
 
 val inject_block:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?force:bool ->
   priority:int ->
@@ -21,6 +22,7 @@ val inject_block:
   Block_hash.t tzresult Lwt.t
 
 val forge_block:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?force:bool ->
   ?operations:Operation_hash.t list ->
@@ -35,11 +37,16 @@ val forge_block:
   Block_hash.t tzresult Lwt.t
 
 module State : sig
-  val get_block: Raw_level.t -> Block_hash.t list tzresult Lwt.t
-  val record_block: Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
+  val get_block:
+    Client_commands.context ->
+    Raw_level.t -> Block_hash.t list tzresult Lwt.t
+  val record_block:
+    Client_commands.context ->
+    Raw_level.t -> Block_hash.t -> Nonce.t -> unit tzresult Lwt.t
 end
 
 val create:
+  Client_commands.context ->
   ?max_priority: int ->
   public_key_hash list ->
   Client_mining_blocks.block_info list Lwt_stream.t ->

src/client/embedded/bootstrap/mining/client_mining_main.ml

@@ -10,159 +10,156 @@
 open Cli_entries
 open Client_proto_contracts
 
-let mine_block block ?force ?max_priority ?src_sk delegate =
+let mine_block cctxt block ?force ?max_priority ?src_sk delegate =
   begin
     match src_sk with
     | None ->
-        Client_keys.get_key delegate >>=? fun (_, _, src_sk) ->
+        Client_keys.get_key cctxt delegate >>=? fun (_, _, src_sk) ->
         return src_sk
     | Some sk -> return sk
   end >>=? fun src_sk ->
-  Client_proto_rpcs.Context.level block >>=? fun level ->
+  Client_proto_rpcs.Context.level cctxt block >>=? fun level ->
   let level = Raw_level.succ level.level in
   let seed_nonce = Client_mining_forge.generate_seed_nonce () in
-  Client_mining_forge.forge_block
+  Client_mining_forge.forge_block cctxt
     ~timestamp:(Time.now ())
     ?force ?max_priority
     ~seed_nonce ~src_sk block delegate >>=? fun block_hash ->
-  Client_mining_forge.State.record_block level block_hash seed_nonce
+  Client_mining_forge.State.record_block cctxt level block_hash seed_nonce
   |> trace_exn (Failure "Error while recording block") >>=? fun () ->
-  message "Injected block %a" Block_hash.pp_short block_hash >>= fun () ->
+  cctxt.message "Injected block %a" Block_hash.pp_short block_hash >>= fun () ->
   return ()
 
-let endorse_block ?force ?max_priority delegate =
+let endorse_block cctxt ?force ?max_priority delegate =
   let block = Client_proto_args.block () in
-  Client_keys.get_key delegate >>=? fun (_src_name, src_pk, src_sk) ->
-  Client_mining_endorsement.forge_endorsement
+  Client_keys.get_key cctxt delegate >>=? fun (_src_name, src_pk, src_sk) ->
+  Client_mining_endorsement.forge_endorsement cctxt
     block ?force ?max_priority ~src_sk src_pk >>=? fun oph ->
-  answer "Operation successfully injected in the node." >>= fun () ->
-  answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
+  cctxt.answer "Operation successfully injected in the node." >>= fun () ->
+  cctxt.answer "Operation hash is '%a'." Operation_hash.pp oph >>= fun () ->
   return ()
 
-let get_predecessor_cycle cycle =
+let get_predecessor_cycle cctxt cycle =
   match Cycle.pred cycle with
   | None ->
       if Cycle.(cycle = root) then
-        error "No predecessor for the first cycle"
+        cctxt.Client_commands.error "No predecessor for the first cycle"
       else
-        error
+        cctxt.error
           "Cannot compute the predecessor of cycle %a"
           Cycle.pp cycle
   | Some cycle -> Lwt.return cycle
 
-let do_reveal ?force block blocks =
+let do_reveal cctxt ?force block blocks =
   let nonces = List.map snd blocks in
-  Client_mining_revelation.forge_seed_nonce_revelation
+  Client_mining_revelation.forge_seed_nonce_revelation cctxt
     block ?force nonces >>=? fun () ->
-  Client_proto_nonces.dels (List.map fst blocks) >>=? fun () ->
+  Client_proto_nonces.dels cctxt (List.map fst blocks) >>=? fun () ->
   return ()
 
-let reveal_block_nonces ?force block_hashes =
+let reveal_block_nonces cctxt ?force block_hashes =
   let block = Client_proto_args.block () in
   Lwt_list.filter_map_p
     (fun hash ->
        Lwt.catch
          (fun () ->
-            Client_mining_blocks.info (`Hash hash) >>= function
+            Client_mining_blocks.info cctxt (`Hash hash) >>= function
             | Ok bi -> Lwt.return (Some bi)
             | Error _ ->
                 Lwt.fail Not_found)
          (fun _ ->
-            Cli_entries.warning
+            cctxt.warning
               "Cannot find block %a in the chain. (ignoring)@."
               Block_hash.pp_short hash >>= fun () ->
             Lwt.return_none))
     block_hashes >>= fun block_infos ->
   map_filter_s (fun (bi : Client_mining_blocks.block_info) ->
-      Client_proto_nonces.find bi.hash >>= function
+      Client_proto_nonces.find cctxt bi.hash >>= function
       | None ->
-          Cli_entries.warning "Cannot find nonces for block %a (ignoring)@."
+          cctxt.warning "Cannot find nonces for block %a (ignoring)@."
             Block_hash.pp_short bi.hash >>= fun () ->
           return None
       | Some nonce ->
           return (Some (bi.hash, (bi.level.level, nonce))))
     block_infos >>=? fun blocks ->
-  do_reveal ?force block blocks
+  do_reveal cctxt ?force block blocks
 
-let reveal_nonces ?force () =
+let reveal_nonces cctxt ?force () =
   let block = Client_proto_args.block () in
-  Client_proto_rpcs.Context.next_level block >>=? fun level ->
+  Client_proto_rpcs.Context.next_level cctxt block >>=? fun level ->
   let cur_cycle = level.cycle in
-  get_predecessor_cycle cur_cycle >>= fun cycle ->
-  Client_mining_blocks.blocks_from_cycle block cycle >>=? fun block_infos ->
+  get_predecessor_cycle cctxt cur_cycle >>= fun cycle ->
+  Client_mining_blocks.blocks_from_cycle cctxt block cycle >>=? fun block_infos ->
   map_filter_s (fun (bi : Client_mining_blocks.block_info) ->
-      Client_proto_nonces.find bi.hash >>= function
+      Client_proto_nonces.find cctxt bi.hash >>= function
       | None -> return None
       | Some nonce ->
-          Cli_entries.warning "Found nonce for %a (level: %a)@."
+          cctxt.warning "Found nonce for %a (level: %a)@."
             Block_hash.pp_short bi.hash Level.pp bi.level >>= fun () ->
           return (Some (bi.hash, (bi.level.level, nonce))))
     block_infos >>=? fun blocks ->
-  do_reveal ?force block blocks
+   do_reveal cctxt ?force block blocks
 
 open Client_proto_args
 
-let run_daemon delegates () =
-  Client_mining_daemon.run
+let run_daemon cctxt delegates =
+  Client_mining_daemon.run cctxt
     ?max_priority:!max_priority
     ~delay:!endorsement_delay
     ~min_date:((Time.add (Time.now ()) (Int64.neg 1800L)))
     (List.map snd delegates)
 
+let group =
+  { Cli_entries.name = "delegate" ;
+    title = "Commands related to delegate operations." }
+
 let commands () =
   let open Cli_entries in
-  register_group "delegate" "Commands related to delegate operations." ;
   [
-    command
-      ~group: "delegate"
-      ~desc: "Launch a daemon that handles delegate operations."
+    command ~group ~desc: "Launch a daemon that handles delegate operations."
       ~args: [endorsement_delay_arg; max_priority_arg;
               Daemon.mining_arg ; Daemon.endorsement_arg ; Daemon.denunciation_arg]
       (prefixes [ "launch" ; "daemon" ]
        @@ seq_of_param Client_keys.Public_key_hash.alias_param )
-      run_daemon ;
-    command
-      ~group: "delegate"
-      ~desc: "Forge and inject an endorsement operation"
+      (fun delegates cctxt ->
+         run_daemon cctxt delegates) ;
+    command ~group ~desc: "Forge and inject an endorsement operation"
       ~args: [ force_arg ]
       (prefixes [ "endorse"; "for" ]
        @@ Client_keys.Public_key_hash.alias_param
          ~name:"miner" ~desc: "name of the delegate owning the endorsement right"
        @@ stop)
-      (fun (_, delegate) () ->
-         endorse_block
+      (fun (_, delegate) cctxt ->
+         endorse_block cctxt
            ~force:!force ?max_priority:!max_priority delegate >>=
-         Client_proto_rpcs.handle_error) ;
-    command
-      ~group: "delegate"
-      ~desc: "Forge and inject block using the delegate rights"
+         Client_proto_rpcs.handle_error cctxt) ;
+    command ~group ~desc: "Forge and inject block using the delegate rights"
       ~args: [ max_priority_arg ; force_arg ]
       (prefixes [ "mine"; "for" ]
        @@ Client_keys.Public_key_hash.alias_param
          ~name:"miner" ~desc: "name of the delegate owning the mining right"
        @@ stop)
-      (fun (_, delegate) () ->
-         mine_block (block ())
+      (fun (_, delegate) cctxt ->
+         mine_block cctxt (block ())
            ~force:!force ?max_priority:!max_priority delegate >>=
-         Client_proto_rpcs.handle_error) ;
-    command
-      ~group: "delegate"
-      ~desc: "Forge and inject a seed-nonce revelation operation"
+         Client_proto_rpcs.handle_error cctxt) ;
+    command ~group ~desc: "Forge and inject a seed-nonce revelation operation"
       ~args: [ force_arg ]
       (prefixes [ "reveal"; "nonce"; "for" ]
        @@ Cli_entries.seq_of_param Block_hash.param)
-      (fun block_hashes () ->
-         reveal_block_nonces ~force:!force block_hashes >>= Client_proto_rpcs.handle_error) ;
-    command
-      ~group: "delegate"
-      ~desc: "Forge and inject redemption operations"
+      (fun block_hashes cctxt ->
+         reveal_block_nonces cctxt
+           ~force:!force block_hashes >>=
+         Client_proto_rpcs.handle_error cctxt) ;
+    command ~group ~desc: "Forge and inject redemption operations"
       ~args: [ force_arg ]
       (prefixes [ "reveal"; "nonces" ]
        @@ stop)
-      (fun () ->
-         reveal_nonces ~force:!force () >>= Client_proto_rpcs.handle_error) ;
+      (fun cctxt ->
+         reveal_nonces cctxt ~force:!force () >>=
+         Client_proto_rpcs.handle_error cctxt) ;
   ]
 
 let () =
-  Client_version.register Client_proto_main.protocol @@
+  Client_commands.register Client_proto_main.protocol @@
   commands ()

src/client/embedded/bootstrap/mining/client_mining_main.mli

@@ -8,6 +8,7 @@
 (**************************************************************************)
 
 val mine_block:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?force:bool ->
   ?max_priority: int ->
@@ -15,4 +16,4 @@ val mine_block:
   public_key_hash ->
   unit tzresult Lwt.t
 
-val commands: unit -> Cli_entries.command list
+val commands: unit -> Client_commands.command list

src/client/embedded/bootstrap/mining/client_mining_operations.ml

@@ -18,15 +18,15 @@ type operation = {
   content: (Updater.shell_operation * proto_operation) option
 }
 
-let monitor ?contents ?check () =
-  Client_node_rpcs.Operations.monitor ?contents () >>= fun ops_stream ->
+let monitor cctxt ?contents ?check () =
+  Client_node_rpcs.Operations.monitor cctxt ?contents () >>= fun ops_stream ->
   let convert ops =
     Lwt_list.filter_map_p
       (fun (hash, bytes) ->
          match bytes with
          | None -> Lwt.return (Some { hash; content = None })
          | Some ({ Store.shell ; proto } : Updater.raw_operation) ->
-             Client_proto_rpcs.Helpers.Parse.operations
+             Client_proto_rpcs.Helpers.Parse.operations cctxt
                `Prevalidation ?check shell proto >>= function
              | Ok proto -> Lwt.return (Some { hash ; content = Some (shell, proto) })
              | Error err ->
@@ -46,7 +46,7 @@ type valid_endorsement = {
   slots: int list ;
 }
 
-let filter_valid_endorsement { hash; content } =
+let filter_valid_endorsement cctxt { hash; content } =
   let open Tezos_context in
   match content with
   | None
@@ -73,14 +73,14 @@ let filter_valid_endorsement { hash; content } =
                 slots in
             (* Ensure thath the block has been previously validated by
                the node. This might took some times... *)
-            Client_node_rpcs.validate_block net_id block >>= function
+            Client_node_rpcs.validate_block cctxt net_id block >>= function
             | Error error ->
                 lwt_log_info
                   "@[<v 2>Found endorsement for an invalid block@,%a@["
                   pp_print_error error >>= fun () ->
                 Lwt.return_none
             | Ok () ->
-                Client_node_rpcs.Blocks.preapply (`Hash block) [hash] >>= function
+                Client_node_rpcs.Blocks.preapply cctxt (`Hash block) [hash] >>= function
                 | Ok _ ->
                     Lwt.return (Some { hash ; source ; block ; slots })
                 | Error error ->
@@ -90,14 +90,14 @@ let filter_valid_endorsement { hash; content } =
                     Lwt.return_none
           with Not_found -> Lwt.return_none
 
-let monitor_endorsement () =
-  monitor ~contents:true ~check:true () >>= fun ops_stream ->
+let monitor_endorsement cctxt =
+  monitor cctxt ~contents:true ~check:true () >>= fun ops_stream ->
   let endorsement_stream, push = Lwt_stream.create () in
   Lwt_stream.on_termination ops_stream (fun () -> push None) ;
   Lwt.async (fun () ->
       Lwt_stream.iter_p
         (Lwt_list.iter_p (fun e ->
-             filter_valid_endorsement e >>= function
+             filter_valid_endorsement cctxt e >>= function
              | None -> Lwt.return_unit
              | Some e -> push (Some e) ; Lwt.return_unit))
         ops_stream) ;

src/client/embedded/bootstrap/mining/client_mining_operations.mli

@@ -13,6 +13,7 @@ type operation = {
 }
 
 val monitor:
+  Client_commands.context ->
   ?contents:bool -> ?check:bool -> unit ->
   operation list Lwt_stream.t Lwt.t
 
@@ -24,7 +25,9 @@ type valid_endorsement = {
 }
 
 val filter_valid_endorsement:
+  Client_commands.context ->
   operation -> valid_endorsement option Lwt.t
 
 val monitor_endorsement:
-  unit -> valid_endorsement Lwt_stream.t Lwt.t
+  Client_commands.context ->
+  valid_endorsement Lwt_stream.t Lwt.t

src/client/embedded/bootstrap/mining/client_mining_revelation.ml

@@ -11,30 +11,31 @@ open Cli_entries
 open Tezos_context
 open Logging.Client.Revelation
 
-let inject_seed_nonce_revelation block ?force ?wait nonces =
+let inject_seed_nonce_revelation cctxt block ?force ?wait nonces =
   let operations =
     List.map
       (fun (level, nonce) ->
          Seed_nonce_revelation { level ; nonce }) nonces in
-  Client_node_rpcs.Blocks.net block >>= fun net ->
-  Client_proto_rpcs.Helpers.Forge.Anonymous.operations
+  Client_node_rpcs.Blocks.net cctxt block >>= fun net ->
+  Client_proto_rpcs.Helpers.Forge.Anonymous.operations cctxt
     block ~net operations >>=? fun bytes ->
-  Client_node_rpcs.inject_operation ?force ?wait bytes >>=? fun oph ->
+  Client_node_rpcs.inject_operation cctxt ?force ?wait bytes >>=? fun oph ->
   return oph
 
 type Error_monad.error += Bad_revelation
 
-let forge_seed_nonce_revelation block ?(force = false) redempted_nonces =
+let forge_seed_nonce_revelation cctxt
+    block ?(force = false) redempted_nonces =
   begin
     if force then return redempted_nonces else
     map_filter_s (fun (level, nonce) ->
-          Client_proto_rpcs.Context.Nonce.get block level >>=? function
+          Client_proto_rpcs.Context.Nonce.get cctxt block level >>=? function
           | Forgotten ->
-              message "Too late revelation for level %a"
+              cctxt.message "Too late revelation for level %a"
                 Raw_level.pp level >>= fun () ->
               return None
           | Revealed _ ->
-              message "Ignoring previously-revealed nonce for level %a"
+              cctxt.message "Ignoring previously-revealed nonce for level %a"
                 Raw_level.pp level >>= fun () ->
               return None
           | Missing nonce_hash ->
@@ -48,11 +49,11 @@ let forge_seed_nonce_revelation block ?(force = false) redempted_nonces =
   end >>=? fun nonces ->
   match nonces with
   | [] ->
-      message "No nonce to reveal";
+      cctxt.message "No nonce to reveal" >>= fun () ->
       return ()
   | _ ->
-      inject_seed_nonce_revelation
+      inject_seed_nonce_revelation cctxt
         block ~force ~wait:true nonces >>=? fun oph ->
-      answer "Operation successfully injected in the node." >>= fun () ->
-      answer "Operation hash is '%a'." Operation_hash.pp_short oph >>= fun () ->
+      cctxt.answer "Operation successfully injected in the node." >>= fun () ->
+      cctxt.answer "Operation hash is '%a'." Operation_hash.pp_short oph >>= fun () ->
       return ()

src/client/embedded/bootstrap/mining/client_mining_revelation.mli

@@ -8,6 +8,7 @@
 (**************************************************************************)
 
 val inject_seed_nonce_revelation:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?force:bool ->
   ?wait:bool ->
@@ -15,6 +16,7 @@ val inject_seed_nonce_revelation:
   Operation_hash.t tzresult Lwt.t
 
 val forge_seed_nonce_revelation:
+  Client_commands.context ->
   Client_proto_rpcs.block ->
   ?force:bool ->
   (Raw_level.t * Nonce.t) list ->

src/client/embedded/bootstrap/webclient/webclient_proto_service_directory.ml

@@ -11,14 +11,16 @@ module Services = Webclient_proto_services.Make (struct
     type root = Node_rpc_services.Blocks.block
   end)
 
+let cctxt = Client_commands.ignore_context
+
 let root =
   let root =
     RPC.register RPC.empty Services.contracts @@ fun block () ->
-    Client_proto_contracts.RawContractAlias.load () >>= fun list ->
+    Client_proto_contracts.RawContractAlias.load cctxt >>= fun list ->
     let (names, _) = List.split list in
     RPC.Answer.return names in
   let root =
     RPC.register root Services.hash @@ fun block () ->
-    Client_node_rpcs.(call_service1 Node_rpc_services.Blocks.hash block ()) >>= fun res ->
+    Client_node_rpcs.(call_service1 cctxt Node_rpc_services.Blocks.hash block ()) >>= fun res ->
     RPC.Answer.return (Hash.Block_hash.to_b48check res) in
   root

src/client/embedded/demo/client_proto_main.ml

@@ -11,35 +11,35 @@ let protocol =
   Protocol_hash.of_b48check
     "2gagsSEvTKAHRjxAamgSdBNkv39VtNCqpaDXrrH4K8R4KQAAHrhe3"
 
-let demo () =
+let demo cctxt =
   let block = Client_config.block () in
-  Cli_entries.message "Calling the 'echo' RPC." >>= fun () ->
+  cctxt.Client_commands.message "Calling the 'echo' RPC." >>= fun () ->
   let msg = "test" in
-  Client_proto_rpcs.echo block msg >>= fun reply ->
+  Client_proto_rpcs.echo cctxt block msg >>= fun reply ->
   fail_unless (reply = msg) (Unclassified "...") >>=? fun () ->
   begin
-    Cli_entries.message "Calling the 'failing' RPC." >>= fun () ->
-    Client_proto_rpcs.failing block 3 >>= function
+    cctxt.message "Calling the 'failing' RPC." >>= fun () ->
+    Client_proto_rpcs.failing cctxt block 3 >>= function
     | Error [Ecoproto_error [Error.Demo_error 3]] ->
         return ()
     | _ -> failwith "..."
   end >>=? fun () ->
-  Cli_entries.message "Direct call to `demo_error`." >>= fun () ->
+  cctxt.message "Direct call to `demo_error`." >>= fun () ->
   begin Error.demo_error 101010 >|= wrap_error >>= function
     | Error [Ecoproto_error [Error.Demo_error 101010]] ->
         return ()
     | _ -> failwith "...."
   end >>=? fun () ->
-  Cli_entries.answer "All good!" >>= fun () ->
+  cctxt.answer "All good!" >>= fun () ->
   return ()
 
-let mine () =
+let mine cctxt =
   let block =
     match Client_config.block () with
     | `Prevalidation -> `Head 0
     | `Test_prevalidation -> `Test_head 0
     | b -> b in
-  Client_node_rpcs.Blocks.info block >>= fun bi ->
+  Client_node_rpcs.Blocks.info cctxt block >>= fun bi ->
   let fitness =
     match bi.fitness with
     | [ v ; b ] ->
@@ -48,46 +48,40 @@ let mine () =
         [ v ; b ]
     | _ ->
         Lwt.ignore_result
-          (Cli_entries.message "Cannot parse fitness: %a" Fitness.pp bi.fitness);
+          (cctxt.message "Cannot parse fitness: %a" Fitness.pp bi.fitness);
         exit 2 in
-  Client_node_rpcs.forge_block
+  Client_node_rpcs.forge_block cctxt
     ~net:bi.net ~predecessor:bi.hash
     fitness [] (MBytes.create 0) >>= fun bytes ->
-  Client_node_rpcs.inject_block ~wait:true bytes >>=? fun hash ->
-  Cli_entries.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
+  Client_node_rpcs.inject_block cctxt ~wait:true bytes >>=? fun hash ->
+  cctxt.answer "Injected %a" Block_hash.pp_short hash >>= fun () ->
   return ()
 
-let handle_error = function
+let handle_error cctxt = function
   | Ok res ->
       Lwt.return res
   | Error exns ->
       pp_print_error Format.err_formatter exns ;
-      Cli_entries.error "cannot continue"
+      cctxt.Client_commands.error "%s" "cannot continue"
 
 let commands () =
   let open Cli_entries in
-  register_group "demo" "Some demo command" ;
+  let group = {name = "demo" ; title = "Some demo command" } in
   [
-    command
-      ~group: "demo"
-      ~desc: "A demo command"
+    command ~group ~desc: "A demo command"
       (fixed [ "demo" ])
-      (fun () -> demo () >>= handle_error) ;
-    command
-      ~group: "demo"
-      ~desc: "An failing command"
+      (fun cctxt -> demo cctxt >>= handle_error cctxt) ;
+    command ~group ~desc: "A failing command"
       (fixed [ "fail" ])
-      (fun () ->
+      (fun cctxt ->
          Error.demo_error 101010
          >|= wrap_error
-         >>= handle_error ) ;
-    command
-      ~group: "demo"
-      ~desc: "Mine an empty block"
+         >>= handle_error cctxt) ;
+    command ~group ~desc: "Mine an empty block"
       (fixed [ "mine" ])
-      (fun () -> mine () >>= handle_error) ;
+      (fun cctxt -> mine cctxt >>= handle_error cctxt) ;
   ]
 
 let () =
-  Client_version.register protocol @@
+  Client_commands.register protocol @@
   commands ()

src/client/embedded/demo/client_proto_rpcs.ml

@@ -7,11 +7,11 @@
 (*                                                                        *)
 (**************************************************************************)
 
-let call_service1 s block a1 =
-  Client_node_rpcs.call_service1
+let call_service1 cctxt s block a1 =
+  Client_node_rpcs.call_service1 cctxt
     (s Node_rpc_services.Blocks.proto_path) block a1
-let call_error_service1 s block a1 =
-  call_service1 s block a1 >|= wrap_error
+let call_error_service1 cctxt s block a1 =
+  call_service1 cctxt s block a1 >|= wrap_error
 
-let echo = call_service1 Services.echo_service
-let failing = call_error_service1 Services.failing_service
+let echo cctxt = call_service1 cctxt Services.echo_service
+let failing cctxt = call_error_service1 cctxt Services.failing_service

src/client/embedded/demo/client_proto_rpcs.mli

@@ -9,5 +9,9 @@
 
 open Node_rpc_services
 
-val echo: Blocks.block -> string -> string Lwt.t
-val failing: Blocks.block -> int -> unit tzresult Lwt.t
+val echo:
+  Client_commands.context ->
+  Blocks.block -> string -> string Lwt.t
+val failing:
+  Client_commands.context ->
+  Blocks.block -> int -> unit tzresult Lwt.t

src/client_main.ml

@@ -11,7 +11,7 @@
 
 open Lwt
 
-let () =
+let cctxt =
   let startup =
     CalendarLib.Printer.Precise_Calendar.sprint
       "%Y-%m-%dT%H:%M:%SZ"
@@ -30,7 +30,7 @@ let () =
           ~mode: Lwt_io.Output
           Client_config.(base_dir#get // "logs" // log // startup)
           (fun chan -> Lwt_io.write chan msg) in
-  Cli_entries.log_hook := Some log
+  Client_commands.make_context log
 
 (* Main (lwt) entry *)
 let main () =
@@ -38,12 +38,13 @@ let main () =
   Sodium.Random.stir () ;
   catch
     (fun () ->
-       Client_config.preparse_args Sys.argv >>= fun block ->
+       Client_config.preparse_args Sys.argv cctxt >>= fun block ->
        Lwt.catch
          (fun () ->
-            Client_node_rpcs.Blocks.protocol block)
+            Client_node_rpcs.Blocks.protocol cctxt block)
          (fun _ ->
-            Cli_entries.message "\n\
+            cctxt.message
+              "\n\
                The connection to the RPC server failed, \
                using the default protocol version.\n" >>= fun () ->
             Lwt.return Client_bootstrap.Client_proto_main.protocol)
@@ -53,12 +54,12 @@ let main () =
          Client_keys.commands () @
          Client_protocols.commands () @
          Client_helpers.commands () @
-         Client_version.commands_for_version version in
+         Client_commands.commands_for_version version in
        Client_config.parse_args ~version
-         (Cli_entries.usage commands)
+         (Cli_entries.usage ~commands)
          (Cli_entries.inline_dispatch commands)
-         Sys.argv >>= fun command ->
-       command () >>= fun () ->
+         Sys.argv cctxt >>= fun command ->
+       command cctxt >>= fun () ->
        Lwt.return 0)
     (function
       | Arg.Help help ->
@@ -70,7 +71,7 @@ let main () =
       | Cli_entries.Command_not_found ->
           Format.eprintf "Unkonwn command, try `-help`.\n%!" ;
           Lwt.return 1
-      | Client_version.Version_not_found ->
+      | Client_commands.Version_not_found ->
           Format.eprintf "Unkonwn protocol version, try `list versions`.\n%!" ;
           Lwt.return 1
       | Cli_entries.Bad_argument (idx, _n, v) ->
@@ -80,7 +81,7 @@ let main () =
           Format.eprintf "Command failed, %s.\n%!" message ;
           Lwt.return 1
       | Failure message ->
-          Format.eprintf "%s%!" message ;
+          Format.eprintf "%s\n%!" message ;
           Lwt.return 1
       | exn ->
           Format.printf "Fatal internal error: %s\n%!"

src/utils/cli_entries.ml

@@ -18,50 +18,35 @@ exception Command_failed of string
 
 (* A simple structure for command interpreters.
    This is more generic than the exported one, see end of file. *)
-type ('a, 'arg, 'ret) tparams =
-  | Prefix : string * ('a, 'arg, 'ret) tparams ->
-    ('a, 'arg, 'ret) tparams
+type ('a, 'arg, 'ret) params =
+  | Prefix : string * ('a, 'arg, 'ret) params ->
+    ('a, 'arg, 'ret) params
   | Param : string * string *
-            (string -> 'p Lwt.t) *
-            ('a, 'arg, 'ret) tparams ->
-    ('p -> 'a, 'arg, 'ret) tparams
+            ('arg -> string -> 'p Lwt.t) *
+            ('a, 'arg, 'ret) params ->
+    ('p -> 'a, 'arg, 'ret) params
   | Stop :
-      ('arg -> 'ret Lwt.t, 'arg, 'ret) tparams
+      ('arg -> 'ret Lwt.t, 'arg, 'ret) params
   | More :
-      (string list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams
+      (string list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
   | Seq : string * string *
-          (string -> 'p Lwt.t) ->
-    ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) tparams
+          ('arg -> string -> 'p Lwt.t) ->
+    ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
+
+(* A command group *)
+type group =
+  { name : string ;
+    title : string }
 
 (* A command wraps a callback with its type and info *)
-and ('arg, 'ret) tcommand =
+type ('arg, 'ret) command =
   | Command
-    : ('a, 'arg, 'ret) tparams * 'a *
-      desc option * tag list * group option *
-      (Arg.key * Arg.spec * Arg.doc) list
-    -> ('arg, 'ret) tcommand
-
-and desc = string
-and group = string
-and tag = string
-
-(* Associates group names with group titles *)
-let groups : (group * string) list ref = ref []
-let register_group group title =
-  try ignore @@ List.assoc group !groups with
-  | Not_found -> groups := (group, title) :: !groups
-let group_title group =
-  try List.assoc group !groups with
-  | Not_found -> group
-
-(* Associates tag names with tag descriptions *)
-let tags : (tag * string) list ref = ref []
-let register_tag tag title =
-  try ignore @@ List.assoc tag !tags with
-  | Not_found -> tags := (tag, title) :: !tags
-let tag_description tag =
-  try List.assoc tag !tags with
-  | Not_found -> "undocumented tag"
+    : { params: ('a, 'arg, 'ret) params ;
+        handler : 'a ;
+        desc : string ;
+        group : group option ;
+        args : (Arg.key * Arg.spec * Arg.doc) list }
+    -> ('arg, 'ret) command
 
 (* Some combinators for writing commands concisely. *)
 let param ~name ~desc kind next = Param (name, desc, kind, next)
@@ -80,18 +65,19 @@ let stop = Stop
 let more = More
 let void = Stop
 let any = More
-let command ?desc ?(tags = []) ?group ?(args = []) params cb =
-  Command (params, cb, desc,tags, group, args)
+let command ?group ?(args = []) ~desc params handler =
+  Command { params ; handler ; desc ; group ; args }
 
 (* Param combinators *)
-let string n desc next = param n desc (fun s -> return s) next
+let string ~name ~desc next =
+  param name desc (fun _ s -> return s) next
 
 (* Command execution *)
 let exec
     (type arg) (type ret)
-    (Command (params, cb, _, _, _, _)) (last : arg) args =
+    (Command { params ; handler }) (last : arg) args =
   let rec exec
-    : type a. int -> (a, arg, ret) tparams -> a -> string list -> ret Lwt.t
+    : type a. int -> (a, arg, ret) params -> a -> string list -> ret Lwt.t
     = fun i params cb args ->
     match params, args with
     | Stop, [] -> cb last
@@ -101,7 +87,7 @@ let exec
           | [] -> Lwt.return (List.rev acc)
           | p :: rest ->
               catch
-                (fun () -> f p)
+                (fun () -> f last p)
                 (function
                   | Failure msg -> Lwt.fail (Bad_argument (i, p, msg))
                   | exn -> Lwt.fail exn) >>= fun v ->
@@ -113,33 +99,33 @@ let exec
         exec (succ i) next cb rest
     | Param (_, _, f, next), p :: rest ->
         catch
-          (fun () -> f p)
+          (fun () -> f last p)
           (function
             | Failure msg -> Lwt.fail (Bad_argument (i, p, msg))
             | exn -> Lwt.fail exn) >>= fun v ->
         exec (succ i) next (cb v) rest
     | _ -> Lwt.fail Command_not_found
-  in exec 1 params cb args
+  in exec 1 params handler args
 
 (* Command dispatch tree *)
 type ('arg, 'ret) level =
-  { stop : ('arg, 'ret) tcommand option ;
+  { stop : ('arg, 'ret) command option ;
     prefix : (string * ('arg, 'ret) tree) list }
 and ('arg, 'ret) param_level =
-  { stop : ('arg, 'ret) tcommand option ;
+  { stop : ('arg, 'ret) command option ;
     tree : ('arg, 'ret) tree }
 and ('arg, 'ret) tree =
   | TPrefix of ('arg, 'ret) level
   | TParam of ('arg, 'ret) param_level
-  | TStop of ('arg, 'ret) tcommand
-  | TMore of ('arg, 'ret) tcommand
+  | TStop of ('arg, 'ret) command
+  | TMore of ('arg, 'ret) command
   | TEmpty
 
 let insert_in_dispatch_tree
     (type arg) (type ret)
-    root (Command (params, _, _, _, _, _) as command) =
+    root (Command { params } as command) =
   let rec insert_tree
-    : type a. (arg, ret) tree -> (a, arg, ret) tparams -> (arg, ret) tree
+    : type a. (arg, ret) tree -> (a, arg, ret) params -> (arg, ret) tree
     = fun t c -> match t, c with
       | TEmpty, Stop -> TStop command
       | TEmpty, More -> TMore command
@@ -207,15 +193,15 @@ let inline_tree_dispatch tree () =
             let t = List.assoc n prefix in
             state := (t, n :: acc) ;
             begin match t with
-              | TStop (Command (_, _, _, _, _, args))
-              | TMore (Command (_, _, _, _, _, args)) -> `Args args
+              | TStop (Command { args })
+              | TMore (Command { args }) -> `Args args
               | _ -> `Nop end
           with Not_found -> `Fail Command_not_found end
     | (TParam { tree }, acc), `Arg n ->
         state := (tree, n :: acc) ;
         begin match tree with
-          | TStop (Command (_, _, _, _, _, args))
-          | TMore (Command (_, _, _, _, _, args)) -> `Args args
+          | TStop (Command { args })
+          | TMore (Command { args }) -> `Args args
           | _ -> `Nop end
     | _, _ -> `Fail Command_not_found
 
@@ -232,13 +218,13 @@ let inline_dispatch commands =
 (* Command line help for a set of commands *)
 let usage
     (type arg) (type ret)
-      commands options =
+    ~commands options =
   let trim s = (* config-file wokaround *)
     Utils.split '\n' s |>
     List.map String.trim |>
     String.concat "\n" in
   let rec help
-    : type a. Format.formatter -> (a, arg, ret) tparams -> unit
+    : type a. Format.formatter -> (a, arg, ret) params -> unit
     = fun ppf -> function
     | Stop -> ()
     | More -> Format.fprintf ppf "..."
@@ -251,7 +237,7 @@ let usage
     | Param (n, "", _, next) -> Format.fprintf ppf "(%s) %a" n help next
     | Param (_, desc, _, next) -> Format.fprintf ppf "(%s) %a" desc help next in
   let rec help_sum
-    : type a. Format.formatter -> (a, arg, ret) tparams -> unit
+    : type a. Format.formatter -> (a, arg, ret) params -> unit
     = fun ppf -> function
     | Stop -> ()
     | More -> Format.fprintf ppf "..."
@@ -261,7 +247,7 @@ let usage
     | Prefix (n, next) -> Format.fprintf ppf "%s %a" n help_sum next
     | Param (n, _, _, next) -> Format.fprintf ppf "(%s) %a" n help_sum next in
   let rec help_args
-    : type a. Format.formatter -> (a, arg, ret) tparams -> unit
+    : type a. Format.formatter -> (a, arg, ret) params -> unit
     = fun ppf -> function
       | Stop -> ()
       | More -> Format.fprintf ppf "..."
@@ -293,20 +279,17 @@ let usage
           | Rest _ -> "" in example opt) ;
     if desc <> "" then
       Format.fprintf ppf "@,  @[<hov>%a@]" Format.pp_print_text (trim desc) in
-  let command_help ppf (Command (p, _, desc, _, _, options)) =
-    let small = Format.asprintf "@[<h>%a@]" help p in
-    let desc =
-      match desc with
-      | None -> "undocumented command"
-      | Some desc -> trim desc in
+  let command_help ppf (Command { params ; desc ; args }) =
+    let small = Format.asprintf "@[<h>%a@]" help params in
+    let desc = trim desc in
     if String.length small < 50 then begin
       Format.fprintf ppf "@[<v 2>%s@,@[<hov>%a@]"
         small Format.pp_print_text desc
     end else begin
       Format.fprintf ppf "@[<v 2>%a@,@[<hov 0>%a@]@,%a"
-        help_sum p
+        help_sum params
         Format.pp_print_text desc
-        help_args p ;
+        help_args params ;
     end ;
     if options = [] then
       Format.fprintf ppf "@]"
@@ -314,14 +297,10 @@ let usage
       Format.fprintf ppf "@,%a@]"
         (Format.pp_print_list option_help)
         options in
-  let rec group_help ppf (n, commands) =
-    let title =
-      match n with
-      | None -> "Miscellaneous commands"
-      | Some n -> group_title n in
+  let rec group_help ppf ({ title }, commands) =
     Format.fprintf ppf "@[<v 2>%s:@,%a@]"
       title
-      (Format.pp_print_list command_help) !commands in
+      (Format.pp_print_list command_help) commands in
   let usage ppf (by_group, options) =
     Format.fprintf ppf
       "@[<v>@[<v 2>Usage:@,%s [ options ] command [ command options ]@]@,\
@@ -331,49 +310,26 @@ let usage
       (Format.pp_print_list option_help) options
       (Format.pp_print_list group_help) by_group in
   let by_group =
+    let ungrouped = ref [] in
+    let grouped =
       List.fold_left
-      (fun acc (Command (_, _, _, _, g, _) as c) ->
+        (fun acc (Command { group } as command) ->
+           match group with
+           | None ->
+               ungrouped := command :: !ungrouped ;
+               acc
+           | Some group ->
                try
-           let r = List.assoc g acc in
-           r := c :: !r ;
+                 let ({ title }, r) =
+                   List.find (fun ({ name }, _) -> group.name = name) acc in
+                 if title <> group.title then
+                   invalid_arg "Cli_entries.usage: duplicate group name" ;
+                 r := command :: !r ;
                  acc
                with Not_found ->
-           (g, ref [ c ]) :: acc)
-      [] commands |> List.sort compare in
+                 (group, ref [ command ]) :: acc)
+        [] commands in
+    List.map (fun (g, c) -> (g, List.rev !c)) grouped @
+    [ { name = "untitled" ; title = "Miscellaneous commands" },
+      List.rev !ungrouped ] in
   Format.asprintf "%a" usage (by_group, options)
-
-(* Pre-instanciated types *)
-type 'a params = ('a, unit, unit) tparams
-type command = (unit, unit) tcommand
-
-let log_hook
-  : (string -> string -> unit Lwt.t) option ref
-  = ref None
-
-let log channel msg =
-  match !log_hook with
-  | None -> Lwt.fail (Invalid_argument "Cli_entries.log: uninitialized hook")
-  | Some hook -> hook channel msg
-
-let error fmt=
-  Format.kasprintf
-    (fun msg ->
-       Lwt.fail (Failure msg))
-    fmt
-
-let warning fmt =
-  Format.kasprintf
-    (fun msg -> log "stderr" msg)
-    fmt
-
-let message fmt =
-  Format.kasprintf
-    (fun msg -> log "stdout" msg)
-    fmt
-
-let answer = message
-
-let log name fmt =
-  Format.kasprintf
-    (fun msg -> log name msg)
-    fmt

src/utils/cli_entries.mli

@@ -14,60 +14,66 @@ exception Command_not_found
 exception Bad_argument of int * string * string
 exception Command_failed of string
 
-type 'a params
-type command
-
-and desc = string
-and group = string
-and tag = string
+type ('a, 'arg, 'ret) params
+type ('arg, 'ret) command
 
 val param:
   name: string ->
   desc: string ->
-  (string -> 'a Lwt.t) -> 'b params -> ('a -> 'b) params
-val prefix: string -> 'a params -> 'a params
-val prefixes: string list -> 'a params -> 'a params
-val string: string -> string -> 'a params -> (string -> 'a) params
-val fixed: string list -> (unit -> unit Lwt.t) params
-val stop: (unit -> unit Lwt.t) params
+  ('arg -> string -> 'a Lwt.t) ->
+  ('b, 'arg, 'ret) params ->
+  ('a -> 'b, 'arg, 'ret) params
+val prefix:
+  string ->
+  ('a, 'arg, 'ret) params ->
+  ('a, 'arg, 'ret) params
+val prefixes:
+  string list ->
+  ('a, 'arg, 'ret) params ->
+  ('a, 'arg, 'ret) params
+val fixed:
+  string list ->
+  ('arg -> 'ret Lwt.t, 'arg, 'ret) params
+val stop:
+  ('arg -> 'ret Lwt.t, 'arg, 'ret) params
 val seq:
   name: string ->
   desc: string ->
-  (string -> 'p Lwt.t) ->
-  ('p list -> unit -> unit Lwt.t) params
+  ('arg -> string -> 'p Lwt.t) ->
+  ('p list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
+
+val string:
+  name: string ->
+  desc: string ->
+  ('a, 'arg, 'ret) params ->
+  (string -> 'a, 'arg, 'ret) params
 
 val seq_of_param:
-  ((unit -> unit Lwt.t) params ->
-   ('a -> unit -> unit Lwt.t) params) ->
-  ('a list -> unit -> unit Lwt.t) params
+  (('arg -> 'ret Lwt.t, 'arg, 'ret) params ->
+   ('a -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params) ->
+  ('a list -> 'arg -> 'ret Lwt.t, 'arg, 'ret) params
+
+type group =
+  { name : string ;
+    title : string }
 
 val command:
-  ?desc:desc ->
-  ?tags:tag list ->
   ?group: group ->
   ?args: (Arg.key * Arg.spec * Arg.doc) list ->
-  'a params -> 'a -> command
-
-val register_group: group -> group -> unit
-val register_tag: tag -> string -> unit
+  desc: string ->
+  ('a, 'arg, 'ret) params -> 'a -> ('arg, 'ret) command
 
 val usage:
-  command list -> (string * Arg.spec * string) list -> string
+  commands: ('arg, 'ret) command list ->
+  (string * Arg.spec * string) list -> string
+
 val inline_dispatch:
-  command list -> unit ->
+  ('arg, 'ret) command list -> unit ->
   [ `Arg of string | `End ] ->
   [ `Args of (Arg.key * Arg.spec * Arg.doc) list
   | `Fail of exn
   | `Nop
-  | `Res of unit -> unit Lwt.t ]
+  | `Res of 'arg -> 'ret Lwt.t ]
 
 val dispatch:
-  command list -> unit -> string list -> unit Lwt.t
-
-val log_hook : (string -> string -> unit Lwt.t) option ref
-
-val error : ('a, Format.formatter, unit, 'b Lwt.t) format4 -> 'a
-val warning : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
-val message : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
-val answer : ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
-val log : string -> ('a, Format.formatter, unit, unit Lwt.t) format4 -> 'a
+  ('arg, 'ret) command list -> 'arg -> string list -> 'ret Lwt.t

src/utils/hash.ml

@@ -224,7 +224,7 @@ module Make_Blake2B (R : sig
          conv to_b48check (Data_encoding.Json.wrap_error of_b48check) string)
 
   let param ?(name=K.name) ?(desc=K.title) t =
-    Cli_entries.param ~name ~desc (fun str -> Lwt.return (of_b48check str)) t
+    Cli_entries.param ~name ~desc (fun _ str -> Lwt.return (of_b48check str)) t
 
   let pp ppf t =
     Format.pp_print_string ppf (to_b48check t)

src/utils/hash.mli

@@ -113,8 +113,8 @@ module Block_hash : sig
   val param :
     ?name:string ->
     ?desc:string ->
-    'a Cli_entries.params ->
-    (t -> 'a) Cli_entries.params
+    ('a, 'arg, 'ret) Cli_entries.params ->
+    (t -> 'a, 'arg, 'ret) Cli_entries.params
 end
 
 module Block_hash_set : module type of Hash_set (Block_hash)

src/webclient_main.ml

@@ -12,77 +12,57 @@
 open Lwt.Infix
 open Logging.Webclient
 
-let with_cli_entries_logging =
-  let startup =
-    CalendarLib.Printer.Precise_Calendar.sprint
-      "%Y-%m-%dT%H:%M:%SZ"
-      (CalendarLib.Calendar.Precise.now ()) in
-  let stdout = Buffer.create 1000 in
-  let stderr = Buffer.create 1000 in
-  let log channel msg = match channel with
-    | "stdout" ->
-        Buffer.add_string stdout msg ;
-        Lwt.return ()
-    | "stderr" ->
-        Buffer.add_string stderr msg ;
-        Lwt.return ()
-    | log ->
-        Lwt_utils.create_dir Client_config.(base_dir#get // "webclient_logs" // log) >>= fun () ->
-        Lwt_io.with_file
-          ~flags: Unix.[ O_APPEND ; O_CREAT ; O_WRONLY ]
-          ~mode: Lwt_io.Output
-          Client_config.(base_dir#get // "webclient_logs" // log // startup)
-          (fun chan -> Lwt_io.write chan msg) in
-  Cli_entries.log_hook := Some log ;
-  let global_cli_entries_mutex = Lwt_mutex.create () in
-  (fun callback ->
-     Lwt_mutex.with_lock
-       global_cli_entries_mutex
+let make_context () =
+  let buffers = Hashtbl.create 50 in
+  Hashtbl.add buffers "stdout" (Buffer.create 1000) ;
+  Hashtbl.add buffers "stderr" (Buffer.create 1000) ;
+  let log channel msg =
+    let buffer =
+      try Hashtbl.find buffers channel with
+        Not_found ->
+          let buffer = Buffer.create 1000 in
+          Hashtbl.add buffers channel buffer ;
+          buffer in
+    Buffer.add_string buffer msg ;
+    Buffer.add_char buffer '\n' ;
+    Lwt.return () in
+  Client_commands.make_context log,
   (fun () ->
-          Buffer.clear stdout ;
-          Buffer.clear stderr ;
-          Lwt.catch
-            (fun () ->
-               callback () >>= fun result ->
-               Lwt.return
-                 (Ok (result,
-                      Buffer.contents stdout,
-                      Buffer.contents stderr)))
-            (fun exn ->
-               Lwt.return
-                 (Error (exn,
-                         Buffer.contents stdout,
-                         Buffer.contents stderr)))))
+     Hashtbl.fold
+       (fun channel buffer acc ->
+          (channel, Buffer.contents buffer) :: acc)
+       buffers [])
 
-let block_protocol block =
+let block_protocol cctxt block =
   Lwt.catch
     (fun () ->
-       Client_node_rpcs.Blocks.protocol block)
+       Client_node_rpcs.Blocks.protocol cctxt block)
     (fun _ ->
-       Cli_entries.message "\n\
+       cctxt.Client_commands.message
+         "\n\
           The connection to the RPC server failed, \
           using the default protocol version.\n" >>= fun () ->
        Lwt.return Client_bootstrap.Client_proto_main.protocol)
 
 let eval_command argv =
-  with_cli_entries_logging
+  let cctxt, result = make_context () in
+  Lwt.catch
     (fun () ->
-       Client_config.preparse_args argv >>= fun block ->
-       block_protocol block >>= fun version ->
+       Client_config.preparse_args argv cctxt >>= fun block ->
+       block_protocol cctxt block >>= fun version ->
        let commands =
          Client_generic_rpcs.commands @
          Client_keys.commands () @
          Client_protocols.commands () @
          Client_helpers.commands () @
-         Client_version.commands_for_version version in
+         Client_commands.commands_for_version version in
        Client_config.parse_args ~version
-         (Cli_entries.usage commands)
+         (Cli_entries.usage ~commands)
          (Cli_entries.inline_dispatch commands)
-         argv >>= fun command ->
-       command ()) >>= function
-  | Ok ((), stdout, _stderr) ->
-      Lwt.return (Ok stdout)
-  | Error (exn, stdout, stderr) ->
+         argv cctxt >>= fun command ->
+       command cctxt >>= fun () ->
+       Lwt.return (Ok (result ())))
+    (fun exn ->
        let msg = match exn with
          | Arg.Help help ->
              Format.asprintf "%s%!" help
@@ -90,7 +70,7 @@ let eval_command argv =
              Format.asprintf "%s%!" help
          | Cli_entries.Command_not_found ->
              Format.asprintf "Unkonwn command, try `-help`.\n%!"
-        | Client_version.Version_not_found ->
+         | Client_commands.Version_not_found ->
              Format.asprintf "Unkonwn protocol version, try `list versions`.\n%!"
          | Cli_entries.Bad_argument (idx, _n, v) ->
              Format.asprintf "There's a problem with argument %d, %s.\n%!" idx v
@@ -100,19 +80,20 @@ let eval_command argv =
              Format.asprintf "Fatal error: %s\n%!" msg
          | exn ->
              Format.asprintf "Fatal internal error: %s\n%!" (Printexc.to_string exn) in
+       let result =
+         result () in
        let stderr =
-        if stdout = ""
-        || String.get stdout (String.length stderr - 1) = '\n' then
-          stdout ^ stderr
-        else
-          stdout ^ "\n" ^ stderr in
+         List.assoc "stderr" result in
        let stderr =
          if stderr = ""
          || String.get stderr (String.length stderr - 1) = '\n' then
            msg
          else
            stderr ^ "\n" ^ msg in
-      Lwt.return (Error stderr)
+       let result =
+         ("stderr", stderr)::
+         List.filter (fun (n, _) -> n <> "stderr") result in
+       Lwt.return (Error result))
 
 module ConnectionMap = Map.Make(Cohttp.Connection)
 
@@ -123,7 +104,7 @@ let root =
   let input, output =
     let open Data_encoding in
     (obj1 (req "command" string)),
-    (obj1 (req "output" string)) in
+    (obj1 (req "outputs" (assoc string))) in
   let root =
     RPC.empty in
   let root =
@@ -138,7 +119,7 @@ let root =
     RPC.register_dynamic_directory1 root
       RPC.Path.(root / "block" /: Node_rpc_services.Blocks.blocks_arg)
       (fun block ->
-         Client_node_rpcs.Blocks.protocol block >>= fun version ->
+         Client_node_rpcs.Blocks.protocol Client_commands.ignore_context block >>= fun version ->
          let directory = Webclient_version.find_contextual_services version in
          let directory = RPC.map (fun ((), block) -> block) directory in
          Lwt.return directory) in
@@ -154,7 +135,7 @@ let find_static_file path =
       let path = index (path, file) in
       (match Node_rpc_services.Blocks.parse_block block with
        | Ok block ->
-           block_protocol block >>= fun version ->
+           block_protocol Client_commands.ignore_context block >>= fun version ->
            Lwt.return
              (try
                 let root =
@@ -194,11 +175,11 @@ let () =
     (Lwt.catch
        (fun () ->
           Client_config.parse_args
-            (Cli_entries.usage [])
+            (Cli_entries.usage ~commands: [])
             (fun () -> function
                | `Arg arg -> raise (Arg.Bad ("unexpected argument " ^ arg))
                | `End -> `Res (fun () -> Lwt.return ()))
-            Sys.argv >>= fun _no_command ->
+            Sys.argv Client_commands.ignore_context>>= fun _no_command ->
           Random.self_init () ;
           Sodium.Random.stir () ;
           http_proxy web_port#get >>= fun _server ->

src/webclient_static/index.html

@@ -7,11 +7,11 @@
   </head>
   <body>
     <h1>Tezos Web client</h1>
+    <pre id="console"></pre>
+    <br/>
     <form id="form">
       ./tezos-client <input type="text" name="command" id="command">
       <input type="submit" value="RUN">
-      <br/>
-      <textarea id="console" cols="80" rows="50"></textarea>
     </form>
     <script>
      $('#form').on('submit', function(e) {
@@ -23,9 +23,14 @@
          dataType: 'json',
          data: JSON.stringify({ command : './tezos-client ' + $('#command')[0].value }),
          processData: false
-       }).done (function ({ output }) {
-         console.log (output);
-         $('#console')[0].value += output;
+       }).done (function ({ outputs }) {
+         let stdout = document.createElement ("span");
+         stdout.appendChild (document.createTextNode (outputs.stdout));
+         let stderr = document.createElement ("span");
+         stderr.appendChild (document.createTextNode (outputs.stderr));
+         stderr.style.color = "darkred";
+         $('#console')[0].appendChild (stdout);
+         $('#console')[0].appendChild (stderr);
        })
      })
     </script>

test/test_basic.ml

@@ -14,7 +14,9 @@ open Error_monad
 open Hash
 
 let () =
-  Random.self_init () ;
+  Random.self_init ()
+
+let cctxt =
   let log channel msg = match channel with
     | "stdout" ->
         print_endline msg ;
@@ -23,7 +25,7 @@ let () =
         prerr_endline msg ;
         Lwt.return ()
     | _ -> Lwt.return () in
-  Cli_entries.log_hook := Some log
+  Client_commands.make_context log
 
 let should_fail f t =
   t >>= function
@@ -74,7 +76,7 @@ type account = {
 }
 
 let bootstrap_accounts () =
-  Client_proto_rpcs.Constants.bootstrap `Genesis
+  Client_proto_rpcs.Constants.bootstrap cctxt `Genesis
   >>= fun accounts ->
   let cpt = ref 0 in
   Lwt.return
@@ -105,7 +107,7 @@ let transfer ?(block = `Prevalidation) ?(fee = 5L) ~src ~target amount =
     match amount with
     | Some x -> x
     | None -> assert false in (* will be captured by the previous assert *)
-  Client_proto_context.transfer
+  Client_proto_context.transfer cctxt
     block
     ~source:src.contract
     ~src_pk:src.public_key
@@ -114,7 +116,7 @@ let transfer ?(block = `Prevalidation) ?(fee = 5L) ~src ~target amount =
     ~amount ~fee ()
 
 let check_balance ?(block = `Prevalidation) account expected =
-  Client_proto_rpcs.Context.Contract.balance
+  Client_proto_rpcs.Context.Contract.balance cctxt
     block account.contract >>=? fun balance ->
   let balance = Tez.to_cents balance in
   Assert.equal_int64 ~msg:__LOC__ expected balance ;
@@ -122,9 +124,9 @@ let check_balance ?(block = `Prevalidation) account expected =
 
 let mine contract =
   let block = `Head 0 in
-  Client_proto_rpcs.Context.level block >>=? fun level ->
+  Client_proto_rpcs.Context.level cctxt block >>=? fun level ->
   let seed_nonce = Client_mining_forge.generate_seed_nonce () in
-  Client_mining_forge.forge_block
+  Client_mining_forge.forge_block cctxt
     ~timestamp:(Time.now ()) ~seed_nonce ~src_sk:contract.secret_key
     block contract.public_key_hash >>=? fun block_hash ->
   return ()