diff --git a/src/client/client_debug.ml b/src/client/client_debug.ml new file mode 100644 index 000000000..91d72faa6 --- /dev/null +++ b/src/client/client_debug.ml @@ -0,0 +1,122 @@ +(**************************************************************************) +(* *) +(* 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 + { Node_rpc_services.Blocks.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): \"%s\"@]" + Hash.Block_hash.pp hash + Context.pp_test_network test_network + level + proto_level + Hash.Block_hash.pp predecessor + Hash.Protocol_hash.pp protocol + Hash.Net_id.pp net_id + Time.pp_hum timestamp + (Format.pp_print_list + ~pp_sep:Format.pp_print_space + Format.pp_print_string) + (List.map Hex_encode.hex_of_bytes fitness) + Hash.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, _) -> Hash.Operation_hash.pp ppf oph)) + ppf operations) + operations + (Hex_encode.hex_of_bytes data) + +let stuck_node_report (cctxt : Client_commands.context) file = + let ppf = Format.formatter_of_out_channel (open_out file) in + let skip_line () = + Format.pp_print_newline ppf (); + return @@ Format.pp_print_newline ppf () in + let print_title title level = + Format.fprintf ppf "%s %s@.@." (String.init level (fun _ -> '#')) title; + return () in + print_title "Stuck node report:" 1 >>=? fun () -> + 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, _) -> Hash.Protocol_hash.pp ppf protocol) + ppf + (Client_commands.get_versions ()) >>=? fun () -> + skip_line () >>=? fun () -> + print_title "Heads:" 2 >>=? fun () -> + Client_rpcs.call_service0 cctxt.rpc_config Node_rpc_services.Blocks.list + { include_ops = true ; + length = Some 1 ; + heads = None ; + monitor = None ; + delay = None ; + min_date = None ; + min_heads = None } >>=? 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 >>=? fun () -> + skip_line () >>=? fun () -> + print_title "Rejected blocks:" 2 >>=? fun () -> + Client_rpcs.call_service0 + cctxt.rpc_config + Node_rpc_services.Blocks.list_invalid () >>=? 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 + [ + command ~desc: "debug report" + no_options + (prefixes [ "debug" ; "stuck" ; "node" ] + @@ string ~name:"file" ~desc:"file in which to save report" + @@ stop) + (fun () file cctxt -> + stuck_node_report cctxt file) + ] diff --git a/src/client/client_debug.mli b/src/client/client_debug.mli new file mode 100644 index 000000000..3ac41ba29 --- /dev/null +++ b/src/client/client_debug.mli @@ -0,0 +1,11 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + + +val commands : unit -> (Client_commands.context, unit) Cli_entries.command list diff --git a/src/client_main.ml b/src/client_main.ml index 6b050fab1..4c4cadd11 100644 --- a/src/client_main.ml +++ b/src/client_main.ml @@ -86,6 +86,7 @@ let main () = Client_keys.commands () @ Client_protocols.commands () @ Client_helpers.commands () @ + Client_debug.commands () @ commands_for_version in let config : Client_commands.cfg = { base_dir = parsed_config_file.base_dir ; diff --git a/src/node/db/context.ml b/src/node/db/context.ml index 541be4af8..62b162d1a 100644 --- a/src/node/db/context.ml +++ b/src/node/db/context.ml @@ -192,6 +192,26 @@ type test_network = expiration: Time.t ; } +let pp_test_network ppf = function + | Not_running -> Format.fprintf ppf "@[Not running@]" + | Forking { protocol ; expiration } -> + Format.fprintf ppf + "@[Forking %a (expires %a)@]" + Hash.Protocol_hash.pp + protocol + Time.pp_hum + expiration + | Running { net_id ; genesis ; protocol ; expiration } -> + Format.fprintf ppf + "@[Running %a\ + @ Genesis: %a\ + @ Net id: %a\ + @ Expiration: %a@]" + Hash.Protocol_hash.pp protocol + Hash.Block_hash.pp genesis + Hash.Net_id.pp net_id + Time.pp_hum expiration + let test_network_encoding = let open Data_encoding in union [ diff --git a/src/node/db/context.mli b/src/node/db/context.mli index 88acdb18b..2cd91ab38 100644 --- a/src/node/db/context.mli +++ b/src/node/db/context.mli @@ -90,6 +90,8 @@ type test_network = expiration: Time.t ; } +val pp_test_network : Format.formatter -> test_network -> unit + val test_network_encoding: test_network Data_encoding.t val get_test_network: context -> test_network Lwt.t