Client: stuck node debug command

src/client/client_debug.ml

@@ -0,0 +1,122 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    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
+    { Node_rpc_services.Blocks.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): \"%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
+         "@[<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
+  [
+    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)
+  ]

src/client/client_debug.mli

@@ -0,0 +1,11 @@
+(**************************************************************************)
+(*                                                                        *)
+(*    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.context, unit) Cli_entries.command list

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 ;

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 "@[<v 2>Not running@]"
+  | Forking { protocol ; expiration } ->
+      Format.fprintf ppf
+        "@[<v 2>Forking %a (expires %a)@]"
+        Hash.Protocol_hash.pp
+        protocol
+        Time.pp_hum
+        expiration
+  | Running { net_id ; genesis ; protocol ; expiration } ->
+      Format.fprintf ppf
+        "@[<v 2>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 [

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