Client: cleanup admin commands

src/bin_client/main_admin.ml

@@ -10,8 +10,8 @@
 let select_commands _ _ =
   return
     (List.flatten
-       [ Client_debug.commands () ;
-         Client_admin.commands () ;
+       [ Client_report_commands.commands () ;
+         Client_admin_commands.commands () ;
          Client_network_commands.commands () ;
          Client_generic_rpcs.commands ])
 

src/lib_client_base/client_admin_commands.ml

@@ -10,14 +10,20 @@
 let commands () =
   let open Cli_entries in
   let group = { name = "admin" ;
-                title = "commands to perform privileged operations on the node" } in
+                title = "Commands to perform privileged operations on the node" } in
   [
-    command ~group ~desc: "unmark invalid"
+    command ~group
+      ~desc: "Make the node forget its decision of rejecting a block."
       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) ->
+       @@ seq_of_param (Block_hash.param ~name:"block" ~desc:"block to remove from invalid list"))
+      (fun () blocks (cctxt : #Client_commands.full_context) ->
+         iter_s
+           (fun block ->
               Block_services.unmark_invalid cctxt block >>=? fun () ->
-         cctxt#message "Block %a no longer marked invalid" Block_hash.pp block >>= return) ;
+              cctxt#message
+                "Block %a no longer marked invalid."
+                Block_hash.pp block >>= fun () ->
+              return ())
+           blocks) ;
   ]

src/lib_client_base/client_debug.ml

