Client: split admin/debug commands into separate executable

.gitignore

@@ -10,6 +10,7 @@ _build
 /tezos-node
 /tezos-protocol-compiler
 /tezos-client
+/tezos-admin-client
 
 /scripts/opam-test-all.sh.DONE
 

Makefile

@@ -5,9 +5,11 @@ all:
 	@jbuilder build ${DEV} \
 		src/bin_node/main.exe \
 		src/bin_client/main.exe \
+		src/bin_client/admin_main.exe \
 		src/lib_protocol_compiler/main.exe
 	@cp _build/default/src/bin_node/main.exe tezos-node
 	@cp _build/default/src/bin_client/main.exe tezos-client
+	@cp _build/default/src/bin_client/admin_main.exe tezos-admin-client
 	@cp _build/default/src/lib_protocol_compiler/main.exe tezos-protocol-compiler
 
 doc-html:

src/bin_client/admin_main.ml

@@ -0,0 +1,15 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Where all the user friendliness starts *)
+let () = Pervasives.exit (Lwt_main.run (
+    Main_lib.main ~only_commands:(Client_debug.commands ()
+                                  @ Client_admin.commands ()
+                                  @ Client_network.commands ()
+                                  @ Client_generic_rpcs.commands) ()))

src/bin_client/jbuild

@@ -1,8 +1,8 @@
 (jbuild_version 1)
 
