Add hard fork config dump and command

Author: cjjdespres

src/app/cli/src/init/client.ml

@@ -2312,6 +2312,28 @@ let test_genesis_creation =
      Cli_lib.Exceptions.handle_nicely
        Test_genesis_creation.time_genesis_creation )
 
+let test_generate_hardfork_config =
+  let open Command.Param in
+  let hardfork_config_dir_flag =
+    flag "--hardfork-config-dir"
+      ~doc:"DIR Directory to generate hardfork configuration" (required string)
+  in
+  Command.async ~summary:"Generate reference hardfork configuration"
+    (Cli_lib.Background_daemon.rpc_init hardfork_config_dir_flag
+       ~f:(fun port directory_name ->
+         match%bind
+           Daemon_rpcs.Client.dispatch_join_errors
+             Daemon_rpcs.Generate_hardfork_config.rpc directory_name port
+         with
+         | Error e ->
+             eprintf "Failed to request hardfork config generation: %s\n"
+               (Error.to_string_hum e) ;
+             exit 17
+         | Ok () ->
+             printf "Hardfork configuration successfully requested in %s\n"
+               directory_name ;
+             exit 0 ) )
+
 let test_ledger_application =
   Command.async ~summary:"Test ledger application"
     (let%map_open.Command privkey_path = Cli_lib.Flag.privkey_read_path
@@ -2535,7 +2557,9 @@ let advanced ~itn_features =
     ; ("print-signature-kind", signature_kind)
     ; ( "test"
       , Command.group ~summary:"Testing-only commands"
-          [ ("create-genesis", test_genesis_creation) ] )
+          [ ("create-genesis", test_genesis_creation)
+          ; ("generate-hardfork-config", test_generate_hardfork_config)
+          ] )
     ]
   in
   let cmds =

src/app/cli/src/init/mina_run.ml

@@ -369,6 +369,23 @@ let setup_local_server ?(client_trustlist = []) ?rest_server_port
     ; implement Daemon_rpcs.Get_object_lifetime_statistics.rpc (fun () () ->
           return
             (Yojson.Safe.pretty_to_string @@ Allocation_functor.Table.dump ()) )
+    ; implement Daemon_rpcs.Generate_hardfork_config.rpc
+        (fun () directory_name ->
+          let dump () =
+            let%map result =
+              Mina_lib.Hardfork_config.dump_reference_config
+                ~breadcrumb_spec:`Stop_slot ~directory_name mina
+            in
+            match result with
+            | Error e ->
+                [%log warn]
+                  !"Failed to generate hardfork config: %s"
+                  (Error.to_string_hum e)
+            | Ok _ ->
+                ()
+          in
+          don't_wait_for (dump ()) ;
+          return (Ok ()) )
     ; implement Daemon_rpcs.Submit_internal_log.rpc
         (fun () { timestamp; message; metadata; process } ->
           let metadata =

src/lib/daemon_rpcs/daemon_rpcs.ml

@@ -346,3 +346,13 @@ module Get_object_lifetime_statistics = struct
     Rpc.Rpc.create ~name:"Get_object_lifetime_statistics" ~version:0 ~bin_query
       ~bin_response
 end
+
+module Generate_hardfork_config = struct
+  type query = string [@@deriving bin_io_unversioned]
+
+  type response = unit Or_error.t [@@deriving bin_io_unversioned]
+
+  let rpc : (query, response) Rpc.Rpc.t =
+    Rpc.Rpc.create ~name:"Generate_hardfork_config" ~version:0 ~bin_query
+      ~bin_response
+end

src/lib/mina_graphql/mina_graphql.ml

@@ -2617,6 +2617,7 @@ module Queries = struct
                  ; staking_epoch_seed
                  ; next_epoch_seed
                  ; blockchain_length
+                 ; block_timestamp = _
                  } =
           Mina_lib.Hardfork_config.prepare_inputs ~breadcrumb_spec mina
         in

src/lib/mina_ledger/root.ml

@@ -215,26 +215,24 @@ struct
              ; backing_2 = Config.backing_of_config config
              } )
 
-  let create_component_checkpoints t ~directory_name =
-    let stable_db, unstable_db_opt =
-      match t with
-      | Stable_db db ->
-          (db, None)
-      | Converting_db db ->
-          ( Converting_ledger.primary_ledger db
-          , Some (Converting_ledger.converting_ledger db) )
-    in
-    let config = Converting_ledger.Config.with_primary ~directory_name in
-    let stable_checkpoint =
-      Stable_db.create_checkpoint stable_db
-        ~directory_name:config.primary_directory ()
-    in
-    let unstable_checkpoint =
-      Option.map unstable_db_opt ~f:(fun unstable_db ->
-          Unstable_db.create_checkpoint unstable_db
-            ~directory_name:config.converting_directory () )
-    in
-    (stable_checkpoint, unstable_checkpoint)
+  let create_stable_checkpoint t ~directory_name =
+    match t with
+    | Stable_db db ->
+        Stable_db.create_checkpoint db ~directory_name ()
+    | Converting_db db ->
+        Stable_db.create_checkpoint
+          (Converting_ledger.primary_ledger db)
+          ~directory_name ()
+
+  let create_migrated_checkpoint t ~directory_name =
+    match t with
+    | Stable_db _db ->
+        None
+    | Converting_db db ->
+        Some
+          (Migrated_db.create_checkpoint
+             (Converting_ledger.converting_ledger db)
+             ~directory_name () )
 
   let as_unmasked t =
     match t with

src/lib/mina_ledger/root.mli

@@ -130,10 +130,10 @@ module Make
   (** Make a checkpoint of the root ledger *)
   val make_checkpoint : t -> config:Config.t -> unit
 
-  (** Make a checkpoint of the existing components of the root ledger and return
-      new ledgers backed by those separate components *)
-  val create_component_checkpoints :
-    t -> directory_name:string -> Stable_db.t * Unstable_db.t option
+  val create_stable_checkpoint : t -> directory_name:string -> Stable_db.t
+
+  val create_migrated_checkpoint :
+    t -> directory_name:string -> Migrated_db.t option
 
   (** View the root ledger as an unmasked [Any_ledger] so it can be used by code
       that does not need to know how the root is implemented *)