From cafcaf925bc7d9ccac0b5e2e6d25743f95753718 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Wed, 14 Feb 2018 14:15:54 +0100 Subject: [PATCH] Client: cleanup admin commands --- src/bin_client/main_admin.ml | 4 +- ...ient_admin.ml => client_admin_commands.ml} | 20 ++- ...nt_admin.mli => client_admin_commands.mli} | 0 src/lib_client_base/client_debug.ml | 154 ------------------ src/lib_client_base/client_report_commands.ml | 128 +++++++++++++++ ...t_debug.mli => client_report_commands.mli} | 0 6 files changed, 143 insertions(+), 163 deletions(-) rename src/lib_client_base/{client_admin.ml => client_admin_commands.ml} (56%) rename src/lib_client_base/{client_admin.mli => client_admin_commands.mli} (100%) delete mode 100644 src/lib_client_base/client_debug.ml create mode 100644 src/lib_client_base/client_report_commands.ml rename src/lib_client_base/{client_debug.mli => client_report_commands.mli} (100%) diff --git a/src/bin_client/main_admin.ml b/src/bin_client/main_admin.ml index b64fe11a4..99737d514 100644 --- a/src/bin_client/main_admin.ml +++ b/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 ]) diff --git a/src/lib_client_base/client_admin.ml b/src/lib_client_base/client_admin_commands.ml similarity index 56% rename from src/lib_client_base/client_admin.ml rename to src/lib_client_base/client_admin_commands.ml index 52e0c386b..14761b036 100644 --- a/src/lib_client_base/client_admin.ml +++ b/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) -> - Block_services.unmark_invalid cctxt block >>=? fun () -> - cctxt#message "Block %a no longer marked invalid" Block_hash.pp block >>= return) ; + @@ 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 >>= fun () -> + return ()) + blocks) ; ] diff --git a/src/lib_client_base/client_admin.mli b/src/lib_client_base/client_admin_commands.mli similarity index 100% rename from src/lib_client_base/client_admin.mli rename to src/lib_client_base/client_admin_commands.mli diff --git a/src/lib_client_base/client_debug.ml b/src/lib_client_base/client_debug.ml deleted file mode 100644 index 837bcd9ce..000000000 --- a/src/lib_client_base/client_debug.ml +++ /dev/null @@ -1,154 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2016. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* 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 - "@[Hash: %a\ - @ Test network: %a\ - @ Level: %ld\ - @ Proto_level: %d\ - @ Predecessor: %a\ - @ Protocol: %a\ - @ Net id: %a\ - @ Timestamp: %a\ - @ Fitness: @[%a@]\ - @ Operations hash: %a\ - @ Operations: @[%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 - "@[Hash: %a\ - @ Level: %ld\ - @ Errors: @[%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 "@.") ; - ] diff --git a/src/lib_client_base/client_report_commands.ml b/src/lib_client_base/client_report_commands.ml new file mode 100644 index 000000000..52b4690ef --- /dev/null +++ b/src/lib_client_base/client_report_commands.ml @@ -0,0 +1,128 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 + "@[Hash: %a\ + @ Test network: %a\ + @ Level: %ld\ + @ Proto_level: %d\ + @ Predecessor: %a\ + @ Protocol: %a\ + @ Net id: %a\ + @ Timestamp: %a\ + @ Fitness: @[%a@]\ + @ Operations hash: %a\ + @ Operations: @[%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 + "@[Hash: %a\ + @ Level: %ld\ + @ Errors: @[%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 + "@[@{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 ()) ; + ] diff --git a/src/lib_client_base/client_debug.mli b/src/lib_client_base/client_report_commands.mli similarity index 100% rename from src/lib_client_base/client_debug.mli rename to src/lib_client_base/client_report_commands.mli