-(executable
+(executables
- ((name main)
+ ((names (main admin_main))
-  (public_name tezos-client)
+  (public_names (tezos-client tezos-admin))
   (libraries (tezos-base
               tezos-rpc-http
               tezos-client-base

src/bin_client/main.ml

@@ -7,110 +7,5 @@
 (*                                                                        *)
 (**************************************************************************)
 
-(* Tezos Command line interface - Main Program *)
-
-let cctxt ~base_dir ~block rpc_config =
-  Client_commands.make_context ~base_dir ~block ~rpc_config (Client_commands.default_log ~base_dir)
-
-(* Main (lwt) entry *)
-let main () =
-  Random.self_init () ;
-  Sodium.Random.stir () ;
-  Lwt.catch begin fun () ->
-    let original_args = List.tl (Array.to_list Sys.argv) in
-    begin
-      Client_config.parse_config_args
-        (cctxt ~base_dir:Client_commands.default_base_dir
-           ~block:Client_commands.default_block
-           Client_rpcs.default_config)
-        original_args
-      >>=? fun (parsed_config_file, parsed_args, remaining) ->
-      let rpc_config : Client_rpcs.config = {
-        Client_rpcs.default_config with
-        host = parsed_config_file.node_addr ;
-        port = parsed_config_file.node_port ;
-        tls = parsed_config_file.tls ;
-      } in
-      let ctxt = new Client_rpcs.http_ctxt rpc_config in
-      begin
-        Client_node_rpcs.Blocks.protocol ctxt parsed_args.block >>= function
-        | Ok version -> begin
-            match parsed_args.protocol with
-            | None ->
-                return (Some version, Client_commands.commands_for_version version)
-            | Some given_version -> begin
-                if not (Protocol_hash.equal version given_version) then
-                  Format.eprintf
-                    "@[<v 2>Warning:@,\
-                     The protocol provided via `-protocol` (%a)@,\
-                     is not the one retrieved from the node (%a).@."
-                    Protocol_hash.pp_short given_version
-                    Protocol_hash.pp_short version ;
-                return (Some version, Client_commands.commands_for_version given_version)
-              end
-          end
-        | Error errs -> begin
-            match parsed_args.protocol with
-            | None -> begin
-                Format.eprintf
-                  "@[<v 2>Ignored error:@,Failed to acquire the protocol version from the node@,%a@."
-                  (Format.pp_print_list pp) errs ;
-                return (None, [])
-              end
-            | Some version ->
-                return (Some version, Client_commands.commands_for_version version)
-          end
-      end >>=? fun (_version, commands_for_version)  ->
-      let commands =
-        Client_generic_rpcs.commands @
-        Client_network.commands () @
-        Client_keys.commands () @
-        Client_protocols.commands () @
-        Client_helpers.commands () @
-        Client_debug.commands () @
-        commands_for_version in
-      let rpc_config =
-        if parsed_args.print_timings then
-          { rpc_config with
-            logger = RPC_client.timings_logger Format.err_formatter }
-        else if parsed_args.log_requests
-        then { rpc_config with logger = RPC_client.full_logger Format.err_formatter }
-        else rpc_config
-      in
-      let client_config =
-        cctxt ~block:parsed_args.block ~base_dir:parsed_config_file.base_dir rpc_config in
-      (Cli_entries.dispatch
-         ~global_options:Client_config.global_options
-         commands
-         client_config
-         remaining) end >>=
-    Cli_entries.handle_cli_errors
-      ~stdout:Format.std_formatter
-      ~stderr:Format.err_formatter
-      ~global_options:Client_config.global_options
-    >>= function
-    | Ok i ->
-        Lwt.return i
-    | Error errs ->
-        Format.eprintf "@[<v 2>Fatal error:@,%a@."
-          (Format.pp_print_list Error_monad.pp) errs ;
-        Lwt.return 1
-  end begin function
-    | Arg.Help help ->
-        Format.printf "%s%!" help ;
-        Lwt.return 0
-    |  Client_commands.Version_not_found ->
-        Format.eprintf "Unknown protocol version.@." ;
-        Lwt.return 1
-    | Failure message ->
-        Format.eprintf
-          "Fatal error: %s@." message ;
-        Lwt.return 1
-    | exn ->
-        Format.printf "Fatal internal error: %s@."
-          (Printexc.to_string exn) ;
-        Lwt.return 1
-  end
-
 (* Where all the user friendliness starts *)
-let () = Pervasives.exit (Lwt_main.run (main ()))
+let () = Pervasives.exit (Lwt_main.run (Main_lib.main ()))

src/bin_client/main_lib.ml

@@ -0,0 +1,117 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2017.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Tezos Command line interface - Main Program *)
+
+let cctxt ~base_dir ~block rpc_config =
+  Client_commands.make_context ~base_dir ~block ~rpc_config (Client_commands.default_log ~base_dir)
+
+let get_commands_for_version ctxt block protocol =
+  Client_node_rpcs.Blocks.protocol ctxt block >>= function
+  | Ok version -> begin
+      match protocol with
+      | None ->
+          return (Some version, Client_commands.commands_for_version version)
+      | Some given_version -> begin
+          if not (Protocol_hash.equal version given_version) then
+            Format.eprintf
+              "@[<v 2>Warning:@,\
+               The protocol provided via `-protocol` (%a)@,\
+               is not the one retrieved from the node (%a).@."
+              Protocol_hash.pp_short given_version
+              Protocol_hash.pp_short version ;
+          return (Some version, Client_commands.commands_for_version given_version)
+        end
+    end
+  | Error errs -> begin
+      match protocol with
+      | None -> begin
+          Format.eprintf
+            "@[<v 2>Ignored error:@,Failed to acquire the protocol version from the node@,%a@."
+            (Format.pp_print_list pp) errs ;
+          return (None, [])
+        end
+      | Some version ->
+          return (Some version, Client_commands.commands_for_version version)
+    end
+
+(* Main (lwt) entry *)
+let main ?only_commands () =
+  Random.self_init () ;
+  Sodium.Random.stir () ;
+  Lwt.catch begin fun () ->
+    let original_args = List.tl (Array.to_list Sys.argv) in
+    begin
+      Client_config.parse_config_args
+        (cctxt ~base_dir:Client_commands.default_base_dir
+           ~block:Client_commands.default_block
+           Client_rpcs.default_config)
+        original_args
+      >>=? fun (parsed_config_file, parsed_args, remaining) ->
+      let rpc_config : Client_rpcs.config = {
+        Client_rpcs.default_config with
+        host = parsed_config_file.node_addr ;
+        port = parsed_config_file.node_port ;
+        tls = parsed_config_file.tls ;
+      } in
+      let ctxt = new Client_rpcs.http_ctxt rpc_config in
+      begin match only_commands with
+        | None ->
+            get_commands_for_version ctxt
+              parsed_args.block
+              parsed_args.protocol >>|? fun (_version, commands_for_version)  ->
+            Client_generic_rpcs.commands @
+            Client_network.commands () @
+            Client_keys.commands () @
+            Client_protocols.commands () @
+            Client_helpers.commands () @
+            commands_for_version
+        | Some commands -> return commands end >>=? fun commands ->
+      let rpc_config =
+        if parsed_args.print_timings then
+          { rpc_config with
+            logger = RPC_client.timings_logger Format.err_formatter }
+        else if parsed_args.log_requests
+        then { rpc_config with logger = RPC_client.full_logger Format.err_formatter }
+        else rpc_config
+      in
+      let client_config =
+        cctxt ~block:parsed_args.block ~base_dir:parsed_config_file.base_dir rpc_config in
+      (Cli_entries.dispatch
+         ~global_options:Client_config.global_options
+         commands
+         client_config
+         remaining) end >>=
+    Cli_entries.handle_cli_errors
+      ~stdout:Format.std_formatter
+      ~stderr:Format.err_formatter
+      ~global_options:Client_config.global_options
+    >>= function
+    | Ok i ->
+        Lwt.return i
+    | Error errs ->
+        Format.eprintf "@[<v 2>Fatal error:@,%a@."
+          (Format.pp_print_list Error_monad.pp) errs ;
+        Lwt.return 1
+  end begin function
+    | Arg.Help help ->
+        Format.printf "%s%!" help ;
+        Lwt.return 0
+    |  Client_commands.Version_not_found ->
+        Format.eprintf "Unknown protocol version.@." ;
+        Lwt.return 1
+    | Failure message ->
+        Format.eprintf
+          "Fatal error: %s@." message ;
+        Lwt.return 1
+    | exn ->
+        Format.printf "Fatal internal error: %s@."
+          (Printexc.to_string exn) ;
+        Lwt.return 1
+  end

src/lib_client_base/client_admin.ml

@@ -0,0 +1,23 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+let commands () =
+  let open Cli_entries in
+  let group = { name = "admin" ;
+                title = "commands to perform privileged operations on the node" } in
+  [
+    command ~group ~desc: "unmark invalid"
+      no_options
+      (prefixes [ "unmark" ; "invalid" ]
+       @@ Block_hash.param ~name:"block" ~desc:"block to remove from invalid list"
+       @@ stop)
+      (fun () block (cctxt : Client_commands.full_context) ->
+         Client_rpcs.call_err_service0 cctxt Node_rpc_services.Blocks.unmark_invalid block >>=? fun () ->
+         cctxt#message "Block %a no longer marked invalid" Block_hash.pp block >>= return) ;
+  ]

src/lib_client_base/client_admin.mli

@@ -0,0 +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 -> (Client_commands.full_context, unit) Cli_entries.command list

src/lib_client_base/client_debug.ml

@@ -47,26 +47,21 @@ let pp_block ppf
     operations
     Hex.pp (MBytes.to_hex data)
 
-let stuck_node_report cctxt file =
+let print_md_title ppf title level =
-  let ppf = Format.formatter_of_out_channel (open_out file) in
+  Format.fprintf ppf "%s %s@.@." (String.init level (fun _ -> '#')) title
-  let skip_line () =
+
-    Format.pp_print_newline ppf ();
+let skip_line ppf =
-    return @@ Format.pp_print_newline ppf () in
+  Format.pp_print_newline ppf ();
-  let print_title title level =
+  return @@ Format.pp_print_newline ppf ()
-    Format.fprintf ppf "%s %s@.@." (String.init level (fun _ -> '#')) title;
+
-    return () in
+let registered_protocols ppf =
-  print_title "Stuck node report:" 1 >>=? fun () ->
+  Format.pp_print_list
-  return @@ Format.fprintf ppf "Date: %a@;"
-    Time.pp_hum (Time.now ()) >>=? fun () ->
-  skip_line () >>=? fun () ->
-  print_title "Registered protocols:" 2 >>=? fun () ->
-  return @@ Format.pp_print_list
     ~pp_sep:Format.pp_print_newline
     (fun ppf (protocol, _) -> Protocol_hash.pp ppf protocol)
     ppf
-    (Client_commands.get_versions ()) >>=? fun () ->
+    (Client_commands.get_versions ())
-  skip_line () >>=? fun () ->
+
-  print_title "Heads:" 2 >>=? fun () ->
+let print_heads ppf cctxt =
   Client_rpcs.call_service0 cctxt Node_rpc_services.Blocks.list
     { include_ops = true ;
       length = Some 1 ;
@@ -83,9 +78,9 @@ let stuck_node_report cctxt file =
          pp_block
          ppf
          blocks)
-    ppf heads >>=? fun () ->
+    ppf heads
-  skip_line () >>=? fun () ->
+
-  print_title "Rejected blocks:" 2 >>=? fun () ->
+let print_rejected ppf cctxt =
   Client_rpcs.call_service0 cctxt
     Node_rpc_services.Blocks.list_invalid () >>=? fun invalid ->
   return @@
@@ -108,22 +103,55 @@ let stuck_node_report cctxt file =
 let commands () =
   let open Cli_entries in
   let group = { name = "debug" ;
-                title = "commands to debug and fix problems with the node" } in
+                title = "commands to report debug information" } in
+  let output_arg =
+    arg
+      ~doc:"Write output of debug command to file"
+      ~parameter:"-file"
+    @@ parameter (fun _ str -> return str) in
+  let output_to_ppf = function
+    | None -> Format.std_formatter
+    | Some file -> Format.formatter_of_out_channel (open_out file) in
   [
-    command ~group ~desc: "debug report"
+    command ~group ~desc: "list protocols"
-      no_options
+      (args1 output_arg)
-      (prefixes [ "debug" ; "stuck" ; "node" ]
+      (fixed [ "list" ; "registered" ; "protocols" ])
-       @@ string ~name:"file" ~desc:"file in which to save report"
+      (fun output (_cctxt : Client_commands.full_context) ->
-       @@ stop)
+         let ppf = output_to_ppf output in
-      (fun () file (cctxt : Client_commands.full_context) ->
+         registered_protocols ppf ;
-         stuck_node_report cctxt file) ;
+         Format.fprintf ppf "@." ;
-    command ~group ~desc: "unmark invalid"
+         return ()) ;
-      no_options
+    command ~group ~desc: "current heads"
-      (prefixes [ "debug" ; "unmark" ; "invalid" ]
+      (args1 output_arg)
-       @@ Block_hash.param ~name:"block" ~desc:"block to remove from invalid list"
+      (fixed [ "list" ; "heads" ])
-       @@ stop)
+      (fun output cctxt ->
-      (fun () block (cctxt : Client_commands.full_context) ->
+         let ppf = output_to_ppf output in
-         Client_rpcs.call_err_service0 cctxt Node_rpc_services.Blocks.unmark_invalid block >>=? fun () ->
+         print_heads ppf cctxt >>=? fun () ->
-         cctxt#message "Block %a no longer marked invalid" Block_hash.pp block >>= return
+         Format.fprintf ppf "@." ;
-      )
+         return ()) ;
+    command ~group ~desc: "rejected blocks"
+      (args1 output_arg)
+      (fixed [ "list" ; "rejected" ; "blocks" ])
+      (fun output cctxt ->
+         let ppf = output_to_ppf output in
+         print_rejected ppf cctxt >>|? fun () ->
+         Format.fprintf ppf "@.") ;
+    command ~group ~desc: "report on current node state"
+      (args1 output_arg)
+      (fixed [ "full" ; "report" ])
+      (fun output cctxt ->
+         let ppf = output_to_ppf output in
+         print_md_title ppf "Node report:" 1 ;
+         return @@ Format.fprintf ppf "Date: %a@;"
+           Time.pp_hum (Time.now ()) >>=? fun () ->
+         skip_line ppf >>=? fun () ->
+         print_md_title ppf "Registered protocols:" 2 ;
+         registered_protocols ppf ;
+         skip_line ppf >>=? fun () ->
+         print_md_title ppf "Heads:" 2 ;
+         print_heads ppf cctxt >>=? fun () ->
+         skip_line ppf >>=? fun () ->
+         print_md_title ppf "Rejected blocks:" 2 ;
+         print_rejected ppf cctxt >>|? fun () ->
+         Format.fprintf ppf "@.") ;
   ]