Add client method to generate hard fork config

Author: cjjdespres

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

@@ -2289,6 +2289,27 @@ let thread_graph =
                   (humanize_graphql_error ~graphql_endpoint e) ) ;
              exit 1 ) )
 
+let 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
+         | Ok () ->
+             printf "Hardfork configuration successfully generated\n" ;
+             exit 0
+         | Error e ->
+             eprintf "Failed to generate hard fork config: %s\n"
+               (Error.to_string_hum e) ;
+             exit 1 ) )
+
 let signature_kind =
   Command.basic
     ~summary:"Print the signature kind that this binary is compiled with"
@@ -2533,6 +2554,7 @@ let advanced ~itn_features =
     ; ("vrf", Cli_lib.Commands.Vrf.command_group)
     ; ("thread-graph", thread_graph)
     ; ("print-signature-kind", signature_kind)
+    ; ("generate-hardfork-config", generate_hardfork_config)
     ; ( "test"
       , Command.group ~summary:"Testing-only commands"
           [ ("create-genesis", test_genesis_creation) ] )

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

@@ -369,6 +369,10 @@ 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 ->
+          Mina_lib.Hardfork_config.dump_reference_config
+            ~breadcrumb_spec:`Stop_slot ~directory_name mina )
     ; 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

@@ -2618,6 +2618,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.mli

@@ -138,7 +138,9 @@ module Make
   val create_checkpoint_with_directory :
     t -> directory_name:string -> t
 
-  (** Convert a root backed by a [Config.Stable_db] to *)
+  (** Convert a root backed by a [Config.Stable_db] to one backed by a
+      [Config.Converting_db] by gradually migrating the stable database. Does
+      nothing if the backing is already [Config.Converting_db]. *)
   val make_converting : t -> t Async.Deferred.t
 
   (** View the root ledger as an unmasked [Any_ledger] so it can be used by code

src/lib/mina_lib/mina_lib.ml

@@ -2828,6 +2828,7 @@ module Hardfork_config = struct
     ; staking_epoch_seed : Epoch_seed.t
     ; next_epoch_seed : Epoch_seed.t
     ; blockchain_length : Mina_numbers.Length.t
+    ; block_timestamp : Block_time.t
     }
 
   let prepare_inputs ~breadcrumb_spec mina =
@@ -2840,6 +2841,7 @@ module Hardfork_config = struct
       |> Consensus.Data.Consensus_state.global_slot_since_genesis
     in
     let state_hash = Transition_frontier.Breadcrumb.state_hash breadcrumb in
+    let block_timestamp = block |> Mina_block.timestamp in
     let protocol_state =
       Transition_frontier.Breadcrumb.protocol_state breadcrumb
     in
@@ -2859,7 +2861,256 @@ module Hardfork_config = struct
     ; staking_epoch_seed
     ; next_epoch_seed
     ; blockchain_length
+    ; block_timestamp
     }
+
+  (** Copy the roots of the [source_ledgers] and gather the stable ledger
+      diffs from the [source_ledgers] to their roots *)
+  let copy_genesis_roots_and_diffs ~source_ledgers parent_directory =
+    Core.Unix.mkdir_p parent_directory ;
+    let genesis_ledger_data =
+      let directory_name = parent_directory ^/ "genesis_ledger" in
+      let root =
+        Ledger.Root.create_checkpoint_with_directory
+          source_ledgers.root_snarked_ledger ~directory_name
+      in
+      let diff = Ledger.all_accounts_on_masks source_ledgers.staged_ledger in
+      (root, diff)
+    in
+    let genesis_staking_ledger_data =
+      let directory_name = parent_directory ^/ "staking_ledger" in
+      match source_ledgers.staking_ledger with
+      | `Genesis _l ->
+          failwith "TODO!"
+      | `Root l ->
+          let root =
+            Ledger.Root.create_checkpoint_with_directory l ~directory_name
+          in
+          let diff = Ledger.Location.Map.empty in
+          (root, diff)
+    in
+    let genesis_next_epoch_ledger_data =
+      let directory_name = parent_directory ^/ "next_epoch_ledger" in
+      match source_ledgers.next_epoch_ledger with
+      | `Genesis _l ->
+          failwith "TODO!"
+      | `Root l ->
+          let root =
+            Ledger.Root.create_checkpoint_with_directory l ~directory_name
+          in
+          let diff = Ledger.Location.Map.empty in
+          (root, diff)
+      | `Uncommitted l ->
+          let root =
+            Ledger.Root.create_checkpoint_with_directory
+              source_ledgers.root_snarked_ledger ~directory_name
+          in
+          let diff = Ledger.all_accounts_on_masks l in
+          (root, diff)
+    in
+    ( genesis_ledger_data
+    , genesis_staking_ledger_data
+    , genesis_next_epoch_ledger_data )
+
+  (** Generate the tar file and runtime ledger config for the given root
+      database, and close and delete the database *)
+  let generate_tar_and_config ~get_directory ~get_root_hash ~close_root ~logger
+      ~target_dir ~ledger_name_prefix root =
+    let open Deferred.Or_error.Let_syntax in
+    let root_hash = get_root_hash root in
+    let ledger_dirname = get_directory root |> Option.value_exn in
+    let%bind tar_path =
+      Genesis_ledger_helper.Ledger.generate_tar ~logger ~target_dir
+        ~ledger_name_prefix ~root_hash ~ledger_dirname ()
+    in
+    let%map s3_data_hash =
+      Genesis_ledger_helper.sha3_hash tar_path
+      |> Deferred.map ~f:Or_error.return
+    in
+    let config =
+      Runtime_config.ledger_of_hashes
+        ~root_hash:(Mina_base.Ledger_hash.to_base58_check root_hash)
+        ~s3_data_hash ()
+    in
+    close_root root ;
+    Mina_stdlib_unix.File_system.rmrf ledger_dirname ;
+    config
+
+  let generate_tars_and_configs ~get_directory ~get_root_hash ~close_root
+      ~logger ~target_dir genesis_ledger genesis_staking_ledger
+      genesis_next_epoch_ledger =
+    let open Deferred.Or_error.Let_syntax in
+    Core.Unix.mkdir_p target_dir ;
+    let%bind genesis_ledger_config =
+      generate_tar_and_config ~get_directory ~get_root_hash ~close_root ~logger
+        ~target_dir ~ledger_name_prefix:"genesis_ledger" genesis_ledger
+    in
+    let%bind genesis_staking_ledger_config =
+      generate_tar_and_config ~get_directory ~get_root_hash ~close_root ~logger
+        ~target_dir ~ledger_name_prefix:"epoch_ledger" genesis_staking_ledger
+    in
+    let%map genesis_next_epoch_ledger_config =
+      generate_tar_and_config ~get_directory ~get_root_hash ~close_root ~logger
+        ~target_dir ~ledger_name_prefix:"epoch_ledger" genesis_next_epoch_ledger
+    in
+    ( genesis_ledger_config
+    , genesis_staking_ledger_config
+    , genesis_next_epoch_ledger_config )
+
+  let make_full_config ~genesis_state_timestamp ~global_slot_since_genesis
+      ~state_hash ~blockchain_length ~staking_epoch_seed ~next_epoch_seed
+      ( genesis_ledger_config
+      , genesis_staking_ledger_config
+      , genesis_next_epoch_ledger_config ) =
+    Runtime_config.make_automatic_fork_config ~genesis_state_timestamp
+      ~genesis_ledger_config ~global_slot_since_genesis ~state_hash
+      ~blockchain_length ~staking_ledger_config:genesis_staking_ledger_config
+      ~staking_epoch_seed:(Epoch_seed.to_base58_check staking_epoch_seed)
+      ~next_epoch_ledger_config:(Some genesis_next_epoch_ledger_config)
+      ~next_epoch_seed:(Epoch_seed.to_base58_check next_epoch_seed)
+
+  let write_config_file ~filename daemon_config =
+    Async.Writer.save filename
+      ~contents:(Yojson.Safe.to_string (Runtime_config.to_yojson daemon_config))
+    |> Deferred.map ~f:Or_error.return
+
+  let write_stable_config_directory ~logger ~genesis_state_timestamp
+      ~global_slot_since_genesis ~state_hash ~staking_epoch_seed
+      ~next_epoch_seed ~blockchain_length ~config_dir genesis_ledger
+      genesis_staking_ledger genesis_next_epoch_ledger =
+    let open Deferred.Or_error.Let_syntax in
+    [%log debug]
+      "Generating database files and daemon.json for stable hard fork config" ;
+    Core.Unix.mkdir_p config_dir ;
+    let genesis_dir = config_dir ^/ "genesis" in
+    let%bind genesis_config =
+      generate_tars_and_configs ~get_directory:Ledger.Db.get_directory
+        ~get_root_hash:Ledger.Db.merkle_root ~close_root:Ledger.Db.close ~logger
+        ~target_dir:genesis_dir genesis_ledger genesis_staking_ledger
+        genesis_next_epoch_ledger
+    in
+    write_config_file
+      ~filename:(config_dir ^/ "daemon.json")
+      (make_full_config ~genesis_state_timestamp ~global_slot_since_genesis
+         ~state_hash ~blockchain_length ~staking_epoch_seed ~next_epoch_seed
+         genesis_config )
+
+  let write_migrated_config_directory ~logger ~genesis_state_timestamp
+      ~global_slot_since_genesis ~state_hash ~staking_epoch_seed
+      ~next_epoch_seed ~blockchain_length ~config_dir genesis_ledger
+      genesis_staking_ledger genesis_next_epoch_ledger =
+    let open Deferred.Or_error.Let_syntax in
+    [%log debug]
+      "Generating database files and daemon.json for migrated hard fork config" ;
+    Core.Unix.mkdir_p config_dir ;
+    let genesis_dir = config_dir ^/ "genesis" in
+    let%bind genesis_config =
+      generate_tars_and_configs ~get_directory:Ledger.Hardfork_db.get_directory
+        ~get_root_hash:Ledger.Hardfork_db.merkle_root
+        ~close_root:Ledger.Hardfork_db.close ~logger ~target_dir:genesis_dir
+        genesis_ledger genesis_staking_ledger genesis_next_epoch_ledger
+    in
+    write_config_file
+      ~filename:(config_dir ^/ "daemon.json")
+      (make_full_config ~genesis_state_timestamp ~global_slot_since_genesis
+         ~state_hash ~blockchain_length ~staking_epoch_seed ~next_epoch_seed
+         genesis_config )
+
+  let genesis_timestamp_str ~hardfork_genesis_timestamp_offset block_timestamp =
+    block_timestamp |> Block_time.to_time_exn
+    |> Fn.flip Time.add hardfork_genesis_timestamp_offset
+    |> Time.to_string_iso8601_basic ~zone:Time.Zone.utc
+
+  let generate_hardfork_configs ~logger
+      ~inputs:
+        { source_ledgers
+        ; global_slot_since_genesis
+        ; state_hash
+        ; staking_epoch_seed
+        ; next_epoch_seed
+        ; blockchain_length
+        ; block_timestamp
+        } ~build_dir directory_name =
+    let open Deferred.Or_error.Let_syntax in
+    let migrate_and_apply (root, diff) =
+      let%map.Deferred root = Ledger.Root.make_converting root in
+      Ledger.Any_ledger.M.set_batch
+        (Ledger.Root.as_unmasked root)
+        (Map.to_alist diff) ;
+      let stable_db, migrated_db_opt =
+        Ledger.Root.unsafely_decompose_root root
+      in
+      let migrated_db =
+        migrated_db_opt
+        |> Option.value_exn
+             ~message:"Invariant: root was already made converting"
+      in
+      (stable_db, migrated_db)
+    in
+    [%log debug] "Copying hard fork genesis ledger inputs" ;
+    let ( genesis_ledger_data
+        , genesis_staking_ledger_data
+        , genesis_next_epoch_ledger_data ) =
+      copy_genesis_roots_and_diffs ~source_ledgers build_dir
+    in
+    let%bind.Deferred genesis_ledger_legacy, genesis_ledger_migrated =
+      migrate_and_apply genesis_ledger_data
+    in
+    let%bind.Deferred ( genesis_staking_ledger_legacy
+                      , genesis_staking_ledger_migrated ) =
+      migrate_and_apply genesis_staking_ledger_data
+    in
+    let%bind.Deferred ( genesis_next_epoch_ledger_legacy
+                      , genesis_next_epoch_ledger_migrated ) =
+      migrate_and_apply genesis_next_epoch_ledger_data
+    in
+    (* TODO: the correct timestamp is actually the timestamp of the slot_tx_end plus the hardfork genesis offset *)
+    let genesis_state_timestamp =
+      genesis_timestamp_str
+        ~hardfork_genesis_timestamp_offset:(Time.Span.of_int_sec 0)
+        block_timestamp
+    in
+    [%log debug] "Writing hard fork config directories" ;
+    let%bind () =
+      write_stable_config_directory ~logger ~genesis_state_timestamp
+        ~global_slot_since_genesis ~state_hash ~staking_epoch_seed
+        ~next_epoch_seed ~blockchain_length
+        ~config_dir:(directory_name ^/ "fork_validation" ^/ "legacy")
+        genesis_ledger_legacy genesis_staking_ledger_legacy
+        genesis_next_epoch_ledger_legacy
+    in
+    let%bind () =
+      write_migrated_config_directory ~logger ~genesis_state_timestamp
+        ~global_slot_since_genesis ~state_hash ~staking_epoch_seed
+        ~next_epoch_seed ~blockchain_length ~config_dir:directory_name
+        genesis_ledger_migrated genesis_staking_ledger_migrated
+        genesis_next_epoch_ledger_migrated
+    in
+    return ()
+
+  let dump_reference_config ~breadcrumb_spec ~directory_name mina =
+    let open Deferred.Or_error.Let_syntax in
+    let logger = mina.config.logger in
+    Deferred.Or_error.try_with_join ~here:[%here]
+    @@ fun () ->
+    let%bind.Deferred dir_exists =
+      Mina_stdlib_unix.File_system.dir_exists directory_name
+    in
+    let%bind () =
+      if dir_exists then
+        Deferred.Or_error.error_string
+          "Requested config directory already exists"
+      else return ()
+    in
+    [%log debug] "Creating reference hard fork config in $directory_name"
+      ~metadata:[ ("directory_name", `String directory_name) ] ;
+    let%bind.Deferred () =
+      Mina_stdlib_unix.File_system.create_dir directory_name
+    in
+    let%bind inputs = prepare_inputs ~breadcrumb_spec mina in
+    Mina_stdlib_unix.File_system.with_temp_dir (directory_name ^/ "_build")
+      ~f:(fun build_dir ->
+        generate_hardfork_configs ~logger ~inputs ~build_dir directory_name )
 end
 
 let zkapp_cmd_limit t = t.config.zkapp_cmd_limit

src/lib/mina_lib/mina_lib.mli

@@ -327,10 +327,27 @@ module Hardfork_config : sig
     ; staking_epoch_seed : Epoch_seed.t
     ; next_epoch_seed : Epoch_seed.t
     ; blockchain_length : Mina_numbers.Length.t
+    ; block_timestamp : Block_time.t
     }
 
   val prepare_inputs :
     breadcrumb_spec:breadcrumb_spec -> mina_lib -> inputs Deferred.Or_error.t
+
+  (** Compute a full hard fork config (genesis ledger, genesis epoch ledgers,
+      and node config) both without hard fork ledger migrations applied (the
+      "legacy" format, compatible with the current daemon) and with the hard
+      fork ledger migrations applied (the actual hard fork format, compatible
+      with a hard fork daemon). The legacy format config will be saved in
+      [daemon.legacy.json] and [genesis_legacy/] in [directory_name], and the
+      hard fork format files will be saved in [daemon.json] and [genesis/] in
+      that same directory. An empty [activated] file will be created in
+      [directory_name] at the very end of this process to indicate that the
+      config was generated successfully. *)
+  val dump_reference_config :
+       breadcrumb_spec:breadcrumb_spec
+    -> directory_name:string
+    -> mina_lib
+    -> unit Deferred.Or_error.t
 end
 
 val zkapp_cmd_limit : t -> int option ref