diff --git a/src/app/cli/src/cli_entrypoint/mina_cli_entrypoint.ml b/src/app/cli/src/cli_entrypoint/mina_cli_entrypoint.ml index 7e3582752aa..491c63c8125 100644 --- a/src/app/cli/src/cli_entrypoint/mina_cli_entrypoint.ml +++ b/src/app/cli/src/cli_entrypoint/mina_cli_entrypoint.ml @@ -1006,7 +1006,7 @@ let setup_daemon logger ~itn_features = let module Context = struct let logger = logger - let precomputed_values = precomputed_values + let compile_config = precomputed_values.compile_config let constraint_constants = precomputed_values.constraint_constants diff --git a/src/config/dev.mlh b/src/config/dev.mlh index 5b190d27948..a948916349c 100644 --- a/src/config/dev.mlh +++ b/src/config/dev.mlh @@ -78,3 +78,7 @@ [%%undef compaction_interval] [%%define vrf_poll_interval 0] [%%undef zkapp_cmd_limit] + +(* Sync ledger query/response size*) +[%%define sync_ledger_max_subtree_depth 4] +[%%define sync_ledger_default_subtree_depth 3] diff --git a/src/config/devnet.mlh b/src/config/devnet.mlh index 5098de491e3..9c203a208ee 100644 --- a/src/config/devnet.mlh +++ b/src/config/devnet.mlh @@ -73,3 +73,7 @@ [%%define vrf_poll_interval 5000] [%%define zkapp_cmd_limit 24] [%%undef scan_state_transaction_capacity_log_2] + +(* Constants determining sync ledger query/response size*) +[%%define sync_ledger_max_subtree_depth 8] +[%%define sync_ledger_default_subtree_depth 6] \ No newline at end of file diff --git a/src/config/lightnet.mlh b/src/config/lightnet.mlh index 47865689790..6551a8c6adc 100644 --- a/src/config/lightnet.mlh +++ b/src/config/lightnet.mlh @@ -72,3 +72,7 @@ [%%define compaction_interval 360000] [%%define vrf_poll_interval 5000] [%%undef zkapp_cmd_limit] + +(* Constants determining sync ledger query/response size*) +[%%define sync_ledger_max_subtree_depth 8] +[%%define sync_ledger_default_subtree_depth 6] diff --git a/src/config/mainnet.mlh b/src/config/mainnet.mlh index fbb41e3d3cc..11e8c897db9 100644 --- a/src/config/mainnet.mlh +++ b/src/config/mainnet.mlh @@ -73,3 +73,7 @@ [%%define vrf_poll_interval 5000] [%%define zkapp_cmd_limit 24] [%%undef scan_state_transaction_capacity_log_2] + +(* Constants determining sync ledger query/response size*) +[%%define sync_ledger_max_subtree_depth 8] +[%%define sync_ledger_default_subtree_depth 6] diff --git a/src/lib/block_producer/block_producer.ml b/src/lib/block_producer/block_producer.ml index af74fca3fb4..e092d41e18c 100644 --- a/src/lib/block_producer/block_producer.ml +++ b/src/lib/block_producer/block_producer.ml @@ -819,12 +819,17 @@ let produce ~genesis_breadcrumb ~context:(module Context : CONTEXT) ~prover (Mina_base.State_hash.to_base58_check protocol_state_hashes.state_hash ) ) ] ; + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in Internal_tracing.with_state_hash protocol_state_hashes.state_hash @@ fun () -> Debug_assert.debug_assert (fun () -> [%test_result: [ `Take | `Keep ]] (Consensus.Hooks.select - ~context:(module Context) + ~context:(module Consensus_context) ~existing: (With_hash.map ~f:Mina_block.consensus_state previous_transition ) @@ -839,7 +844,7 @@ let produce ~genesis_breadcrumb ~context:(module Context : CONTEXT) ~prover in [%test_result: [ `Take | `Keep ]] (Consensus.Hooks.select - ~context:(module Context) + ~context:(module Consensus_context) ~existing:root_consensus_state_with_hashes ~candidate:consensus_state_with_hashes ) ~expect:`Take @@ -908,7 +913,7 @@ let produce ~genesis_breadcrumb ~context:(module Context : CONTEXT) ~prover `This_block_was_not_received_via_gossip >>= Validation.validate_frontier_dependencies ~to_header:Mina_block.header - ~context:(module Context) + ~context:(module Consensus_context) ~root_block: ( Transition_frontier.root frontier |> Breadcrumb.block_with_hash ) @@ -1412,10 +1417,15 @@ let run_precomputed ~context:(module Context : CONTEXT) ~verifier ~trust_system Header.protocol_state @@ Mina_block.header (With_hash.data previous_transition) in + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in Debug_assert.debug_assert (fun () -> [%test_result: [ `Take | `Keep ]] (Consensus.Hooks.select - ~context:(module Context) + ~context:(module Consensus_context) ~existing: (With_hash.map ~f:Mina_block.consensus_state previous_transition ) @@ -1430,7 +1440,7 @@ let run_precomputed ~context:(module Context : CONTEXT) ~verifier ~trust_system in [%test_result: [ `Take | `Keep ]] (Consensus.Hooks.select - ~context:(module Context) + ~context:(module Consensus_context) ~existing:root_consensus_state_with_hashes ~candidate:consensus_state_with_hashes ) ~expect:`Take @@ -1468,7 +1478,7 @@ let run_precomputed ~context:(module Context : CONTEXT) ~verifier ~trust_system previous_protocol_state ) >>= Validation.validate_frontier_dependencies ~to_header:Mina_block.header - ~context:(module Context) + ~context:(module Consensus_context) ~root_block: ( Transition_frontier.root frontier |> Breadcrumb.block_with_hash ) diff --git a/src/lib/bootstrap_controller/bootstrap_controller.ml b/src/lib/bootstrap_controller/bootstrap_controller.ml index 0480d70faef..07ff47f8b9c 100644 --- a/src/lib/bootstrap_controller/bootstrap_controller.ml +++ b/src/lib/bootstrap_controller/bootstrap_controller.ml @@ -17,8 +17,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end type Structured_log_events.t += Bootstrap_complete @@ -65,9 +63,11 @@ let time_deferred deferred = (Time.diff end_time start_time, result) let worth_getting_root ({ context = (module Context); _ } as t) candidate = - let module Context = struct + let module Consensus_context = struct include Context + let compile_config = precomputed_values.compile_config + let logger = Logger.extend logger [ ( "selection_context" @@ -76,7 +76,7 @@ let worth_getting_root ({ context = (module Context); _ } as t) candidate = end in Consensus.Hooks.equal_select_status `Take @@ Consensus.Hooks.select - ~context:(module Context) + ~context:(module Consensus_context) ~existing: ( t.best_seen_transition |> Mina_block.Validation.block_with_hash |> With_hash.map ~f:Mina_block.consensus_state ) @@ -152,7 +152,7 @@ let to_consensus_state h = the existing one, then reset the Sync_ledger's target by calling [start_sync_job_with_peer] function. *) let on_transition ({ context = (module Context); _ } as t) ~sender - ~root_sync_ledger ~genesis_constants candidate_header = + ~root_sync_ledger candidate_header = let open Context in let candidate_consensus_state = With_hash.map ~f:to_consensus_state candidate_header @@ -175,7 +175,7 @@ let on_transition ({ context = (module Context); _ } as t) ~sender match%bind Sync_handler.Root.verify ~context:(module Context) - ~verifier:t.verifier ~genesis_constants candidate_consensus_state + ~verifier:t.verifier candidate_consensus_state peer_root_with_proof.data with | Ok (`Root root, `Best_tip best_tip) -> @@ -189,7 +189,7 @@ let on_transition ({ context = (module Context); _ } as t) ~sender incoming transitions, add those to the transition_cache and calls [on_transition] function. *) let sync_ledger ({ context = (module Context); _ } as t) ~preferred - ~root_sync_ledger ~transition_graph ~sync_ledger_reader ~genesis_constants = + ~root_sync_ledger ~transition_graph ~sync_ledger_reader = let open Context in let query_reader = Sync_ledger.Db.query_reader root_sync_ledger in let response_writer = Sync_ledger.Db.answer_writer root_sync_ledger in @@ -232,11 +232,15 @@ let sync_ledger ({ context = (module Context); _ } as t) ~preferred ] ; Deferred.ignore_m - @@ on_transition t ~sender ~root_sync_ledger ~genesis_constants - header_with_hash ) + @@ on_transition t ~sender ~root_sync_ledger header_with_hash ) else Deferred.unit ) let external_transition_compare ~context:(module Context : CONTEXT) = + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in let get_consensus_state = Fn.compose Protocol_state.consensus_state Mina_block.Header.protocol_state in @@ -250,7 +254,9 @@ let external_transition_compare ~context:(module Context : CONTEXT) = then 0 else if Consensus.Hooks.equal_select_status `Keep - @@ Consensus.Hooks.select ~context:(module Context) ~existing ~candidate + @@ Consensus.Hooks.select + ~context:(module Consensus_context) + ~existing ~candidate then -1 else 1 ) ~f:(With_hash.map ~f:get_consensus_state) @@ -273,10 +279,6 @@ let run ~context:(module Context : CONTEXT) ~trust_system ~verifier ~network ~persistent_frontier ~initial_root_transition ~catchup_mode = let open Context in O1trace.thread "bootstrap" (fun () -> - let genesis_constants = - Precomputed_values.genesis_constants precomputed_values - in - let constraint_constants = precomputed_values.constraint_constants in let rec loop previous_cycles = let sync_ledger_pipe = "sync ledger pipe" in let sync_ledger_reader, sync_ledger_writer = @@ -331,14 +333,21 @@ let run ~context:(module Context : CONTEXT) ~trust_system ~verifier ~network temp_persistent_root_instance in (* step 1. download snarked_ledger *) + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in let%bind sync_ledger_time, (hash, sender, expected_staged_ledger_hash) = time_deferred (let root_sync_ledger = - Sync_ledger.Db.create temp_snarked_ledger ~logger ~trust_system + Sync_ledger.Db.create temp_snarked_ledger + ~context:(module Consensus_context) + ~trust_system in don't_wait_for (sync_ledger t ~preferred:preferred_peers ~root_sync_ledger - ~transition_graph ~sync_ledger_reader ~genesis_constants ) ; + ~transition_graph ~sync_ledger_reader ) ; (* We ignore the resulting ledger returned here since it will always * be the same as the ledger we started with because we are syncing * a db ledger. *) @@ -565,7 +574,7 @@ let run ~context:(module Context : CONTEXT) ~trust_system ~verifier ~network [%log info] "Synchronizing consensus local state" ; let%map result = Consensus.Hooks.sync_local_state - ~context:(module Context) + ~context:(module Consensus_context) ~local_state:consensus_local_state ~trust_system ~glue_sync_ledger: (Mina_networking.glue_sync_ledger t.network) @@ -616,7 +625,7 @@ let run ~context:(module Context : CONTEXT) ~trust_system ~verifier ~network bootstrapping: " ^ msg ) in Transition_frontier.load - ~context:(module Context) + ~context:(module Consensus_context) ~retry_with_fresh_db:false ~verifier ~consensus_local_state ~persistent_root ~persistent_frontier ~catchup_mode () >>| function @@ -658,7 +667,7 @@ let run ~context:(module Context : CONTEXT) ~trust_system ~verifier ~network in Consensus.Hooks.equal_select_status `Take @@ Consensus.Hooks.select - ~context:(module Context) + ~context:(module Consensus_context) ~existing:root_consensus_state ~candidate: (With_hash.map @@ -741,8 +750,6 @@ let%test_module "Bootstrap_controller tests" = let constraint_constants = precomputed_values.constraint_constants - let compile_config = Mina_compile_config.For_unit_tests.t - module Context = struct let logger = logger @@ -752,8 +759,6 @@ let%test_module "Bootstrap_controller tests" = Genesis_constants.For_unit_tests.Constraint_constants.t let consensus_constants = precomputed_values.consensus_constants - - let compile_config = compile_config end let verifier = @@ -800,8 +805,7 @@ let%test_module "Bootstrap_controller tests" = let%bind fake_network = Fake_network.Generator.( gen ~precomputed_values ~verifier ~max_frontier_length - ~compile_config [ fresh_peer; fresh_peer ] - ~use_super_catchup:false) + [ fresh_peer; fresh_peer ] ~use_super_catchup:false) in let%map make_branch = Transition_frontier.Breadcrumb.For_tests.gen_seq ~precomputed_values @@ -829,16 +833,21 @@ let%test_module "Bootstrap_controller tests" = let bootstrap = make_non_running_bootstrap ~genesis_root ~network:me.network in + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in let root_sync_ledger = Sync_ledger.Db.create (Transition_frontier.root_snarked_ledger me.state.frontier) - ~logger ~trust_system + ~context:(module Consensus_context) + ~trust_system in Async.Thread_safe.block_on_async_exn (fun () -> let sync_deferred = sync_ledger bootstrap ~root_sync_ledger ~transition_graph ~preferred:[] ~sync_ledger_reader - ~genesis_constants:Genesis_constants.For_unit_tests.t in let%bind () = Deferred.List.iter branch ~f:(fun breadcrumb -> @@ -935,7 +944,7 @@ let%test_module "Bootstrap_controller tests" = Quickcheck.test ~trials:1 Fake_network.Generator.( gen ~precomputed_values ~verifier ~max_frontier_length - ~use_super_catchup:false ~compile_config + ~use_super_catchup:false [ fresh_peer ; peer_with_branch ~frontier_branch_size:((max_frontier_length * 2) + 2) diff --git a/src/lib/bootstrap_controller/bootstrap_controller.mli b/src/lib/bootstrap_controller/bootstrap_controller.mli index df18118e515..d9730576a92 100644 --- a/src/lib/bootstrap_controller/bootstrap_controller.mli +++ b/src/lib/bootstrap_controller/bootstrap_controller.mli @@ -11,8 +11,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end type Structured_log_events.t += Bootstrap_complete [@@deriving register_event] diff --git a/src/lib/consensus/intf.ml b/src/lib/consensus/intf.ml index d00f1b5b1b7..df4e178cac4 100644 --- a/src/lib/consensus/intf.ml +++ b/src/lib/consensus/intf.ml @@ -11,6 +11,8 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Constants.t + + val compile_config : Mina_compile_config.t end module type Constants = sig diff --git a/src/lib/consensus/proof_of_stake.ml b/src/lib/consensus/proof_of_stake.ml index 126d4797066..32abc3dd2e5 100644 --- a/src/lib/consensus/proof_of_stake.ml +++ b/src/lib/consensus/proof_of_stake.ml @@ -30,6 +30,8 @@ module Make_str (A : Wire_types.Concrete) = struct val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Constants.t + + val compile_config : Mina_compile_config.t end let make_checked t = Snark_params.Tick.Run.make_checked t @@ -2678,8 +2680,9 @@ module Make_str (A : Wire_types.Concrete) = struct (next_epoch_ledger_location local_state) in let sync_ledger = - Mina_ledger.Sync_ledger.Db.create ~logger ~trust_system - db_ledger + Mina_ledger.Sync_ledger.Db.create + ~context:(module Context) + ~trust_system db_ledger in let query_reader = Mina_ledger.Sync_ledger.Db.query_reader sync_ledger @@ -3107,6 +3110,8 @@ module Make_str (A : Wire_types.Concrete) = struct Genesis_constants.For_unit_tests.Constraint_constants.t let consensus_constants = Lazy.force Constants.for_unit_tests + + let compile_config = Mina_compile_config.For_unit_tests.t end in (* Even when consensus constants are of prod sizes, candidate should still trigger a bootstrap *) should_bootstrap_len @@ -3433,6 +3438,8 @@ module Make_str (A : Wire_types.Concrete) = struct let constraint_constants = constraint_constants let consensus_constants = constants + + let compile_config = Mina_compile_config.For_unit_tests.t end let test_update constraint_constants = diff --git a/src/lib/fake_network/fake_network.ml b/src/lib/fake_network/fake_network.ml index ba5d3639f13..611bf93bd05 100644 --- a/src/lib/fake_network/fake_network.ml +++ b/src/lib/fake_network/fake_network.ml @@ -14,8 +14,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end (* There must be at least 2 peers to create a network *) @@ -215,6 +213,11 @@ module Generator = struct ?get_transition_chain_proof ?get_ancestry ?get_best_tip ~context:(module Context : CONTEXT) ~verifier ~max_frontier_length ~use_super_catchup = + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in let open Context in let epoch_ledger_location = Filename.temp_dir_name ^/ "epoch_ledger" @@ -223,7 +226,7 @@ module Generator = struct let genesis_ledger = Precomputed_values.genesis_ledger precomputed_values in let consensus_local_state = Consensus.Data.Local_state.create Public_key.Compressed.Set.empty - ~context:(module Context) + ~context:(module Consensus_context) ~genesis_ledger ~genesis_epoch_data:precomputed_values.genesis_epoch_data ~epoch_ledger_location @@ -257,6 +260,11 @@ module Generator = struct ?get_transition_chain_proof ?get_ancestry ?get_best_tip ~context:(module Context : CONTEXT) ~verifier ~max_frontier_length ~use_super_catchup = + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in let open Context in let epoch_ledger_location = Filename.temp_dir_name ^/ "epoch_ledger" @@ -265,7 +273,7 @@ module Generator = struct let genesis_ledger = Precomputed_values.genesis_ledger precomputed_values in let consensus_local_state = Consensus.Data.Local_state.create Public_key.Compressed.Set.empty - ~context:(module Context) + ~context:(module Consensus_context) ~genesis_ledger ~genesis_epoch_data:precomputed_values.genesis_epoch_data ~epoch_ledger_location @@ -300,7 +308,7 @@ module Generator = struct let gen ?(logger = Logger.null ()) ~precomputed_values ~verifier ~max_frontier_length ~use_super_catchup - (configs : (peer_config, 'n num_peers) Gadt_lib.Vect.t) ~compile_config = + (configs : (peer_config, 'n num_peers) Gadt_lib.Vect.t) = (* TODO: Pass in *) let module Context = struct let logger = logger @@ -312,8 +320,6 @@ module Generator = struct let consensus_constants = precomputed_values.Precomputed_values.consensus_constants - - let compile_config = compile_config end in let open Quickcheck.Generator.Let_syntax in let%map states = diff --git a/src/lib/fake_network/fake_network.mli b/src/lib/fake_network/fake_network.mli index b3d041cf7f6..cee6df672f8 100644 --- a/src/lib/fake_network/fake_network.mli +++ b/src/lib/fake_network/fake_network.mli @@ -10,8 +10,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end (* There must be at least 2 peers to create a network *) @@ -100,6 +98,5 @@ module Generator : sig -> max_frontier_length:int -> use_super_catchup:bool -> (peer_config, 'n num_peers) Vect.t - -> compile_config:Mina_compile_config.t -> 'n num_peers t Generator.t end diff --git a/src/lib/ledger_catchup/ledger_catchup.ml b/src/lib/ledger_catchup/ledger_catchup.ml index 599dbcf587b..5e452ab565e 100644 --- a/src/lib/ledger_catchup/ledger_catchup.ml +++ b/src/lib/ledger_catchup/ledger_catchup.ml @@ -9,8 +9,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end let run ~context:(module Context : CONTEXT) ~trust_system ~verifier ~network diff --git a/src/lib/ledger_catchup/ledger_catchup.mli b/src/lib/ledger_catchup/ledger_catchup.mli index 03f94401b79..0a957e7e835 100644 --- a/src/lib/ledger_catchup/ledger_catchup.mli +++ b/src/lib/ledger_catchup/ledger_catchup.mli @@ -13,8 +13,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end module Catchup_jobs : sig diff --git a/src/lib/ledger_catchup/normal_catchup.ml b/src/lib/ledger_catchup/normal_catchup.ml index f9fa996c2d5..38a23725d08 100644 --- a/src/lib/ledger_catchup/normal_catchup.ml +++ b/src/lib/ledger_catchup/normal_catchup.ml @@ -15,8 +15,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end (** [Ledger_catchup] is a procedure that connects a foreign external transition @@ -898,8 +896,6 @@ let%test_module "Ledger_catchup tests" = let constraint_constants = precomputed_values.constraint_constants - let compile_config = Mina_compile_config.For_unit_tests.t - let trust_system = Trust_system.null () let time_controller = Block_time.Controller.basic ~logger @@ -919,8 +915,6 @@ let%test_module "Ledger_catchup tests" = let constraint_constants = constraint_constants let consensus_constants = precomputed_values.consensus_constants - - let compile_config = compile_config end let downcast_transition transition = @@ -1045,7 +1039,6 @@ let%test_module "Ledger_catchup tests" = in gen ~precomputed_values ~verifier ~max_frontier_length ~use_super_catchup - ~compile_config:Mina_compile_config.For_unit_tests.t [ fresh_peer ; peer_with_branch ~frontier_branch_size:peer_branch_size ]) @@ -1067,7 +1060,6 @@ let%test_module "Ledger_catchup tests" = Fake_network.Generator.( gen ~precomputed_values ~verifier ~max_frontier_length ~use_super_catchup - ~compile_config:Mina_compile_config.For_unit_tests.t [ fresh_peer; peer_with_branch ~frontier_branch_size:1 ]) ~f:(fun network -> let open Fake_network in @@ -1083,7 +1075,6 @@ let%test_module "Ledger_catchup tests" = Fake_network.Generator.( gen ~precomputed_values ~verifier ~max_frontier_length ~use_super_catchup - ~compile_config:Mina_compile_config.For_unit_tests.t [ fresh_peer ; peer_with_branch ~frontier_branch_size:(max_frontier_length * 2) ]) diff --git a/src/lib/ledger_catchup/super_catchup.ml b/src/lib/ledger_catchup/super_catchup.ml index e866cd3e83d..c871a47d556 100644 --- a/src/lib/ledger_catchup/super_catchup.ml +++ b/src/lib/ledger_catchup/super_catchup.ml @@ -16,8 +16,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end (** [Ledger_catchup] is a procedure that connects a foreign external transition @@ -768,6 +766,11 @@ let pick ~context:(module Context : CONTEXT) (x : Mina_state.Protocol_state.Value.t State_hash.With_state_hashes.t) (y : Mina_state.Protocol_state.Value.t State_hash.With_state_hashes.t) = let f = With_hash.map ~f:Mina_state.Protocol_state.consensus_state in + let module Context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in match Consensus.Hooks.select ~context:(module Context) @@ -1450,8 +1453,6 @@ let%test_module "Ledger_catchup tests" = let use_super_catchup = true - let compile_config = Mina_compile_config.For_unit_tests.t - let verifier = Async.Thread_safe.block_on_async_exn (fun () -> Verifier.For_tests.default ~constraint_constants ~logger ~proof_level @@ -1465,8 +1466,6 @@ let%test_module "Ledger_catchup tests" = let constraint_constants = constraint_constants let consensus_constants = precomputed_values.consensus_constants - - let compile_config = compile_config end (* let mock_verifier = @@ -1645,7 +1644,7 @@ let%test_module "Ledger_catchup tests" = Int.gen_incl (max_frontier_length / 2) (max_frontier_length - 1) in gen ~precomputed_values ~verifier ~max_frontier_length - ~use_super_catchup ~compile_config + ~use_super_catchup [ fresh_peer ; peer_with_branch ~frontier_branch_size:peer_branch_size ]) @@ -1665,7 +1664,7 @@ let%test_module "Ledger_catchup tests" = Quickcheck.test ~trials:1 Fake_network.Generator.( gen ~precomputed_values ~verifier ~max_frontier_length - ~use_super_catchup ~compile_config + ~use_super_catchup [ fresh_peer; peer_with_branch ~frontier_branch_size:1 ]) ~f:(fun network -> let open Fake_network in @@ -1681,7 +1680,7 @@ let%test_module "Ledger_catchup tests" = Quickcheck.test ~trials:1 Fake_network.Generator.( gen ~precomputed_values ~verifier ~max_frontier_length - ~use_super_catchup ~compile_config + ~use_super_catchup [ fresh_peer; peer_with_branch ~frontier_branch_size:1 ]) ~f:(fun network -> let open Fake_network in @@ -1698,7 +1697,7 @@ let%test_module "Ledger_catchup tests" = Quickcheck.test ~trials:1 Fake_network.Generator.( gen ~precomputed_values ~verifier ~max_frontier_length - ~use_super_catchup ~compile_config + ~use_super_catchup [ fresh_peer ; peer_with_branch ~frontier_branch_size:((max_frontier_length * 3) + 1) @@ -1776,7 +1775,7 @@ let%test_module "Ledger_catchup tests" = Quickcheck.test ~trials:1 Fake_network.Generator.( gen ~precomputed_values ~verifier ~max_frontier_length - ~use_super_catchup ~compile_config + ~use_super_catchup [ fresh_peer (* ; peer_with_branch ~frontier_branch_size:(max_frontier_length / 2) *) ; peer_with_branch_custom_rpc diff --git a/src/lib/merkle_address/merkle_address.ml b/src/lib/merkle_address/merkle_address.ml index 69568280e53..3a7d3304d18 100644 --- a/src/lib/merkle_address/merkle_address.ml +++ b/src/lib/merkle_address/merkle_address.ml @@ -133,6 +133,18 @@ let child ~ledger_depth (path : t) dir : t Or_error.t = let child_exn ~ledger_depth (path : t) dir : t = child ~ledger_depth path dir |> Or_error.ok_exn +let extend ~ledger_depth (path : t) ~num_bits (child_idx : int64) = + let final_len = bitstring_length path + num_bits in + if Int.(final_len > ledger_depth) then + Or_error.errorf "The address length cannot be greater than depth (%i > %i)" + final_len ledger_depth + else + let%bitstring path = {| path: -1: bitstring; child_idx: num_bits: int |} in + Or_error.return path + +let extend_exn ~ledger_depth path ~num_bits child_idx = + extend ~ledger_depth path ~num_bits child_idx |> Or_error.ok_exn + let to_int (path : t) : int = Sequence.range 0 (depth path) |> Sequence.fold ~init:0 ~f:(fun acc i -> diff --git a/src/lib/merkle_address/merkle_address.mli b/src/lib/merkle_address/merkle_address.mli index af169723da8..a65b35cdb6e 100644 --- a/src/lib/merkle_address/merkle_address.mli +++ b/src/lib/merkle_address/merkle_address.mli @@ -33,6 +33,10 @@ val child : ledger_depth:int -> t -> Direction.t -> t Or_error.t val child_exn : ledger_depth:int -> t -> Direction.t -> t +val extend : ledger_depth:int -> t -> num_bits:int -> int64 -> t Or_error.t + +val extend_exn : ledger_depth:int -> t -> num_bits:int -> int64 -> t + val parent_exn : t -> t val dirs_from_root : t -> Direction.t list diff --git a/src/lib/mina_block/validation.ml b/src/lib/mina_block/validation.ml index 8ff4a9c7d3a..7ef73524feb 100644 --- a/src/lib/mina_block/validation.ml +++ b/src/lib/mina_block/validation.ml @@ -18,6 +18,8 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t + + val compile_config : Mina_compile_config.t end let validation (_, v) = v diff --git a/src/lib/mina_block/validation.mli b/src/lib/mina_block/validation.mli index edb63b48893..71881258304 100644 --- a/src/lib/mina_block/validation.mli +++ b/src/lib/mina_block/validation.mli @@ -19,6 +19,8 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t + + val compile_config : Mina_compile_config.t end val validation : diff --git a/src/lib/mina_compile_config/mina_compile_config.ml b/src/lib/mina_compile_config/mina_compile_config.ml index 64a372a102d..4c0d05fa4a7 100644 --- a/src/lib/mina_compile_config/mina_compile_config.ml +++ b/src/lib/mina_compile_config/mina_compile_config.ml @@ -18,12 +18,14 @@ module Inputs = struct ; rpc_heartbeat_timeout_sec : float ; rpc_heartbeat_send_every_sec : float ; zkapps_disabled : bool + ; sync_ledger_max_subtree_depth : int + ; sync_ledger_default_subtree_depth : int } - [@@deriving yojson] + [@@deriving yojson, bin_io_unversioned] end type t = - { default_snark_worker_fee : Currency.Fee.t + { default_snark_worker_fee : Currency.Fee.Stable.Latest.t ; itn_features : bool ; compaction_interval : Time.Span.t option ; vrf_poll_interval : Time.Span.t @@ -33,8 +35,10 @@ type t = ; rpc_heartbeat_timeout : Time_ns.Span.t ; rpc_heartbeat_send_every : Time_ns.Span.t ; zkapps_disabled : bool + ; sync_ledger_max_subtree_depth : int + ; sync_ledger_default_subtree_depth : int } -[@@deriving sexp_of] +[@@deriving sexp_of, bin_io_unversioned] let make (inputs : Inputs.t) = { default_snark_worker_fee = @@ -53,6 +57,8 @@ let make (inputs : Inputs.t) = ; network_id = inputs.network_id ; zkapp_cmd_limit = inputs.zkapp_cmd_limit ; zkapps_disabled = inputs.zkapps_disabled + ; sync_ledger_max_subtree_depth = inputs.sync_ledger_max_subtree_depth + ; sync_ledger_default_subtree_depth = inputs.sync_ledger_default_subtree_depth } let to_yojson t = @@ -76,6 +82,9 @@ let to_yojson t = , Option.value_map ~default:`Null ~f:(fun x -> `Int x) t.zkapp_cmd_limit ) ; ("zkapps_disabled", `Bool t.zkapps_disabled) + ; ("sync_ledger_max_subtree_depth", `Int t.sync_ledger_max_subtree_depth) + ; ( "sync_ledger_default_subtree_depth" + , `Int t.sync_ledger_default_subtree_depth ) ] (*TODO: Delete this module and read in a value from the environment*) @@ -92,6 +101,10 @@ module Compiled = struct ; rpc_heartbeat_timeout_sec = 60.0 ; rpc_heartbeat_send_every_sec = 10.0 ; zkapps_disabled = false + ; sync_ledger_max_subtree_depth = + Node_config.sync_ledger_max_subtree_depth + ; sync_ledger_default_subtree_depth = + Node_config.sync_ledger_default_subtree_depth } in make inputs @@ -114,6 +127,10 @@ module For_unit_tests = struct ; network_id = Node_config_for_unit_tests.network ; zkapp_cmd_limit = Node_config_for_unit_tests.zkapp_cmd_limit ; zkapps_disabled = Node_config_for_unit_tests.zkapps_disabled + ; sync_ledger_max_subtree_depth = + Node_config_for_unit_tests.sync_ledger_max_subtree_depth + ; sync_ledger_default_subtree_depth = + Node_config_for_unit_tests.sync_ledger_default_subtree_depth } in make inputs diff --git a/src/lib/mina_intf/transition_frontier_components_intf.ml b/src/lib/mina_intf/transition_frontier_components_intf.ml index ab57b4c3768..4521e31c0f8 100644 --- a/src/lib/mina_intf/transition_frontier_components_intf.ml +++ b/src/lib/mina_intf/transition_frontier_components_intf.ml @@ -13,8 +13,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end module type Transition_handler_validator_intf = sig @@ -207,7 +205,6 @@ module type Consensus_best_tip_prover_intf = sig val verify : context:(module CONTEXT) -> verifier:Verifier.t - -> genesis_constants:Genesis_constants.t -> Consensus.Data.Consensus_state.Value.t State_hash.With_state_hashes.t -> ( Mina_block.t , State_body_hash.t list * Mina_block.t ) @@ -224,9 +221,9 @@ module type Sync_handler_intf = sig frontier:transition_frontier -> Ledger_hash.t -> Mina_ledger.Sync_ledger.Query.t Envelope.Incoming.t - -> logger:Logger.t + -> context:(module CONTEXT) -> trust_system:Trust_system.t - -> Mina_ledger.Sync_ledger.Answer.t option Deferred.t + -> Mina_ledger.Sync_ledger.Answer.t Or_error.t Deferred.t val get_staged_ledger_aux_and_pending_coinbases_at_hash : frontier:transition_frontier diff --git a/src/lib/mina_ledger/sync_ledger.ml b/src/lib/mina_ledger/sync_ledger.ml index 397cdbf3434..ed6f62c52ae 100644 --- a/src/lib/mina_ledger/sync_ledger.ml +++ b/src/lib/mina_ledger/sync_ledger.ml @@ -54,6 +54,16 @@ module Answer = struct module Stable = struct [@@@no_toplevel_latest_type] + module V3 = struct + type t = + ( Ledger_hash.Stable.V1.t + , Account.Stable.V2.t ) + Syncable_ledger.Answer.Stable.V2.t + [@@deriving sexp, to_yojson] + + let to_latest = Fn.id + end + module V2 = struct type t = ( Ledger_hash.Stable.V1.t @@ -61,7 +71,13 @@ module Answer = struct Syncable_ledger.Answer.Stable.V1.t [@@deriving sexp, to_yojson] - let to_latest = Fn.id + let to_latest x = Syncable_ledger.Answer.Stable.V1.to_latest Fn.id x + + (* Not a standard versioning function *) + + (** Attempts to downgrade v3 -> v2 *) + let from_v3 : V3.t -> t Or_error.t = + fun x -> Syncable_ledger.Answer.Stable.V1.from_v2 x end end] @@ -79,12 +95,31 @@ module Query = struct module Stable = struct [@@@no_toplevel_latest_type] + module V2 = struct + type t = + Ledger.Location.Addr.Stable.V1.t Syncable_ledger.Query.Stable.V2.t + [@@deriving sexp, to_yojson, hash, compare] + + let to_latest = Fn.id + end + module V1 = struct type t = Ledger.Location.Addr.Stable.V1.t Syncable_ledger.Query.Stable.V1.t [@@deriving sexp, to_yojson, hash, compare] - let to_latest = Fn.id + let to_latest : t -> V2.t = Syncable_ledger.Query.Stable.V1.to_latest + + (* Not a standard versioning function *) + + (* Attempts to downgrade v2 -> v1 *) + let from_v2 : V2.t -> t = function + | What_child_hashes (a, _) -> + What_child_hashes a + | What_contents a -> + What_contents a + | Num_accounts -> + Num_accounts end end] diff --git a/src/lib/mina_lib/mina_lib.ml b/src/lib/mina_lib/mina_lib.ml index 1b421c52a20..e3ed4a2c614 100644 --- a/src/lib/mina_lib/mina_lib.ml +++ b/src/lib/mina_lib/mina_lib.ml @@ -1269,6 +1269,8 @@ let context ~commit_id (config : Config.t) : (module CONTEXT) = let compaction_interval = config.compile_config.compaction_interval + (*Same as config.precomputed_values.compile_config. + TODO: Remove redundant fields *) let compile_config = config.compile_config end ) @@ -1621,7 +1623,9 @@ let create ~commit_id ?wallets (config : Config.t) = Vrf_evaluator.create ~commit_id ~constraint_constants ~pids:config.pids ~logger:config.logger ~conf_dir:config.conf_dir ~consensus_constants - ~keypairs:config.block_production_keypairs ) ) + ~keypairs:config.block_production_keypairs + ~compile_config:config.precomputed_values.compile_config ) + ) >>| Result.ok_exn in let snark_worker = diff --git a/src/lib/mina_lib/tests/tests.ml b/src/lib/mina_lib/tests/tests.ml index 36dc2377835..0bd06eddb09 100644 --- a/src/lib/mina_lib/tests/tests.ml +++ b/src/lib/mina_lib/tests/tests.ml @@ -429,7 +429,8 @@ let%test_module "Epoch ledger sync tests" = | Error _ -> failwith "Could not add starting account" ) ; let sync_ledger = - Mina_ledger.Sync_ledger.Db.create ~logger + Mina_ledger.Sync_ledger.Db.create + ~context:(module Context) ~trust_system:Context.trust_system db_ledger in let query_reader = diff --git a/src/lib/mina_networking/mina_networking.ml b/src/lib/mina_networking/mina_networking.ml index aa6f39d9582..6c240e821bc 100644 --- a/src/lib/mina_networking/mina_networking.ml +++ b/src/lib/mina_networking/mina_networking.ml @@ -42,8 +42,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end module Node_status = Node_status diff --git a/src/lib/mina_networking/mina_networking.mli b/src/lib/mina_networking/mina_networking.mli index 1aaf511d8e2..d53ae824086 100644 --- a/src/lib/mina_networking/mina_networking.mli +++ b/src/lib/mina_networking/mina_networking.mli @@ -29,8 +29,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end module Node_status = Node_status diff --git a/src/lib/mina_networking/rpcs.ml b/src/lib/mina_networking/rpcs.ml index 1d91b2f105e..4e5fbf76869 100644 --- a/src/lib/mina_networking/rpcs.ml +++ b/src/lib/mina_networking/rpcs.ml @@ -33,8 +33,6 @@ module type CONTEXT = sig val list_peers : unit -> Peer.t list Deferred.t val get_transition_frontier : unit -> Transition_frontier.t option - - val compile_config : Mina_compile_config.t end type ctx = (module CONTEXT) @@ -366,13 +364,13 @@ module Answer_sync_ledger_query = struct include Master end) - module V3 = struct + module V4 = struct module T = struct - type query = Ledger_hash.Stable.V1.t * Sync_ledger.Query.Stable.V1.t + type query = Ledger_hash.Stable.V1.t * Sync_ledger.Query.Stable.V2.t [@@deriving sexp] type response = - (( Sync_ledger.Answer.Stable.V2.t + (( Sync_ledger.Answer.Stable.V3.t , Bounded_types.Wrapped_error.Stable.V1.t ) Result.t [@version_asserted] ) @@ -399,6 +397,49 @@ module Answer_sync_ledger_query = struct include Register (T') end + module V3 = struct + module T = struct + type query = Ledger_hash.Stable.V1.t * Sync_ledger.Query.Stable.V1.t + [@@deriving sexp] + + type response = + (( Sync_ledger.Answer.Stable.V2.t + , Bounded_types.Wrapped_error.Stable.V1.t ) + Result.t + [@version_asserted] ) + [@@deriving sexp] + + let query_of_caller_model : Master.T.query -> query = + fun (h, q) -> (h, Sync_ledger.Query.Stable.V1.from_v2 q) + + let callee_model_of_query : query -> Master.T.query = + fun (h, q) -> (h, Sync_ledger.Query.Stable.V1.to_latest q) + + let response_of_callee_model : Master.T.response -> response = function + | Ok a -> + Sync_ledger.Answer.Stable.V2.from_v3 a + | Error e -> + Error e + + let caller_model_of_response : response -> Master.T.response = function + | Ok a -> + Ok (Sync_ledger.Answer.Stable.V2.to_latest a) + | Error e -> + Error e + end + + module T' = + Perf_histograms.Rpc.Plain.Decorate_bin_io + (struct + include M + include Master + end) + (T) + + include T' + include Register (T') + end + let receipt_trust_action_message (_, query) = ( "Answer_sync_ledger_query: $query" , [ ("query", Sync_ledger.Query.to_yojson query) ] ) @@ -412,17 +453,20 @@ module Answer_sync_ledger_query = struct let ledger_hash, _ = Envelope.Incoming.data request in let query = Envelope.Incoming.map request ~f:Tuple2.get2 in let%bind answer = - let%bind.Deferred.Option frontier = return (get_transition_frontier ()) in - Sync_handler.answer_query ~frontier ledger_hash query ~logger - ~trust_system + match get_transition_frontier () with + | Some frontier -> + Sync_handler.answer_query ~frontier ledger_hash query + ~context:(module Context) + ~trust_system + | None -> + return (Or_error.error_string "No Frontier") in let result = - Result.of_option answer - ~error: - (Error.createf - !"Refusing to answer sync ledger query for ledger_hash: \ - %{sexp:Ledger_hash.t}" - ledger_hash ) + Result.map_error answer ~f:(fun e -> + Error.createf + !"Refusing to answer sync ledger query for ledger_hash: \ + %{sexp:Ledger_hash.t}. Error: %s" + ledger_hash (Error.to_string_hum e) ) in let%map () = match result with diff --git a/src/lib/node_config/for_unit_tests/node_config_for_unit_tests.ml b/src/lib/node_config/for_unit_tests/node_config_for_unit_tests.ml index a419209f192..356424ef342 100644 --- a/src/lib/node_config/for_unit_tests/node_config_for_unit_tests.ml +++ b/src/lib/node_config/for_unit_tests/node_config_for_unit_tests.ml @@ -94,3 +94,7 @@ let rpc_handshake_timeout_sec = 60.0 let rpc_heartbeat_timeout_sec = 60.0 let rpc_heartbeat_send_every_sec = 10.0 (*same as the default*) + +let sync_ledger_max_subtree_depth = 4 + +let sync_ledger_default_subtree_depth = 3 diff --git a/src/lib/node_config/for_unit_tests/node_config_for_unit_tests.mli b/src/lib/node_config/for_unit_tests/node_config_for_unit_tests.mli index bbe3b4300d0..1037949c11e 100644 --- a/src/lib/node_config/for_unit_tests/node_config_for_unit_tests.mli +++ b/src/lib/node_config/for_unit_tests/node_config_for_unit_tests.mli @@ -21,3 +21,7 @@ val rpc_handshake_timeout_sec : float val rpc_heartbeat_timeout_sec : float val rpc_heartbeat_send_every_sec : float + +val sync_ledger_max_subtree_depth : int + +val sync_ledger_default_subtree_depth : int diff --git a/src/lib/node_config/intf/node_config_intf.mli b/src/lib/node_config/intf/node_config_intf.mli index 95ca7e1ad04..3cac2856a08 100644 --- a/src/lib/node_config/intf/node_config_intf.mli +++ b/src/lib/node_config/intf/node_config_intf.mli @@ -60,4 +60,8 @@ module type S = sig val zkapp_cmd_limit : int option val scan_state_tps_goal_x10 : int option + + val sync_ledger_max_subtree_depth : int + + val sync_ledger_default_subtree_depth : int end diff --git a/src/lib/node_config/node_config.ml b/src/lib/node_config/node_config.ml index 71f7f4909c3..29cfb48045c 100644 --- a/src/lib/node_config/node_config.ml +++ b/src/lib/node_config/node_config.ml @@ -26,6 +26,11 @@ include Node_config_version [%%inject "scan_state_with_tps_goal", scan_state_with_tps_goal] +[%%inject "sync_ledger_max_subtree_depth", sync_ledger_max_subtree_depth] + +[%%inject +"sync_ledger_default_subtree_depth", sync_ledger_default_subtree_depth] + [%%ifndef scan_state_transaction_capacity_log_2] let scan_state_transaction_capacity_log_2 : int option = None diff --git a/src/lib/runtime_config/runtime_config.ml b/src/lib/runtime_config/runtime_config.ml index 0ba813ee8d3..a5b9630c6dd 100644 --- a/src/lib/runtime_config/runtime_config.ml +++ b/src/lib/runtime_config/runtime_config.ml @@ -514,6 +514,8 @@ module Json_layout = struct [@default None] [@key "validation-queue-size"] ; stop_time : int option [@default None] [@key "stop-time"] ; peers : string list option [@default None] [@key "peers"] + ; sync_ledger_max_subtree_depth : int option [@default None] + ; sync_ledger_default_subtree_depth : int option [@default None] } [@@deriving yojson, fields] @@ -1289,6 +1291,8 @@ module Daemon = struct ; validation_queue_size : int option [@default None] ; stop_time : int option [@default None] ; peers : string list option [@default None] + ; sync_ledger_max_subtree_depth : int option [@default None] + ; sync_ledger_default_subtree_depth : int option [@default None] } [@@deriving bin_io_unversioned, fields] @@ -1330,6 +1334,8 @@ module Daemon = struct ; validation_queue_size = None ; stop_time = None ; peers = None + ; sync_ledger_max_subtree_depth = None + ; sync_ledger_default_subtree_depth = None } let to_json_layout : t -> Json_layout.Daemon.t = Fn.id @@ -1420,6 +1426,12 @@ module Daemon = struct t2.validation_queue_size ; stop_time = opt_fallthrough ~default:t1.stop_time t2.stop_time ; peers = opt_fallthrough ~default:t1.peers t2.peers + ; sync_ledger_max_subtree_depth = + opt_fallthrough ~default:t1.sync_ledger_max_subtree_depth + t2.sync_ledger_max_subtree_depth + ; sync_ledger_default_subtree_depth = + opt_fallthrough ~default:t1.sync_ledger_default_subtree_depth + t2.sync_ledger_default_subtree_depth } end @@ -1980,6 +1992,13 @@ module Constants : Constants_intf = struct network_id = Option.value ~default:a.compile_config.network_id Option.(b.daemon >>= fun d -> d.network_id) + ; sync_ledger_max_subtree_depth = + Option.value ~default:a.compile_config.sync_ledger_max_subtree_depth + Option.(b.daemon >>= fun d -> d.sync_ledger_max_subtree_depth) + ; sync_ledger_default_subtree_depth = + Option.value + ~default:a.compile_config.sync_ledger_default_subtree_depth + Option.(b.daemon >>= fun d -> d.sync_ledger_default_subtree_depth) ; default_snark_worker_fee = Option.value ~default:a.compile_config.default_snark_worker_fee Option.( diff --git a/src/lib/sync_handler/sync_handler.ml b/src/lib/sync_handler/sync_handler.ml index 0fd5643c7bf..13bec079662 100644 --- a/src/lib/sync_handler/sync_handler.ml +++ b/src/lib/sync_handler/sync_handler.ml @@ -14,8 +14,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end module type Inputs_intf = sig @@ -90,16 +88,28 @@ module Make (Inputs : Inputs_intf) : frontier:Inputs.Transition_frontier.t -> Ledger_hash.t -> Sync_ledger.Query.t Envelope.Incoming.t - -> logger:Logger.t + -> context:(module CONTEXT) -> trust_system:Trust_system.t - -> Sync_ledger.Answer.t Option.t Deferred.t = - fun ~frontier hash query ~logger ~trust_system -> + -> Sync_ledger.Answer.t Or_error.t Deferred.t = + fun ~frontier hash query ~context:(module Context) ~trust_system -> + let (module C : Syncable_ledger.CONTEXT) = + ( module struct + let logger = Context.logger + + let compile_config = Context.precomputed_values.compile_config + end ) + in match get_ledger_by_hash ~frontier hash with | None -> - return None + return + (Or_error.error_string + (sprintf + !"Failed to find ledger for hash %{sexp:Ledger_hash.t}" + hash ) ) | Some ledger -> let responder = - Sync_ledger.Any_ledger.Responder.create ledger ignore ~logger + Sync_ledger.Any_ledger.Responder.create ledger ignore + ~context:(module C) ~trust_system in Sync_ledger.Any_ledger.Responder.answer_query responder query @@ -198,6 +208,8 @@ module Make (Inputs : Inputs_intf) : let module Context = struct include Context + let compile_config = precomputed_values.compile_config + let logger = Logger.extend logger [ ("selection_context", `String "Root.prove") ] end in @@ -220,20 +232,24 @@ module Make (Inputs : Inputs_intf) : data = With_hash.data best_tip_with_witness.data } - let verify ~context:(module Context : CONTEXT) ~verifier ~genesis_constants - observed_state peer_root = + let verify ~context:(module Context : CONTEXT) ~verifier observed_state + peer_root = let module Context = struct include Context + let compile_config = precomputed_values.compile_config + let logger = Logger.extend logger [ ("selection_context", `String "Root.verify") ] end in let open Context in let open Deferred.Result.Let_syntax in + (*TODO: use precomputed_values.genesis_constants that's already passed*) let%bind ( (`Root _, `Best_tip (best_tip_transition, _)) as verified_witness ) = - Best_tip_prover.verify ~verifier ~genesis_constants ~precomputed_values - peer_root + Best_tip_prover.verify ~verifier + ~genesis_constants:precomputed_values.genesis_constants + ~precomputed_values peer_root in let is_before_best_tip candidate = Consensus.Hooks.equal_select_status diff --git a/src/lib/syncable_ledger/dune b/src/lib/syncable_ledger/dune index fddc7b607a8..5e51630c4b9 100644 --- a/src/lib/syncable_ledger/dune +++ b/src/lib/syncable_ledger/dune @@ -22,6 +22,7 @@ direction error_json ppx_version.runtime + mina_compile_config ) (preprocess (pps ppx_mina ppx_version ppx_jane ppx_compare ppx_deriving_yojson ppx_register_event)) diff --git a/src/lib/syncable_ledger/syncable_ledger.ml b/src/lib/syncable_ledger/syncable_ledger.ml index 44f1f972064..15f97bf9876 100644 --- a/src/lib/syncable_ledger/syncable_ledger.ml +++ b/src/lib/syncable_ledger/syncable_ledger.ml @@ -13,6 +13,24 @@ let rec funpow n f r = if n > 0 then funpow (n - 1) f (f r) else r module Query = struct [%%versioned module Stable = struct + module V2 = struct + type 'addr t = + | What_child_hashes of 'addr * int + (** What are the hashes of the children of this address? + If depth > 1 then we get the leaves of a subtree rooted + at address and of the given depth. + For depth = 1 we have the simplest case with just the 2 + direct children. + *) + | What_contents of 'addr + (** What accounts are at this address? addr must have depth + tree_depth - account_subtree_height *) + | Num_accounts + (** How many accounts are there? Used to size data structure and + figure out what part of the tree is filled in. *) + [@@deriving sexp, yojson, hash, compare] + end + module V1 = struct type 'addr t = | What_child_hashes of 'addr @@ -24,6 +42,14 @@ module Query = struct (** How many accounts are there? Used to size data structure and figure out what part of the tree is filled in. *) [@@deriving sexp, yojson, hash, compare] + + let to_latest : 'a t -> 'a V2.t = function + | What_child_hashes a -> + What_child_hashes (a, 1) + | What_contents a -> + What_contents a + | Num_accounts -> + Num_accounts end end] end @@ -31,6 +57,20 @@ end module Answer = struct [%%versioned module Stable = struct + module V2 = struct + type ('hash, 'account) t = + | Child_hashes_are of 'hash Bounded_types.ArrayN4000.Stable.V1.t + (** The requested addresses' children have these hashes. + May be any power of 2 number of children, and not necessarily + immediate children *) + | Contents_are of 'account list + (** The requested address has these accounts *) + | Num_accounts of int * 'hash + (** There are this many accounts and the smallest subtree that + contains all non-empty nodes has this hash. *) + [@@deriving sexp, yojson] + end + module V1 = struct type ('hash, 'account) t = | Child_hashes_are of 'hash * 'hash @@ -44,15 +84,33 @@ module Answer = struct let to_latest acct_to_latest = function | Child_hashes_are (h1, h2) -> - Child_hashes_are (h1, h2) + V2.Child_hashes_are [| h1; h2 |] | Contents_are accts -> - Contents_are (List.map ~f:acct_to_latest accts) + V2.Contents_are (List.map ~f:acct_to_latest accts) | Num_accounts (i, h) -> - Num_accounts (i, h) + V2.Num_accounts (i, h) + + (* Not a standard versioning function *) + + (** Attempts to downgrade v2 -> v1 *) + let from_v2 : ('a, 'b) V2.t -> ('a, 'b) t Or_error.t = function + | Child_hashes_are h -> + if Array.length h = 2 then Ok (Child_hashes_are (h.(0), h.(1))) + else Or_error.error_string "can't downgrade wide query" + | Contents_are accs -> + Ok (Contents_are accs) + | Num_accounts (n, h) -> + Ok (Num_accounts (n, h)) end end] end +module type CONTEXT = sig + val logger : Logger.t + + val compile_config : Mina_compile_config.t +end + module type Inputs_intf = sig module Addr : module type of Merkle_address @@ -107,16 +165,19 @@ module type S = sig val create : merkle_tree -> (query -> unit) - -> logger:Logger.t + -> context:(module CONTEXT) -> trust_system:Trust_system.t -> t val answer_query : - t -> query Envelope.Incoming.t -> answer option Deferred.t + t -> query Envelope.Incoming.t -> answer Or_error.t Deferred.t end val create : - merkle_tree -> logger:Logger.t -> trust_system:Trust_system.t -> 'a t + merkle_tree + -> context:(module CONTEXT) + -> trust_system:Trust_system.t + -> 'a t val answer_writer : 'a t @@ -221,25 +282,31 @@ end = struct type query = Addr.t Query.t + (* Provides addresses at an specific depth from this address *) + let intermediate_range ledger_depth addr i = + Array.init (1 lsl i) ~f:(fun idx -> + Addr.extend_exn ~ledger_depth addr ~num_bits:i (Int64.of_int idx) ) + module Responder = struct type t = { mt : MT.t ; f : query -> unit - ; logger : Logger.t + ; context : (module CONTEXT) ; trust_system : Trust_system.t } let create : MT.t -> (query -> unit) - -> logger:Logger.t + -> context:(module CONTEXT) -> trust_system:Trust_system.t -> t = - fun mt f ~logger ~trust_system -> { mt; f; logger; trust_system } + fun mt f ~context ~trust_system -> { mt; f; context; trust_system } let answer_query : - t -> query Envelope.Incoming.t -> answer option Deferred.t = - fun { mt; f; logger; trust_system } query_envelope -> + t -> query Envelope.Incoming.t -> answer Or_error.t Deferred.t = + fun { mt; f; context; trust_system } query_envelope -> + let open (val context) in let open Trust_system in let ledger_depth = MT.depth mt in let sender = Envelope.Incoming.sender query_envelope in @@ -247,35 +314,12 @@ end = struct f query ; let response_or_punish = match query with - | What_child_hashes a -> ( - match - let open Or_error.Let_syntax in - let%bind lchild = Addr.child ~ledger_depth a Direction.Left in - let%bind rchild = Addr.child ~ledger_depth a Direction.Right in - Or_error.try_with (fun () -> - Answer.Child_hashes_are - ( MT.get_inner_hash_at_addr_exn mt lchild - , MT.get_inner_hash_at_addr_exn mt rchild ) ) - with - | Ok answer -> - Either.First answer - | Error e -> - let logger = Logger.create () in - [%log error] - ~metadata:[ ("error", Error_json.error_to_yojson e) ] - "When handling What_child_hashes request, the following \ - error happended: $error" ; - Either.Second - ( Actions.Violated_protocol - , Some - ( "invalid address $addr in What_child_hashes request" - , [ ("addr", Addr.to_yojson a) ] ) ) ) | What_contents a -> if Addr.height ~ledger_depth a > account_subtree_height then Either.Second ( Actions.Violated_protocol , Some - ( "requested too big of a subtree at once: $addr" + ( "Requested too big of a subtree at once" , [ ("addr", Addr.to_yojson a) ] ) ) else let addresses_and_accounts = @@ -291,8 +335,8 @@ end = struct Either.Second ( Actions.Violated_protocol , Some - ( "Requested empty subtree: $addr" - , [ ("addr", Addr.to_yojson a) ] ) ) + ("Requested empty subtree", [ ("addr", Addr.to_yojson a) ]) + ) else let first_address, rest_address = (List.hd_exn addresses, List.tl_exn addresses) @@ -340,22 +384,62 @@ end = struct Either.First (Num_accounts (len, MT.get_inner_hash_at_addr_exn mt content_root_addr) ) + | What_child_hashes (a, subtree_depth) -> ( + match subtree_depth with + | n when n >= 1 -> ( + let subtree_depth = + min n compile_config.sync_ledger_max_subtree_depth + in + let ledger_depth = MT.depth mt in + let addresses = + intermediate_range ledger_depth a subtree_depth + in + match + Or_error.try_with (fun () -> + let get_hash a = MT.get_inner_hash_at_addr_exn mt a in + let hashes = Array.map addresses ~f:get_hash in + Answer.Child_hashes_are hashes ) + with + | Ok answer -> + Either.First answer + | Error e -> + [%log error] + ~metadata:[ ("error", Error_json.error_to_yojson e) ] + "When handling What_child_hashes request, the following \ + error happended: $error" ; + Either.Second + ( Actions.Violated_protocol + , Some + ( "Invalid address in What_child_hashes request" + , [ ("addr", Addr.to_yojson a) ] ) ) ) + | _ -> + [%log error] + "When handling What_child_hashes request, the depth was \ + outside the valid range" ; + Either.Second + ( Actions.Violated_protocol + , Some + ( "Invalid depth requested in What_child_hashes request" + , [ ("addr", Addr.to_yojson a) ] ) ) ) in + match response_or_punish with | Either.First answer -> - Deferred.return @@ Some answer + Deferred.return @@ Ok answer | Either.Second action -> let%map _ = record_envelope_sender trust_system logger sender action in - None + let err = + Option.value_map ~default:"Violated protocol" (snd action) ~f:fst + in + Or_error.error_string err end type 'a t = { mutable desired_root : Root_hash.t option ; mutable auxiliary_data : 'a option ; tree : MT.t - ; logger : Logger.t ; trust_system : Trust_system.t ; answers : (Root_hash.t * query * answer Envelope.Incoming.t) Linear_pipe.Reader.t @@ -369,6 +453,7 @@ end = struct ; waiting_content : Hash.t Addr.Table.t ; mutable validity_listener : [ `Ok | `Target_changed of Root_hash.t option * Root_hash.t ] Ivar.t + ; context : (module CONTEXT) } let t_of_sexp _ = failwith "t_of_sexp: not implemented" @@ -387,7 +472,8 @@ end = struct let expect_children : 'a t -> Addr.t -> Hash.t -> unit = fun t parent_addr expected -> - [%log' trace t.logger] + let open (val t.context) in + [%log trace] ~metadata: [ ("parent_address", Addr.to_yojson parent_addr) ; ("hash", Hash.to_yojson expected) @@ -397,7 +483,8 @@ end = struct let expect_content : 'a t -> Addr.t -> Hash.t -> unit = fun t addr expected -> - [%log' trace t.logger] + let open (val t.context) in + [%log trace] ~metadata: [ ("address", Addr.to_yojson addr); ("hash", Hash.to_yojson expected) ] "Expecting content addr $address, expected: $hash" ; @@ -412,13 +499,14 @@ end = struct -> [ `Success | `Hash_mismatch of Hash.t * Hash.t (** expected hash, actual *) ] = fun t addr content -> + let open (val t.context) in let expected = Addr.Table.find_exn t.waiting_content addr in (* TODO #444 should we batch all the updates and do them at the end? *) (* We might write the wrong data to the underlying ledger here, but if so we'll requeue the address and it'll be overwritten. *) MT.set_all_accounts_rooted_at_exn t.tree addr content ; Addr.Table.remove t.waiting_content addr ; - [%log' trace t.logger] + [%log trace] ~metadata: [ ("address", Addr.to_yojson addr); ("hash", Hash.to_yojson expected) ] "Found content addr $address, with hash $hash, removing from waiting \ @@ -427,58 +515,83 @@ end = struct if Hash.equal actual expected then `Success else `Hash_mismatch (expected, actual) - (** Given an address and the hashes of the children of the corresponding node, - check the children hash to the expected value. If they do, queue the - children for retrieval if the values in the underlying ledger don't match - the hashes we got from the network. *) - let add_child_hashes_to : + (* Merges each 2 contigous nodes, halving the size of the array *) + let merge_siblings : Hash.t array -> index -> Hash.t array = + fun nodes height -> + let len = Array.length nodes in + if len mod 2 <> 0 then failwith "length must be even" ; + let half_len = len / 2 in + let f i = Hash.merge ~height nodes.(2 * i) nodes.((2 * i) + 1) in + Array.init half_len ~f + + (* Assumes nodes to be a power of 2 and merges them into their common root *) + let rec merge_many : Hash.t array -> index -> Hash.t = + fun nodes height -> + let len = Array.length nodes in + match len with + | 1 -> + nodes.(0) + | _ -> + let half = merge_siblings nodes height in + merge_many half (height + 1) + + let merge_many : Hash.t array -> index -> index -> Hash.t = + fun nodes height subtree_depth -> + let bottom_height = height - subtree_depth in + let hash = merge_many nodes bottom_height in + hash + + (* Adds the subtree given as the 2^k subtree leaves with the given prefix address *) + (* Returns next nodes to be checked *) + let add_subtree : 'a t -> Addr.t - -> Hash.t - -> Hash.t - -> [ `Good of (Addr.t * Hash.t) list - (** The addresses and expected hashes of the now-retrievable children *) + -> Hash.t array + -> int + -> [ `Good of (Addr.t * Hash.t) array | `Hash_mismatch of Hash.t * Hash.t - (** Hash check failed, peer lied. First parameter expected, second parameter actual. *) - ] = - fun t parent_addr lh rh -> - let ledger_depth = MT.depth t.tree in - let la, ra = - Option.value_exn ~message:"Tried to fetch a leaf as if it was a node" - ( Or_error.ok - @@ Or_error.both - (Addr.child ~ledger_depth parent_addr Direction.Left) - (Addr.child ~ledger_depth parent_addr Direction.Right) ) - in - let expected = - Option.value_exn ~message:"Forgot to wait for a node" - (Addr.Table.find t.waiting_parents parent_addr) - in - let merged_hash = - (* Height here is the height of the things we're merging, so one less than - the parent height. *) - Hash.merge ~height:(ledger_depth - Addr.depth parent_addr - 1) lh rh - in - if Hash.equal merged_hash expected then ( - (* Fetch the children of a node if the hash in the underlying ledger - doesn't match what we got. *) - let should_fetch_children addr hash = - not @@ Hash.equal (MT.get_inner_hash_at_addr_exn t.tree addr) hash + | `Invalid_length ] = + fun t addr nodes requested_depth -> + let open (val t.context) in + let len = Array.length nodes in + let is_power = Int.is_pow2 len in + let is_more_than_two = len >= 2 in + let subtree_depth = Int.ceil_log2 len in + let less_than_requested = subtree_depth <= requested_depth in + let valid_length = is_power && is_more_than_two && less_than_requested in + if valid_length then + let ledger_depth = MT.depth t.tree in + let expected = + Option.value_exn ~message:"Forgot to wait for a node" + (Addr.Table.find t.waiting_parents addr) in - let subtrees_to_fetch = - [ (la, lh); (ra, rh) ] - |> List.filter ~f:(Tuple2.uncurry should_fetch_children) + let merged = + merge_many nodes (ledger_depth - Addr.depth addr) subtree_depth in - Addr.Table.remove t.waiting_parents parent_addr ; - `Good subtrees_to_fetch ) - else `Hash_mismatch (expected, merged_hash) + if Hash.equal expected merged then ( + Addr.Table.remove t.waiting_parents addr ; + let addresses = intermediate_range ledger_depth addr subtree_depth in + let addresses_and_hashes = Array.zip_exn addresses nodes in + + (* Filter to fetch only those that differ *) + let should_fetch_children addr hash = + not @@ Hash.equal (MT.get_inner_hash_at_addr_exn t.tree addr) hash + in + let subtrees_to_fetch = + addresses_and_hashes + |> Array.filter ~f:(Tuple2.uncurry should_fetch_children) + in + `Good subtrees_to_fetch ) + else `Hash_mismatch (expected, merged) + else `Invalid_length let all_done t = + let open (val t.context) in if not (Root_hash.equal (MT.merkle_root t.tree) (desired_root_exn t)) then failwith "We finished syncing, but made a mistake somewhere :(" else ( if Ivar.is_full t.validity_listener then - [%log' error t.logger] "Ivar.fill bug is here!" ; + [%log error] "Ivar.fill bug is here!" ; Ivar.fill t.validity_listener `Ok ) (** Compute the hash of an empty tree of the specified height. *) @@ -505,6 +618,7 @@ end = struct the children. *) let handle_node t addr exp_hash = + let open (val t.context) in if Addr.depth addr >= MT.depth t.tree - account_subtree_height then ( expect_content t addr exp_hash ; Linear_pipe.write_without_pushback_if_open t.queries @@ -512,7 +626,9 @@ end = struct else ( expect_children t addr exp_hash ; Linear_pipe.write_without_pushback_if_open t.queries - (desired_root_exn t, What_child_hashes addr) ) + ( desired_root_exn t + , What_child_hashes + (addr, compile_config.sync_ledger_default_subtree_depth) ) ) (** Handle the initial Num_accounts message, starting the main syncing process. *) @@ -534,6 +650,7 @@ end = struct else `Hash_mismatch (rh, actual) let main_loop t = + let open (val t.context) in let handle_answer : Root_hash.t * Addr.t Query.t @@ -548,14 +665,14 @@ end = struct in let sender = Envelope.Incoming.sender env in let answer = Envelope.Incoming.data env in - [%log' trace t.logger] + [%log trace] ~metadata: [ ("root_hash", Root_hash.to_yojson root_hash) ; ("query", Query.to_yojson Addr.to_yojson query) ] "Handle answer for $root_hash" ; if not (Root_hash.equal root_hash (desired_root_exn t)) then ( - [%log' trace t.logger] + [%log trace] ~metadata: [ ("desired_hash", Root_hash.to_yojson (desired_root_exn t)) ; ("ignored_hash", Root_hash.to_yojson root_hash) @@ -565,8 +682,7 @@ end = struct else if already_done then ( (* This can happen if we asked for hashes that turn out to be equal in underlying ledger and the target. *) - [%log' debug t.logger] - "Got sync response when we're already finished syncing" ; + [%log debug] "Got sync response when we're already finished syncing" ; Deferred.unit ) else let open Trust_system in @@ -576,7 +692,7 @@ end = struct Linear_pipe.write_without_pushback_if_open t.queries (root_hash, query) in let credit_fulfilled_request () = - record_envelope_sender t.trust_system t.logger sender + record_envelope_sender t.trust_system logger sender ( Actions.Fulfilled_request , Some ( "sync ledger query $query" @@ -584,35 +700,13 @@ end = struct in let%bind _ = match (query, answer) with - | Query.What_child_hashes addr, Answer.Child_hashes_are (lh, rh) -> ( - match add_child_hashes_to t addr lh rh with - | `Hash_mismatch (expected, actual) -> - let%map () = - record_envelope_sender t.trust_system t.logger sender - ( Actions.Sent_bad_hash - , Some - ( "sent child hashes $lhash and $rhash for address \ - $addr, they merge hash to $actualmerge but we \ - expected $expectedmerge" - , [ ("lhash", Hash.to_yojson lh) - ; ("rhash", Hash.to_yojson rh) - ; ("actualmerge", Hash.to_yojson actual) - ; ("expectedmerge", Hash.to_yojson expected) - ] ) ) - in - requeue_query () - | `Good children_to_verify -> - (* TODO #312: Make sure we don't write too much *) - List.iter children_to_verify ~f:(fun (addr, hash) -> - handle_node t addr hash ) ; - credit_fulfilled_request () ) | Query.What_contents addr, Answer.Contents_are leaves -> ( match add_content t addr leaves with | `Success -> credit_fulfilled_request () | `Hash_mismatch (expected, actual) -> let%map () = - record_envelope_sender t.trust_system t.logger sender + record_envelope_sender t.trust_system logger sender ( Actions.Sent_bad_hash , Some ( "sent accounts $accounts for address $addr, they \ @@ -631,7 +725,7 @@ end = struct credit_fulfilled_request () | `Hash_mismatch (expected, actual) -> let%map () = - record_envelope_sender t.trust_system t.logger sender + record_envelope_sender t.trust_system logger sender ( Actions.Sent_bad_hash , Some ( "Claimed num_accounts $count, content root hash \ @@ -644,9 +738,42 @@ end = struct ] ) ) in requeue_query () ) + | ( Query.What_child_hashes (address, requested_depth) + , Answer.Child_hashes_are hashes ) -> ( + match add_subtree t address hashes requested_depth with + | `Hash_mismatch (expected, actual) -> + let%map () = + record_envelope_sender t.trust_system logger sender + ( Actions.Sent_bad_hash + , Some + ( "hashes sent for subtree on address $address merge \ + to $actual_merge but we expected $expected_merge" + , [ ("actual_merge", Hash.to_yojson actual) + ; ("expected_merge", Hash.to_yojson expected) + ] ) ) + in + requeue_query () + | `Invalid_length -> + let%map () = + record_envelope_sender t.trust_system logger sender + ( Actions.Sent_bad_hash + , Some + ( "hashes sent for subtree on address $address must \ + be a power of 2 in the range 2-2^$depth" + , [ ( "depth" + , `Int + compile_config.sync_ledger_max_subtree_depth + ) + ] ) ) + in + requeue_query () + | `Good children_to_verify -> + Array.iter children_to_verify ~f:(fun (addr, hash) -> + handle_node t addr hash ) ; + credit_fulfilled_request () ) | query, answer -> let%map () = - record_envelope_sender t.trust_system t.logger sender + record_envelope_sender t.trust_system logger sender ( Actions.Violated_protocol , Some ( "Answered question we didn't ask! Query was $query \ @@ -664,13 +791,14 @@ end = struct (Option.value_exn t.desired_root) (MT.merkle_root t.tree) then ( - [%str_log' trace t.logger] Snarked_ledger_synced ; + [%str_log trace] Snarked_ledger_synced ; all_done t ) ; Deferred.unit in Linear_pipe.iter t.answers ~f:handle_answer let new_goal t h ~data ~equal = + let open (val t.context) in let should_skip = match t.desired_root with | None -> @@ -680,7 +808,7 @@ end = struct in if not should_skip then ( Option.iter t.desired_root ~f:(fun root_hash -> - [%log' debug t.logger] + [%log debug] ~metadata: [ ("old_root_hash", Root_hash.to_yojson root_hash) ; ("new_root_hash", Root_hash.to_yojson h) @@ -697,7 +825,7 @@ end = struct Option.fold t.auxiliary_data ~init:false ~f:(fun _ saved_data -> equal data saved_data ) then ( - [%log' debug t.logger] "New_goal to same hash, not doing anything" ; + [%log debug] "New_goal to same hash, not doing anything" ; `Repeat ) else ( t.auxiliary_data <- Some data ; @@ -731,14 +859,13 @@ end = struct ignore (new_goal t rh ~data ~equal : [ `New | `Repeat | `Update_data ]) ; wait_until_valid t rh - let create mt ~logger ~trust_system = + let create mt ~context ~trust_system = let qr, qw = Linear_pipe.create () in let ar, aw = Linear_pipe.create () in let t = { desired_root = None ; auxiliary_data = None ; tree = mt - ; logger ; trust_system ; answers = ar ; answer_writer = aw @@ -747,6 +874,7 @@ end = struct ; waiting_parents = Addr.Table.create () ; waiting_content = Addr.Table.create () ; validity_listener = Ivar.create () + ; context } in don't_wait_for (main_loop t) ; diff --git a/src/lib/syncable_ledger/test/dune b/src/lib/syncable_ledger/test/dune index 11927311d65..c1573d877b2 100644 --- a/src/lib/syncable_ledger/test/dune +++ b/src/lib/syncable_ledger/test/dune @@ -30,6 +30,7 @@ mina_base.import signature_lib bounded_types + mina_compile_config ) (preprocess (pps ppx_version ppx_jane ppx_compare ppx_deriving_yojson)) diff --git a/src/lib/syncable_ledger/test/test.ml b/src/lib/syncable_ledger/test/test.ml index 0d076706b12..5cc21424ba8 100644 --- a/src/lib/syncable_ledger/test/test.ml +++ b/src/lib/syncable_ledger/test/test.ml @@ -18,6 +18,8 @@ module type Input_intf = sig val equal : t -> t -> bool end + module Context : Syncable_ledger.CONTEXT + module Ledger : Ledger_intf with type root_hash := Root_hash.t @@ -35,6 +37,64 @@ module type Input_intf = sig and type answer := (Root_hash.t, Ledger.account) Syncable_ledger.Answer.t end +module Make_context (Subtree_depth : sig + val sync_ledger_max_subtree_depth : int + + val sync_ledger_default_subtree_depth : int +end) : Syncable_ledger.CONTEXT = struct + let logger = Logger.null () + + let compile_config = + { Mina_compile_config.For_unit_tests.t with + sync_ledger_max_subtree_depth = + Subtree_depth.sync_ledger_max_subtree_depth + ; sync_ledger_default_subtree_depth = + Subtree_depth.sync_ledger_default_subtree_depth + } +end + +module Context_subtree_depth32 = Make_context (struct + let sync_ledger_max_subtree_depth = 3 + + let sync_ledger_default_subtree_depth = 2 +end) + +module Context_subtree_depth81 = Make_context (struct + let sync_ledger_max_subtree_depth = 8 + + let sync_ledger_default_subtree_depth = 1 +end) + +module Context_subtree_depth82 = Make_context (struct + let sync_ledger_max_subtree_depth = 8 + + let sync_ledger_default_subtree_depth = 2 +end) + +module Context_subtree_depth86 = Make_context (struct + let sync_ledger_max_subtree_depth = 8 + + let sync_ledger_default_subtree_depth = 6 +end) + +module Context_subtree_depth88 = Make_context (struct + let sync_ledger_max_subtree_depth = 8 + + let sync_ledger_default_subtree_depth = 8 +end) + +module Context_subtree_depth68 = Make_context (struct + let sync_ledger_max_subtree_depth = 6 + + let sync_ledger_default_subtree_depth = 8 +end) + +module Context_subtree_depth80 = Make_context (struct + let sync_ledger_max_subtree_depth = 8 + + let sync_ledger_default_subtree_depth = 0 +end) + module Make_test (Input : Input_intf) (Input' : sig val num_accts : int @@ -48,8 +108,6 @@ struct * in before we need it. *) let total_queries = ref None - let logger = Logger.null () - let trust_system = Trust_system.null () let () = @@ -60,24 +118,23 @@ struct let l1, _k1 = Ledger.load_ledger 1 1 in let l2, _k2 = Ledger.load_ledger num_accts 2 in let desired_root = Ledger.merkle_root l2 in - let lsync = Sync_ledger.create l1 ~logger ~trust_system in + let lsync = Sync_ledger.create l1 ~context:(module Context) ~trust_system in let qr = Sync_ledger.query_reader lsync in let aw = Sync_ledger.answer_writer lsync in let seen_queries = ref [] in let sr = Sync_responder.create l2 (fun q -> seen_queries := q :: !seen_queries) - ~logger ~trust_system + ~context:(module Context) + ~trust_system in don't_wait_for (Linear_pipe.iter_unordered ~max_concurrency:3 qr ~f:(fun (root_hash, query) -> - let%bind answ_opt = + let%bind answ_or_error = Sync_responder.answer_query sr (Envelope.Incoming.local query) in - let answ = - Option.value_exn ~message:"refused to answer query" answ_opt - in + let answ = Or_error.ok_exn answ_or_error in let%bind () = if match query with What_contents _ -> true | _ -> false then Clock_ns.after @@ -103,7 +160,7 @@ struct let l2, _k2 = Ledger.load_ledger num_accts 2 in let l3, _k3 = Ledger.load_ledger num_accts 3 in let desired_root = ref @@ Ledger.merkle_root l2 in - let lsync = Sync_ledger.create l1 ~logger ~trust_system in + let lsync = Sync_ledger.create l1 ~context:(module Context) ~trust_system in let qr = Sync_ledger.query_reader lsync in let aw = Sync_ledger.answer_writer lsync in let seen_queries = ref [] in @@ -111,7 +168,8 @@ struct ref @@ Sync_responder.create l2 (fun q -> seen_queries := q :: !seen_queries) - ~logger ~trust_system + ~context:(module Context) + ~trust_system in let ctr = ref 0 in don't_wait_for @@ -123,7 +181,8 @@ struct sr := Sync_responder.create l3 (fun q -> seen_queries := q :: !seen_queries) - ~logger ~trust_system ; + ~context:(module Context) + ~trust_system ; desired_root := Ledger.merkle_root l3 ; ignore ( Sync_ledger.new_goal lsync !desired_root ~data:() @@ -131,13 +190,11 @@ struct : [ `New | `Repeat | `Update_data ] ) ; Deferred.unit ) else - let%bind answ_opt = + let%bind answ_or_error = Sync_responder.answer_query !sr (Envelope.Incoming.local query) in - let answ = - Option.value_exn ~message:"refused to answer query" answ_opt - in + let answ = Or_error.ok_exn answ_or_error in Linear_pipe.write aw (!desired_root, query, Envelope.Incoming.local answ) in @@ -162,6 +219,89 @@ struct failwith "the target changed again" ) end +module Make_test_edge_cases (Input : Input_intf) = struct + open Input + module Sync_responder = Sync_ledger.Responder + + let trust_system = Trust_system.null () + + let num_accts = 1026 + + let () = + Async.Scheduler.set_record_backtraces true ; + Core.Backtrace.elide := false + + let check_answer (query : Ledger.addr Syncable_ledger.Query.t) answer = + match query with + | What_child_hashes (_, depth) -> ( + let invalid_depth = depth < 1 in + match answer with + | Error s -> + if + invalid_depth + && String.is_substring (Error.to_string_hum s) + ~substring: + "Invalid depth requested in What_child_hashes request" + then `Failure_as_expected + else + failwithf + "Expected failure due to invalid subtree depth, returned %s" + (Error.to_string_hum s) () + | Ok a -> + if invalid_depth then + failwith + "Expected failure due to invalid subtree depth, returned a \ + successful answer" + else `Answer a ) + | _ -> + `Answer (Or_error.ok_exn answer) + + let%test "try full_sync_entirely_different with failures" = + let l1, _k1 = Ledger.load_ledger 1 1 in + let l2, _k2 = Ledger.load_ledger num_accts 2 in + let desired_root = Ledger.merkle_root l2 in + let got_failure_ivar = Ivar.create () in + + let lsync = Sync_ledger.create l1 ~context:(module Context) ~trust_system in + let qr = Sync_ledger.query_reader lsync in + let aw = Sync_ledger.answer_writer lsync in + let sr = + Sync_responder.create l2 ignore ~context:(module Context) ~trust_system + in + don't_wait_for + (Linear_pipe.iter_unordered ~max_concurrency:3 qr + ~f:(fun (root_hash, query) -> + let%bind answ_or_error = + Sync_responder.answer_query sr (Envelope.Incoming.local query) + in + match check_answer query answ_or_error with + | `Answer answ -> + let%bind () = + if match query with What_contents _ -> true | _ -> false then + Clock_ns.after + (Time_ns.Span.randomize (Time_ns.Span.of_ms 0.2) + ~percent:(Percent.of_percentage 20.) ) + else Deferred.unit + in + Linear_pipe.write aw + (root_hash, query, Envelope.Incoming.local answ) + | `Failure_as_expected -> + Ivar.fill got_failure_ivar true ; + Deferred.unit ) ) ; + Async.Thread_safe.block_on_async_exn (fun () -> + let deferred_res = + match%map + Sync_ledger.fetch lsync desired_root ~data:() ~equal:(fun () () -> + true ) + with + | `Ok mt -> + Root_hash.equal desired_root (Ledger.merkle_root mt) + | `Target_changed _ -> + false + in + Deferred.any [ deferred_res; Ivar.read got_failure_ivar ] ) +end + module Root_hash = struct include Merkle_ledger_tests.Test_stubs.Hash @@ -176,9 +316,10 @@ end (* Testing different ledger instantiations on Syncable_ledger *) module Db = struct - module Make (Depth : sig - val depth : int - end) = + module Make + (Context : Syncable_ledger.CONTEXT) (Depth : sig + val depth : int + end) = struct open Merkle_ledger_tests.Test_stubs @@ -242,19 +383,61 @@ module Db = struct module MT = Ledger include Base_ledger_inputs - let account_subtree_height = 3 + let account_subtree_height = 6 end module Sync_ledger = Syncable_ledger.Make (Syncable_ledger_inputs) + module Context = Context end - module DB3 = Make (struct - let depth = 3 - end) + module DB3 = + Make + (Context_subtree_depth32) + (struct + let depth = 3 + end) + + module DB16_subtree_depths81 = + Make + (Context_subtree_depth81) + (struct + let depth = 16 + end) + + module DB16_subtree_depths82 = + Make + (Context_subtree_depth82) + (struct + let depth = 16 + end) + + module DB16_subtree_depths86 = + Make + (Context_subtree_depth86) + (struct + let depth = 16 + end) - module DB16 = Make (struct - let depth = 16 - end) + module DB16_subtree_depths88 = + Make + (Context_subtree_depth88) + (struct + let depth = 16 + end) + + module DB16_subtree_depths68 = + Make + (Context_subtree_depth68) + (struct + let depth = 16 + end) + + module DB16_subtree_depths80 = + Make + (Context_subtree_depth80) + (struct + let depth = 16 + end) module TestDB3_3 = Make_test @@ -272,32 +455,62 @@ module Db = struct module TestDB16_20 = Make_test - (DB16) + (DB16_subtree_depths86) (struct let num_accts = 20 end) module TestDB16_1024 = Make_test - (DB16) + (DB16_subtree_depths86) (struct let num_accts = 1024 end) - module TestDB16_1026 = + module TestDB16_1026_subtree_depth81 = + Make_test + (DB16_subtree_depths81) + (struct + let num_accts = 1026 + end) + + module TestDB16_1026_subtree_depth82 = + Make_test + (DB16_subtree_depths82) + (struct + let num_accts = 1026 + end) + + module TestDB16_1026_subtree_depth86 = + Make_test + (DB16_subtree_depths86) + (struct + let num_accts = 1026 + end) + + (*Test till sync_ledger_max_subtree_depth*) + module TestDB16_1026_subtree_depth88 = Make_test - (DB16) + (DB16_subtree_depths88) (struct let num_accts = 1026 end) + + module TestDB16_Edge_Cases_subtree_depth68 = + Make_test_edge_cases (DB16_subtree_depths68) + module TestDB16_Edge_Cases_subtree_depth86 = + Make_test_edge_cases (DB16_subtree_depths81) + module TestDB16_Edge_Cases_subtree_depth80 = + Make_test_edge_cases (DB16_subtree_depths80) end module Mask = struct - module Make (Input : sig - val depth : int + module Make + (Context : Syncable_ledger.CONTEXT) (Input : sig + val depth : int - val mask_layers : int - end) = + val mask_layers : int + end) = struct open Merkle_ledger_tests.Test_stubs @@ -387,29 +600,84 @@ module Mask = struct module MT = Ledger include Base_ledger_inputs - let account_subtree_height = 3 + let account_subtree_height = 6 end module Sync_ledger = Syncable_ledger.Make (Syncable_ledger_inputs) + module Context = Context end - module Mask3_Layer1 = Make (struct - let depth = 3 + module Mask3_Layer1 = + Make + (Context_subtree_depth32) + (struct + let depth = 3 + + let mask_layers = 1 + end) + + module Mask16_Layer1 = + Make + (Context_subtree_depth32) + (struct + let depth = 16 - let mask_layers = 1 - end) + let mask_layers = 1 + end) - module Mask16_Layer1 = Make (struct - let depth = 16 + module Mask16_Layer2 = + Make + (Context_subtree_depth32) + (struct + let depth = 16 - let mask_layers = 1 - end) + let mask_layers = 2 + end) - module Mask16_Layer2 = Make (struct - let depth = 16 + module Mask16_Layer2_Depth81 = + Make + (Context_subtree_depth81) + (struct + let depth = 16 - let mask_layers = 2 - end) + let mask_layers = 2 + end) + + module Mask16_Layer2_Depth86 = + Make + (Context_subtree_depth86) + (struct + let depth = 16 + + let mask_layers = 2 + end) + + module Mask16_Layer2_Depth88 = + Make + (Context_subtree_depth88) + (struct + let depth = 16 + + let mask_layers = 2 + end) + + module Mask16_Layer2_Depth68 = + Make + (Context_subtree_depth68) + (struct + let depth = 16 + + let mask_layers = 2 + end) + + module Mask16_Layer2_Depth80 = + Make + (Context_subtree_depth80) + (struct + let depth = 16 + + let mask_layers = 2 + end) module TestMask3_Layer1_3 = Make_test @@ -452,4 +720,32 @@ module Mask = struct (struct let num_accts = 1024 end) + + module TestMask16_Layer2_1024_Depth81 = + Make_test + (Mask16_Layer2_Depth81) + (struct + let num_accts = 1024 + end) + + module TestMask16_Layer2_1024_Depth86 = + Make_test + (Mask16_Layer2_Depth86) + (struct + let num_accts = 1024 + end) + + module TestMask16_Layer2_1024_Depth88 = + Make_test + (Mask16_Layer2_Depth88) + (struct + let num_accts = 1024 + end) + + module TestMask16_Edge_Cases_Depth68 = + Make_test_edge_cases (Mask16_Layer2_Depth68) + module TestMask16_Edge_Cases_Depth81 = + Make_test_edge_cases (Mask16_Layer2_Depth81) + module TestMask16_Edge_Cases_Depth80 = + Make_test_edge_cases (Mask16_Layer2_Depth80) end diff --git a/src/lib/transition_frontier/full_frontier/full_frontier.ml b/src/lib/transition_frontier/full_frontier/full_frontier.ml index 33b5bc4ffc6..73d1079b544 100644 --- a/src/lib/transition_frontier/full_frontier/full_frontier.ml +++ b/src/lib/transition_frontier/full_frontier/full_frontier.ml @@ -563,6 +563,11 @@ let calculate_diffs ({ context = (module Context); _ } as t) breadcrumb = ] end in let open Diff in + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in O1trace.sync_thread "calculate_diff_frontier_diffs" (fun () -> let breadcrumb_hash = Breadcrumb.state_hash breadcrumb in let parent_node = @@ -583,7 +588,7 @@ let calculate_diffs ({ context = (module Context); _ } as t) breadcrumb = if Consensus.Hooks.equal_select_status (Consensus.Hooks.select - ~context:(module Context) + ~context:(module Consensus_context) ~existing: (Breadcrumb.consensus_state_with_hashes current_best_tip) ~candidate:(Breadcrumb.consensus_state_with_hashes breadcrumb) ) @@ -958,6 +963,8 @@ module For_tests = struct let precomputed_values = precomputed_values let consensus_constants = precomputed_values.consensus_constants + + let compile_config = precomputed_values.compile_config end let verifier () = diff --git a/src/lib/transition_frontier/transition_frontier.ml b/src/lib/transition_frontier/transition_frontier.ml index 52389205353..f2fdff6036c 100644 --- a/src/lib/transition_frontier/transition_frontier.ml +++ b/src/lib/transition_frontier/transition_frontier.ml @@ -719,6 +719,8 @@ module For_tests = struct let constraint_constants = precomputed_values.constraint_constants let consensus_constants = precomputed_values.consensus_constants + + let compile_config = precomputed_values.compile_config end in let open Context in let open Quickcheck.Generator.Let_syntax in diff --git a/src/lib/transition_frontier_controller/transition_frontier_controller.ml b/src/lib/transition_frontier_controller/transition_frontier_controller.ml index 738b7c3f577..7a28592ec8a 100644 --- a/src/lib/transition_frontier_controller/transition_frontier_controller.ml +++ b/src/lib/transition_frontier_controller/transition_frontier_controller.ml @@ -11,8 +11,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end let run ~context:(module Context : CONTEXT) ~trust_system ~verifier ~network diff --git a/src/lib/transition_handler/processor.ml b/src/lib/transition_handler/processor.ml index f0cb41f0aee..d76c9e2a473 100644 --- a/src/lib/transition_handler/processor.ml +++ b/src/lib/transition_handler/processor.ml @@ -25,8 +25,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end (* TODO: calculate a sensible value from postake consensus arguments *) @@ -113,7 +111,12 @@ let process_transition ~context:(module Context : CONTEXT) ~trust_system let is_block_in_frontier = Fn.compose Option.is_some @@ Transition_frontier.find frontier in - let open Context in + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in + let open Consensus_context in let header, transition_hash, transition_receipt_time, sender, validation = match block_or_header with | `Block cached_env -> @@ -164,7 +167,7 @@ let process_transition ~context:(module Context : CONTEXT) ~trust_system [%log internal] "Validate_frontier_dependencies" ; match Mina_block.Validation.validate_frontier_dependencies - ~context:(module Context) + ~context:(module Consensus_context) ~root_block ~is_block_in_frontier ~to_header:ident (Envelope.Incoming.data env) with @@ -195,7 +198,7 @@ let process_transition ~context:(module Context : CONTEXT) ~trust_system [%log internal] "Validate_frontier_dependencies" ; match Mina_block.Validation.validate_frontier_dependencies - ~context:(module Context) + ~context:(module Consensus_context) ~root_block ~is_block_in_frontier ~to_header:Mina_block.header initially_validated_transition with @@ -486,8 +489,6 @@ let%test_module "Transition_handler.Processor tests" = let trust_system = Trust_system.null () - let compile_config = Mina_compile_config.For_unit_tests.t - let verifier = Async.Thread_safe.block_on_async_exn (fun () -> Verifier.For_tests.default ~constraint_constants ~logger ~proof_level @@ -501,8 +502,6 @@ let%test_module "Transition_handler.Processor tests" = let constraint_constants = constraint_constants let consensus_constants = precomputed_values.consensus_constants - - let compile_config = compile_config end let downcast_breadcrumb breadcrumb = diff --git a/src/lib/transition_handler/validator.ml b/src/lib/transition_handler/validator.ml index dc8862b85fa..cb1e39b4df2 100644 --- a/src/lib/transition_handler/validator.ml +++ b/src/lib/transition_handler/validator.ml @@ -22,6 +22,8 @@ let validate_header_is_relevant ~context:(module Context : CONTEXT) ~frontier let module Context = struct include Context + let compile_config = precomputed_values.compile_config + let logger = Logger.extend logger [ ("selection_context", `String "Transition_handler.Validator") ] diff --git a/src/lib/transition_router/transition_router.ml b/src/lib/transition_router/transition_router.ml index a8b57177966..57489dd5dc8 100644 --- a/src/lib/transition_router/transition_router.ml +++ b/src/lib/transition_router/transition_router.ml @@ -12,8 +12,6 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t - - val compile_config : Mina_compile_config.t end type Structured_log_events.t += Starting_transition_frontier_controller @@ -57,8 +55,8 @@ let to_consensus_state h = (Fn.compose Mina_state.Protocol_state.consensus_state Mina_block.Header.protocol_state ) -let is_transition_for_bootstrap ~context:(module Context : CONTEXT) frontier - new_header = +let is_transition_for_bootstrap + ~context:(module Context : Consensus.Intf.CONTEXT) frontier new_header = let root_consensus_state = Transition_frontier.root frontier |> Transition_frontier.Breadcrumb.consensus_state_with_hashes @@ -285,6 +283,11 @@ let download_best_tip ~context:(module Context : CONTEXT) ~notify_online [ ("actual", `Int (List.length tips)); ("expected", `Int num_peers) ] "Finished requesting tips. Got $actual / $expected" ; let%map () = notify_online () in + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in let res = List.fold tips ~init:None ~f:(fun acc enveloped_candidate_best_tip -> Option.merge acc (Option.return enveloped_candidate_best_tip) @@ -295,7 +298,7 @@ let download_best_tip ~context:(module Context : CONTEXT) ~notify_online in match Consensus.Hooks.select - ~context:(module Context) + ~context:(module Consensus_context) ~existing:(f enveloped_existing_best_tip.data.data) ~candidate:(f enveloped_candidate_best_tip.data.data) with @@ -404,6 +407,11 @@ let initialize ~context:(module Context : CONTEXT) ~sync_local_state ~network let genesis_constants = Precomputed_values.genesis_constants precomputed_values in + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in match%bind Deferred.both (download_best_tip @@ -433,7 +441,7 @@ let initialize ~context:(module Context : CONTEXT) ~sync_local_state ~network (Option.map ~f:(fun x -> `Block x) best_seen_transition) | Some best_tip, Some frontier when is_transition_for_bootstrap - ~context:(module Context) + ~context:(module Consensus_context) frontier ( best_tip |> Envelope.Incoming.data |> Mina_block.Validation.to_header ) -> @@ -503,7 +511,7 @@ let initialize ~context:(module Context : CONTEXT) ~sync_local_state ~network Consensus.Hooks.sync_local_state ~local_state:consensus_local_state ~glue_sync_ledger:(Mina_networking.glue_sync_ledger network) - ~context:(module Context) + ~context:(module Consensus_context) ~trust_system sync_jobs with | Error e -> @@ -569,6 +577,11 @@ let run ?(sync_local_state = true) ?(cache_exceptions = false) ~get_most_recent_valid_block ~most_recent_valid_block_writer ~get_completed_work ~catchup_mode ~notify_online () = let open Context in + let module Consensus_context = struct + include Context + + let compile_config = precomputed_values.compile_config + end in [%log info] "Starting transition router" ; let initialization_finish_signal = Ivar.create () in let clear_reader, clear_writer = @@ -662,7 +675,7 @@ let run ?(sync_local_state = true) ?(cache_exceptions = false) if Consensus.Hooks.equal_select_status `Take (Consensus.Hooks.select - ~context:(module Context) + ~context:(module Consensus_context) ~existing:(to_consensus_state current_header_with_hash) ~candidate:(to_consensus_state header_with_hash) ) then @@ -682,7 +695,7 @@ let run ?(sync_local_state = true) ?(cache_exceptions = false) | Some frontier -> if is_transition_for_bootstrap - ~context:(module Context) + ~context:(module Consensus_context) frontier header_with_hash then ( Strict_pipe.Writer.kill !transition_writer_ref ; diff --git a/src/lib/vrf_evaluator/dune b/src/lib/vrf_evaluator/dune index 02714054a68..cd1cacde338 100644 --- a/src/lib/vrf_evaluator/dune +++ b/src/lib/vrf_evaluator/dune @@ -28,6 +28,7 @@ logger logger.file_system ppx_version.runtime + mina_compile_config ) (instrumentation (backend bisect_ppx)) (preprocess (pps ppx_mina ppx_version ppx_jane))) diff --git a/src/lib/vrf_evaluator/vrf_evaluator.ml b/src/lib/vrf_evaluator/vrf_evaluator.ml index ff5b71ee4ed..561f9292f0a 100644 --- a/src/lib/vrf_evaluator/vrf_evaluator.ml +++ b/src/lib/vrf_evaluator/vrf_evaluator.ml @@ -10,6 +10,8 @@ module type CONTEXT = sig val constraint_constants : Genesis_constants.Constraint_constants.t val consensus_constants : Consensus.Constants.t + + val compile_config : Mina_compile_config.t end (*Slot number within an epoch*) @@ -75,6 +77,7 @@ module Worker_state = struct type init_arg = { constraint_constants : Genesis_constants.Constraint_constants.t ; consensus_constants : Consensus.Constants.Stable.Latest.t + ; compile_config : Mina_compile_config.t ; conf_dir : string ; logger : Logger.t ; commit_id : string @@ -84,6 +87,7 @@ module Worker_state = struct let context_of_config ({ constraint_constants ; consensus_constants + ; compile_config ; logger ; conf_dir = _ ; commit_id = _ @@ -95,6 +99,8 @@ module Worker_state = struct let consensus_constants = consensus_constants let logger = logger + + let compile_config = compile_config end ) type t = @@ -414,7 +420,7 @@ let update_block_producer_keys { connection; process = _ } ~keypairs = ~arg:(Keypair.And_compressed_pk.Set.to_list keypairs) let create ~constraint_constants ~pids ~consensus_constants ~conf_dir ~logger - ~keypairs ~commit_id = + ~keypairs ~commit_id ~compile_config = let on_failure err = [%log error] "VRF evaluator process failed with error $err" ~metadata:[ ("err", Error_json.error_to_yojson err) ] ; @@ -424,7 +430,13 @@ let create ~constraint_constants ~pids ~consensus_constants ~conf_dir ~logger let%bind connection, process = Worker.spawn_in_foreground_exn ~connection_timeout:(Time.Span.of_min 1.) ~on_failure ~shutdown_on:Connection_closed ~connection_state_init_arg:() - { constraint_constants; consensus_constants; conf_dir; logger; commit_id } + { constraint_constants + ; consensus_constants + ; compile_config + ; conf_dir + ; logger + ; commit_id + } in [%log info] "Daemon started process of kind $process_kind with pid $vrf_evaluator_pid"