@@ -1,154 +0,0 @@
-(**************************************************************************)
-(*                                                                        *)
-(*    Copyright (c) 2014 - 2016.                                          *)
-(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
-(*                                                                        *)
-(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
-(*                                                                        *)
-(**************************************************************************)
-
-(* Commands used to debug the node/alphanet *)
-
-let pp_block ppf
-    { Block_services.hash ; net_id ; level ;
-      proto_level ; predecessor ; timestamp ;
-      operations_hash ; fitness ; data ;
-      operations ; protocol ; test_network } =
-  Format.fprintf ppf
-    "@[<v 2>Hash: %a\
-     @ Test network: %a\
-     @ Level: %ld\
-     @ Proto_level: %d\
-     @ Predecessor: %a\
-     @ Protocol: %a\
-     @ Net id: %a\
-     @ Timestamp: %a\
-     @ Fitness: @[<v>%a@]\
-     @ Operations hash: %a\
-     @ Operations: @[<v>%a@]\
-     @ Data (hex encoded): \"%a\"@]"
-    Block_hash.pp hash
-    Test_network_status.pp test_network
-    level
-    proto_level
-    Block_hash.pp predecessor
-    Protocol_hash.pp protocol
-    Net_id.pp net_id
-    Time.pp_hum timestamp
-    Fitness.pp fitness
-    Operation_list_list_hash.pp operations_hash
-    (fun ppf -> function
-       | None -> Format.fprintf ppf "None"
-       | Some operations ->
-           Format.pp_print_list ~pp_sep:Format.pp_print_newline
-             (Format.pp_print_list ~pp_sep:Format.pp_print_space
-                (fun ppf (oph, _) -> Operation_hash.pp ppf oph))
-             ppf operations)
-    operations
-    Hex.pp (MBytes.to_hex data)
-
-let print_md_title ppf title level =
-  Format.fprintf ppf "%s %s@.@." (String.init level (fun _ -> '#')) title
-
-let skip_line ppf =
-  Format.pp_print_newline ppf ();
-  return @@ Format.pp_print_newline ppf ()
-
-let registered_protocols ppf =
-  Format.pp_print_list
-    ~pp_sep:Format.pp_print_newline
-    (fun ppf (protocol, _) -> Protocol_hash.pp ppf protocol)
-    ppf
-    (Client_commands.get_versions ())
-
-let print_heads ppf cctxt =
-  Block_services.list
-    ~include_ops:true
-    ~length:1
-    cctxt >>=? fun heads ->
-  return @@
-  Format.pp_print_list ~pp_sep:Format.pp_print_newline
-    (fun ppf blocks ->
-       Format.pp_print_list
-         ~pp_sep:Format.pp_print_newline
-         pp_block
-         ppf
-         blocks)
-    ppf heads
-
-let print_rejected ppf cctxt =
-  Block_services.list_invalid cctxt >>=? fun invalid ->
-  return @@
-  Format.pp_print_list
-    (fun ppf (hash, level, errors) ->
-       Format.fprintf ppf
-         "@[<v 2>Hash: %a\
-          @ Level: %ld\
-          @ Errors: @[<v>%a@]@]"
-         Block_hash.pp hash
-         level
-         (Format.pp_print_list ~pp_sep:Format.pp_print_newline
-            Error_monad.pp)
-         errors)
-    ppf
-    invalid
-
-
-
-let commands () =
-  let open Cli_entries in
-  let group = { name = "debug" ;
-                title = "commands to report debug information" } in
-  let output_arg =
-    arg
-      ~doc:"Write output of debug command to file"
-      ~long:"output"
-      ~short:'o'
-      ~placeholder:"path"
-    @@ 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: "list protocols"
-      (args1 output_arg)
-      (fixed [ "list" ; "registered" ; "protocols" ])
-      (fun output (_cctxt : #Client_commands.full_context) ->
-         let ppf = output_to_ppf output in
-         registered_protocols ppf ;
-         Format.fprintf ppf "@." ;
-         return ()) ;
-    command ~group ~desc: "current heads"
-      (args1 output_arg)
-      (fixed [ "list" ; "heads" ])
-      (fun output cctxt ->
-         let ppf = output_to_ppf output in
-         print_heads ppf cctxt >>=? fun () ->
-         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 "@.") ;
-  ]

src/lib_client_base/client_report_commands.ml

@@ -0,0 +1,128 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    Copyright (c) 2014 - 2016.                                          *)
+(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
+(*                                                                        *)
+(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(* Commands used to introspect the node's state *)
+
+let pp_block ppf
+    { Block_services.hash ; net_id ; level ;
+      proto_level ; predecessor ; timestamp ;
+      operations_hash ; fitness ; data ;
+      operations ; protocol ; test_network } =
+  Format.fprintf ppf
+    "@[<v 2>Hash: %a\
+     @ Test network: %a\
+     @ Level: %ld\
+     @ Proto_level: %d\
+     @ Predecessor: %a\
+     @ Protocol: %a\
+     @ Net id: %a\
+     @ Timestamp: %a\
+     @ Fitness: @[<v>%a@]\
+     @ Operations hash: %a\
+     @ Operations: @[<v>%a@]\
+     @ Data (hex encoded): \"%a\"@]"
+    Block_hash.pp hash
+    Test_network_status.pp test_network
+    level
+    proto_level
+    Block_hash.pp predecessor
+    Protocol_hash.pp protocol
+    Net_id.pp net_id
+    Time.pp_hum timestamp
+    Fitness.pp fitness
+    Operation_list_list_hash.pp operations_hash
+    (fun ppf -> function
+       | None -> Format.fprintf ppf "None"
+       | Some operations ->
+           Format.pp_print_list ~pp_sep:Format.pp_print_newline
+             (Format.pp_print_list ~pp_sep:Format.pp_print_space
+                (fun ppf (oph, _) -> Operation_hash.pp ppf oph))
+             ppf operations)
+    operations
+    Hex.pp (MBytes.to_hex data)
+
+let skip_line ppf =
+  Format.pp_print_newline ppf ();
+  return @@ Format.pp_print_newline ppf ()
+
+let print_heads ppf heads =
+  Format.pp_print_list ~pp_sep:Format.pp_print_newline
+    (fun ppf blocks ->
+       Format.pp_print_list
+         ~pp_sep:Format.pp_print_newline
+         pp_block
+         ppf
+         blocks)
+    ppf heads
+
+let print_rejected ppf = function
+  | [] -> Format.fprintf ppf "No invalid blocks."
+  | invalid ->
+      Format.pp_print_list
+        (fun ppf (hash, level, errors) ->
+           Format.fprintf ppf
+             "@[<v 2>Hash: %a\
+              @ Level: %ld\
+              @ Errors: @[<v>%a@]@]"
+             Block_hash.pp hash
+             level
+             (Format.pp_print_list ~pp_sep:Format.pp_print_newline
+                Error_monad.pp)
+             errors)
+        ppf
+        invalid
+
+let commands () =
+  let open Cli_entries in
+  let group = { name = "report" ;
+                title = "Commands to report the node's status" } in
+  let output_arg =
+    default_arg
+      ~doc:"write to a file"
+      ~long:"output"
+      ~short:'o'
+      ~placeholder:"path"
+      ~default: "-"
+      (parameter (fun _ -> function
+           | "-" -> return Format.std_formatter
+           | file ->
+               let ppf = Format.formatter_of_out_channel (open_out file) in
+               ignore Cli_entries.(setup_formatter ppf Plain Full) ;
+               return ppf)) in
+  [
+    command ~group
+      ~desc: "The last heads that have been considered by the node."
+      (args1 output_arg)
+      (fixed [ "list" ; "heads" ])
+      (fun ppf cctxt ->
+         Block_services.list ~include_ops:true ~length:1 cctxt >>=? fun heads ->
+         Format.fprintf ppf "%a@." print_heads heads ;
+         return ()) ;
+    command ~group ~desc: "The blocks that have been marked invalid by the node."
+      (args1 output_arg)
+      (fixed [ "list" ; "rejected" ; "blocks" ])
+      (fun ppf cctxt ->
+         Block_services.list_invalid cctxt >>=? fun invalid ->
+         Format.fprintf ppf "%a@." print_rejected invalid ;
+         return ()) ;
+    command ~group ~desc: "A full report of the node's state."
+      (args1 output_arg)
+      (fixed [ "full" ; "report" ])
+      (fun ppf cctxt ->
+         Block_services.list ~include_ops:true ~length:1 cctxt >>=? fun heads ->
+         Block_services.list_invalid cctxt >>=? fun invalid ->
+         Format.fprintf ppf
+           "@[<v 0>@{<title>Date@} %a@,\
+            @[<v 2>@{<title>Heads@}@,%a@]@,\
+            @[<v 2>@{<title>Rejected blocks@}@,%a@]@]"
+           Time.pp_hum (Time.now ())
+           print_heads heads
+           print_rejected invalid ;
+         return ()) ;
+  ]