diff --git a/src/app/archive/lib/diff.ml b/src/app/archive/lib/diff.ml index d5405a4cb7b2..5daeba1c6080 100644 --- a/src/app/archive/lib/diff.ml +++ b/src/app/archive/lib/diff.ml @@ -1,4 +1,3 @@ -open Mina_block open Core_kernel open Mina_base module Breadcrumb = Transition_frontier.Breadcrumb @@ -27,9 +26,6 @@ module Transition_frontier = struct (Account_id.Stable.Latest.t * Receipt.Chain_hash.Stable.Latest.t) list } - | Root_transitioned of - Transition_frontier.Diff.Root_transition.Lite.Stable.Latest.t - | Bootstrap of { lost_blocks : State_hash.Stable.Latest.t list } [@@deriving bin_io_unversioned] end @@ -101,13 +97,7 @@ module Builder = struct let account_creation_fee = precomputed_values.constraint_constants.account_creation_fee in - let previous_block_state_hash = - Mina_block.header block |> Header.protocol_state - |> Mina_state.Protocol_state.previous_state_hash - in - List.map - (Staged_ledger.latest_block_accounts_created staged_ledger - ~previous_block_state_hash ) ~f:(fun acct_id -> + List.map (Breadcrumb.accounts_created breadcrumb) ~f:(fun acct_id -> (acct_id, account_creation_fee) ) in let tokens_used = diff --git a/src/app/archive/lib/processor.ml b/src/app/archive/lib/processor.ml index caad5467425c..5c155e646570 100644 --- a/src/app/archive/lib/processor.ml +++ b/src/app/archive/lib/processor.ml @@ -4590,39 +4590,38 @@ let add_block_aux_extensional ~proof_cache_db ~logger ~signature_kind ?retries let run pool reader ~proof_cache_db ~genesis_constants ~constraint_constants ~logger ~delete_older_than : unit Deferred.t = Strict_pipe.Reader.iter reader ~f:(function - | Diff.Transition_frontier - (Breadcrumb_added - { block; accounts_accessed; accounts_created; tokens_used; _ } ) -> ( - let add_block = - Block.add_if_doesn't_exist ~logger ~constraint_constants - ~accounts_accessed ~accounts_created - in - let hash = State_hash.With_state_hashes.state_hash in - let signature_kind = Mina_signature_kind.t_DEPRECATED in - let block = - With_hash.map - ~f: - (Mina_block.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db ) - block - in - match%bind - add_block_aux ~logger ~genesis_constants ~pool ~delete_older_than - ~hash ~add_block ~tokens_used block - with - | Error e -> - let state_hash = hash block in - [%log warn] - ~metadata: - [ ("state_hash", State_hash.to_yojson state_hash) - ; ("error", `String (Caqti_error.show e)) - ] - "Failed to archive block with state hash $state_hash, see $error" ; - Deferred.unit - | Ok () -> - Deferred.unit ) - | Transition_frontier _ -> - Deferred.unit ) + | Diff.Transition_frontier + (Breadcrumb_added + { block; accounts_accessed; accounts_created; tokens_used; _ } ) + -> + (let add_block = + Block.add_if_doesn't_exist ~logger ~constraint_constants + ~accounts_accessed ~accounts_created + in + let hash = State_hash.With_state_hashes.state_hash in + let signature_kind = Mina_signature_kind.t_DEPRECATED in + let block = + With_hash.map + ~f: + (Mina_block.write_all_proofs_to_disk ~signature_kind + ~proof_cache_db ) + block + in + match%bind + add_block_aux ~logger ~genesis_constants ~pool ~delete_older_than ~hash + ~add_block ~tokens_used block + with + | Error e -> + let state_hash = hash block in + [%log warn] + ~metadata: + [ ("state_hash", State_hash.to_yojson state_hash) + ; ("error", `String (Caqti_error.show e)) + ] + "Failed to archive block with state hash $state_hash, see $error" ; + Deferred.unit + | Ok () -> + Deferred.unit ) ) (* [add_genesis_accounts] is called when starting the archive process *) let add_genesis_accounts ~logger ~(runtime_config_opt : Runtime_config.t option) @@ -4653,8 +4652,9 @@ let add_genesis_accounts ~logger ~(runtime_config_opt : Runtime_config.t option) Account_id.Set.to_list account_id_set in let genesis_block = - let With_hash.{ data = block; hash = the_hash }, _ = + let With_hash.{ data = block; hash = the_hash } = Mina_block.genesis ~precomputed_values + |> fst |> Mina_block.Validated.forget in With_hash.{ data = block; hash = the_hash } in diff --git a/src/app/cli/src/init/fix_persistent_frontier.ml b/src/app/cli/src/init/fix_persistent_frontier.ml index 8510a7bec469..3b462c8ed585 100644 --- a/src/app/cli/src/init/fix_persistent_frontier.ml +++ b/src/app/cli/src/init/fix_persistent_frontier.ml @@ -55,27 +55,33 @@ let apply_root_transitions ~logger ~db diffs = .message err ) ) ) |> Result.ok_exn in + let initial_root_history = + Transition_frontier.Persistent_frontier.Database.get_root_history db + in + let root_history_capacity = + Transition_frontier.Persistent_frontier.Database.root_history_capacity db + in Transition_frontier.Persistent_frontier.Database.with_batch db ~f:(fun batch -> - ( List.fold diffs ~init:initial_root_hash ~f:(fun old_root_hash diff -> + ( List.fold diffs ~init:(initial_root_hash, initial_root_history) + ~f:(fun (old_root_hash, old_root_history) diff -> match diff with | Diff.Lite.E.E (Diff.Root_transitioned { new_root; garbage = Lite garbage; _ } ) -> - let parent_hash = - Root_data.Limited.Stable.Latest.transition new_root - |> Mina_block.Validated.Stable.Latest.header - |> Mina_block.Header.protocol_state - |> Mina_state.Protocol_state.previous_state_hash - in - assert (State_hash.equal parent_hash old_root_hash) ; Transition_frontier.Persistent_frontier.Database.move_root - ~old_root_hash ~new_root ~garbage batch ; + ~old_root_hash ~new_root ~garbage ~old_root_history + ~root_history_capacity batch ; (* Return new root hash for next iteration *) - (Root_data.Limited.Stable.Latest.hashes new_root).state_hash + let old_root_history' = + if List.length old_root_history = root_history_capacity then + List.drop_last_exn old_root_history + else old_root_history + in + (new_root.state_hash, old_root_hash :: old_root_history') | _ -> failwith "Expected Root_transitioned diff" ) - : State_hash.t ) + : State_hash.t * State_hash.t list ) |> ignore ) ; [%log' info logger] "Successfully applied $count diffs" ~metadata:[ ("count", `Int (List.length diffs)) ] ; @@ -85,8 +91,57 @@ let apply_root_transitions ~logger ~db diffs = ~metadata:[ ("error", `String (Exn.to_string exn)) ] ; Error ("Failed to apply root transitions: " ^ Exn.to_string exn) +let persist_all_transitions ~logger ~db breadcrumbs = + [%log info] "Re-persisting %d transitions" (List.length breadcrumbs) ; + Transition_frontier.Persistent_frontier.Database.with_batch db + ~f:(fun batch -> + List.iter breadcrumbs ~f:(fun breadcrumb -> + Transition_frontier.Persistent_frontier.Database.set_transition + ~state_hash:(Breadcrumb.state_hash breadcrumb) + ~transition_data:(Breadcrumb.to_block_data_exn breadcrumb) + batch ) ) ; + [%log info] "Re-persisted %d transitions" (List.length breadcrumbs) + +let print_ram_usage ~logger frontier_length rss_before rss_after rss_after_gc + elapsed = + let gc_stats = Gc.stat () in + let float_opt_json = Option.value_map ~default:`Null ~f:(fun x -> `Float x) in + [%log info] + "Loaded transition frontier of %d breadcrumbs in $elapsed seconds with RSS \ + $rss_after_gc (started with $rss_before, before GC: $rss_after), see \ + $gc_stats (taken after GC)" + frontier_length + ~metadata: + [ ("elapsed", `Float (Time.Span.to_sec elapsed)) + ; ("rss_after", float_opt_json rss_after) + ; ("rss_after_gc", float_opt_json rss_after_gc) + ; ("rss_before", float_opt_json rss_before) + ; ( "gc_stats" + , `Assoc + [ ("heap_words", `Int gc_stats.heap_words) + ; ("major_words", `Float gc_stats.major_words) + ; ("minor_words", `Float gc_stats.minor_words) + ; ( "forced_major_collections" + , `Int gc_stats.forced_major_collections ) + ; ("major_collections", `Int gc_stats.major_collections) + ; ("minor_collections", `Int gc_stats.minor_collections) + ; ("compactions", `Int gc_stats.compactions) + ; ("promoted_words", `Float gc_stats.promoted_words) + ; ("heap_chunks", `Int gc_stats.heap_chunks) + ; ("live_words", `Int gc_stats.live_words) + ; ("free_words", `Int gc_stats.free_words) + ; ("largest_free", `Int gc_stats.largest_free) + ; ("fragments", `Int gc_stats.fragments) + ; ("live_blocks", `Int gc_stats.live_blocks) + ; ("free_blocks", `Int gc_stats.free_blocks) + ; ("top_heap_words", `Int gc_stats.top_heap_words) + ; ("stack_size", `Int gc_stats.stack_size) + ] ) + ] + let fix_persistent_frontier_root_do ~logger ~config_directory - ~chain_state_locations ~max_frontier_depth runtime_config = + ~chain_state_locations ~max_frontier_depth ~migrate_frontier runtime_config + = let signature_kind = Mina_signature_kind.t_DEPRECATED in (* Get compile-time constants *) let genesis_constants = Genesis_constants.Compiled.genesis_constants in @@ -131,6 +186,10 @@ let fix_persistent_frontier_root_do ~logger ~config_directory ~directory:chain_state_locations.frontier ~time_controller:(Block_time.Controller.basic ~logger) ~signature_kind + ~root_history_capacity: + ( 2 + * Transition_frontier.global_max_length + precomputed_values.genesis_constants ) in let proof_cache_db = Proof_cache_tag.create_identity_db () in let%bind.Deferred.Result persistent_frontier_root_hash = @@ -170,6 +229,8 @@ let fix_persistent_frontier_root_do ~logger ~config_directory ~epoch_ledger_backing_type:Stable_db Signature_lib.Public_key.Compressed.Set.empty in + let rss_before = Mina_stdlib_unix.File_system.read_rss_kb None in + let start = Time.now () in (* TODO loading of frontier is redundant unless fixing is needed *) (* Load transition frontier using the standard API *) let%bind frontier = @@ -178,7 +239,10 @@ let fix_persistent_frontier_root_do ~logger ~config_directory ~context:(module Context) ~retry_with_fresh_db:false ~max_frontier_depth ~verifier ~consensus_local_state ~persistent_root ~persistent_frontier - ~catchup_mode:`Super ~set_best_tip:false () + ~catchup_mode:`Super + ~set_best_tip:false + (* application data is used in frontier migration, so we need to retain it *) + ~retain_application_data:migrate_frontier ~check_arcs:false () with | Error err -> let err_str = @@ -198,6 +262,13 @@ let fix_persistent_frontier_root_do ~logger ~config_directory | Ok f -> f in + let rss_after = Mina_stdlib_unix.File_system.read_rss_kb None in + Gc.compact () ; + let rss_after_gc = Mina_stdlib_unix.File_system.read_rss_kb None in + let elapsed = Time.diff (Time.now ()) start in + print_ram_usage ~logger + (Transition_frontier.all_breadcrumbs frontier |> List.length) + rss_before rss_after rss_after_gc elapsed ; let frontier_root_hash = Transition_frontier.root frontier |> Breadcrumb.state_hash in @@ -205,7 +276,25 @@ let fix_persistent_frontier_root_do ~logger ~config_directory let with_persistent_frontier_instance f = Persistent_frontier.with_instance_exn persistent_frontier ~f in + let migrate_frontier_do (instance : Persistent_frontier.Instance.t) = + if migrate_frontier then + let root_hash = + Transition_frontier.root frontier |> Breadcrumb.state_hash + in + let breadcrumbs = + (* Excluding root, because for it application data is not preserved, + and transition record isn't used. *) + Transition_frontier.all_breadcrumbs frontier + |> List.filter ~f:(fun breadcrumb -> + not @@ State_hash.equal root_hash + @@ Breadcrumb.state_hash breadcrumb ) + in + persist_all_transitions ~logger ~db:instance.db breadcrumbs + else () + in let clean_frontier () = + Transition_frontier.with_persistent_frontier_instance_exn frontier + ~f:migrate_frontier_do ; let%bind () = Transition_frontier.close ~loc:__LOC__ frontier in Mina_stdlib_unix.File_system.remove_dir tmp_root_location in @@ -263,8 +352,7 @@ let fix_persistent_frontier_root_do ~logger ~config_directory in ( ( breadcrumb , Transition_frontier.Util.to_protocol_states_map_exn - @@ Root_data.Limited.Stable.Latest.protocol_states - @@ root_transition.new_root ) + root_transition.new_root.protocol_states_for_scan_state ) , res ) ) in [%log info] "Generated $count transition diffs" @@ -278,7 +366,7 @@ let fix_persistent_frontier_root_do ~logger ~config_directory [%log info] "Successfully moved frontier root to match persistent root" let fix_persistent_frontier_root ~config_directory ~config_file - ~max_frontier_depth = + ~max_frontier_depth ~migrate_frontier = Logger.Consumer_registry.register ~commit_id:"" ~id:Logger.Logger_id.mina ~processor:Internal_tracing.For_logger.processor ~transport: @@ -322,7 +410,8 @@ let fix_persistent_frontier_root ~config_directory ~config_file Deferred.Result.return () | `Both_exist -> fix_persistent_frontier_root_do ~logger ~config_directory - ~chain_state_locations ~max_frontier_depth runtime_config + ~chain_state_locations ~max_frontier_depth ~migrate_frontier + runtime_config let command = Command.async @@ -337,6 +426,11 @@ let command = and max_frontier_depth = flag "--max-frontier-depth" ~doc:"INT maximum frontier depth (default: 10)" (optional int) + and migrate_frontier = + flag "--migrate-frontier" + ~doc: + "BOOL whether to migrate frontier to the new format (default: false)" + no_arg in Cli_lib.Exceptions.handle_nicely @@ fun () -> @@ -352,6 +446,7 @@ let command = match%bind fix_persistent_frontier_root ~config_directory:conf_dir ~config_file ~max_frontier_depth:(Option.value max_frontier_depth ~default:10) + ~migrate_frontier with | Ok () -> printf "Persistent frontier root fix completed successfully.\n" ; diff --git a/src/app/cli/src/init/test_submit_to_archive.ml b/src/app/cli/src/init/test_submit_to_archive.ml index 0080a911780e..0dff561a1b31 100644 --- a/src/app/cli/src/init/test_submit_to_archive.ml +++ b/src/app/cli/src/init/test_submit_to_archive.ml @@ -101,6 +101,9 @@ module Block = struct let protocol_state t = Frontier_base.Breadcrumb.protocol_state t.breadcrumb + let consensus_state_with_hashes t = + Frontier_base.Breadcrumb.consensus_state_with_hashes t.breadcrumb + let state_timestamp t = Blockchain_state.timestamp @@ Protocol_state.blockchain_state @@ protocol_state t @@ -110,12 +113,9 @@ module Block = struct let compute_genesis ~logger ~precomputed_values (module Keys : Keys_S) = (* Generate genesis block, used in a bunch of other places (including block producer and tests) *) - let genesis_block_with_hash, genesis_validation = + let genesis_block, genesis_block_tag = Mina_block.genesis ~precomputed_values in - let validated = - Mina_block.Validated.lift (genesis_block_with_hash, genesis_validation) - in let constraint_constants = precomputed_values.constraint_constants in (* Create a staged ledger out of genesis ledger. Fresh code, not copied from anywhere else. *) @@ -137,10 +137,11 @@ module Block = struct in [%log info] "Generating genesis breadcrumb" ; let breadcrumb = - Frontier_base.Breadcrumb.create ~validated_transition:validated + Frontier_base.Breadcrumb.create ~validated_transition:genesis_block ~staged_ledger ~transition_receipt_time:(Some (Time.now ())) - ~just_emitted_a_proof:false + ~just_emitted_a_proof:false ~accounts_created:[] + ~block_tag:genesis_block_tag in (* Block proof contained in genesis header is just a stub. Hence we need to generate the real proof here, in order to @@ -365,7 +366,7 @@ let build_breadcrumb ~transactions ~context ~precomputed_values ~verifier ~state_hash:(Some previous_state_hash) previous_protocol_state ) >>| V.skip_proof_validation `This_block_was_generated_internally >>= V.validate_frontier_dependencies ~to_header:Mina_block.header ~context - ~root_block:(Block.block_with_hash previous) + ~root_consensus_state:(Block.consensus_state_with_hashes previous) ~is_block_in_frontier:(State_hash.equal previous_state_hash) |> Result.map_error ~f:(const (Error.of_string "failed to validate just created block")) @@ -415,7 +416,10 @@ let mk_payment ~(valid_until : Mina_numbers.Global_slot_since_genesis.t) { Signed_command.Poly.signer = signer_keypair.public_key; signature; payload } let generate_txs ~valid_until ~init_nonce ~n_zkapp_txs ~n_payments ~n_blocks - ~constraint_constants keypair : User_command.Valid.t Sequence.t list = + ~constraint_constants keypair : + Mina_transaction.Transaction_hash.User_command_with_valid_signature.t + Sequence.t + list = let signer_pk = Public_key.compress keypair.Keypair.public_key in let event_elements = 12 in let action_elements = 12 in @@ -444,7 +448,8 @@ let generate_txs ~valid_until ~init_nonce ~n_zkapp_txs ~n_payments ~n_blocks valid_command ) = User_command.to_valid_unsafe command in - valid_command ) + Mina_transaction.Transaction_hash.User_command_with_valid_signature + .create valid_command ) in List.init n_blocks ~f:generate_payments diff --git a/src/app/delegation_verify/cassandra.ml b/src/app/delegation_verify/cassandra.ml index bc4296e881e1..a603cfa25f49 100644 --- a/src/app/delegation_verify/cassandra.ml +++ b/src/app/delegation_verify/cassandra.ml @@ -35,7 +35,7 @@ let make_conf ?executable ~keyspace : conf = let conn = make_conn_conf () in let credentials = make_cred_conf () in let executable = - Option.merge executable (Sys.getenv "CQLSH") ~f:Fn.const + Option.first_some executable (Sys.getenv "CQLSH") |> Option.value ~default:"cqlsh" in { executable; connection = conn; credentials; keyspace } diff --git a/src/app/disk_caching_stats/disk_caching_stats.ml b/src/app/disk_caching_stats/disk_caching_stats.ml index 24a6fd8d6c50..0ace529d5b81 100644 --- a/src/app/disk_caching_stats/disk_caching_stats.ml +++ b/src/app/disk_caching_stats/disk_caching_stats.ml @@ -364,7 +364,8 @@ module Values (S : Sample) = struct let base_work varying witness : Transaction_snark_scan_state.Transaction_with_witness.t = - { transaction_with_info = { previous_hash = field (); varying = varying () } + let transaction_with_status, tx_applied = varying () in + { transaction_with_status ; state_hash = (state_hash (), field ()) ; statement = (*Transaction_snark.Statement.Stable.V2.t*) @@ -387,46 +388,60 @@ module Values (S : Sample) = struct ; fee_excess = fee_excess () ; sok_digest = () } - ; init_stack = Base (pending_coinbase_stack ()) + ; init_stack = pending_coinbase_stack () ; first_pass_ledger_witness = witness () ; second_pass_ledger_witness = witness () - ; block_global_slot = global_slot_since_genesis () + ; block_global_slot = global_slot_since_genesis () (* TODO: add a value *) + ; previous_protocol_state_body_opt = None + ; transaction_applied_or_tag = First tx_applied } let zkapp_command_base_work ~config () : Transaction_snark_scan_state.Transaction_with_witness.t = base_work (fun () -> - Command - (Zkapp_command - { accounts = - List.init Params.max_accounts_modified_per_zkapp_command - ~f:(fun _ -> - let a = account () in - (Mina_base.Account.identifier a, Some a) ) - ; command = - { status = Applied; data = zkapp_command' () } - (* the worst case is that no new accounts are created and they are all cached, so we leave this empty *) - ; new_accounts = [] - } ) ) + let zkapp_command = zkapp_command' () in + ( { Mina_base.With_status.status = Applied + ; data = Command (Zkapp_command zkapp_command) + } + , { previous_hash = field () + ; varying = + Command + (Zkapp_command + { accounts = + List.init Params.max_accounts_modified_per_zkapp_command + ~f:(fun _ -> + let a = account () in + (Mina_base.Account.identifier a, Some a) ) + ; command = { status = Applied; data = zkapp_command } + ; new_accounts = [] + } ) + } ) ) (zkapp_command_witness ~config) let signed_command_base_work ~config () : Transaction_snark_scan_state.Transaction_with_witness.t = base_work (fun () -> - Command - (Signed_command - { common = - { user_command = - { status = Applied; data = signed_command' () } - } - ; body = - Payment - { new_accounts = - [ Mina_base.Account.identifier (account ()) ] - } - } ) ) + let signed_command = signed_command' () in + ( { Mina_base.With_status.status = Applied + ; data = Command (Signed_command signed_command) + } + , { previous_hash = field () + ; varying = + Command + (Signed_command + { common = + { user_command = + { status = Applied; data = signed_command } + } + ; body = + Payment + { new_accounts = + [ Mina_base.Account.identifier (account ()) ] + } + } ) + } ) ) (signed_command_witness ~config) let sok_message () : Mina_base.Sok_message.t = diff --git a/src/app/dump_blocks/dump_blocks.ml b/src/app/dump_blocks/dump_blocks.ml index 7e2363acf69a..35b28afa97e0 100644 --- a/src/app/dump_blocks/dump_blocks.ml +++ b/src/app/dump_blocks/dump_blocks.ml @@ -91,7 +91,10 @@ let f (type a) ?parent (outputs : a codec io list) make_breadcrumb = List.iter outputs ~f:(fun output -> let module Enc = (val output.encoding) in let content = - Enc.of_breadcrumb ?with_parent_statehash:parent breadcrumb + Enc.of_breadcrumb ?with_parent_statehash:parent + ~accounts_created: + (Frontier_base.Breadcrumb.accounts_created breadcrumb) + breadcrumb in eprintf !"Randomly generated block, %s: %s\n" diff --git a/src/app/dump_blocks/encoding.ml b/src/app/dump_blocks/encoding.ml index c4b0924e6cb6..a762f223c711 100644 --- a/src/app/dump_blocks/encoding.ml +++ b/src/app/dump_blocks/encoding.ml @@ -8,7 +8,7 @@ type 'a content = let append_newline s = s ^ "\n" -let block_of_breadcrumb ?with_parent_statehash breadcrumb = +let block_of_breadcrumb ?with_parent_statehash ~accounts_created:_ breadcrumb = let open Mina_block in let block = Frontier_base.Breadcrumb.block breadcrumb in match with_parent_statehash with @@ -37,7 +37,10 @@ module type S = sig val name : string val of_breadcrumb : - ?with_parent_statehash:string -> Frontier_base.Breadcrumb.t -> t + ?with_parent_statehash:string + -> accounts_created:Mina_base.Account_id.t list + -> Frontier_base.Breadcrumb.t + -> t val to_string : t -> string @@ -80,9 +83,12 @@ let precomputed_values = Lazy.force Precomputed_values.for_unit_tests let constraint_constants = precomputed_values.constraint_constants -let precomputed_of_breadcrumb ?with_parent_statehash breadcrumb = +let precomputed_of_breadcrumb ?with_parent_statehash ~accounts_created + breadcrumb = let open Frontier_base in - let block = block_of_breadcrumb ?with_parent_statehash breadcrumb in + let block = + block_of_breadcrumb ?with_parent_statehash ~accounts_created breadcrumb + in let staged_ledger = Transition_frontier.Breadcrumb.staged_ledger breadcrumb in let scheduled_time = Mina_block.Stable.Latest.header block @@ -93,6 +99,7 @@ let precomputed_of_breadcrumb ?with_parent_statehash breadcrumb = Mina_block.Precomputed.of_block ~logger ~constraint_constants ~staged_ledger ~scheduled_time (Breadcrumb.block_with_hash breadcrumb) + ~accounts_created module Sexp_precomputed : S with type t = Mina_block.Precomputed.t = struct type t = Mina_block.Precomputed.t diff --git a/src/app/heap_usage/heap_usage.ml b/src/app/heap_usage/heap_usage.ml index c6440779d164..da1998f122c8 100644 --- a/src/app/heap_usage/heap_usage.ml +++ b/src/app/heap_usage/heap_usage.ml @@ -48,8 +48,7 @@ let main ~genesis_constants ~constraint_constants conf_dir : unit Deferred.t = scan_state_base_node_zkapp ~constraint_constants ~zkapp_command in print_heap_usage "Parallel_scan.Base.t (zkApp)" scan_state_base_node_zkapp ; - print_heap_usage "Parallel_scan.Merge.t" - (scan_state_merge_node ~proof_cache_db) ; + print_heap_usage "Parallel_scan.Merge.t" scan_state_merge_node ; print_heap_usage "Transaction_snark.Statement.t" transaction_snark_statement let () = diff --git a/src/app/heap_usage/values.ml b/src/app/heap_usage/values.ml index 89f380fad8e0..02e275c3e857 100644 --- a/src/app/heap_usage/values.ml +++ b/src/app/heap_usage/values.ml @@ -68,8 +68,8 @@ let verification_key = let applied = Mina_base.Transaction_status.Applied -let mk_scan_state_base_node - (varying : Mina_transaction_logic.Transaction_applied.Varying.t) +let mk_scan_state_base_node (transaction : Mina_transaction.Transaction.t) + (varying_applied : Mina_transaction_logic.Transaction_applied.Varying.t) ~(constraint_constants : Genesis_constants.Constraint_constants.t) : Transaction_snark_scan_state.Transaction_with_witness.t Parallel_scan.Base.t = @@ -81,26 +81,20 @@ let mk_scan_state_base_node let state_hash = get Mina_base.State_hash.gen in let state_body_hash = get Mina_base.State_body_hash.gen in let statement = get Transaction_snark.Statement.gen in - let init_stack = - Transaction_snark.Pending_coinbase_stack_state.Init_stack.Merge - in + let init_stack = Mina_base.Pending_coinbase.Stack.empty in let ledger_witness = let depth = constraint_constants.ledger_depth in let account_access_statuses = - match varying with + match transaction with | Command (Signed_command signed_cmd) -> - let user_cmd = signed_cmd.common.user_command.data in - Mina_base.Signed_command.account_access_statuses user_cmd applied + Mina_base.Signed_command.account_access_statuses signed_cmd applied | Command (Zkapp_command zkapp_cmd) -> - let zkapp_cmd = zkapp_cmd.command.data in Mina_base.Zkapp_command.account_access_statuses zkapp_cmd applied | Fee_transfer ft -> - let fee_transfer = ft.fee_transfer.data in - List.map (Mina_base.Fee_transfer.receivers fee_transfer) - ~f:(fun acct_id -> (acct_id, `Accessed)) + List.map (Mina_base.Fee_transfer.receivers ft) ~f:(fun acct_id -> + (acct_id, `Accessed) ) | Coinbase cb -> - let coinbase = cb.coinbase.data in - Mina_base.Coinbase.account_access_statuses coinbase applied + Mina_base.Coinbase.account_access_statuses cb applied in let num_accounts_accessed = List.count account_access_statuses ~f:(fun (_acct_id, accessed) -> @@ -122,18 +116,19 @@ let mk_scan_state_base_node acct ) ) ; !ledger in - let transaction_with_info : Mina_transaction_logic.Transaction_applied.t = - let previous_hash = get Mina_base.Ledger_hash.gen in - { previous_hash; varying } - in + let previous_hash = get Mina_base.Ledger_hash.gen in let job : Transaction_snark_scan_state.Transaction_with_witness.t = - { transaction_with_info + { transaction_with_status = { status = applied; data = transaction } ; state_hash = (state_hash, state_body_hash) ; statement ; init_stack ; first_pass_ledger_witness = ledger_witness ; second_pass_ledger_witness = ledger_witness - ; block_global_slot = Mina_numbers.Global_slot_since_genesis.zero + ; block_global_slot = + Mina_numbers.Global_slot_since_genesis.zero (* TODO: add a value *) + ; previous_protocol_state_body_opt = None + ; transaction_applied_or_tag = + First { previous_hash; varying = varying_applied } } in let record : _ Parallel_scan.Base.Record.t = @@ -144,62 +139,51 @@ let mk_scan_state_base_node (weight, job) let scan_state_base_node_coinbase = - let varying : Mina_transaction_logic.Transaction_applied.Varying.t = - let coinbase = - Mina_base.Coinbase.create ~amount:Currency.Amount.zero - ~receiver:sample_pk_compressed ~fee_transfer:None - |> Or_error.ok_exn - in - Coinbase + let coinbase = + Mina_base.Coinbase.create ~amount:Currency.Amount.zero + ~receiver:sample_pk_compressed ~fee_transfer:None + |> Or_error.ok_exn + in + let applied = + Mina_transaction_logic.Transaction_applied.Varying.Coinbase { coinbase = Mina_base.With_status.{ data = coinbase; status = Applied } ; new_accounts = [] ; burned_tokens = Currency.Amount.zero } in - mk_scan_state_base_node varying + mk_scan_state_base_node (Coinbase coinbase) applied let scan_state_base_node_payment = - let varying : Mina_transaction_logic.Transaction_applied.Varying.t = - let payload : Mina_base.Signed_command_payload.t = - let payment_payload = - Quickcheck.random_value - (Mina_base.Payment_payload.gen Currency.Amount.zero) - in - let body : Mina_base.Signed_command_payload.Body.t = - Payment payment_payload - in - let common : Mina_base.Signed_command_payload.Common.t = - { fee = Currency.Fee.zero - ; fee_payer_pk = sample_pk_compressed - ; nonce = Mina_numbers.Account_nonce.zero - ; valid_until = Mina_numbers.Global_slot_since_genesis.max_value - ; memo = Mina_base.Signed_command_memo.empty - } - in - { common; body } + let payload : Mina_base.Signed_command_payload.t = + let payment_payload = + Quickcheck.random_value + (Mina_base.Payment_payload.gen Currency.Amount.zero) in - let user_command : _ Mina_base.With_status.t = - let signer = sample_pk in - let data : Mina_base.Signed_command.t = - { payload; signer; signature = Mina_base.Signature.dummy } - in - { data; status = Applied } + let body : Mina_base.Signed_command_payload.Body.t = + Payment payment_payload in - let common : - Mina_transaction_logic.Transaction_applied.Signed_command_applied.Common - .t = - { user_command } - in - let body : - Mina_transaction_logic.Transaction_applied.Signed_command_applied.Body.t - = - Payment { new_accounts = [] } + let common : Mina_base.Signed_command_payload.Common.t = + { fee = Currency.Fee.zero + ; fee_payer_pk = sample_pk_compressed + ; nonce = Mina_numbers.Account_nonce.zero + ; valid_until = Mina_numbers.Global_slot_since_genesis.max_value + ; memo = Mina_base.Signed_command_memo.empty + } in - Command (Signed_command { common; body }) + { common; body } + in + let user_command : Mina_base.Signed_command.t = + { payload; signer = sample_pk; signature = Mina_base.Signature.dummy } in - mk_scan_state_base_node varying + mk_scan_state_base_node (Command (Signed_command user_command)) + (Command + (Signed_command + { common = + { user_command = { data = user_command; status = Applied } } + ; body = Payment { new_accounts = [] } + } ) ) -let scan_state_base_node_zkapp ~constraint_constants ~zkapp_command = +let scan_state_base_node_zkapp ~zkapp_command = let varying : Mina_transaction_logic.Transaction_applied.Varying.t = let zkapp_command_applied : Mina_transaction_logic.Transaction_applied.Zkapp_command_applied.t = @@ -226,9 +210,9 @@ let scan_state_base_node_zkapp ~constraint_constants ~zkapp_command = in Command (Zkapp_command zkapp_command_applied) in - mk_scan_state_base_node varying ~constraint_constants + mk_scan_state_base_node (Command (Zkapp_command zkapp_command)) varying -let scan_state_merge_node ~proof_cache_db : +let scan_state_merge_node : Transaction_snark_scan_state.Ledger_proof_with_sok_message.t Parallel_scan.Merge.t = let weight1 : Parallel_scan.Weight.t = { base = 42; merge = 99 } in @@ -249,8 +233,7 @@ let scan_state_merge_node ~proof_cache_db : { without_sok with sok_digest = Mina_base.Sok_message.digest sok_msg } in let ledger_proof = Transaction_snark.create ~statement ~proof in - ( Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db ledger_proof - , sok_msg ) + (ledger_proof, sok_msg) in let right = let sok_msg : Mina_base.Sok_message.t = @@ -266,8 +249,7 @@ let scan_state_merge_node ~proof_cache_db : { without_sok with sok_digest = Mina_base.Sok_message.digest sok_msg } in let ledger_proof = Transaction_snark.create ~statement ~proof in - ( Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db ledger_proof - , sok_msg ) + (ledger_proof, sok_msg) in Full { left; right; seq_no = 1; status = Todo } in diff --git a/src/app/replayer/sql.ml b/src/app/replayer/sql.ml index 160e21318772..396bfaf28134 100644 --- a/src/app/replayer/sql.ml +++ b/src/app/replayer/sql.ml @@ -344,7 +344,7 @@ module Internal_command = struct Caqti_type.[ string; int; int64; int; int64; int64; int; int ] (* the transaction global slot since genesis is taken from the internal command's current block, mirroring - the call to Staged_ledger.apply in Block_producer + the call to Staged_ledger.apply_diff in Block_producer *) let query = Mina_caqti.collect_req diff --git a/src/lib/best_tip_prover/best_tip_prover.ml b/src/lib/best_tip_prover/best_tip_prover.ml index 82eed13fe0b4..4806237b4469 100644 --- a/src/lib/best_tip_prover/best_tip_prover.ml +++ b/src/lib/best_tip_prover/best_tip_prover.ml @@ -17,23 +17,20 @@ module Make (Inputs : Inputs_intf) : end module Merkle_list_prover = Merkle_list_prover.Make_ident (struct - type value = Mina_block.Validated.t + type value = Frontier_base.Breadcrumb.t type context = Transition_frontier.t type proof_elem = State_body_hash.t - let to_proof_elem = Mina_block.Validated.state_body_hash + let to_proof_elem b = + Frontier_base.Breadcrumb.protocol_state_with_hashes b + |> State_hash.With_state_hashes.state_body_hash + ~compute_hashes:Mina_state.Protocol_state.hashes let get_previous ~context transition = - let parent_hash = - transition |> Mina_block.Validated.header - |> Mina_block.Header.protocol_state - |> Protocol_state.previous_state_hash - in - let open Option.Let_syntax in - let%map breadcrumb = Transition_frontier.find context parent_hash in - Transition_frontier.Breadcrumb.validated_transition breadcrumb + let parent_hash = transition |> Frontier_base.Breadcrumb.parent_hash in + Transition_frontier.find context parent_hash end) module Merkle_list_verifier = Merkle_list_verifier.Make (struct @@ -65,16 +62,8 @@ module Make (Inputs : Inputs_intf) : () in let best_tip_breadcrumb = Transition_frontier.best_tip frontier in - let best_verified_tip = - Transition_frontier.Breadcrumb.validated_transition best_tip_breadcrumb - in - let best_tip = Mina_block.Validated.forget best_verified_tip in - let root = - Transition_frontier.root frontier - |> Transition_frontier.Breadcrumb.validated_transition - in let _, merkle_list = - Merkle_list_prover.prove ~context:frontier best_verified_tip + Merkle_list_prover.prove ~context:frontier best_tip_breadcrumb in [%log debug] ~metadata: @@ -83,9 +72,7 @@ module Make (Inputs : Inputs_intf) : ] "Best tip prover produced a merkle list of $merkle_list" ; Proof_carrying_data. - { data = best_tip - ; proof = (merkle_list, With_hash.data @@ Mina_block.Validated.forget root) - } + { data = best_tip_breadcrumb; proof = (merkle_list, root) } let validate_proof ~verifier ~genesis_state_hash (header_hashed : Mina_block.Header.with_hash) : diff --git a/src/lib/block_producer/block_producer.ml b/src/lib/block_producer/block_producer.ml index 34ed23947431..fc16b3366db1 100644 --- a/src/lib/block_producer/block_producer.ml +++ b/src/lib/block_producer/block_producer.ml @@ -6,6 +6,27 @@ open Mina_transaction open Mina_state open Mina_block +(** State hash that is temporarily used in block creation + to be able to write work/witness tags before passing them + on to scan state construction. It's safe to use hardcoded value, given + that block production is single threaded and state hash is not used + in any other place. *) +let temp_state_hash = + (* TODO don't use quick check for generating this value: + 1. Define min/max bounds for big number in state hash module (extract it out of + [State_hash.gen]) + 2. Compute hash the same way it's done now + 3. Take necessary number of bits (use hash of the hash if more bits needed) + + I.e. this value should be computed once but shouldn't be prone to manipulation + *) + lazy + (Quickcheck.random_value + ~seed: + (`Deterministic + Blake2.(digest_string "temporary state hash" |> to_raw_string) ) + State_hash.gen ) + module type CONTEXT = sig val logger : Logger.t @@ -152,7 +173,10 @@ let report_transaction_inclusion_failures ~commit_id ~logger failed_txns = | (txn, error) :: remaining_failures -> let element = `Assoc - [ ("transaction", User_command.Valid.to_yojson txn) + [ ( "transaction_hash" + , Transaction_hash.to_yojson + @@ Transaction_hash.User_command_with_valid_signature + .transaction_hash txn ) ; ("error", Error_json.error_to_yojson error) ] in @@ -199,9 +223,11 @@ let generate_next_state ~commit_id ~zkapp_cmd_limit ~constraint_constants ~body_hash:previous_protocol_state_body_hash previous_protocol_state ) .state_hash in - let previous_state_view = + let previous_protocol_state_body = Protocol_state.body previous_protocol_state - |> Mina_state.Protocol_state.Body.view + in + let previous_state_view = + Protocol_state.Body.view previous_protocol_state_body in let global_slot = Consensus.Data.Block_data.global_slot_since_genesis block_data @@ -278,26 +304,81 @@ let generate_next_state ~commit_id ~zkapp_cmd_limit ~constraint_constants diff_result ) in [%log internal] "Apply_staged_ledger_diff" ; - match%map + let application_res = let%bind.Deferred.Result diff = return diff in - Staged_ledger.apply_diff_unchecked staged_ledger - ~constraint_constants ~global_slot diff ~logger - ~current_state_view:previous_state_view - ~state_and_body_hash: - (previous_protocol_state_hash, previous_protocol_state_body_hash) - ~coinbase_receiver ~supercharge_coinbase ~zkapp_cmd_limit_hardcap - ~signature_kind - with + let state_and_body_hash = + (previous_protocol_state_hash, previous_protocol_state_body_hash) + in + let%bind.Deferred.Result ( `Ledger new_ledger + , `Accounts_created _ + , `Stack_update stack_update + , `First_pass_ledger_end + first_pass_ledger_end + , `Witnesses witnesses + , `Works works + , `Pending_coinbase_update + (is_new_stack, pcu_action) ) = + Staged_ledger.apply_diff_unchecked staged_ledger + ~constraint_constants ~global_slot diff ~logger + ~parent_protocol_state_body:previous_protocol_state_body + ~state_and_body_hash ~coinbase_receiver ~supercharge_coinbase + ~zkapp_cmd_limit_hardcap ~signature_kind + in + let tagged_witnesses, tagged_works = + State_hash.File_storage.write_values_exn + (Lazy.force temp_state_hash) ~f:(fun writer -> + let witnesses' = + Staged_ledger.Scan_state.Transaction_with_witness + .persist_many witnesses writer + in + let works' = + Staged_ledger.Scan_state.Ledger_proof_with_sok_message + .persist_many works writer + in + (witnesses', works') ) + in + let scan_state_application_data = + { Staged_ledger.Scan_state.Application_data.is_new_stack + ; stack_update + ; first_pass_ledger_end + ; tagged_works + ; tagged_witnesses + } + in + (* TODO consider skipping verification (i.e. ~skip_verification:true) *) + let%map.Deferred.Result new_staged_ledger, ledger_proof_opt = + Staged_ledger.apply_to_scan_state ~logger ~skip_verification:false + ~log_prefix:"apply_diff_unchecked" ~ledger:new_ledger + ~previous_pending_coinbase_collection: + (Staged_ledger.pending_coinbase_collection staged_ledger) + ~previous_scan_state:(Staged_ledger.scan_state staged_ledger) + ~constraint_constants scan_state_application_data + in + (new_staged_ledger, ledger_proof_opt, is_new_stack, pcu_action) + in + match%map application_res with | Ok - ( `Ledger_proof ledger_proof_opt - , `Staged_ledger transitioned_staged_ledger - , `Pending_coinbase_update (is_new_stack, pending_coinbase_update) - ) -> + ( transitioned_staged_ledger + , ledger_proof_opt + , is_new_stack + , pending_coinbase_update ) -> [%log internal] "Hash_new_staged_ledger" ; let staged_ledger_hash = Staged_ledger.hash transitioned_staged_ledger in [%log internal] "Hash_new_staged_ledger_done" ; + (* TODO instead of throwing the new staged ledger away: + 1. Construct new block + 2. Replace [temp_state_hash] with the new state hash by traversing + the new scan state and checking equality of state hash against + every entry + 3. Use the new staged ledger with fixed-up scan state in breadcrumb + building + 4. Move the state hash file from [temp_state_hash]'s location to + a new location + 5. Append necessary serializations (e.g. block's raw data) at the + new location + *) (*staged_ledger remains unchanged and transitioned_staged_ledger is discarded because the external transtion created out of this diff will be applied in Transition_frontier*) ignore @@ Mina_ledger.Ledger.unregister_mask_exn ~loc:__LOC__ @@ -344,7 +425,7 @@ let generate_next_state ~commit_id ~zkapp_cmd_limit ~constraint_constants , next_staged_ledger_hash , ledger_proof_opt , is_new_stack - , pending_coinbase_update ) -> + , pending_coinbase_update ) -> ( let diff_unwrapped = Staged_ledger_diff.read_all_proofs_from_disk @@ Staged_ledger_diff.forget diff @@ -357,8 +438,8 @@ let generate_next_state ~commit_id ~zkapp_cmd_limit ~constraint_constants in let ledger_proof_statement = match ledger_proof_opt with - | Some (proof, _) -> - Ledger_proof.Cached.statement proof + | Some proof -> + Ledger_proof.Tagged.statement proof | None -> let state = previous_protocol_state @@ -372,8 +453,8 @@ let generate_next_state ~commit_id ~zkapp_cmd_limit ~constraint_constants in let supply_increase = Option.value_map ledger_proof_opt - ~f:(fun (proof, _) -> - (Ledger_proof.Cached.statement proof).supply_increase ) + ~f:(fun proof -> + (Ledger_proof.Tagged.statement proof).supply_increase ) ~default:Currency.Amount.Signed.zero in let body_reference = @@ -407,32 +488,44 @@ let generate_next_state ~commit_id ~zkapp_cmd_limit ~constraint_constants ~genesis_ledger_hash ~supply_increase ~logger ~constraint_constants ) ) in - lift_sync (fun () -> - let snark_transition = - O1trace.sync_thread "generate_snark_transition" (fun () -> - Snark_transition.create_value - ~blockchain_state: - (Protocol_state.blockchain_state protocol_state) - ~consensus_transition:consensus_transition_data - ~pending_coinbase_update () ) - in - let internal_transition = - O1trace.sync_thread "generate_internal_transition" (fun () -> - Internal_transition.create ~snark_transition - ~prover_state: - (Consensus.Data.Block_data.prover_state block_data) - ~staged_ledger_diff:(Staged_ledger_diff.forget diff) - ~ledger_proof: - (Option.map ledger_proof_opt ~f:(fun (proof, _) -> - Ledger_proof.Cached.read_proof_from_disk proof ) ) ) - in - let witness = - { Pending_coinbase_witness.pending_coinbases = - Staged_ledger.pending_coinbase_collection staged_ledger - ; is_new_stack - } - in - Some (protocol_state, internal_transition, witness) ) ) + let finish ledger_proof = + lift_sync (fun () -> + let snark_transition = + O1trace.sync_thread "generate_snark_transition" (fun () -> + Snark_transition.create_value + ~blockchain_state: + (Protocol_state.blockchain_state protocol_state) + ~consensus_transition:consensus_transition_data + ~pending_coinbase_update () ) + in + let internal_transition = + O1trace.sync_thread "generate_internal_transition" (fun () -> + Internal_transition.create ~snark_transition + ~prover_state: + (Consensus.Data.Block_data.prover_state block_data) + ~staged_ledger_diff:(Staged_ledger_diff.forget diff) + ~ledger_proof ) + in + let witness = + { Pending_coinbase_witness.pending_coinbases = + Staged_ledger.pending_coinbase_collection staged_ledger + ; is_new_stack + } + in + Some (protocol_state, internal_transition, witness) ) + in + Option.map ledger_proof_opt + ~f:Ledger_proof.Tagged.read_proof_from_disk + |> function + | Some (Error e) -> + [%log error] + ~metadata:[ ("error", Error_json.error_to_yojson e) ] + "Failed to read ledger proof from disk" ; + Interruptible.return None + | Some (Ok ledger_proof) -> + finish (Some ledger_proof) + | None -> + finish None ) ) let handle_block_production_errors ~logger ~rejected_blocks_logger ~time_taken:span ~previous_protocol_state ~protocol_state x = @@ -754,15 +847,15 @@ let produce ~genesis_breadcrumb ~context:(module Context : CONTEXT) ~prover ) ] "Producing new block with parent $parent_hash%!" ; - let previous_transition = Breadcrumb.block_with_hash crumb in - let previous_protocol_state = - Header.protocol_state - @@ Mina_block.header (With_hash.data previous_transition) + let previous_header = Breadcrumb.header crumb in + let previous_consensus_state_with_hashes = + Breadcrumb.consensus_state_with_hashes crumb in + let previous_protocol_state = Breadcrumb.protocol_state crumb in let%bind previous_protocol_state_proof = if Consensus.Data.Consensus_state.is_genesis_state - (Protocol_state.consensus_state previous_protocol_state) + (With_hash.data previous_consensus_state_with_hashes) && Option.is_none precomputed_values.proof_data then ( match%bind Interruptible.uninterruptible (genesis_breadcrumb ()) with @@ -774,17 +867,12 @@ let produce ~genesis_breadcrumb ~context:(module Context : CONTEXT) ~prover "Aborting block production: cannot generate a genesis proof" ~metadata:[ ("error", Error_json.error_to_yojson err) ] ; Interruptible.lift (Deferred.never ()) (Deferred.return ()) ) - else - return - ( Header.protocol_state_proof - @@ Mina_block.header (With_hash.data previous_transition) ) + else return (Header.protocol_state_proof previous_header) in [%log internal] "Get_transactions_from_pool" ; let transactions = Network_pool.Transaction_pool.Resource_pool.transactions transaction_resource_pool - |> Sequence.map - ~f:Transaction_hash.User_command_with_valid_signature.data in let%bind () = Interruptible.lift (Deferred.return ()) (Ivar.read ivar) in [%log internal] "Generate_next_state" ; @@ -826,9 +914,7 @@ let produce ~genesis_breadcrumb ~context:(module Context : CONTEXT) ~prover phys_equal (Consensus.Hooks.select ~context:(module Context) - ~existing: - (With_hash.map ~f:Mina_block.consensus_state - previous_transition ) + ~existing:previous_consensus_state_with_hashes ~candidate:consensus_state_with_hashes ) `Take || failwith @@ -911,9 +997,9 @@ let produce ~genesis_breadcrumb ~context:(module Context : CONTEXT) ~prover >>= Validation.validate_frontier_dependencies ~to_header:Mina_block.header ~context:(module Context) - ~root_block: + ~root_consensus_state: ( Transition_frontier.root frontier - |> Breadcrumb.block_with_hash ) + |> Breadcrumb.consensus_state_with_hashes ) ~is_block_in_frontier: (Fn.compose Option.is_some (Transition_frontier.find frontier) ) @@ -958,8 +1044,8 @@ let produce ~genesis_breadcrumb ~context:(module Context : CONTEXT) ~prover ~metadata: [ ( "blockchain_length" , Mina_numbers.Length.to_yojson - @@ Mina_block.blockchain_length - @@ Breadcrumb.block breadcrumb ) + @@ Mina_block.Header.blockchain_length + @@ Breadcrumb.header breadcrumb ) ; ("transactions", `List txs) ] ; [%str_log info] @@ -1420,18 +1506,15 @@ let run_precomputed ~context:(module Context : CONTEXT) ~verifier ~trust_system [%log trace] ~metadata:[ ("breadcrumb", Breadcrumb.to_yojson crumb) ] "Emitting precomputed block with parent $breadcrumb%!" ; - let previous_transition = Breadcrumb.block_with_hash crumb in - let previous_protocol_state = - Header.protocol_state - @@ Mina_block.header (With_hash.data previous_transition) + let previous_consensus_state_with_hashes = + Breadcrumb.consensus_state_with_hashes crumb in + let previous_protocol_state = Breadcrumb.protocol_state crumb in assert ( phys_equal (Consensus.Hooks.select ~context:(module Context) - ~existing: - (With_hash.map ~f:Mina_block.consensus_state - previous_transition ) + ~existing:previous_consensus_state_with_hashes ~candidate:consensus_state_with_hashes ) `Take || failwith @@ -1454,7 +1537,8 @@ let run_precomputed ~context:(module Context : CONTEXT) ~verifier ~trust_system let emit_breadcrumb () = let open Deferred.Result.Let_syntax in let previous_protocol_state_hash = - State_hash.With_state_hashes.state_hash previous_transition + State_hash.With_state_hashes.state_hash + previous_consensus_state_with_hashes in let header = Header.create ~protocol_state ~protocol_state_proof @@ -1486,9 +1570,9 @@ let run_precomputed ~context:(module Context : CONTEXT) ~verifier ~trust_system >>= Validation.validate_frontier_dependencies ~to_header:Mina_block.header ~context:(module Context) - ~root_block: + ~root_consensus_state: ( Transition_frontier.root frontier - |> Breadcrumb.block_with_hash ) + |> Breadcrumb.consensus_state_with_hashes ) ~is_block_in_frontier: (Fn.compose Option.is_some (Transition_frontier.find frontier) ) diff --git a/src/lib/bootstrap_controller/bootstrap_controller.ml b/src/lib/bootstrap_controller/bootstrap_controller.ml index bdb28d29fa34..6b283da36eee 100644 --- a/src/lib/bootstrap_controller/bootstrap_controller.ml +++ b/src/lib/bootstrap_controller/bootstrap_controller.ml @@ -279,6 +279,124 @@ let download_snarked_ledger ~trust_system ~preferred_peers ~transition_graph Sync_ledger.Root.destroy root_sync_ledger ; data ) +let handle_scan_state_and_aux ~logger ~expected_staged_ledger_hash + ~temp_snarked_ledger ~verifier ~constraint_constants ~signature_kind t + (scan_state_v2, expected_merkle_root, pending_coinbases, protocol_states) = + let%map staged_ledger_construction_result = + O1trace.thread "construct_root_staged_ledger" (fun () -> + let open Deferred.Or_error.Let_syntax in + let received_staged_ledger_hash = + Staged_ledger_hash.of_aux_ledger_and_coinbase_hash + (Staged_ledger.Scan_state.Stable.V2.hash scan_state_v2) + expected_merkle_root pending_coinbases + in + [%log debug] + ~metadata: + [ ( "expected_staged_ledger_hash" + , Staged_ledger_hash.to_yojson expected_staged_ledger_hash ) + ; ( "received_staged_ledger_hash" + , Staged_ledger_hash.to_yojson received_staged_ledger_hash ) + ] + "Comparing $expected_staged_ledger_hash to \ + $received_staged_ledger_hash" ; + let%bind new_root = + t.current_root + |> Mina_block.Validation.skip_frontier_dependencies_validation + `This_block_belongs_to_a_detached_subtree + |> Mina_block.Validation.validate_staged_ledger_hash + (`Staged_ledger_already_materialized received_staged_ledger_hash) + |> Result.map_error ~f:(fun _ -> + Error.of_string "received faulty scan state from peer" ) + |> Deferred.return + in + let protocol_states = + List.map protocol_states + ~f:(With_hash.of_data ~hash_data:Protocol_state.hashes) + in + let scan_state = + Staged_ledger.Scan_state.Stable.V2.to_latest scan_state_v2 + in + let%bind protocol_states = + Staged_ledger.Scan_state.check_required_protocol_states scan_state + ~protocol_states + |> Deferred.return + in + let protocol_states_map = + protocol_states + |> List.map ~f:(fun ps -> + (State_hash.With_state_hashes.state_hash ps, ps) ) + |> State_hash.Map.of_alist_exn + in + let get_state hash = + match Map.find protocol_states_map hash with + | None -> + let new_state_hash = + State_hash.With_state_hashes.state_hash (fst new_root) + in + [%log error] + ~metadata: + [ ("new_root", State_hash.to_yojson new_state_hash) + ; ("state_hash", State_hash.to_yojson hash) + ] + "Protocol state (for scan state transactions) for $state_hash \ + not found when bootstrapping to the new root $new_root" ; + Or_error.errorf + !"Protocol state (for scan state transactions) for \ + %{sexp:State_hash.t} not found when bootstrapping to the new \ + root %{sexp:State_hash.t}" + hash new_state_hash + | Some protocol_state -> + Ok (With_hash.data protocol_state) + in + (* step 3. Construct staged ledger from snarked ledger, scan state + and pending coinbases. *) + (* Construct the staged ledger before constructing the transition + * frontier in order to verify the scan state we received. + * TODO: reorganize the code to avoid doing this twice (#3480) *) + let open Deferred.Let_syntax in + let%map staged_ledger_construction_time, construction_result = + time_deferred + (let open Deferred.Let_syntax in + let temp_mask = Root_ledger.as_masked temp_snarked_ledger in + (* [of_scan_state_pending_coinbases_and_snarked_ledger] is called here + * to verify the scan state we received. We ignore the resulting staged + * ledger (from [temp_mask]). Later we call [Transition_frontier.load] + * which will indirectly invoke + * [of_scan_state_pending_coinbases_and_snarked_ledger_unchecked] + * repeating the same computation (except for proof verification + * which is skipped). Chain of calls: + * [Transition_frontier.load] -> .. -> [load_from_persistence_and_start] + * -> [load_full_frontier] -> [construct_staged_ledger_at_root] -> + * -> [of_scan_state_pending_coinbases_and_snarked_ledger_unchecked] + *) + let%map result = + Staged_ledger.of_scan_state_pending_coinbases_and_snarked_ledger + ~logger + ~snarked_local_state: + Mina_block.( + t.current_root |> Validation.block |> header + |> Header.protocol_state |> Protocol_state.blockchain_state + |> Blockchain_state.snarked_local_state) + ~verifier ~constraint_constants ~scan_state + ~snarked_ledger:temp_mask ~expected_merkle_root + ~pending_coinbases ~get_state ~signature_kind + in + ignore + ( Ledger.Maskable.unregister_mask_exn ~loc:__LOC__ temp_mask + : Ledger.unattached_mask ) ; + Result.map result + ~f: + (const + (scan_state, pending_coinbases, new_root, protocol_states) )) + in + Ok (staged_ledger_construction_time, construction_result) ) + in + match staged_ledger_construction_result with + | Error err -> + (None, Error err) + | Ok (staged_ledger_construction_time, result) -> + (Some staged_ledger_construction_time, result) + (** Run one bootstrap cycle *) let run_cycle ~context:(module Context : CONTEXT) ~trust_system ~verifier ~network ~consensus_local_state ~network_transition_pipe ~preferred_peers @@ -332,8 +450,7 @@ let run_cycle ~context:(module Context : CONTEXT) ~trust_system ~verifier (Float.of_int t.num_of_root_snarked_ledger_retargeted)) ; (* step 2. Download scan state and pending coinbases. *) let%bind ( staged_ledger_data_download_time - , staged_ledger_construction_time - , staged_ledger_aux_result ) = + , (staged_ledger_construction_time, staged_ledger_aux_result) ) = let%bind ( staged_ledger_data_download_time , staged_ledger_data_download_result ) = time_deferred @@ -342,127 +459,14 @@ let run_cycle ~context:(module Context : CONTEXT) ~trust_system ~verifier in match staged_ledger_data_download_result with | Error err -> - Deferred.return (staged_ledger_data_download_time, None, Error err) - | Ok - ( scan_state_uncached - , expected_merkle_root - , pending_coinbases - , protocol_states ) -> ( - let%map staged_ledger_construction_result = - O1trace.thread "construct_root_staged_ledger" (fun () -> - let open Deferred.Or_error.Let_syntax in - let received_staged_ledger_hash = - Staged_ledger_hash.of_aux_ledger_and_coinbase_hash - (Staged_ledger.Scan_state.Stable.Latest.hash - scan_state_uncached ) - expected_merkle_root pending_coinbases - in - [%log debug] - ~metadata: - [ ( "expected_staged_ledger_hash" - , Staged_ledger_hash.to_yojson expected_staged_ledger_hash - ) - ; ( "received_staged_ledger_hash" - , Staged_ledger_hash.to_yojson received_staged_ledger_hash - ) - ] - "Comparing $expected_staged_ledger_hash to \ - $received_staged_ledger_hash" ; - let%bind new_root = - t.current_root - |> Mina_block.Validation.skip_frontier_dependencies_validation - `This_block_belongs_to_a_detached_subtree - |> Mina_block.Validation.validate_staged_ledger_hash - (`Staged_ledger_already_materialized - received_staged_ledger_hash ) - |> Result.map_error ~f:(fun _ -> - Error.of_string "received faulty scan state from peer" ) - |> Deferred.return - in - let protocol_states = - List.map protocol_states - ~f:(With_hash.of_data ~hash_data:Protocol_state.hashes) - in - let scan_state = - Staged_ledger.Scan_state.write_all_proofs_to_disk - ~signature_kind ~proof_cache_db scan_state_uncached - in - let%bind protocol_states = - Staged_ledger.Scan_state.check_required_protocol_states - scan_state ~protocol_states - |> Deferred.return - in - let protocol_states_map = - protocol_states - |> List.map ~f:(fun ps -> - (State_hash.With_state_hashes.state_hash ps, ps) ) - |> State_hash.Map.of_alist_exn - in - let get_state hash = - match Map.find protocol_states_map hash with - | None -> - let new_state_hash = - State_hash.With_state_hashes.state_hash (fst new_root) - in - [%log error] - ~metadata: - [ ("new_root", State_hash.to_yojson new_state_hash) - ; ("state_hash", State_hash.to_yojson hash) - ] - "Protocol state (for scan state transactions) for \ - $state_hash not found when bootstrapping to the new \ - root $new_root" ; - Or_error.errorf - !"Protocol state (for scan state transactions) for \ - %{sexp:State_hash.t} not found when bootstrapping to \ - the new root %{sexp:State_hash.t}" - hash new_state_hash - | Some protocol_state -> - Ok (With_hash.data protocol_state) - in - (* step 3. Construct staged ledger from snarked ledger, scan state - and pending coinbases. *) - (* Construct the staged ledger before constructing the transition - * frontier in order to verify the scan state we received. - * TODO: reorganize the code to avoid doing this twice (#3480) *) - let open Deferred.Let_syntax in - let%map staged_ledger_construction_time, construction_result = - time_deferred - (let open Deferred.Let_syntax in - let temp_mask = Root_ledger.as_masked temp_snarked_ledger in - let%map result = - Staged_ledger - .of_scan_state_pending_coinbases_and_snarked_ledger ~logger - ~snarked_local_state: - Mina_block.( - t.current_root |> Validation.block |> header - |> Header.protocol_state - |> Protocol_state.blockchain_state - |> Blockchain_state.snarked_local_state) - ~verifier ~constraint_constants ~scan_state - ~snarked_ledger:temp_mask ~expected_merkle_root - ~pending_coinbases ~get_state ~signature_kind - in - ignore - ( Ledger.Maskable.unregister_mask_exn ~loc:__LOC__ temp_mask - : Ledger.unattached_mask ) ; - Result.map result - ~f: - (const - ( scan_state - , pending_coinbases - , new_root - , protocol_states ) )) - in - Ok (staged_ledger_construction_time, construction_result) ) + Deferred.return (staged_ledger_data_download_time, (None, Error err)) + | Ok result -> + let%map res = + handle_scan_state_and_aux ~logger ~expected_staged_ledger_hash + ~temp_snarked_ledger ~verifier ~constraint_constants ~signature_kind + t result in - match staged_ledger_construction_result with - | Error err -> - (staged_ledger_data_download_time, None, Error err) - | Ok (staged_ledger_construction_time, result) -> - ( staged_ledger_data_download_time - , Some staged_ledger_construction_time - , result ) ) + (staged_ledger_data_download_time, res) in Transition_frontier.Persistent_root.Instance.close temp_persistent_root_instance ; @@ -497,7 +501,8 @@ let run_cycle ~context:(module Context : CONTEXT) ~trust_system ~verifier } in `Repeat (this_cycle :: previous_cycles) - | Ok (scan_state, pending_coinbase, new_root, protocol_states) -> ( + | Ok (scan_state, pending_coinbase, new_root, protocol_states_for_scan_state) + -> ( let%bind () = Trust_system.( record t.trust_system logger sender @@ -559,11 +564,39 @@ let run_cycle ~context:(module Context : CONTEXT) ~trust_system ~verifier in Deferred.return (`Repeat (this_cycle :: previous_cycles)) | Ok () -> + let root_block_with_hash = + Mina_block.Validation.block_with_hash new_root + in + let new_root_state_hash = + State_hash.With_state_hashes.state_hash root_block_with_hash + in (* step 5. Close the old frontier and reload a new one from disk. *) - let new_root_data : Transition_frontier.Root_data.Limited.t = - Transition_frontier.Root_data.Limited.create - ~transition:(Mina_block.Validated.lift new_root) - ~scan_state ~pending_coinbase ~protocol_states + let new_root_data : Transition_frontier.Root_data.t = + let block = + With_hash.data root_block_with_hash + |> Mina_block.read_all_proofs_from_disk + in + (* We're initializing frontier, so there shouldn't be any data preserved at the + state hash's multi-key file storage, and root block won't be validated, so there won't + be an overwrite *) + let block_tag = + State_hash.File_storage.write_values_exn new_root_state_hash + ~f:(fun writer -> + State_hash.File_storage.write_value writer + (module Mina_block.Stable.Latest) + block ) + in + { block_tag + ; state_hash = new_root_state_hash + ; scan_state + ; pending_coinbase + ; protocol_states_for_scan_state + ; protocol_state = + Mina_block.Stable.Latest.header block + |> Mina_block.Header.protocol_state + ; delta_block_chain_proof = + Mina_block.Validated.(delta_block_chain_proof @@ lift new_root) + } in let%bind () = Transition_frontier.Persistent_frontier.reset_database_exn @@ -574,9 +607,7 @@ let run_cycle ~context:(module Context : CONTEXT) ~trust_system ~verifier in (* TODO: lazy load db in persistent root to avoid unnecessary opens like this *) Transition_frontier.Persistent_root.( - set_root_state_hash persistent_root - @@ Mina_block.Validated.state_hash - @@ Mina_block.Validated.lift new_root) ; + set_root_state_hash persistent_root new_root_state_hash) ; let%map new_frontier = let fail msg = failwith @@ -904,9 +935,7 @@ let%test_module "Bootstrap_controller tests" = let assert_transitions_increasingly_sorted ~root (incoming_transitions : Transition_cache.element list) = - let root = - Transition_frontier.Breadcrumb.block root |> Mina_block.header - in + let root = Transition_frontier.Breadcrumb.header root in ignore ( List.fold_result ~init:root incoming_transitions ~f:(fun max_acc incoming_transition -> @@ -979,11 +1008,10 @@ let%test_module "Bootstrap_controller tests" = Quickcheck.test ~trials:1 (Transition_frontier.For_tests.gen ~precomputed_values ~verifier ~max_length:max_frontier_length ~size:max_frontier_length () ) - ~f:(fun frontier -> + ~f:(fun (frontier, breadcrumbs) -> Thread_safe.block_on_async_exn @@ fun () -> - Deferred.List.iter (Transition_frontier.all_breadcrumbs frontier) - ~f:(fun breadcrumb -> + Deferred.List.iter breadcrumbs ~f:(fun breadcrumb -> let staged_ledger = Transition_frontier.Breadcrumb.staged_ledger breadcrumb in diff --git a/src/lib/fake_network/fake_network.ml b/src/lib/fake_network/fake_network.ml index 15399b3ee583..30187df0a3db 100644 --- a/src/lib/fake_network/fake_network.ml +++ b/src/lib/fake_network/fake_network.ml @@ -242,7 +242,7 @@ module Generator = struct precomputed_values.protocol_state_with_hashes.hash.state_hash ~epoch_ledger_backing_type:Stable_db in - let%map frontier = + let%map frontier, _ = Transition_frontier.For_tests.gen ~precomputed_values ~verifier ~consensus_local_state ~max_length:max_frontier_length ~size:0 () in diff --git a/src/lib/ledger_catchup/super_catchup.ml b/src/lib/ledger_catchup/super_catchup.ml index 56a160061424..ea7236ad2b15 100644 --- a/src/lib/ledger_catchup/super_catchup.ml +++ b/src/lib/ledger_catchup/super_catchup.ml @@ -381,10 +381,7 @@ let try_to_connect_hash_chain t hashes ~frontier let module T = struct type t = State_hash.t list [@@deriving to_yojson] end in - let all_hashes = - List.map (Transition_frontier.all_breadcrumbs frontier) ~f:(fun b -> - Frontier_base.Breadcrumb.state_hash b ) - in + let all_hashes = Transition_frontier.all_state_hashes frontier in [%log debug] ~metadata: [ ("n", `Int (List.length acc)) @@ -695,7 +692,7 @@ let create_node ~logger ~downloader t x = match x with | `Root root -> let blockchain_length = - Breadcrumb.block root |> Mina_block.blockchain_length + Breadcrumb.header root |> Mina_block.Header.blockchain_length in Internal_tracing.with_state_hash (Breadcrumb.state_hash root) @@ fun () -> diff --git a/src/lib/ledger_proof/dune b/src/lib/ledger_proof/dune index 571db19e7c23..e7d43923bdc5 100644 --- a/src/lib/ledger_proof/dune +++ b/src/lib/ledger_proof/dune @@ -21,4 +21,5 @@ ppx_hash ppx_compare ppx_version - ppx_deriving_yojson))) + ppx_deriving_yojson + ppx_let))) diff --git a/src/lib/ledger_proof/ledger_proof.ml b/src/lib/ledger_proof/ledger_proof.ml index 15bd6984190f..69aa0680e7e7 100644 --- a/src/lib/ledger_proof/ledger_proof.ml +++ b/src/lib/ledger_proof/ledger_proof.ml @@ -57,6 +57,26 @@ module Cached = struct { Proof_carrying_data.proof; data = { statement with sok_digest } } end +module Tagged = struct + type t = + ( Mina_state.Snarked_ledger_state.With_sok.t + , Proof.t State_hash.File_storage.tag ) + Proof_carrying_data.t + + let read_proof_from_disk ({ Proof_carrying_data.data = statement; proof } : t) + : Stable.Latest.t Or_error.t = + let%map.Or_error proof = + State_hash.File_storage.read (module Proof.Stable.Latest) proof + in + Transaction_snark.create ~statement ~proof + + let statement (t : t) = { t.data with sok_digest = () } + + let create ~(statement : Mina_state.Snarked_ledger_state.t) ~sok_digest ~proof + : t = + { Proof_carrying_data.proof; data = { statement with sok_digest } } +end + module For_tests = struct let mk_dummy_proof statement = create ~statement ~sok_digest:Sok_message.Digest.default diff --git a/src/lib/ledger_proof/ledger_proof_intf.ml b/src/lib/ledger_proof/ledger_proof_intf.ml index 008b4e210f2a..b4a744980720 100644 --- a/src/lib/ledger_proof/ledger_proof_intf.ml +++ b/src/lib/ledger_proof/ledger_proof_intf.ml @@ -64,4 +64,18 @@ module type S = sig -> proof:Proof_cache_tag.t -> t end + + module Tagged : sig + type t + + val read_proof_from_disk : t -> Stable.Latest.t Or_error.t + + val statement : t -> Mina_state.Snarked_ledger_state.t + + val create : + statement:Mina_state.Snarked_ledger_state.t + -> sok_digest:Sok_message.Digest.t + -> proof:Proof.t State_hash.File_storage.tag + -> t + end end diff --git a/src/lib/mina_base/dune b/src/lib/mina_base/dune index 90483c9a08a2..3eb39adb5eda 100644 --- a/src/lib/mina_base/dune +++ b/src/lib/mina_base/dune @@ -73,7 +73,8 @@ snark_bits error_json ppx_version.runtime - proof_cache_tag) + proof_cache_tag + multi_key_file_storage) (preprocess (pps ppx_annot diff --git a/src/lib/mina_base/state_hash.ml b/src/lib/mina_base/state_hash.ml index a3387f8461b1..99caef2c148c 100644 --- a/src/lib/mina_base/state_hash.ml +++ b/src/lib/mina_base/state_hash.ml @@ -60,3 +60,35 @@ module With_state_hashes = struct State_hashes.state_body_hash hash ~compute_hashes:(fun () -> compute_hashes data ) end + +module Tag = struct + [%%versioned + module Stable = struct + module V1 = struct + type 'a t = (Stable.V1.t, 'a) Multi_key_file_storage.Tag.Stable.V1.t + + let compare a b = Multi_key_file_storage.Tag.compare Stable.V1.compare a b + + let equal a b = Multi_key_file_storage.Tag.equal Stable.V1.equal a b + + let sexp_of_t a = + Multi_key_file_storage.Tag.sexp_of_t Stable.V1.sexp_of_t a + + let t_of_sexp sexp = + Multi_key_file_storage.Tag.t_of_sexp Stable.V1.t_of_sexp sexp + + let to_latest = Fn.id + end + end] + + [%%define_locally Stable.Latest.(compare, equal, sexp_of_t, t_of_sexp)] +end + +module File_storage_filename = struct + type filename_key = t + + (* TODO replace with hex string, pass directory parameter *) + let filename h = T.to_decimal_string h ^ ".dat" +end + +module File_storage = Multi_key_file_storage.Make_custom (File_storage_filename) diff --git a/src/lib/mina_block/block.mli b/src/lib/mina_block/block.mli index 36034f638977..abef2ba874d4 100644 --- a/src/lib/mina_block/block.mli +++ b/src/lib/mina_block/block.mli @@ -6,7 +6,11 @@ module Stable : sig [@@@no_toplevel_latest_type] module V2 : sig - type t [@@deriving sexp, equal] + type t = + { header : Header.Stable.V2.t + ; body : Staged_ledger_diff.Body.Stable.V1.t + } + [@@deriving sexp, equal] val header : t -> Header.Stable.V2.t @@ -16,6 +20,9 @@ module Stable : sig constraint_constants:Genesis_constants.Constraint_constants.t -> t -> Transaction.Stable.V2.t With_status.t list + + val create : + header:Header.Stable.V2.t -> body:Staged_ledger_diff.Body.Stable.V1.t -> t end end] diff --git a/src/lib/mina_block/mina_block.ml b/src/lib/mina_block/mina_block.ml index bc0a651b0b52..107fa4ebd84e 100644 --- a/src/lib/mina_block/mina_block.ml +++ b/src/lib/mina_block/mina_block.ml @@ -21,7 +21,8 @@ type almost_valid_header = Validation.almost_valid_with_header type fully_valid_block = Validation.fully_valid_with_block -let genesis ~precomputed_values : Block.with_hash * Validation.fully_valid = +let genesis ~precomputed_values : + Validated_block.t * Block.Stable.Latest.t State_hash.File_storage.tag = let genesis_state = Precomputed_values.genesis_state_with_hashes precomputed_values in @@ -38,6 +39,15 @@ let genesis ~precomputed_values : Block.with_hash * Validation.fully_valid = let block = Block.create ~header ~body in With_hash.map genesis_state ~f:(Fn.const block) in + let state_hash = State_hash.With_state_hashes.state_hash genesis_state in + let block_tag = + (* TODO write only if file is not existent, otherwise just create a tag + using file size as data length and position 0 *) + State_hash.File_storage.write_values_exn state_hash ~f:(fun writer -> + State_hash.File_storage.write_value writer + (module Block.Stable.Latest) + (With_hash.data block_with_hash |> Block.read_all_proofs_from_disk) ) + in let validation = ( (`Time_received, Mina_stdlib.Truth.True ()) , (`Genesis_state, Mina_stdlib.Truth.True ()) @@ -50,11 +60,13 @@ let genesis ~precomputed_values : Block.with_hash * Validation.fully_valid = , (`Staged_ledger_diff, Mina_stdlib.Truth.True ()) , (`Protocol_versions, Mina_stdlib.Truth.True ()) ) in - (block_with_hash, validation) + (Validated_block.lift (block_with_hash, validation), block_tag) let genesis_header ~precomputed_values = - let b, v = genesis ~precomputed_values in + let validated, _ = genesis ~precomputed_values in + let b, v = Validated_block.remember validated in (With_hash.map ~f:Block.header b, v) + |> Validation.reset_staged_ledger_diff_validation let handle_dropped_transition ?pipe_name ?valid_cb ~logger block = [%log warn] "Dropping state_hash $state_hash from $pipe transition pipe" diff --git a/src/lib/mina_block/precomputed_block.ml b/src/lib/mina_block/precomputed_block.ml index 93e24dddc05c..74d3bcd47d9e 100644 --- a/src/lib/mina_block/precomputed_block.ml +++ b/src/lib/mina_block/precomputed_block.ml @@ -100,7 +100,7 @@ end] let of_block ~logger ~(constraint_constants : Genesis_constants.Constraint_constants.t) - ~scheduled_time ~staged_ledger block_with_hash = + ~scheduled_time ~staged_ledger ~accounts_created block_with_hash = let ledger = Staged_ledger.ledger staged_ledger in let block = With_hash.data block_with_hash in let state_hash = @@ -145,13 +145,7 @@ let of_block ~logger ] ; let accounts_created = let account_creation_fee = constraint_constants.account_creation_fee in - let previous_block_state_hash = - Mina_state.Protocol_state.previous_state_hash - (Header.protocol_state header) - in - List.map - (Staged_ledger.latest_block_accounts_created staged_ledger - ~previous_block_state_hash ) ~f:(fun acct_id -> + List.map accounts_created ~f:(fun acct_id -> (acct_id, account_creation_fee) ) in let tokens_used = diff --git a/src/lib/mina_block/precomputed_block.mli b/src/lib/mina_block/precomputed_block.mli index abfb2af42da7..eca3d2860007 100644 --- a/src/lib/mina_block/precomputed_block.mli +++ b/src/lib/mina_block/precomputed_block.mli @@ -56,5 +56,6 @@ val of_block : -> constraint_constants:Genesis_constants.Constraint_constants.t -> scheduled_time:Block_time.Time.t -> staged_ledger:Staged_ledger.t + -> accounts_created:Account_id.t list -> (Block.t, Mina_base.State_hash.State_hashes.t) With_hash.t -> t diff --git a/src/lib/mina_block/validated_block.ml b/src/lib/mina_block/validated_block.ml index 28bd56ff08a5..009958c7e03d 100644 --- a/src/lib/mina_block/validated_block.ml +++ b/src/lib/mina_block/validated_block.ml @@ -16,6 +16,8 @@ module Stable = struct let hashes (t, _) = With_hash.hash t let header (t, _) = With_hash.data t |> Block.Stable.V2.header + + let block (t, _) = With_hash.data t end end] diff --git a/src/lib/mina_block/validated_block.mli b/src/lib/mina_block/validated_block.mli index 2e7665f606d2..326e490ab9f0 100644 --- a/src/lib/mina_block/validated_block.mli +++ b/src/lib/mina_block/validated_block.mli @@ -10,6 +10,8 @@ module Stable : sig val hashes : t -> State_hash.State_hashes.Stable.V1.t val header : t -> Header.Stable.V2.t + + val block : t -> Block.Stable.V2.t end end] diff --git a/src/lib/mina_block/validation.ml b/src/lib/mina_block/validation.ml index 24fde96ba037..72223359a48f 100644 --- a/src/lib/mina_block/validation.ml +++ b/src/lib/mina_block/validation.ml @@ -399,8 +399,8 @@ let skip_delta_block_chain_validation `This_block_was_not_received_via_gossip (Mina_stdlib.Nonempty_list.singleton previous_protocol_state_hash) ) let validate_frontier_dependencies ~to_header - ~context:(module Context : CONTEXT) ~root_block ~is_block_in_frontier - (t, validation) = + ~context:(module Context : CONTEXT) ~root_consensus_state + ~is_block_in_frontier (t, validation) = let module Context = struct include Context @@ -413,13 +413,6 @@ let validate_frontier_dependencies ~to_header let open Result.Let_syntax in let hash = State_hash.With_state_hashes.state_hash t in let protocol_state = Fn.compose Header.protocol_state to_header in - let root_consensus_state = - With_hash.map - ~f: - (Fn.compose Protocol_state.consensus_state - (Fn.compose Header.protocol_state Block.header) ) - root_block - in let parent_hash = Protocol_state.previous_state_hash (protocol_state @@ With_hash.data t) in @@ -486,46 +479,112 @@ let validate_staged_ledger_diff ?skip_staged_ledger_verification ~logger let consensus_state = Protocol_state.consensus_state protocol_state in let global_slot = Consensus_state.global_slot_since_genesis consensus_state in let body = Block.body block in + let state_hash = State_hash.With_state_hashes.state_hash t in let apply_start_time = Core.Time.now () in let body_ref_from_header = Blockchain_state.body_reference blockchain_state in + let body_stable = Staged_ledger_diff.Body.read_all_proofs_from_disk body in + let block_stable = Block.Stable.Latest.create ~header ~body:body_stable in let body_ref_computed = Staged_ledger_diff.Body.compute_reference ~tag:Mina_net2.Bitswap_tag.(to_enum Body) - @@ Staged_ledger_diff.Body.read_all_proofs_from_disk body + body_stable in let%bind.Deferred.Result () = if Blake2.equal body_ref_computed body_ref_from_header then Deferred.Result.return () else Deferred.Result.fail `Invalid_body_reference in - let%bind.Deferred.Result ( `Ledger_proof proof_opt - , `Staged_ledger transitioned_staged_ledger - , `Pending_coinbase_update _ ) = - Staged_ledger.apply ?skip_verification:skip_staged_ledger_verification - ~get_completed_work - ~constraint_constants: - precomputed_values.Precomputed_values.constraint_constants ~global_slot - ~logger ~verifier parent_staged_ledger - (Staged_ledger_diff.Body.staged_ledger_diff body) - ~current_state_view: - Mina_state.Protocol_state.(Body.view @@ body parent_protocol_state) - ~state_and_body_hash: - (let body_hash = - Protocol_state.(Body.hash @@ body parent_protocol_state) + let parent_protocol_state_body = Protocol_state.body parent_protocol_state in + [%log internal] "Apply_diff" ; + let state_and_body_hash = + let body_hash = Protocol_state.(Body.hash @@ body parent_protocol_state) in + ( (Protocol_state.hashes_with_body parent_protocol_state ~body_hash) + .state_hash + , body_hash ) + in + let constraint_constants = + precomputed_values.Precomputed_values.constraint_constants + in + let%bind.Deferred.Result ( transitioned_staged_ledger + , proof_opt + , accounts_created + , tagged_block + , scan_state_application_data ) = + Deferred.Result.map_error ~f:(fun e -> `Staged_ledger_application_failed e) + @@ let%bind.Deferred.Result ( `Ledger new_ledger + , `Accounts_created accounts_created + , `Stack_update stack_update + , `First_pass_ledger_end first_pass_ledger_end + , `Witnesses witnesses + , `Works works + , `Pending_coinbase_update (is_new_stack, _) ) = + Staged_ledger.apply_diff + ?skip_verification:skip_staged_ledger_verification + ~get_completed_work ~constraint_constants ~global_slot ~logger + ~verifier parent_staged_ledger + (Staged_ledger_diff.Body.staged_ledger_diff body) + ~parent_protocol_state_body ~state_and_body_hash + ~coinbase_receiver: + (Consensus_state.coinbase_receiver consensus_state) + ~supercharge_coinbase: + (Consensus_state.supercharge_coinbase consensus_state) + ~zkapp_cmd_limit_hardcap: + precomputed_values.Precomputed_values.genesis_constants + .zkapp_cmd_limit_hardcap + ~signature_kind:Mina_signature_kind.t_DEPRECATED + ?transaction_pool_proxy + in + let tagged_witnesses, tagged_works, tagged_block = + State_hash.File_storage.write_values_exn state_hash ~f:(fun writer -> + let witnesses' = + Staged_ledger.Scan_state.Transaction_with_witness.persist_many + witnesses writer + in + let works' = + Staged_ledger.Scan_state.Ledger_proof_with_sok_message + .persist_many works writer + in + let block' = + State_hash.File_storage.write_value writer + (module Block.Stable.Latest) + block_stable + in + (witnesses', works', block') ) + in + let scan_state_application_data = + { Staged_ledger.Scan_state.Application_data.is_new_stack + ; stack_update + ; first_pass_ledger_end + ; tagged_works + ; tagged_witnesses + } + in + let%map.Deferred.Result new_staged_ledger, res_opt = + let skip_verification = + [%equal: [ `All | `Proofs ] option] skip_staged_ledger_verification + (Some `All) in - ( (Protocol_state.hashes_with_body parent_protocol_state ~body_hash) - .state_hash - , body_hash ) ) - ~coinbase_receiver:(Consensus_state.coinbase_receiver consensus_state) - ~supercharge_coinbase: - (Consensus_state.supercharge_coinbase consensus_state) - ~zkapp_cmd_limit_hardcap: - precomputed_values.Precomputed_values.genesis_constants - .zkapp_cmd_limit_hardcap - ~signature_kind:Mina_signature_kind.t_DEPRECATED ?transaction_pool_proxy - |> Deferred.Result.map_error ~f:(fun e -> - `Staged_ledger_application_failed e ) + Staged_ledger.apply_to_scan_state ~logger ~skip_verification + ~log_prefix:"apply_diff" ~ledger:new_ledger + ~previous_pending_coinbase_collection: + (Staged_ledger.pending_coinbase_collection parent_staged_ledger) + ~previous_scan_state:(Staged_ledger.scan_state parent_staged_ledger) + ~constraint_constants scan_state_application_data + in + Or_error.iter_error + ( Staged_ledger.update_scan_state_metrics + @@ Staged_ledger.scan_state new_staged_ledger ) + ~f:(fun e -> + [%log error] + ~metadata:[ ("error", Error_json.error_to_yojson e) ] + !"Error updating metrics after applying scan state: $error" ) ; + ( new_staged_ledger + , res_opt + , accounts_created + , tagged_block + , scan_state_application_data ) in + [%log internal] "Diff_applied" ; let staged_ledger_hash_opt = match skip_staged_ledger_verification with | Some `All -> @@ -541,15 +600,15 @@ let validate_staged_ledger_diff ?skip_staged_ledger_verification ~logger [ ( "time_elapsed" , `Float Core.Time.(Span.to_ms @@ diff (now ()) apply_start_time) ) ] - "Staged_ledger.apply takes $time_elapsed" ; + "Staged ledger diff application (diffs + scan state) takes $time_elapsed" ; let snarked_ledger_hash = match proof_opt with | None -> (*There was no proof emitted, snarked ledger hash shouldn't change*) Protocol_state.snarked_ledger_hash parent_protocol_state - | Some (proof, _) -> + | Some proof -> Mina_state.Snarked_ledger_state.snarked_ledger_hash - @@ Ledger_proof.Cached.statement proof + @@ Ledger_proof.Tagged.statement proof in let staged_ledger_hash_check staged_ledger_hash = if @@ -580,7 +639,10 @@ let validate_staged_ledger_diff ?skip_staged_ledger_verification ~logger ( `Just_emitted_a_proof (Option.is_some proof_opt) , `Block_with_validation (t, Unsafe.set_valid_staged_ledger_diff validation) - , `Staged_ledger transitioned_staged_ledger ) + , `Staged_ledger transitioned_staged_ledger + , `Accounts_created accounts_created + , `Block_serialized tagged_block + , `Scan_state_application_data scan_state_application_data ) | Error errors -> Error (`Invalid_staged_ledger_diff errors) diff --git a/src/lib/mina_block/validation.mli b/src/lib/mina_block/validation.mli index 955f36f92b38..be890f6a5b01 100644 --- a/src/lib/mina_block/validation.mli +++ b/src/lib/mina_block/validation.mli @@ -283,7 +283,8 @@ val skip_delta_block_chain_validation : val validate_frontier_dependencies : to_header:('a -> Header.t) -> context:(module CONTEXT) - -> root_block:Block.with_hash + -> root_consensus_state: + Consensus.Data.Consensus_state.Value.t State_hash.With_state_hashes.t -> is_block_in_frontier:(Frozen_ledger_hash.t -> bool) -> ('a, State_hash.State_hashes.t) With_hash.t * ( 'b @@ -378,6 +379,10 @@ val validate_staged_ledger_diff : , 'f ) with_block ] * [ `Staged_ledger of Staged_ledger.t ] + * [ `Accounts_created of Account_id.t list ] + * [ `Block_serialized of Block.Stable.V2.t State_hash.File_storage.tag ] + * [ `Scan_state_application_data of + Staged_ledger.Scan_state.Application_data.t ] , [> `Staged_ledger_application_failed of Staged_ledger.Staged_ledger_error.t | `Invalid_body_reference diff --git a/src/lib/mina_graphql/mina_graphql.ml b/src/lib/mina_graphql/mina_graphql.ml index 0689aa7e2d98..bcd3089ffecd 100644 --- a/src/lib/mina_graphql/mina_graphql.ml +++ b/src/lib/mina_graphql/mina_graphql.ml @@ -2070,7 +2070,7 @@ module Queries = struct let transaction_pool = Mina_lib.transaction_pool mina in (* TODO: do not compute hashes to just get the status *) Transaction_inclusion_status.get_status ~frontier_broadcast_pipe - ~transaction_pool txn.data ) + ~transaction_pool txn.hash ) let current_snark_worker = field "currentSnarkWorker" ~typ:Types.snark_worker @@ -2210,8 +2210,8 @@ module Queries = struct |> Staged_ledger_diff.commands in let block_number = - bc |> Transition_frontier.Breadcrumb.block - |> Mina_block.header |> Mina_block.Header.blockchain_length + bc |> Transition_frontier.Breadcrumb.header + |> Mina_block.Header.blockchain_length in let transaction_seq = ref 0 in let action_list_list = @@ -2381,38 +2381,40 @@ module Queries = struct ~typ:Types.Input.UInt32.arg_typ ] ~typ:(non_null @@ list @@ non_null Types.pending_work_spec) - ~resolve:(fun { ctx = mina; _ } () start_idx end_idx -> + ~resolve:(fun { ctx = mina; _ } () _start_idx _end_idx -> let snark_job_state = Mina_lib.work_selector mina in let snark_pool = Mina_lib.snark_pool mina in - let all_work = Work_selector.all_work ~snark_pool snark_job_state in - let work_size = all_work |> List.length |> Unsigned.UInt32.of_int in - let less_than uint1 uint2 = Unsigned.UInt32.compare uint1 uint2 < 0 in - let to_bundle_specs = - List.map ~f:(fun (spec, fee_prover) -> - let spec = - One_or_two.map spec - ~f: - (Snark_work_lib.Work.Single.Spec.map - ~f_proof:Ledger_proof.Cached.read_proof_from_disk - ~f_witness:Transaction_witness.read_all_proofs_from_disk ) - in - { Types.Snark_work_bundle.spec; fee_prover } ) - in - match end_idx with - | None when less_than start_idx work_size -> - (* drop handles case when start_idx is greater than pending work and is O(start_idx)*) - let start = Unsigned.UInt32.to_int start_idx in - List.drop all_work start |> to_bundle_specs - | Some end_idx - when less_than start_idx end_idx && less_than start_idx work_size -> - let pos = Unsigned.UInt32.to_int start_idx in - let len = - Unsigned.UInt32.( - min (sub end_idx start_idx) (sub work_size start_idx) |> to_int) - in - List.sub ~pos ~len all_work |> to_bundle_specs - | _ -> - [] ) + let _all_work = Work_selector.all_work ~snark_pool snark_job_state in + (* TODO uncomment *) + (* let work_size = all_work |> List.length |> Unsigned.UInt32.of_int in + let less_than uint1 uint2 = Unsigned.UInt32.compare uint1 uint2 < 0 in + let to_bundle_specs = + List.map ~f:(fun (spec, fee_prover) -> + let spec = + One_or_two.map spec + ~f: + (Snark_work_lib.Work.Single.Spec.map + ~f_proof:Ledger_proof.Cached.read_proof_from_disk + ~f_witness:Transaction_witness.read_all_proofs_from_disk ) + in + { Types.Snark_work_bundle.spec; fee_prover } ) + in + match end_idx with + | None when less_than start_idx work_size -> + (* drop handles case when start_idx is greater than pending work and is O(start_idx)*) + let start = Unsigned.UInt32.to_int start_idx in + List.drop all_work start |> to_bundle_specs + | Some end_idx + when less_than start_idx end_idx && less_than start_idx work_size -> + let pos = Unsigned.UInt32.to_int start_idx in + let len = + Unsigned.UInt32.( + min (sub end_idx start_idx) (sub work_size start_idx) |> to_int) + in + List.sub ~pos ~len all_work |> to_bundle_specs + | _ -> + [] *) + [] ) module SnarkedLedgerMembership = struct let resolve_membership : diff --git a/src/lib/mina_intf/transition_frontier_components_intf.ml b/src/lib/mina_intf/transition_frontier_components_intf.ml index 262087bddcd4..5c93a6a3a753 100644 --- a/src/lib/mina_intf/transition_frontier_components_intf.ml +++ b/src/lib/mina_intf/transition_frontier_components_intf.ml @@ -181,8 +181,8 @@ module type Best_tip_prover_intf = sig val prove : context:(module CONTEXT) -> transition_frontier - -> ( Mina_block.t State_hash.With_state_hashes.t - , State_body_hash.t list * Mina_block.t ) + -> ( Frontier_base.Breadcrumb.t + , State_body_hash.t list * Frontier_base.Breadcrumb.t ) Proof_carrying_data.t option @@ -208,8 +208,8 @@ module type Consensus_best_tip_prover_intf = sig context:(module CONTEXT) -> frontier:transition_frontier -> Consensus.Data.Consensus_state.Value.t State_hash.With_state_hashes.t - -> ( Mina_block.t - , State_body_hash.t list * Mina_block.t ) + -> ( Frontier_base.Breadcrumb.t + , State_body_hash.t list * Frontier_base.Breadcrumb.t ) Proof_carrying_data.t option @@ -240,16 +240,13 @@ module type Sync_handler_intf = sig logger:Logger.t -> frontier:transition_frontier -> State_hash.t - -> ( Staged_ledger.Scan_state.t - * Ledger_hash.t - * Pending_coinbase.t - * Mina_state.Protocol_state.value list ) - Option.t + -> Frontier_base.Network_types.Staged_ledger_aux_and_pending_coinbases.t + option val get_transition_chain : frontier:transition_frontier -> State_hash.t list - -> Mina_block.t list option + -> Frontier_base.Network_types.Block.t list option val best_tip_path : frontier:transition_frontier -> State_hash.t list diff --git a/src/lib/mina_ledger/ledger.mli b/src/lib/mina_ledger/ledger.mli index f157adca8f71..384993660cfd 100644 --- a/src/lib/mina_ledger/ledger.mli +++ b/src/lib/mina_ledger/ledger.mli @@ -4,17 +4,23 @@ open Mina_base module Location : Merkle_ledger.Location_intf.S -module Mask_maps : - Merkle_mask.Mask_maps_intf.S - with type account := Account.t - and type account_id := Account_id.t - and type 'a account_id_map := 'a Account_id.Map.t - and type account_id_set := Account_id.Set.t - and type 'a address_map := 'a Location.Addr.Map.t - and type hash := Ledger_hash.t - and type location := Location.t - and type 'a location_map := 'a Location.Map.t - and type 'a token_id_map := 'a Token_id.Map.t +module Mask_maps : sig + include + Merkle_mask.Mask_maps_intf.S + with type account := Account.t + and type account_id := Account_id.t + and type 'a account_id_map := 'a Account_id.Map.t + and type account_id_set := Account_id.Set.t + and type 'a address_map := 'a Location.Addr.Map.t + and type hash := Ledger_hash.t + and type location := Location.t + and type 'a location_map := 'a Location.Map.t + and type 'a token_id_map := 'a Token_id.Map.t + + val to_stable : ledger_depth:int -> t -> Mask_maps.Stable.Latest.t + + val of_stable : ledger_depth:int -> Mask_maps.Stable.Latest.t -> t +end module Db : Merkle_ledger.Intf.Ledger.DATABASE diff --git a/src/lib/mina_lib/mina_lib.ml b/src/lib/mina_lib/mina_lib.ml index e09fc86d8398..43b193860f4f 100644 --- a/src/lib/mina_lib/mina_lib.ml +++ b/src/lib/mina_lib/mina_lib.ml @@ -763,8 +763,7 @@ let get_snarked_ledger_full t state_hash_opt = else return () ) in let snarked_ledger_hash = - Transition_frontier.Breadcrumb.block b - |> Mina_block.header |> Header.protocol_state + Transition_frontier.Breadcrumb.protocol_state b |> Mina_state.Protocol_state.blockchain_state |> Mina_state.Blockchain_state.snarked_ledger_hash in @@ -853,11 +852,6 @@ let most_recent_valid_transition t = t.components.most_recent_valid_block let block_produced_bvar t = t.components.block_produced_bvar -let staged_ledger_ledger_proof t = - let open Option.Let_syntax in - let%bind sl = best_staged_ledger_opt t in - Staged_ledger.current_ledger_proof sl - let validated_transitions t = t.pipes.validated_transitions_reader let initialization_finish_signal t = t.initialization_finish_signal @@ -896,14 +890,39 @@ let request_work t = let%bind.Option prover = Option.first_some (snark_worker_key t) (snark_coordinator_key t) in + let%bind.Option frontier = + Broadcast_pipe.Reader.peek t.components.transition_frontier + in + let get_state hash = + Transition_frontier.find_protocol_state frontier hash + |> function + | Some state -> + Or_error.return state + | None -> + Or_error.error_string "Protocol state not found" + in let fee = snark_work_fee t in let sok_message = Sok_message.create ~fee ~prover in [%log' debug t.config.logger] "Received work request" ~metadata:[ ("sok_message", Sok_message.to_yojson sok_message) ] ; let work_from_selector = lazy - (Work_selection_method.work ~snark_pool:(snark_pool t) ~fee - ~logger:t.config.logger t.work_selector ) + ( Work_selection_method.work ~snark_pool:(snark_pool t) ~fee + ~logger:t.config.logger t.work_selector + |> Option.map + ~f: + (Staged_ledger.Scan_state.Available_job.single_spec_one_or_two + ~get_state ) + |> function + | Some (Error e) -> + [%log' fatal t.config.logger] + "Error occured when converting available work: $error" + ~metadata:[ ("error", Error_json.error_to_yojson e) ] ; + None + | Some (Ok x) -> + Some x + | None -> + None ) in Work_partitioner.request_partitioned_work ~work_from_selector ~sok_message ~partitioner:t.work_partitioner @@ -913,7 +932,7 @@ let work_selection_method t = t.config.work_selection_method let add_complete_work ~logger ~fee ~prover ~(results : ( Snark_work_lib.Spec.Single.t - , Ledger_proof.Cached.t ) + , Ledger_proof.t ) Snark_work_lib.Result.Single.Poly.t One_or_two.t ) t = let update_metrics () = @@ -948,12 +967,8 @@ let add_complete_work ~logger ~fee ~prover Local_sink.push t.pipes.snark_local_sink ( Add_solved_work ( stmts - , Network_pool.Priced_proof. - { proof = - proofs - |> One_or_two.map ~f:Ledger_proof.Cached.read_proof_from_disk - ; fee = fee_with_prover - } ) + , Network_pool.Priced_proof.{ proof = proofs; fee = fee_with_prover } + ) , Result.iter_error ~f:(fun err -> (* Possible reasons of failure: receiving pipe's capacity exceeded, fee that isn't the lowest, failure in verification or application to the pool *) @@ -1649,8 +1664,8 @@ let fetch_completed_snarks (module Context : CONTEXT) snark_pool network | Some frontier -> let tip = Transition_frontier.best_tip frontier in let top_block = - Transition_frontier.Breadcrumb.validated_transition tip - |> Mina_block.Validated.header |> Mina_block.Header.blockchain_length + Transition_frontier.Breadcrumb.header tip + |> Mina_block.Header.blockchain_length in let delta = Unsigned.UInt32.(Infix.(received_block - top_block) |> to_int) @@ -2167,7 +2182,7 @@ let create ~commit_id ?wallets (config : Config.t) = Work_partitioner.create ~signature_kind ~reassignment_timeout: (Time.Span.of_ms (Float.of_int config.work_reassignment_wait)) - ~logger:config.logger ~proof_cache_db + ~logger:config.logger in let sinks = (block_sink, tx_remote_sink, snark_remote_sink) in let%bind net = @@ -2228,8 +2243,7 @@ let create ~commit_id ?wallets (config : Config.t) = Broadcast_pipe.create ( Mina_block.genesis_header ~precomputed_values:config.precomputed_values - |> Validation.reset_frontier_dependencies_validation - |> Validation.reset_staged_ledger_diff_validation ) + |> Validation.reset_frontier_dependencies_validation ) in let get_most_recent_valid_block () = Broadcast_pipe.Reader.peek most_recent_valid_block_reader @@ -2661,14 +2675,8 @@ let best_chain_block_by_height (t : t) height = let%bind transition_frontier = get_transition_frontier t in Transition_frontier.best_tip_path transition_frontier |> List.find ~f:(fun bc -> - let validated_transition = - Transition_frontier.Breadcrumb.validated_transition bc - in - let block_height = - Mina_block.( - blockchain_length @@ With_hash.data - @@ Validated.forget validated_transition) - in + let header = Transition_frontier.Breadcrumb.header bc in + let block_height = Mina_block.Header.blockchain_length header in Unsigned.UInt32.equal block_height height ) |> Result.of_option ~error: @@ -2875,11 +2883,10 @@ module Hardfork_config = struct hard fork genesis slot delta in the runtime config, if those have been set and the [breadcrum_spec] was [`Stop_slot]. Otherwise, it will be the global slot since genesis of the hard fork block. *) - let hard_fork_global_slot ~breadcrumb_spec ~block mina : + let hard_fork_global_slot ~breadcrumb_spec ~consensus_state mina : Mina_numbers.Global_slot_since_hard_fork.t = let block_global_slot = - Mina_block.consensus_state block - |> Consensus.Data.Consensus_state.curr_global_slot + Consensus.Data.Consensus_state.curr_global_slot consensus_state in let configured_slot = match breadcrumb_spec with @@ -2930,15 +2937,18 @@ module Hardfork_config = struct let prepare_inputs ~breadcrumb_spec mina = let open Deferred.Result.Let_syntax in let%bind breadcrumb = breadcrumb ~breadcrumb_spec mina in - let block = Transition_frontier.Breadcrumb.block breadcrumb in - let blockchain_length = Mina_block.blockchain_length block in + let consensus_state = + Transition_frontier.Breadcrumb.consensus_state breadcrumb + in + let blockchain_length = + Consensus.Data.Consensus_state.blockchain_length consensus_state + in let global_slot_since_hard_fork = - hard_fork_global_slot ~breadcrumb_spec ~block mina + hard_fork_global_slot ~breadcrumb_spec ~consensus_state mina in let global_slot_since_genesis = move_hard_fork_consensus_to_scheduled_genesis - ~hard_fork_consensus_data:(Mina_block.consensus_state block) - global_slot_since_hard_fork + ~hard_fork_consensus_data:consensus_state global_slot_since_hard_fork in let genesis_state_timestamp = genesis_timestamp_str diff --git a/src/lib/mina_lib/mina_lib.mli b/src/lib/mina_lib/mina_lib.mli index f07c96d6127b..ca599abf5acb 100644 --- a/src/lib/mina_lib/mina_lib.mli +++ b/src/lib/mina_lib/mina_lib.mli @@ -227,8 +227,6 @@ val stop_snark_worker : ?should_wait_kill:bool -> t -> unit Deferred.t val create : commit_id:string -> ?wallets:Secrets.Wallets.t -> Config.t -> t Deferred.t -val staged_ledger_ledger_proof : t -> Ledger_proof.Cached.t option - val transition_frontier : t -> Transition_frontier.t option Broadcast_pipe.Reader.t diff --git a/src/lib/mina_lib/mina_subscriptions.ml b/src/lib/mina_lib/mina_subscriptions.ml index ec710be10fb1..4f2978b6cdba 100644 --- a/src/lib/mina_lib/mina_subscriptions.ml +++ b/src/lib/mina_lib/mina_subscriptions.ml @@ -144,6 +144,9 @@ let create ~logger ~constraint_constants ~wallets ~new_blocks in Mina_block.Precomputed.of_block ~logger ~constraint_constants ~staged_ledger ~scheduled_time + ~accounts_created: + (Frontier_base.Breadcrumb.accounts_created + breadcrumb ) new_block in [%log debug] "Precomputed block generated in $time ms" diff --git a/src/lib/mina_lib/tests/tests.ml b/src/lib/mina_lib/tests/tests.ml index d843cd88b9c5..636f7bdfd53b 100644 --- a/src/lib/mina_lib/tests/tests.ml +++ b/src/lib/mina_lib/tests/tests.ml @@ -341,8 +341,7 @@ let%test_module "Epoch ledger sync tests" = let most_recent_valid_block_reader, most_recent_valid_block_writer = Broadcast_pipe.create ( Mina_block.genesis_header ~precomputed_values - |> Mina_block.Validation.reset_frontier_dependencies_validation - |> Mina_block.Validation.reset_staged_ledger_diff_validation ) + |> Mina_block.Validation.reset_frontier_dependencies_validation ) in let get_current_frontier () = Broadcast_pipe.Reader.peek frontier_broadcast_pipe_r diff --git a/src/lib/mina_lmdb_storage/block.ml b/src/lib/mina_lmdb_storage/block.ml index ce35ed427e92..60fd98b83316 100644 --- a/src/lib/mina_lmdb_storage/block.ml +++ b/src/lib/mina_lmdb_storage/block.ml @@ -149,6 +149,7 @@ let%test_module "Block storage tests" = f conf_dir helper ) let send_and_receive ~helper ~reader ~db breadcrumb = + (* TODO use block tag *) let body = Breadcrumb.block breadcrumb |> Mina_block.body |> Mina_block.Body.read_all_proofs_from_disk diff --git a/src/lib/mina_metrics/prometheus_metrics/dune b/src/lib/mina_metrics/prometheus_metrics/dune index 3cd172f3a46b..831cd1737ee4 100644 --- a/src/lib/mina_metrics/prometheus_metrics/dune +++ b/src/lib/mina_metrics/prometheus_metrics/dune @@ -22,7 +22,8 @@ ;; local libraries logger o1trace - mina_node_config) + mina_node_config + mina_stdlib_unix) (instrumentation (backend bisect_ppx)) (preprocess diff --git a/src/lib/mina_metrics/prometheus_metrics/mina_metrics.ml b/src/lib/mina_metrics/prometheus_metrics/mina_metrics.ml index 6c41bbb9f676..2fc04e7f1a38 100644 --- a/src/lib/mina_metrics/prometheus_metrics/mina_metrics.ml +++ b/src/lib/mina_metrics/prometheus_metrics/mina_metrics.ml @@ -250,31 +250,6 @@ end module Process_memory = struct let subsystem = "Process_memory" - (* Read RSS (Resident Set Size) from /proc//status *) - let read_rss_kb pid_opt = - try - let proc_file = - match pid_opt with - | None -> - "/proc/self/status" - | Some pid -> - Printf.sprintf "/proc/%d/status" (Pid.to_int pid) - in - let ic = In_channel.create proc_file in - let rec find_vmrss () = - let%bind.Option line = In_channel.input_line ic in - match - Option.try_with (fun () -> Scanf.sscanf line "VmRSS: %f" Fn.id) - with - | None -> - find_vmrss () - | Some kb -> - Some kb - in - let result = find_vmrss () in - In_channel.close ic ; result - with _ -> None - (* Functor to create RSS gauge for a specific process type *) module Make_rss_gauge (Config : sig val process_name : string @@ -300,7 +275,9 @@ module Process_memory = struct let update () = if Config.is_daemon || Option.is_some !process_pid then - Option.iter (read_rss_kb !process_pid) ~f:(Gauge.set gauge) + Option.iter + (Mina_stdlib_unix.File_system.read_rss_kb !process_pid) + ~f:(Gauge.set gauge) end module Daemon = Make_rss_gauge (struct diff --git a/src/lib/mina_networking/mina_networking.ml b/src/lib/mina_networking/mina_networking.ml index cfe26fbe5ce5..2724f870ed87 100644 --- a/src/lib/mina_networking/mina_networking.ml +++ b/src/lib/mina_networking/mina_networking.ml @@ -257,17 +257,31 @@ let make_rpc_request ?heartbeat_timeout ?timeout ~rpc ~label t peer input = | Failed_to_connect e -> Error (Error.tag e ~tag:"failed-to-connect") -let get_transition_chain_proof ?heartbeat_timeout ?timeout t = +let get_transition_chain_proof ?heartbeat_timeout ?timeout t peer = make_rpc_request ?heartbeat_timeout ?timeout - ~rpc:Rpcs.Get_transition_chain_proof ~label:"transition chain proof" t + ~rpc:Rpcs.Get_transition_chain_proof ~label:"transition chain proof" t peer -let get_transition_chain ?heartbeat_timeout ?timeout t = +let get_transition_chain ?heartbeat_timeout ?timeout t peer req = + let extract = + Fn.compose Or_error.all + @@ List.map ~f:Frontier_base.Network_types.Block.extract + in make_rpc_request ?heartbeat_timeout ?timeout ~rpc:Rpcs.Get_transition_chain - ~label:"chain of transitions" t + ~label:"chain of transitions" t peer req + >>=? Fn.compose Deferred.return extract + +let extract_block_proof { Proof_carrying_data.data; proof = chain, proof_block } + = + let%bind.Or_error proof_block = + Frontier_base.Network_types.Block.extract proof_block + in + let%map.Or_error data = Frontier_base.Network_types.Block.extract data in + { Proof_carrying_data.data; proof = (chain, proof_block) } let get_best_tip ?heartbeat_timeout ?timeout t peer = make_rpc_request ?heartbeat_timeout ?timeout ~rpc:Rpcs.Get_best_tip ~label:"best tip" t peer () + >>=? Fn.compose Deferred.return extract_block_proof let get_completed_checked_snarks t peer = make_rpc_request ~rpc:Rpcs.Get_completed_snarks @@ -367,9 +381,17 @@ let get_staged_ledger_aux_and_pending_coinbases_at_hash t inet_addr input = rpc_peer_then_random t inet_addr input ~rpc:Rpcs.Get_staged_ledger_aux_and_pending_coinbases_at_hash >>|? Envelope.Incoming.data + >>=? Fn.compose Deferred.return + Frontier_base.Network_types.Staged_ledger_aux_and_pending_coinbases + .extract let get_ancestry t inet_addr input = + let extract_block_proof' env = + let%map.Or_error data' = extract_block_proof (Envelope.Incoming.data env) in + Envelope.Incoming.map env ~f:(const data') + in rpc_peer_then_random t inet_addr input ~rpc:Rpcs.Get_ancestry + >>=? Fn.compose Deferred.return extract_block_proof' module Sl_downloader = struct module Key = struct diff --git a/src/lib/mina_networking/mina_networking.mli b/src/lib/mina_networking/mina_networking.mli index 29bb6c71058a..f4c462c3cc3d 100644 --- a/src/lib/mina_networking/mina_networking.mli +++ b/src/lib/mina_networking/mina_networking.mli @@ -53,10 +53,7 @@ module Rpcs : sig type query = State_hash.t type response = - ( Staged_ledger.Scan_state.Stable.Latest.t - * Ledger_hash.t - * Pending_coinbase.t - * Mina_state.Protocol_state.value list ) + Frontier_base.Network_types.Staged_ledger_aux_and_pending_coinbases.t option end @@ -72,7 +69,7 @@ module Rpcs : sig module Get_transition_chain : sig type query = State_hash.t list - type response = Mina_block.Stable.Latest.t list option + type response = Frontier_base.Network_types.Block.t list option end module Get_transition_chain_proof : sig @@ -92,8 +89,8 @@ module Rpcs : sig (Consensus.Data.Consensus_state.Value.t, State_hash.t) With_hash.t type response = - ( Mina_block.Stable.Latest.t - , State_body_hash.t list * Mina_block.Stable.Latest.t ) + ( Frontier_base.Network_types.Block.t + , State_body_hash.t list * Frontier_base.Network_types.Block.t ) Proof_carrying_data.t option end @@ -109,8 +106,8 @@ module Rpcs : sig type query = unit type response = - ( Mina_block.Stable.Latest.t - , State_body_hash.t list * Mina_block.Stable.Latest.t ) + ( Frontier_base.Network_types.Block.t + , State_body_hash.t list * Frontier_base.Network_types.Block.t ) Proof_carrying_data.t option end @@ -229,10 +226,10 @@ val get_staged_ledger_aux_and_pending_coinbases_at_hash : t -> Peer.Id.t -> State_hash.t - -> ( Staged_ledger.Scan_state.Stable.Latest.t - * Ledger_hash.t - * Pending_coinbase.t - * Mina_state.Protocol_state.value list ) + -> Frontier_base.Network_types.Staged_ledger_aux_and_pending_coinbases.Data + .Stable + .Latest + .t Deferred.Or_error.t val get_completed_checked_snarks : diff --git a/src/lib/mina_networking/rpcs.ml b/src/lib/mina_networking/rpcs.ml index a02d73534a7a..7ed3bb9957a4 100644 --- a/src/lib/mina_networking/rpcs.ml +++ b/src/lib/mina_networking/rpcs.ml @@ -47,24 +47,23 @@ end type ctx = (module CONTEXT) -let validate_protocol_versions ~logger ~trust_system ~rpc_name ~sender blocks = +let validate_protocol_versions ~logger ~trust_system ~rpc_name ~sender headers = let version_errors = let invalid_current_versions = - List.filter blocks ~f:(fun block -> - Mina_block.header block |> Mina_block.Header.current_protocol_version + List.filter headers ~f:(fun header -> + Mina_block.Header.current_protocol_version header |> Protocol_version.is_valid |> not ) in let invalid_next_versions = - List.filter blocks ~f:(fun block -> - Mina_block.header block - |> Mina_block.Header.proposed_protocol_version_opt + List.filter headers ~f:(fun header -> + Mina_block.Header.proposed_protocol_version_opt header |> Option.for_all ~f:Protocol_version.is_valid |> not ) in let current_version_mismatches = - List.filter blocks ~f:(fun block -> - Mina_block.header block |> Mina_block.Header.current_protocol_version + List.filter headers ~f:(fun header -> + Mina_block.Header.current_protocol_version header |> Protocol_version.compatible_with_daemon |> not ) in List.map invalid_current_versions ~f:(fun x -> @@ -77,8 +76,7 @@ let validate_protocol_versions ~logger ~trust_system ~rpc_name ~sender blocks = (* NB: these errors aren't always accurate... sometimes we are calling this when we were requested to serve an outdated block (requested vs sent) *) Deferred.List.iter version_errors ~how:`Parallel - ~f:(fun (version_error, block) -> - let header = Mina_block.header block in + ~f:(fun (version_error, header) -> let block_protocol_version = Mina_block.Header.current_protocol_version header in @@ -215,10 +213,7 @@ module Get_staged_ledger_aux_and_pending_coinbases_at_hash = struct type query = State_hash.t type response = - ( Staged_ledger.Scan_state.Stable.Latest.t - * Ledger_hash.t - * Pending_coinbase.t - * Mina_state.Protocol_state.value list ) + Frontier_base.Network_types.Staged_ledger_aux_and_pending_coinbases.t option end @@ -252,15 +247,15 @@ module Get_staged_ledger_aux_and_pending_coinbases_at_hash = struct include Master end) - module V2 = struct + module V3 = struct module T = struct type query = State_hash.Stable.V1.t type response = - ( Staged_ledger.Scan_state.Stable.V2.t - * Ledger_hash.Stable.V1.t - * Pending_coinbase.Stable.V2.t - * Mina_state.Protocol_state.Value.Stable.V2.t list ) + Frontier_base.Network_types.Staged_ledger_aux_and_pending_coinbases + .Stable + .V1 + .t option let query_of_caller_model = Fn.id @@ -300,22 +295,16 @@ module Get_staged_ledger_aux_and_pending_coinbases_at_hash = struct Sync_handler.get_staged_ledger_aux_and_pending_coinbases_at_hash ~logger ~frontier hash in - match result with - | None -> + let%map () = + if Option.is_none result then Trust_system.( record_envelope_sender trust_system logger (Envelope.Incoming.sender request) Actions. (Requested_unknown_item, Some (receipt_trust_action_message hash))) - >>| const None - | Some (scan_state, expected_merkle_root, pending_coinbases, protocol_states) - -> - return - (Some - ( Staged_ledger.Scan_state.read_all_proofs_from_disk scan_state - , expected_merkle_root - , pending_coinbases - , protocol_states ) ) + else Deferred.unit + in + result let rate_limit_budget = (4, `Per Time.Span.minute) @@ -506,7 +495,7 @@ module Get_transition_chain = struct module T = struct type query = State_hash.t list [@@deriving sexp, to_yojson] - type response = Mina_block.Stable.Latest.t list option + type response = Frontier_base.Network_types.Block.t list option end module Caller = T @@ -537,7 +526,7 @@ module Get_transition_chain = struct module T = struct type query = State_hash.Stable.V1.t list [@@deriving sexp] - type response = Mina_block.Stable.V2.t list option + type response = Frontier_base.Network_types.Block.Stable.V1.t list option let query_of_caller_model = Fn.id @@ -578,14 +567,7 @@ module Get_transition_chain = struct in match result with | Some blocks -> - let%map valid_versions = - validate_protocol_versions ~logger ~trust_system - ~rpc_name:"Get_transition_chain" - ~sender:(Envelope.Incoming.sender request) - blocks - in - Option.some_if valid_versions - @@ List.map ~f:Mina_block.read_all_proofs_from_disk blocks + Deferred.return @@ Option.some blocks | None -> let%map () = Trust_system.( @@ -897,8 +879,8 @@ module Get_ancestry = struct [@@deriving sexp, to_yojson] type response = - ( Mina_block.Stable.Latest.t - , State_body_hash.t list * Mina_block.Stable.Latest.t ) + ( Frontier_base.Network_types.Block.t + , State_body_hash.t list * Frontier_base.Network_types.Block.t ) Proof_carrying_data.t option end @@ -936,8 +918,9 @@ module Get_ancestry = struct [@@deriving sexp] type response = - ( Mina_block.Stable.V2.t - , State_body_hash.Stable.V1.t list * Mina_block.Stable.V2.t ) + ( Frontier_base.Network_types.Block.Stable.V1.t + , State_body_hash.Stable.V1.t list + * Frontier_base.Network_types.Block.Stable.V1.t ) Proof_carrying_data.Stable.V1.t option @@ -994,17 +977,14 @@ module Get_ancestry = struct in None | Some { proof = chain, base_block; data = block } -> - let%map valid_versions = - validate_protocol_versions ~logger ~trust_system - ~rpc_name:"Get_ancestry" - ~sender:(Envelope.Incoming.sender request) - [ base_block ] - in - Option.some_if valid_versions - { Proof_carrying_data.proof = - (chain, Mina_block.read_all_proofs_from_disk base_block) - ; data = Mina_block.read_all_proofs_from_disk block - } + let block = Frontier_base.Breadcrumb.block_tag block in + let base_block = Frontier_base.Breadcrumb.block_tag base_block in + Deferred.return + @@ ( Some + { Proof_carrying_data.proof = (chain, Tag base_block) + ; data = Tag block + } + : response ) let rate_limit_budget = (5, `Per Time.Span.minute) @@ -1106,8 +1086,8 @@ module Get_best_tip = struct type query = unit [@@deriving sexp, to_yojson] type response = - ( Mina_block.Stable.Latest.t - , State_body_hash.t list * Mina_block.Stable.Latest.t ) + ( Frontier_base.Network_types.Block.t + , State_body_hash.t list * Frontier_base.Network_types.Block.t ) Proof_carrying_data.t option end @@ -1141,8 +1121,9 @@ module Get_best_tip = struct type query = unit [@@deriving sexp] type response = - ( Mina_block.Stable.V2.t - , State_body_hash.Stable.V1.t list * Mina_block.Stable.V2.t ) + ( Frontier_base.Network_types.Block.Stable.V1.t + , State_body_hash.Stable.V1.t list + * Frontier_base.Network_types.Block.Stable.V1.t ) Proof_carrying_data.Stable.V1.t option @@ -1180,11 +1161,7 @@ module Get_best_tip = struct let result = let open Option.Let_syntax in let%bind frontier = get_transition_frontier () in - let%map proof_with_data = - Best_tip_prover.prove ~context:(module Context) frontier - in - (* strip hash from proof data *) - Proof_carrying_data.map proof_with_data ~f:With_hash.data + Best_tip_prover.prove ~context:(module Context) frontier in match result with | None -> @@ -1197,23 +1174,14 @@ module Get_best_tip = struct in None | Some { data = data_block; proof = chain, proof_block } -> - let%map data_valid_versions = - validate_protocol_versions ~logger ~trust_system - ~rpc_name:"Get_best_tip (data)" - ~sender:(Envelope.Incoming.sender request) - [ data_block ] - and proof_valid_versions = - validate_protocol_versions ~logger ~trust_system - ~rpc_name:"Get_best_tip (proof)" - ~sender:(Envelope.Incoming.sender request) - [ proof_block ] - in - Option.some_if - (data_valid_versions && proof_valid_versions) - { Proof_carrying_data.data = - Mina_block.read_all_proofs_from_disk data_block - ; proof = (chain, Mina_block.read_all_proofs_from_disk proof_block) - } + let data_block = Frontier_base.Breadcrumb.block_tag data_block in + let proof_block = Frontier_base.Breadcrumb.block_tag proof_block in + Deferred.return + @@ ( Some + { Proof_carrying_data.data = Tag data_block + ; proof = (chain, Tag proof_block) + } + : response ) let rate_limit_budget = (3, `Per Time.Span.minute) diff --git a/src/lib/mina_state/protocol_state.ml b/src/lib/mina_state/protocol_state.ml index f31888e6835a..acad307ddfd8 100644 --- a/src/lib/mina_state/protocol_state.ml +++ b/src/lib/mina_state/protocol_state.ml @@ -34,14 +34,15 @@ module Make_str (A : Wire_types.Concrete) = struct end] end + let compute_state_hash ~previous_state_hash ~state_body_hash = + Random_oracle.hash ~init:Hash_prefix.protocol_state + [| (previous_state_hash :> Field.t); (state_body_hash :> Field.t) |] + |> State_hash.of_hash + let hashes_abstract ~hash_body ({ previous_state_hash; body } : (State_hash.t, _) Poly.t) = let state_body_hash : State_body_hash.t = hash_body body in - let state_hash = - Random_oracle.hash ~init:Hash_prefix.protocol_state - [| (previous_state_hash :> Field.t); (state_body_hash :> Field.t) |] - |> State_hash.of_hash - in + let state_hash = compute_state_hash ~previous_state_hash ~state_body_hash in { State_hash.State_hashes.state_hash ; state_body_hash = Some state_body_hash } diff --git a/src/lib/mina_state/protocol_state_intf.ml b/src/lib/mina_state/protocol_state_intf.ml index e90bb31b587b..c490636188bd 100644 --- a/src/lib/mina_state/protocol_state_intf.ml +++ b/src/lib/mina_state/protocol_state_intf.ml @@ -14,6 +14,11 @@ module type Full = sig end] end + val compute_state_hash : + previous_state_hash:State_hash.t + -> state_body_hash:State_body_hash.t + -> State_hash.t + val hashes_abstract : hash_body:('body -> State_body_hash.t) -> (State_hash.t, 'body) Poly.t diff --git a/src/lib/mina_stdlib/nonempty_list.ml b/src/lib/mina_stdlib/nonempty_list.ml index 7ce5f8dc1fd6..0840b518c1a0 100644 --- a/src/lib/mina_stdlib/nonempty_list.ml +++ b/src/lib/mina_stdlib/nonempty_list.ml @@ -28,6 +28,15 @@ let tail_opt t = of_list_opt (tail t) let map (x, xs) ~f = (f x, List.map ~f xs) +let map_result (x, xs) ~f = + let%bind.Result x' = f x in + let%map.Result xs' = + List.fold_result xs ~init:[] ~f:(fun acc y -> + let%map.Result y' = f y in + y' :: acc ) + in + (x', List.rev xs') + let mapi (x, xs) ~f = (f 0 x, List.mapi ~f:(fun idx x -> f (idx + 1) x) xs) let rev (x, xs) = List.fold xs ~init:(singleton x) ~f:(Fn.flip cons) diff --git a/src/lib/mina_stdlib/nonempty_list.mli b/src/lib/mina_stdlib/nonempty_list.mli index 8375053b4902..b2d7fd290bdd 100644 --- a/src/lib/mina_stdlib/nonempty_list.mli +++ b/src/lib/mina_stdlib/nonempty_list.mli @@ -46,6 +46,10 @@ val tail_opt : 'a t -> 'a t option (** Apply a function to each element of the non empty list *) val map : 'a t -> f:('a -> 'b) -> 'b t +(** Apply a function to each element of the non empty list, returning [Error] if + * any of the function applications return [Error] *) +val map_result : 'a t -> f:('a -> ('b, 'e) Result.t) -> ('b t, 'e) Result.t + (** Apply a function to each element of the non empty list, along with its index starting from 0 *) val mapi : 'a t -> f:(int -> 'a -> 'b) -> 'b t diff --git a/src/lib/mina_stdlib_unix/file_system.ml b/src/lib/mina_stdlib_unix/file_system.ml index 25c0212b7c90..92af38498e26 100644 --- a/src/lib/mina_stdlib_unix/file_system.ml +++ b/src/lib/mina_stdlib_unix/file_system.ml @@ -83,3 +83,26 @@ let create_dir ?(clear_if_exists = false) dir = if clear_if_exists then clear_dir dir else return () | _ -> return (Core.Unix.mkdir_p dir) + +(* Read RSS (Resident Set Size) from /proc//status *) +let read_rss_kb pid_opt = + try + let proc_file = + match pid_opt with + | None -> + "/proc/self/status" + | Some pid -> + Printf.sprintf "/proc/%d/status" (Pid.to_int pid) + in + let ic = In_channel.create proc_file in + let rec find_vmrss () = + let%bind.Option line = In_channel.input_line ic in + match Option.try_with (fun () -> Scanf.sscanf line "VmRSS: %f" Fn.id) with + | None -> + find_vmrss () + | Some kb -> + Some kb + in + let result = find_vmrss () in + In_channel.close ic ; result + with _ -> None diff --git a/src/lib/multi-key-file-storage/dune b/src/lib/multi-key-file-storage/dune index d417ae066710..d1dcefcfca35 100644 --- a/src/lib/multi-key-file-storage/dune +++ b/src/lib/multi-key-file-storage/dune @@ -3,7 +3,7 @@ (public_name multi_key_file_storage) (libraries core_kernel bin_prot mina_stdlib) (preprocess - (pps ppx_jane ppx_version)) + (pps ppx_mina ppx_jane ppx_version)) (modules_without_implementation intf) (instrumentation (backend bisect_ppx))) diff --git a/src/lib/multi-key-file-storage/intf.mli b/src/lib/multi-key-file-storage/intf.mli index ba64524e896b..a04bb47f203c 100644 --- a/src/lib/multi-key-file-storage/intf.mli +++ b/src/lib/multi-key-file-storage/intf.mli @@ -45,7 +45,31 @@ module type S = sig ) ]} *) - val write_values_exn : f:(writer_t -> 'a) -> filename_key -> 'a + val write_values_exn : + ?buffer_size:int -> f:(writer_t -> 'a) -> filename_key -> 'a + + (** Append multiple keys to an existing database file. + + The [filename] parameter specifies the target file. + The file must exist; values will be appended to the end of the file. + + The [f] parameter is a callback that receives a [write_value] function which can be + called multiple times to append different key-value pairs to the database. + + Each call to [write_value bin_prot_module value] serializes [value] using the + provided bin_prot serializer and returns a [tag] that can be used to read the value later. + Tags will have offsets adjusted to account for the existing file content. + + Example (assuming the default implementation with [type filename_key = string]): + {[ + append_values_exn "my.db" ~f:(fun writer -> + let tag3 = write_value writer (module Int) 99 in + (* ... store tags for later use ... *) + ) + ]} +*) + val append_values_exn : + ?buffer_size:int -> f:(writer_t -> 'a) -> filename_key -> 'a (** Read a value from the database using a tag. @@ -65,4 +89,15 @@ module type S = sig (module Bin_prot.Binable.S with type t = 'a) -> 'a tag -> 'a Core_kernel.Or_error.t + + val read_many : + (module Bin_prot.Binable.S with type t = 'a) + -> 'a tag list + -> 'a list Core_kernel.Or_error.t + + (** Read the bytes stored at the given tag *) + val read_bytes : 'a tag -> Bytes.t Core_kernel.Or_error.t + + (** Get the size of the value stored at the given tag *) + val size : 'a tag -> int end diff --git a/src/lib/multi-key-file-storage/multi_key_file_storage.ml b/src/lib/multi-key-file-storage/multi_key_file_storage.ml index 1ac676f35c8f..194c8065ee66 100644 --- a/src/lib/multi-key-file-storage/multi_key_file_storage.ml +++ b/src/lib/multi-key-file-storage/multi_key_file_storage.ml @@ -1,7 +1,7 @@ open Core_kernel (** Buffer size for writing: 128 KB *) -let buffer_size = 131072 +let default_buffer_size = 131072 module type S = Intf.S @@ -11,8 +11,33 @@ module Tag = struct module V1 = struct type ('filename_key, 'a) t = { filename_key : 'filename_key; offset : int64; size : int } + + let compare filename_key_compare t1 t2 = + let c = filename_key_compare t1.filename_key t2.filename_key in + if c <> 0 then c + else + let c' = Int64.compare t1.offset t2.offset in + if c' <> 0 then c' else Int.compare t1.size t2.size + + let equal filename_key_equal t1 t2 = + let c = filename_key_equal t1.filename_key t2.filename_key in + if c then + if Int64.equal t1.offset t2.offset then Int.equal t1.size t2.size + else false + else false + + let sexp_of_t sexp_of_filename_key t = + [%sexp_of: Sexp.t * int64 * int] + (sexp_of_filename_key t.filename_key, t.offset, t.size) + + let t_of_sexp filename_key_of_sexp sexp = + [%of_sexp: Sexp.t * int64 * int] sexp + |> fun (filename_key, offset, size) -> + { filename_key = filename_key_of_sexp filename_key; offset; size } end end] + + [%%define_locally Stable.Latest.(compare, equal, t_of_sexp, sexp_of_t)] end module Make_custom (Inputs : sig @@ -37,7 +62,9 @@ end) : Out_channel.output_string oc (Buffer.contents buffer) (* Write key function provided to the callback *) - let make_writer ~oc ~filename_key ~buffer : writer_t = + let make_writer ~buffer_size ~init_offset ~oc ~filename_key ~buffer : writer_t + = + let offset = ref init_offset in { f = (fun (type a) (module B : Bin_prot.Binable.S with type t = a) (value : a) -> @@ -52,12 +79,11 @@ end) : (* Create tag before writing *) let tag = - { Tag.filename_key - ; offset = Int64.of_int @@ Buffer.length buffer - ; size = serialized_size - } + { Tag.filename_key; offset = !offset; size = serialized_size } in + (offset := Int64.(!offset + of_int serialized_size)) ; + (* Add to buffer *) Buffer.add_string buffer data ; @@ -69,11 +95,13 @@ end) : } (** Write multiple keys to a database file with buffered I/O *) - let write_values_exn ~f filename_key = + let write_values_exn ?(buffer_size = default_buffer_size) ~f filename_key = let do_writing oc = (* Buffer for accumulating writes *) let buffer = Buffer.create buffer_size in - let writer = make_writer ~oc ~filename_key ~buffer in + let writer = + make_writer ~buffer_size ~init_offset:0L ~oc ~filename_key ~buffer + in (* Call user function with write_value *) let result = f writer in @@ -87,11 +115,37 @@ end) : (Inputs.filename filename_key) ~binary:true ~f:do_writing - (** Read a value from the database using a tag *) - let read : - type a. - (module Bin_prot.Binable.S with type t = a) -> a tag -> a Or_error.t = - fun (module B : Bin_prot.Binable.S with type t = a) tag -> + (** Append multiple keys to an existing database file with buffered I/O *) + let append_values_exn ?(buffer_size = default_buffer_size) ~f filename_key = + let filename = Inputs.filename filename_key in + let do_appending oc = + (* Get current file size to calculate offset for new writes *) + let init_offset = Out_channel.length oc in + + (* Buffer for accumulating writes *) + let buffer = Buffer.create buffer_size in + + (* Create a modified writer that accounts for the initial file offset *) + let writer = + make_writer ~buffer_size ~init_offset ~oc ~filename_key ~buffer + in + + (* Call user function with write_value *) + let result = f writer in + + (* Flush any remaining data *) + if Buffer.length buffer > 0 then flush_buffer oc buffer ; + + result + in + Out_channel.with_file filename ~binary:true ~append:true ~f:do_appending + + (** Get the size of the value stored at the given tag *) + let size (tag : _ tag) = tag.size + + (** Read the bytes stored at the given tag *) + let read_bytes : _ tag -> Bytes.t Or_error.t = + fun tag -> let do_reading ic = (* Seek to the specified offset *) In_channel.seek ic tag.offset ; @@ -99,7 +153,22 @@ end) : (* Read the exact number of bytes *) let buffer = Bytes.create tag.size in In_channel.really_input_exn ic ~buf:buffer ~pos:0 ~len:tag.size ; + buffer + in + Or_error.tag ~tag:(Inputs.filename tag.filename_key) + @@ Or_error.try_with ~backtrace:true + @@ fun () -> + In_channel.with_file + (Inputs.filename tag.filename_key) + ~binary:true ~f:do_reading + (** Read a value from the database using a tag *) + let read : + type a. + (module Bin_prot.Binable.S with type t = a) -> a tag -> a Or_error.t = + fun (module B : Bin_prot.Binable.S with type t = a) tag -> + let%bind.Or_error buffer = read_bytes tag in + let do_parsing () = (* Deserialize using bin_prot *) let bigstring = Bigstring.of_bytes buffer in let pos_ref = ref 0 in @@ -114,11 +183,10 @@ end) : else Ok value in Or_error.tag ~tag:(Inputs.filename tag.filename_key) - @@ Or_error.try_with_join ~backtrace:true - @@ fun () -> - In_channel.with_file - (Inputs.filename tag.filename_key) - ~binary:true ~f:do_reading + @@ Or_error.try_with_join ~backtrace:true do_parsing + + let read_many (type a) (module B : Bin_prot.Binable.S with type t = a) = + Mina_stdlib.Result.List.map ~f:(read (module B)) end include Make_custom (struct diff --git a/src/lib/multi-key-file-storage/multi_key_file_storage.mli b/src/lib/multi-key-file-storage/multi_key_file_storage.mli index 7ded5b8413e3..606ee6ce3c1e 100644 --- a/src/lib/multi-key-file-storage/multi_key_file_storage.mli +++ b/src/lib/multi-key-file-storage/multi_key_file_storage.mli @@ -1,12 +1,47 @@ (** Multi-key file storage - stores multiple keys with heterogeneous types in a single file *) +open Core_kernel module Tag : sig [%%versioned: module Stable : sig module V1 : sig type ('filename_key, 'a) t + + val compare : + ('filename_key -> 'filename_key -> int) + -> ('filename_key, 'a) t + -> ('filename_key, 'a) t + -> int + + val equal : + ('filename_key -> 'filename_key -> bool) + -> ('filename_key, 'a) t + -> ('filename_key, 'a) t + -> bool + + val sexp_of_t : + ('filename_key -> Sexp.t) -> ('filename_key, 'a) t -> Sexp.t + + val t_of_sexp : + (Sexp.t -> 'filename_key) -> Sexp.t -> ('filename_key, 'a) t end end] + + val compare : + ('filename_key -> 'filename_key -> int) + -> ('filename_key, 'a) t + -> ('filename_key, 'a) t + -> int + + val equal : + ('filename_key -> 'filename_key -> bool) + -> ('filename_key, 'a) t + -> ('filename_key, 'a) t + -> bool + + val sexp_of_t : ('filename_key -> Sexp.t) -> ('filename_key, 'a) t -> Sexp.t + + val t_of_sexp : (Sexp.t -> 'filename_key) -> Sexp.t -> ('filename_key, 'a) t end module type S = Intf.S @@ -17,4 +52,7 @@ module Make_custom (Inputs : sig type filename_key val filename : filename_key -> string -end) : S with type filename_key = Inputs.filename_key +end) : + S + with type 'a tag = (Inputs.filename_key, 'a) Tag.t + and type filename_key = Inputs.filename_key diff --git a/src/lib/multi-key-file-storage/tests/test_multi_key_file_storage.ml b/src/lib/multi-key-file-storage/tests/test_multi_key_file_storage.ml index 4a2cb6fd8db8..6adecf394d3a 100644 --- a/src/lib/multi-key-file-storage/tests/test_multi_key_file_storage.ml +++ b/src/lib/multi-key-file-storage/tests/test_multi_key_file_storage.ml @@ -12,6 +12,7 @@ let simplest_test (type fkey) (module M : S with type filename_key = fkey) (filename_key : fkey) = let int_value = 42 in let string_value = "hello world" in + let appended_int_value = 99 in let int_tag, string_tag = M.write_values_exn @@ -22,12 +23,24 @@ let simplest_test (type fkey) (module M : S with type filename_key = fkey) filename_key in + (* Append a third value to the file *) + let appended_int_tag = + M.append_values_exn + ~f:(fun writer -> M.write_value writer (module Int) appended_int_value) + filename_key + in + + (* Read all three values and verify *) let int_result = M.read (module Int) int_tag |> Or_error.ok_exn in let string_result = M.read (module String) string_tag |> Or_error.ok_exn in + let appended_int_result = + M.read (module Int) appended_int_tag |> Or_error.ok_exn + in - Alcotest.(check int) "Single int value round-trip" int_value int_result ; - Alcotest.(check string) - "Single string value round-trip" string_value string_result + Alcotest.(check int) "First int value round-trip" int_value int_result ; + Alcotest.(check string) "String value round-trip" string_value string_result ; + Alcotest.(check int) + "Appended int value round-trip" appended_int_value appended_int_result (* Test basic write and read with a single value *) let test_single_values () = @@ -105,16 +118,13 @@ module Write_and_test_later = struct Q.map ~f:bool Q.bool end -let triple gen = +let expanded_read_ops_group ?length () = let module Q = Base_quickcheck.Generator in - let%bind.Q gen1 = gen in - let%bind.Q gen2 = gen in - let%map.Q gen3 = gen in - (gen1, gen2, gen3) - -let expanded_read_ops_group = - let module Q = Base_quickcheck.Generator in - let%bind.Q group = Q.list_non_empty @@ Write_and_test_later.gen in + let list_gen = + Option.value_map length ~default:Q.list_non_empty ~f:(fun length -> + Q.list_with_length ~length ) + in + let%bind.Q group = list_gen Write_and_test_later.gen in let sz = List.length group in let%map.Q expansions = Q.list_with_length ~length:sz @@ Q.int_inclusive 1 4 in let expansions_total = List.sum (module Int) ~f:ident expansions in @@ -125,44 +135,87 @@ let expanded_read_ops_group = ~f:(fun (n, op) -> List.init n ~f:(const op)) (List.zip_exn expansions read_ops) ) -let three_op_groups = +module Writer_consumer = struct + type t = + { consumers : + (writer_t -> Write_and_test_later.read_and_check_t list) + Mina_stdlib.Nonempty_list.t + ; actions_accumulator : Write_and_test_later.read_and_check_t list list + ; permutation : int list + } + + type t_ = (t, Write_and_test_later.read_and_check_t list) Either.t + + let consume writer + { consumers = prev_consumers + ; actions_accumulator = prev_accum + ; permutation + } = + let func, crest = Mina_stdlib.Nonempty_list.uncons prev_consumers in + let actions_accumulator = func writer :: prev_accum in + match Mina_stdlib.Nonempty_list.of_list_opt crest with + | Some crest -> + Either.First { consumers = crest; actions_accumulator; permutation } + | None -> + let actions = List.concat actions_accumulator |> Array.of_list in + assert (Array.length actions = List.length permutation) ; + Either.Second (List.map permutation ~f:(fun i -> actions.(i))) + + let consume_exn writer : t_ -> t_ = function + | First data -> + consume writer data + | Second _ -> + failwith "consumed all" + + let extract_result_exn : t_ -> Write_and_test_later.read_and_check_t list = + function + | Second res -> + res + | First _ -> + failwith "unconsumed" +end + +let op_groups ?length n = let module Q = Base_quickcheck.Generator in - let%bind.Q (sz1, group1), (sz2, group2), (sz3, group3) = - triple expanded_read_ops_group + let%bind.Q size_and_group_lst = + Q.list_with_length ~length:n @@ expanded_read_ops_group ?length () in - let%map.Q permutation = - Q.list_permutations (List.init (sz1 + sz2 + sz3) ~f:ident) + let total_size = List.sum (module Int) ~f:fst size_and_group_lst in + let%map.Q permutation = Q.list_permutations (List.init total_size ~f:ident) in + let consumers = + List.map ~f:snd size_and_group_lst + |> Mina_stdlib.Nonempty_list.of_list_opt + |> Option.value_exn ~message:"unexpected empty list from quickcheck's gen" in - fun (writer1, writer2, writer3) -> - let read_ops = - group1 writer1 @ group2 writer2 @ group3 writer3 |> Array.of_list - in - List.map permutation ~f:(fun i -> read_ops.(i)) + { Writer_consumer.consumers; permutation; actions_accumulator = [] } (** Property test: Write three files with different write operations. Read the values back (some repeatedly) in a random order. Check that the values retrieved are correct. *) -let test_property () = - let file1 = temp_filename "file1" in - let file2 = temp_filename "file2" in - let file3 = temp_filename "file3" in +let test_property ?buffer_size ?length () = + let files = List.init 3 ~f:(fun i -> temp_filename @@ sprintf "file%d" i) in + let consume_files ~f init = + List.fold files ~init ~f:(fun unconsumed file -> + f ~f:(fun writer -> Writer_consumer.consume_exn writer unconsumed) file ) + in let res = Or_error.try_with @@ fun () -> - Quickcheck.test three_op_groups ~f:(fun write_three_groups -> + Quickcheck.test + ?trials:(Option.map ~f:(const 1) length) + (op_groups ?length @@ (List.length files * 3)) + ~f:(fun groups -> let read_ops = - write_values_exn file1 ~f:(fun writer1 -> - write_values_exn file2 ~f:(fun writer2 -> - write_values_exn file3 ~f:(fun writer3 -> - write_three_groups (writer1, writer2, writer3) ) ) ) + consume_files (Either.First groups) ~f:(write_values_exn ?buffer_size) + |> consume_files ~f:(append_values_exn ?buffer_size) + |> consume_files ~f:(append_values_exn ?buffer_size) + |> Writer_consumer.extract_result_exn in List.iter read_ops ~f:(fun { Write_and_test_later.read_and_check } -> read_and_check () ) ) in - cleanup_file file1 ; - cleanup_file file2 ; - cleanup_file file3 ; + List.iter ~f:cleanup_file files ; Or_error.ok_exn res (* Main test suite *) @@ -173,6 +226,10 @@ let () = ; Alcotest.test_case "Multiple same type" `Quick test_multiple_same_type ; Alcotest.test_case "Custom filename key" `Quick test_custom_filename_key - ; Alcotest.test_case "Property test" `Quick test_property + ; Alcotest.test_case "Property test" `Quick + (test_property ?buffer_size:None ?length:None) + ; Alcotest.test_case + "Property test (enough values to exceeed the buffer)" `Quick + (test_property ~buffer_size:128 ~length:128) ] ) ] diff --git a/src/lib/network_pool/transaction_pool.ml b/src/lib/network_pool/transaction_pool.ml index 1d9c1926da47..60185fcaf8a5 100644 --- a/src/lib/network_pool/transaction_pool.ml +++ b/src/lib/network_pool/transaction_pool.ml @@ -25,8 +25,10 @@ module type Transition_frontier_intf = sig end type best_tip_diff = - { new_commands : User_command.Valid.t With_status.t list - ; removed_commands : User_command.Valid.t With_status.t list + { new_commands : + Transaction_hash.User_command_with_valid_signature.t With_status.t list + ; removed_commands : + Transaction_hash.User_command_with_valid_signature.t With_status.t list ; reorg_best_tip : bool } @@ -531,8 +533,13 @@ struct (diff_error_of_indexed_pool_error e) , indexed_pool_error_metadata e ) - let handle_transition_frontier_diff_inner ~new_commands ~removed_commands - ~best_tip_ledger t = + let handle_transition_frontier_diff_inner + ~(new_commands : + Transaction_hash.User_command_with_valid_signature.t With_status.t + list ) + ~(removed_commands : + Transaction_hash.User_command_with_valid_signature.t With_status.t + list ) ~best_tip_ledger t = (* This runs whenever the best tip changes. The simple case is when the new best tip is an extension of the old one. There, we just remove any user commands that were included in it from the transaction pool. @@ -554,10 +561,13 @@ struct let vk_table_dec t ~account_id ~(vk : Verification_key_wire.t) = Vk_refcount_table.dec t ~account_id ~vk_hash:vk.hash in - let vk_table_lift = Vk_refcount_table.lift t.verification_key_table in let vk_table_lift_hashed = Vk_refcount_table.lift_hashed t.verification_key_table in + let vk_table_lift_hashed_with_status f tx = + Vk_refcount_table.lift_hashed t.verification_key_table f + (With_status.data tx) + in let global_slot = Indexed_pool.global_slot_since_genesis t.pool in t.best_tip_ledger <- Some best_tip_ledger ; let pool_max_size = t.config.pool_max_size in @@ -573,30 +583,24 @@ struct ] @ metadata ) in - List.iter new_commands ~f:(vk_table_lift vk_table_inc) ; - List.iter removed_commands ~f:(vk_table_lift vk_table_dec) ; - let compact_json = - Fn.compose User_command.fee_payer_summary_json User_command.forget_check + List.iter new_commands ~f:(vk_table_lift_hashed_with_status vk_table_inc) ; + List.iter removed_commands + ~f:(vk_table_lift_hashed_with_status vk_table_dec) ; + let hash_json = + With_status.to_yojson + (Fn.compose Transaction_hash.to_yojson + Transaction_hash.User_command_with_valid_signature.transaction_hash ) in [%log' trace t.logger] ~metadata: - [ ( "removed" - , `List - (List.map removed_commands - ~f:(With_status.to_yojson compact_json) ) ) - ; ( "added" - , `List - (List.map new_commands ~f:(With_status.to_yojson compact_json)) - ) + [ ("removed", `List (List.map removed_commands ~f:hash_json)) + ; ("added", `List (List.map new_commands ~f:hash_json)) ] "Diff: removed: $removed added: $added from best tip" ; let pool', dropped_backtrack = List.fold (List.rev removed_commands) ~init:(t.pool, Sequence.empty) - ~f:(fun (pool, dropped_so_far) unhashed_cmd -> - let cmd = - Transaction_hash.User_command_with_valid_signature.create - unhashed_cmd.data - in + ~f:(fun (pool, dropped_so_far) cmd_with_status -> + let cmd = With_status.data cmd_with_status in ( match Locally_generated.find_and_remove t.locally_generated_committed cmd @@ -606,11 +610,7 @@ struct | Some time_added -> [%log' info t.logger] "Locally generated command $cmd committed in a block!" - ~metadata: - [ ( "cmd" - , With_status.to_yojson User_command.Valid.to_yojson - unhashed_cmd ) - ] ; + ~metadata:[ ("cmd", hash_json cmd_with_status) ] ; Locally_generated.add_exn t.locally_generated_uncommitted ~key:cmd ~data:time_added ) ; let pool', dropped_seq = @@ -649,7 +649,8 @@ struct List.fold (new_commands @ removed_commands) ~init:Account_id.Set.empty ~f:(fun set cmd -> let set' = - With_status.data cmd |> User_command.forget_check + With_status.data cmd + |> Transaction_hash.User_command_with_valid_signature.command |> User_command.accounts_referenced |> Account_id.Set.of_list in Set.union set set' ) @@ -678,7 +679,6 @@ struct ~f:(fun set cmd -> let cmd_hash = With_status.data cmd - |> Transaction_hash.User_command_with_valid_signature.create |> Transaction_hash.User_command_with_valid_signature .transaction_hash in @@ -1641,8 +1641,16 @@ include include Transition_frontier type best_tip_diff = Extensions.Best_tip_diff.view = - { new_commands : User_command.Valid.t With_status.t list - ; removed_commands : User_command.Valid.t With_status.t list + { new_commands : + Mina_transaction.Transaction_hash.User_command_with_valid_signature + .t + With_status.t + list + ; removed_commands : + Mina_transaction.Transaction_hash.User_command_with_valid_signature + .t + With_status.t + list ; reorg_best_tip : bool } @@ -1732,8 +1740,12 @@ let%test_module _ = end type best_tip_diff = - { new_commands : User_command.Valid.t With_status.t list - ; removed_commands : User_command.Valid.t With_status.t list + { new_commands : + Transaction_hash.User_command_with_valid_signature.t With_status.t + list + ; removed_commands : + Transaction_hash.User_command_with_valid_signature.t With_status.t + list ; reorg_best_tip : bool } @@ -2207,7 +2219,10 @@ let%test_module _ = expected_commands ) ) let mk_with_status (cmd : User_command.Valid.t) = - { With_status.data = cmd; status = Applied } + { With_status.data = + Transaction_hash.User_command_with_valid_signature.create cmd + ; status = Applied + } let add_commands ?(local = true) test cs = let sender = diff --git a/src/lib/one_or_two/one_or_two.ml b/src/lib/one_or_two/one_or_two.ml index f20633bd7d2f..c66526c288db 100644 --- a/src/lib/one_or_two/one_or_two.ml +++ b/src/lib/one_or_two/one_or_two.ml @@ -35,21 +35,21 @@ let to_numbered_list = function | `Two (a, b) -> [ (0, a); (1, b) ] -let group_sequence : 'a Sequence.t -> 'a t Sequence.t = - fun to_group -> - Sequence.unfold ~init:to_group ~f:(fun acc -> - match Sequence.next acc with - | None -> - None - | Some (a, rest_1) -> ( - match Sequence.next rest_1 with - | None -> - Some (`One a, Sequence.empty) - | Some (b, rest_2) -> - Some (`Two (a, b), rest_2) ) ) - let group_list : 'a list -> 'a t list = - fun xs -> xs |> Sequence.of_list |> group_sequence |> Sequence.to_list + let f (el, acc) x = + match el with + | `One a -> + (`Two (a, x), acc) + | `Two (a, b) -> + (`One x, `Two (a, b) :: acc) + in + function + | [] -> + [] + | fst_x :: xs -> + let init = (`One fst_x, []) in + let last, res = List.fold ~init ~f xs in + List.rev @@ (last :: res) let zip : 'a t -> 'b t -> ('a * 'b) t Or_error.t = fun a b -> diff --git a/src/lib/one_or_two/one_or_two.mli b/src/lib/one_or_two/one_or_two.mli index 0183b5366f3a..085f5eacec28 100644 --- a/src/lib/one_or_two/one_or_two.mli +++ b/src/lib/one_or_two/one_or_two.mli @@ -24,8 +24,6 @@ val to_list : 'a t -> 'a list val to_numbered_list : 'a t -> (int * 'a) list -val group_sequence : 'a Sequence.t -> 'a t Sequence.t - val group_list : 'a list -> 'a t list val zip : 'a t -> 'b t -> ('a * 'b) t Or_error.t diff --git a/src/lib/parallel_scan/parallel_scan.ml b/src/lib/parallel_scan/parallel_scan.ml index 3a4dac17e28c..8f7527184e05 100644 --- a/src/lib/parallel_scan/parallel_scan.ml +++ b/src/lib/parallel_scan/parallel_scan.ml @@ -75,6 +75,11 @@ module Base = struct end] let map (t : 'a t) ~(f : 'a -> 'b) : 'b t = { t with job = f t.job } + + let map_result (t : 'a t) ~(f : 'a -> ('b, 'e) Result.t) : + ('b t, 'e) Result.t = + let%map.Result job = f t.job in + { t with job } end module Job = struct @@ -89,6 +94,15 @@ module Base = struct let map (t : 'a t) ~(f : 'a -> 'b) : 'b t = match t with Empty -> Empty | Full r -> Full (Record.map r ~f) + let map_result (t : 'a t) ~(f : 'a -> ('b, 'e) Result.t) : + ('b t, 'e) Result.t = + match t with + | Empty -> + Ok Empty + | Full r -> + let%map.Result r = Record.map_result r ~f in + Full r + let job_str = function Empty -> "Base.Empty" | Full _ -> "Base.Full" end @@ -101,6 +115,11 @@ module Base = struct end] let map ((x, j) : 'a t) ~(f : 'a -> 'b) : 'b t = (x, Job.map j ~f) + + let map_result ((x, j) : 'a t) ~(f : 'a -> ('b, 'e) Result.t) : + ('b t, 'e) Result.t = + let%map.Result j = Job.map_result j ~f in + (x, j) end (** For merge proofs: Merging two base proofs or two merge proofs*) @@ -121,6 +140,12 @@ module Merge = struct let map (t : 'a t) ~(f : 'a -> 'b) : 'b t = { t with left = f t.left; right = f t.right } + + let map_result (t : 'a t) ~(f : 'a -> ('b, 'e) Result.t) : + ('b t, 'e) Result.t = + let%bind.Result left = f t.left in + let%map.Result right = f t.right in + { t with left; right } end module Job = struct @@ -144,6 +169,18 @@ module Merge = struct | Full r -> Full (Record.map r ~f) + let map_result (t : 'a t) ~(f : 'a -> ('b, 'e) Result.t) : + ('b t, 'e) Result.t = + match t with + | Empty -> + Ok Empty + | Part x -> + let%map.Result x = f x in + Part x + | Full r -> + let%map.Result r = Record.map_result r ~f in + Full r + let job_str = function | Empty -> "Merge.Empty" @@ -163,6 +200,11 @@ module Merge = struct end] let map ((x, j) : 'a t) ~(f : 'a -> 'b) : 'b t = (x, Job.map j ~f) + + let map_result ((x, j) : 'a t) ~(f : 'a -> ('b, 'e) Result.t) : + ('b t, 'e) Result.t = + let%bind.Result j = Job.map_result j ~f in + Ok (x, j) end (**All the jobs on a tree that can be done. Base.Full and Merge.Full*) @@ -288,6 +330,32 @@ module Tree = struct sub_tree } + let result_pair x y = + let%bind.Result x' = x in + let%map.Result y' = y in + (x', y') + + let rec map_depth_result : + type a_merge b_merge c_base d_base e. + f_merge:(int -> a_merge -> (b_merge, e) Result.t) + -> f_base:(c_base -> (d_base, e) Result.t) + -> (a_merge, c_base) t + -> ((b_merge, d_base) t, e) Result.t = + fun ~f_merge ~f_base tree -> + match tree with + | Leaf d -> + let%map.Result d' = f_base d in + Leaf d' + | Node { depth; value; sub_tree } -> + let%bind.Result value = f_merge depth value in + let%map.Result sub_tree = + map_depth_result + ~f_merge:(fun i (x, y) -> result_pair (f_merge i x) (f_merge i y)) + ~f_base:(fun (x, y) -> result_pair (f_base x) (f_base y)) + sub_tree + in + Node { depth; value; sub_tree } + let map : type a_merge b_merge c_base d_base. f_merge:(a_merge -> b_merge) @@ -929,6 +997,27 @@ module State = struct ; acc = Option.map t.acc ~f:(fun (m, bs) -> (f1 m, List.map bs ~f:f2)) } + let map_result (type a1 a2 b1 b2 e) (t : (a1, a2) t) + ~(f1 : a1 -> (b1, e) Result.t) ~(f2 : a2 -> (b2, e) Result.t) : + ((b1, b2) t, e) Result.t = + let%bind.Result trees = + Mina_stdlib.Nonempty_list.map_result t.trees + ~f: + (Tree.map_depth_result + ~f_merge:(fun _ -> Merge.map_result ~f:f1) + ~f_base:(Base.map_result ~f:f2) ) + in + let%map.Result acc = + match t.acc with + | None -> + Ok None + | Some (m, bs) -> + let%bind.Result m = f1 m in + let%map.Result bs = Mina_stdlib.Result.List.map ~f:f2 bs in + Some (m, bs) + in + { t with trees; acc } + let hash t f_merge f_base = let { trees; acc; max_base_jobs; curr_job_seq_no; delay; _ } = with_leaner_trees t @@ -1396,7 +1485,7 @@ let update_helper : (*update the latest emitted value *) let%bind () = State_or_error.put - { state with acc = Option.merge result_opt state.acc ~f:Fn.const } + { state with acc = Option.first_some result_opt state.acc } in (*Check the tree-list length is under max*) let%map () = @@ -1430,25 +1519,6 @@ let last_emitted_value t = t.acc let current_job_sequence_number t = t.curr_job_seq_no -let base_jobs_on_latest_tree t = - let depth = Int.ceil_log2 t.max_base_jobs in - List.filter_map - (Tree.jobs_on_level ~depth ~level:depth - (Mina_stdlib.Nonempty_list.head t.trees) ) - ~f:(fun job -> match job with Base d -> Some d | Merge _ -> None) - -(* 0-based indexing, so 0 indicates next-to-latest tree *) -let base_jobs_on_earlier_tree t ~index = - let depth = Int.ceil_log2 t.max_base_jobs in - let earlier_trees = Mina_stdlib.Nonempty_list.tail t.trees in - match List.nth earlier_trees index with - | None -> - [] - | Some tree -> - let jobs = Tree.jobs_on_level ~depth ~level:depth tree in - List.filter_map jobs ~f:(fun job -> - match job with Base d -> Some d | Merge _ -> None ) - let partition_if_overflowing : ('merge, 'base) t -> Space_partition.t = fun t -> let cur_tree_space = free_space_on_current_tree t in diff --git a/src/lib/parallel_scan/parallel_scan.mli b/src/lib/parallel_scan/parallel_scan.mli index c740e5a0a1c2..18dfd79ab48f 100644 --- a/src/lib/parallel_scan/parallel_scan.mli +++ b/src/lib/parallel_scan/parallel_scan.mli @@ -210,6 +210,12 @@ module State : sig val map : ('a1, 'a2) t -> f1:('a1 -> 'b1) -> f2:('a2 -> 'b2) -> ('b1, 'b2) t + val map_result : + ('a1, 'a2) t + -> f1:('a1 -> ('b1, 'e) Result.t) + -> f2:('a2 -> ('b2, 'e) Result.t) + -> (('b1, 'b2) t, 'e) Result.t + module Hash : sig type t = Digestif.SHA256.t end @@ -288,17 +294,6 @@ val view_jobs_with_position : -> ('base -> 'c) -> 'c Job_view.t list list -(** All the base jobs that are part of the latest tree being filled - * i.e., does not include base jobs that are part of previous trees not - * promoted to the merge jobs yet*) -val base_jobs_on_latest_tree : ('merge, 'base) State.t -> 'base list - -(** All the base jobs that are part of a tree before the latest tree - index is 0-based, 0 is the next-to-latest tree -*) -val base_jobs_on_earlier_tree : - ('merge, 'base) State.t -> index:int -> 'base list - (** Returns true only if the next 'd that could be enqueued is on a new tree*) val next_on_new_tree : ('merge, 'base) State.t -> bool diff --git a/src/lib/snark_profiler_lib/snark_profiler_lib.ml b/src/lib/snark_profiler_lib/snark_profiler_lib.ml index 41b236783252..de44712b0940 100644 --- a/src/lib/snark_profiler_lib/snark_profiler_lib.ml +++ b/src/lib/snark_profiler_lib/snark_profiler_lib.ml @@ -570,8 +570,7 @@ let profile_user_command (module T : Transaction_snark.S) ~genesis_constants ~f:(fun ((max_span, source_ledger, coinbase_stack_source), proofs) (target_ledger, applied) -> let txn = - With_status.data - @@ Mina_ledger.Ledger.transaction_of_applied applied + Mina_transaction_logic.Transaction_applied.transaction applied in (* the txn was already valid before apply, we are just recasting it here after application *) let (`If_this_is_used_it_should_have_a_comment_justifying_it @@ -792,8 +791,8 @@ let check_base_snarks ~genesis_constants ~constraint_constants ~logger |> List.fold ~init:sparse_ledger0 ~f:(fun source_ledger (target_ledger, applied_txn) -> let txn = - With_status.data - @@ Mina_ledger.Ledger.transaction_of_applied applied_txn + Mina_transaction_logic.Transaction_applied.transaction + applied_txn in (* the txn was already valid before apply, we are just recasting it here after application *) let (`If_this_is_used_it_should_have_a_comment_justifying_it @@ -857,8 +856,8 @@ let generate_base_snarks_witness ~genesis_constants ~constraint_constants |> List.fold ~init:sparse_ledger0 ~f:(fun source_ledger (target_ledger, applied_txn) -> let txn = - With_status.data - @@ Mina_ledger.Ledger.transaction_of_applied applied_txn + Mina_transaction_logic.Transaction_applied.transaction + applied_txn in (* the txn was already valid before apply, we are just recasting it here after application *) let (`If_this_is_used_it_should_have_a_comment_justifying_it diff --git a/src/lib/snark_work_lib/combined_result.mli b/src/lib/snark_work_lib/combined_result.mli index 63d2fa8d8bc9..9394d6e061dd 100644 --- a/src/lib/snark_work_lib/combined_result.mli +++ b/src/lib/snark_work_lib/combined_result.mli @@ -1,6 +1,5 @@ type t = - { results : - (Single_spec.t, Ledger_proof.Cached.t) Single_result.Poly.t One_or_two.t + { results : (Single_spec.t, Ledger_proof.t) Single_result.Poly.t One_or_two.t ; fee : Currency.Fee.t ; prover : Signature_lib.Public_key.Compressed.t } diff --git a/src/lib/snark_work_lib/metrics.ml b/src/lib/snark_work_lib/metrics.ml index e3debb3d9e86..5957fdbdcada 100644 --- a/src/lib/snark_work_lib/metrics.ml +++ b/src/lib/snark_work_lib/metrics.ml @@ -1,20 +1,5 @@ open Core_kernel - -module Transaction_type = struct - type t = [ `Zkapp_command | `Signed_command | `Coinbase | `Fee_transfer ] - [@@deriving to_yojson] - - let of_transaction = function - | Mina_transaction.Transaction.Command - (Mina_base.User_command.Zkapp_command _) -> - `Zkapp_command - | Command (Signed_command _) -> - `Signed_command - | Coinbase _ -> - `Coinbase - | Fee_transfer _ -> - `Fee_transfer -end +module Transaction_type = Mina_transaction.Transaction_type let emit_single_metrics_impl ~logger ~(single_spec : (Transaction_type.t, _) Single_spec.Poly.t) ~elapsed = @@ -54,8 +39,9 @@ let emit_single_metrics ~logger ~(single_spec : _ Single_spec.Poly.t) = emit_single_metrics_impl ~logger ~single_spec: (Single_spec.Poly.map ~f_proof:Fn.id - ~f_witness:(fun { Transaction_witness.transaction = tx; _ } -> - Transaction_type.of_transaction tx ) + ~f_witness:(fun { Transaction_witness.Stable.Latest.transaction = tx + ; _ + } -> Transaction_type.of_transaction tx ) single_spec ) let emit_single_metrics_stable ~logger ~(single_spec : _ Single_spec.Poly.t) = diff --git a/src/lib/snark_work_lib/partitioned_spec.ml b/src/lib/snark_work_lib/partitioned_spec.ml index bac7330e675f..cb1f11ac79ac 100644 --- a/src/lib/snark_work_lib/partitioned_spec.ml +++ b/src/lib/snark_work_lib/partitioned_spec.ml @@ -58,29 +58,3 @@ module Stable = struct end] type t = (Single_spec.t, Sub_zkapp_spec.t) Poly.t - -let read_all_proofs_from_disk : t -> Stable.Latest.t = function - | Single job -> - Single - (With_job_meta.map ~f_spec:Single_spec.read_all_proofs_from_disk job) - | Sub_zkapp_command job -> - Sub_zkapp_command - (With_job_meta.map ~f_spec:Sub_zkapp_spec.read_all_proofs_from_disk job) - -let write_all_proofs_to_disk ~signature_kind - ~(proof_cache_db : Proof_cache_tag.cache_db) : Stable.Latest.t -> t = - function - | Single job -> - Single - (With_job_meta.map - ~f_spec: - (Single_spec.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db ) - job ) - | Sub_zkapp_command job -> - Sub_zkapp_command - (With_job_meta.map - ~f_spec: - (Sub_zkapp_spec.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db ) - job ) diff --git a/src/lib/snark_work_lib/partitioned_spec.mli b/src/lib/snark_work_lib/partitioned_spec.mli index afc094fee8c8..742881a9ddb3 100644 --- a/src/lib/snark_work_lib/partitioned_spec.mli +++ b/src/lib/snark_work_lib/partitioned_spec.mli @@ -44,11 +44,3 @@ module Stable : sig end] type t = (Single_spec.t, Sub_zkapp_spec.t) Poly.t - -val read_all_proofs_from_disk : t -> Stable.Latest.t - -val write_all_proofs_to_disk : - signature_kind:Mina_signature_kind.t - -> proof_cache_db:Proof_cache_tag.cache_db - -> Stable.Latest.t - -> t diff --git a/src/lib/snark_work_lib/selector.ml b/src/lib/snark_work_lib/selector.ml index 33d2672e129e..b9f6712d69d3 100644 --- a/src/lib/snark_work_lib/selector.ml +++ b/src/lib/snark_work_lib/selector.ml @@ -32,14 +32,6 @@ module Spec = struct end] type t = Single.Spec.t Work.Spec.t - - let read_all_proofs_from_disk : t -> Stable.Latest.t = - Work.Spec.map ~f:Single.Spec.read_all_proofs_from_disk - - let write_all_proofs_to_disk ~signature_kind - ~(proof_cache_db : Proof_cache_tag.cache_db) : Stable.Latest.t -> t = - Work.Spec.map - ~f:(Single.Spec.write_all_proofs_to_disk ~signature_kind ~proof_cache_db) end module Result = struct @@ -59,15 +51,5 @@ module Result = struct end end] - type t = (Spec.t, Ledger_proof.Cached.t) Work.Result.Stable.V1.t - - let read_all_proofs_from_disk : t -> Stable.Latest.t = - Work.Result.map ~f_spec:Spec.read_all_proofs_from_disk - ~f_single:Ledger_proof.Cached.read_proof_from_disk - - let write_all_proofs_to_disk ~signature_kind - ~(proof_cache_db : Proof_cache_tag.cache_db) : Stable.Latest.t -> t = - Work.Result.map - ~f_spec:(Spec.write_all_proofs_to_disk ~signature_kind ~proof_cache_db) - ~f_single:(Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db) + type t = (Spec.t, Ledger_proof.t) Work.Result.Stable.V1.t end diff --git a/src/lib/snark_work_lib/single_result.ml b/src/lib/snark_work_lib/single_result.ml index 0548704ffd73..dad4ea64079c 100644 --- a/src/lib/snark_work_lib/single_result.ml +++ b/src/lib/snark_work_lib/single_result.ml @@ -30,15 +30,4 @@ module Stable = struct end end] -type t = (Single_spec.t, Ledger_proof.Cached.t) Poly.t - -let read_all_proofs_from_disk : t -> Stable.Latest.t = - Poly.map ~f_spec:Single_spec.read_all_proofs_from_disk - ~f_proof:Ledger_proof.Cached.read_proof_from_disk - -let write_all_proofs_to_disk ~signature_kind - ~(proof_cache_db : Proof_cache_tag.cache_db) : Stable.Latest.t -> t = - Poly.map - ~f_spec: - (Single_spec.write_all_proofs_to_disk ~signature_kind ~proof_cache_db) - ~f_proof:(Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db) +type t = (Single_spec.t, Ledger_proof.t) Poly.t diff --git a/src/lib/snark_work_lib/single_result.mli b/src/lib/snark_work_lib/single_result.mli index 009be32149fc..c10f49cdaacf 100644 --- a/src/lib/snark_work_lib/single_result.mli +++ b/src/lib/snark_work_lib/single_result.mli @@ -28,12 +28,4 @@ module Stable : sig end end] -type t = (Single_spec.t, Ledger_proof.Cached.t) Poly.t - -val read_all_proofs_from_disk : t -> Stable.Latest.t - -val write_all_proofs_to_disk : - signature_kind:Mina_signature_kind.t - -> proof_cache_db:Proof_cache_tag.cache_db - -> Stable.Latest.t - -> t +type t = (Single_spec.t, Ledger_proof.t) Poly.t diff --git a/src/lib/snark_work_lib/single_spec.ml b/src/lib/snark_work_lib/single_spec.ml index 428e2ea584c4..c4bc304255d2 100644 --- a/src/lib/snark_work_lib/single_spec.ml +++ b/src/lib/snark_work_lib/single_spec.ml @@ -65,16 +65,4 @@ module Stable = struct end end] -type t = (Transaction_witness.t, Ledger_proof.Cached.t) Poly.t - -let read_all_proofs_from_disk : t -> Stable.Latest.t = - Poly.map ~f_witness:Transaction_witness.read_all_proofs_from_disk - ~f_proof:Ledger_proof.Cached.read_proof_from_disk - -let write_all_proofs_to_disk ~signature_kind - ~(proof_cache_db : Proof_cache_tag.cache_db) : Stable.Latest.t -> t = - Poly.map - ~f_witness: - (Transaction_witness.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db ) - ~f_proof:(Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db) +type t = Stable.Latest.t diff --git a/src/lib/snark_work_lib/single_spec.mli b/src/lib/snark_work_lib/single_spec.mli index f9175235a5bd..18e02413b181 100644 --- a/src/lib/snark_work_lib/single_spec.mli +++ b/src/lib/snark_work_lib/single_spec.mli @@ -44,12 +44,4 @@ module Stable : sig end end] -type t = (Transaction_witness.t, Ledger_proof.Cached.t) Poly.t - -val read_all_proofs_from_disk : t -> Stable.Latest.t - -val write_all_proofs_to_disk : - signature_kind:Mina_signature_kind.t - -> proof_cache_db:Proof_cache_tag.cache_db - -> Stable.Latest.t - -> t +type t = Stable.Latest.t diff --git a/src/lib/snark_work_lib/sub_zkapp_spec.ml b/src/lib/snark_work_lib/sub_zkapp_spec.ml index 07f7c9237014..0b395ecf6613 100644 --- a/src/lib/snark_work_lib/sub_zkapp_spec.ml +++ b/src/lib/snark_work_lib/sub_zkapp_spec.ml @@ -40,41 +40,8 @@ end] type t = | Segment of { statement : Transaction_snark.Statement.With_sok.t - ; witness : Transaction_snark.Zkapp_command_segment.Witness.t + ; witness : + Transaction_snark.Zkapp_command_segment.Witness.Stable.Latest.t ; spec : Transaction_snark.Zkapp_command_segment.Basic.t } - | Merge of { proof1 : Ledger_proof.Cached.t; proof2 : Ledger_proof.Cached.t } - -let read_all_proofs_from_disk : t -> Stable.Latest.t = function - | Segment { statement; witness; spec } -> - Segment - { statement - ; witness = - Transaction_snark.Zkapp_command_segment.Witness - .read_all_proofs_from_disk witness - ; spec - } - | Merge { proof1; proof2 } -> - Merge - { proof1 = Ledger_proof.Cached.read_proof_from_disk proof1 - ; proof2 = Ledger_proof.Cached.read_proof_from_disk proof2 - } - -let write_all_proofs_to_disk ~signature_kind - ~(proof_cache_db : Proof_cache_tag.cache_db) : Stable.Latest.t -> t = - function - | Segment { statement; witness; spec } -> - Segment - { statement - ; witness = - Transaction_snark.Zkapp_command_segment.Witness - .write_all_proofs_to_disk ~signature_kind ~proof_cache_db witness - ; spec - } - | Merge { proof1; proof2 } -> - Merge - { proof1 = - Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db proof1 - ; proof2 = - Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db proof2 - } + | Merge of { proof1 : Ledger_proof.t; proof2 : Ledger_proof.t } diff --git a/src/lib/snark_work_lib/sub_zkapp_spec.mli b/src/lib/snark_work_lib/sub_zkapp_spec.mli index 38a6dfdc9759..a462266dec31 100644 --- a/src/lib/snark_work_lib/sub_zkapp_spec.mli +++ b/src/lib/snark_work_lib/sub_zkapp_spec.mli @@ -27,15 +27,8 @@ end] type t = | Segment of { statement : Transaction_snark.Statement.With_sok.t - ; witness : Transaction_snark.Zkapp_command_segment.Witness.t + ; witness : + Transaction_snark.Zkapp_command_segment.Witness.Stable.Latest.t ; spec : Transaction_snark.Zkapp_command_segment.Basic.t } - | Merge of { proof1 : Ledger_proof.Cached.t; proof2 : Ledger_proof.Cached.t } - -val read_all_proofs_from_disk : t -> Stable.Latest.t - -val write_all_proofs_to_disk : - signature_kind:Mina_signature_kind.t - -> proof_cache_db:Proof_cache_tag.cache_db - -> Stable.Latest.t - -> t + | Merge of { proof1 : Ledger_proof.t; proof2 : Ledger_proof.t } diff --git a/src/lib/staged_ledger/application_state.ml b/src/lib/staged_ledger/application_state.ml new file mode 100644 index 000000000000..4cab981c5d00 --- /dev/null +++ b/src/lib/staged_ledger/application_state.ml @@ -0,0 +1,119 @@ +open Core_kernel +open Mina_base +open Mina_transaction + +type 'txn t = + { valid_seq : 'txn Sequence.t + ; invalid : ('txn * Error.t) list + ; skipped_by_fee_payer : 'txn list Account_id.Map.t + ; zkapp_space_remaining : int option + ; total_space_remaining : int + } + +let init ?zkapp_limit ~total_limit = + { valid_seq = Sequence.empty + ; invalid = [] + ; skipped_by_fee_payer = Account_id.Map.empty + ; zkapp_space_remaining = zkapp_limit + ; total_space_remaining = total_limit + } + +module Make (Txn : sig + type t [@@deriving to_yojson] + + val key : t -> Account_id.t + + val is_zkapp_command : t -> bool + + val to_user_command : t -> User_command.t +end) : sig + val try_applying_txn : + ?logger:Logger.t + -> apply: + ( User_command.t Transaction.t_ + -> ('any_application_result, Error.t) result ) + -> Txn.t t + -> Txn.t + -> (Txn.t t, Txn.t Sequence.t * (Txn.t * Error.t) list) Continue_or_stop.t +end = struct + let add_skipped_txn t (txn : Txn.t) = + Account_id.Map.update t.skipped_by_fee_payer (Txn.key txn) + ~f:(Option.value_map ~default:[ txn ] ~f:(List.cons txn)) + + let dependency_skipped txn t = + Account_id.Map.mem t.skipped_by_fee_payer (Txn.key txn) + + let try_applying_txn ?logger ~apply (state : Txn.t t) (txn : Txn.t) = + let open Continue_or_stop in + match state.zkapp_space_remaining with + | _ when state.total_space_remaining < 1 -> + Stop (state.valid_seq, state.invalid) + | Some zkapp_limit when Txn.is_zkapp_command txn && zkapp_limit < 1 -> + Continue { state with skipped_by_fee_payer = add_skipped_txn state txn } + | Some _ when dependency_skipped txn state -> + Continue { state with skipped_by_fee_payer = add_skipped_txn state txn } + | _ -> ( + match + O1trace.sync_thread "validate_transaction_against_staged_ledger" + (fun () -> apply (Transaction.Command (Txn.to_user_command txn))) + with + | Error e -> + Option.iter logger ~f:(fun logger -> + [%log error] + ~metadata: + [ ("user_command", Txn.to_yojson txn) + ; ("error", Error_json.error_to_yojson e) + ] + "Staged_ledger_diff creation: Skipping user command: \ + $user_command due to error: $error" ) ; + Continue { state with invalid = (txn, e) :: state.invalid } + | Ok _txn_partially_applied -> + let valid_seq = + Sequence.append (Sequence.singleton txn) state.valid_seq + in + let zkapp_space_remaining = + Option.map state.zkapp_space_remaining ~f:(fun limit -> + if Txn.is_zkapp_command txn then limit - 1 else limit ) + in + Continue + { state with + valid_seq + ; zkapp_space_remaining + ; total_space_remaining = state.total_space_remaining - 1 + } ) +end + +module Valid_user_command_inputs = struct + type t = User_command.Valid.t [@@deriving to_yojson] + + let key = function + | User_command.Zkapp_command cmd -> + Zkapp_command.(Valid.forget cmd |> fee_payer) + | Signed_command cmd -> + Signed_command.(forget_check cmd |> fee_payer) + + let is_zkapp_command = function + | User_command.Zkapp_command _ -> + true + | Signed_command _ -> + false + + let to_user_command = User_command.forget_check +end + +module Valid_user_command = Make (Valid_user_command_inputs) + +module Valid_user_command_with_hash = Make (struct + type t = Transaction_hash.User_command_with_valid_signature.t + + let proxy1 f = + Fn.compose f Transaction_hash.User_command_with_valid_signature.data + + let key = proxy1 Valid_user_command_inputs.key + + let is_zkapp_command = proxy1 Valid_user_command_inputs.is_zkapp_command + + let to_user_command = proxy1 Valid_user_command_inputs.to_user_command + + let to_yojson = Transaction_hash.User_command_with_valid_signature.to_yojson +end) diff --git a/src/lib/staged_ledger/check_commands.ml b/src/lib/staged_ledger/check_commands.ml index d27c7225e538..7fd3deb83813 100644 --- a/src/lib/staged_ledger/check_commands.ml +++ b/src/lib/staged_ledger/check_commands.ml @@ -1,6 +1,5 @@ open Core_kernel open Mina_base -open Mina_transaction open Mina_stdlib module Ledger = Mina_ledger.Ledger @@ -19,14 +18,8 @@ let dummy_transaction_pool_proxy : transaction_pool_proxy = command verification *) let verify_command_with_transaction_pool_proxy ~(transaction_pool_proxy : transaction_pool_proxy) + ~(cmd_hash : Mina_transaction.Transaction_hash.t) (cmd_with_status : User_command.Verifiable.t With_status.t) = - let With_status.{ data = verifiable_cmd; _ } = cmd_with_status in - let cmd_hash = - (* PERF: `hash_command` is slow, so we may need to investigate if we could - reuse hashes from transition verification. *) - User_command.of_verifiable verifiable_cmd - |> Transaction_hash.hash_command_with_hashes - in match transaction_pool_proxy.find_by_hash cmd_hash with | None -> `No_fast_forward @@ -35,7 +28,8 @@ let verify_command_with_transaction_pool_proxy let check_commands ledger ~verifier ~(transaction_pool_proxy : transaction_pool_proxy) - (cs : User_command.t With_status.t list) = + (cs : User_command.t With_status.t list) + (hashes : Mina_transaction.Transaction_hash.t list) = let open Deferred.Or_error.Let_syntax in let%bind cs = User_command.Applied_sequence.to_all_verifiable cs @@ -46,10 +40,11 @@ let check_commands ledger ~verifier ~get_batch:(Ledger.get_batch ledger) ) |> Deferred.return in - let partitioner cmd = + let partitioner (cmd, cmd_hash) = let open Core_kernel.Either in match - verify_command_with_transaction_pool_proxy ~transaction_pool_proxy cmd + verify_command_with_transaction_pool_proxy ~transaction_pool_proxy + ~cmd_hash cmd with | `No_fast_forward -> Second cmd @@ -63,7 +58,7 @@ let check_commands ledger ~verifier ~finalizer:(fun left right_m ~f -> let%map.Deferred.Or_error right = right_m in f left right ) - cs + (List.zip_exn cs hashes) in Result.all (List.map xs ~f:(function diff --git a/src/lib/staged_ledger/check_commands.mli b/src/lib/staged_ledger/check_commands.mli index 367aadb4c0f2..1223c0679ecd 100644 --- a/src/lib/staged_ledger/check_commands.mli +++ b/src/lib/staged_ledger/check_commands.mli @@ -15,6 +15,7 @@ val check_commands : -> verifier:Verifier.t -> transaction_pool_proxy:transaction_pool_proxy -> User_command.t With_status.t list + -> Mina_transaction.Transaction_hash.t list -> ( ( Signed_command.With_valid_signature.t , Zkapp_command.Valid.t ) User_command.t_ diff --git a/src/lib/staged_ledger/diff_creation_log.ml b/src/lib/staged_ledger/diff_creation_log.ml index 0bbe21f9ffe8..4867e664369e 100644 --- a/src/lib/staged_ledger/diff_creation_log.ml +++ b/src/lib/staged_ledger/diff_creation_log.ml @@ -1,5 +1,6 @@ open Core_kernel open Mina_base +open Mina_transaction type count_and_fee = int * Currency.Fee.t [@@deriving sexp, to_yojson] @@ -58,7 +59,8 @@ module Summary = struct let init_resources ~(completed_work : Transaction_snark_work.Checked.t Sequence.t) - ~(commands : User_command.Valid.t Sequence.t) + ~(commands : + Transaction_hash.User_command_with_valid_signature.t Sequence.t ) ~(coinbase : Coinbase.Fee_transfer.t Staged_ledger_diff.At_most_two.t) = let completed_work = ( Sequence.length completed_work @@ -71,13 +73,17 @@ module Summary = struct , Sequence.sum (module Fee_Summable) commands - ~f:(fun cmd -> User_command.fee (User_command.forget_check cmd)) ) + ~f:(fun cmd -> + User_command.fee + (Transaction_hash.User_command_with_valid_signature.command cmd) + ) ) in let coinbase_work_fees = coinbase_fees coinbase in { completed_work; commands; coinbase_work_fees } let init ~(completed_work : Transaction_snark_work.Checked.t Sequence.t) - ~(commands : User_command.Valid.t Sequence.t) + ~(commands : + Transaction_hash.User_command_with_valid_signature.t Sequence.t ) ~(coinbase : Coinbase.Fee_transfer.t Staged_ledger_diff.At_most_two.t) ~partition ~available_slots ~required_work_count = let start_resources = init_resources ~completed_work ~commands ~coinbase in @@ -101,7 +107,8 @@ module Summary = struct } let end_log t ~(completed_work : Transaction_snark_work.Checked.t Sequence.t) - ~(commands : User_command.Valid.t Sequence.t) + ~(commands : + Transaction_hash.User_command_with_valid_signature.t Sequence.t ) ~(coinbase : Coinbase.Fee_transfer.t Staged_ledger_diff.At_most_two.t) = end_resources.set (init_resources ~completed_work ~commands ~coinbase) t @@ -147,7 +154,8 @@ module Detail = struct type t = line list [@@deriving sexp, to_yojson] let init ~(completed_work : Transaction_snark_work.Checked.t Sequence.t) - ~(commands : User_command.Valid.t Sequence.t) + ~(commands : + Transaction_hash.User_command_with_valid_signature.t Sequence.t ) ~(coinbase : Coinbase.Fee_transfer.t Staged_ledger_diff.At_most_two.t) = let init = Summary.init_resources ~completed_work ~commands ~coinbase in [ { reason = `Init @@ -207,7 +215,7 @@ type summary_list = Summary.t list [@@deriving sexp, to_yojson] type detail_list = Detail.t list [@@deriving sexp, to_yojson] let init ~(completed_work : Transaction_snark_work.Checked.t Sequence.t) - ~(commands : User_command.Valid.t Sequence.t) + ~(commands : Transaction_hash.User_command_with_valid_signature.t Sequence.t) ~(coinbase : Coinbase.Fee_transfer.t Staged_ledger_diff.At_most_two.t) ~partition ~available_slots ~required_work_count = let summary = @@ -228,7 +236,7 @@ let discard_completed_work why completed_work t = (summary, detailed) let end_log ~(completed_work : Transaction_snark_work.Checked.t Sequence.t) - ~(commands : User_command.Valid.t Sequence.t) + ~(commands : Transaction_hash.User_command_with_valid_signature.t Sequence.t) ~(coinbase : Coinbase.Fee_transfer.t Staged_ledger_diff.At_most_two.t) t = let summary = Summary.end_log (fst t) ~completed_work ~commands ~coinbase in let detailed = Detail.end_log coinbase (snd t) in diff --git a/src/lib/staged_ledger/dune b/src/lib/staged_ledger/dune index 437cb5fff416..9f590d8a80aa 100644 --- a/src/lib/staged_ledger/dune +++ b/src/lib/staged_ledger/dune @@ -60,7 +60,8 @@ transaction_witness verifier with_hash - zkapp_command_builder) + zkapp_command_builder + multi_key_file_storage) (instrumentation (backend bisect_ppx)) (preprocess diff --git a/src/lib/staged_ledger/pre_diff_info.ml b/src/lib/staged_ledger/pre_diff_info.ml index 0bc14a91d87e..1e70e64bb1fb 100644 --- a/src/lib/staged_ledger/pre_diff_info.ml +++ b/src/lib/staged_ledger/pre_diff_info.ml @@ -339,16 +339,11 @@ let get_individual_info (type c) List.map coinbase_parts ~f:(fun Coinbase.{ amount; _ } -> amount) } -let check_coinbase - (diff : - _ Staged_ledger_diff.Pre_diff_two.t - * _ Staged_ledger_diff.Pre_diff_one.t option ) = - match - ( (fst diff).coinbase - , Option.value_map ~default:Staged_ledger_diff.At_most_one.Zero (snd diff) - ~f:(fun d -> d.coinbase) ) - with - | Zero, Zero | Zero, One _ | One _, Zero | Two _, Zero -> +let check_coinbase = function + | Staged_ledger_diff.At_most_two.Zero, Staged_ledger_diff.At_most_one.Zero + | Zero, One _ + | One _, Zero + | Two _, Zero -> Ok () | x, y -> Error @@ -403,7 +398,8 @@ let compute_statuses let split_transaction_statuses txns_with_statuses = List.partition_map txns_with_statuses ~f:(fun txn_applied -> let { With_status.data = txn; status } = - Mina_ledger.Ledger.transaction_of_applied txn_applied + Mina_transaction_logic.Transaction_applied.transaction_with_status + txn_applied in match txn with | Transaction.Command cmd -> @@ -450,7 +446,8 @@ let compute_statuses let get_impl (type c) ~get_transaction_data ~(constraint_constants : Genesis_constants.Constraint_constants.t) ~(to_user_command : c With_status.t -> (_, _, _) User_command.with_forest) - ~diff ~coinbase_receiver ~coinbase_amount = + ~diff ~coinbase_receiver ~coinbase_amount ~extract_prediff_two + ~extract_prediff_one = let open Result.Let_syntax in let%bind coinbase_amount = Option.value_map coinbase_amount @@ -465,37 +462,61 @@ let get_impl (type c) ~get_transaction_data constraint_constants.coinbase_amount ) ) ) ~f:(fun x -> Ok x) in - let apply_pre_diff_with_at_most_two (t1 : _ Staged_ledger_diff.Pre_diff_two.t) - = + let apply_pre_diff_with_at_most_two ~constraint_constants t1 = + let completed_works, commands, coinbases, internal_command_statuses = + extract_prediff_two t1 + in let coinbase_parts = - match t1.coinbase with Zero -> `Zero | One x -> `One x | Two x -> `Two x + match coinbases with + | Staged_ledger_diff.At_most_two.Zero -> + `Zero + | One x -> + `One x + | Two x -> + `Two x + in + let%map p = + get_individual_info ~get_transaction_data coinbase_parts + ~receiver:coinbase_receiver commands completed_works ~coinbase_amount + ~internal_command_statuses ~to_user_command ~constraint_constants in - get_individual_info ~get_transaction_data coinbase_parts - ~receiver:coinbase_receiver t1.commands t1.completed_works - ~coinbase_amount ~internal_command_statuses:t1.internal_command_statuses - ~to_user_command + (coinbases, p) in - let apply_pre_diff_with_at_most_one (t2 : _ Staged_ledger_diff.Pre_diff_one.t) - = + let apply_pre_diff_with_at_most_one ~constraint_constants t2 = + let completed_works, commands, coinbases, internal_command_statuses = + extract_prediff_one t2 + in let coinbase_added = - match t2.coinbase with Zero -> `Zero | One x -> `One x + match coinbases with + | Staged_ledger_diff.At_most_one.Zero -> + `Zero + | One x -> + `One x + in + let%map p = + get_individual_info ~get_transaction_data coinbase_added + ~receiver:coinbase_receiver commands completed_works ~coinbase_amount + ~internal_command_statuses ~to_user_command ~constraint_constants in - get_individual_info ~get_transaction_data coinbase_added - ~receiver:coinbase_receiver t2.commands t2.completed_works - ~coinbase_amount ~internal_command_statuses:t2.internal_command_statuses - ~to_user_command + (coinbases, p) in - let%bind () = check_coinbase diff in - let%bind p1 = + let%bind cb1, p1 = apply_pre_diff_with_at_most_two ~constraint_constants (fst diff) in - let%map p2 = + let%bind cb2, p2 = Option.value_map - ~f:(fun d -> apply_pre_diff_with_at_most_one ~constraint_constants d) + ~f:(apply_pre_diff_with_at_most_one ~constraint_constants) (snd diff) ~default: - (Ok { transactions = []; work = []; commands_count = 0; coinbases = [] }) + (Ok + ( Staged_ledger_diff.At_most_one.Zero + , { transactions = [] + ; work = [] + ; commands_count = 0 + ; coinbases = [] + } ) ) in + let%map () = check_coinbase (cb1, cb2) in ( p1.transactions @ p2.transactions , p1.work @ p2.work , p1.commands_count + p2.commands_count @@ -518,6 +539,8 @@ let get ~check ~constraint_constants ~coinbase_receiver ~supercharge_coinbase t ~coinbase_amount: (Staged_ledger_diff.With_valid_signatures.coinbase ~constraint_constants ~supercharge_coinbase diff ) + ~extract_prediff_two:Staged_ledger_diff.Pre_diff_generic.extract_prediff + ~extract_prediff_one:Staged_ledger_diff.Pre_diff_generic.extract_prediff let get_unchecked ~constraint_constants ~coinbase_receiver ~supercharge_coinbase (t : Staged_ledger_diff.With_valid_signatures_and_proofs.t) = @@ -529,17 +552,26 @@ let get_unchecked ~constraint_constants ~coinbase_receiver ~supercharge_coinbase ~coinbase_amount: (Staged_ledger_diff.With_valid_signatures.coinbase ~constraint_constants ~supercharge_coinbase t ) + ~extract_prediff_two:Staged_ledger_diff.Pre_diff_generic.extract_prediff + ~extract_prediff_one:Staged_ledger_diff.Pre_diff_generic.extract_prediff let get_transactions_stable ~constraint_constants ~coinbase_receiver ~supercharge_coinbase ({ diff } : Staged_ledger_diff.Stable.Latest.t) = let open Result.Let_syntax in let open Transaction_data_getter_stable in + let extract_prediff_two x = + Staged_ledger_diff.Pre_diff_generic.Stable.Latest.extract_prediff x + in + let extract_prediff_one x = + Staged_ledger_diff.Pre_diff_generic.Stable.Latest.extract_prediff x + in let%map transactions, _, _, _ = get_impl ~get_transaction_data ~constraint_constants ~to_user_command:With_status.data ~diff ~coinbase_receiver ~coinbase_amount: (Staged_ledger_diff.Diff.Stable.Latest.coinbase ~constraint_constants ~supercharge_coinbase diff ) + ~extract_prediff_two ~extract_prediff_one in transactions @@ -547,11 +579,18 @@ let get_transactions ~constraint_constants ~coinbase_receiver ~supercharge_coinbase ({ diff } : Staged_ledger_diff.t) = let open Result.Let_syntax in let open Transaction_data_getter_unchecked in + let extract_prediff_two x = + Staged_ledger_diff.Pre_diff_generic.extract_prediff x + in + let extract_prediff_one x = + Staged_ledger_diff.Pre_diff_generic.extract_prediff x + in let%map transactions, _, _, _ = get_impl ~get_transaction_data ~constraint_constants ~to_user_command:With_status.data ~diff ~coinbase_receiver ~coinbase_amount: (Staged_ledger_diff.Diff.coinbase ~constraint_constants ~supercharge_coinbase diff ) + ~extract_prediff_two ~extract_prediff_one in transactions diff --git a/src/lib/staged_ledger/scan_state_application_data.ml b/src/lib/staged_ledger/scan_state_application_data.ml new file mode 100644 index 000000000000..b60b9779a73b --- /dev/null +++ b/src/lib/staged_ledger/scan_state_application_data.ml @@ -0,0 +1,28 @@ +open Core_kernel +open Mina_base + +[%%versioned +module Stable = struct + module V1 = struct + (* Data for loading the staged ledger *) + type t = + { is_new_stack : bool + ; stack_update : + Pending_coinbase.Stack_versioned.Stable.V1.t One_or_two.Stable.V1.t + option + ; first_pass_ledger_end : Frozen_ledger_hash.Stable.V1.t + ; tagged_works : + Transaction_snark_scan_state.Ledger_proof_with_sok_message.Tagged + .Stable + .V1 + .t + list + ; tagged_witnesses : + Transaction_snark_scan_state.Transaction_with_witness.Tagged.Stable.V1 + .t + list + } + + let to_latest = Fn.id + end +end] diff --git a/src/lib/staged_ledger/staged_ledger.ml b/src/lib/staged_ledger/staged_ledger.ml index 9d8e483586ed..49502808bc1c 100644 --- a/src/lib/staged_ledger/staged_ledger.ml +++ b/src/lib/staged_ledger/staged_ledger.ml @@ -31,12 +31,16 @@ module Pre_statement = struct ; first_pass_ledger_target_hash : Ledger_hash.t ; pending_coinbase_stack_source : Pending_coinbase.Stack_versioned.t ; pending_coinbase_stack_target : Pending_coinbase.Stack_versioned.t - ; init_stack : Transaction_snark.Pending_coinbase_stack_state.Init_stack.t + ; init_stack : Mina_base.Pending_coinbase.Stack_versioned.t } end module T = struct - module Scan_state = Transaction_snark_scan_state + module Scan_state = struct + include Transaction_snark_scan_state + module Application_data = Scan_state_application_data + end + module Pre_diff_info = Pre_diff_info module Staged_ledger_error = struct @@ -192,7 +196,7 @@ module T = struct let open Deferred.Let_syntax in match map_opt job_msg_proofs ~f:(fun (job, msg, proof) -> - Option.map (Scan_state.statement_of_job job) ~f:(fun s -> + Option.map (Scan_state.Available_job.statement job) ~f:(fun s -> (proof, s, msg) ) ) with | None -> @@ -222,10 +226,7 @@ module T = struct let verify ~verifier:{ logger; verifier } ts = verify_proofs ~logger ~verifier - (List.map ts ~f:(fun (p, m) -> - ( Ledger_proof.Cached.read_proof_from_disk p - , Ledger_proof.Cached.statement p - , m ) ) ) + (List.map ts ~f:(fun (p, m) -> (p, Ledger_proof.statement p, m))) end module Statement_scanner_with_proofs = @@ -241,16 +242,9 @@ module T = struct ; pending_coinbase_collection : Pending_coinbase.t } - let proof_txns_with_state_hashes t = - Scan_state.latest_ledger_proof t.scan_state - |> Option.bind ~f:(Fn.compose Mina_stdlib.Nonempty_list.of_list_opt snd) - let scan_state { scan_state; _ } = scan_state - let all_work_pairs t - ~(get_state : State_hash.t -> Mina_state.Protocol_state.value Or_error.t) - = - Scan_state.all_work_pairs t.scan_state ~get_state + let all_work_pairs t = Scan_state.all_work_pairs t.scan_state let all_work_statements_exn t = Scan_state.all_work_statements_exn t.scan_state @@ -273,26 +267,19 @@ module T = struct in let statement_check = `Partial in let last_proof_statement = - Option.map - ~f:(fun ((p, _), _) -> Ledger_proof.Cached.statement p) - (Scan_state.latest_ledger_proof scan_state) + Scan_state.latest_ledger_proof_statement scan_state in Statement_scanner.check_invariants ~constraint_constants scan_state ~statement_check ~verifier:() ~error_prefix ~registers_end ~last_proof_statement - let of_scan_state_and_ledger_unchecked ~ledger ~scan_state - ~constraint_constants ~pending_coinbase_collection = - { ledger; scan_state; constraint_constants; pending_coinbase_collection } - let of_scan_state_and_ledger ~logger ~(constraint_constants : Genesis_constants.Constraint_constants.t) ~verifier ~last_proof_statement ~ledger ~scan_state ~pending_coinbase_collection ~get_state ~first_pass_ledger_target = let open Deferred.Or_error.Let_syntax in let t = - of_scan_state_and_ledger_unchecked ~ledger ~scan_state - ~constraint_constants ~pending_coinbase_collection + { ledger; scan_state; constraint_constants; pending_coinbase_collection } in let%bind pending_coinbase_stack = Pending_coinbase.latest_stack ~is_new_stack:false @@ -320,6 +307,7 @@ module T = struct ~last_proof_statement ~ledger ~scan_state ~pending_coinbase_collection ~first_pass_ledger_target = let open Deferred.Or_error.Let_syntax in + (* TODO consider removing the invariants check *) let%bind pending_coinbase_stack = Pending_coinbase.latest_stack ~is_new_stack:false pending_coinbase_collection @@ -377,13 +365,15 @@ module T = struct expected_merkle_root staged_ledger_hash ) in let last_proof_statement = - Scan_state.latest_ledger_proof scan_state - |> Option.map ~f:(fun ((p, _), _) -> Ledger_proof.Cached.statement p) + Scan_state.latest_ledger_proof_statement scan_state in f ~constraint_constants ~last_proof_statement ~ledger:snarked_ledger ~scan_state ~pending_coinbase_collection:pending_coinbases ~first_pass_ledger_target + (* Used in bootstrap (to verify data received from network) + Consider changing types to work on stable scan state + *) let of_scan_state_pending_coinbases_and_snarked_ledger ~logger ~constraint_constants ~verifier ~scan_state ~snarked_ledger ~snarked_local_state ~expected_merkle_root ~pending_coinbases ~get_state @@ -393,6 +383,7 @@ module T = struct ~expected_merkle_root ~get_state ~signature_kind (of_scan_state_and_ledger ~logger ~get_state ~verifier) + (* Used in loading the root from disk *) let of_scan_state_pending_coinbases_and_snarked_ledger_unchecked ~constraint_constants ~logger ~scan_state ~snarked_ledger ~snarked_local_state ~expected_merkle_root ~pending_coinbases ~get_state @@ -419,7 +410,7 @@ module T = struct ; pending_coinbase_collection } : Staged_ledger_hash.t = Staged_ledger_hash.of_aux_ledger_and_coinbase_hash - Scan_state.(Stable.Latest.hash @@ read_all_proofs_from_disk scan_state) + (Scan_state.hash scan_state) (Ledger.merkle_root ledger) pending_coinbase_collection @@ -435,11 +426,6 @@ module T = struct |> Or_error.ok_exn } - let current_ledger_proof t = - Option.map - (Scan_state.latest_ledger_proof t.scan_state) - ~f:(Fn.compose fst fst) - let replace_ledger_exn t ledger = [%test_result: Ledger_hash.t] ~message:"Cannot replace ledger since merkle_root differs" @@ -527,9 +513,7 @@ module T = struct ; first_pass_ledger_target_hash = target_ledger_hash ; pending_coinbase_stack_source = pending_coinbase_stack_state.pc.source ; pending_coinbase_stack_target = pending_coinbase_target - ; init_stack = - Transaction_snark.Pending_coinbase_stack_state.Init_stack.Base - pending_coinbase_stack_state.init_stack + ; init_stack = pending_coinbase_stack_state.init_stack } , { Stack_state_with_init_stack.pc = { source = pending_coinbase_target; target = pending_coinbase_target } @@ -559,13 +543,16 @@ module T = struct ~constraint_constants applied_txn ) in let%map () = - let actual_status = Ledger.status_of_applied applied_txn in + let actual_status = + Mina_transaction_logic.Transaction_applied.transaction_status + applied_txn + in if Transaction_status.equal pre_stmt.expected_status actual_status then return () else let txn_with_expected_status = { With_status.data = - With_status.data (Ledger.transaction_of_applied applied_txn) + Mina_transaction_logic.Transaction_applied.transaction applied_txn ; status = pre_stmt.expected_status } in @@ -593,14 +580,19 @@ module T = struct ; sok_digest = () } in - { Scan_state.Transaction_with_witness.transaction_with_info = applied_txn - ; state_hash = state_and_body_hash - ; first_pass_ledger_witness = pre_stmt.first_pass_ledger_witness - ; second_pass_ledger_witness = ledger_witness - ; init_stack = pre_stmt.init_stack - ; statement - ; block_global_slot = global_slot - } + ( { Scan_state.Transaction_with_witness.transaction_with_status = + Mina_transaction_logic.Transaction_applied.transaction_with_status + applied_txn + ; state_hash = state_and_body_hash + ; first_pass_ledger_witness = pre_stmt.first_pass_ledger_witness + ; second_pass_ledger_witness = ledger_witness + ; init_stack = pre_stmt.init_stack + ; statement + ; block_global_slot = global_slot + ; previous_protocol_state_body_opt = None + ; transaction_applied_or_tag = First applied_txn + } + , Mina_transaction_logic.Transaction_applied.new_accounts applied_txn ) let apply_transactions_first_pass ~yield ~constraint_constants ~global_slot ~signature_kind ledger init_pending_coinbase_stack_state ts @@ -689,7 +681,7 @@ module T = struct let exception Statement_of_job_failure in let statement_of_job_exn job = Option.value_exn ~error:(Error.of_exn Statement_of_job_failure) - @@ Scan_state.statement_of_job job + @@ Scan_state.Available_job.statement job in try let job_statements = One_or_two.map ~f:statement_of_job_exn jobs in @@ -780,7 +772,7 @@ module T = struct List.fold_right ~init:(Ok []) data ~f:(fun (d : Scan_state.Transaction_with_witness.t) acc -> let%map.Or_error acc = acc in - let t = d.transaction_with_info |> Ledger.transaction_of_applied in + let t = d.transaction_with_status in t :: acc ) in let total_fee_excess txns = @@ -849,7 +841,7 @@ module T = struct ( is_new_stack , data , Pending_coinbase.Update.Action.Update_one - , `Update_one updated_stack + , Some (`One updated_stack) , `First_pass_ledger_end first_pass_ledger_end ) ) else (*Two partition: @@ -882,24 +874,24 @@ module T = struct match (coinbase_in_first_partition, second_has_data) with | true, true -> ( Pending_coinbase.Update.Action.Update_two_coinbase_in_first - , `Update_two (updated_stack1, updated_stack2) ) + , Some (`Two (updated_stack1, updated_stack2)) ) (* updated_stack2 does not have coinbase and but has the state from the previous stack *) | true, false -> (* updated_stack1 has some new coinbase but parition 2 has no data and so we have only one stack to update *) - (Update_one, `Update_one updated_stack1) + (Update_one, Some (`One updated_stack1)) | false, true -> (* updated_stack1 just has the new state. [updated stack2] might have coinbase, definitely has some data and therefore will have a non-dummy state. *) ( Update_two_coinbase_in_second - , `Update_two (updated_stack1, updated_stack2) ) + , Some (`Two (updated_stack1, updated_stack2)) ) | false, false -> (* a diff consists of only non-coinbase transactions. This is currently not possible because a diff will have a coinbase at the very least, so don't update anything? *) - (Update_none, `Update_none) + (Update_none, None) in [%log internal] "Update_coinbase_stack_done" ~metadata: @@ -935,7 +927,7 @@ module T = struct ( false , [] , Pending_coinbase.Update.Action.Update_none - , `Update_none + , None , `First_pass_ledger_end (Ledger.merkle_root ledger) ) ) ) (* Update the pending_coinbase tree with the updated/new stack and delete the @@ -946,14 +938,14 @@ module T = struct (* Deleting oldest stack if proof emitted *) let%bind pending_coinbase_collection_updated1 = match ledger_proof with - | Some (proof, _) -> + | Some proof -> let%bind oldest_stack, pending_coinbase_collection_updated1 = Pending_coinbase.remove_coinbase_stack ~depth pending_coinbase_collection |> to_staged_ledger_or_error in let ledger_proof_stack = - (Ledger_proof.Cached.statement proof).target.pending_coinbase_stack + (Ledger_proof.Tagged.statement proof).target.pending_coinbase_stack in let%map () = if Pending_coinbase.Stack.equal oldest_stack ledger_proof_stack then @@ -972,13 +964,13 @@ module T = struct in (* Updating the latest stack and/or adding a new one *) match stack_update with - | `Update_none -> + | None -> Ok pending_coinbase_collection_updated1 - | `Update_one stack1 -> + | Some (`One stack1) -> Pending_coinbase.update_coinbase_stack ~depth pending_coinbase_collection_updated1 stack1 ~is_new_stack |> to_staged_ledger_or_error - | `Update_two (stack1, stack2) -> + | Some (`Two (stack1, stack2)) -> (* The case when some of the transactions go into the old tree and remaining on to the new tree *) let%bind update1 = @@ -1003,20 +995,106 @@ module T = struct (Pre_diff_info.Error.Coinbase_error "More than two coinbase parts") ) - let apply_diff ?(skip_verification = false) ~logger ~constraint_constants - ~global_slot ~current_state_view ~state_and_body_hash ~log_prefix - ~zkapp_cmd_limit_hardcap ~signature_kind t pre_diff_info = + let log_scan_state_update_error ~logger ~witnesses ~previous_scan_state + ~log_prefix e = + let data_json = + `List + (List.map witnesses ~f:(fun tagged -> + Transaction_snark.Statement.to_yojson + @@ Scan_state.Transaction_with_witness.Tagged.statement tagged ) ) + in + [%log error] + ~metadata: + [ ( "scan_state" + , `String (Scan_state.snark_job_list_json previous_scan_state) ) + ; ("data", data_json) + ; ("error", Error_json.error_to_yojson e) + ; ("prefix", `String log_prefix) + ] + !"$prefix: Unexpected error when applying diff data $data to the \ + scan_state $scan_state: $error" + + let apply_to_scan_state ~logger ~skip_verification ~log_prefix ~ledger + ~previous_pending_coinbase_collection ~previous_scan_state + ~constraint_constants + { Scan_state.Application_data.is_new_stack + ; stack_update + ; first_pass_ledger_end + ; tagged_works + ; tagged_witnesses + } = + let open Deferred.Result.Let_syntax in + [%log internal] "Fill_work_and_enqueue_transactions" ; + let%bind res_opt, scan_state = + O1trace.thread "fill_work_and_enqueue_transactions" + @@ fun () -> + let r = + Scan_state.fill_work_and_enqueue_transactions previous_scan_state + ~logger tagged_witnesses tagged_works + in + Or_error.iter_error r + ~f: + (log_scan_state_update_error ~logger ~witnesses:tagged_witnesses + ~previous_scan_state ~log_prefix ) ; + Deferred.return (to_staged_ledger_or_error r) + in + let%bind () = yield_result () in + [%log internal] "Update_pending_coinbase_collection" ; + let%bind pending_coinbase_collection = + O1trace.thread "update_pending_coinbase_collection" (fun () -> + update_pending_coinbase_collection + ~depth: + constraint_constants + .Genesis_constants.Constraint_constants.pending_coinbase_depth + previous_pending_coinbase_collection stack_update ~is_new_stack + ~ledger_proof:res_opt + |> Deferred.return ) + in + let%bind () = yield_result () in + let%map () = + if skip_verification || List.is_empty tagged_witnesses then + Deferred.return (Ok ()) + else ( + [%log internal] "Verify_scan_state_after_apply" ; + O1trace.thread "verify_scan_state_after_apply" (fun () -> + let%bind pending_coinbase_stack = + Pending_coinbase.latest_stack ~is_new_stack:false + pending_coinbase_collection + |> to_staged_ledger_or_error |> Deferred.return + in + Deferred.( + verify_scan_state_after_apply ~constraint_constants ~logger + ~first_pass_ledger_end + ~second_pass_ledger_end: + (Frozen_ledger_hash.of_ledger_hash + (Ledger.merkle_root ledger) ) + ~pending_coinbase_stack scan_state + >>| to_staged_ledger_or_error) ) ) + in + ( { scan_state; ledger; constraint_constants; pending_coinbase_collection } + , res_opt ) + + (* TODO Remove hashing from first & second passes and then + remove Deferred.t from [apply_diff], now it's there only for yielding *) + let apply_diff_impl ~logger ~constraint_constants ~global_slot + ~parent_protocol_state_body ~state_and_body_hash ~log_prefix + ~zkapp_cmd_limit_hardcap ~signature_kind ~previous_scan_state + ~previous_pending_coinbase_collection ~previous_ledger pre_diff_info = let open Deferred.Result.Let_syntax in let max_throughput = - Int.pow 2 t.constraint_constants.transaction_capacity_log_2 + Int.pow 2 + constraint_constants + .Genesis_constants.Constraint_constants.transaction_capacity_log_2 in let spots_available, proofs_waiting = - let jobs = Scan_state.all_work_statements_exn t.scan_state in - ( Int.min (Scan_state.free_space t.scan_state) max_throughput + let jobs = Scan_state.all_work_statements_exn previous_scan_state in + ( Int.min (Scan_state.free_space previous_scan_state) max_throughput , List.length jobs ) in - let new_mask = Ledger.Mask.create ~depth:(Ledger.depth t.ledger) () in - let new_ledger = Ledger.register_mask t.ledger new_mask in + let new_mask = + Ledger.Mask.create ~depth:(Ledger.depth previous_ledger) () + in + let new_ledger = Ledger.register_mask previous_ledger new_mask in let transactions, works, commands_count, coinbases = pre_diff_info in let accounts_accessed = List.fold_left ~init:Account_id.Set.empty transactions ~f:(fun set txn -> @@ -1055,6 +1133,9 @@ module T = struct ; ("proofs_waiting", `Int proofs_waiting) ; ("max_throughput", `Int max_throughput) ] ; + let current_state_view = + Mina_state.Protocol_state.(Body.view parent_protocol_state_body) + in let%bind ( is_new_stack , data , stack_update_in_snark @@ -1062,27 +1143,37 @@ module T = struct , `First_pass_ledger_end first_pass_ledger_end ) = O1trace.thread "update_coinbase_stack_start_time" (fun () -> update_coinbase_stack_and_get_data ~logger ~constraint_constants - ~global_slot ~signature_kind t.scan_state new_ledger - t.pending_coinbase_collection transactions current_state_view + ~global_slot ~signature_kind previous_scan_state new_ledger + previous_pending_coinbase_collection transactions current_state_view state_and_body_hash ) in + let to_witness (witness, _) = + { witness with + Transaction_snark_scan_state.Transaction_with_witness + .previous_protocol_state_body_opt = Some parent_protocol_state_body + } + in + let witnesses = List.map data ~f:to_witness in let slots = List.length data in let work_count = List.length works in - let required_pairs = Scan_state.work_statements_for_new_diff t.scan_state in + let required_pairs = + Scan_state.work_statements_for_new_diff previous_scan_state + in [%log internal] "Check_for_sufficient_snark_work" ~metadata: [ ("required_pairs", `Int (List.length required_pairs)) ; ("work_count", `Int work_count) ; ("slots", `Int slots) - ; ("free_space", `Int (Scan_state.free_space t.scan_state)) + ; ("free_space", `Int (Scan_state.free_space previous_scan_state)) ] ; let%bind () = O1trace.thread "check_for_sufficient_snark_work" (fun () -> let required = List.length required_pairs in if work_count < required - && List.length data - > Scan_state.free_space t.scan_state - required + work_count + && slots + > Scan_state.free_space previous_scan_state + - required + work_count then Deferred.Result.fail (Staged_ledger_error.Insufficient_work @@ -1093,68 +1184,8 @@ module T = struct else Deferred.Result.return () ) in [%log internal] "Check_zero_fee_excess" ; - let%bind () = Deferred.return (check_zero_fee_excess t.scan_state data) in - [%log internal] "Fill_work_and_enqueue_transactions" ; - let%bind res_opt, scan_state' = - O1trace.thread "fill_work_and_enqueue_transactions" (fun () -> - let r = - Scan_state.fill_work_and_enqueue_transactions t.scan_state ~logger - data works - in - Or_error.iter_error r ~f:(fun e -> - let data_json = - `List - (List.map data - ~f:(fun - { Scan_state.Transaction_with_witness.statement; _ } - -> Transaction_snark.Statement.to_yojson statement ) ) - in - [%log error] - ~metadata: - [ ( "scan_state" - , `String (Scan_state.snark_job_list_json t.scan_state) ) - ; ("data", data_json) - ; ("error", Error_json.error_to_yojson e) - ; ("prefix", `String log_prefix) - ] - !"$prefix: Unexpected error when applying diff data $data to \ - the scan_state $scan_state: $error" ) ; - Deferred.return (to_staged_ledger_or_error r) ) - in - let%bind () = yield_result () in - [%log internal] "Update_pending_coinbase_collection" ; - let%bind updated_pending_coinbase_collection' = - O1trace.thread "update_pending_coinbase_collection" (fun () -> - update_pending_coinbase_collection - ~depth:t.constraint_constants.pending_coinbase_depth - t.pending_coinbase_collection stack_update ~is_new_stack - ~ledger_proof:res_opt - |> Deferred.return ) - in - let%bind () = yield_result () in - let%bind coinbase_amount = - Deferred.return (coinbase_for_blockchain_snark coinbases) - in - let%bind latest_pending_coinbase_stack = - Pending_coinbase.latest_stack ~is_new_stack:false - updated_pending_coinbase_collection' - |> to_staged_ledger_or_error |> Deferred.return - in - let%bind () = yield_result () in - let%map () = - if skip_verification || List.is_empty data then Deferred.return (Ok ()) - else ( - [%log internal] "Verify_scan_state_after_apply" ; - O1trace.thread "verify_scan_state_after_apply" (fun () -> - Deferred.( - verify_scan_state_after_apply ~constraint_constants ~logger - ~first_pass_ledger_end - ~second_pass_ledger_end: - (Frozen_ledger_hash.of_ledger_hash - (Ledger.merkle_root new_ledger) ) - ~pending_coinbase_stack:latest_pending_coinbase_stack - scan_state' - >>| to_staged_ledger_or_error) ) ) + let%bind () = + Deferred.return (check_zero_fee_excess previous_scan_state witnesses) in [%log debug] ~metadata: @@ -1170,30 +1201,39 @@ module T = struct \ Coinbase parts:$coinbase_count Spots\n\ \ available:$spots_available Pending work in the \ scan-state:$proof_bundles_waiting Work included:$work_count" ; - let new_staged_ledger = - { scan_state = scan_state' - ; ledger = new_ledger - ; constraint_constants = t.constraint_constants - ; pending_coinbase_collection = updated_pending_coinbase_collection' - } + let accounts_created = List.concat_map data ~f:snd in + let%map coinbase_amount = + Deferred.return (coinbase_for_blockchain_snark coinbases) in - ( `Ledger_proof res_opt - , `Staged_ledger new_staged_ledger + ( `Ledger new_ledger + , `Accounts_created accounts_created + , `Stack_update stack_update + , `First_pass_ledger_end first_pass_ledger_end + , `Witnesses witnesses + , `Works works , `Pending_coinbase_update ( is_new_stack , { Pending_coinbase.Update.Poly.action = stack_update_in_snark ; coinbase_amount } ) ) - let update_metrics (t : t) (witness : Staged_ledger_diff.t) = - let open Or_error.Let_syntax in + let update_scan_state_metrics scan_state = + let%bind.Or_error () = Scan_state.update_metrics scan_state in + Or_error.try_with (fun () -> + let open Mina_metrics in + Gauge.set Scan_state_metrics.snark_work_required + (Float.of_int + (List.length (Scan_state.all_work_statements_exn scan_state)) ) ) + + let update_diff_metrics (witness : Staged_ledger_diff.t) = let commands = Staged_ledger_diff.commands witness in let work = Staged_ledger_diff.completed_works witness in - let%bind total_txn_fee = + let%bind.Or_error total_txn_fee = sum_fees commands ~f:(fun { data = cmd; _ } -> User_command.fee cmd) in - let%bind total_snark_fee = sum_fees work ~f:Transaction_snark_work.fee in - let%bind () = Scan_state.update_metrics t.scan_state in + let%bind.Or_error total_snark_fee = + sum_fees work ~f:Transaction_snark_work.fee + in Or_error.try_with (fun () -> let open Mina_metrics in Gauge.set Scan_state_metrics.snark_fee_per_block @@ -1201,10 +1241,7 @@ module T = struct Gauge.set Scan_state_metrics.transaction_fees_per_block (Int.to_float @@ Fee.to_nanomina_int total_txn_fee) ; Gauge.set Scan_state_metrics.purchased_snark_work_per_block - (Float.of_int @@ List.length work) ; - Gauge.set Scan_state_metrics.snark_work_required - (Float.of_int - (List.length (Scan_state.all_work_statements_exn t.scan_state)) ) ) + (Float.of_int @@ List.length work) ) let forget_prediff_info ((a : Transaction.Valid.t With_status.t list), b, c, d) = @@ -1212,14 +1249,14 @@ module T = struct type transaction_pool_proxy = Check_commands.transaction_pool_proxy - let apply ?skip_verification ~constraint_constants ~global_slot - ~get_completed_work ~logger ~verifier ~current_state_view + let apply_diff ?skip_verification ~constraint_constants ~global_slot + ~get_completed_work ~logger ~verifier ~parent_protocol_state_body ~state_and_body_hash ~coinbase_receiver ~supercharge_coinbase ~zkapp_cmd_limit_hardcap ~signature_kind ?(transaction_pool_proxy = Check_commands.dummy_transaction_pool_proxy) t - (witness : Staged_ledger_diff.t) = + (staged_ledger_diff : Staged_ledger_diff.t) = let open Deferred.Result.Let_syntax in - let work = Staged_ledger_diff.completed_works witness in + let work = Staged_ledger_diff.completed_works staged_ledger_diff in let%bind () = O1trace.thread "check_completed_works" (fun () -> match skip_verification with @@ -1231,48 +1268,58 @@ module T = struct check_completed_works ~get_completed_work ~logger ~verifier t.scan_state work ) in + let check_commands txs hashes = + match skip_verification with + | Some `All -> + let f { With_status.data = tx; _ } = + (* Skipping verification when [`All] is provided (this + is used only when loading an already verified + transition from disk). *) + let (`If_this_is_used_it_should_have_a_comment_justifying_it tx') = + User_command.to_valid_unsafe tx + in + tx' + in + let res = List.map ~f txs in + Deferred.Result.return (Ok res) + | _ -> + Check_commands.check_commands t.ledger ~verifier + ~transaction_pool_proxy txs hashes + in [%log internal] "Prediff" ; let%bind prediff = - Pre_diff_info.get witness ~constraint_constants ~coinbase_receiver - ~supercharge_coinbase - ~check: - (Check_commands.check_commands t.ledger ~verifier - ~transaction_pool_proxy ) + Pre_diff_info.get staged_ledger_diff ~constraint_constants + ~coinbase_receiver ~supercharge_coinbase ~check:check_commands |> Deferred.map ~f: (Result.map_error ~f:(fun error -> Staged_ledger_error.Pre_diff error ) ) in let apply_diff_start_time = Core.Time.now () in - [%log internal] "Apply_diff" ; - let%map ((_, `Staged_ledger new_staged_ledger, _) as res) = - apply_diff - ~skip_verification: - ([%equal: [ `All | `Proofs ] option] skip_verification (Some `All)) - ~constraint_constants ~global_slot t + let%map res = + apply_diff_impl ~constraint_constants ~global_slot + ~previous_scan_state:t.scan_state + ~previous_pending_coinbase_collection:t.pending_coinbase_collection + ~previous_ledger:t.ledger (forget_prediff_info prediff) - ~logger ~current_state_view ~state_and_body_hash + ~logger ~parent_protocol_state_body ~state_and_body_hash ~log_prefix:"apply_diff" ~zkapp_cmd_limit_hardcap ~signature_kind in - [%log internal] "Diff_applied" ; + Or_error.iter_error (update_diff_metrics staged_ledger_diff) ~f:(fun e -> + [%log error] + ~metadata:[ ("error", Error_json.error_to_yojson e) ] + !"Error updating metrics after applying diff: $error" ) ; [%log debug] ~metadata: [ ( "time_elapsed" , `Float Core.Time.(Span.to_ms @@ diff (now ()) apply_diff_start_time) ) ] - "Staged_ledger.apply_diff take $time_elapsed" ; - let () = - Or_error.iter_error (update_metrics new_staged_ledger witness) - ~f:(fun e -> - [%log error] - ~metadata:[ ("error", Error_json.error_to_yojson e) ] - !"Error updating metrics after applying staged_ledger diff: $error" ) - in + "Staged_ledger.apply_diff takes $time_elapsed" ; res let apply_diff_unchecked ~constraint_constants ~global_slot ~logger - ~current_state_view ~state_and_body_hash ~coinbase_receiver + ~parent_protocol_state_body ~state_and_body_hash ~coinbase_receiver ~supercharge_coinbase ~zkapp_cmd_limit_hardcap ~signature_kind t (sl_diff : Staged_ledger_diff.With_valid_signatures_and_proofs.t) = let open Deferred.Result.Let_syntax in @@ -1282,16 +1329,20 @@ module T = struct ~supercharge_coinbase sl_diff |> Deferred.return in - apply_diff t + apply_diff_impl ~constraint_constants ~global_slot + ~previous_scan_state:t.scan_state + ~previous_pending_coinbase_collection:t.pending_coinbase_collection + ~previous_ledger:t.ledger (forget_prediff_info prediff) - ~constraint_constants ~global_slot ~logger ~current_state_view - ~state_and_body_hash ~log_prefix:"apply_diff_unchecked" - ~zkapp_cmd_limit_hardcap ~signature_kind + ~logger ~parent_protocol_state_body ~state_and_body_hash + ~log_prefix:"apply_diff_unchecked" ~zkapp_cmd_limit_hardcap + ~signature_kind module Resources = struct module Discarded = struct type t = - { commands_rev : User_command.Valid.t Sequence.t + { commands_rev : + Transaction_hash.User_command_with_valid_signature.t Sequence.t ; completed_work : Transaction_snark_work.Checked.t Sequence.t } @@ -1311,7 +1362,8 @@ module T = struct { max_space : int (*max space available currently*) ; max_jobs : int (*Required amount of work for max_space that can be purchased*) - ; commands_rev : User_command.Valid.t Sequence.t + ; commands_rev : + Transaction_hash.User_command_with_valid_signature.t Sequence.t ; completed_work_rev : Transaction_snark_work.Checked.t Sequence.t ; fee_transfers : Fee.t Public_key.Compressed.Map.t ; add_coinbase : bool @@ -1464,7 +1516,9 @@ module T = struct in (coinbase, singles) - let init ~constraint_constants (uc_seq : User_command.Valid.t Sequence.t) + let init ~constraint_constants + (uc_seq : + Transaction_hash.User_command_with_valid_signature.t Sequence.t ) (cw_seq : Transaction_snark_work.Checked.t Sequence.t) (slots, job_count) ~receiver_pk ~add_coinbase ~supercharge_coinbase logger ~is_coinbase_receiver_new = @@ -1490,7 +1544,9 @@ module T = struct let budget = Or_error.map2 (sum_fees (Sequence.to_list uc_seq) ~f:(fun t -> - User_command.fee (User_command.forget_check t) ) ) + User_command.fee + (Transaction_hash.User_command_with_valid_signature.command t) ) + ) (sum_fees (List.filter ~f:(fun (k, _) -> @@ -1507,11 +1563,11 @@ module T = struct in { max_space = slots ; max_jobs = job_count - ; commands_rev = - uc_seq + ; commands_rev = uc_seq + ; completed_work_rev = + seq_rev cw_seq (* Completed work in reverse order for faster removal of proofs if budget doesn't suffice *) - ; completed_work_rev = seq_rev cw_seq ; fee_transfers ; add_coinbase ; supercharge_coinbase @@ -1573,7 +1629,8 @@ module T = struct let open Or_error.Let_syntax in let payment_fees = sum_fees (Sequence.to_list t.commands_rev) ~f:(fun t -> - User_command.(fee (forget_check t)) ) + User_command.fee + (Transaction_hash.User_command_with_valid_signature.command t) ) in let prover_fee_others = Public_key.Compressed.Map.fold t.fee_transfers ~init:(Ok Fee.zero) @@ -1707,7 +1764,11 @@ module T = struct match t.budget with | Ok b -> option "Fee insufficient" - (Fee.sub b User_command.(fee (forget_check uc))) + (Fee.sub b + User_command.( + fee + (Transaction_hash.User_command_with_valid_signature + .command uc )) ) | _ -> rebudget new_t in @@ -1798,7 +1859,8 @@ module T = struct check_constraints_and_update ~constraint_constants resources' (Option.value_map uc_opt ~default:log ~f:(fun uc -> Diff_creation_log.discard_command `No_space - (User_command.forget_check uc) + (Transaction_hash.User_command_with_valid_signature.command + uc ) log ) ) else (* insufficient budget; reduce the cost*) @@ -1816,7 +1878,7 @@ module T = struct check_constraints_and_update ~constraint_constants resources' (Option.value_map uc_opt ~default:log ~f:(fun uc -> Diff_creation_log.discard_command `No_work - (User_command.forget_check uc) + (Transaction_hash.User_command_with_valid_signature.command uc) log ) ) let one_prediff ~constraint_constants cw_seq ts_seq ~receiver ~add_coinbase @@ -1857,25 +1919,42 @@ module T = struct coinbase in the second pre_diff" ; Zero in + let command_lst = Sequence.to_list res.commands_rev in (* We have to reverse here because we only know they work in THIS order *) - { Staged_ledger_diff.Pre_diff_one.commands = - Sequence.to_list_rev res.commands_rev + { Staged_ledger_diff.Pre_diff_generic.commands = + List.rev_map + ~f:Transaction_hash.User_command_with_valid_signature.data + command_lst ; completed_works = Sequence.to_list_rev res.completed_work_rev ; coinbase = to_at_most_one res.coinbase ; internal_command_statuses = [] (*updated later based on application result*) + ; command_hashes = + List.rev_map + ~f: + Transaction_hash.User_command_with_valid_signature + .transaction_hash command_lst } ) in let pre_diff_with_two (res : Resources.t) : ( Transaction_snark_work.Checked.t , User_command.Valid.t ) Staged_ledger_diff.Pre_diff_two.t = + let command_lst = Sequence.to_list res.commands_rev in (* We have to reverse here because we only know they work in THIS order *) - { commands = Sequence.to_list_rev res.commands_rev + { commands = + List.rev_map + ~f:Transaction_hash.User_command_with_valid_signature.data + command_lst ; completed_works = Sequence.to_list_rev res.completed_work_rev ; coinbase = res.coinbase ; internal_command_statuses = [] (*updated later based on application result*) + ; command_hashes = + List.rev_map + ~f: + Transaction_hash.User_command_with_valid_signature + .transaction_hash command_lst } in let end_log ((res : Resources.t), (log : Diff_creation_log.t)) = @@ -2007,94 +2086,13 @@ module T = struct : Ledger.unattached_mask ) ; r - module Application_state = struct - type txn = - ( Signed_command.With_valid_signature.t - , Zkapp_command.Valid.t ) - User_command.t_ - - type t = - { valid_seq : txn Sequence.t - ; invalid : (txn * Error.t) list - ; skipped_by_fee_payer : txn list Account_id.Map.t - ; zkapp_space_remaining : int option - ; total_space_remaining : int - } - - let init ?zkapp_limit ~total_limit = - { valid_seq = Sequence.empty - ; invalid = [] - ; skipped_by_fee_payer = Account_id.Map.empty - ; zkapp_space_remaining = zkapp_limit - ; total_space_remaining = total_limit - } - - let txn_key = function - | User_command.Zkapp_command cmd -> - Zkapp_command.(Valid.forget cmd |> fee_payer) - | User_command.Signed_command cmd -> - Signed_command.(forget_check cmd |> fee_payer) - - let add_skipped_txn t (txn : txn) = - Account_id.Map.update t.skipped_by_fee_payer (txn_key txn) - ~f:(Option.value_map ~default:[ txn ] ~f:(List.cons txn)) - - let dependency_skipped txn t = - Account_id.Map.mem t.skipped_by_fee_payer (txn_key txn) - - let try_applying_txn ?logger ~apply (state : t) (txn : txn) = - let open Continue_or_stop in - match (state.zkapp_space_remaining, txn) with - | _ when state.total_space_remaining < 1 -> - Stop (state.valid_seq, state.invalid) - | Some zkapp_limit, User_command.Zkapp_command _ when zkapp_limit < 1 -> - Continue - { state with skipped_by_fee_payer = add_skipped_txn state txn } - | Some _, _ when dependency_skipped txn state -> - Continue - { state with skipped_by_fee_payer = add_skipped_txn state txn } - | _ -> ( - match - O1trace.sync_thread "validate_transaction_against_staged_ledger" - (fun () -> - apply (Transaction.Command (User_command.forget_check txn)) ) - with - | Error e -> - Option.iter logger ~f:(fun logger -> - [%log error] - ~metadata: - [ ("user_command", User_command.Valid.to_yojson txn) - ; ("error", Error_json.error_to_yojson e) - ] - "Staged_ledger_diff creation: Skipping user command: \ - $user_command due to error: $error" ) ; - Continue { state with invalid = (txn, e) :: state.invalid } - | Ok _txn_partially_applied -> - let valid_seq = - Sequence.append (Sequence.singleton txn) state.valid_seq - in - let zkapp_space_remaining = - Option.map state.zkapp_space_remaining ~f:(fun limit -> - match txn with - | Zkapp_command _ -> - limit - 1 - | Signed_command _ -> - limit ) - in - Continue - { state with - valid_seq - ; zkapp_space_remaining - ; total_space_remaining = state.total_space_remaining - 1 - } ) - end - let create_diff ~(constraint_constants : Genesis_constants.Constraint_constants.t) ~(global_slot : Mina_numbers.Global_slot_since_genesis.t) ?(log_block_creation = false) t ~coinbase_receiver ~logger ~current_state_view ~zkapp_cmd_limit - ~(transactions_by_fee : User_command.Valid.t Sequence.t) + ~(transactions_by_fee : + Transaction_hash.User_command_with_valid_signature.t Sequence.t ) ~(get_completed_work : Transaction_snark_work.Statement.t -> Transaction_snark_work.Checked.t option ) ~supercharge_coinbase = @@ -2209,7 +2207,9 @@ module T = struct ~init: (Application_state.init ?zkapp_limit:zkapp_cmd_limit ~total_limit:(Scan_state.free_space t.scan_state) ) - ~f:(Application_state.try_applying_txn ~apply ~logger) + ~f: + (Application_state.Valid_user_command_with_hash + .try_applying_txn ~apply ~logger ) ~finish:(fun state -> (state.valid_seq, state.invalid)) in [%log internal] "Generate_staged_ledger_diff" ; @@ -2260,39 +2260,6 @@ module T = struct ( { Staged_ledger_diff.With_valid_signatures_and_proofs.diff } , invalid_on_this_ledger ) ) ) - let latest_block_accounts_created t ~previous_block_state_hash = - let scan_state = scan_state t in - (* filter leaves by state hash from previous block *) - let block_transactions_applied = - let f - ({ state_hash = leaf_block_hash, _; transaction_with_info; _ } : - Scan_state.Transaction_with_witness.t ) = - if State_hash.equal leaf_block_hash previous_block_state_hash then - Some transaction_with_info.varying - else None - in - List.filter_map (Scan_state.base_jobs_on_latest_tree scan_state) ~f - @ List.filter_map - (Scan_state.base_jobs_on_earlier_tree ~index:0 scan_state) - ~f - in - List.map block_transactions_applied ~f:(function - | Command (Signed_command cmd) -> ( - match cmd.body with - | Payment { new_accounts } -> - new_accounts - | Stake_delegation _ -> - [] - | Failed -> - [] ) - | Command (Zkapp_command { new_accounts; _ }) -> - new_accounts - | Fee_transfer { new_accounts; _ } -> - new_accounts - | Coinbase { new_accounts; _ } -> - new_accounts ) - |> List.concat - let convert_and_apply_all_masks_to_ledger ~hardfork_db ({ ledger; _ } : t) = let accounts = Ledger.all_accounts_on_masks ledger @@ -2305,6 +2272,10 @@ end include T +module For_tests = struct + module Application_state = Application_state +end + module Test_helpers = struct let constraint_constants = Genesis_constants.For_unit_tests.Constraint_constants.t @@ -2354,12 +2325,15 @@ module Test_helpers = struct (Mina_state.Protocol_state.previous_state_hash state) ~body in + let parent_protocol_state_body = + Mina_state.Protocol_state.body state_with_global_slot + in ( state_with_global_slot - , Mina_state.Protocol_state.Body.view - (Mina_state.Protocol_state.body state_with_global_slot) ) + , Mina_state.Protocol_state.Body.view parent_protocol_state_body + , parent_protocol_state_body ) let dummy_state_view ?global_slot () = - dummy_state_and_view ?global_slot () |> snd + dummy_state_and_view ?global_slot () |> fun (_, view, _) -> view let update_coinbase_stack_and_get_data_impl = update_coinbase_stack_and_get_data_impl @@ -2418,9 +2392,57 @@ let%test_module "staged ledger tests" = in Sl.can_apply_supercharged_coinbase_exn ~winner ~global_slot ~epoch_ledger + let apply_diff_full ~constraint_constants ~global_slot t diff ~logger + ~verifier ~get_completed_work ~parent_protocol_state_body + ~state_and_body_hash ~coinbase_receiver ~supercharge_coinbase + ~zkapp_cmd_limit_hardcap ~signature_kind = + let%bind.Deferred.Result ( `Ledger new_ledger + , `Accounts_created _ + , `Stack_update stack_update + , `First_pass_ledger_end first_pass_ledger_end + , `Witnesses witnesses + , `Works works + , `Pending_coinbase_update + (is_new_stack, pending_coinbase_update_action) + ) = + Sl.apply_diff ~constraint_constants ~global_slot t diff ~logger + ~verifier ~get_completed_work ~parent_protocol_state_body + ~state_and_body_hash ~coinbase_receiver ~supercharge_coinbase + ~zkapp_cmd_limit_hardcap ~signature_kind + in + (* For test it is not important which file to write to *) + let state_hash = Quickcheck.random_value State_hash.gen in + let tagged_witnesses, tagged_works = + State_hash.File_storage.write_values_exn state_hash ~f:(fun writer -> + let witnesses' = + Scan_state.Transaction_with_witness.persist_many witnesses writer + in + let works' = + Scan_state.Ledger_proof_with_sok_message.persist_many works writer + in + (witnesses', works') ) + in + let data = + { Scan_state.Application_data.is_new_stack + ; stack_update + ; first_pass_ledger_end + ; tagged_works + ; tagged_witnesses + } + in + let%map.Deferred.Result new_staged_ledger, res_opt = + apply_to_scan_state ~logger ~skip_verification:false + ~log_prefix:"apply_diff" ~ledger:new_ledger + ~previous_pending_coinbase_collection:t.pending_coinbase_collection + ~previous_scan_state:t.scan_state ~constraint_constants data + in + ( `Ledger_proof res_opt + , `Staged_ledger new_staged_ledger + , `Pending_coinbase_update (is_new_stack, pending_coinbase_update_action) + ) + (* Functor for testing with different instantiated staged ledger modules. *) - let create_and_apply_with_state_body_hash - ~(current_state_view : Zkapp_precondition.Protocol_state.View.t) + let create_and_apply_with_state_body_hash ~parent_protocol_state_body ~global_slot ~state_and_body_hash ~signature_kind ?zkapp_cmd_limit ?(coinbase_receiver = coinbase_receiver) ?(winner = self_pk) sl txns stmt_to_work = @@ -2428,9 +2450,16 @@ let%test_module "staged ledger tests" = let supercharge_coinbase = supercharge_coinbase ~ledger:(Sl.ledger !sl) ~winner ~global_slot in + let current_state_view = + Mina_state.Protocol_state.(Body.view parent_protocol_state_body) + in + let transactions_by_fee = + Sequence.map txns + ~f:Transaction_hash.User_command_with_valid_signature.create + in let diff = Sl.create_diff ~constraint_constants ~global_slot !sl ~logger - ~current_state_view ~transactions_by_fee:txns + ~current_state_view ~transactions_by_fee ~get_completed_work:stmt_to_work ~supercharge_coinbase ~coinbase_receiver ~zkapp_cmd_limit in @@ -2446,10 +2475,10 @@ let%test_module "staged ledger tests" = , `Staged_ledger sl' , `Pending_coinbase_update (is_new_stack, pc_update) ) = match%map - Sl.apply ~constraint_constants ~global_slot !sl diff' ~logger - ~verifier ~get_completed_work:(Fn.const None) ~current_state_view - ~state_and_body_hash ~coinbase_receiver ~supercharge_coinbase - ~zkapp_cmd_limit_hardcap ~signature_kind + apply_diff_full ~constraint_constants ~global_slot !sl diff' ~logger + ~verifier ~get_completed_work:(Fn.const None) + ~parent_protocol_state_body ~state_and_body_hash ~coinbase_receiver + ~supercharge_coinbase ~zkapp_cmd_limit_hardcap ~signature_kind with | Ok x -> x @@ -2462,13 +2491,13 @@ let%test_module "staged ledger tests" = (ledger_proof, diff', is_new_stack, pc_update, supercharge_coinbase) let create_and_apply ?(coinbase_receiver = coinbase_receiver) - ?(winner = self_pk) ~global_slot ~protocol_state_view + ?(winner = self_pk) ~global_slot ~parent_protocol_state_body ~state_and_body_hash ~signature_kind sl txns stmt_to_work = let open Deferred.Let_syntax in let%map ledger_proof, diff, _, _, _ = create_and_apply_with_state_body_hash ~coinbase_receiver ~winner - ~current_state_view:protocol_state_view ~global_slot - ~state_and_body_hash sl txns stmt_to_work ~signature_kind + ~parent_protocol_state_body ~global_slot ~state_and_body_hash sl txns + stmt_to_work ~signature_kind in (ledger_proof, diff) @@ -2687,18 +2716,11 @@ let%test_module "staged ledger tests" = |> Sequence.to_list (* Fee excess at top level ledger proofs should always be zero *) - let assert_fee_excess : - ( Ledger_proof.Cached.t - * (Transaction.t With_status.t * _ * _) - Sl.Scan_state.Transactions_ordered.Poly.t - list ) - option - -> unit = + let assert_fee_excess : Ledger_proof.Tagged.t option -> unit = fun proof_opt -> let fee_excess = - Option.value_map ~default:Fee_excess.zero proof_opt - ~f:(fun (proof, _txns) -> - (Ledger_proof.Cached.statement proof).fee_excess ) + Option.value_map ~default:Fee_excess.zero proof_opt ~f:(fun proof -> + (Ledger_proof.Tagged.statement proof).fee_excess ) in assert (Fee_excess.is_zero fee_excess) @@ -2767,7 +2789,7 @@ let%test_module "staged ledger tests" = in let state_tbl = State_hash.Table.create () in (*Add genesis state to the table*) - let genesis, _ = dummy_state_and_view () in + let genesis, _, _ = dummy_state_and_view () in let state_hash = (Mina_state.Protocol_state.hashes genesis).state_hash in State_hash.Table.add state_tbl ~key:state_hash ~data:genesis |> ignore ; let%map `Proof_count total_ledger_proofs, _ = @@ -2775,7 +2797,7 @@ let%test_module "staged ledger tests" = (`Proof_count 0, `Slot global_slot) (fun cmds_left count_opt cmds_this_iter (`Proof_count proof_count, `Slot global_slot) -> - let current_state, current_view = + let current_state, current_view, parent_protocol_state_body = dummy_state_and_view ~global_slot () in let state_hash = @@ -2784,7 +2806,7 @@ let%test_module "staged ledger tests" = State_hash.Table.add state_tbl ~key:state_hash ~data:current_state |> ignore ; let%bind ledger_proof, diff = - create_and_apply ~global_slot ~protocol_state_view:current_view + create_and_apply ~global_slot ~parent_protocol_state_body ~state_and_body_hash: ( state_hash , (Mina_state.Protocol_state.hashes current_state) @@ -2825,7 +2847,7 @@ let%test_module "staged ledger tests" = in let%bind () = match proof_opt with - | Some (proof, _transactions) -> + | Some proof -> (*update snarked ledger with the transactions in the most recently emitted proof*) let%map res = Sl.Scan_state.get_snarked_ledger_async @@ -2835,7 +2857,7 @@ let%test_module "staged ledger tests" = !sl.scan_state in let target_snarked_ledger = - let stmt = Ledger_proof.Cached.statement proof in + let stmt = Ledger_proof.Tagged.statement proof in stmt.target.first_pass_ledger in [%test_eq: Ledger_hash.t] target_snarked_ledger @@ -3339,7 +3361,10 @@ let%test_module "staged ledger tests" = @@ ( { completed_works = List.take completed_works job_count1 ; commands = List.take txns slots ; coinbase = Zero - ; internal_command_statuses = [] + ; internal_command_statuses = + [] + (* Skipping hash computation, as they shouldn't affect status computation *) + ; command_hashes = [] } , None ) | Some (_, _) -> @@ -3348,7 +3373,10 @@ let%test_module "staged ledger tests" = ( { completed_works = List.take completed_works job_count1 ; commands = List.take txns slots ; coinbase = Zero - ; internal_command_statuses = [] + ; internal_command_statuses = + [] + (* Skipping hash computation, as they shouldn't affect status computation *) + ; command_hashes = [] } , Some { completed_works = @@ -3356,7 +3384,10 @@ let%test_module "staged ledger tests" = else List.drop completed_works job_count1 ) ; commands = txns_in_second_diff ; coinbase = Zero - ; internal_command_statuses = [] + ; internal_command_statuses = + [] + (* Skipping hash computation, as they shouldn't affect status computation *) + ; command_hashes = [] } ) in let empty_diff = Staged_ledger_diff.empty_diff in @@ -3401,16 +3432,17 @@ let%test_module "staged ledger tests" = ~coinbase_amount:constraint_constants.coinbase_amount ~global_slot cmds_this_iter work_done partitions in - let current_state, current_view = + let current_state, _, parent_protocol_state_body = dummy_state_and_view ~global_slot () in let state_hashes = Mina_state.Protocol_state.hashes current_state in let%bind apply_res = - Sl.apply ~constraint_constants ~global_slot !sl diff - ~logger ~verifier ~get_completed_work:(Fn.const None) - ~current_state_view:current_view + apply_diff_full ~constraint_constants ~global_slot !sl + diff ~logger ~verifier + ~get_completed_work:(Fn.const None) + ~parent_protocol_state_body ~state_and_body_hash: ( state_hashes.state_hash , state_hashes.state_body_hash |> Option.value_exn ) @@ -3483,10 +3515,15 @@ let%test_module "staged ledger tests" = Mina_numbers.Global_slot_since_genesis.of_int global_slot in let current_state_view = dummy_state_view ~global_slot () in + let transactions_by_fee = + Sequence.map cmds_this_iter + ~f: + Transaction_hash.User_command_with_valid_signature + .create + in let diff_result = Sl.create_diff ~constraint_constants ~global_slot !sl - ~logger ~current_state_view - ~transactions_by_fee:cmds_this_iter + ~logger ~current_state_view ~transactions_by_fee ~get_completed_work:stmt_to_work ~coinbase_receiver ~supercharge_coinbase:true ~zkapp_cmd_limit:None in @@ -3549,7 +3586,7 @@ let%test_module "staged ledger tests" = let global_slot = Mina_numbers.Global_slot_since_genesis.of_int global_slot in - let current_state, current_state_view = + let current_state, current_state_view, parent_protocol_state_body = dummy_state_and_view ~global_slot () in let state_and_body_hash = @@ -3561,8 +3598,7 @@ let%test_module "staged ledger tests" = in let%map proof, diff = create_and_apply ~global_slot ~state_and_body_hash - ~protocol_state_view:current_state_view ~signature_kind sl - cmds_this_iter + ~parent_protocol_state_body ~signature_kind sl cmds_this_iter (stmt_to_work_restricted (List.take work_list proofs_available_this_iter) provers ) @@ -3747,7 +3783,7 @@ let%test_module "staged ledger tests" = let global_slot = Mina_numbers.Global_slot_since_genesis.of_int global_slot in - let current_state, current_state_view = + let current_state, _, parent_protocol_state_body = dummy_state_and_view ~global_slot () in let state_and_body_hash = @@ -3758,9 +3794,8 @@ let%test_module "staged ledger tests" = , state_hashes.state_body_hash |> Option.value_exn ) in let%map _proof, diff = - create_and_apply ~global_slot - ~protocol_state_view:current_state_view ~state_and_body_hash - ~signature_kind sl cmds_this_iter + create_and_apply ~global_slot ~state_and_body_hash + ~parent_protocol_state_body ~signature_kind sl cmds_this_iter (stmt_to_work_random_fee work_to_be_done provers) in let sorted_work_from_diff1 @@ -3974,7 +4009,7 @@ let%test_module "staged ledger tests" = List.hd_exn proofs_available_left in let sl_before = !sl in - let current_state, current_state_view = + let current_state, current_state_view, parent_protocol_state_body = dummy_state_and_view ~global_slot () in let state_and_body_hash = @@ -3985,7 +4020,7 @@ let%test_module "staged ledger tests" = , state_hashes.state_body_hash |> Option.value_exn ) in let%map proof, diff, is_new_stack, pc_update, supercharge_coinbase = - create_and_apply_with_state_body_hash ~current_state_view + create_and_apply_with_state_body_hash ~parent_protocol_state_body ~global_slot ~state_and_body_hash ~signature_kind sl cmds_this_iter (stmt_to_work_restricted @@ -4107,7 +4142,7 @@ let%test_module "staged ledger tests" = let global_slot = Mina_numbers.Global_slot_since_genesis.of_int block_count in - let current_state, current_state_view = + let current_state, _, parent_protocol_state_body = dummy_state_and_view ~global_slot () in let state_and_body_hash = @@ -4118,7 +4153,7 @@ let%test_module "staged ledger tests" = let%bind _ = create_and_apply_with_state_body_hash ~winner:delegator.public_key ~coinbase_receiver:coinbase_receiver.public_key sl - ~current_state_view + ~parent_protocol_state_body ~global_slot: (Mina_numbers.Global_slot_since_genesis.of_int block_count) ~state_and_body_hash ~signature_kind Sequence.empty @@ -4334,7 +4369,11 @@ let%test_module "staged ledger tests" = let diff_result = Sl.create_diff ~constraint_constants ~global_slot !sl ~logger ~current_state_view - ~transactions_by_fee:(Sequence.of_list [ invalid_command ]) + ~transactions_by_fee: + (Sequence.singleton + ( invalid_command + |> Transaction_hash.User_command_with_valid_signature + .create ) ) ~get_completed_work:(stmt_to_work_zero_fee ~prover:self_pk) ~coinbase_receiver ~supercharge_coinbase:false ~zkapp_cmd_limit:None @@ -4413,7 +4452,8 @@ let%test_module "staged ledger tests" = let global_slot = Mina_numbers.Global_slot_since_genesis.of_int global_slot in - let current_state, current_state_view = + let current_state, current_state_view, parent_protocol_state_body + = dummy_state_and_view ~global_slot () in let state_and_body_hash = @@ -4426,7 +4466,11 @@ let%test_module "staged ledger tests" = let diff_result = Sl.create_diff ~constraint_constants ~global_slot !sl ~logger ~current_state_view - ~transactions_by_fee:(Sequence.of_list [ valid_command ]) + ~transactions_by_fee: + (Sequence.singleton + ( valid_command + |> Transaction_hash.User_command_with_valid_signature + .create ) ) ~get_completed_work:(stmt_to_work_zero_fee ~prover:self_pk) ~coinbase_receiver ~supercharge_coinbase:false ~zkapp_cmd_limit:None @@ -4458,10 +4502,10 @@ let%test_module "staged ledger tests" = } in match%map - Sl.apply ~constraint_constants ~global_slot !sl + apply_diff_full ~constraint_constants ~global_slot !sl (Staged_ledger_diff.forget diff) ~logger ~verifier ~get_completed_work:(Fn.const None) - ~current_state_view ~state_and_body_hash + ~parent_protocol_state_body ~state_and_body_hash ~coinbase_receiver ~supercharge_coinbase:false ~zkapp_cmd_limit_hardcap ~signature_kind with @@ -4626,7 +4670,7 @@ let%test_module "staged ledger tests" = let global_slot = Mina_numbers.Global_slot_since_genesis.of_int global_slot in - let current_state, current_state_view = + let current_state, current_state_view, parent_protocol_state_body = dummy_state_and_view ~global_slot () in let state_and_body_hash = @@ -4638,15 +4682,19 @@ let%test_module "staged ledger tests" = Sl.create_diff ~constraint_constants ~global_slot sl ~logger ~current_state_view ~transactions_by_fee: - (Sequence.of_list - [ valid_command_1 - ; valid_command_2 - ; invalid_command_3 - ; invalid_command_4 - ; valid_command_5 - ; invalid_command_6 - ; valid_command_7 - ] ) + ( Sequence.of_list + [ valid_command_1 + ; valid_command_2 + ; invalid_command_3 + ; invalid_command_4 + ; valid_command_5 + ; invalid_command_6 + ; valid_command_7 + ] + |> Sequence.map + ~f: + Transaction_hash.User_command_with_valid_signature.create + ) ~get_completed_work:(stmt_to_work_zero_fee ~prover:self_pk) ~coinbase_receiver ~supercharge_coinbase:false ~zkapp_cmd_limit:None @@ -4671,12 +4719,12 @@ let%test_module "staged ledger tests" = |> List.map ~f:(fun cmd -> User_command.forget_check cmd) ) ) ; assert (List.length invalid_txns = 3) ; match%bind - Sl.apply ~constraint_constants ~global_slot sl + apply_diff_full ~constraint_constants ~global_slot sl (Staged_ledger_diff.forget diff) ~logger ~verifier ~get_completed_work:(Fn.const None) - ~current_state_view ~state_and_body_hash ~coinbase_receiver - ~supercharge_coinbase:false ~zkapp_cmd_limit_hardcap - ~signature_kind + ~parent_protocol_state_body ~state_and_body_hash + ~coinbase_receiver ~supercharge_coinbase:false + ~zkapp_cmd_limit_hardcap ~signature_kind with | Ok _x -> ( let valid_command_1_with_status = @@ -4718,10 +4766,10 @@ let%test_module "staged ledger tests" = } in match%map - Sl.apply ~constraint_constants ~global_slot sl + apply_diff_full ~constraint_constants ~global_slot sl (Staged_ledger_diff.forget diff) ~logger ~verifier ~get_completed_work:(Fn.const None) - ~current_state_view ~state_and_body_hash + ~parent_protocol_state_body ~state_and_body_hash ~coinbase_receiver ~supercharge_coinbase:false ~zkapp_cmd_limit_hardcap ~signature_kind with @@ -4797,6 +4845,11 @@ let%test_module "staged ledger tests" = ; commands = cmds ; coinbase = Zero ; internal_command_statuses = [ Applied ] + ; command_hashes = + List.map cmds + ~f: + (Fn.compose Transaction_hash.hash_command_with_hashes + With_status.data ) } in { diff = (pre_diff, None) } @@ -4805,7 +4858,7 @@ let%test_module "staged ledger tests" = let global_slot = Mina_numbers.Global_slot_since_genesis.of_int 1 in - let current_state, current_state_view = + let current_state, _, parent_protocol_state_body = dummy_state_and_view ~global_slot () in let state_and_body_hash = @@ -4816,11 +4869,11 @@ let%test_module "staged ledger tests" = , state_hashes.state_body_hash |> Option.value_exn ) in let%map result = - apply ~logger ~constraint_constants ~global_slot + apply_diff_full ~logger ~constraint_constants ~global_slot ~get_completed_work:(Fn.const None) ~verifier - ~current_state_view ~state_and_body_hash ~coinbase_receiver - ~supercharge_coinbase:false sl diff ~zkapp_cmd_limit_hardcap - ~signature_kind + ~parent_protocol_state_body ~state_and_body_hash + ~coinbase_receiver ~supercharge_coinbase:false sl diff + ~zkapp_cmd_limit_hardcap ~signature_kind in match (expectation, result) with | `Accept, Ok _ | `Reject, Error _ -> @@ -5100,7 +5153,7 @@ let%test_module "staged ledger tests" = (Zkapp_command.Valid.For_tests.to_valid ~failed:true ~find_vk:(find_vk ledger) zkapp_command ) in - let current_state, current_state_view = + let current_state, _, parent_protocol_state_body = dummy_state_and_view ~global_slot () in let state_and_body_hash = @@ -5112,7 +5165,7 @@ let%test_module "staged ledger tests" = in let%bind _proof, diff = create_and_apply ~global_slot ~state_and_body_hash - ~protocol_state_view:current_state_view ~signature_kind sl + ~parent_protocol_state_body ~signature_kind sl (Sequence.singleton (User_command.Zkapp_command failed_zkapp_command) ) stmt_to_work_one_prover @@ -5152,7 +5205,7 @@ let%test_module "staged ledger tests" = let sl = ref @@ Sl.create_exn ~constraint_constants ~ledger in let%bind _proof, diff = create_and_apply sl ~global_slot ~state_and_body_hash - ~protocol_state_view:current_state_view ~signature_kind + ~parent_protocol_state_body ~signature_kind (Sequence.singleton (User_command.Zkapp_command valid_zkapp_command) ) stmt_to_work_one_prover @@ -5223,7 +5276,9 @@ let%test_module "staged ledger tests" = let global_slot = Mina_numbers.Global_slot_since_genesis.of_int global_slot in - let current_state, current_state_view = + let ( current_state + , current_state_view + , parent_protocol_state_body ) = dummy_state_and_view ~global_slot () in let state_and_body_hash = @@ -5238,7 +5293,9 @@ let%test_module "staged ledger tests" = ~logger ~current_state_view ~transactions_by_fee: (Sequence.singleton - (User_command.Zkapp_command invalid_zkapp_command) ) + ( User_command.Zkapp_command invalid_zkapp_command + |> Transaction_hash.User_command_with_valid_signature + .create ) ) ~get_completed_work: (stmt_to_work_zero_fee ~prover:self_pk) ~coinbase_receiver ~supercharge_coinbase:false @@ -5258,10 +5315,10 @@ let%test_module "staged ledger tests" = ~proof_level:Full () in match%map - Sl.apply ~constraint_constants ~global_slot !sl + apply_diff_full ~constraint_constants ~global_slot !sl (Staged_ledger_diff.forget diff) ~get_completed_work:(Fn.const None) ~logger - ~verifier:verifier_full ~current_state_view + ~verifier:verifier_full ~parent_protocol_state_body ~state_and_body_hash ~coinbase_receiver ~supercharge_coinbase:false ~zkapp_cmd_limit_hardcap ~signature_kind diff --git a/src/lib/staged_ledger/staged_ledger.mli b/src/lib/staged_ledger/staged_ledger.mli index 52407c556b84..995af255a047 100644 --- a/src/lib/staged_ledger/staged_ledger.mli +++ b/src/lib/staged_ledger/staged_ledger.mli @@ -8,18 +8,78 @@ module Ledger = Mina_ledger.Ledger type t module Scan_state : sig + module Application_data = Scan_state_application_data + + module Available_job : sig + type t + + val single_spec_one_or_two : + get_state: + ( Mina_base.State_hash.t + -> Mina_state.Protocol_state.Value.t Or_error.t ) + -> t One_or_two.t + -> ( Transaction_witness.Stable.Latest.t + , Ledger_proof.t ) + Snark_work_lib.Spec.Single.Poly.t + One_or_two.t + Or_error.t + + val statement : t -> Transaction_snark.Statement.t option + + val single_spec : + get_state: + ( Mina_base.State_hash.t + -> Mina_state.Protocol_state.Value.t Or_error.t ) + -> t + -> ( Transaction_witness.Stable.Latest.t + , Ledger_proof.t ) + Snark_work_lib.Spec.Single.Poly.t + Or_error.t + + val is_transition : t -> bool + + val target_second_pass_ledger : t -> Frozen_ledger_hash.t option + end + + module Ledger_proof_with_sok_message : sig + module Tagged = + Transaction_snark_scan_state.Ledger_proof_with_sok_message.Tagged + + val persist_many : + Transaction_snark_work.t list + -> State_hash.File_storage.writer_t + -> Tagged.t list + end + + module Transaction_with_witness : sig + type t + + module Tagged = Transaction_snark_scan_state.Transaction_with_witness.Tagged + + val persist_many : + t list -> State_hash.File_storage.writer_t -> Tagged.t list + end + [%%versioned: module Stable : sig [@@@no_toplevel_latest_type] + module V3 : sig + type t + end + module V2 : sig type t val hash : t -> Staged_ledger_hash.Aux_hash.t + + val to_latest : t -> V3.t + + val of_latest_exn : V3.t -> t end end] - type t + type t = Stable.V3.t module Job_view : sig type t [@@deriving sexp, to_yojson] @@ -37,36 +97,12 @@ module Scan_state : sig [@@deriving sexp] end - module Transactions_ordered : sig - module Poly : sig - type 'a t = - { first_pass : 'a list - ; second_pass : 'a list - ; previous_incomplete : 'a list - ; current_incomplete : 'a list - } - [@@deriving sexp, to_yojson] - end - - type t = Transaction_snark_scan_state.Transaction_with_witness.t Poly.t - end - val empty : constraint_constants:Genesis_constants.Constraint_constants.t -> unit -> t (** Statements of the required snark work *) val snark_job_list_json : t -> string - (** All the transactions with hash of the parent block in which they were - included in the order in which they were applied *) - val staged_transactions_with_state_hash : - t - -> ( Transaction.t With_status.t - * State_hash.t - * Mina_numbers.Global_slot_since_genesis.t ) - Transactions_ordered.Poly.t - list - (** Statements of all the pending work. Fails if there are any invalid statements in the scan state [t] *) val all_work_statements_exn : t -> Transaction_snark_work.Statement.t list @@ -146,13 +182,7 @@ module Scan_state : sig -> t -> unit Deferred.Or_error.t - val write_all_proofs_to_disk : - signature_kind:Mina_signature_kind.t - -> proof_cache_db:Proof_cache_tag.cache_db - -> Stable.Latest.t - -> t - - val read_all_proofs_from_disk : t -> Stable.Latest.t + (* val read_all_proofs_from_disk : t -> Stable.Latest.t Or_error.t *) end module Pre_diff_info : Pre_diff_info.S @@ -194,23 +224,15 @@ val create_exn : val replace_ledger_exn : t -> Ledger.t -> t -(** Transactions corresponding to the most recent ledger proof in t *) -val proof_txns_with_state_hashes : - t - -> ( Transaction.t With_status.t - * State_hash.t - * Mina_numbers.Global_slot_since_genesis.t ) - Scan_state.Transactions_ordered.Poly.t - Mina_stdlib.Nonempty_list.t - option - val copy : t -> t val hash : t -> Staged_ledger_hash.t type transaction_pool_proxy = Check_commands.transaction_pool_proxy -val apply : +val update_scan_state_metrics : Scan_state.t -> unit Or_error.t + +val apply_diff : ?skip_verification:[ `Proofs | `All ] -> constraint_constants:Genesis_constants.Constraint_constants.t -> global_slot:Mina_numbers.Global_slot_since_genesis.t @@ -219,7 +241,7 @@ val apply : -> Transaction_snark_work.Checked.t option ) -> logger:Logger.t -> verifier:Verifier.t - -> current_state_view:Zkapp_precondition.Protocol_state.View.t + -> parent_protocol_state_body:Mina_state.Protocol_state.Body.Value.t -> state_and_body_hash:State_hash.t * State_body_hash.t -> coinbase_receiver:Public_key.Compressed.t -> supercharge_coinbase:bool @@ -228,15 +250,13 @@ val apply : -> ?transaction_pool_proxy:Check_commands.transaction_pool_proxy -> t -> Staged_ledger_diff.t - -> ( [ `Ledger_proof of - ( Ledger_proof.Cached.t - * ( Transaction.t With_status.t - * State_hash.t - * Mina_numbers.Global_slot_since_genesis.t ) - Scan_state.Transactions_ordered.Poly.t - list ) - option ] - * [ `Staged_ledger of t ] + -> ( [ `Ledger of Ledger.t ] + * [ `Accounts_created of Account_id.t list ] + * [ `Stack_update of + Pending_coinbase.Stack_versioned.t One_or_two.t option ] + * [ `First_pass_ledger_end of Frozen_ledger_hash.t ] + * [ `Witnesses of Scan_state.Transaction_with_witness.t list ] + * [ `Works of Transaction_snark_work.t list ] * [ `Pending_coinbase_update of bool * Pending_coinbase.Update.t ] , Staged_ledger_error.t ) Deferred.Result.t @@ -245,7 +265,7 @@ val apply_diff_unchecked : constraint_constants:Genesis_constants.Constraint_constants.t -> global_slot:Mina_numbers.Global_slot_since_genesis.t -> logger:Logger.t - -> current_state_view:Zkapp_precondition.Protocol_state.View.t + -> parent_protocol_state_body:Mina_state.Protocol_state.Body.Value.t -> state_and_body_hash:State_hash.t * State_body_hash.t -> coinbase_receiver:Public_key.Compressed.t -> supercharge_coinbase:bool @@ -253,47 +273,27 @@ val apply_diff_unchecked : -> signature_kind:Mina_signature_kind.t -> t -> Staged_ledger_diff.With_valid_signatures_and_proofs.t - -> ( [ `Ledger_proof of - ( Ledger_proof.Cached.t - * ( Transaction.t With_status.t - * State_hash.t - * Mina_numbers.Global_slot_since_genesis.t ) - Scan_state.Transactions_ordered.Poly.t - list ) - option ] - * [ `Staged_ledger of t ] + -> ( [ `Ledger of Ledger.t ] + * [ `Accounts_created of Account_id.t list ] + * [ `Stack_update of + Pending_coinbase.Stack_versioned.t One_or_two.t option ] + * [ `First_pass_ledger_end of Frozen_ledger_hash.t ] + * [ `Witnesses of Scan_state.Transaction_with_witness.t list ] + * [ `Works of Transaction_snark_work.t list ] * [ `Pending_coinbase_update of bool * Pending_coinbase.Update.t ] , Staged_ledger_error.t ) Deferred.Result.t -(** Most recent ledger proof in t *) -val current_ledger_proof : t -> Ledger_proof.Cached.t option - -(* Internals of the txn application. This is only exposed to facilitate - writing unit tests. *) -module Application_state : sig - type txn = - ( Signed_command.With_valid_signature.t - , Zkapp_command.Valid.t ) - User_command.t_ - - type t = - { valid_seq : txn Sequence.t - ; invalid : (txn * Error.t) list - ; skipped_by_fee_payer : txn list Account_id.Map.t - ; zkapp_space_remaining : int option - ; total_space_remaining : int - } - - val init : ?zkapp_limit:int -> total_limit:int -> t - - val try_applying_txn : - ?logger:Logger.t - -> apply:(User_command.t Transaction.t_ -> ('a, Error.t) Result.t) - -> t - -> txn - -> (t, txn Sequence.t * (txn * Error.t) list) Continue_or_stop.t -end +val apply_to_scan_state : + logger:Logger.t + -> skip_verification:bool + -> log_prefix:string + -> ledger:Ledger.t + -> previous_pending_coinbase_collection:Pending_coinbase.t + -> previous_scan_state:Scan_state.t + -> constraint_constants:Genesis_constants.Constraint_constants.t + -> Scan_state.Application_data.t + -> (t * Ledger_proof.Tagged.t option, Staged_ledger_error.t) Deferred.Result.t (* This should memoize the snark verifications *) @@ -306,13 +306,14 @@ val create_diff : -> logger:Logger.t -> current_state_view:Zkapp_precondition.Protocol_state.View.t -> zkapp_cmd_limit:int option - -> transactions_by_fee:User_command.Valid.t Sequence.t + -> transactions_by_fee: + Transaction_hash.User_command_with_valid_signature.t Sequence.t -> get_completed_work: ( Transaction_snark_work.Statement.t -> Transaction_snark_work.Checked.t option ) -> supercharge_coinbase:bool -> ( Staged_ledger_diff.With_valid_signatures_and_proofs.t - * (User_command.Valid.t * Error.t) list + * (Transaction_hash.User_command_with_valid_signature.t * Error.t) list , Pre_diff_info.Error.t ) Result.t @@ -350,37 +351,28 @@ val of_scan_state_pending_coinbases_and_snarked_ledger_unchecked : -> t Or_error.t Deferred.t (** All the pending work in t and the data required to generate proofs. *) -val all_work_pairs : - t - -> get_state:(State_hash.t -> Mina_state.Protocol_state.value Or_error.t) - -> ( Transaction_witness.t - , Ledger_proof.Cached.t ) - Snark_work_lib.Work.Single.Spec.t - One_or_two.t - list - Or_error.t +val all_work_pairs : t -> Scan_state.Available_job.t One_or_two.t list (** Statements of all the pending work in t*) val all_work_statements_exn : t -> Transaction_snark_work.Statement.t list -(** Account ids created in the latest block, taken from the new_accounts - in the latest and next-to-latest trees of the scan state -*) -val latest_block_accounts_created : - t -> previous_block_state_hash:State_hash.t -> Account_id.t list - (** Go through all masks until reach root, convert all accounts accumulated along the way, and commit them to a HF database *) val convert_and_apply_all_masks_to_ledger : hardfork_db:Ledger.Hardfork_db.t -> t -> unit +module For_tests : sig + module Application_state = Application_state +end + module Test_helpers : sig val dummy_state_and_view : ?global_slot:Mina_numbers.Global_slot_since_genesis.t -> unit -> Mina_state.Protocol_state.value * Zkapp_precondition.Protocol_state.View.t + * Mina_state.Protocol_state.Body.Value.t val dummy_state_view : ?global_slot:Mina_numbers.Global_slot_since_genesis.t @@ -401,13 +393,11 @@ module Test_helpers : sig -> Zkapp_precondition.Protocol_state.View.t -> Frozen_ledger_hash.t * Frozen_ledger_hash.t -> ( bool - * Transaction_snark_scan_state.Transaction_with_witness.t list + * ( Transaction_snark_scan_state.Transaction_with_witness.t + * Account_id.t list ) + list * Pending_coinbase.Update.Action.t - * [> `Update_none - | `Update_one of Pending_coinbase.Stack_versioned.t - | `Update_two of - Pending_coinbase.Stack_versioned.t - * Pending_coinbase.Stack_versioned.t ] + * Pending_coinbase.Stack_versioned.t One_or_two.t option * [> `First_pass_ledger_end of Frozen_ledger_hash.t ] , Staged_ledger_error.t ) Deferred.Result.t diff --git a/src/lib/staged_ledger/test/txn_application_test.ml b/src/lib/staged_ledger/test/txn_application_test.ml index 20571d5e7cad..4b3e14cb2ca1 100644 --- a/src/lib/staged_ledger/test/txn_application_test.ml +++ b/src/lib/staged_ledger/test/txn_application_test.ml @@ -3,13 +3,13 @@ open Mina_base open Mina_generators open Mina_numbers open Mina_transaction -open Staged_ledger +module Application_state = Staged_ledger.For_tests.Application_state type apply = User_command.t Transaction.t_ - -> Ledger.Transaction_partially_applied.t Or_error.t + -> Staged_ledger.Ledger.Transaction_partially_applied.t Or_error.t -let gen_apply_and_txn : (apply * Application_state.txn) Quickcheck.Generator.t = +let gen_apply_and_txn : (apply * User_command.Valid.t) Quickcheck.Generator.t = let open Quickcheck.Generator in let open Let_syntax in let constraint_constants = @@ -20,7 +20,9 @@ let gen_apply_and_txn : (apply * Application_state.txn) Quickcheck.Generator.t = ~genesis_constants:Genesis_constants.For_unit_tests.t () in let%map global_slot = Global_slot_since_genesis.gen in - let current_state_view = Test_helpers.dummy_state_view ~global_slot () in + let current_state_view = + Staged_ledger.Test_helpers.dummy_state_view ~global_slot () + in let apply = Transaction_snark.Transaction_validator.apply_transaction_first_pass ~constraint_constants ~global_slot validating_ledger @@ -29,7 +31,8 @@ let gen_apply_and_txn : (apply * Application_state.txn) Quickcheck.Generator.t = in (apply, txn) -let gen_application_state : Application_state.t Quickcheck.Generator.t = +let gen_application_state : + User_command.Valid.t Application_state.t Quickcheck.Generator.t = let open Application_state in let open Quickcheck.Generator in let open Let_syntax in @@ -50,7 +53,9 @@ let apply_against_non_empty_scan_state () = Quickcheck.test (Quickcheck.Generator.tuple2 gen_apply_and_txn gen_application_state) ~f:(fun ((apply, txn), state) -> - match Application_state.try_applying_txn ~apply state txn with + match + Application_state.Valid_user_command.try_applying_txn ~apply state txn + with | Continue state' when state.total_space_remaining > 0 -> [%test_pred: int] (fun delta -> delta = 0 || delta = 1) diff --git a/src/lib/staged_ledger_diff/diff.ml b/src/lib/staged_ledger_diff/diff.ml index ffa5755d9cf1..895ccb3c84d9 100644 --- a/src/lib/staged_ledger_diff/diff.ml +++ b/src/lib/staged_ledger_diff/diff.ml @@ -74,68 +74,119 @@ module Ft = struct type t = Stable.Latest.t [@@deriving equal, compare, sexp, yojson] end -module Pre_diff_two = struct +module Pre_diff_generic = struct [%%versioned module Stable = struct [@@@no_toplevel_latest_type] module V2 = struct - type ('a, 'b) t = + type ('a, 'b, 'coinbase) t = { completed_works : 'a list ; commands : 'b list - ; coinbase : Ft.Stable.V1.t At_most_two.Stable.V1.t + ; coinbase : 'coinbase ; internal_command_statuses : Transaction_status.Stable.V2.t list } [@@deriving equal, compare, sexp, yojson] + + let extract_prediff t = + (t.completed_works, t.commands, t.coinbase, t.internal_command_statuses) end end] - type ('a, 'b) t = ('a, 'b) Stable.Latest.t = - { completed_works : 'a list + type ('a, 'b, 'coinbase) t = + { command_hashes : Mina_transaction.Transaction_hash.t list [@sexp.opaque] + ; completed_works : 'a list ; commands : 'b list - ; coinbase : Ft.t At_most_two.t + ; coinbase : 'coinbase ; internal_command_statuses : Transaction_status.t list } - [@@deriving equal, compare, sexp, yojson] + [@@deriving equal, compare, sexp_of, to_yojson] - let map t ~f1 ~f2 = - { completed_works = List.map t.completed_works ~f:f1 - ; commands = List.map t.commands ~f:f2 - ; coinbase = t.coinbase - ; internal_command_statuses = t.internal_command_statuses + let extract_prediff t = + (t.completed_works, t.commands, t.coinbase, t.internal_command_statuses) + + let write_all_proofs_to_disk ~signature_kind ~proof_cache_db + ({ commands; completed_works; coinbase; internal_command_statuses } : + ( Transaction_snark_work.Stable.Latest.t + , User_command.Stable.Latest.t With_status.Stable.Latest.t + , 'c ) + Stable.Latest.t ) : + (Transaction_snark_work.t, User_command.t With_status.t, 'c) t = + let write_sw = + Transaction_snark_work.write_all_proofs_to_disk ~proof_cache_db + in + let write_tx = + With_status.map + ~f: + (User_command.write_all_proofs_to_disk ~signature_kind ~proof_cache_db) + in + let hash_command = + Fn.compose Mina_transaction.Transaction_hash.hash_command With_status.data + in + { commands = List.map ~f:write_tx commands + ; completed_works = List.map ~f:write_sw completed_works + ; coinbase + ; internal_command_statuses + ; command_hashes = List.map ~f:hash_command commands + } + + let read_all_proofs_from_disk + ({ commands + ; completed_works + ; coinbase + ; internal_command_statuses + ; command_hashes = _ + } : + (Transaction_snark_work.t, User_command.t With_status.t, 'c) t ) : + ( Transaction_snark_work.Stable.Latest.t + , User_command.Stable.Latest.t With_status.Stable.Latest.t + , 'c ) + Stable.Latest.t = + let read_sw = Transaction_snark_work.read_all_proofs_from_disk in + let read_tx = With_status.map ~f:User_command.read_all_proofs_from_disk in + { commands = List.map ~f:read_tx commands + ; completed_works = List.map ~f:read_sw completed_works + ; coinbase + ; internal_command_statuses } end -module Pre_diff_one = struct +module Pre_diff_two = struct [%%versioned module Stable = struct [@@@no_toplevel_latest_type] module V2 = struct type ('a, 'b) t = - { completed_works : 'a list - ; commands : 'b list - ; coinbase : Ft.Stable.V1.t At_most_one.Stable.V1.t - ; internal_command_statuses : Transaction_status.Stable.V2.t list - } + ( 'a + , 'b + , Ft.Stable.V1.t At_most_two.Stable.V1.t ) + Pre_diff_generic.Stable.V2.t [@@deriving equal, compare, sexp, yojson] end end] - type ('a, 'b) t = ('a, 'b) Stable.Latest.t = - { completed_works : 'a list - ; commands : 'b list - ; coinbase : Ft.t At_most_one.t - ; internal_command_statuses : Transaction_status.t list - } - [@@deriving equal, compare, sexp, yojson] + type ('a, 'b) t = ('a, 'b, Ft.t At_most_two.t) Pre_diff_generic.t + [@@deriving equal, compare, sexp_of, to_yojson] +end - let map t ~f1 ~f2 = - { completed_works = List.map t.completed_works ~f:f1 - ; commands = List.map t.commands ~f:f2 - ; coinbase = t.coinbase - ; internal_command_statuses = t.internal_command_statuses - } +module Pre_diff_one = struct + [%%versioned + module Stable = struct + [@@@no_toplevel_latest_type] + + module V2 = struct + type ('a, 'b) t = + ( 'a + , 'b + , Ft.Stable.V1.t At_most_one.Stable.V1.t ) + Pre_diff_generic.Stable.V2.t + [@@deriving equal, compare, sexp, yojson] + end + end] + + type ('a, 'b) t = ('a, 'b, Ft.t At_most_one.t) Pre_diff_generic.t + [@@deriving equal, compare, sexp_of, to_yojson] end module Pre_diff_with_at_most_two_coinbase = struct @@ -157,19 +208,8 @@ module Pre_diff_with_at_most_two_coinbase = struct type t = (Transaction_snark_work.t, User_command.t With_status.t) Pre_diff_two.t - let write_all_proofs_to_disk ~signature_kind ~proof_cache_db : - Stable.Latest.t -> t = - Pre_diff_two.map - ~f1:(Transaction_snark_work.write_all_proofs_to_disk ~proof_cache_db) - ~f2: - (With_status.map - ~f: - (User_command.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db ) ) - - let read_all_proofs_from_disk : t -> Stable.Latest.t = - Pre_diff_two.map ~f1:Transaction_snark_work.read_all_proofs_from_disk - ~f2:(With_status.map ~f:User_command.read_all_proofs_from_disk) + [%%define_locally + Pre_diff_generic.(read_all_proofs_from_disk, write_all_proofs_to_disk)] end module Pre_diff_with_at_most_one_coinbase = struct @@ -191,19 +231,8 @@ module Pre_diff_with_at_most_one_coinbase = struct type t = (Transaction_snark_work.t, User_command.t With_status.t) Pre_diff_one.t - let write_all_proofs_to_disk ~signature_kind ~proof_cache_db : - Stable.Latest.t -> t = - Pre_diff_one.map - ~f1:(Transaction_snark_work.write_all_proofs_to_disk ~proof_cache_db) - ~f2: - (With_status.map - ~f: - (User_command.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db ) ) - - let read_all_proofs_from_disk : t -> Stable.Latest.t = - Pre_diff_one.map ~f1:Transaction_snark_work.read_all_proofs_from_disk - ~f2:(With_status.map ~f:User_command.read_all_proofs_from_disk) + [%%define_locally + Pre_diff_generic.(read_all_proofs_from_disk, write_all_proofs_to_disk)] end module Diff = struct @@ -222,9 +251,9 @@ module Diff = struct coinbase_amount ~constraint_constants ~supercharge_coinbase in match - ( first_pre_diff.Pre_diff_two.coinbase + ( first_pre_diff.Pre_diff_generic.coinbase , Option.value_map second_pre_diff_opt ~default:At_most_one.Zero - ~f:(fun d -> d.Pre_diff_one.coinbase) ) + ~f:(fun d -> d.Pre_diff_generic.coinbase) ) with | At_most_two.Zero, At_most_one.Zero -> Some Currency.Amount.zero @@ -243,7 +272,21 @@ module Diff = struct let to_latest = Fn.id - let coinbase = coinbase + let coinbase + ~(constraint_constants : Genesis_constants.Constraint_constants.t) + ~supercharge_coinbase (first_pre_diff, second_pre_diff_opt) = + let coinbase_amount = + coinbase_amount ~constraint_constants ~supercharge_coinbase + in + match + ( first_pre_diff.Pre_diff_generic.Stable.Latest.coinbase + , Option.value_map second_pre_diff_opt ~default:At_most_one.Zero + ~f:(fun d -> d.Pre_diff_generic.Stable.Latest.coinbase) ) + with + | At_most_two.Zero, At_most_one.Zero -> + Some Currency.Amount.zero + | _ -> + coinbase_amount end end] @@ -332,6 +375,7 @@ module With_valid_signatures_and_proofs = struct ; commands = [] ; coinbase = At_most_two.Zero ; internal_command_statuses = [] + ; command_hashes = [] } , None ) } @@ -363,29 +407,18 @@ module With_valid_signatures = struct let coinbase ~(constraint_constants : Genesis_constants.Constraint_constants.t) ~supercharge_coinbase (t : t) = - let first_pre_diff, second_pre_diff_opt = t.diff in - let coinbase_amount = - Diff.coinbase_amount ~constraint_constants ~supercharge_coinbase - in - match - ( first_pre_diff.coinbase - , Option.value_map second_pre_diff_opt ~default:At_most_one.Zero - ~f:(fun d -> d.coinbase) ) - with - | At_most_two.Zero, At_most_one.Zero -> - Some Currency.Amount.zero - | _ -> - coinbase_amount + Diff.coinbase ~constraint_constants ~supercharge_coinbase t.diff end let validate_commands (t : t) ~(check : User_command.t With_status.t list + -> Mina_transaction.Transaction_hash.t list -> (User_command.Valid.t list, 'e) Result.t Async.Deferred.Or_error.t ) : (With_valid_signatures.t, 'e) Result.t Async.Deferred.Or_error.t = let map t ~f = Async.Deferred.Or_error.map t ~f:(Result.map ~f) in - let validate cs = - map (check cs) + let validate cs hashes = + map (check cs hashes) ~f: (List.map2_exn cs ~f:(fun c data -> { With_status.data; status = c.status } ) ) @@ -393,7 +426,9 @@ let validate_commands (t : t) let d1, d2 = t.diff in map (validate - (d1.commands @ Option.value_map d2 ~default:[] ~f:(fun d2 -> d2.commands)) ) + (d1.commands @ Option.value_map d2 ~default:[] ~f:(fun d2 -> d2.commands)) + ( d1.command_hashes + @ Option.value_map d2 ~default:[] ~f:(fun d2 -> d2.command_hashes) ) ) ~f:(fun commands_all -> let commands1, commands2 = List.split_n commands_all (List.length d1.commands) @@ -403,15 +438,17 @@ let validate_commands (t : t) ; commands = commands1 ; coinbase = d1.coinbase ; internal_command_statuses = d1.internal_command_statuses + ; command_hashes = d1.command_hashes } in let p2 = Option.value_map ~default:None d2 ~f:(fun d2 -> Some - { Pre_diff_one.completed_works = d2.completed_works + { Pre_diff_generic.completed_works = d2.completed_works ; commands = commands2 ; coinbase = d2.coinbase ; internal_command_statuses = d2.internal_command_statuses + ; command_hashes = d2.command_hashes } ) in ({ diff = (p1, p2) } : With_valid_signatures.t) ) @@ -424,6 +461,7 @@ let forget_proof_checks (d : With_valid_signatures_and_proofs.t) : ; commands = d1.commands ; coinbase = d1.coinbase ; internal_command_statuses = d1.internal_command_statuses + ; command_hashes = d1.command_hashes } in let p2 = @@ -433,14 +471,21 @@ let forget_proof_checks (d : With_valid_signatures_and_proofs.t) : ; commands = d2.commands ; coinbase = d2.coinbase ; internal_command_statuses = d2.internal_command_statuses + ; command_hashes = d2.command_hashes } ) in { diff = (p1, p2) } -let forget_pre_diff_with_at_most_two +let forget_pre_diff (pre_diff : - With_valid_signatures_and_proofs.pre_diff_with_at_most_two_coinbase ) : - Pre_diff_with_at_most_two_coinbase.t = + ( Transaction_snark_work.Checked.t + , User_command.Valid.t With_status.t + , 'c ) + Pre_diff_generic.t ) : + ( Transaction_snark_work.t + , User_command.t With_status.t + , 'c ) + Pre_diff_generic.t = { completed_works = forget_cw pre_diff.completed_works ; commands = List.map @@ -448,30 +493,22 @@ let forget_pre_diff_with_at_most_two pre_diff.commands ; coinbase = pre_diff.coinbase ; internal_command_statuses = pre_diff.internal_command_statuses - } - -let forget_pre_diff_with_at_most_one - (pre_diff : - With_valid_signatures_and_proofs.pre_diff_with_at_most_one_coinbase ) = - { Pre_diff_one.completed_works = forget_cw pre_diff.completed_works - ; commands = - List.map - ~f:(With_status.map ~f:User_command.forget_check) - pre_diff.commands - ; coinbase = pre_diff.coinbase - ; internal_command_statuses = pre_diff.internal_command_statuses + ; command_hashes = pre_diff.command_hashes } let forget (t : With_valid_signatures_and_proofs.t) = { diff = - ( forget_pre_diff_with_at_most_two (fst t.diff) - , Option.map (snd t.diff) ~f:forget_pre_diff_with_at_most_one ) + (forget_pre_diff (fst t.diff), Option.map (snd t.diff) ~f:forget_pre_diff) } let commands (t : t) = (fst t.diff).commands @ Option.value_map (snd t.diff) ~default:[] ~f:(fun d -> d.commands) +let command_hashes (t : t) = + (fst t.diff).command_hashes + @ Option.value_map (snd t.diff) ~default:[] ~f:(fun d -> d.command_hashes) + let completed_works (t : t) = (fst t.diff).completed_works @ Option.value_map (snd t.diff) ~default:[] ~f:(fun d -> d.completed_works) @@ -505,6 +542,7 @@ let empty_diff : t = ; commands = [] ; coinbase = At_most_two.Zero ; internal_command_statuses = [] + ; command_hashes = [] } , None ) } @@ -515,6 +553,7 @@ let is_empty = function ; commands = [] ; coinbase = At_most_two.Zero ; internal_command_statuses = [] + ; command_hashes = [] } , None ) } -> diff --git a/src/lib/staged_ledger_diff/diff.mli b/src/lib/staged_ledger_diff/diff.mli index a139c3e0aded..7bdeaf4d6af5 100644 --- a/src/lib/staged_ledger_diff/diff.mli +++ b/src/lib/staged_ledger_diff/diff.mli @@ -31,38 +31,76 @@ module At_most_one : sig val increase : 'a t -> 'a list -> 'a t Or_error.t end -module Pre_diff_two : sig +module Pre_diff_generic : sig [%%versioned: module Stable : sig + [@@@no_toplevel_latest_type] + module V2 : sig - type ('a, 'b) t = + type ('a, 'b, 'coinbase) t = { completed_works : 'a list ; commands : 'b list - ; coinbase : Coinbase.Fee_transfer.Stable.V1.t At_most_two.Stable.V1.t + ; coinbase : 'coinbase ; internal_command_statuses : Transaction_status.Stable.V2.t list } + + val extract_prediff : + ('a, 'b, 'coinbase) t + -> 'a list * 'b list * 'coinbase * Transaction_status.Stable.V2.t list + end + end] + + type ('a, 'b, 'coinbase) t = + { command_hashes : Mina_transaction.Transaction_hash.t list [@sexp.opaque] + ; completed_works : 'a list + ; commands : 'b list + ; coinbase : 'coinbase + ; internal_command_statuses : Transaction_status.t list + } + + val extract_prediff : + ('a, 'b, 'coinbase) t + -> 'a list * 'b list * 'coinbase * Transaction_status.t list +end + +module Pre_diff_two : sig + [%%versioned: + module Stable : sig + [@@@no_toplevel_latest_type] + + module V2 : sig + type ('a, 'b) t = + ( 'a + , 'b + , Coinbase.Fee_transfer.Stable.V1.t At_most_two.Stable.V1.t ) + Pre_diff_generic.Stable.V2.t [@@deriving equal, compare, sexp, yojson] end end] - val map : ('a, 'b) t -> f1:('a -> 'c) -> f2:('b -> 'd) -> ('c, 'd) t + type ('a, 'b) t = + ('a, 'b, Coinbase.Fee_transfer.t At_most_two.t) Pre_diff_generic.t + [@@deriving equal, compare, sexp_of, to_yojson] end module Pre_diff_one : sig [%%versioned: module Stable : sig + [@@@no_toplevel_latest_type] + module V2 : sig type ('a, 'b) t = - { completed_works : 'a list - ; commands : 'b list - ; coinbase : Coinbase.Fee_transfer.Stable.V1.t At_most_one.Stable.V1.t - ; internal_command_statuses : Transaction_status.Stable.V2.t list - } + ( 'a + , 'b + , Coinbase.Fee_transfer.Stable.V1.t At_most_one.Stable.V1.t ) + Pre_diff_generic.Stable.V2.t [@@deriving equal, compare, sexp, yojson] end end] - val map : ('a, 'b) t -> f1:('a -> 'c) -> f2:('b -> 'd) -> ('c, 'd) t + type ('a, 'b) t = + ('a, 'b, Coinbase.Fee_transfer.t At_most_one.t) Pre_diff_generic.t + [@@deriving equal, compare, sexp_of, to_yojson] end module Pre_diff_with_at_most_two_coinbase : sig @@ -211,6 +249,7 @@ val validate_commands : t -> check: ( User_command.t With_status.t list + -> Mina_transaction.Transaction_hash.t list -> (User_command.Valid.t list, 'e) Result.t Async.Deferred.Or_error.t ) -> (With_valid_signatures.t, 'e) Result.t Async.Deferred.Or_error.t @@ -218,6 +257,8 @@ val forget : With_valid_signatures_and_proofs.t -> t val commands : t -> User_command.t With_status.t list +val command_hashes : t -> Mina_transaction.Transaction_hash.t list + val completed_works : t -> Transaction_snark_work.t list val net_return : diff --git a/src/lib/sync_handler/sync_handler.ml b/src/lib/sync_handler/sync_handler.ml index 71f25bad8ab8..d415f646713e 100644 --- a/src/lib/sync_handler/sync_handler.ml +++ b/src/lib/sync_handler/sync_handler.ml @@ -43,13 +43,6 @@ module Make (Inputs : Inputs_intf) : in Root_history.lookup root_history state_hash - let protocol_states_in_root_history frontier state_hash = - let open Transition_frontier.Extensions in - let root_history = - get_extension (Transition_frontier.extensions frontier) Root_history - in - Root_history.protocol_states_for_scan_state root_history state_hash - let get_ledger_by_hash ~frontier ledger_hash = let root_ledger = Root_ledger.as_unmasked @@ -116,55 +109,31 @@ module Make (Inputs : Inputs_intf) : let get_staged_ledger_aux_and_pending_coinbases_at_hash ~logger ~frontier state_hash = - let open Option.Let_syntax in - let protocol_states scan_state = - Staged_ledger.Scan_state.required_state_hashes scan_state - |> State_hash.Set.to_list - |> List.fold_until ~init:(Some []) - ~f:(fun acc hash -> - match - Option.map2 - (Transition_frontier.find_protocol_state frontier hash) - acc ~f:List.cons - with - | None -> - Stop None - | Some acc' -> - Continue (Some acc') ) - ~finish:Fn.id - in + (* TODO: CAUTION we don't convert the scan state to serialized format *) match - let%bind breadcrumb = Transition_frontier.find frontier state_hash in - let staged_ledger = - Transition_frontier.Breadcrumb.staged_ledger breadcrumb - in - let scan_state = Staged_ledger.scan_state staged_ledger in - let staged_ledger_hash = Breadcrumb.staged_ledger_hash breadcrumb in - let merkle_root = Staged_ledger_hash.ledger_hash staged_ledger_hash in - let%map scan_state_protocol_states = protocol_states scan_state in - let pending_coinbase = - Staged_ledger.pending_coinbase_collection staged_ledger - in - [%log debug] - ~metadata: - [ ( "staged_ledger_hash" - , Staged_ledger_hash.to_yojson staged_ledger_hash ) - ] - "sending scan state and pending coinbase" ; - (scan_state, merkle_root, pending_coinbase, scan_state_protocol_states) + Transition_frontier.staged_ledger_aux_and_pending_coinbases frontier + state_hash with - | Some res -> - Some res | None -> - let open Root_data.Historical in - let%bind root = find_in_root_history frontier state_hash in - let%map scan_state_protocol_states = - protocol_states_in_root_history frontier state_hash + let open Transition_frontier.Extensions in + let root_history = + get_extension (Transition_frontier.extensions frontier) Root_history in - ( scan_state root - , staged_ledger_target_ledger_hash root - , pending_coinbase root - , scan_state_protocol_states ) + let%map.Option historical = + Root_history.lookup root_history state_hash + in + Frontier_base.Network_types.Tag_or_data.Tag + (Root_data.Historical.staged_ledger_aux_and_pending_coinbases + historical ) + | Some (res, staged_ledger_hash) -> + [%log debug] + ~metadata: + [ ( "staged_ledger_hash" + , Staged_ledger_hash.to_yojson staged_ledger_hash ) + ; ("state_hash", State_hash.to_yojson state_hash) + ] + "sending scan state and pending coinbase generated from frontier" ; + Some (Tag res) let get_transition_chain ~frontier hashes = let open Option.Let_syntax in @@ -179,15 +148,10 @@ module Make (Inputs : Inputs_intf) : None ) in let get hash = - let%map validated_transition = - Option.merge - Transition_frontier.( - find frontier hash >>| Breadcrumb.validated_transition) - ( find_in_root_history frontier hash - >>| Root_data.Historical.transition ) - ~f:Fn.const - in - With_hash.data @@ Mina_block.Validated.forget validated_transition + Option.first_some + Transition_frontier.(find frontier hash >>| Breadcrumb.block_tag) + (find_in_root_history frontier hash >>| Root_data.Historical.block_tag) + |> Option.map ~f:(fun x -> Frontier_base.Network_types.Tag_or_data.Tag x) in match Transition_frontier.catchup_state frontier with | Full _ -> @@ -223,15 +187,13 @@ module Make (Inputs : Inputs_intf) : (Consensus.Hooks.select ~context:(module Context) ~existing: - (With_hash.map ~f:Mina_block.consensus_state + (Breadcrumb.consensus_state_with_hashes best_tip_with_witness.data ) ~candidate:seen_consensus_state ) `Keep in let%map () = Option.some_if is_tip_better () in - { best_tip_with_witness with - data = With_hash.data best_tip_with_witness.data - } + best_tip_with_witness let verify ~context:(module Context : CONTEXT) ~verifier observed_state peer_root = diff --git a/src/lib/transaction/transaction.ml b/src/lib/transaction/transaction.ml index db52c5258e32..224ec45cadcf 100644 --- a/src/lib/transaction/transaction.ml +++ b/src/lib/transaction/transaction.ml @@ -79,7 +79,7 @@ let forget : Valid.t -> t = function | Coinbase t -> Coinbase t -let fee_excess : t -> Fee_excess.t Or_error.t = function +let fee_excess : (_, _, _) with_forest -> Fee_excess.t Or_error.t = function | Command (Signed_command t) -> Ok (Signed_command.fee_excess t) | Command (Zkapp_command ps) -> diff --git a/src/lib/transaction/transaction_type.ml b/src/lib/transaction/transaction_type.ml new file mode 100644 index 000000000000..80a3ddfdd742 --- /dev/null +++ b/src/lib/transaction/transaction_type.ml @@ -0,0 +1,19 @@ +[%%versioned +module Stable = struct + module V1 = struct + type t = [ `Zkapp_command | `Signed_command | `Coinbase | `Fee_transfer ] + [@@deriving to_yojson, sexp] + + let to_latest x = x + end +end] + +let of_transaction = function + | Transaction.Command (Mina_base.User_command.Zkapp_command _) -> + `Zkapp_command + | Command (Signed_command _) -> + `Signed_command + | Coinbase _ -> + `Coinbase + | Fee_transfer _ -> + `Fee_transfer diff --git a/src/lib/transaction_inclusion_status/transaction_inclusion_status.ml b/src/lib/transaction_inclusion_status/transaction_inclusion_status.ml index a7c1384e11cf..263c5111d2c2 100644 --- a/src/lib/transaction_inclusion_status/transaction_inclusion_status.ml +++ b/src/lib/transaction_inclusion_status/transaction_inclusion_status.ml @@ -24,7 +24,7 @@ module State = struct end (* TODO: this is extremely expensive as implemented and needs to be replaced with an extension *) -let get_status ~frontier_broadcast_pipe ~transaction_pool cmd = +let get_status ~frontier_broadcast_pipe ~transaction_pool cmd_hash = let resource_pool = Transaction_pool.resource_pool transaction_pool in match Broadcast_pipe.Reader.peek frontier_broadcast_pipe with | None -> @@ -33,22 +33,17 @@ let get_status ~frontier_broadcast_pipe ~transaction_pool cmd = let best_tip_path = Transition_frontier.best_tip_path transition_frontier in - let in_breadcrumb breadcrumb = - breadcrumb |> Transition_frontier.Breadcrumb.validated_transition - |> Mina_block.Validated.valid_commands - |> List.exists ~f:(fun { data = found; _ } -> - let found' = User_command.forget_check found in - User_command.equal_ignoring_proofs_and_hashes_and_aux cmd found' ) + let in_breadcrumb = + Fn.flip Transition_frontier.Breadcrumb.contains_transaction_by_hash + cmd_hash in if List.exists ~f:in_breadcrumb best_tip_path then State.Included else if List.exists ~f:in_breadcrumb (Transition_frontier.all_breadcrumbs transition_frontier) then State.Pending - else if - Transaction_pool.Resource_pool.member resource_pool - (Transaction_hash.hash_command cmd) - then State.Pending + else if Transaction_pool.Resource_pool.member resource_pool cmd_hash then + State.Pending else State.Unknown let%test_module "transaction_status" = @@ -108,8 +103,9 @@ let%test_module "transaction_status" = (Option.value_exn random_key_opt) ) let gen_frontier = - Transition_frontier.For_tests.gen ~logger ~precomputed_values ~verifier - ~trust_system ~max_length ~size:frontier_size () + Quickcheck.Generator.map ~f:fst + @@ Transition_frontier.For_tests.gen ~logger ~precomputed_values ~verifier + ~trust_system ~max_length ~size:frontier_size () (* TODO: Generate zkApps txns *) let gen_user_command = @@ -166,8 +162,9 @@ let%test_module "transaction_status" = let%map () = Async.Scheduler.yield_until_no_jobs_remain () in [%log info] "Checking status" ; [%test_eq: State.t] ~equal:State.equal State.Unknown - (get_status ~frontier_broadcast_pipe ~transaction_pool - (Signed_command user_command) ) ) ) + ( get_status ~frontier_broadcast_pipe ~transaction_pool + @@ Transaction_hash.hash_command (Signed_command user_command) + ) ) ) let%test_unit "A pending transaction is either in the transition frontier \ or transaction pool, but not in the best path of the \ @@ -189,7 +186,7 @@ let%test_module "transaction_status" = let%map () = Async.Scheduler.yield_until_no_jobs_remain () in let status = get_status ~frontier_broadcast_pipe ~transaction_pool - (Signed_command user_command) + @@ Transaction_hash.hash_command (Signed_command user_command) in [%log info] "Computing status" ; [%test_eq: State.t] ~equal:State.equal State.Pending status ) ) @@ -227,6 +224,7 @@ let%test_module "transaction_status" = let%map () = Async.Scheduler.yield_until_no_jobs_remain () in [%log info] "Computing status" ; [%test_eq: State.t] ~equal:State.equal State.Unknown - (get_status ~frontier_broadcast_pipe ~transaction_pool - (Signed_command unknown_user_command) ) ) ) + ( get_status ~frontier_broadcast_pipe ~transaction_pool + @@ Transaction_hash.hash_command + (Signed_command unknown_user_command) ) ) ) end ) diff --git a/src/lib/transaction_inclusion_status/transaction_inclusion_status.mli b/src/lib/transaction_inclusion_status/transaction_inclusion_status.mli index 22770d3406f7..ab6ca46a83f2 100644 --- a/src/lib/transaction_inclusion_status/transaction_inclusion_status.mli +++ b/src/lib/transaction_inclusion_status/transaction_inclusion_status.mli @@ -1,6 +1,5 @@ open Core_kernel open Pipe_lib -open Mina_base module State : sig module Stable : sig @@ -22,5 +21,5 @@ val get_status : frontier_broadcast_pipe: Transition_frontier.t Option.t Broadcast_pipe.Reader.t -> transaction_pool:Network_pool.Transaction_pool.t - -> User_command.Stable.Latest.t + -> Mina_transaction.Transaction_hash.t -> State.t diff --git a/src/lib/transaction_logic/mina_transaction_logic.ml b/src/lib/transaction_logic/mina_transaction_logic.ml index f6b5f0617ced..b37bca0be979 100644 --- a/src/lib/transaction_logic/mina_transaction_logic.ml +++ b/src/lib/transaction_logic/mina_transaction_logic.ml @@ -11,11 +11,6 @@ module type S = sig type location - val transaction_of_applied : - Transaction_applied.t -> Transaction.t With_status.t - - val status_of_applied : Transaction_applied.t -> Transaction_status.t - module Global_state : sig type t = { first_pass_ledger : ledger @@ -444,34 +439,6 @@ module Make (L : Ledger_intf.S) : transaction expiry slot %{sexp: Global_slot_since_genesis.t}" current_global_slot valid_until - let transaction_of_applied : - Transaction_applied.t -> Transaction.t With_status.t = - fun { varying; _ } -> - match varying with - | Command (Signed_command uc) -> - With_status.map uc.common.user_command ~f:(fun cmd -> - Transaction.Command (User_command.Signed_command cmd) ) - | Command (Zkapp_command s) -> - With_status.map s.command ~f:(fun c -> - Transaction.Command (User_command.Zkapp_command c) ) - | Fee_transfer f -> - With_status.map f.fee_transfer ~f:(fun f -> Transaction.Fee_transfer f) - | Coinbase c -> - With_status.map c.coinbase ~f:(fun c -> Transaction.Coinbase c) - - let status_of_applied : Transaction_applied.t -> Transaction_status.t = - fun { varying; _ } -> - match varying with - | Command - (Signed_command { common = { user_command = { status; _ }; _ }; _ }) -> - status - | Command (Zkapp_command c) -> - c.command.status - | Fee_transfer f -> - f.fee_transfer.status - | Coinbase c -> - c.coinbase.status - let get_new_accounts action pk = if Ledger_intf.equal_account_state action `Added then [ pk ] else [] diff --git a/src/lib/transaction_logic/transaction_applied.ml b/src/lib/transaction_logic/transaction_applied.ml index 5ee3c4b28e19..87321202ca47 100644 --- a/src/lib/transaction_logic/transaction_applied.ml +++ b/src/lib/transaction_logic/transaction_applied.ml @@ -170,6 +170,9 @@ module Varying : sig module V2 : sig type t [@@deriving sexp, to_yojson] + + val transaction_with_status : + t -> Transaction.Stable.V2.t With_status.Stable.V2.t end end] @@ -198,6 +201,19 @@ end = struct [@@deriving sexp, to_yojson] let to_latest = Fn.id + + let transaction_with_status = function + | Command (Signed_command uc) -> + With_status.map uc.common.user_command ~f:(fun cmd -> + Transaction.Command (User_command.Signed_command cmd) ) + | Command (Zkapp_command s) -> + With_status.map s.command ~f:(fun c -> + Transaction.Command (User_command.Zkapp_command c) ) + | Fee_transfer f -> + With_status.map f.fee_transfer ~f:(fun f -> + Transaction.Fee_transfer f ) + | Coinbase c -> + With_status.map c.coinbase ~f:(fun c -> Transaction.Coinbase c) end end] @@ -314,6 +330,22 @@ let supply_increase : Option.value_map total ~default:(Or_error.error_string "overflow") ~f:(fun v -> Ok v) +let transaction : t -> Transaction.t = + fun { varying; _ } -> + match varying with + | Command (Signed_command { common = { user_command = { data; _ }; _ }; _ }) + -> + Transaction.Command (User_command.Signed_command data) + | Command (Zkapp_command { command = { data; _ }; _ }) -> + Transaction.Command (User_command.Zkapp_command data) + | Fee_transfer { fee_transfer = { data; _ }; _ } -> + Transaction.Fee_transfer data + | Coinbase { coinbase = { data; _ }; _ } -> + Transaction.Coinbase data + +let transaction_with_status_stable { Stable.Latest.varying; _ } = + Varying.Stable.Latest.transaction_with_status varying + let transaction_with_status : t -> Transaction.t With_status.t = fun { varying; _ } -> match varying with diff --git a/src/lib/transaction_snark/test/util.ml b/src/lib/transaction_snark/test/util.ml index 1978de0a4168..cde91948a1fb 100644 --- a/src/lib/transaction_snark/test/util.ml +++ b/src/lib/transaction_snark/test/util.ml @@ -629,7 +629,9 @@ let test_transaction_union ?expected_failure ?txn_global_slot ledger txn = with | Ok res -> ( if Option.is_some expected_failure then - match Ledger.status_of_applied res with + match + Mina_transaction_logic.Transaction_applied.transaction_status res + with | Applied -> failwith (sprintf "Expected Ledger.apply_transaction to fail with %s" diff --git a/src/lib/transaction_snark/transaction_snark.ml b/src/lib/transaction_snark/transaction_snark.ml index 7ee65f8663db..b2f3d934e620 100644 --- a/src/lib/transaction_snark/transaction_snark.ml +++ b/src/lib/transaction_snark/transaction_snark.ml @@ -3538,6 +3538,11 @@ module Make_str (A : Wire_types.Concrete) = struct init_stack pending_coinbase_stack_state handler let verify_impl ~f ts = + (* TODO: move this check outside of verify_impl + Let's do it in Daemon, not verifier, and skip it entirely when + validating proofs from scan state (even when received + from the network, we simply don't need sok messages anymore) + *) if List.for_all ts ~f:(fun ((p : Stable.Latest.t), m) -> Sok_message.Digest.equal (Sok_message.digest m) p.data.sok_digest ) diff --git a/src/lib/transaction_snark_scan_state/transaction_snark_scan_state.ml b/src/lib/transaction_snark_scan_state/transaction_snark_scan_state.ml index 199944e3c907..fa155e61bcdc 100644 --- a/src/lib/transaction_snark_scan_state/transaction_snark_scan_state.ml +++ b/src/lib/transaction_snark_scan_state/transaction_snark_scan_state.ml @@ -19,86 +19,293 @@ module type Monad_with_Or_error_intf = sig end module Transaction_with_witness = struct - [%%versioned - module Stable = struct - [@@@no_toplevel_latest_type] + module T = struct + [%%versioned + module Stable = struct + [@@@no_toplevel_latest_type] + + (* TODO In Mesa use Transaction_snark.Statement.t * Transaction_witness.t *) + module V3 = struct + type t = + { transaction_with_status : + Transaction.Stable.V2.t With_status.Stable.V2.t + ; state_hash : State_hash.Stable.V1.t * State_body_hash.Stable.V1.t + ; statement : Transaction_snark.Statement.Stable.V2.t + ; init_stack : Mina_base.Pending_coinbase.Stack_versioned.Stable.V1.t + ; first_pass_ledger_witness : Mina_ledger.Sparse_ledger.Stable.V2.t + ; second_pass_ledger_witness : Mina_ledger.Sparse_ledger.Stable.V2.t + ; block_global_slot : + Mina_numbers.Global_slot_since_genesis.Stable.V1.t + ; previous_protocol_state_body_opt : + Mina_state.Protocol_state.Body.Value.Stable.V2.t option + (* TODO: in Mesa remove the option, just have the value *) + ; transaction_applied_tag : + ( State_hash.Stable.V1.t + , Mina_transaction_logic.Transaction_applied.Stable.V2.t ) + Multi_key_file_storage.Tag.Stable.V1.t + (* TODO: in Mesa remove the field, after modifying + network synchronization and hash computation *) + } - module V2 = struct - (* TODO: The statement is redundant here - it can be computed from the - witness and the transaction - *) - type t = - { transaction_with_info : - Mina_transaction_logic.Transaction_applied.Stable.V2.t - ; state_hash : State_hash.Stable.V1.t * State_body_hash.Stable.V1.t - ; statement : Transaction_snark.Statement.Stable.V2.t - ; init_stack : - Transaction_snark.Pending_coinbase_stack_state.Init_stack.Stable.V1 - .t - ; first_pass_ledger_witness : - (Mina_ledger.Sparse_ledger.Stable.V2.t[@sexp.opaque]) - ; second_pass_ledger_witness : - (Mina_ledger.Sparse_ledger.Stable.V2.t[@sexp.opaque]) - ; block_global_slot : Mina_numbers.Global_slot_since_genesis.Stable.V1.t - } - [@@deriving sexp, to_yojson] + let transaction_type t = + Transaction_type.of_transaction + (With_status.data t.transaction_with_status) - let to_latest = Fn.id - end - end] + let mk_transaction_applied_tag writer + (transaction_applied : + Mina_transaction_logic.Transaction_applied.Stable.V2.t ) = + State_hash.File_storage.write_value writer + (module Mina_transaction_logic.Transaction_applied.Stable.V2) + transaction_applied - type t = - { transaction_with_info : Mina_transaction_logic.Transaction_applied.t - ; state_hash : State_hash.t * State_body_hash.t - ; statement : Transaction_snark.Statement.t - ; init_stack : Transaction_snark.Pending_coinbase_stack_state.Init_stack.t - ; first_pass_ledger_witness : Mina_ledger.Sparse_ledger.t - ; second_pass_ledger_witness : Mina_ledger.Sparse_ledger.t - ; block_global_slot : Mina_numbers.Global_slot_since_genesis.t - } + let to_latest = Fn.id + end + + module V2 = struct + (* TODO: The statement is redundant here - it can be computed from the + witness and the transaction + *) + type t = + { transaction_with_info : + Mina_transaction_logic.Transaction_applied.Stable.V2.t + ; state_hash : State_hash.Stable.V1.t * State_body_hash.Stable.V1.t + ; statement : Transaction_snark.Statement.Stable.V2.t + ; init_stack : + Transaction_snark.Pending_coinbase_stack_state.Init_stack.Stable + .V1 + .t + ; first_pass_ledger_witness : Mina_ledger.Sparse_ledger.Stable.V2.t + ; second_pass_ledger_witness : Mina_ledger.Sparse_ledger.Stable.V2.t + ; block_global_slot : + Mina_numbers.Global_slot_since_genesis.Stable.V1.t + } + + let of_latest_exn : V3.t -> t = + fun { state_hash + ; statement + ; init_stack + ; first_pass_ledger_witness + ; second_pass_ledger_witness + ; block_global_slot + ; transaction_applied_tag + ; _ + } -> + { transaction_with_info = + State_hash.File_storage.read + (module Mina_transaction_logic.Transaction_applied.Stable.V2) + transaction_applied_tag + |> Or_error.tag ~tag:"of_latest_exn" + |> Or_error.ok_exn + ; state_hash + ; statement + ; init_stack = Base init_stack + ; first_pass_ledger_witness + ; second_pass_ledger_witness + ; block_global_slot + } + + let to_latest : State_hash.File_storage.writer_t -> t -> V3.t = + fun writer + { transaction_with_info + ; state_hash + ; statement + ; init_stack + ; first_pass_ledger_witness + ; second_pass_ledger_witness + ; block_global_slot + } -> + { transaction_with_status = + Mina_transaction_logic.Transaction_applied + .transaction_with_status_stable transaction_with_info + ; statement + ; state_hash + ; init_stack = + ( match init_stack with + | Base stack -> + stack + | Merge -> + failwith "Unexpected stack for witness" ) + ; first_pass_ledger_witness + ; second_pass_ledger_witness + ; block_global_slot + ; previous_protocol_state_body_opt = None + ; transaction_applied_tag = + State_hash.File_storage.write_value writer + (module Mina_transaction_logic.Transaction_applied.Stable.V2) + transaction_with_info + } + end + end] + + type t = + { transaction_with_status : Transaction.t With_status.t + ; state_hash : State_hash.t * State_body_hash.t + ; statement : Transaction_snark.Statement.t + ; init_stack : Mina_base.Pending_coinbase.Stack_versioned.t + ; first_pass_ledger_witness : Mina_ledger.Sparse_ledger.t + ; second_pass_ledger_witness : Mina_ledger.Sparse_ledger.t + ; block_global_slot : Mina_numbers.Global_slot_since_genesis.t + ; previous_protocol_state_body_opt : + Mina_state.Protocol_state.Body.Value.t option + ; transaction_applied_or_tag : + ( Mina_transaction_logic.Transaction_applied.t + , Mina_transaction_logic.Transaction_applied.Stable.V2.t + State_hash.File_storage.tag ) + Either.t + } + + let source_second_pass_ledger t = t.statement.source.second_pass_ledger + + let target_first_pass_ledger t = t.statement.target.first_pass_ledger + + let transaction_type t = + Transaction_type.of_transaction + (With_status.data t.transaction_with_status) + + let of_same_block t1 t2 = + State_hash.equal (fst t1.state_hash) (fst t2.state_hash) + end + + include T + + module Tag = struct + [%%versioned + module Stable = struct + module V1 = struct + type t = T.Stable.V3.t State_hash.Tag.Stable.V1.t + + [%%define_locally State_hash.Tag.Stable.V1.(sexp_of_t, t_of_sexp)] + + let to_latest = Fn.id + end + end] + end + + module Tagged = struct + [%%versioned + module Stable = struct + [@@@no_toplevel_latest_type] + + module V1 = struct + type t = + { tag : Tag.Stable.V1.t + (* Consider removing it as well, it is used only in a handful of places *) + ; statement : Transaction_snark.Statement.Stable.V2.t + ; transaction_type : Mina_transaction.Transaction_type.Stable.V1.t + ; parent_state_hash : State_hash.Stable.V1.t + } + [@@deriving sexp] + + let to_latest = Fn.id + end + end] + + let source_second_pass_ledger t = + t.Stable.Latest.statement.source.second_pass_ledger + + let target_first_pass_ledger t = + t.Stable.Latest.statement.target.first_pass_ledger + + let transaction_type t = t.Stable.Latest.transaction_type + + let of_same_block t1 t2 = + State_hash.equal t1.Stable.Latest.parent_state_hash + t2.Stable.Latest.parent_state_hash + + let create ~tag (t : T.Stable.Latest.t) = + { Stable.Latest.tag + ; statement = t.statement + ; transaction_type = T.Stable.Latest.transaction_type t + ; parent_state_hash = fst @@ t.state_hash + } + + let statement t = t.Stable.Latest.statement + + type t = Stable.Latest.t + end + + let read_tag (tagged : Tagged.t) : Stable.Latest.t Or_error.t = + State_hash.File_storage.read (module Stable.Latest) tagged.tag + + let read_tag_exn ~error_tag tagged = + read_tag tagged |> Or_error.tag ~tag:error_tag |> Or_error.ok_exn + + let read_tags (tagged : Tagged.t list) : Stable.Latest.t list Or_error.t = + State_hash.File_storage.read_many + (module Stable.Latest) + (List.map ~f:(fun { tag; _ } -> tag) tagged) let write_all_proofs_to_disk ~signature_kind ~proof_cache_db - { Stable.Latest.transaction_with_info + { Stable.Latest.transaction_with_status ; state_hash ; statement ; init_stack ; first_pass_ledger_witness ; second_pass_ledger_witness ; block_global_slot + ; previous_protocol_state_body_opt + ; transaction_applied_tag } = - { transaction_with_info = - Mina_transaction_logic.Transaction_applied.write_all_proofs_to_disk - ~signature_kind ~proof_cache_db transaction_with_info + { transaction_with_status = + With_status.map + ~f: + (Transaction.write_all_proofs_to_disk ~signature_kind + ~proof_cache_db ) + transaction_with_status ; state_hash ; statement ; init_stack ; first_pass_ledger_witness ; second_pass_ledger_witness ; block_global_slot + ; previous_protocol_state_body_opt + ; transaction_applied_or_tag = Either.Second transaction_applied_tag } - let read_all_proofs_from_disk - { transaction_with_info + let read_all_proofs_from_disk writer + { transaction_with_status ; state_hash ; statement ; init_stack ; first_pass_ledger_witness ; second_pass_ledger_witness ; block_global_slot + ; previous_protocol_state_body_opt + ; transaction_applied_or_tag } = - { Stable.Latest.transaction_with_info = - Mina_transaction_logic.Transaction_applied.read_all_proofs_from_disk - transaction_with_info + { Stable.Latest.transaction_with_status = + With_status.map ~f:Transaction.read_all_proofs_from_disk + transaction_with_status ; state_hash ; statement ; init_stack ; first_pass_ledger_witness ; second_pass_ledger_witness ; block_global_slot + ; previous_protocol_state_body_opt + ; transaction_applied_tag = + ( match transaction_applied_or_tag with + | First data -> + Stable.V3.mk_transaction_applied_tag writer + @@ Mina_transaction_logic.Transaction_applied + .read_all_proofs_from_disk data + | Second tag -> + tag ) } + + let persist_many witnesses writer = + let module FS = State_hash.File_storage in + let write_witness = FS.write_value writer (module Stable.Latest) in + let write_witness' witness = + (* TODO remove read_all_proofs_from_disk *) + let stable = read_all_proofs_from_disk writer witness in + Tagged.create ~tag:(write_witness stable) stable + in + List.map ~f:write_witness' witnesses end module Ledger_proof_with_sok_message = struct + (* TODO In Mesa use Ledger_proof.t, no need for sok message *) [%%versioned module Stable = struct [@@@no_toplevel_latest_type] @@ -111,14 +318,132 @@ module Ledger_proof_with_sok_message = struct end end] - type t = Ledger_proof.Cached.t * Sok_message.t + module Tagged = struct + [%%versioned + module Stable = struct + module V1 = struct + type t = + { tag : + ( State_hash.Stable.V1.t + , Proof.Stable.V2.t ) + Multi_key_file_storage.Tag.Stable.V1.t + ; sok_message : Sok_message.Stable.V1.t + ; statement : Mina_state.Snarked_ledger_state.With_sok.Stable.V2.t + } + + let to_latest = Fn.id + end + end] + + let create ~tag ~sok_message ~statement = { tag; sok_message; statement } + + let statement (t : t) = { t.statement with sok_digest = () } + + let sok_digest (t : t) = t.statement.sok_digest + end + + let persist_many works writer = + let module FS = State_hash.File_storage in + let write_proof = FS.write_value writer (module Proof.Stable.Latest) in + let write_proof' ~fee ~prover proof = + (* TODO remove read_proof_from_disk *) + let stable = Ledger_proof.Cached.read_proof_from_disk proof in + let statement = Ledger_proof.statement_with_sok stable in + let proof = Ledger_proof.underlying_proof stable in + let sok_message = Sok_message.create ~fee ~prover in + Tagged.create ~tag:(write_proof proof) ~sok_message ~statement + in + List.concat_map works + ~f:(fun { Transaction_snark_work.proofs; fee; prover } -> + One_or_two.to_list proofs |> List.map ~f:(write_proof' ~fee ~prover) ) + + let read_tag ({ tag; sok_message; statement } : Tagged.t) : + Stable.Latest.t Or_error.t = + let%map.Or_error proof = + State_hash.File_storage.read (module Proof.Stable.Latest) tag + in + (Transaction_snark.create ~statement ~proof, sok_message) + + let read_tag_exn ~error_tag tagged = + read_tag tagged |> Or_error.tag ~tag:error_tag |> Or_error.ok_exn + + type t = Ledger_proof.t * Sok_message.t end module Available_job = struct type t = - ( Ledger_proof_with_sok_message.t - , Transaction_with_witness.t ) + ( Ledger_proof_with_sok_message.Tagged.t + , Transaction_with_witness.Tagged.t ) Parallel_scan.Available_job.t + + let is_transition (t : t) = match t with Base _ -> true | Merge _ -> false + + let target_second_pass_ledger (t : t) = + match t with + | Base { statement = { target = { second_pass_ledger; _ }; _ }; _ } -> + Some second_pass_ledger + | Merge _ -> + None + + let single_spec ~get_state = function + | Parallel_scan.Available_job.Merge (p1, p2) -> + let%bind.Or_error merged = + Transaction_snark.Statement.merge + (Ledger_proof_with_sok_message.Tagged.statement p1) + (Ledger_proof_with_sok_message.Tagged.statement p2) + in + let%bind.Or_error p1', _ = Ledger_proof_with_sok_message.read_tag p1 in + let%map.Or_error p2', _ = Ledger_proof_with_sok_message.read_tag p2 in + Snark_work_lib.Work.Single.Spec.Stable.Latest.Merge (merged, p1', p2') + | Base tagged_witness -> + let%bind.Or_error { transaction_with_status = + { data = transaction; status } + ; statement + ; state_hash + ; first_pass_ledger_witness = first_pass_ledger + ; second_pass_ledger_witness = second_pass_ledger + ; init_stack + ; block_global_slot + ; previous_protocol_state_body_opt + ; transaction_applied_tag = _ + } = + Transaction_with_witness.read_tag tagged_witness + in + let%map.Or_error protocol_state_body = + match previous_protocol_state_body_opt with + | Some protocol_state_body -> + Ok protocol_state_body + | None -> + get_state (fst state_hash) + |> Or_error.map ~f:Mina_state.Protocol_state.body + in + Snark_work_lib.Work.Single.Spec.Stable.Latest.Transition + ( statement + , { Transaction_witness.Stable.Latest.first_pass_ledger + ; second_pass_ledger + ; transaction + ; protocol_state_body + ; init_stack + ; status + ; block_global_slot + } ) + + let single_spec_one_or_two ~get_state = function + | `One job -> + Or_error.map ~f:(fun x -> `One x) (single_spec ~get_state job) + | `Two (job1, job2) -> + let%bind.Or_error spec1 = single_spec ~get_state job1 in + let%map.Or_error spec2 = single_spec ~get_state job2 in + `Two (spec1, spec2) + + let statement : t -> Transaction_snark.Statement.t option = function + | Base { statement; _ } -> + Some statement + | Merge (p1, p2) -> + Transaction_snark.Statement.merge + (Ledger_proof_with_sok_message.Tagged.statement p1) + (Ledger_proof_with_sok_message.Tagged.statement p2) + |> Result.ok end module Space_partition = Parallel_scan.Space_partition @@ -192,14 +517,49 @@ module Job_view = struct `List [ `Int position; job_to_yojson ] end -type job = Available_job.t +let hash_generic ~serialize_ledger_proof_with_sok_message + ~serialize_transaction_with_witness scan_state + previous_incomplete_zkapp_updates = + let state_hash = + Parallel_scan.State.hash scan_state serialize_ledger_proof_with_sok_message + serialize_transaction_with_witness + in + let ( previous_incomplete_zkapp_updates + , `Border_block_continued_in_the_next_tree continue_in_next_tree ) = + previous_incomplete_zkapp_updates + in + let incomplete_updates = + List.fold ~init:(Digestif.SHA256.init ()) previous_incomplete_zkapp_updates + ~f:(fun h t -> + Digestif.SHA256.feed_string h @@ serialize_transaction_with_witness t ) + |> Digestif.SHA256.get + in + let continue_in_next_tree = + Digestif.SHA256.digest_string (Bool.to_string continue_in_next_tree) + in + [ state_hash; incomplete_updates; continue_in_next_tree ] + |> List.fold ~init:(Digestif.SHA256.init ()) ~f:(fun h t -> + Digestif.SHA256.feed_string h (Digestif.SHA256.to_raw_string t) ) + |> Digestif.SHA256.get |> Staged_ledger_hash.Aux_hash.of_sha256 (*Scan state and any zkapp updates that were applied to the to the most recent snarked ledger but are from the tree just before the tree corresponding to the snarked ledger*) [%%versioned module Stable = struct - [@@@no_toplevel_latest_type] + module V3 = struct + type t = + { scan_state : + ( Ledger_proof_with_sok_message.Tagged.Stable.V1.t + , Transaction_with_witness.Tagged.Stable.V1.t ) + Parallel_scan.State.Stable.V1.t + ; previous_incomplete_zkapp_updates : + Transaction_with_witness.Tagged.Stable.V1.t list + * [ `Border_block_continued_in_the_next_tree of bool ] + } + + let to_latest = Fn.id + end module V2 = struct type t = @@ -212,57 +572,104 @@ module Stable = struct * [ `Border_block_continued_in_the_next_tree of bool ] } - let to_latest = Fn.id + let of_latest_exn : V3.t -> t = + let f1 = + Ledger_proof_with_sok_message.read_tag_exn ~error_tag:"v3 -> v2" + in + let f2 w = + Transaction_with_witness.read_tag_exn ~error_tag:"v3 -> v2" w + |> Transaction_with_witness.Stable.V2.of_latest_exn + in + fun { scan_state + ; previous_incomplete_zkapp_updates = updates, continue_in_next_tree + } -> + { scan_state = Parallel_scan.State.map scan_state ~f1 ~f2 + ; previous_incomplete_zkapp_updates = + (List.map updates ~f:f2, continue_in_next_tree) + } + + let to_latest : t -> V3.t = + fun { scan_state + ; previous_incomplete_zkapp_updates = updates, continue_in_next_tree + } -> + (* TODO: Although this trick will work, it is not the best way to do it. + Conversion logic is dependent upon the fact that it's safe to write to + location associated with `State_hash.dummy`. + Instead of having V3 for the same module, let's create a different module + equivalent to V3 and have `to_latest` accept writer as an argument. + *) + State_hash.File_storage.write_values_exn State_hash.dummy + ~f:(fun writer -> + let f1 + ((proof, sok_message) : Ledger_proof_with_sok_message.Stable.V2.t) + = + let statement = Ledger_proof.statement_with_sok proof in + let proof' = Ledger_proof.underlying_proof proof in + let tag = + State_hash.File_storage.write_value writer + (module Proof.Stable.V2) + proof' + in + Ledger_proof_with_sok_message.Tagged.create ~tag ~sok_message + ~statement + in + let f2 witness = + let stable = + Transaction_with_witness.Stable.V2.to_latest writer witness + in + let tag = + State_hash.File_storage.write_value writer + (module Transaction_with_witness.Stable.V3) + stable + in + Transaction_with_witness.Tagged.create ~tag stable + in + { V3.scan_state = Parallel_scan.State.map scan_state ~f1 ~f2 + ; previous_incomplete_zkapp_updates = + (List.map updates ~f:f2, continue_in_next_tree) + } ) let hash (t : t) = - let state_hash = - Parallel_scan.State.hash t.scan_state + hash_generic t.scan_state t.previous_incomplete_zkapp_updates + ~serialize_ledger_proof_with_sok_message: (Binable.to_string (module Ledger_proof_with_sok_message.Stable.V2)) + ~serialize_transaction_with_witness: (Binable.to_string (module Transaction_with_witness.Stable.V2)) - in - let ( previous_incomplete_zkapp_updates - , `Border_block_continued_in_the_next_tree continue_in_next_tree ) = - t.previous_incomplete_zkapp_updates - in - let incomplete_updates = - List.fold ~init:(Digestif.SHA256.init ()) - previous_incomplete_zkapp_updates ~f:(fun h t -> - Digestif.SHA256.feed_string h - @@ Binable.to_string (module Transaction_with_witness.Stable.V2) t ) - |> Digestif.SHA256.get - in - let continue_in_next_tree = - Digestif.SHA256.digest_string (Bool.to_string continue_in_next_tree) - in - [ state_hash; incomplete_updates; continue_in_next_tree ] - |> List.fold ~init:(Digestif.SHA256.init ()) ~f:(fun h t -> - Digestif.SHA256.feed_string h (Digestif.SHA256.to_raw_string t) ) - |> Digestif.SHA256.get |> Staged_ledger_hash.Aux_hash.of_sha256 + + let serialize_ledger_proof_with_sok_message_tagged = + Fn.compose + (Binable.to_string (module Ledger_proof_with_sok_message.Stable.V2)) + @@ Ledger_proof_with_sok_message.read_tag_exn + ~error_tag:"scan state hashing" + + let serialize_transaction_with_witness_tagged w = + Binable.to_string (module Transaction_with_witness.Stable.V2) + @@ Transaction_with_witness.Stable.V2.of_latest_exn + @@ Transaction_with_witness.read_tag_exn ~error_tag:"scan state hashing" w end end] -type t = - { scan_state : - ( Ledger_proof_with_sok_message.t - , Transaction_with_witness.t ) - Parallel_scan.State.t - ; previous_incomplete_zkapp_updates : - Transaction_with_witness.t list - * [ `Border_block_continued_in_the_next_tree of bool ] - } +let hash t = + hash_generic t.scan_state t.previous_incomplete_zkapp_updates + ~serialize_ledger_proof_with_sok_message: + Stable.V2.serialize_ledger_proof_with_sok_message_tagged + ~serialize_transaction_with_witness: + Stable.V2.serialize_transaction_with_witness_tagged (**********Helpers*************) let create_expected_statement ~constraint_constants ~(get_state : State_hash.t -> Mina_state.Protocol_state.value Or_error.t) ~connecting_merkle_root - { Transaction_with_witness.transaction_with_info + { Transaction_with_witness.transaction_with_status ; state_hash ; first_pass_ledger_witness ; second_pass_ledger_witness - ; init_stack + ; init_stack = pending_coinbase_before ; statement ; block_global_slot + ; previous_protocol_state_body_opt + ; transaction_applied_or_tag = _ } = let open Or_error.Let_syntax in let source_first_pass_merkle_root = @@ -273,11 +680,18 @@ let create_expected_statement ~constraint_constants Frozen_ledger_hash.of_ledger_hash @@ Sparse_ledger.merkle_root second_pass_ledger_witness in - let { With_status.data = transaction; status = _ } = - Ledger.transaction_of_applied transaction_with_info + let transaction = With_status.data transaction_with_status in + let%bind previous_protocol_state_body = + match previous_protocol_state_body_opt with + | Some protocol_state -> + Ok protocol_state + | None -> + get_state (fst state_hash) + |> Or_error.map ~f:Mina_state.Protocol_state.body + in + let state_view = + Mina_state.Protocol_state.Body.view previous_protocol_state_body in - let%bind protocol_state = get_state (fst state_hash) in - let state_view = Mina_state.Protocol_state.Body.view protocol_state.body in let empty_local_state = Mina_state.Local_state.empty () in let%bind ( target_first_pass_merkle_root , target_second_pass_merkle_root @@ -307,15 +721,6 @@ let create_expected_statement ~constraint_constants , target_second_pass_merkle_root , supply_increase ) in - let%bind pending_coinbase_before = - match init_stack with - | Base source -> - Ok source - | Merge -> - Or_error.errorf - !"Invalid init stack in Pending coinbase stack state . Expected Base \ - found Merge" - in let pending_coinbase_after = let state_body_hash = snd state_hash in let pending_coinbase_with_state = @@ -348,8 +753,10 @@ let create_expected_statement ~constraint_constants ; sok_digest = () } -let total_proofs (works : Transaction_snark_work.t list) = - List.sum (module Int) works ~f:(fun w -> One_or_two.length w.proofs) +(* + TODO: move to a different module and use + let total_proofs (works : Transaction_snark_work.t list) = + List.sum (module Int) works ~f:(fun w -> One_or_two.length w.proofs) *) (*************exposed functions*****************) @@ -358,7 +765,7 @@ module Make_statement_scanner (Verifier : sig val verify : verifier:t - -> Ledger_proof_with_sok_message.t list + -> Ledger_proof_with_sok_message.Stable.Latest.t list -> unit Or_error.t Deferred.Or_error.t end) = struct @@ -413,9 +820,13 @@ struct "%s timing" label end + let proof_cache_db = Proof_cache_tag.create_identity_db () + (*TODO: fold over the pending_coinbase tree and validate the statements?*) let scan_statement (type merge) ~constraint_constants ~logger - ~merge_to_statement tree ~statement_check ~verify = + ~merge_to_statement + (tree : (merge, Transaction_with_witness.Tagged.t) Parallel_scan.State.t) + ~statement_check ~verify = let open Deferred.Or_error.Let_syntax in let timer = Timer.create ~logger () in let yield_occasionally = @@ -495,11 +906,20 @@ struct (acc_stmt, acc_pc) in let check_base (acc_statement, acc_pc) - (transaction : Transaction_with_witness.t) = + (tagged : Transaction_with_witness.Tagged.t) = with_error "Bad base statement" ~f:(fun () -> let%bind expected_statement = match statement_check with | `Full get_state -> + let%bind transaction_stable = + Transaction_with_witness.read_tag tagged |> Deferred.return + in + let transaction = + (* TODO: hash computation insude, remove it *) + Transaction_with_witness.write_all_proofs_to_disk + ~signature_kind:Mina_signature_kind.t_DEPRECATED + ~proof_cache_db transaction_stable + in let%bind result = Timer.time timer (sprintf "create_expected_statement:%s" __LOC__) (fun () -> @@ -513,18 +933,18 @@ struct let%map () = yield_always () in result | `Partial -> - return transaction.statement + return tagged.statement in let%bind () = yield_always () in if - Transaction_snark.Statement.equal transaction.statement + Transaction_snark.Statement.equal tagged.statement expected_statement then let%bind acc_stmt = - merge_acc ~proofs:[] acc_statement transaction.statement + merge_acc ~proofs:[] acc_statement tagged.statement in let%map acc_pc = - merge_pc acc_pc transaction.statement |> Deferred.return + merge_pc acc_pc tagged.statement |> Deferred.return in (acc_stmt, acc_pc) else @@ -533,7 +953,7 @@ struct !"Bad base statement expected: \ %{sexp:Transaction_snark.Statement.t} got: \ %{sexp:Transaction_snark.Statement.t}" - transaction.statement expected_statement ) ) + tagged.statement expected_statement ) ) in let fold_step_d (acc_statement, acc_pc) job = match job with @@ -541,7 +961,7 @@ struct return (acc_statement, acc_pc) | Full { status = Parallel_scan.Job_status.Done - ; job = (transaction : Transaction_with_witness.t) + ; job = (transaction : Transaction_with_witness.Tagged.t) ; _ } -> let%map acc_pc = @@ -584,8 +1004,11 @@ struct | Error e -> Deferred.return (Error (`Error e)) - let check_invariants_impl parallel_scan_state ~merge_to_statement - ~constraint_constants ~logger ~statement_check ~verify ~error_prefix + let check_invariants_impl + (parallel_scan_state : + (_, Transaction_with_witness.Tagged.t) Parallel_scan.State.t ) + ~merge_to_statement ~constraint_constants ~logger ~statement_check ~verify + ~error_prefix ~(last_proof_statement : Transaction_snark.Statement.t option) ~(registers_end : ( Frozen_ledger_hash.t @@ -665,21 +1088,19 @@ struct in () - let check_invariants (t : t) ~verifier = + let check_invariants t ~verifier = + let verify tagged_list = + let%bind.Deferred.Or_error ps = + Mina_stdlib.Result.List.map ~f:Ledger_proof_with_sok_message.read_tag + tagged_list + |> Deferred.return + in + Verifier.verify ~verifier ps + in check_invariants_impl t.scan_state - ~merge_to_statement:(Fn.compose Ledger_proof.Cached.statement fst) - ~verify:(Verifier.verify ~verifier) + ~merge_to_statement:Ledger_proof_with_sok_message.Tagged.statement ~verify end -let statement_of_job : job -> Transaction_snark.Statement.t option = function - | Base { statement; _ } -> - Some statement - | Merge ((p1, _), (p2, _)) -> - Transaction_snark.Statement.merge - (Ledger_proof.Cached.statement p1) - (Ledger_proof.Cached.statement p2) - |> Result.ok - let create ~work_delay ~transaction_capacity_log_2 : t = let k = Int.pow 2 transaction_capacity_log_2 in { scan_state = Parallel_scan.empty ~delay:work_delay ~max_base_jobs:k @@ -692,178 +1113,210 @@ let empty ~(constraint_constants : Genesis_constants.Constraint_constants.t) () create ~work_delay:constraint_constants.work_delay ~transaction_capacity_log_2:constraint_constants.transaction_capacity_log_2 -module Transactions_ordered = struct +module Transactions_categorized = struct module Poly = struct + (** Represents sequence of transactions extracted from scan state + when it emitted a proof, split into: + + * [first_pass] - transactions that went through first pass + * [second_pass] - transactions that went through second pass and correspond + to the current ledger proof (subset of first pass group) + * [current_incomplete] - transactions that went through second pass and correspond + to the the next ledger proof (subset of first pass group) + * [previous_incomplete] - leftover from previous ledger proof emitted with + the current ledger proof (not intersecting with other groups) + *) type 'a t = { first_pass : 'a list ; second_pass : 'a list ; previous_incomplete : 'a list - ; current_incomplete : 'a list + ; continued_in_the_next_tree : bool } [@@deriving sexp, to_yojson] end type t = Transaction_with_witness.t Poly.t - let map (t : 'a Poly.t) ~f : 'b Poly.t = - let f = List.map ~f in - { Poly.first_pass = f t.first_pass - ; second_pass = f t.second_pass - ; previous_incomplete = f t.previous_incomplete - ; current_incomplete = f t.current_incomplete - } - let fold (t : 'a Poly.t) ~f ~init = let init = List.fold ~init t.first_pass ~f in let init = List.fold ~init t.previous_incomplete ~f in - let init = List.fold ~init t.second_pass ~f in - List.fold ~init t.current_incomplete ~f + List.fold ~init t.second_pass ~f +end - let first_and_second_pass_transactions_per_tree ~previous_incomplete - (txns_per_tree : Transaction_with_witness.t list) = - let complete_and_incomplete_transactions = function - | [] -> - None - | (h : Transaction_with_witness.t) :: _ as txns_with_witnesses -> - let target_first_pass_ledger = h.statement.source.first_pass_ledger in - let first_pass_txns, second_pass_txns, target_first_pass_ledger = - let first_pass_txns, second_pass_txns, target_first_pass_ledger = - List.fold ~init:([], [], target_first_pass_ledger) - txns_with_witnesses - ~f:(fun - (first_pass_txns, second_pass_txns, _old_root) - (txn_with_witness : Transaction_with_witness.t) - -> - let txn = - Ledger.transaction_of_applied - txn_with_witness.transaction_with_info - in - let target_first_pass_ledger = - txn_with_witness.statement.target.first_pass_ledger - in - match txn.data with - | Transaction.Coinbase _ - | Fee_transfer _ - | Command (User_command.Signed_command _) -> - ( txn_with_witness :: first_pass_txns - , second_pass_txns - , target_first_pass_ledger ) - | Command (Zkapp_command _) -> - ( txn_with_witness :: first_pass_txns - , txn_with_witness :: second_pass_txns - , target_first_pass_ledger ) ) - in - ( List.rev first_pass_txns - , List.rev second_pass_txns - , target_first_pass_ledger ) - in - let second_pass_txns, incomplete_txns = - match List.hd second_pass_txns with - | None -> - ([], []) - | Some txn_with_witness -> - if - Frozen_ledger_hash.equal - txn_with_witness.statement.source.second_pass_ledger - target_first_pass_ledger - then - (*second pass completed in the same tree*) - (second_pass_txns, []) - else ([], second_pass_txns) - in - let previous_incomplete = - match previous_incomplete with - | [] -> - [] - | (t : Transaction_with_witness.t) :: _ -> - if State_hash.equal (fst t.state_hash) (fst h.state_hash) then - (*same block*) - previous_incomplete - else [] - in - Some - { Poly.first_pass = first_pass_txns - ; second_pass = second_pass_txns - ; current_incomplete = incomplete_txns - ; previous_incomplete - } +module Make_transaction_categorizer (Tx : sig + type t + + val source_second_pass_ledger : t -> Ledger_hash.t + + val target_first_pass_ledger : t -> Ledger_hash.t + + val transaction_type : t -> Mina_transaction.Transaction_type.t + + val of_same_block : t -> t -> bool +end) = +struct + let txns_by_block txns_per_tree = + List.group txns_per_tree ~break:(fun t1 t2 -> not (Tx.of_same_block t1 t2)) + |> List.filter_map ~f:Mina_stdlib.Nonempty_list.of_list_opt + + (** Compoutes representation for the sequence of transactions extracted from scan state + when it emitted a proof, split into: + + * [first_pass] - transactions that went through first pass + * [second_pass] - transactions that went through second pass and correspond + to the current ledger proof (subset of first pass group) + * [current_incomplete] - transactions that went through second pass and correspond + to the the next ledger proof (subset of first pass group) + * [previous_incomplete] - leftover from previous ledger proof emitted with + the current ledger proof (not intersecting with other groups) + Received as a parameter and passed through if the first transaction in it + belongs to the same block as the first transaction in [txns_with_witnesses_non_empty]. + *) + let categorize_transactions ~previous_incomplete txns_non_empty = + let first_txn = Mina_stdlib.Nonempty_list.head txns_non_empty in + let txns = Mina_stdlib.Nonempty_list.to_list txns_non_empty in + let target_first_pass_ledger = + Tx.target_first_pass_ledger + (Mina_stdlib.Nonempty_list.last txns_non_empty) + in + let second_pass_txns = + List.filter txns ~f:(fun txn -> + match Tx.transaction_type txn with + | `Zkapp_command -> + true + | _ -> + false ) + in + (* determine whether second pass completed in the same tree *) + let continued_in_the_next_tree = + Option.value_map ~default:false ~f:(fun txn -> + not + @@ Frozen_ledger_hash.equal + (Tx.source_second_pass_ledger txn) + target_first_pass_ledger ) + @@ List.hd second_pass_txns + in + let previous_incomplete = + match previous_incomplete with + | t :: _ when Tx.of_same_block t first_txn -> + previous_incomplete + | _ -> + [] in - let txns_by_block (txns_per_tree : Transaction_with_witness.t list) = - List.group txns_per_tree ~break:(fun t1 t2 -> - State_hash.equal (fst t1.state_hash) (fst t2.state_hash) |> not ) + { Transactions_categorized.Poly.first_pass = txns + ; second_pass = second_pass_txns + ; previous_incomplete + ; continued_in_the_next_tree + } + + let second_pass_last_block txns_per_tree = + let%map.Option last_group = List.last (txns_by_block txns_per_tree) in + let { Transactions_categorized.Poly.second_pass + ; continued_in_the_next_tree + ; _ + } = + (* [previous_incomplete] is ok to be set empty because it affects + only the [previous_incomplete] field of the result *) + categorize_transactions ~previous_incomplete:[] last_group in - List.filter_map ~f:complete_and_incomplete_transactions + ( second_pass + , `Border_block_continued_in_the_next_tree continued_in_the_next_tree ) + + let categorize_transactions_per_tree ~previous_incomplete txns_per_tree = + List.map (txns_by_block txns_per_tree) + ~f:(categorize_transactions ~previous_incomplete) - let first_and_second_pass_transactions_per_forest scan_state_txns - ~previous_incomplete = + let categorize_transactions_per_forest scan_state_txns ~previous_incomplete = List.map scan_state_txns - ~f:(first_and_second_pass_transactions_per_tree ~previous_incomplete) + ~f:(categorize_transactions_per_tree ~previous_incomplete) end +module Witness_categorizer = + Make_transaction_categorizer (Transaction_with_witness) +module Tagged_categorizer = + Make_transaction_categorizer (Transaction_with_witness.Tagged) + let extract_txn_and_global_slot (txn_with_witness : Transaction_with_witness.t) = - let txn = - Ledger.transaction_of_applied txn_with_witness.transaction_with_info - in + let txn = txn_with_witness.transaction_with_status in let state_hash = fst txn_with_witness.state_hash in let global_slot = txn_with_witness.block_global_slot in (txn, state_hash, global_slot) -let latest_ledger_proof' t = - let open Option.Let_syntax in - let%map proof, txns_with_witnesses = - Parallel_scan.last_emitted_value t.scan_state - in - let ( previous_incomplete - , `Border_block_continued_in_the_next_tree continued_in_next_tree ) = - t.previous_incomplete_zkapp_updates - in +let latest_ledger_proof_statement t = + let%map.Option tagged, _ = Parallel_scan.last_emitted_value t.scan_state in + Ledger_proof_with_sok_message.Tagged.statement tagged + +let latest_recent_proof_txs_impl ~process ~continued_in_next_tree + ~previous_incomplete txns_with_witnesses = let txns = - if continued_in_next_tree then - Transactions_ordered.first_and_second_pass_transactions_per_tree - txns_with_witnesses ~previous_incomplete - else - let txns = - Transactions_ordered.first_and_second_pass_transactions_per_tree - txns_with_witnesses ~previous_incomplete:[] - in - if List.is_empty previous_incomplete then txns - else - { Transactions_ordered.Poly.first_pass = [] - ; second_pass = [] - ; previous_incomplete - ; current_incomplete = [] - } - :: txns + process + ~previous_incomplete: + (if continued_in_next_tree then previous_incomplete else []) + txns_with_witnesses in - (proof, txns) + if List.is_empty previous_incomplete || continued_in_next_tree then txns + else + { Transactions_categorized.Poly.first_pass = [] + ; second_pass = [] + ; previous_incomplete + ; continued_in_the_next_tree = false + } + :: txns -let latest_ledger_proof t = - Option.map (latest_ledger_proof' t) ~f:(fun (p, txns) -> - ( p - , List.map txns - ~f:(Transactions_ordered.map ~f:extract_txn_and_global_slot) ) ) +let read_tags_and_write_proofs ~signature_kind ~proof_cache_db txns_tagged = + let%map.Or_error txns_stable = + Transaction_with_witness.read_tags txns_tagged + in + (* TODO: hash computation insude, remove it *) + List.map + ~f: + (Transaction_with_witness.write_all_proofs_to_disk ~signature_kind + ~proof_cache_db ) + txns_stable + +let latest_recent_proof_txs_untagged ~signature_kind ~proof_cache_db t = + match Parallel_scan.last_emitted_value t.scan_state |> Option.map ~f:snd with + | None -> + Or_error.return None + | Some txns_with_witnesses_tagged -> + let ( previous_incomplete_tagged + , `Border_block_continued_in_the_next_tree continued_in_next_tree ) = + t.previous_incomplete_zkapp_updates + in + let%bind.Or_error txns_with_witnesses = + read_tags_and_write_proofs ~signature_kind ~proof_cache_db + txns_with_witnesses_tagged + in + let%map.Or_error previous_incomplete = + read_tags_and_write_proofs ~signature_kind ~proof_cache_db + previous_incomplete_tagged + in + latest_recent_proof_txs_impl + ~process:Witness_categorizer.categorize_transactions_per_tree + ~continued_in_next_tree ~previous_incomplete txns_with_witnesses + |> Option.some let incomplete_txns_from_recent_proof_tree t = - let open Option.Let_syntax in - let%map proof, txns_per_block = latest_ledger_proof' t in - let txns = - match List.last txns_per_block with - | None -> - ([], `Border_block_continued_in_the_next_tree false) - | Some txns_in_last_block -> - (*First pass ledger is considered as the snarked ledger, so any account update whether completed in the same tree or not should be included in the next tree *) - if not (List.is_empty txns_in_last_block.second_pass) then - ( txns_in_last_block.second_pass - , `Border_block_continued_in_the_next_tree false ) - else - ( txns_in_last_block.current_incomplete - , `Border_block_continued_in_the_next_tree true ) + let%map.Option tagged, txns_with_witnesses = + Parallel_scan.last_emitted_value t.scan_state in - (proof, txns) + (* First pass ledger is considered as the snarked ledger, + so any account update whether completed in the same tree + or not should be included in the next tree *) + let res = + Tagged_categorizer.second_pass_last_block txns_with_witnesses + |> Option.value ~default:([], `Border_block_continued_in_the_next_tree false) + in + (Ledger_proof_with_sok_message.Tagged.statement tagged, res) let staged_transactions t = + let process ~previous_incomplete txns = + Tagged_categorizer.categorize_transactions_per_forest ~previous_incomplete + txns + |> List.concat + in let ( previous_incomplete , `Border_block_continued_in_the_next_tree continued_in_next_tree ) = Option.value_map @@ -871,39 +1324,40 @@ let staged_transactions t = (incomplete_txns_from_recent_proof_tree t) ~f:snd in - let txns = - if continued_in_next_tree then - Transactions_ordered.first_and_second_pass_transactions_per_forest - (Parallel_scan.pending_data t.scan_state) - ~previous_incomplete - else - let txns = - Transactions_ordered.first_and_second_pass_transactions_per_forest - (Parallel_scan.pending_data t.scan_state) - ~previous_incomplete:[] - in - if List.is_empty previous_incomplete then txns - else - [ { Transactions_ordered.Poly.first_pass = [] - ; second_pass = [] - ; previous_incomplete - ; current_incomplete = [] - } - ] - :: txns + let txns_with_witnesses = Parallel_scan.pending_data t.scan_state in + latest_recent_proof_txs_impl ~process ~continued_in_next_tree + ~previous_incomplete txns_with_witnesses + +let staged_transactions_untagged ~signature_kind ~proof_cache_db t = + let process ~previous_incomplete txns = + Witness_categorizer.categorize_transactions_per_forest ~previous_incomplete + txns + |> List.concat in - List.concat txns - -(*All the transactions in the order in which they were applied along with the parent protocol state of the blocks that contained them*) -let staged_transactions_with_state_hash t = - let pending_transactions_per_block = staged_transactions t in - List.map pending_transactions_per_block - ~f:(Transactions_ordered.map ~f:extract_txn_and_global_slot) + let ( previous_incomplete_tagged + , `Border_block_continued_in_the_next_tree continued_in_next_tree ) = + Option.value_map + ~default:([], `Border_block_continued_in_the_next_tree false) + (incomplete_txns_from_recent_proof_tree t) + ~f:snd + in + let txns_with_witnesses_tagged = Parallel_scan.pending_data t.scan_state in + let%bind.Or_error txns_with_witnesses = + Mina_stdlib.Result.List.map + ~f:(read_tags_and_write_proofs ~signature_kind ~proof_cache_db) + txns_with_witnesses_tagged + in + let%map.Or_error previous_incomplete = + read_tags_and_write_proofs ~signature_kind ~proof_cache_db + previous_incomplete_tagged + in + latest_recent_proof_txs_impl ~process ~continued_in_next_tree + ~previous_incomplete txns_with_witnesses (* written in continuation passing style so that implementation can be used both sync and async *) -let apply_ordered_txns_stepwise ?(stop_at_first_pass = false) ordered_txns - ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass - ~apply_first_pass_sparse_ledger = +let apply_categorized_txns_stepwise ?(stop_at_first_pass = false) + categorized_txns ~ledger ~get_protocol_state ~apply_first_pass + ~apply_second_pass ~apply_first_pass_sparse_ledger = let open Or_error.Let_syntax in let module Previous_incomplete_txns = struct type t = @@ -950,7 +1404,9 @@ let apply_ordered_txns_stepwise ?(stop_at_first_pass = false) ordered_txns k () | (expected_status, partially_applied_txn) :: partially_applied_txns' -> let%bind res = apply_second_pass ledger partially_applied_txn in - let status = Ledger.status_of_applied res in + let status = + Mina_transaction_logic.Transaction_applied.transaction_status res + in if Transaction_status.equal expected_status status then Ok (`Continue @@ -1067,7 +1523,7 @@ let apply_ordered_txns_stepwise ?(stop_at_first_pass = false) ordered_txns apply_txns_second_pass partially_applied_txns ~k in let rec apply_txns (previous_incomplete : Previous_incomplete_txns.t) - (ordered_txns : _ Transactions_ordered.Poly.t list) + (categorized_txns : _ Transactions_categorized.Poly.t list) ~first_pass_ledger_hash ~signature_kind = let previous_incomplete = (*filter out any non-zkapp transactions for second pass application*) @@ -1075,10 +1531,7 @@ let apply_ordered_txns_stepwise ?(stop_at_first_pass = false) ordered_txns | Previous_incomplete_txns.Unapplied txns -> Previous_incomplete_txns.Unapplied (List.filter txns ~f:(fun txn -> - match - (Ledger.transaction_of_applied txn.transaction_with_info) - .data - with + match With_status.data txn.transaction_with_status with | Command (Zkapp_command _) -> true | _ -> @@ -1088,7 +1541,7 @@ let apply_ordered_txns_stepwise ?(stop_at_first_pass = false) ordered_txns (List.filter txns ~f:(fun (_, t) -> match t with Zkapp_command _ -> true | _ -> false ) ) in - match ordered_txns with + match categorized_txns with | [] -> apply_previous_incomplete_txns ~signature_kind ~k:(fun () -> Ok (`Complete first_pass_ledger_hash)) @@ -1102,7 +1555,7 @@ let apply_ordered_txns_stepwise ?(stop_at_first_pass = false) ordered_txns previous_incomplete txns will be applied when processing the first set. The subsequent sets shouldn’t have any previous-incomplete.*) apply_txns (Unapplied []) [] ~first_pass_ledger_hash ~signature_kind ) - | txns_per_block :: ordered_txns' -> + | txns_per_block :: categorized_txns' -> (*Apply first pass of a blocks transactions either new or continued from previous tree*) apply_txns_first_pass txns_per_block.first_pass ~k:(fun first_pass_ledger_hash partially_applied_txns -> @@ -1119,26 +1572,28 @@ let apply_ordered_txns_stepwise ?(stop_at_first_pass = false) ordered_txns not (List.is_empty txns) in previous_not_empty - && not (List.is_empty txns_per_block.current_incomplete) + && txns_per_block.continued_in_the_next_tree in let do_second_pass = (*if transactions completed in the same tree; do second pass now*) - (not (List.is_empty txns_per_block.second_pass)) + (not + ( txns_per_block.continued_in_the_next_tree + || List.is_empty txns_per_block.second_pass ) ) || continue_previous_tree's_txns in if do_second_pass then apply_txns_second_pass partially_applied_txns ~k:(fun () -> - apply_txns (Unapplied []) ordered_txns' + apply_txns (Unapplied []) categorized_txns' ~first_pass_ledger_hash ~signature_kind ) else (*Transactions not completed in this tree, so second pass after first pass of remaining transactions for the same block in the next tree*) apply_txns (Partially_applied partially_applied_txns) - ordered_txns' ~first_pass_ledger_hash ~signature_kind ) ) + categorized_txns' ~first_pass_ledger_hash ~signature_kind ) ) in let previous_incomplete = - Option.value_map (List.hd ordered_txns) + Option.value_map (List.hd categorized_txns) ~default:(Previous_incomplete_txns.Unapplied []) - ~f:(fun (first_block : Transactions_ordered.t) -> + ~f:(fun (first_block : Transactions_categorized.t) -> Unapplied first_block.previous_incomplete ) in (*Assuming this function is called on snarked ledger and snarked ledger is the @@ -1146,9 +1601,9 @@ let apply_ordered_txns_stepwise ?(stop_at_first_pass = false) ordered_txns let first_pass_ledger_hash = `First_pass_ledger_hash (Ledger.merkle_root ledger) in - apply_txns previous_incomplete ordered_txns ~first_pass_ledger_hash + apply_txns previous_incomplete categorized_txns ~first_pass_ledger_hash -let apply_ordered_txns_sync ?stop_at_first_pass ordered_txns ~ledger +let apply_categorized_txns_sync ?stop_at_first_pass categorized_txns ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind = let rec run = function @@ -1160,11 +1615,11 @@ let apply_ordered_txns_sync ?stop_at_first_pass ordered_txns ~ledger Error err in run - @@ apply_ordered_txns_stepwise ?stop_at_first_pass ordered_txns ~ledger - ~get_protocol_state ~apply_first_pass ~apply_second_pass + @@ apply_categorized_txns_stepwise ?stop_at_first_pass categorized_txns + ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind -let apply_ordered_txns_async ?stop_at_first_pass ordered_txns +let apply_categorized_txns_async ?stop_at_first_pass categorized_txns ?(async_batch_size = 10) ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind = let open Deferred.Result.Let_syntax in @@ -1183,39 +1638,62 @@ let apply_ordered_txns_async ?stop_at_first_pass ordered_txns Deferred.return (Error err) in run - @@ apply_ordered_txns_stepwise ?stop_at_first_pass ordered_txns ~ledger - ~get_protocol_state ~apply_first_pass ~apply_second_pass + @@ apply_categorized_txns_stepwise ?stop_at_first_pass categorized_txns + ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind +(* Used in move_root if the block emitted a proof *) let get_snarked_ledger_sync ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind t = - match latest_ledger_proof' t with + (* NOTE: data is short-lived, so it's ok to use identity cache *) + match%bind.Or_error + latest_recent_proof_txs_untagged ~signature_kind + ~proof_cache_db:(Proof_cache_tag.create_identity_db ()) + t + with | None -> Or_error.errorf "No transactions found" - | Some (_, txns_per_block) -> - apply_ordered_txns_sync ~stop_at_first_pass:true txns_per_block ~ledger - ~get_protocol_state ~apply_first_pass ~apply_second_pass + | Some txns_per_block -> + apply_categorized_txns_sync ~stop_at_first_pass:true txns_per_block + ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind |> Or_error.ignore_m +(* Used in get_snarked_ledger_full, which is used for: + - Checking membership of an account vs ledger (GraphQL) + - Client's endpoint to export ledger + - Hardfork migration *) let get_snarked_ledger_async ?async_batch_size ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind t = - match latest_ledger_proof' t with + (* NOTE: data is short-lived, so it's ok to use identity cache *) + match%bind.Deferred.Or_error + latest_recent_proof_txs_untagged ~signature_kind + ~proof_cache_db:(Proof_cache_tag.create_identity_db ()) + t + |> Deferred.return + with | None -> Deferred.Or_error.errorf "No transactions found" - | Some (_, txns_per_block) -> - apply_ordered_txns_async ~stop_at_first_pass:true txns_per_block + | Some txns_per_block -> + apply_categorized_txns_async ~stop_at_first_pass:true txns_per_block ?async_batch_size ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind |> Deferred.Or_error.ignore_m +(* Used in loading the root from disk or receiving it during bootstrap *) let get_staged_ledger_async ?async_batch_size ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind t = - let staged_transactions_with_state_hash = staged_transactions t in - apply_ordered_txns_async staged_transactions_with_state_hash ?async_batch_size - ~ledger ~get_protocol_state ~apply_first_pass ~apply_second_pass + (* NOTE: data is short-lived, so it's ok to use identity cache *) + let%bind.Deferred.Or_error staged_txns = + staged_transactions_untagged ~signature_kind + ~proof_cache_db:(Proof_cache_tag.create_identity_db ()) + t + |> Deferred.return + in + apply_categorized_txns_async staged_txns ?async_batch_size ~ledger + ~get_protocol_state ~apply_first_pass ~apply_second_pass ~apply_first_pass_sparse_ledger ~signature_kind let free_space t = Parallel_scan.free_space t.scan_state @@ -1225,12 +1703,6 @@ let all_jobs t = Parallel_scan.all_jobs t.scan_state let next_on_new_tree t = Parallel_scan.next_on_new_tree t.scan_state -let base_jobs_on_latest_tree t = - Parallel_scan.base_jobs_on_latest_tree t.scan_state - -let base_jobs_on_earlier_tree t = - Parallel_scan.base_jobs_on_earlier_tree t.scan_state - let partition_if_overflowing t = let bundle_count work_count = (work_count + 1) / 2 in let { Space_partition.first = slots, job_count; second } = @@ -1242,26 +1714,10 @@ let partition_if_overflowing t = (slots, bundle_count job_count) ) } -let extract_from_job (job : job) = - match job with - | Parallel_scan.Available_job.Base d -> - First - ( d.transaction_with_info - , d.statement - , d.state_hash - , d.first_pass_ledger_witness - , d.second_pass_ledger_witness - , d.init_stack - , d.block_global_slot ) - | Merge ((p1, _), (p2, _)) -> - Second (p1, p2) - let snark_job_list_json t = let all_jobs : Job_view.t list list = - let fa (a : Ledger_proof_with_sok_message.t) = - Ledger_proof.Cached.statement (fst a) - in - let fd (d : Transaction_with_witness.t) = d.statement in + let fa a = Ledger_proof_with_sok_message.Tagged.statement a in + let fd (d : Transaction_with_witness.Tagged.t) = d.statement in Parallel_scan.view_jobs_with_position t.scan_state fa fd in Yojson.Safe.to_string @@ -1269,13 +1725,18 @@ let snark_job_list_json t = (List.map all_jobs ~f:(fun tree -> `List (List.map tree ~f:Job_view.to_yojson) ) ) ) +(* TODO create a function work_statements_length and use it + where only the length of the list is needed *) +(* Length is used in ledger application. Whole list is + needed only in a test and in Snark_pool_refcount extension (i.e. + processing will happen once on each block) *) (*Always the same pairing of jobs*) let all_work_statements_exn t : Transaction_snark_work.Statement.t list = let work_seqs = all_jobs t in List.concat_map work_seqs ~f:(fun work_seq -> One_or_two.group_list (List.map work_seq ~f:(fun job -> - match statement_of_job job with + match Available_job.statement job with | None -> assert false | Some stmt -> @@ -1290,116 +1751,43 @@ let k_work_pairs_for_new_diff t ~k = List.( take (concat_map work_list ~f:(fun works -> One_or_two.group_list works)) k) +(* TODO create a function work_statements_length and use it + where only the length of the list is needed *) +(* Length is used in ledger application. Whole list is + needed only in tests and in [Staged_ledger.create_diff] *) (*Always the same pairing of jobs*) let work_statements_for_new_diff t : Transaction_snark_work.Statement.t list = let work_list = Parallel_scan.jobs_for_next_update t.scan_state in List.concat_map work_list ~f:(fun work_seq -> One_or_two.group_list (List.map work_seq ~f:(fun job -> - match statement_of_job job with + match Available_job.statement job with | None -> assert false | Some stmt -> stmt ) ) ) -let all_work_pairs t - ~(get_state : State_hash.t -> Mina_state.Protocol_state.value Or_error.t) : - ( Transaction_witness.t - , Ledger_proof.Cached.t ) - Snark_work_lib.Work.Single.Spec.t - One_or_two.t - list - Or_error.t = - let all_jobs = all_jobs t in - let module A = Available_job in - let open Or_error.Let_syntax in - let single_spec (job : job) = - match extract_from_job job with - | First - ( transaction_with_info - , statement - , state_hash - , first_pass_ledger_witness - , second_pass_ledger_witness - , init_stack - , block_global_slot ) -> - let%map witness = - let { With_status.data = transaction; status } = - Mina_transaction_logic.Transaction_applied.transaction_with_status - transaction_with_info - in - let%bind protocol_state_body = - let%map state = get_state (fst state_hash) in - Mina_state.Protocol_state.body state - in - let%map init_stack = - match init_stack with - | Base x -> - Ok x - | Merge -> - Or_error.error_string "init_stack was Merge" - in - { Transaction_witness.first_pass_ledger = first_pass_ledger_witness - ; second_pass_ledger = second_pass_ledger_witness - ; transaction - ; protocol_state_body - ; init_stack - ; status - ; block_global_slot - } - in - Snark_work_lib.Work.Single.Spec.Transition (statement, witness) - | Second (p1, p2) -> - let%map merged = - Transaction_snark.Statement.merge - (Ledger_proof.Cached.statement p1) - (Ledger_proof.Cached.statement p2) - in - Snark_work_lib.Work.Single.Spec.Merge (merged, p1, p2) - in - List.fold_until all_jobs ~init:[] - ~finish:(fun lst -> Ok lst) - ~f:(fun acc jobs -> - let specs_list : 'a One_or_two.t list Or_error.t = - List.fold ~init:(Ok []) (One_or_two.group_list jobs) - ~f:(fun acc' pair -> - let%bind acc' = acc' in - let%map spec = One_or_two.Or_error.map ~f:single_spec pair in - spec :: acc' ) - in - match specs_list with - | Ok list -> - Continue (acc @ List.rev list) - | Error e -> - Stop (Error e) ) +let all_work_pairs t : Available_job.t One_or_two.t list = + all_jobs t |> List.concat_map ~f:One_or_two.group_list let update_metrics t = Parallel_scan.update_metrics t.scan_state -let fill_work_and_enqueue_transactions t ~logger transactions work = +let fill_work_and_enqueue_transactions t ~logger transactions works = let open Or_error.Let_syntax in - let deconstruct_work (w : Transaction_snark_work.t) : - Ledger_proof_with_sok_message.t list = - let fee = Transaction_snark_work.fee w in - let prover = Transaction_snark_work.prover w in - One_or_two.map (Transaction_snark_work.proofs w) ~f:(fun proof -> - (proof, Sok_message.create ~fee ~prover) ) - |> One_or_two.to_list - in (*get incomplete transactions from previous proof which will be completed in the new proof, if there's one*) let old_proof_and_incomplete_zkapp_updates = incomplete_txns_from_recent_proof_tree t in - let work_list = List.concat_map ~f:deconstruct_work work in let%bind proof_opt, updated_scan_state = - Parallel_scan.update t.scan_state ~completed_jobs:work_list - ~data:transactions + Parallel_scan.update t.scan_state ~completed_jobs:works ~data:transactions in [%log internal] "@metadata" ~metadata: - [ ("scan_state_added_works", `Int (List.length work)) - ; ("total_proofs", `Int (total_proofs work)) - ; ("merge_jobs_created", `Int (List.length work_list)) + [ ("scan_state_added_works", `Int (List.length works)) + (* TODO uncomment *) + (* ; ("total_proofs", `Int (total_proofs works)) *) + ; ("merge_jobs_created", `Int (List.length works)) ; ("emitted_proof", `Bool (Option.is_some proof_opt)) ] ; let%map result_opt, scan_state' = @@ -1412,16 +1800,17 @@ let fill_work_and_enqueue_transactions t ~logger transactions work = t.previous_incomplete_zkapp_updates } ) ) proof_opt - ~f:(fun ((proof, _), _txns_with_witnesses) -> - let curr_stmt = Ledger_proof.Cached.statement proof in + ~f:(fun (curr_tagged, _txns_with_witnesses) -> + let curr_stmt = + Ledger_proof_with_sok_message.Tagged.statement curr_tagged + in let prev_stmt, incomplete_zkapp_updates_from_old_proof = Option.value_map ~default: (curr_stmt, ([], `Border_block_continued_in_the_next_tree false)) old_proof_and_incomplete_zkapp_updates - ~f:(fun ((p', _), incomplete_zkapp_updates_from_old_proof) -> - ( Ledger_proof.Cached.statement p' - , incomplete_zkapp_updates_from_old_proof ) ) + ~f:(fun (p', incomplete_zkapp_updates_from_old_proof) -> + (p', incomplete_zkapp_updates_from_old_proof) ) in (*prev_target is connected to curr_source- Order of the arguments is important here*) @@ -1439,14 +1828,18 @@ let fill_work_and_enqueue_transactions t ~logger transactions work = incomplete_zkapp_updates_from_old_proof } in - (*This block is for when there's a proof emitted so Option. - value_exn is safe here - [latest_ledger_proof] generates ordered transactions - appropriately*) - let (proof, _), txns = - Option.value_exn (latest_ledger_proof scan_state') + let proof' = + let%map.Option ({ tag; _ } as tagged), _ = + Parallel_scan.last_emitted_value scan_state'.scan_state + in + let statement = + Ledger_proof_with_sok_message.Tagged.statement tagged + in + Ledger_proof.Tagged.create ~statement ~proof:tag + ~sok_digest: + (Ledger_proof_with_sok_message.Tagged.sok_digest tagged) in - Ok (Some (proof, txns), scan_state') + Ok (proof', scan_state') | Error e -> Or_error.errorf "The new final statement does not connect to the previous \ @@ -1457,10 +1850,11 @@ let fill_work_and_enqueue_transactions t ~logger transactions work = let required_state_hashes t = List.fold ~init:State_hash.Set.empty - ~f:(fun acc (txns : Transactions_ordered.t) -> - Transactions_ordered.fold ~init:acc txns - ~f:(fun acc (t : Transaction_with_witness.t) -> - Set.add acc (fst t.state_hash) ) ) + ~f:(fun acc txns -> + Transactions_categorized.fold ~init:acc txns ~f:(fun acc t -> + Set.add acc + t.Transaction_with_witness.Tagged.Stable.Latest.parent_state_hash ) + ) (staged_transactions t) let check_required_protocol_states t ~protocol_states = @@ -1491,40 +1885,3 @@ let check_required_protocol_states t ~protocol_states = in let%map () = check_length protocol_states_assoc in protocol_states_assoc - -let write_all_proofs_to_disk ~signature_kind ~proof_cache_db - { Stable.Latest.scan_state = uncached - ; previous_incomplete_zkapp_updates = tx_list, border_status - } = - let f1 (p, v) = - (Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db p, v) - in - { scan_state = - Parallel_scan.State.map uncached ~f1 - ~f2: - (Transaction_with_witness.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db ) - ; previous_incomplete_zkapp_updates = - ( List.map - ~f: - (Transaction_with_witness.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db ) - tx_list - , border_status ) - } - -let read_all_proofs_from_disk - { scan_state = cached - ; previous_incomplete_zkapp_updates = tx_list, border_status - } = - let f1 (p, v) = (Ledger_proof.Cached.read_proof_from_disk p, v) in - let scan_state = - Parallel_scan.State.map ~f1 - ~f2:Transaction_with_witness.read_all_proofs_from_disk cached - in - Stable.Latest. - { scan_state - ; previous_incomplete_zkapp_updates = - ( List.map ~f:Transaction_with_witness.read_all_proofs_from_disk tx_list - , border_status ) - } diff --git a/src/lib/transaction_snark_scan_state/transaction_snark_scan_state.mli b/src/lib/transaction_snark_scan_state/transaction_snark_scan_state.mli index 7fecbf0a5de8..1d53b3849ba8 100644 --- a/src/lib/transaction_snark_scan_state/transaction_snark_scan_state.mli +++ b/src/lib/transaction_snark_scan_state/transaction_snark_scan_state.mli @@ -6,36 +6,121 @@ module Ledger = Mina_ledger.Ledger [%%versioned: module Stable : sig - [@@@no_toplevel_latest_type] + module V3 : sig + type t + end module V2 : sig type t + val to_latest : t -> V3.t + val hash : t -> Staged_ledger_hash.Aux_hash.t + + val of_latest_exn : V3.t -> t end end] -type t +val hash : t -> Staged_ledger_hash.Aux_hash.t module Transaction_with_witness : sig + [%%versioned: + module Stable : sig + [@@@no_toplevel_latest_type] + + module V3 : sig + type t + end + + module V2 : sig + type t + end + end] + + module Tag : sig + type t = Stable.Latest.t State_hash.Tag.t + end + + module Tagged : sig + type t + + val create : tag:Tag.t -> Stable.Latest.t -> t + + [%%versioned: + module Stable : sig + [@@@no_toplevel_latest_type] + + module V1 : sig + type nonrec t = t + end + end] + + val statement : t -> Transaction_snark.Statement.t + end + (* TODO: The statement is redundant here - it can be computed from the witness and the transaction *) type t = - { transaction_with_info : Mina_transaction_logic.Transaction_applied.t + { transaction_with_status : Transaction.t With_status.t ; state_hash : State_hash.t * State_body_hash.t ; statement : Transaction_snark.Statement.t - ; init_stack : Transaction_snark.Pending_coinbase_stack_state.Init_stack.t + ; init_stack : Mina_base.Pending_coinbase.Stack_versioned.t ; first_pass_ledger_witness : Mina_ledger.Sparse_ledger.t ; second_pass_ledger_witness : Mina_ledger.Sparse_ledger.t ; block_global_slot : Mina_numbers.Global_slot_since_genesis.t + ; previous_protocol_state_body_opt : + Mina_state.Protocol_state.Body.Value.t option + ; transaction_applied_or_tag : + ( Mina_transaction_logic.Transaction_applied.t + , Mina_transaction_logic.Transaction_applied.Stable.V2.t + State_hash.File_storage.tag ) + Either.t } + + val persist_many : t list -> State_hash.File_storage.writer_t -> Tagged.t list end module Ledger_proof_with_sok_message : sig - type t = Ledger_proof.Cached.t * Sok_message.t + type t = Ledger_proof.t * Sok_message.t + + module Tagged : sig + [%%versioned: + module Stable : sig + module V1 : sig + type t + end + end] + + val create : + tag:Proof.t State_hash.Tag.t + -> sok_message:Sok_message.t + -> statement:Mina_state.Snarked_ledger_state.With_sok.t + -> t + end + + val persist_many : + Transaction_snark_work.t list + -> State_hash.File_storage.writer_t + -> Tagged.t list end module Available_job : sig type t + + val is_transition : t -> bool + + val target_second_pass_ledger : t -> Frozen_ledger_hash.t option + + val single_spec : + get_state:(State_hash.t -> Mina_state.Protocol_state.Value.t Or_error.t) + -> t + -> Snark_work_lib.Spec.Single.Stable.Latest.t Or_error.t + + val single_spec_one_or_two : + get_state:(State_hash.t -> Mina_state.Protocol_state.Value.t Or_error.t) + -> t One_or_two.t + -> Snark_work_lib.Spec.Single.Stable.Latest.t One_or_two.t Or_error.t + + val statement : t -> Transaction_snark.Statement.t option end module Space_partition : sig @@ -68,47 +153,18 @@ end) : sig -> (unit, Error.t) Deferred.Result.t end -module Transactions_ordered : sig - module Poly : sig - type 'a t = - { first_pass : 'a list - ; second_pass : 'a list - ; previous_incomplete : 'a list - ; current_incomplete : 'a list - } - [@@deriving sexp, to_yojson] - end - - type t = Transaction_with_witness.t Poly.t -end - val empty : constraint_constants:Genesis_constants.Constraint_constants.t -> unit -> t val fill_work_and_enqueue_transactions : t -> logger:Logger.t - -> Transaction_with_witness.t list - -> Transaction_snark_work.t list - -> ( ( Ledger_proof.Cached.t - * ( Transaction.t With_status.t - * State_hash.t - * Mina_numbers.Global_slot_since_genesis.t ) - Transactions_ordered.Poly.t - list ) - option - * t ) - Or_error.t + -> Transaction_with_witness.Tagged.t list + -> Ledger_proof_with_sok_message.Tagged.t list + -> (Ledger_proof.Tagged.t option * t) Or_error.t -val latest_ledger_proof : - t - -> ( Ledger_proof_with_sok_message.t - * ( Transaction.t With_status.t - * State_hash.t - * Mina_numbers.Global_slot_since_genesis.t ) - Transactions_ordered.Poly.t - list ) - option +val latest_ledger_proof_statement : + t -> Mina_state.Snarked_ledger_state.t option (** Apply transactions coorresponding to the last emitted proof based on the two-pass system- first pass includes legacy transactions and zkapp payments @@ -203,26 +259,9 @@ val get_staged_ledger_async : val free_space : t -> int -val base_jobs_on_latest_tree : t -> Transaction_with_witness.t list - -(* a 0 index means next-to-latest tree *) -val base_jobs_on_earlier_tree : - t -> index:int -> Transaction_with_witness.t list - -(** All the transactions with hash of the parent block in which they were included in the order in which they were applied*) -val staged_transactions_with_state_hash : - t - -> ( Transaction.t With_status.t - * State_hash.t - * Mina_numbers.Global_slot_since_genesis.t ) - Transactions_ordered.Poly.t - list - (** Available space and the corresponding required work-count in one and/or two trees (if the slots to be occupied are in two different trees)*) val partition_if_overflowing : t -> Space_partition.t -val statement_of_job : Available_job.t -> Transaction_snark.Statement.t option - val snark_job_list_json : t -> string (** All the proof bundles *) @@ -257,20 +296,6 @@ val check_required_protocol_states : Or_error.t (** All the proof bundles for snark workers*) -val all_work_pairs : - t - -> get_state:(State_hash.t -> Mina_state.Protocol_state.value Or_error.t) - -> ( Transaction_witness.t - , Ledger_proof.Cached.t ) - Snark_work_lib.Work.Single.Spec.t - One_or_two.t - list - Or_error.t - -val write_all_proofs_to_disk : - signature_kind:Mina_signature_kind.t - -> proof_cache_db:Proof_cache_tag.cache_db - -> Stable.Latest.t - -> t +val all_work_pairs : t -> Available_job.t One_or_two.t list -val read_all_proofs_from_disk : t -> Stable.Latest.t +(* val read_all_proofs_from_disk : t -> Stable.Latest.t Or_error.t *) diff --git a/src/lib/transition_chain_prover/transition_chain_prover.ml b/src/lib/transition_chain_prover/transition_chain_prover.ml index d71bcbffc6a0..991b52df901d 100644 --- a/src/lib/transition_chain_prover/transition_chain_prover.ml +++ b/src/lib/transition_chain_prover/transition_chain_prover.ml @@ -18,44 +18,42 @@ module Make (Inputs : Inputs_intf) : get_extension (Transition_frontier.extensions frontier) Root_history in let%map root_data = Root_history.lookup root_history state_hash in - Frontier_base.Root_data.Historical.transition root_data + Frontier_base.Root_data.Historical.protocol_state_with_hashes root_data module Merkle_list = Merkle_list_prover.Make_ident (struct - type value = Mina_block.Validated.t + type value = + Mina_state.Protocol_state.Value.t State_hash.With_state_hashes.t type context = Transition_frontier.t type proof_elem = State_body_hash.t - let to_proof_elem = Mina_block.Validated.state_body_hash + let to_proof_elem = + State_hash.With_state_hashes.state_body_hash + ~compute_hashes:Mina_state.Protocol_state.hashes let get_previous ~context transition = let parent_hash = - transition |> Mina_block.Validated.forget |> With_hash.data - |> Mina_block.header |> Mina_block.Header.protocol_state - |> Protocol_state.previous_state_hash + With_hash.data transition |> Protocol_state.previous_state_hash in - let open Option.Let_syntax in - Option.merge - Transition_frontier.( - find context parent_hash >>| Breadcrumb.validated_transition) + Option.first_some + ( Option.map ~f:Frontier_base.Breadcrumb.protocol_state_with_hashes + @@ Transition_frontier.find context parent_hash ) (find_in_root_history context parent_hash) - ~f:Fn.const end) let prove ?length ~frontier state_hash = let open Option.Let_syntax in let%map requested_transition = - Option.merge - Transition_frontier.( - find frontier state_hash >>| Breadcrumb.validated_transition) + Option.first_some + ( Option.map ~f:Frontier_base.Breadcrumb.protocol_state_with_hashes + @@ Transition_frontier.find frontier state_hash ) (find_in_root_history frontier state_hash) - ~f:Fn.const in let first_transition, merkle_list = Merkle_list.prove ?length ~context:frontier requested_transition in - (Mina_block.Validated.state_hash first_transition, merkle_list) + (State_hash.With_state_hashes.state_hash first_transition, merkle_list) end include Make (struct diff --git a/src/lib/transition_frontier/catchup_hash_tree.ml b/src/lib/transition_frontier/catchup_hash_tree.ml index fd8f575938b2..d3ac4c46473f 100644 --- a/src/lib/transition_frontier/catchup_hash_tree.ml +++ b/src/lib/transition_frontier/catchup_hash_tree.ml @@ -213,7 +213,7 @@ let apply_diffs t (ds : Diff.Full.E.t list) = breadcrumb_added t b | E (Root_transitioned { new_root; garbage = Full hs; _ }) -> List.iter (Diff.Node_list.to_lite hs) ~f:(remove_node t) ; - let h = (Root_data.Limited.Stable.Latest.hashes new_root).state_hash in + let h = new_root.state_hash in Hashtbl.change t.nodes h ~f:(function | None -> [%log' debug t.logger] diff --git a/src/lib/transition_frontier/extensions/best_tip_diff.ml b/src/lib/transition_frontier/extensions/best_tip_diff.ml index eeff93b828aa..c7a1d9939bcc 100644 --- a/src/lib/transition_frontier/extensions/best_tip_diff.ml +++ b/src/lib/transition_frontier/extensions/best_tip_diff.ml @@ -6,8 +6,14 @@ module T = struct type t = { logger : Logger.t; best_tip_diff_logger : Logger.t } type view = - { new_commands : User_command.Valid.t With_status.t list - ; removed_commands : User_command.Valid.t With_status.t list + { new_commands : + Mina_transaction.Transaction_hash.User_command_with_valid_signature.t + With_status.t + list + ; removed_commands : + Mina_transaction.Transaction_hash.User_command_with_valid_signature.t + With_status.t + list ; reorg_best_tip : bool } @@ -32,16 +38,13 @@ module T = struct [@@deriving register_event { msg = "Formed a new best tip" }] end - let breadcrumb_commands = - Fn.compose Mina_block.Validated.valid_commands - Breadcrumb.validated_transition - let create ~logger frontier = let best_tip_diff_logger = Logger.create ~id:Logger.Logger_id.best_tip_diff () in ( { logger; best_tip_diff_logger } - , { new_commands = breadcrumb_commands (Full_frontier.root frontier) + , { new_commands = + Breadcrumb.valid_commands_hashed (Full_frontier.root frontier) ; removed_commands = [] ; reorg_best_tip = false } ) @@ -137,11 +140,13 @@ module T = struct |> Or_error.ok_exn in let new_commands = - List.bind added_to_best_tip_path ~f:breadcrumb_commands + List.bind added_to_best_tip_path + ~f:Breadcrumb.valid_commands_hashed @ new_commands in let removed_commands = - List.bind removed_from_best_tip_path ~f:breadcrumb_commands + List.bind removed_from_best_tip_path + ~f:Breadcrumb.valid_commands_hashed @ removed_commands in let reorg_best_tip = diff --git a/src/lib/transition_frontier/extensions/best_tip_diff.mli b/src/lib/transition_frontier/extensions/best_tip_diff.mli index 799a55b654bf..43d8ea5a8558 100644 --- a/src/lib/transition_frontier/extensions/best_tip_diff.mli +++ b/src/lib/transition_frontier/extensions/best_tip_diff.mli @@ -1,8 +1,14 @@ open Mina_base type view = - { new_commands : User_command.Valid.t With_status.t list - ; removed_commands : User_command.Valid.t With_status.t list + { new_commands : + Mina_transaction.Transaction_hash.User_command_with_valid_signature.t + With_status.t + list + ; removed_commands : + Mina_transaction.Transaction_hash.User_command_with_valid_signature.t + With_status.t + list ; reorg_best_tip : bool } diff --git a/src/lib/transition_frontier/extensions/root_history.ml b/src/lib/transition_frontier/extensions/root_history.ml index e909343ed31c..bea3d3633c5a 100644 --- a/src/lib/transition_frontier/extensions/root_history.ml +++ b/src/lib/transition_frontier/extensions/root_history.ml @@ -3,15 +3,124 @@ open Mina_base open Frontier_base module Queue = Hash_queue.Make (State_hash) -module T = struct - type t = - { history : Root_data.Historical.t Queue.t - ; capacity : int - ; mutable current_root : Root_data.Historical.t - ; mutable protocol_states_for_root_scan_state : - Full_frontier.Protocol_states_for_root_scan_state.t - } +type t = + { history : Root_data.Historical.t Queue.t + ; capacity : int + ; mutable current_root : Root_data.Historical.t + ; mutable protocol_states_for_root_scan_state : + Full_frontier.Protocol_states_for_root_scan_state.t + } + +let lookup { history; _ } = Queue.lookup history + +let mem { history; _ } = Queue.mem history + +(** Looks up values by key using the lookup function and returns + obtained values in reverse order or None if any of the lookups fail *) +let lookup_all_reversed ~lookup = + List.fold_until ~init:[] ~finish:Option.some ~f:(fun acc key -> + match lookup key with + | Some value -> + Continue (value :: acc) + | None -> + Stop None ) + +let protocol_states_for_scan_state ~protocol_states_for_root_scan_state ~history + required_state_hashes = + let lookup_in_scan_states hash = + let%map.Option state_with_hash = + State_hash.Map.find protocol_states_for_root_scan_state hash + in + With_hash.data state_with_hash + in + let lookup_in_root_history hash = + Option.map ~f:Root_data.Historical.protocol_state + (Queue.lookup history hash) + in + let lookup hash = + match lookup_in_root_history hash with + | Some value -> + Some value + | None -> + lookup_in_scan_states hash + in + lookup_all_reversed ~lookup required_state_hashes + +let most_recent { history; _ } = + (* unfortunately, there is not function to inspect the last element in the queue, + * so we need to remove it and reinsert it instead *) + let open Option.Let_syntax in + let%map state_hash, breadcrumb = Queue.dequeue_back_with_key history in + (* should never return `Key_already_present since we just removed it *) + assert ( + [%equal: [ `Ok | `Key_already_present ]] `Ok + (Queue.enqueue_back history state_hash breadcrumb) ) ; + breadcrumb + +let oldest { history; _ } = Queue.first history + +let is_empty { history; _ } = Queue.is_empty history + +let to_list { history; _ } = Queue.to_list history + +let staged_ledger_aux_and_pending_coinbases_of_breadcrumb + ~protocol_states_for_root_scan_state ~history breadcrumb = + let staged_ledger = Breadcrumb.staged_ledger breadcrumb in + let scan_state = Staged_ledger.scan_state staged_ledger in + let required_state_hashes = + Staged_ledger.Scan_state.required_state_hashes scan_state + |> State_hash.Set.to_list + in + let%map.Option scan_state_protocol_states = + protocol_states_for_scan_state ~protocol_states_for_root_scan_state ~history + required_state_hashes + in + let pending_coinbase = + Staged_ledger.pending_coinbase_collection staged_ledger + in + let staged_ledger_target_ledger_hash = + Breadcrumb.staged_ledger_hash breadcrumb |> Staged_ledger_hash.ledger_hash + in + let data = + ( Staged_ledger.Scan_state.Stable.V2.of_latest_exn scan_state + , staged_ledger_target_ledger_hash + , pending_coinbase + , scan_state_protocol_states ) + in + let module Data = + Network_types.Staged_ledger_aux_and_pending_coinbases.Data.Stable.Latest + in + (* Cache in frontier and return tag *) + State_hash.File_storage.append_values_exn (Breadcrumb.state_hash breadcrumb) + ~f:(fun writer -> + State_hash.File_storage.write_value writer (module Data) data ) +let historical_of_breadcrumb ~protocol_states_for_root_scan_state ~history + breadcrumb = + let cached_opt = + Breadcrumb.staged_ledger_aux_and_pending_coinbases_cached breadcrumb + in + let%map.Option staged_ledger_aux_and_pending_coinbases = + match cached_opt with + | Some value -> + Some value + | None -> + staged_ledger_aux_and_pending_coinbases_of_breadcrumb + ~protocol_states_for_root_scan_state ~history breadcrumb + in + let scan_state = + Staged_ledger.scan_state (Breadcrumb.staged_ledger breadcrumb) + in + let required_state_hashes = + Staged_ledger.Scan_state.required_state_hashes scan_state + in + Root_data.Historical.create + ~block_tag:(Breadcrumb.block_tag breadcrumb) + ~staged_ledger_aux_and_pending_coinbases ~required_state_hashes + ~protocol_state_with_hashes: + (Breadcrumb.protocol_state_with_hashes breadcrumb) + +module T = struct type view = t let name = "root_registry" @@ -19,16 +128,17 @@ module T = struct let create ~logger:_ frontier = let capacity = 2 * Full_frontier.max_length frontier in let history = Queue.create () in + let protocol_states_for_root_scan_state = + Full_frontier.protocol_states_for_root_scan_state frontier + in let current_root = - Root_data.Historical.of_breadcrumb (Full_frontier.root frontier) + historical_of_breadcrumb ~protocol_states_for_root_scan_state ~history + (Full_frontier.root frontier) + |> Option.value_exn + ~message:"root_history: can't compute historical for root" in let t = - { history - ; capacity - ; current_root - ; protocol_states_for_root_scan_state = - Full_frontier.protocol_states_for_root_scan_state frontier - } + { history; capacity; current_root; protocol_states_for_root_scan_state } in (t, t) @@ -44,12 +154,10 @@ module T = struct Full_frontier.Protocol_states_for_root_scan_state .protocol_states_for_next_root_scan_state t.protocol_states_for_root_scan_state - ~new_scan_state:(scan_state new_oldest_root) - ~old_root_state: - ( transition oldest_root |> Mina_block.Validated.forget - |> With_hash.map ~f:(fun block -> - block |> Mina_block.header - |> Mina_block.Header.protocol_state ) ) + ~next_root_required_hashes: + ( Root_data.Historical.required_state_hashes new_oldest_root + |> State_hash.Set.to_list ) + ~old_root_state:(protocol_state_with_hashes oldest_root) |> List.map ~f:(fun s -> State_hash.With_state_hashes.(state_hash s, s)) |> State_hash.Map.of_alist_exn in @@ -57,7 +165,8 @@ module T = struct assert ( [%equal: [ `Ok | `Key_already_present ]] `Ok (Queue.enqueue_back t.history - (Mina_block.Validated.state_hash @@ transition t.current_root) + ( State_hash.With_state_hashes.state_hash + @@ protocol_state_with_hashes t.current_root ) t.current_root ) ) ; t.current_root <- new_root @@ -66,19 +175,27 @@ module T = struct let should_produce_view = List.exists diffs_with_mutants ~f:(function (* TODO: send full diffs to extensions to avoid extra lookups in frontier *) - | E (Root_transitioned { new_root; _ }, _) -> ( - let state_hash = - (Root_data.Limited.Stable.Latest.hashes new_root).state_hash + | E (Root_transitioned { new_root = { state_hash; _ }; _ }, _) -> + let breadcrumb = + Full_frontier.find frontier state_hash + |> Option.value_exn + ~message: + (sprintf "root_history: new root %s not found in frontier" + (State_hash.to_base58_check state_hash) ) + in + let historical = + historical_of_breadcrumb + ~protocol_states_for_root_scan_state: + root_history.protocol_states_for_root_scan_state + ~history:root_history.history breadcrumb + |> Option.value_exn + ~message: + (sprintf + "root_history: can't compute historical for new root %s" + (State_hash.to_base58_check state_hash) ) in - match Full_frontier.find frontier state_hash with - | Some breadcrumb -> - enqueue root_history - (Root_data.Historical.of_breadcrumb breadcrumb) ; - true - | None -> - failwithf "root_history: new root %s not found in frontier" - (State_hash.to_base58_check state_hash) - () ) + enqueue root_history historical ; + true | E _ -> false ) in @@ -86,57 +203,9 @@ module T = struct end include T -module Broadcasted = Functor.Make_broadcasted (T) - -let lookup { history; _ } = Queue.lookup history - -let mem { history; _ } = Queue.mem history - -let protocol_states_for_scan_state t state_hash = - let history = t.history in - let protocol_states_for_root_scan_state = - t.protocol_states_for_root_scan_state - in - let open Option.Let_syntax in - let open Root_data.Historical in - let%bind data = Queue.lookup history state_hash in - let required_state_hashes = - Staged_ledger.Scan_state.required_state_hashes (scan_state data) - |> State_hash.Set.to_list - in - List.fold_until ~init:[] - ~finish:(fun lst -> Some lst) - required_state_hashes - ~f:(fun acc hash -> - let res = - match Queue.lookup history hash with - | Some data -> - Some - ( transition data |> Mina_block.Validated.forget |> With_hash.data - |> Mina_block.header |> Mina_block.Header.protocol_state ) - | None -> - (*Not present in the history queue, check in the protocol states map that has all the protocol states required for transactions in the root*) - let%map.Option state_with_hash = - State_hash.Map.find protocol_states_for_root_scan_state hash - in - With_hash.data state_with_hash - in - match res with None -> Stop None | Some state -> Continue (state :: acc) - ) - -let most_recent { history; _ } = - (* unfortunately, there is not function to inspect the last element in the queue, - * so we need to remove it and reinsert it instead *) - let open Option.Let_syntax in - let%map state_hash, breadcrumb = Queue.dequeue_back_with_key history in - (* should never return `Key_already_present since we just removed it *) - assert ( - [%equal: [ `Ok | `Key_already_present ]] `Ok - (Queue.enqueue_back history state_hash breadcrumb) ) ; - breadcrumb -let oldest { history; _ } = Queue.first history - -let is_empty { history; _ } = Queue.is_empty history +module Broadcasted = Functor.Make_broadcasted (struct + type nonrec t = t -let to_list { history; _ } = Queue.to_list history + include T +end) diff --git a/src/lib/transition_frontier/extensions/root_history.mli b/src/lib/transition_frontier/extensions/root_history.mli index 46459f015f47..1fb3397b398c 100644 --- a/src/lib/transition_frontier/extensions/root_history.mli +++ b/src/lib/transition_frontier/extensions/root_history.mli @@ -21,6 +21,3 @@ val most_recent : t -> Root_data.Historical.t option val oldest : t -> Root_data.Historical.t option val to_list : t -> Root_data.Historical.t list - -val protocol_states_for_scan_state : - t -> State_hash.t -> Mina_state.Protocol_state.value list option diff --git a/src/lib/transition_frontier/extensions/snark_pool_refcount.ml b/src/lib/transition_frontier/extensions/snark_pool_refcount.ml index d01ca4ce16dd..087d413fdc19 100644 --- a/src/lib/transition_frontier/extensions/snark_pool_refcount.ml +++ b/src/lib/transition_frontier/extensions/snark_pool_refcount.ml @@ -15,7 +15,7 @@ module T = struct *) ; mutable best_tip_table : Work.Set.t (** The set of all snark work statements present in the scan state - for the last 10 blocks in the best chain. + for the last 3 blocks in the best chain. *) } diff --git a/src/lib/transition_frontier/frontier_base/block_data.ml b/src/lib/transition_frontier/frontier_base/block_data.ml new file mode 100644 index 000000000000..9b5c72dd6504 --- /dev/null +++ b/src/lib/transition_frontier/frontier_base/block_data.ml @@ -0,0 +1,101 @@ +open Core_kernel +open Mina_base + +[%%versioned +module Stable = struct + [@@@no_toplevel_latest_type] + + module V1 = struct + type t = + { protocol_state : Mina_state.Protocol_state.Value.Stable.V2.t + ; block_tag : + ( State_hash.Stable.V1.t + , Mina_block.Stable.V2.t ) + Multi_key_file_storage.Tag.Stable.V1.t + ; delta_block_chain_proof : + State_hash.Stable.V1.t Mina_stdlib.Nonempty_list.Stable.V1.t + } + + let to_latest = Fn.id + end +end] + +type t = Stable.Latest.t = + { protocol_state : Mina_state.Protocol_state.value + ; block_tag : Mina_block.Stable.Latest.t Mina_base.State_hash.File_storage.tag + ; delta_block_chain_proof : State_hash.t Mina_stdlib.Nonempty_list.t + } + +let validated_of_stable ~signature_kind ~proof_cache_db ~state_hash transition = + let block = + { With_hash.data = transition + ; hash = { State_hash.State_hashes.state_hash; state_body_hash = None } + } + in + let parent_hash = + block |> With_hash.data |> Mina_block.Stable.Latest.header + |> Mina_block.Header.protocol_state + |> Mina_state.Protocol_state.previous_state_hash + in + let cached_block = + With_hash.map + ~f:(Mina_block.write_all_proofs_to_disk ~signature_kind ~proof_cache_db) + block + in + (* TODO: the delta transition chain proof is incorrect (same behavior the daemon used to have, but we should probably fix this?) *) + Mina_block.Validated.unsafe_of_trusted_block + ~delta_block_chain_proof:(Mina_stdlib.Nonempty_list.singleton parent_hash) + (`This_block_is_trusted_to_be_safe cached_block) + +module Staged_ledger_data = struct + type t = + Mina_ledger.Mask_maps.Stable.Latest.t + * Staged_ledger.Scan_state.Application_data.t +end + +module Full = struct + [%%versioned + module Stable = struct + [@@@no_toplevel_latest_type] + + module V1 = struct + type t = + { header : Mina_block.Header.Stable.V2.t + ; block_tag : + ( State_hash.Stable.V1.t + , Mina_block.Stable.V2.t ) + Multi_key_file_storage.Tag.Stable.V1.t + ; delta_block_chain_proof : + State_hash.Stable.V1.t Mina_stdlib.Nonempty_list.Stable.V1.t + ; staged_ledger_data : + Mina_ledger.Mask_maps.Stable.V1.t + * Staged_ledger.Scan_state.Application_data.Stable.V1.t + (* TODO consider removing the field, it's not used on lite breadcrumb *) + ; accounts_created : Account_id.Stable.V2.t list + ; staged_ledger_aux_and_pending_coinbases_cached : + ( State_hash.Stable.V1.t + , Network_types.Staged_ledger_aux_and_pending_coinbases.Data.Stable + .V1 + .t ) + Multi_key_file_storage.Tag.Stable.V1.t + option + ; transaction_hashes_unordered : + Mina_transaction.Transaction_hash.Stable.V1.t list + ; command_stats : Command_stats.Stable.V1.t + } + + let to_latest = Fn.id + end + end] + + type t = Stable.Latest.t + + let read_block { Stable.Latest.block_tag; _ } = + State_hash.File_storage.read (module Mina_block.Stable.Latest) block_tag + + let to_validated_block ~signature_kind ~proof_cache_db ~state_hash + transition_data = + read_block transition_data + |> Or_error.map + ~f:(validated_of_stable ~signature_kind ~proof_cache_db ~state_hash) +end diff --git a/src/lib/transition_frontier/frontier_base/breadcrumb.ml b/src/lib/transition_frontier/frontier_base/breadcrumb.ml index c9fa5d412204..66a67a8a653b 100644 --- a/src/lib/transition_frontier/frontier_base/breadcrumb.ml +++ b/src/lib/transition_frontier/frontier_base/breadcrumb.ml @@ -5,15 +5,41 @@ open Mina_state open Mina_block open Network_peer +let command_hashes_of_transition validated_transition = + Mina_block.Validated.body validated_transition + |> Body.staged_ledger_diff |> Staged_ledger_diff.command_hashes + +type stored_transition = + | Full of Mina_block.Validated.t + | Lite of + { header : Mina_block.Header.t + ; hashes : State_hash.State_hashes.t + ; delta_block_chain_proof : State_hash.t Mina_stdlib.Nonempty_list.t + ; command_stats : Command_stats.t + } + +let state_hash_of_stored_transition = function + | Full validated_transition -> + Mina_block.Validated.state_hash validated_transition + | Lite { hashes; _ } -> + hashes.state_hash + module T = struct let id = "breadcrumb" type t = - { validated_transition : Mina_block.Validated.t + { validated_transition : stored_transition ; staged_ledger : Staged_ledger.t ; just_emitted_a_proof : bool ; transition_receipt_time : Time.t option ; staged_ledger_hash : Staged_ledger_hash.t + ; accounts_created : Account_id.t list + ; block_tag : Mina_block.Stable.Latest.t State_hash.File_storage.tag + ; mutable staged_ledger_aux_and_pending_coinbases_cached : + Network_types.Staged_ledger_aux_and_pending_coinbases.data_tag option + ; transaction_hashes : Mina_transaction.Transaction_hash.Set.t + (* Should be some for non-root *) + ; application_data : Staged_ledger.Scan_state.Application_data.t option } [@@deriving fields] @@ -22,16 +48,19 @@ module T = struct -> staged_ledger:Staged_ledger.t -> just_emitted_a_proof:bool -> transition_receipt_time:Time.t option + -> accounts_created:Account_id.t list + -> block_tag:Mina_block.Stable.Latest.t State_hash.File_storage.tag -> 'a let map_creator creator ~f ~validated_transition ~staged_ledger - ~just_emitted_a_proof ~transition_receipt_time = + ~just_emitted_a_proof ~transition_receipt_time ~accounts_created + ~block_tag = f (creator ~validated_transition ~staged_ledger ~just_emitted_a_proof - ~transition_receipt_time ) + ~transition_receipt_time ~accounts_created ~block_tag ) let create ~validated_transition ~staged_ledger ~just_emitted_a_proof - ~transition_receipt_time = + ~transition_receipt_time ~accounts_created ~block_tag = (* TODO This looks terrible, consider removing this in the hardfork by either removing staged_ledger_hash from the header or computing it consistently for the genesis block *) @@ -43,11 +72,18 @@ module T = struct |> Mina_block.Header.protocol_state |> Protocol_state.blockchain_state |> Blockchain_state.staged_ledger_hash in - { validated_transition + { validated_transition = Full validated_transition ; staged_ledger ; just_emitted_a_proof ; transition_receipt_time ; staged_ledger_hash + ; accounts_created + ; block_tag + ; staged_ledger_aux_and_pending_coinbases_cached = None + ; transaction_hashes = + command_hashes_of_transition validated_transition + |> Mina_transaction.Transaction_hash.Set.of_list + ; application_data = None } let to_yojson @@ -56,27 +92,52 @@ module T = struct ; just_emitted_a_proof ; transition_receipt_time ; staged_ledger_hash = _ + ; accounts_created = _ + ; block_tag = _ + ; staged_ledger_aux_and_pending_coinbases_cached = _ + ; transaction_hashes + ; application_data = _ } = `Assoc - [ ( "validated_transition" - , Mina_block.Validated.to_yojson validated_transition ) - ; ("staged_ledger", `String "") + [ ( "state_hash" + , State_hash.to_yojson + @@ state_hash_of_stored_transition validated_transition ) ; ("just_emitted_a_proof", `Bool just_emitted_a_proof) ; ( "transition_receipt_time" , `String (Option.value_map transition_receipt_time ~default:"" ~f:(Time.to_string_iso8601_basic ~zone:Time.Zone.utc) ) ) + ; ( "transaction_hashes_unordered" + , `List + ( Mina_transaction.Transaction_hash.Set.to_list transaction_hashes + |> List.map ~f:Mina_transaction.Transaction_hash.to_yojson ) ) ] end [%%define_locally T. - ( validated_transition - , staged_ledger + ( staged_ledger , just_emitted_a_proof , transition_receipt_time , to_yojson - , staged_ledger_hash )] + , staged_ledger_hash + , accounts_created + , block_tag + , staged_ledger_aux_and_pending_coinbases_cached )] + +let header t = + match T.validated_transition t with + | Full validated_transition -> + Mina_block.Validated.header validated_transition + | Lite { header; _ } -> + header + +(* TODO: for better efficiency, add set of tx hashes to `maps_t` + and use existing mechanism of mask handling to get accumulated lookups, + then in transaction_status it will be necessary to only traverse + all of the tips instead of all of the breadcrumbs. *) +let contains_transaction_by_hash t hash = + Mina_transaction.Transaction_hash.Set.mem t.T.transaction_hashes hash include Allocation_functor.Make.Basic (T) @@ -124,21 +185,38 @@ let build ?skip_staged_ledger_verification ?transaction_pool_proxy ~logger ~get_completed_work ~logger ~precomputed_values ~verifier ~parent_staged_ledger:(staged_ledger parent) ~parent_protocol_state: - ( parent.validated_transition |> Mina_block.Validated.header - |> Mina_block.Header.protocol_state ) + (header parent |> Mina_block.Header.protocol_state) ?transaction_pool_proxy transition_with_validation with | Ok ( `Just_emitted_a_proof just_emitted_a_proof , `Block_with_validation fully_valid_block - , `Staged_ledger transitioned_staged_ledger ) -> + , `Staged_ledger transitioned_staged_ledger + , `Accounts_created accounts_created + , `Block_serialized block_tag + , `Scan_state_application_data application_data ) -> [%log internal] "Create_breadcrumb" ; + let validated_transition = + Mina_block.Validated.lift fully_valid_block + in Deferred.Result.return - (create - ~validated_transition: - (Mina_block.Validated.lift fully_valid_block) - ~staged_ledger:transitioned_staged_ledger ~just_emitted_a_proof - ~transition_receipt_time ) + { T.validated_transition = Full validated_transition + ; staged_ledger = transitioned_staged_ledger + ; accounts_created + ; just_emitted_a_proof + ; transition_receipt_time + ; block_tag + ; application_data = Some application_data + ; staged_ledger_hash = + Mina_block.Validated.header validated_transition + |> Mina_block.Header.protocol_state + |> Protocol_state.blockchain_state + |> Blockchain_state.staged_ledger_hash + ; staged_ledger_aux_and_pending_coinbases_cached = None + ; transaction_hashes = + command_hashes_of_transition validated_transition + |> Mina_transaction.Transaction_hash.Set.of_list + } | Error `Invalid_body_reference -> let message = "invalid body reference" in let%map () = @@ -215,27 +293,40 @@ let build ?skip_staged_ledger_verification ?transaction_pool_proxy ~logger (Staged_ledger.Staged_ledger_error.to_error staged_ledger_error) ) ) -let block_with_hash = - Fn.compose Mina_block.Validated.forget validated_transition - -let block = Fn.compose With_hash.data block_with_hash +let command_stats t = + match t.T.validated_transition with + | Full validated_transition -> + Command_stats.of_body @@ Mina_block.Validated.body @@ validated_transition + | Lite { command_stats; _ } -> + command_stats -let state_hash = Fn.compose Mina_block.Validated.state_hash validated_transition +let state_hash t = state_hash_of_stored_transition t.T.validated_transition -let protocol_state b = - b |> block |> Mina_block.header |> Mina_block.Header.protocol_state +let protocol_state b = Mina_block.Header.protocol_state (header b) let protocol_state_with_hashes breadcrumb = - breadcrumb |> validated_transition |> Mina_block.Validated.forget - |> With_hash.map ~f:(Fn.compose Header.protocol_state Mina_block.header) + match breadcrumb.T.validated_transition with + | Full validated_transition -> + Mina_block.Validated.forget validated_transition + |> With_hash.map + ~f:(Fn.compose Mina_block.Header.protocol_state Mina_block.header) + | Lite { hashes; header; _ } -> + { With_hash.hash = hashes + ; data = Mina_block.Header.protocol_state header + } + +let delta_block_chain_proof breadcrumb = + match breadcrumb.T.validated_transition with + | Full validated_transition -> + Mina_block.Validated.delta_block_chain_proof validated_transition + | Lite { delta_block_chain_proof; _ } -> + delta_block_chain_proof let consensus_state = Fn.compose Protocol_state.consensus_state protocol_state let consensus_state_with_hashes breadcrumb = - breadcrumb |> block_with_hash - |> With_hash.map ~f:(fun block -> - block |> Mina_block.header |> Mina_block.Header.protocol_state - |> Protocol_state.consensus_state ) + protocol_state_with_hashes breadcrumb + |> With_hash.map ~f:Protocol_state.consensus_state let parent_hash b = b |> protocol_state |> Protocol_state.previous_state_hash @@ -262,9 +353,7 @@ type display = [@@deriving yojson] let display t = - let protocol_state = - t |> block |> Mina_block.header |> Mina_block.Header.protocol_state - in + let protocol_state = t |> header |> Mina_block.Header.protocol_state in let blockchain_state = Blockchain_state.display (Protocol_state.blockchain_state protocol_state) in @@ -279,6 +368,191 @@ let display t = ; parent } +let staged_ledger_aux_and_pending_coinbases_at_hash_compute + ~scan_state_protocol_states breadcrumb = + let staged_ledger = staged_ledger breadcrumb in + let scan_state = Staged_ledger.scan_state staged_ledger in + let%map.Option protocol_states = scan_state_protocol_states scan_state in + let staged_ledger_hash = staged_ledger_hash breadcrumb in + let merkle_root = Staged_ledger_hash.ledger_hash staged_ledger_hash in + let pending_coinbase = + Staged_ledger.pending_coinbase_collection staged_ledger + in + let module Data = + Network_types.Staged_ledger_aux_and_pending_coinbases.Data.Stable.Latest + in + (* Cache in frontier and return tag *) + State_hash.File_storage.append_values_exn (state_hash breadcrumb) + ~f:(fun writer -> + State_hash.File_storage.write_value writer + (module Data) + ( Staged_ledger.Scan_state.Stable.V2.of_latest_exn scan_state + , merkle_root + , pending_coinbase + , protocol_states ) ) + +let staged_ledger_aux_and_pending_coinbases ~scan_state_protocol_states + breadcrumb : + Network_types.Staged_ledger_aux_and_pending_coinbases.data_tag option = + match staged_ledger_aux_and_pending_coinbases_cached breadcrumb with + | Some res -> + Some res + | None -> + let res = + staged_ledger_aux_and_pending_coinbases_at_hash_compute + ~scan_state_protocol_states breadcrumb + in + Option.iter res ~f:(fun tag -> + breadcrumb.staged_ledger_aux_and_pending_coinbases_cached <- Some tag ) ; + res + +let to_maps (staged_ledger : Staged_ledger.t) = + let ledger = Staged_ledger.ledger staged_ledger in + Mina_ledger.Ledger.get_maps ledger + |> Mina_ledger.Ledger.Mask_maps.to_stable + ~ledger_depth:(Mina_ledger.Ledger.depth ledger) + +let to_block_data_exn (breadcrumb : T.t) : Block_data.Full.t = + let application_data = + match breadcrumb.application_data with + | Some application_data -> + application_data + | None -> + failwithf "application_data is not set for breadcrumb %s" + (State_hash.to_base58_check @@ state_hash breadcrumb) + () + in + { Block_data.Full.Stable.Latest.header = header breadcrumb + ; block_tag = breadcrumb.block_tag + ; delta_block_chain_proof = delta_block_chain_proof breadcrumb + ; staged_ledger_data = (to_maps breadcrumb.staged_ledger, application_data) + ; accounts_created = breadcrumb.accounts_created + ; staged_ledger_aux_and_pending_coinbases_cached = + breadcrumb.staged_ledger_aux_and_pending_coinbases_cached + ; transaction_hashes_unordered = + Mina_transaction.Transaction_hash.Set.to_list + breadcrumb.transaction_hashes + ; command_stats = command_stats breadcrumb + } + +let lighten ?(retain_application_data = false) (breadcrumb : T.t) : T.t = + match breadcrumb.T.validated_transition with + | Full validated_transition -> + { breadcrumb with + validated_transition = + Lite + { header = header breadcrumb + ; hashes = + Mina_block.Validated.forget validated_transition + |> With_hash.hash + ; delta_block_chain_proof = delta_block_chain_proof breadcrumb + ; command_stats = command_stats breadcrumb + } + ; application_data = + (let%bind.Option () = Option.some_if retain_application_data () in + breadcrumb.application_data ) + } + | Lite _ -> + breadcrumb + +(* Methods below are expensive if called on Lite transition *) +(* TODO consider strengthening usage of these on a type level + to avoid calling them on Lite transitions without explicit conversion to Full *) + +let validated_transition t = + match t.T.validated_transition with + | Full validated_transition -> + validated_transition + | Lite { hashes; delta_block_chain_proof; _ } -> + let proof_cache_db = + (* TODO: replace with actual DB *) + Proof_cache_tag.create_identity_db () + in + let block_stable = + State_hash.File_storage.read + (module Mina_block.Stable.Latest) + t.T.block_tag + (* TODO consider using a more specific error *) + |> Or_error.tag ~tag:"get_root_transition" + |> Or_error.ok_exn + in + let block = + Mina_block.write_all_proofs_to_disk + ~signature_kind:Mina_signature_kind.t_DEPRECATED ~proof_cache_db + block_stable + in + Mina_block.Validated.unsafe_of_trusted_block ~delta_block_chain_proof + (`This_block_is_trusted_to_be_safe + { With_hash.data = block; hash = hashes } ) + +let block_with_hash = + Fn.compose Mina_block.Validated.forget validated_transition + +let block = Fn.compose With_hash.data block_with_hash + +let command_hashes t = command_hashes_of_transition (validated_transition t) + +let valid_commands_hashed (t : T.t) = + List.map2_exn + (Mina_block.Validated.valid_commands @@ validated_transition t) + (command_hashes t) + ~f:(fun command hash -> + With_status.map command + ~f: + (Fn.flip + Mina_transaction.Transaction_hash.User_command_with_valid_signature + .make hash ) ) + +let stored_transition_of_block_data ~state_hash (block_data : Block_data.Full.t) + : stored_transition = + Lite + { hashes = { State_hash.State_hashes.state_hash; state_body_hash = None } + ; delta_block_chain_proof = block_data.delta_block_chain_proof + ; command_stats = block_data.command_stats + ; header = block_data.header + } + +let of_block_data ~logger ~constraint_constants ~parent_staged_ledger + ~state_hash (block_data : Block_data.Full.t) : (t, _) Deferred.Result.t = + let maps_stable, application_data = block_data.staged_ledger_data in + let parent_ledger = Staged_ledger.ledger parent_staged_ledger in + let maps = + Mina_ledger.Ledger.Mask_maps.of_stable + ~ledger_depth:(Mina_ledger.Ledger.depth parent_ledger) + maps_stable + in + let new_mask = + Mina_ledger.Ledger.Mask.create + ~depth:(Mina_ledger.Ledger.depth parent_ledger) + () + in + let new_ledger = Mina_ledger.Ledger.register_mask parent_ledger new_mask in + Mina_ledger.Ledger.append_maps new_ledger maps ; + let%map.Deferred.Result staged_ledger, res_opt = + Staged_ledger.apply_to_scan_state ~logger ~skip_verification:true + ~log_prefix:"of_block_data" ~ledger:new_ledger + ~previous_pending_coinbase_collection: + (Staged_ledger.pending_coinbase_collection parent_staged_ledger) + ~previous_scan_state:(Staged_ledger.scan_state parent_staged_ledger) + ~constraint_constants application_data + in + { T.validated_transition = + stored_transition_of_block_data ~state_hash block_data + ; staged_ledger + ; accounts_created = block_data.accounts_created + ; just_emitted_a_proof = Option.is_some res_opt + ; transition_receipt_time = None + ; block_tag = block_data.block_tag + ; application_data = None + ; staged_ledger_hash = + Mina_block.Header.protocol_state block_data.header + |> Protocol_state.blockchain_state |> Blockchain_state.staged_ledger_hash + ; staged_ledger_aux_and_pending_coinbases_cached = None + ; transaction_hashes = + Mina_transaction.Transaction_hash.Set.of_list + block_data.transaction_hashes_unordered + } + module For_tests = struct open Currency open Signature_lib @@ -360,7 +634,10 @@ module For_tests = struct let transactions = gen_payments ~send_to_random_pk parent_staged_ledger accounts_with_secret_keys - |> Sequence.map ~f:(fun x -> User_command.Signed_command x) + |> Sequence.map ~f:(fun x -> + Mina_transaction.Transaction_hash + .User_command_with_valid_signature + .create @@ User_command.Signed_command x ) in let _, largest_account = List.max_elt accounts_with_secret_keys @@ -382,18 +659,20 @@ module For_tests = struct ; prover } ) in - let current_state_view, state_and_body_hash = + let current_state_view, state_and_body_hash, parent_protocol_state_body = let prev_state = parent_breadcrumb |> block |> Mina_block.header |> Mina_block.Header.protocol_state in let prev_state_hashes = Protocol_state.hashes prev_state in + let parent_protocol_state_body = Protocol_state.body prev_state in let current_state_view = - Protocol_state.body prev_state |> Protocol_state.Body.view + Protocol_state.Body.view parent_protocol_state_body in ( current_state_view , ( prev_state_hashes.state_hash - , Option.value_exn prev_state_hashes.state_body_hash ) ) + , Option.value_exn prev_state_hashes.state_body_hash ) + , parent_protocol_state_body ) in let current_global_slot = Mina_numbers.Global_slot_since_genesis.add @@ -413,19 +692,57 @@ module For_tests = struct let body = Mina_block.Body.create @@ Staged_ledger_diff.forget staged_ledger_diff in - let%bind ( `Ledger_proof ledger_proof_opt - , `Staged_ledger transitioned_staged_ledger - , `Pending_coinbase_update _ ) = - match%bind + let ledger_and_proof = + let%bind.Deferred.Result ( `Ledger new_ledger + , `Accounts_created _ + , `Stack_update stack_update + , `First_pass_ledger_end first_pass_ledger_end + , `Witnesses witnesses + , `Works works + , `Pending_coinbase_update (is_new_stack, _) ) + = Staged_ledger.apply_diff_unchecked parent_staged_ledger ~global_slot:current_global_slot ~coinbase_receiver ~logger staged_ledger_diff ~constraint_constants:precomputed_values.constraint_constants - ~current_state_view ~state_and_body_hash ~supercharge_coinbase + ~parent_protocol_state_body ~state_and_body_hash + ~supercharge_coinbase ~zkapp_cmd_limit_hardcap: precomputed_values.genesis_constants.zkapp_cmd_limit_hardcap ~signature_kind:Testnet - with + in + (* For test it is not important which file to write to *) + let state_hash = Quickcheck.random_value State_hash.gen in + let tagged_witnesses, tagged_works = + State_hash.File_storage.write_values_exn state_hash ~f:(fun writer -> + let witnesses' = + Staged_ledger.Scan_state.Transaction_with_witness.persist_many + witnesses writer + in + let works' = + Staged_ledger.Scan_state.Ledger_proof_with_sok_message + .persist_many works writer + in + (witnesses', works') ) + in + let scan_state_application_data = + { Staged_ledger.Scan_state.Application_data.is_new_stack + ; stack_update + ; first_pass_ledger_end + ; tagged_works + ; tagged_witnesses + } + in + Staged_ledger.apply_to_scan_state ~logger ~skip_verification:false + ~log_prefix:"apply_diff" ~ledger:new_ledger + ~previous_pending_coinbase_collection: + (Staged_ledger.pending_coinbase_collection parent_staged_ledger) + ~previous_scan_state:(Staged_ledger.scan_state parent_staged_ledger) + ~constraint_constants:precomputed_values.constraint_constants + scan_state_application_data + in + let%bind transitioned_staged_ledger, ledger_proof_opt = + match%bind ledger_and_proof with | Ok r -> return r | Error e -> @@ -440,8 +757,7 @@ module For_tests = struct |> Blockchain_state.ledger_proof_statement in let ledger_proof_statement = - Option.value_map ledger_proof_opt - ~f:(fun (proof, _) -> Ledger_proof.Cached.statement proof) + Option.value_map ledger_proof_opt ~f:Ledger_proof.Tagged.statement ~default:previous_ledger_proof_stmt in let genesis_ledger_hash = diff --git a/src/lib/transition_frontier/frontier_base/breadcrumb.mli b/src/lib/transition_frontier/frontier_base/breadcrumb.mli index 491b5e629192..1322521cf4cd 100644 --- a/src/lib/transition_frontier/frontier_base/breadcrumb.mli +++ b/src/lib/transition_frontier/frontier_base/breadcrumb.mli @@ -25,6 +25,8 @@ val create : -> staged_ledger:Staged_ledger.t -> just_emitted_a_proof:bool -> transition_receipt_time:Time.t option + -> accounts_created:Account_id.t list + -> block_tag:Mina_block.Stable.Latest.t State_hash.File_storage.tag -> t val build : @@ -49,11 +51,14 @@ val build : Result.t Deferred.t -val validated_transition : t -> Mina_block.Validated.t +val contains_transaction_by_hash : + t -> Mina_transaction.Transaction_hash.t -> bool -val block_with_hash : t -> Mina_block.with_hash +val header : t -> Mina_block.Header.t -val block : t -> Mina_block.t +val command_stats : t -> Command_stats.t + +val block_tag : t -> Mina_block.Stable.Latest.t State_hash.File_storage.tag val staged_ledger : t -> Staged_ledger.t @@ -85,6 +90,86 @@ val name : t -> string val staged_ledger_hash : t -> Staged_ledger_hash.t +(** The accounts created in the block that this breadcrumb represents + For convenience of implementation, it's by definition an empty list for the root *) +val accounts_created : t -> Account_id.t list + +val delta_block_chain_proof : t -> State_hash.t Mina_stdlib.Nonempty_list.t + +val staged_ledger_aux_and_pending_coinbases_cached : + t -> Network_types.Staged_ledger_aux_and_pending_coinbases.data_tag option + +val staged_ledger_aux_and_pending_coinbases : + scan_state_protocol_states: + ( Staged_ledger.Scan_state.t + -> Mina_state.Protocol_state.Value.t list option ) + -> t + -> Network_types.Staged_ledger_aux_and_pending_coinbases.data_tag option + +(** Convert a breadcrumb to a block data + + Will return an exception if called on transition frontier root or + a lite breadcrumb (i.e. one that was added to frontier). +*) +val to_block_data_exn : t -> Block_data.Full.t + +(** Convert a full breadcrumb to a lite breadcrumb *) +val lighten : ?retain_application_data:bool -> t -> t + +(** Get the validated transition from a breadcrumb. + + Caution: operation is expensive if called on a lite + breadcrumb (and can throw an exception on reading from + multi-key file storage for block). +*) +val validated_transition : t -> Mina_block.Validated.t + +(** Get the block with hash from a breadcrumb. + + Caution: operation is expensive if called on a lite + breadcrumb (and can throw an exception on reading from + multi-key file storage for block). +*) +val block_with_hash : t -> Mina_block.with_hash + +(** Get the block from a breadcrumb. + + Caution: operation is expensive if called on a lite + breadcrumb (and can throw an exception on reading from + multi-key file storage for block). +*) +val block : t -> Mina_block.t + +(** Get the command hashes from a breadcrumb + (in order of transaction appearance in block). + + Caution: operation is expensive if called on a lite + breadcrumb (and can throw an exception on reading from + multi-key file storage for block). +*) +val command_hashes : t -> Mina_transaction.Transaction_hash.t list + +(** Get the valid commands from a breadcrumb along with their hashes + (in order of transaction appearance in block). + + Caution: operation is expensive if called on a lite + breadcrumb (and can throw an exception on reading from + multi-key file storage for block). +*) +val valid_commands_hashed : + t + -> Mina_transaction.Transaction_hash.User_command_with_valid_signature.t + With_status.t + list + +val of_block_data : + logger:Logger.t + -> constraint_constants:Genesis_constants.Constraint_constants.t + -> parent_staged_ledger:Staged_ledger.t + -> state_hash:Frozen_ledger_hash.t + -> Block_data.Full.t + -> (t, Staged_ledger.Staged_ledger_error.t) Deferred.Result.t + module For_tests : sig val gen : ?logger:Logger.t diff --git a/src/lib/transition_frontier/frontier_base/command_stats.ml b/src/lib/transition_frontier/frontier_base/command_stats.ml new file mode 100644 index 000000000000..8cfa48c7a16f --- /dev/null +++ b/src/lib/transition_frontier/frontier_base/command_stats.ml @@ -0,0 +1,38 @@ +open Core_kernel +open Mina_base + +[%%versioned +module Stable = struct + module V1 = struct + type t = { total : int; zkapp_commands : int; has_coinbase : bool } + + let to_latest = Fn.id + end +end] + +let has_coinbase (staged_ledger_diff : Staged_ledger_diff.t) = + let d1, d2 = staged_ledger_diff.diff in + match (d1.coinbase, d2) with + | Zero, None | Zero, Some { coinbase = Zero; _ } -> + false + | Zero, Some { coinbase = One _; _ } | One _, _ | Two _, _ -> + true + +let of_body (body : Mina_block.Body.t) = + let staged_ledger_diff = Staged_ledger_diff.Body.staged_ledger_diff body in + Staged_ledger_diff.commands staged_ledger_diff + |> List.fold + ~init: + { total = 0 + ; zkapp_commands = 0 + ; has_coinbase = has_coinbase staged_ledger_diff + } + ~f: + (fun v -> function + | { With_status.data = User_command.Signed_command _; _ } -> + { v with total = v.total + 1 } + | { data = Zkapp_command _; _ } -> + { v with + total = v.total + 1 + ; zkapp_commands = v.zkapp_commands + 1 + } ) diff --git a/src/lib/transition_frontier/frontier_base/diff.ml b/src/lib/transition_frontier/frontier_base/diff.ml index f13b00cd7751..5fde60450dda 100644 --- a/src/lib/transition_frontier/frontier_base/diff.ml +++ b/src/lib/transition_frontier/frontier_base/diff.ml @@ -8,14 +8,12 @@ type lite = Lite module Node = struct type 'a t = | Full : Breadcrumb.t -> full t - | Lite : Mina_block.Validated.t -> lite t + | Lite : State_hash.t * Block_data.Full.t -> lite t end module Node_list = struct type full_node = - { transition : Mina_block.Validated.t - ; scan_state : Staged_ledger.Scan_state.t - } + { state_hash : State_hash.t; scan_state : Staged_ledger.Scan_state.t } type lite_node = State_hash.t @@ -25,9 +23,7 @@ module Node_list = struct type 'repr node_list = 'repr t - let to_lite = - List.map ~f:(fun { transition; _ } -> - Mina_block.Validated.state_hash transition ) + let to_lite = List.map ~f:(fun { state_hash; _ } -> state_hash) module Lite = struct module Binable_arg = struct @@ -70,7 +66,7 @@ module Root_transition = struct | Full : Staged_ledger.Scan_state.t -> full root_transition_scan_state type 'repr t = - { new_root : Root_data.Limited.Stable.Latest.t + { new_root : Root_data.t ; garbage : 'repr Node_list.t ; old_root_scan_state : 'repr root_transition_scan_state ; just_emitted_a_proof : bool @@ -78,69 +74,8 @@ module Root_transition = struct type 'repr root_transition = 'repr t - module Lite_binable = struct - [%%versioned - module Stable = struct - [@@@no_toplevel_latest_type] - - module V4 = struct - type t = - { new_root : Root_data.Limited.Stable.V3.t - ; garbage : Node_list.Lite.Stable.V1.t - ; just_emitted_a_proof : bool - } - - let to_latest = Fn.id - end - end] - end - module Lite = struct - module Binable_arg = struct - [%%versioned - module Stable = struct - [@@@no_toplevel_latest_type] - - module V4 = struct - type t = Lite_binable.Stable.V4.t - - let to_latest = Fn.id - end - end] - end - - [%%versioned_binable - module Stable = struct - module V4 = struct - type t = lite root_transition - - module T_nonbinable = struct - type nonrec t = t - - let to_binable - ({ new_root - ; garbage - ; just_emitted_a_proof - ; old_root_scan_state = Lite - } : - t ) : Binable_arg.Stable.V4.t = - { new_root; garbage; just_emitted_a_proof } - - let of_binable - ({ new_root; garbage; just_emitted_a_proof } : - Binable_arg.Stable.V4.t ) : t = - { new_root - ; garbage - ; old_root_scan_state = Lite - ; just_emitted_a_proof - } - end - - include Binable.Of_binable (Binable_arg.Stable.V4) (T_nonbinable) - - let to_latest = Fn.id - end - end] + type t = lite root_transition end end @@ -164,8 +99,8 @@ let to_yojson (type repr mutant) (key : (repr, mutant) t) = match key with | New_node (Full breadcrumb) -> State_hash.to_yojson (Breadcrumb.state_hash breadcrumb) - | New_node (Lite transition) -> - State_hash.to_yojson (Mina_block.Validated.state_hash transition) + | New_node (Lite (state_hash, _)) -> + State_hash.to_yojson state_hash | Root_transitioned { new_root; garbage; just_emitted_a_proof; old_root_scan_state = _ } -> let garbage_hashes = @@ -176,9 +111,7 @@ let to_yojson (type repr mutant) (key : (repr, mutant) t) = hashes in `Assoc - [ ( "new_root" - , State_hash.to_yojson - (Root_data.Limited.Stable.Latest.hashes new_root).state_hash ) + [ ("new_root", State_hash.to_yojson new_root.state_hash) ; ("garbage", `List (List.map ~f:State_hash.to_yojson garbage_hashes)) ; ("just_emitted_a_proof", `Bool just_emitted_a_proof) ] @@ -190,8 +123,8 @@ let to_yojson (type repr mutant) (key : (repr, mutant) t) = let to_lite (type mutant) (diff : (full, mutant) t) : (lite, mutant) t = match diff with | New_node (Full breadcrumb) -> - let external_transition = Breadcrumb.validated_transition breadcrumb in - New_node (Lite external_transition) + let external_transition = Breadcrumb.to_block_data_exn breadcrumb in + New_node (Lite (Breadcrumb.state_hash breadcrumb, external_transition)) | Root_transitioned { new_root ; garbage = Full garbage_nodes diff --git a/src/lib/transition_frontier/frontier_base/diff.mli b/src/lib/transition_frontier/frontier_base/diff.mli index ee7489b41fbe..dd5b41c6c245 100644 --- a/src/lib/transition_frontier/frontier_base/diff.mli +++ b/src/lib/transition_frontier/frontier_base/diff.mli @@ -23,14 +23,12 @@ type lite = Lite module Node : sig type 'a t = | Full : Breadcrumb.t -> full t - | Lite : Mina_block.Validated.t -> lite t + | Lite : State_hash.t * Block_data.Full.t -> lite t end module Node_list : sig type full_node = - { transition : Mina_block.Validated.t - ; scan_state : Staged_ledger.Scan_state.t - } + { state_hash : State_hash.t; scan_state : Staged_ledger.Scan_state.t } type lite_node = State_hash.Stable.V1.t @@ -62,7 +60,7 @@ module Root_transition : sig | Full : Staged_ledger.Scan_state.t -> full root_transition_scan_state type 'repr t = - { new_root : Root_data.Limited.Stable.Latest.t + { new_root : Root_data.t ; garbage : 'repr Node_list.t ; old_root_scan_state : 'repr root_transition_scan_state ; just_emitted_a_proof : bool @@ -71,12 +69,7 @@ module Root_transition : sig type 'repr root_transition = 'repr t module Lite : sig - [%%versioned: - module Stable : sig - module V4 : sig - type t = lite root_transition - end - end] + type t = lite root_transition end end diff --git a/src/lib/transition_frontier/frontier_base/frontier_intf.ml b/src/lib/transition_frontier/frontier_base/frontier_intf.ml index fabe984061a1..2aadc5013861 100644 --- a/src/lib/transition_frontier/frontier_base/frontier_intf.ml +++ b/src/lib/transition_frontier/frontier_base/frontier_intf.ml @@ -10,10 +10,13 @@ module type S = sig val consensus_local_state : t -> Consensus.Data.Local_state.t + val all_state_hashes : t -> State_hash.t list + val all_breadcrumbs : t -> Breadcrumb.t list val root_length : t -> int + (* Primary needed for consensus state *) val root : t -> Breadcrumb.t val best_tip : t -> Breadcrumb.t @@ -32,8 +35,6 @@ module type S = sig val successors : t -> Breadcrumb.t -> Breadcrumb.t list - val iter : t -> f:(Breadcrumb.t -> unit) -> unit - val best_tip_path_length_exn : t -> int val visualize_to_string : t -> string diff --git a/src/lib/transition_frontier/frontier_base/network_types.ml b/src/lib/transition_frontier/frontier_base/network_types.ml new file mode 100644 index 000000000000..2a921d423011 --- /dev/null +++ b/src/lib/transition_frontier/frontier_base/network_types.ml @@ -0,0 +1,107 @@ +open Core_kernel +open Mina_base + +module Tag_or_data = struct + [%%versioned + module Stable = struct + module V1 = struct + type 'a t = + | Tag of + (State_hash.Stable.V1.t, 'a) Multi_key_file_storage.Tag.Stable.V1.t + | Data of 'a + + let to_latest = Fn.id + end + end] +end + +module Make' (Data : Binable.S) = struct + include Bin_prot.Utils.Of_minimal (struct + type t = Data.t Tag_or_data.t + + let bin_shape_t = Data.bin_shape_t + + let __bin_read_t__ buf ~pos_ref vint = + Tag_or_data.Data (Data.__bin_read_t__ buf ~pos_ref vint) + + let bin_read_t buf ~pos_ref = + Tag_or_data.Data (Data.bin_read_t buf ~pos_ref) + + let bin_size_t = function + | Tag_or_data.Tag tag -> + State_hash.File_storage.size tag + | Data x -> + Data.bin_size_t x + + let bin_write_t buf ~pos = function + | Tag_or_data.Tag tag -> + let data = + State_hash.File_storage.read_bytes tag |> Or_error.ok_exn + in + let bs = Bigstring.of_bytes data in + let len = Bigstring.length bs in + Bigstring.blit ~src:bs ~src_pos:0 ~dst:buf ~dst_pos:pos ~len ; + pos + len + | Data x -> + Data.bin_write_t buf ~pos x + end) + + let extract = function + | Tag_or_data.Tag x -> + State_hash.File_storage.read (module Data) x + | Data x -> + Or_error.return x + + type data_tag = Data.t State_hash.File_storage.tag +end + +module Staged_ledger_aux_and_pending_coinbases = struct + module Data = struct + [%%versioned + module Stable = struct + [@@@no_toplevel_latest_type] + + module V1 = struct + type t = + Staged_ledger.Scan_state.Stable.V2.t + * Ledger_hash.Stable.V1.t + * Pending_coinbase.Stable.V2.t + * Mina_state.Protocol_state.Value.Stable.V2.t list + + let to_latest = Fn.id + end + end] + end + + [%%versioned_binable + module Stable = struct + module V1 = struct + type t = Data.Stable.Latest.t Tag_or_data.t + + let to_latest = Fn.id + + include Make' (Data.Stable.V1) + end + end] + + let extract = Stable.Latest.extract + + type data_tag = Stable.Latest.data_tag +end + +module Block = struct + [%%versioned_binable + module Stable = struct + module V1 = struct + type t = Mina_block.Stable.V2.t Tag_or_data.t + + let to_latest = Fn.id + + include Make' (Mina_block.Stable.V2) + end + end] + + let extract = Stable.Latest.extract + + type data_tag = Stable.Latest.data_tag +end diff --git a/src/lib/transition_frontier/frontier_base/root_data.ml b/src/lib/transition_frontier/frontier_base/root_data.ml index 7850bd3fc2aa..e973c0b07129 100644 --- a/src/lib/transition_frontier/frontier_base/root_data.ml +++ b/src/lib/transition_frontier/frontier_base/root_data.ml @@ -4,7 +4,16 @@ open Mina_base module Common = struct [%%versioned module Stable = struct - [@@@no_toplevel_latest_type] + (* TODO: split out V3 as a new type, remove the "option" from [block_data_opt] *) + module V3 = struct + type t = + { scan_state : Staged_ledger.Scan_state.Stable.V3.t + ; pending_coinbase : Pending_coinbase.Stable.V2.t + ; block_data_opt : Block_data.Stable.V1.t option + } + + let to_latest = Fn.id + end module V2 = struct type t = @@ -12,122 +21,85 @@ module Common = struct ; pending_coinbase : Pending_coinbase.Stable.V2.t } - let to_latest = Fn.id + let to_latest { scan_state; pending_coinbase } = + { V3.scan_state = + Staged_ledger.Scan_state.Stable.V2.to_latest scan_state + ; pending_coinbase + ; block_data_opt = None + } end end] - type t = - { scan_state : Staged_ledger.Scan_state.t - ; pending_coinbase : Pending_coinbase.t - } - - let to_yojson { scan_state = _; pending_coinbase } = - `Assoc - [ ("scan_state", `String "") - ; ( "pending_coinbase" - , Pending_coinbase.Stable.V2.to_yojson pending_coinbase ) - ] - - let create ~scan_state ~pending_coinbase = { scan_state; pending_coinbase } + let create ~scan_state ~pending_coinbase ~block_data_opt = + { scan_state; pending_coinbase; block_data_opt } let scan_state t = t.scan_state let pending_coinbase t = t.pending_coinbase - let read_all_proofs_from_disk { scan_state; pending_coinbase } = - { Stable.Latest.pending_coinbase - ; scan_state = Staged_ledger.Scan_state.read_all_proofs_from_disk scan_state - } + let protocol_state t = + Option.map t.block_data_opt ~f:(fun t -> t.protocol_state) end module Historical = struct type t = - { transition : Mina_block.Validated.t - ; common : Common.t - ; staged_ledger_target_ledger_hash : Ledger_hash.t + { block_tag : Network_types.Block.data_tag + ; staged_ledger_aux_and_pending_coinbases : + Network_types.Staged_ledger_aux_and_pending_coinbases.data_tag + ; required_state_hashes : State_hash.Set.t + ; protocol_state_with_hashes : + Mina_state.Protocol_state.Value.t State_hash.With_state_hashes.t } + [@@deriving fields] - let transition t = t.transition - - let staged_ledger_target_ledger_hash t = t.staged_ledger_target_ledger_hash - - let scan_state t = Common.scan_state t.common + let protocol_state t = With_hash.data t.protocol_state_with_hashes - let pending_coinbase t = Common.pending_coinbase t.common - - let of_breadcrumb breadcrumb = - let transition = Breadcrumb.validated_transition breadcrumb in - let staged_ledger = Breadcrumb.staged_ledger breadcrumb in - let scan_state = Staged_ledger.scan_state staged_ledger in - let pending_coinbase = - Staged_ledger.pending_coinbase_collection staged_ledger - in - let staged_ledger_target_ledger_hash = - Breadcrumb.staged_ledger_hash breadcrumb |> Staged_ledger_hash.ledger_hash - in - let common = Common.create ~scan_state ~pending_coinbase in - { transition; common; staged_ledger_target_ledger_hash } + let create ~block_tag ~staged_ledger_aux_and_pending_coinbases + ~required_state_hashes ~protocol_state_with_hashes = + { block_tag + ; staged_ledger_aux_and_pending_coinbases + ; required_state_hashes + ; protocol_state_with_hashes + } end module Limited = struct - [%%versioned - module Stable = struct - [@@@no_toplevel_latest_type] - - module V3 = struct - type t = - { transition : Mina_block.Validated.Stable.V2.t - ; protocol_states : - Mina_state.Protocol_state.Value.Stable.V2.t - Mina_base.State_hash.With_state_hashes.Stable.V1.t - list - ; common : Common.Stable.V2.t - } - [@@deriving fields] - - let to_latest = Fn.id - - let hashes t = Mina_block.Validated.Stable.Latest.hashes t.transition - - let create ~transition ~scan_state ~pending_coinbase ~protocol_states = - let common = { Common.Stable.V2.scan_state; pending_coinbase } in - { transition; common; protocol_states } - end - end] - type t = - { transition : Mina_block.Validated.t - ; protocol_states : - Mina_state.Protocol_state.Value.t - Mina_base.State_hash.With_state_hashes.t + { state_hash : State_hash.Stable.Latest.t + ; protocol_states_for_scan_state : + Mina_state.Protocol_state.Value.Stable.Latest.t + Mina_base.State_hash.With_state_hashes.Stable.Latest.t list - ; common : Common.t + ; scan_state : Staged_ledger.Scan_state.Stable.Latest.t + ; pending_coinbase : Pending_coinbase.Stable.Latest.t + ; protocol_state : Mina_state.Protocol_state.Value.Stable.Latest.t + ; block_tag : + ( State_hash.Stable.Latest.t + , Mina_block.Stable.Latest.t ) + Multi_key_file_storage.Tag.Stable.Latest.t + } + [@@deriving bin_io_unversioned, fields] + + let to_yojson { state_hash; _ } = + `Assoc [ ("state_hash", State_hash.to_yojson state_hash) ] + + let create ~block_tag ~state_hash ~scan_state ~pending_coinbase + ~protocol_states_for_scan_state ~protocol_state = + { state_hash + ; protocol_states_for_scan_state + ; scan_state + ; pending_coinbase + ; protocol_state + ; block_tag } - [@@deriving fields] - - let to_yojson { transition; protocol_states = _; common } = - `Assoc - [ ("transition", Mina_block.Validated.to_yojson transition) - ; ("protocol_states", `String "") - ; ("common", Common.to_yojson common) - ] - - let create ~transition ~scan_state ~pending_coinbase ~protocol_states = - let common = { Common.scan_state; pending_coinbase } in - { transition; common; protocol_states } - let hashes t = With_hash.hash @@ Mina_block.Validated.forget t.transition + let scan_state t = t.scan_state - let scan_state t = Common.scan_state t.common + let pending_coinbase t = t.pending_coinbase - let pending_coinbase t = Common.pending_coinbase t.common + let block_tag t = t.block_tag - let read_all_proofs_from_disk t = - { Stable.Latest.transition = - Mina_block.Validated.read_all_proofs_from_disk t.transition - ; protocol_states = t.protocol_states - ; common = Common.read_all_proofs_from_disk t.common - } + let protocol_state t = t.protocol_state end module Minimal = struct @@ -135,30 +107,33 @@ module Minimal = struct module Stable = struct [@@@no_toplevel_latest_type] - module V2 = struct - type t = { hash : State_hash.Stable.V1.t; common : Common.Stable.V2.t } - [@@deriving fields] - - let of_limited ~common hash = { hash; common } + module V3 = struct + type t = + { state_hash : State_hash.Stable.V1.t; common : Common.Stable.V3.t } let to_latest = Fn.id + end - let common t = t.common - - let scan_state t = t.common.Common.Stable.Latest.scan_state + module V2 = struct + type t = + { state_hash : State_hash.Stable.V1.t; common : Common.Stable.V2.t } - let pending_coinbase t = t.common.Common.Stable.Latest.pending_coinbase + let to_latest { state_hash; common } = + { V3.state_hash; common = Common.Stable.V2.to_latest common } end end] - type t = { hash : State_hash.t; common : Common.t } [@@deriving fields] + type t = Stable.Latest.t = { state_hash : State_hash.t; common : Common.t } + [@@deriving fields] - let of_limited ~common hash = { hash; common } + let common t = t.common - let upgrade t ~transition ~protocol_states = - assert (State_hash.equal (Mina_block.Validated.state_hash transition) t.hash) ; - let protocol_states = - List.map protocol_states ~f:(fun (state_hash, s) -> + let block_data_opt t = t.common.block_data_opt + + let upgrade t ~protocol_states_for_scan_state ~protocol_state ~block_tag = + (* TODO: make common always contain block_data and then remove three last parameters of this function *) + let protocol_states_for_scan_state = + List.map protocol_states_for_scan_state ~f:(fun (state_hash, s) -> { With_hash.data = s ; hash = { Mina_base.State_hash.State_hashes.state_hash @@ -168,61 +143,87 @@ module Minimal = struct in ignore ( Staged_ledger.Scan_state.check_required_protocol_states - t.common.scan_state ~protocol_states + t.common.scan_state ~protocol_states:protocol_states_for_scan_state |> Or_error.ok_exn : Mina_state.Protocol_state.value State_hash.With_state_hashes.t list ) ; - { Limited.transition; protocol_states; common = t.common } + { Limited.state_hash = t.state_hash + ; protocol_states_for_scan_state + ; scan_state = t.common.scan_state + ; pending_coinbase = t.common.pending_coinbase + ; block_tag + ; protocol_state + } + + let create ~state_hash ~scan_state ~pending_coinbase ~block_tag + ~protocol_state ~delta_block_chain_proof = + let common = + { Common.scan_state + ; pending_coinbase + ; block_data_opt = + Some { block_tag; protocol_state; delta_block_chain_proof } + } + in + { state_hash; common } - let create ~hash ~scan_state ~pending_coinbase = - let common = { Common.scan_state; pending_coinbase } in - { hash; common } + let of_common ~state_hash common = { state_hash; common } let scan_state t = Common.scan_state t.common let pending_coinbase t = Common.pending_coinbase t.common - - let write_all_proofs_to_disk ~proof_cache_db ~signature_kind - Stable.Latest.{ hash; common = { scan_state; pending_coinbase } } = - { hash - ; common = - { pending_coinbase - ; scan_state = - Staged_ledger.Scan_state.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db scan_state - } - } - - let read_all_proofs_from_disk - { hash; common = { scan_state; pending_coinbase } } = - { Stable.Latest.hash - ; common = - { pending_coinbase - ; scan_state = - Staged_ledger.Scan_state.read_all_proofs_from_disk scan_state - } - } end type t = - { transition : Mina_block.Validated.t - ; staged_ledger : Staged_ledger.t - ; protocol_states : + { block_tag : Mina_block.Stable.Latest.t Mina_base.State_hash.File_storage.tag + ; state_hash : State_hash.t + ; protocol_state : Mina_state.Protocol_state.Value.t + ; scan_state : Staged_ledger.Scan_state.t + ; pending_coinbase : Pending_coinbase.t + ; protocol_states_for_scan_state : Mina_state.Protocol_state.Value.t Mina_base.State_hash.With_state_hashes.t list + ; delta_block_chain_proof : State_hash.t Mina_stdlib.Nonempty_list.t } -let minimize { transition; staged_ledger; protocol_states = _ } = - let scan_state = Staged_ledger.scan_state staged_ledger in - let pending_coinbase = - Staged_ledger.pending_coinbase_collection staged_ledger +let minimize + { scan_state + ; pending_coinbase + ; protocol_states_for_scan_state = _ + ; block_tag + ; state_hash + ; delta_block_chain_proof + ; protocol_state + } = + let common = + Common.create ~scan_state ~pending_coinbase + ~block_data_opt: + (Some { block_tag; protocol_state; delta_block_chain_proof }) in - let common = Common.create ~scan_state ~pending_coinbase in - { Minimal.hash = Mina_block.Validated.state_hash transition; common } + { Minimal.state_hash; common } + +let limit + { scan_state + ; pending_coinbase + ; protocol_states_for_scan_state + ; block_tag + ; state_hash + ; delta_block_chain_proof = _ + ; protocol_state + } = + { Limited.block_tag + ; protocol_state + ; protocol_states_for_scan_state + ; state_hash + ; scan_state + ; pending_coinbase + } -let limit { transition; staged_ledger; protocol_states } = - let scan_state = Staged_ledger.scan_state staged_ledger in - let pending_coinbase = - Staged_ledger.pending_coinbase_collection staged_ledger - in - let common = Common.create ~scan_state ~pending_coinbase in - { Limited.transition; common; protocol_states } +let to_common + { scan_state + ; pending_coinbase + ; block_tag + ; protocol_state + ; delta_block_chain_proof + ; _ + } = + Common.create ~scan_state ~pending_coinbase + ~block_data_opt:(Some { block_tag; protocol_state; delta_block_chain_proof }) diff --git a/src/lib/transition_frontier/frontier_base/root_data.mli b/src/lib/transition_frontier/frontier_base/root_data.mli index a77c4e415983..559d0df749a0 100644 --- a/src/lib/transition_frontier/frontier_base/root_data.mli +++ b/src/lib/transition_frontier/frontier_base/root_data.mli @@ -3,16 +3,24 @@ open Mina_base module Common : sig [%%versioned: module Stable : sig - [@@@no_toplevel_latest_type] + module V3 : sig + type t + end module V2 : sig type t + + val to_latest : t -> V3.t end end] - type t + val create : + scan_state:Staged_ledger.Scan_state.t + -> pending_coinbase:Pending_coinbase.t + -> block_data_opt:Block_data.t option + -> t - val read_all_proofs_from_disk : t -> Stable.V2.t + val protocol_state : t -> Mina_state.Protocol_state.Value.t option end (* Historical root data is similar to Limited root data, except that it also @@ -22,75 +30,55 @@ end module Historical : sig type t - val transition : t -> Mina_block.Validated.t + val staged_ledger_aux_and_pending_coinbases : + t -> Network_types.Staged_ledger_aux_and_pending_coinbases.data_tag - val scan_state : t -> Staged_ledger.Scan_state.t + val required_state_hashes : t -> State_hash.Set.t - val pending_coinbase : t -> Pending_coinbase.t + val protocol_state : t -> Mina_state.Protocol_state.Value.t + + val protocol_state_with_hashes : + t -> Mina_state.Protocol_state.Value.t State_hash.With_state_hashes.t - val staged_ledger_target_ledger_hash : t -> Ledger_hash.t + val block_tag : t -> Network_types.Block.data_tag - val of_breadcrumb : Breadcrumb.t -> t + val create : + block_tag:Network_types.Block.data_tag + -> staged_ledger_aux_and_pending_coinbases: + Network_types.Staged_ledger_aux_and_pending_coinbases.data_tag + -> required_state_hashes:State_hash.Set.t + -> protocol_state_with_hashes: + Mina_state.Protocol_state.Value.t State_hash.With_state_hashes.t + -> t end (* Limited root data is similar to Minimal root data, except that it contains * the full validated transition at a root instead of just a pointer to one and protocol states for the root scan state *) module Limited : sig - [%%versioned: - module Stable : sig - [@@@no_toplevel_latest_type] - - module V3 : sig - type t - - val hashes : t -> State_hash.State_hashes.Stable.V1.t - - val common : t -> Common.Stable.V2.t - - val protocol_states : - t - -> Mina_state.Protocol_state.Value.Stable.V2.t - Mina_base.State_hash.With_state_hashes.Stable.V1.t - list - - val create : - transition:Mina_block.Validated.Stable.V2.t - -> scan_state:Staged_ledger.Scan_state.Stable.V2.t - -> pending_coinbase:Pending_coinbase.Stable.V2.t - -> protocol_states: - Mina_state.Protocol_state.value - State_hash.With_state_hashes.Stable.V1.t - list - -> t + type t [@@deriving to_yojson, bin_io] - val transition : t -> Mina_block.Validated.Stable.V2.t - end - end] - - type t [@@deriving to_yojson] + val block_tag : t -> Mina_block.Stable.Latest.t State_hash.File_storage.tag - val transition : t -> Mina_block.Validated.t - - val hashes : t -> State_hash.State_hashes.t + val state_hash : t -> State_hash.t val scan_state : t -> Staged_ledger.Scan_state.t val pending_coinbase : t -> Pending_coinbase.t - val protocol_states : + val protocol_states_for_scan_state : t -> Mina_state.Protocol_state.value State_hash.With_state_hashes.t list + val protocol_state : t -> Mina_state.Protocol_state.value + val create : - transition:Mina_block.Validated.t + block_tag:Mina_block.Stable.Latest.t State_hash.File_storage.tag + -> state_hash:State_hash.t -> scan_state:Staged_ledger.Scan_state.t -> pending_coinbase:Pending_coinbase.t - -> protocol_states: + -> protocol_states_for_scan_state: Mina_state.Protocol_state.value State_hash.With_state_hashes.t list + -> protocol_state:Mina_state.Protocol_state.value -> t - - val common : t -> Common.t - - val read_all_proofs_from_disk : t -> Stable.Latest.t end (* Minimal root data contains the smallest amount of information about a root. @@ -101,63 +89,61 @@ end module Minimal : sig [%%versioned: module Stable : sig - [@@@no_toplevel_latest_type] + module V3 : sig + type t + end module V2 : sig type t - val hash : t -> State_hash.t - - val of_limited : common:Common.Stable.V2.t -> State_hash.Stable.V1.t -> t - - val common : t -> Common.Stable.V2.t - - val scan_state : t -> Staged_ledger.Scan_state.Stable.V2.t - - val pending_coinbase : t -> Pending_coinbase.Stable.V2.t + val to_latest : t -> V3.t end end] - type t + val common : t -> Common.t - val hash : t -> State_hash.t + val state_hash : t -> State_hash.t val scan_state : t -> Staged_ledger.Scan_state.t val pending_coinbase : t -> Pending_coinbase.t - val of_limited : common:Common.t -> State_hash.t -> t + val of_common : state_hash:State_hash.t -> Common.t -> t + + val block_data_opt : t -> Block_data.t option val upgrade : t - -> transition:Mina_block.Validated.t - -> protocol_states: - (Mina_base.State_hash.t * Mina_state.Protocol_state.Value.t) list + -> protocol_states_for_scan_state: + (State_hash.t * Mina_state.Protocol_state.value) list + -> protocol_state:Mina_state.Protocol_state.Value.t + -> block_tag:Mina_block.Stable.Latest.t State_hash.File_storage.tag -> Limited.t val create : - hash:State_hash.t + state_hash:State_hash.t -> scan_state:Staged_ledger.Scan_state.t -> pending_coinbase:Pending_coinbase.t - -> t - - val read_all_proofs_from_disk : t -> Stable.Latest.t - - val write_all_proofs_to_disk : - proof_cache_db:Proof_cache_tag.cache_db - -> signature_kind:Mina_signature_kind.t - -> Stable.Latest.t + -> block_tag:Mina_block.Stable.Latest.t State_hash.File_storage.tag + -> protocol_state:Mina_state.Protocol_state.Value.t + -> delta_block_chain_proof:State_hash.t Mina_stdlib.Nonempty_list.t -> t end type t = - { transition : Mina_block.Validated.t - ; staged_ledger : Staged_ledger.t - ; protocol_states : + { block_tag : Mina_block.Stable.Latest.t Mina_base.State_hash.File_storage.tag + ; state_hash : State_hash.t + ; protocol_state : Mina_state.Protocol_state.Value.t + ; scan_state : Staged_ledger.Scan_state.t + ; pending_coinbase : Pending_coinbase.t + ; protocol_states_for_scan_state : Mina_state.Protocol_state.Value.t Mina_base.State_hash.With_state_hashes.t list + ; delta_block_chain_proof : State_hash.t Mina_stdlib.Nonempty_list.t } val minimize : t -> Minimal.t val limit : t -> Limited.t + +val to_common : t -> Common.t diff --git a/src/lib/transition_frontier/full_catchup_tree.ml b/src/lib/transition_frontier/full_catchup_tree.ml index 1363c0f1aae2..bd2d8ee28176 100644 --- a/src/lib/transition_frontier/full_catchup_tree.ml +++ b/src/lib/transition_frontier/full_catchup_tree.ml @@ -368,7 +368,7 @@ let apply_diffs (t : t) (ds : Diff.Full.E.t list) = breadcrumb_added t b | E (Root_transitioned { new_root; garbage = Full hs; _ }) -> List.iter (Diff.Node_list.to_lite hs) ~f:(remove_node t) ; - let h = (Root_data.Limited.Stable.Latest.hashes new_root).state_hash in + let h = new_root.state_hash in if Hashtbl.mem t.nodes h then prune t ~root_hash:h else ( [%log' debug t.logger] diff --git a/src/lib/transition_frontier/full_frontier/full_frontier.ml b/src/lib/transition_frontier/full_frontier/full_frontier.ml index c547af12952f..96265c43ada3 100644 --- a/src/lib/transition_frontier/full_frontier/full_frontier.ml +++ b/src/lib/transition_frontier/full_frontier/full_frontier.ml @@ -50,12 +50,8 @@ module Protocol_states_for_root_scan_state = struct type t = Protocol_state.value State_hash.With_state_hashes.t State_hash.Map.t let protocol_states_for_next_root_scan_state protocol_states_for_old_root - ~new_scan_state + ~next_root_required_hashes ~(old_root_state : Protocol_state.value State_hash.With_state_hashes.t) = - let required_state_hashes = - Staged_ledger.Scan_state.required_state_hashes new_scan_state - |> State_hash.Set.to_list - in let protocol_state_map = (*Note: Protocol states for the next root should all be in this map assuming roots transition to their successors and do not skip any node in @@ -64,7 +60,7 @@ module Protocol_states_for_root_scan_state = struct ~key:(State_hash.With_state_hashes.state_hash old_root_state) ~data:old_root_state in - List.map required_state_hashes + List.map next_root_required_hashes ~f:(State_hash.Map.find_exn protocol_state_map) end @@ -92,6 +88,12 @@ let consensus_local_state { consensus_local_state; _ } = consensus_local_state let all_breadcrumbs t = List.map (Hashtbl.data t.table) ~f:(fun { breadcrumb; _ } -> breadcrumb) +let size t = Hashtbl.length t.table + +let all_state_hashes t = + List.map (Hashtbl.data t.table) ~f:(fun { breadcrumb; _ } -> + Breadcrumb.state_hash breadcrumb ) + let find t hash = let open Option.Let_syntax in let%map node = Hashtbl.find t.table hash in @@ -115,9 +117,7 @@ let find_protocol_state (t : t) hash = in With_hash.data s | Some breadcrumb -> - Some - ( breadcrumb |> Breadcrumb.block |> Mina_block.header - |> Mina_block.Header.protocol_state ) + Some (Breadcrumb.protocol_state breadcrumb) let root t = find_exn ~message:"root" t t.root @@ -135,21 +135,47 @@ let close ~loc t = let create ~context:(module Context : CONTEXT) ~root_data ~root_ledger ~consensus_local_state ~max_length ~persistent_root_instance - ~time_controller = + ~time_controller ~staged_ledger = let open Context in let open Root_data in - let transition_receipt_time = None in - let validated_transition = root_data.transition in - let root_hash = Mina_block.Validated.state_hash validated_transition in + let root_block_stable = + root_data.block_tag + |> State_hash.File_storage.read (module Mina_block.Stable.Latest) + |> Or_error.tag ~tag:"Full_frontier.create" + |> Or_error.ok_exn + in + let root_block = + (* It's ok to use identity DB because root is a short-lived + object: when frontier moves, it will be utilized, + and it's just one block in memory, so no concern + about excessive RAM usage *) + Mina_block.write_all_proofs_to_disk root_block_stable + ~signature_kind:Mina_signature_kind.t_DEPRECATED + ~proof_cache_db:(Proof_cache_tag.create_identity_db ()) + in + let root_hash = root_data.state_hash in + let root_block_with_hashes = + { With_hash.data = root_block + ; hash = + State_hash.State_hashes. + { state_hash = root_hash; state_body_hash = None } + } + in + let validated_transition = + Mina_block.Validated.unsafe_of_trusted_block + ~delta_block_chain_proof:root_data.delta_block_chain_proof + (`This_block_is_trusted_to_be_safe root_block_with_hashes) + in let protocol_states_for_root_scan_state = - root_data.protocol_states + root_data.protocol_states_for_scan_state |> List.map ~f:(fun s -> (State_hash.With_state_hashes.state_hash s, s)) |> State_hash.Map.of_alist_exn in let root_protocol_state = - validated_transition |> Mina_block.Validated.forget |> With_hash.data - |> Mina_block.header |> Mina_block.Header.protocol_state + Mina_block.Stable.Latest.header root_block_stable + |> Mina_block.Header.protocol_state in + let root_blockchain_state = Protocol_state.blockchain_state root_protocol_state in @@ -162,9 +188,11 @@ let create ~context:(module Context : CONTEXT) ~root_data ~root_ledger (Ledger.Any_ledger.M.merkle_root root_ledger) ) root_blockchain_state_ledger_hash ) ; let root_breadcrumb = - Breadcrumb.create ~validated_transition - ~staged_ledger:root_data.staged_ledger ~just_emitted_a_proof:false - ~transition_receipt_time + Breadcrumb.create ~validated_transition ~staged_ledger + ~just_emitted_a_proof:false + ~transition_receipt_time:None + (* accounts created shouldn't be used for the root *) + ~accounts_created:[] ~block_tag:root_data.block_tag in let root_node = { Node.breadcrumb = root_breadcrumb; successor_hashes = []; length = 0 } @@ -187,9 +215,15 @@ let create ~context:(module Context : CONTEXT) ~root_data ~root_ledger let root_data t = let open Root_data in let root = root t in - { transition = Breadcrumb.validated_transition root - ; staged_ledger = Breadcrumb.staged_ledger root - ; protocol_states = State_hash.Map.data t.protocol_states_for_root_scan_state + { state_hash = Breadcrumb.state_hash root + ; scan_state = Breadcrumb.staged_ledger root |> Staged_ledger.scan_state + ; pending_coinbase = + Breadcrumb.staged_ledger root |> Staged_ledger.pending_coinbase_collection + ; protocol_states_for_scan_state = + State_hash.Map.data t.protocol_states_for_root_scan_state + ; block_tag = Breadcrumb.block_tag root + ; delta_block_chain_proof = Breadcrumb.delta_block_chain_proof root + ; protocol_state = Breadcrumb.protocol_state root } let max_length { max_length; _ } = max_length @@ -233,8 +267,6 @@ let precomputed_values { context = (module Context); _ } = let genesis_constants { context = (module Context); _ } = Context.precomputed_values.genesis_constants -let iter t ~f = Hashtbl.iter t.table ~f:(fun n -> f n.breadcrumb) - let best_tip_path_length_exn { table; root; best_tip; _ } = let open Option.Let_syntax in let result = @@ -334,32 +366,33 @@ module Util = struct let garbage_nodes = List.map garbage_breadcrumbs ~f:(fun breadcrumb -> let open Diff.Node_list in - let transition = Breadcrumb.validated_transition breadcrumb in + let state_hash = Breadcrumb.state_hash breadcrumb in let scan_state = Staged_ledger.scan_state (Breadcrumb.staged_ledger breadcrumb) in - { transition; scan_state } ) + { state_hash; scan_state } ) in let new_scan_state = Staged_ledger.scan_state heir_staged_ledger in - let protocol_states = + let next_root_required_hashes = + Staged_ledger.Scan_state.required_state_hashes new_scan_state + |> State_hash.Set.to_list + in + let protocol_states_for_scan_state = Protocol_states_for_root_scan_state .protocol_states_for_next_root_scan_state - protocol_states_for_root_scan_state ~new_scan_state + protocol_states_for_root_scan_state ~next_root_required_hashes ~old_root_state:(Breadcrumb.protocol_state_with_hashes parent) in - let heir_transition = - Breadcrumb.validated_transition heir - |> Mina_block.Validated.read_all_proofs_from_disk - in - let new_scan_state_unwrapped = - Staged_ledger.Scan_state.read_all_proofs_from_disk new_scan_state - in let new_root_data = - Root_data.Limited.Stable.Latest.create ~transition:heir_transition - ~scan_state:new_scan_state_unwrapped - ~pending_coinbase: - (Staged_ledger.pending_coinbase_collection heir_staged_ledger) - ~protocol_states + { Root_data.block_tag = Breadcrumb.block_tag heir + ; state_hash = heir_hash + ; scan_state = new_scan_state + ; pending_coinbase = + Staged_ledger.pending_coinbase_collection heir_staged_ledger + ; protocol_states_for_scan_state + ; protocol_state = Breadcrumb.protocol_state heir + ; delta_block_chain_proof = Breadcrumb.delta_block_chain_proof heir + } in let just_emitted_a_proof = Breadcrumb.just_emitted_a_proof heir in { Diff.Root_transition.new_root = new_root_data @@ -442,7 +475,7 @@ let move_root ({ context = (module Context); _ } as t) ~new_root_hash (* STEP 1 *) List.iter garbage ~f:(fun node -> let open Diff.Node_list in - let hash = Mina_block.Validated.state_hash node.transition in + let hash = node.state_hash in let breadcrumb = find_exn ~message:"garbage" t hash in let mask = Breadcrumb.mask breadcrumb in (* this should get garbage collected and should not require additional destruction *) @@ -560,6 +593,9 @@ let move_root ({ context = (module Context); _ } as t) ~new_root_hash (Breadcrumb.just_emitted_a_proof new_root_node.breadcrumb) ~transition_receipt_time: (Breadcrumb.transition_receipt_time new_root_node.breadcrumb) + (* accounts created shouldn't be used for the root *) + ~accounts_created:[] + ~block_tag:(Breadcrumb.block_tag new_root_node.breadcrumb) in (*Update the protocol states required for scan state at the new root. Note: this should be after applying the transactions to the snarked ledger (Step 5) @@ -657,14 +693,16 @@ let apply_diff (type mutant) t (diff : (Diff.full, mutant) Diff.t) let old_best_tip = t.best_tip in t.best_tip <- new_best_tip ; (old_best_tip, None) - | Root_transitioned { new_root; garbage = Full garbage; _ } -> - let new_root_hash = - (Root_data.Limited.Stable.Latest.hashes new_root).state_hash - in + | Root_transitioned + { new_root = + { state_hash = new_root_hash + ; protocol_states_for_scan_state = new_root_protocol_states + ; _ + } + ; garbage = Full garbage + ; _ + } -> let old_root_hash = t.root in - let new_root_protocol_states = - Root_data.Limited.Stable.Latest.protocol_states new_root - in [%log' internal t.logger] "Move_frontier_root" ; move_root t ~new_root_hash ~new_root_protocol_states ~garbage ~enable_epoch_ledger_sync ; @@ -701,12 +739,7 @@ module Metrics = struct let empty_blocks_at_best_tip t = let rec go acc b = - if - not - (List.is_empty - ( Breadcrumb.validated_transition b - |> Mina_block.Validated.valid_commands ) ) - then acc + if (Breadcrumb.command_stats b).total <> 0 then acc else match parent t b with None -> acc | Some b -> go (acc + 1) b in go 0 (best_tip t) @@ -726,18 +759,6 @@ module Metrics = struct in r -. Mina_metrics.time_offset_sec - let has_coinbase b = - let d1, d2 = - ( Breadcrumb.block b |> Mina_block.body - |> Mina_block.Body.staged_ledger_diff ) - .diff - in - match (d1.coinbase, d2) with - | Zero, None | Zero, Some { coinbase = Zero; _ } -> - false - | Zero, Some { coinbase = One _; _ } | One _, _ | Two _, _ -> - true - let intprop f b = Unsigned.UInt32.to_int (f (Breadcrumb.consensus_state b)) (* Rate of slots filled on the main chain in the k slots preceeding the best tip. *) @@ -793,10 +814,7 @@ let update_metrics_with_diff (type mutant) Int.to_float (1 + List.length garbage_breadcrumbs) in let num_finalized_staged_txns = - Int.to_float - (List.length - ( Breadcrumb.validated_transition new_root_breadcrumb - |> Mina_block.Validated.valid_commands ) ) + Int.to_float (Breadcrumb.command_stats new_root_breadcrumb).total in Gauge.dec Transition_frontier.active_breadcrumbs num_breadcrumbs_removed ; Gauge.set Transition_frontier.recently_finalized_staged_txns @@ -837,27 +855,17 @@ let update_metrics_with_diff (type mutant) in Block_time.Span.( <= ) (Block_time.diff now slot_time) two_slots in - let valid_commands = - Breadcrumb.validated_transition best_tip - |> Mina_block.Validated.valid_commands + let { Command_stats.total; zkapp_commands; has_coinbase } = + Breadcrumb.command_stats best_tip in Mina_metrics.( - Gauge.set Transition_frontier.best_tip_user_txns - (Int.to_float (List.length valid_commands)) ; + Gauge.set Transition_frontier.best_tip_user_txns (Int.to_float total) ; Mina_metrics.( Gauge.set Transition_frontier.best_tip_zkapp_txns - (Int.to_float - (List.fold ~init:0 - ~f:(fun c cmd -> - match cmd.data with - | Mina_base.User_command.Poly.Zkapp_command _ -> - c + 1 - | _ -> - c ) - valid_commands ) )) ; + (Int.to_float zkapp_commands)) ; if is_recent_block then Gauge.set Transition_frontier.best_tip_coinbase - (if has_coinbase best_tip then 1. else 0.) ; + (if has_coinbase then 1. else 0.) ; Gauge.set Transition_frontier.slot_fill_rate (slot_fill_rate t) ; Gauge.set Transition_frontier.min_window_density (Int.to_float (intprop min_window_density best_tip)) ; @@ -870,6 +878,15 @@ let update_metrics_with_diff (type mutant) Gauge.set Transition_frontier.empty_blocks_at_best_tip (Int.to_float (empty_blocks_at_best_tip t))) +let lighten ?retain_application_data t state_hash = + let f node = + { node with + Node.breadcrumb = + Breadcrumb.lighten ?retain_application_data node.Node.breadcrumb + } + in + Hashtbl.change t.table state_hash ~f:(Option.map ~f) + let apply_diffs ({ context = (module Context); _ } as t) diffs ~enable_epoch_ledger_sync ~has_long_catchup_job = let open Context in @@ -942,28 +959,6 @@ module For_tests = struct !"Protocol state with hash %s not found" (State_body_hash.to_yojson hash |> Yojson.Safe.to_string) ) - let equal t1 t2 = - let sort_breadcrumbs = List.sort ~compare:Breadcrumb.compare in - let equal_breadcrumb breadcrumb1 breadcrumb2 = - let open Breadcrumb in - let open Option.Let_syntax in - let get_successor_nodes frontier breadcrumb = - let%map node = Hashtbl.find frontier.table @@ state_hash breadcrumb in - Node.successor_hashes node - in - equal breadcrumb1 breadcrumb2 - && State_hash.equal (parent_hash breadcrumb1) (parent_hash breadcrumb2) - && (let%bind successors1 = get_successor_nodes t1 breadcrumb1 in - let%map successors2 = get_successor_nodes t2 breadcrumb2 in - List.equal State_hash.equal - (successors1 |> List.sort ~compare:State_hash.compare) - (successors2 |> List.sort ~compare:State_hash.compare) ) - |> Option.value_map ~default:false ~f:Fn.id - in - List.equal equal_breadcrumb - (all_breadcrumbs t1 |> sort_breadcrumbs) - (all_breadcrumbs t2 |> sort_breadcrumbs) - (* TODO: Don't force here!! *) let precomputed_values = Lazy.force Precomputed_values.for_unit_tests @@ -1037,10 +1032,18 @@ module For_tests = struct in let root_data = let open Root_data in - { transition = - Mina_block.Validated.lift @@ Mina_block.genesis ~precomputed_values - ; staged_ledger - ; protocol_states = [] + let transition, block_tag = Mina_block.genesis ~precomputed_values in + { state_hash = Mina_block.Validated.state_hash transition + ; delta_block_chain_proof = + Mina_block.Validated.delta_block_chain_proof transition + ; scan_state = Staged_ledger.scan_state staged_ledger + ; pending_coinbase = + Staged_ledger.pending_coinbase_collection staged_ledger + ; protocol_states_for_scan_state = [] + ; block_tag + ; protocol_state = + Mina_block.Validated.header transition + |> Mina_block.Header.protocol_state } in let persistent_root = @@ -1063,7 +1066,7 @@ module For_tests = struct root_ledger ) ~consensus_local_state ~max_length ~time_controller:(Block_time.Controller.basic ~logger) - ~persistent_root_instance + ~persistent_root_instance ~staged_ledger let clean_up_persistent_root ~frontier = let persistent_root_instance = persistent_root_instance frontier in diff --git a/src/lib/transition_frontier/full_frontier/full_frontier.mli b/src/lib/transition_frontier/full_frontier/full_frontier.mli index 23d38e87e3f2..7da30a5e863a 100644 --- a/src/lib/transition_frontier/full_frontier/full_frontier.mli +++ b/src/lib/transition_frontier/full_frontier/full_frontier.mli @@ -29,7 +29,7 @@ module Protocol_states_for_root_scan_state : sig val protocol_states_for_next_root_scan_state : t - -> new_scan_state:Staged_ledger.Scan_state.t + -> next_root_required_hashes:State_hash.t list -> old_root_state:Protocol_state.value State_hash.With_state_hashes.t -> Protocol_state.value State_hash.With_state_hashes.t list end @@ -46,6 +46,7 @@ val create : -> max_length:int -> persistent_root_instance:Persistent_root.Instance.t -> time_controller:Block_time.Controller.t + -> staged_ledger:Staged_ledger.t -> t val persistent_root_instance : t -> Persistent_root.Instance.t @@ -64,6 +65,8 @@ val apply_diffs : -> [ `New_root_and_diffs_with_mutants of Root_identifier.t option * Diff.Full.With_mutant.t list ] +val size : t -> int + val common_ancestor : t -> Breadcrumb.t @@ -72,6 +75,8 @@ val common_ancestor : , [ `Parent_not_found of State_hash.t * [ `Parent of State_hash.t ] ] ) Result.t +val lighten : ?retain_application_data:bool -> t -> State_hash.t -> unit + module Util : sig (** given an heir, calculate the diff that will transition the root to that heir (assuming parent is the root) *) @@ -88,8 +93,6 @@ module Util : sig end module For_tests : sig - val equal : t -> t -> bool - val find_protocol_state_exn : t -> State_hash.t -> Mina_state.Protocol_state.value diff --git a/src/lib/transition_frontier/persistent_frontier/database.ml b/src/lib/transition_frontier/persistent_frontier/database.ml index 4093e31594b7..7ba36a9897cd 100644 --- a/src/lib/transition_frontier/persistent_frontier/database.ml +++ b/src/lib/transition_frontier/persistent_frontier/database.ml @@ -48,9 +48,50 @@ module Schema = struct [@@@warning "-22"] + module Transition = struct + [%%versioned + module Stable = struct + [@@@no_toplevel_latest_type] + + module V3 = struct + type t = + | Old_format of Mina_block.Stable.V2.t + | New_format of Block_data.Full.Stable.V1.t + + let to_latest = Fn.id + end + + module V2 = struct + type t = Mina_block.Stable.V2.t = + { header : Header.Stable.V2.t + ; body : Staged_ledger_diff.Body.Stable.V1.t + } + + let to_latest : t -> V3.t = fun block -> Old_format block + end + end] + + let header = function + | Stable.Latest.Old_format block -> + Mina_block.Stable.V2.header block + | New_format { header; _ } -> + header + + let to_validated_block ~signature_kind ~proof_cache_db ~state_hash = + function + | Stable.Latest.Old_format transition -> + Result.return + @@ Block_data.validated_of_stable ~signature_kind ~proof_cache_db + ~state_hash transition + | New_format transition -> + Block_data.Full.to_validated_block ~signature_kind ~proof_cache_db + ~state_hash transition + end + type _ t = | Db_version : int t | Transition : State_hash.Stable.V1.t -> Mina_block.Stable.V2.t t + | Transition_new : State_hash.Stable.V1.t -> Block_data.Full.Stable.V1.t t | Arcs : State_hash.Stable.V1.t -> State_hash.Stable.V1.t list t (* TODO: In hard forks, `Root` should be replaced by `(Root_hash, Root_common)`; @@ -65,9 +106,11 @@ module Schema = struct | Root : Root_data.Minimal.Stable.V2.t t | Root_hash : State_hash.Stable.V1.t t | Root_common : Root_data.Common.Stable.V2.t t + | Root_new : Root_data.Common.Stable.V3.t t | Best_tip : State_hash.Stable.V1.t t | Protocol_states_for_root_scan_state : Mina_state.Protocol_state.Value.Stable.V2.t list t + | Root_history : State_hash.Stable.V1.t list t [@@@warning "+22"] @@ -76,6 +119,8 @@ module Schema = struct "Db_version" | Transition _ -> "Transition _" + | Transition_new _ -> + "Transition_new _" | Arcs _ -> "Arcs _" | Root -> @@ -84,28 +129,38 @@ module Schema = struct "Root_hash" | Root_common -> "Root_common" + | Root_new -> + "Root_new" | Best_tip -> "Best_tip" | Protocol_states_for_root_scan_state -> "Protocol_states_for_root_scan_state" + | Root_history -> + "Root_history" let binable_data_type (type a) : a t -> a Bin_prot.Type_class.t = function | Db_version -> [%bin_type_class: int] | Transition _ -> [%bin_type_class: Mina_block.Stable.Latest.t] + | Transition_new _ -> + [%bin_type_class: Block_data.Full.Stable.Latest.t] | Arcs _ -> [%bin_type_class: State_hash.Stable.Latest.t list] | Root -> - [%bin_type_class: Root_data.Minimal.Stable.Latest.t] + [%bin_type_class: Root_data.Minimal.Stable.V2.t] | Root_hash -> [%bin_type_class: State_hash.Stable.Latest.t] | Root_common -> + [%bin_type_class: Root_data.Common.Stable.V2.t] + | Root_new -> [%bin_type_class: Root_data.Common.Stable.Latest.t] | Best_tip -> [%bin_type_class: State_hash.Stable.Latest.t] | Protocol_states_for_root_scan_state -> [%bin_type_class: Mina_state.Protocol_state.Value.Stable.Latest.t list] + | Root_history -> + [%bin_type_class: State_hash.Stable.Latest.t list] (* HACK: a simple way to derive Bin_prot.Type_class.t for each case of a GADT *) let gadt_input_type_class (type data a) : @@ -146,6 +201,11 @@ module Schema = struct (module Keys.Prefixed_state_hash.Stable.Latest) ~to_gadt:(fun (_, hash) -> Transition hash) ~of_gadt:(fun (Transition hash) -> ("transition", hash)) + | Transition_new _ -> + gadt_input_type_class + (module Keys.Prefixed_state_hash.Stable.Latest) + ~to_gadt:(fun (_, hash) -> Transition_new hash) + ~of_gadt:(fun (Transition_new hash) -> ("transition_new", hash)) | Arcs _ -> gadt_input_type_class (module Keys.Prefixed_state_hash.Stable.Latest) @@ -161,6 +221,11 @@ module Schema = struct (module Keys.String) ~to_gadt:(fun _ -> Root_hash) ~of_gadt:(fun Root_hash -> "root_hash") + | Root_new -> + gadt_input_type_class + (module Keys.String) + ~to_gadt:(fun _ -> Root_new) + ~of_gadt:(fun Root_new -> "root_new") | Root_common -> gadt_input_type_class (module Keys.String) @@ -177,6 +242,11 @@ module Schema = struct ~to_gadt:(fun _ -> Protocol_states_for_root_scan_state) ~of_gadt:(fun Protocol_states_for_root_scan_state -> "protocol_states_in_root_scan_state" ) + | Root_history -> + gadt_input_type_class + (module Keys.String) + ~to_gadt:(fun _ -> Root_history) + ~of_gadt:(fun Root_history -> "root_history") end module Error = struct @@ -230,6 +300,8 @@ module Error = struct ("arcs", Some hash) | `Protocol_states_for_root_scan_state -> ("protocol states in root scan state", None) + | `Root_history -> + ("root history", None) in let additional_context = Option.map member_id ~f:(fun id -> @@ -249,12 +321,19 @@ end module Rocks = Rocksdb.Serializable.GADT.Make (Schema) -type t = { directory : string; logger : Logger.t; db : Rocks.t } +type t = + { directory : string + ; logger : Logger.t + ; db : Rocks.t + ; root_history_capacity : int + } + +let root_history_capacity t = t.root_history_capacity -let create ~logger ~directory = +let create ~logger ~directory ~root_history_capacity = if not (Result.is_ok (Unix.access directory [ `Exists ])) then Unix.mkdir ~perm:0o766 directory ; - { directory; logger; db = Rocks.create directory } + { directory; logger; db = Rocks.create directory; root_history_capacity } let close t = Rocks.close t.db @@ -273,21 +352,34 @@ let get db ~key ~error = Don't use this when possible. It cost ~90s while get_root_hash cost seconds. *) let get_root t = - match get_batch t.db ~keys:[ Some_key Root_hash; Some_key Root_common ] with + match + get_batch t.db + ~keys:[ Some_key Root_hash; Some_key Root_new; Some_key Root_common ] + with + | [ Some (Some_key_value (Root_hash, hash)) + ; Some (Some_key_value (Root_new, common)) + ; _ + ] -> + Ok (Root_data.Minimal.of_common common ~state_hash:hash) | [ Some (Some_key_value (Root_hash, hash)) + ; None ; Some (Some_key_value (Root_common, common)) ] -> - Ok (Root_data.Minimal.Stable.V2.of_limited ~common hash) + Ok + (Root_data.Minimal.of_common + (Root_data.Common.Stable.V2.to_latest common) + ~state_hash:hash ) | _ -> ( match get t.db ~key:Root ~error:(`Not_found `Root) with - | Ok root -> + | Ok root_old -> + let root = Root_data.Minimal.Stable.V2.to_latest root_old in (* automatically split Root into (Root_hash, Root_common) *) Batch.with_batch t.db ~f:(fun batch -> - let hash = Root_data.Minimal.Stable.Latest.hash root in - let common = Root_data.Minimal.Stable.V2.common root in + let hash = Root_data.Minimal.state_hash root in + let common = Root_data.Minimal.common root in Batch.remove batch ~key:Root ; Batch.set batch ~key:Root_hash ~data:hash ; - Batch.set batch ~key:Root_common ~data:common ) ; + Batch.set batch ~key:Root_new ~data:common ) ; Ok root | Error _ as e -> @@ -298,11 +390,27 @@ let get_root_hash t = | Ok hash -> Ok hash | Error _ -> - Result.map ~f:Root_data.Minimal.Stable.Latest.hash (get_root t) + Result.map ~f:Root_data.Minimal.state_hash (get_root t) + +let get_root_history t = + match get t.db ~key:Root_history ~error:(`Not_found `Root_history) with + | Ok history -> + history + | Error _ -> + [] + +let get_transition_do t hash = + let error = `Not_found (`Transition hash) in + match get t.db ~key:(Transition_new hash) ~error with + | Ok transition -> + Ok (Transition.Stable.Latest.New_format transition) + | Error _ -> + get t.db ~key:(Transition hash) ~error + |> Result.map ~f:(fun x -> Transition.Stable.Latest.Old_format x) (* TODO: check that best tip is connected to root *) (* TODO: check for garbage *) -let check t ~genesis_state_hash = +let check ?(check_arcs = true) t ~genesis_state_hash = Or_error.try_with (fun () -> let check_version () = match get_if_exists t.db ~key:Db_version ~default:0 with @@ -321,21 +429,41 @@ let check t ~genesis_state_hash = let%bind best_tip = get t.db ~key:Best_tip ~error:(`Corrupt (`Not_found `Best_tip)) in - let%bind root_transition = - get t.db ~key:(Transition root_hash) - ~error:(`Corrupt (`Not_found `Root_transition)) + let%bind root_protocol_state = + match + get t.db ~key:Root_new ~error:() + |> Result.map ~f:Root_data.Common.protocol_state + with + | Ok (Some protocol_state) -> + Ok protocol_state + | Ok None | Error () -> + get_transition_do t root_hash + |> Result.map_error + ~f:(const @@ `Corrupt (`Not_found `Root_transition)) + |> Result.map + ~f: + (Fn.compose Mina_block.Header.protocol_state + Transition.header ) in let%bind _ = get t.db ~key:Protocol_states_for_root_scan_state ~error:(`Corrupt (`Not_found `Protocol_states_for_root_scan_state)) in let%map _ = - get t.db ~key:(Transition best_tip) - ~error:(`Corrupt (`Not_found `Best_tip_transition)) + if Frozen_ledger_hash.equal best_tip root_hash then + (* in case best tip is the root, its data is fully + stored in the root data, nothing is stored as a separate + transition *) + Ok () + else + get_transition_do t best_tip + |> Result.map_error + ~f:(const @@ `Corrupt (`Not_found `Best_tip_transition)) + |> Result.ignore_m in - (root_hash, root_transition) + (root_hash, root_protocol_state) in - let rec check_arcs pred_hash = + let rec check_arcs_do pred_hash = let%bind successors = get t.db ~key:(Arcs pred_hash) ~error:(`Corrupt (`Not_found (`Arcs pred_hash))) @@ -343,17 +471,13 @@ let check t ~genesis_state_hash = List.fold successors ~init:(Ok ()) ~f:(fun acc succ_hash -> let%bind () = acc in let%bind _ = - get t.db ~key:(Transition succ_hash) - ~error:(`Corrupt (`Not_found (`Transition succ_hash))) + get_transition_do t succ_hash + |> Result.map_error ~f:(fun e -> `Corrupt e) in - check_arcs succ_hash ) + check_arcs_do succ_hash ) in let%bind () = check_version () in - let%bind root_hash, root_block = check_base () in - let root_protocol_state = - root_block |> Mina_block.Stable.Latest.header - |> Mina_block.Header.protocol_state - in + let%bind root_hash, root_protocol_state = check_base () in let%bind () = let persisted_genesis_state_hash = Mina_state.Protocol_state.genesis_state_hash root_protocol_state @@ -362,38 +486,27 @@ let check t ~genesis_state_hash = Ok () else Error (`Genesis_state_mismatch persisted_genesis_state_hash) in - let%map () = check_arcs root_hash in - root_block |> Mina_block.Stable.Latest.header |> Header.protocol_state - |> Mina_state.Protocol_state.blockchain_state + let%map () = if check_arcs then check_arcs_do root_hash else Ok () in + Mina_state.Protocol_state.blockchain_state root_protocol_state |> Mina_state.Blockchain_state.snarked_ledger_hash ) |> Result.map_error ~f:(fun err -> `Corrupt (`Raised err)) |> Result.join let initialize t ~root_data = - let root_state_hash, root_transition = - let t = - Mina_block.Validated.forget (Root_data.Limited.transition root_data) - in - ( State_hash.With_state_hashes.state_hash t - , State_hash.With_state_hashes.data t ) - in - let root_transition = Mina_block.read_all_proofs_from_disk root_transition in + let root_state_hash = root_data.Root_data.state_hash in + let root_common = Root_data.to_common root_data in [%log' trace t.logger] - ~metadata:[ ("root_data", Root_data.Limited.to_yojson root_data) ] + ~metadata:[ ("root_data", State_hash.to_yojson root_state_hash) ] "Initializing persistent frontier database with $root_data" ; Batch.with_batch t.db ~f:(fun batch -> Batch.set batch ~key:Db_version ~data:version ; - Batch.set batch ~key:(Transition root_state_hash) ~data:root_transition ; Batch.set batch ~key:(Arcs root_state_hash) ~data:[] ; Batch.set batch ~key:Root_hash ~data:root_state_hash ; - Batch.set batch ~key:Root_common - ~data: - ( root_data |> Root_data.Limited.common - |> Root_data.Common.read_all_proofs_from_disk ) ; + Batch.set batch ~key:Root_new ~data:root_common ; Batch.set batch ~key:Best_tip ~data:root_state_hash ; Batch.set batch ~key:Protocol_states_for_root_scan_state ~data: - ( Root_data.Limited.protocol_states root_data + ( root_data.protocol_states_for_scan_state |> List.map ~f:With_hash.data ) ) let find_arcs_and_root t ~(arcs_cache : State_hash.t list State_hash.Table.t) @@ -419,70 +532,69 @@ let find_arcs_and_root t ~(arcs_cache : State_hash.t list State_hash.Table.t) | _ -> Error (`Not_found `Old_root_transition) -let add ~arcs_cache ~transition = - let transition = Mina_block.Validated.forget transition in - let hash = State_hash.With_state_hashes.state_hash transition in +let set_transition ~state_hash ~transition_data = + Batch.set ~key:(Transition_new state_hash) ~data:transition_data + +let add ~arcs_cache ~state_hash ~transition_data = let parent_hash = - With_hash.data transition |> Mina_block.header |> Header.protocol_state - |> Mina_state.Protocol_state.previous_state_hash + transition_data.Block_data.Full.Stable.Latest.header + |> Header.protocol_state |> Mina_state.Protocol_state.previous_state_hash in let parent_arcs = State_hash.Table.find_exn arcs_cache parent_hash in - State_hash.Table.set arcs_cache ~key:parent_hash ~data:(hash :: parent_arcs) ; - State_hash.Table.set arcs_cache ~key:hash ~data:[] ; - let transition_unwrapped = - With_hash.data transition |> Mina_block.read_all_proofs_from_disk - in + State_hash.Table.set arcs_cache ~key:parent_hash + ~data:(state_hash :: parent_arcs) ; + State_hash.Table.set arcs_cache ~key:state_hash ~data:[] ; fun batch -> - Batch.set batch ~key:(Transition hash) ~data:transition_unwrapped ; - Batch.set batch ~key:(Arcs hash) ~data:[] ; - Batch.set batch ~key:(Arcs parent_hash) ~data:(hash :: parent_arcs) - -let move_root ~old_root_hash ~new_root ~garbage = - let new_root_hash = - (Root_data.Limited.Stable.Latest.hashes new_root).state_hash + set_transition batch ~state_hash ~transition_data ; + Batch.set batch ~key:(Arcs state_hash) ~data:[] ; + Batch.set batch ~key:(Arcs parent_hash) ~data:(state_hash :: parent_arcs) + +let move_root ~old_root_hash ~old_root_history ~root_history_capacity ~new_root + ~garbage = + let new_root_hash = new_root.Root_data.state_hash in + let root_for_removal_opt, old_root_history' = + if List.length old_root_history = root_history_capacity then + (List.last old_root_history, List.drop_last_exn old_root_history) + else (None, old_root_history) in fun batch -> Batch.remove batch ~key:Root ; Batch.set batch ~key:Root_hash ~data:new_root_hash ; - Batch.set batch ~key:Root_common - ~data:(Root_data.Limited.Stable.Latest.common new_root) ; + Batch.set batch ~key:Root_new ~data:(Root_data.to_common new_root) ; Batch.set batch ~key:Protocol_states_for_root_scan_state - ~data: - (List.map ~f:With_hash.data - (Root_data.Limited.Stable.Latest.protocol_states new_root) ) ; - List.iter (old_root_hash :: garbage) ~f:(fun node_hash -> - (* because we are removing entire forks of the tree, there is - * no need to have extra logic to any remove arcs to the node - * we are deleting since there we are deleting all of a node's - * parents as well - *) - Batch.remove batch ~key:(Transition node_hash) ; - Batch.remove batch ~key:(Arcs node_hash) ) + ~data:(List.map ~f:With_hash.data new_root.protocol_states_for_scan_state) ; + Batch.set batch ~key:Root_history ~data:(old_root_hash :: old_root_history') ; + let remove node_hash = + (* because we are removing entire forks of the tree, there is + * no need to have extra logic to any remove arcs to the node + * we are deleting since there we are deleting all of a node's + * parents as well + *) + Batch.remove batch ~key:(Transition_new node_hash) ; + Batch.remove batch ~key:(Transition node_hash) ; + Batch.remove batch ~key:(Arcs node_hash) ; + (* TODO shouldn't be within DB batch *) + Core.Sys.remove @@ State_hash.File_storage_filename.filename node_hash + in + List.iter garbage ~f:remove ; + Option.iter root_for_removal_opt ~f:remove + +let get_transition_data ~signature_kind ~proof_cache_db t hash = + match%map.Result get_transition_do t hash with + | Old_format block -> + Either.First + (Block_data.validated_of_stable ~signature_kind ~proof_cache_db + ~state_hash:hash block ) + | New_format transition -> + Either.Second transition let get_transition ~signature_kind ~proof_cache_db t hash = - let%map transition = - get t.db ~key:(Transition hash) ~error:(`Not_found (`Transition hash)) - in - let block = - { With_hash.data = transition - ; hash = - { State_hash.State_hashes.state_hash = hash; state_body_hash = None } - } - in - let parent_hash = - block |> With_hash.data |> Mina_block.Stable.Latest.header - |> Mina_block.Header.protocol_state - |> Mina_state.Protocol_state.previous_state_hash - in - let cached_block = - With_hash.map - ~f:(Mina_block.write_all_proofs_to_disk ~signature_kind ~proof_cache_db) - block - in - (* TODO: the delta transition chain proof is incorrect (same behavior the daemon used to have, but we should probably fix this?) *) - Mina_block.Validated.unsafe_of_trusted_block - ~delta_block_chain_proof:(Mina_stdlib.Nonempty_list.singleton parent_hash) - (`This_block_is_trusted_to_be_safe cached_block) + (* TODO: consider using a more specific error *) + let error = `Not_found (`Transition hash) in + let%bind.Result transition_data = get_transition_do t hash in + Transition.to_validated_block ~signature_kind ~proof_cache_db ~state_hash:hash + transition_data + |> Result.map_error ~f:(fun _ -> error) let get_arcs t hash = get t.db ~key:(Arcs hash) ~error:(`Not_found (`Arcs hash)) @@ -507,10 +619,11 @@ let rec crawl_successors ?max_depth ~signature_kind ~proof_cache_db ~init ~f t deferred_list_result_iter successors ~f:(fun succ_hash -> let%bind transition = Deferred.return - (get_transition ~signature_kind ~proof_cache_db t succ_hash) + (get_transition_data ~signature_kind ~proof_cache_db t succ_hash) in let%bind init' = - Deferred.map (f init transition) + Deferred.map + (f ~state_hash:succ_hash init transition) ~f:(Result.map_error ~f:(fun err -> `Crawl_error err)) in crawl_successors ~signature_kind ~proof_cache_db diff --git a/src/lib/transition_frontier/persistent_frontier/database.mli b/src/lib/transition_frontier/persistent_frontier/database.mli index 70a7affcc996..0ebf4a31c602 100644 --- a/src/lib/transition_frontier/persistent_frontier/database.mli +++ b/src/lib/transition_frontier/persistent_frontier/database.mli @@ -45,12 +45,16 @@ module Error : sig val message : t -> string end -val create : logger:Logger.t -> directory:string -> t +val create : + logger:Logger.t -> directory:string -> root_history_capacity:int -> t + +val root_history_capacity : t -> int val close : t -> unit val check : - t + ?check_arcs:bool + -> t -> genesis_state_hash:State_hash.t -> ( Frozen_ledger_hash.t , [> `Not_initialized @@ -69,7 +73,7 @@ val check : | `Raised of Core_kernel.Error.t ] ] ) Result.t -val initialize : t -> root_data:Root_data.Limited.t -> unit +val initialize : t -> root_data:Root_data.t -> unit val find_arcs_and_root : t @@ -81,13 +85,16 @@ val find_arcs_and_root : val add : arcs_cache:State_hash.t list State_hash.Table.t - -> transition:Mina_block.Validated.t + -> state_hash:State_hash.t + -> transition_data:Block_data.Full.t -> batch_t -> unit val move_root : old_root_hash:State_hash.t - -> new_root:Root_data.Limited.Stable.Latest.t + -> old_root_history:State_hash.t list + -> root_history_capacity:int + -> new_root:Root_data.t -> garbage:State_hash.t list -> batch_t -> unit @@ -101,6 +108,14 @@ val get_transition : , [> `Not_found of [> `Transition of State_hash.t ] ] ) Result.t +val get_root_history : t -> State_hash.t list + +val set_transition : + state_hash:State_hash.t + -> transition_data:Block_data.Full.t + -> batch_t + -> unit + val get_arcs : t -> State_hash.t @@ -128,7 +143,11 @@ val crawl_successors : -> signature_kind:Mina_signature_kind.t -> proof_cache_db:Proof_cache_tag.cache_db -> init:'a - -> f:('a -> Mina_block.Validated.t -> ('a, 'b) Deferred.Result.t) + -> f: + ( state_hash:State_hash.t + -> 'a + -> (Mina_block.Validated.t, Block_data.Full.t) Either.t + -> ('a, 'b) Deferred.Result.t ) -> t -> State_hash.t -> ( unit diff --git a/src/lib/transition_frontier/persistent_frontier/persistent_frontier.ml b/src/lib/transition_frontier/persistent_frontier/persistent_frontier.ml index f71692001091..7641aa8e0be0 100644 --- a/src/lib/transition_frontier/persistent_frontier/persistent_frontier.ml +++ b/src/lib/transition_frontier/persistent_frontier/persistent_frontier.ml @@ -23,17 +23,13 @@ end exception Invalid_genesis_state_hash of Mina_block.Validated.t -let construct_staged_ledger_at_root ~proof_cache_db - ~(precomputed_values : Precomputed_values.t) ~root_ledger ~root_transition +let construct_staged_ledger_at_root ~(precomputed_values : Precomputed_values.t) + ~root_ledger ~root_protocol_state ~(root : Root_data.Minimal.Stable.Latest.t) ~protocol_states ~logger ~signature_kind = - let blockchain_state = - root_transition |> Mina_block.Validated.forget |> With_hash.data - |> Mina_block.header |> Mina_block.Header.protocol_state - |> Protocol_state.blockchain_state - in - let pending_coinbases, scan_state_unwrapped = - Root_data.Minimal.Stable.Latest.(pending_coinbase root, scan_state root) + let blockchain_state = Protocol_state.blockchain_state root_protocol_state in + let pending_coinbases, scan_state = + Root_data.Minimal.(pending_coinbase root, scan_state root) in let protocol_states_map = List.fold protocol_states ~init:State_hash.Map.empty @@ -61,10 +57,6 @@ let construct_staged_ledger_at_root ~proof_cache_db let staged_ledger_hash = Blockchain_state.staged_ledger_hash blockchain_state in - let scan_state = - Staged_ledger.Scan_state.write_all_proofs_to_disk ~signature_kind - ~proof_cache_db scan_state_unwrapped - in Staged_ledger.of_scan_state_pending_coinbases_and_snarked_ledger_unchecked ~snarked_local_state:local_state ~snarked_ledger:mask ~scan_state ~constraint_constants:precomputed_values.constraint_constants ~logger @@ -85,6 +77,7 @@ and Factory_type : sig ; verifier : Verifier.t ; time_controller : Block_time.Controller.t ; signature_kind : Mina_signature_kind.t + ; root_history_capacity : int ; mutable instance : Instance_type.t option } end = @@ -99,6 +92,7 @@ module Instance = struct let create factory = let db = Database.create ~logger:factory.logger ~directory:factory.directory + ~root_history_capacity:factory.root_history_capacity in { db; sync = None; factory } @@ -151,16 +145,42 @@ module Instance = struct let factory { factory; _ } = factory - let check_database t = Database.check t.db + let check_database ?check_arcs t = Database.check ?check_arcs t.db let get_root_hash t = Database.get_root_hash t.db |> Result.map_error ~f:Database.Error.message let get_root_transition ~signature_kind ~proof_cache_db t = let open Result.Let_syntax in - Database.get_root_hash t.db - >>= Database.get_transition t.db ~signature_kind ~proof_cache_db - |> Result.map_error ~f:Database.Error.message + let%bind root = + Database.get_root t.db |> Result.map_error ~f:Database.Error.message + in + let root_hash = Root_data.Minimal.state_hash root in + match Root_data.Minimal.block_data_opt root with + | None -> + Database.get_transition t.db ~signature_kind ~proof_cache_db root_hash + |> Result.map_error ~f:Database.Error.message + | Some { block_tag; delta_block_chain_proof; _ } -> + let%map block_stable = + State_hash.File_storage.read + (module Mina_block.Stable.Latest) + block_tag + (* TODO consider using a more specific error *) + |> Result.map_error ~f:(fun e -> + Error.(tag ~tag:"get_root_transition" e |> to_string_mach) ) + in + let block = + Mina_block.write_all_proofs_to_disk ~signature_kind ~proof_cache_db + block_stable + in + Mina_block.Validated.unsafe_of_trusted_block ~delta_block_chain_proof + (`This_block_is_trusted_to_be_safe + { With_hash.data = block + ; hash = + { State_hash.State_hashes.state_hash = root_hash + ; state_body_hash = None + } + } ) let fast_forward t target_root : (unit, [> `Failure of string | `Bootstrap_required ]) Result.t = @@ -192,7 +212,7 @@ module Instance = struct let downgrade_transition transition genesis_state_hash : ( Mina_block.almost_valid_block - , [ `Invalid_genesis_protocol_state ] ) + , [> `Invalid_genesis_protocol_state ] ) Result.t = (* we explicitly re-validate the genesis protocol state here to prevent X-version bugs *) transition |> Mina_block.Validated.remember @@ -217,15 +237,11 @@ module Instance = struct [%log internal] "Notify_frontier_extensions_done" ; Result.return result - let load_transition ~root_genesis_state_hash ~logger ~precomputed_values t - ~parent transition = + let load_transition_old_format ~root_genesis_state_hash ~logger + ~precomputed_values ~verifier ~parent (transition : Mina_block.Validated.t) + = let%bind.Deferred.Result transition = - match downgrade_transition transition root_genesis_state_hash with - | Ok t -> - Deferred.Result.return t - | Error `Invalid_genesis_protocol_state -> - Error (`Fatal_error (Invalid_genesis_state_hash transition)) - |> Deferred.return + downgrade_transition transition root_genesis_state_hash |> Deferred.return in let state_hash = (With_hash.hash @@ Mina_block.Validation.block_with_hash transition) @@ -243,12 +259,49 @@ module Instance = struct (* we're loading transitions from persistent storage, don't assign a timestamp *) - let transition_receipt_time = None in - Breadcrumb.build ~skip_staged_ledger_verification:`All - ~logger:t.factory.logger ~precomputed_values ~verifier:t.factory.verifier - ~trust_system:(Trust_system.null ()) ~parent ~transition - ~get_completed_work:(Fn.const None) ~sender:None ~transition_receipt_time - () + Breadcrumb.build ~skip_staged_ledger_verification:`All ~logger + ~precomputed_values ~verifier ~trust_system:(Trust_system.null ()) ~parent + ~transition ~get_completed_work:(Fn.const None) ~sender:None + ~transition_receipt_time:None () + + let load_transition_new_format ~state_hash ~root_genesis_state_hash ~logger + ~precomputed_values ~parent (block_data : Block_data.Full.t) = + let hashes = + { State_hash.State_hashes.state_hash; state_body_hash = None } + in + let%bind.Deferred.Result _ = + Validation.wrap_header + { With_hash.hash = hashes; data = block_data.header } + |> Validation.validate_genesis_protocol_state + ~genesis_state_hash:root_genesis_state_hash + |> Deferred.return + in + Internal_tracing.with_state_hash state_hash + @@ fun () -> + [%log internal] "@block_metadata" + ~metadata: + [ ( "blockchain_length" + , Mina_numbers.Length.to_yojson + @@ Mina_block.Header.blockchain_length block_data.header ) + ] ; + [%log internal] "Loaded_transition_from_storage" ; + Breadcrumb.of_block_data ~logger + ~constraint_constants: + precomputed_values.Precomputed_values.constraint_constants + ~parent_staged_ledger:(Breadcrumb.staged_ledger parent) + ~state_hash block_data + |> Deferred.Result.map_error ~f:(fun e -> + `Invalid_staged_ledger_diff + (Staged_ledger.Staged_ledger_error.to_error e) ) + + let load_transition ~root_genesis_state_hash ~logger ~precomputed_values + ~verifier ~parent ~state_hash = function + | Either.First old -> + load_transition_old_format ~root_genesis_state_hash ~logger + ~precomputed_values ~parent ~verifier old + | Second new_ -> + load_transition_new_format ~state_hash ~root_genesis_state_hash ~logger + ~precomputed_values ~parent new_ let set_best_tip ~logger ~frontier ~extensions ~ignore_consensus_local_state ~root_ledger best_tip_hash = @@ -257,38 +310,73 @@ module Instance = struct let load_full_frontier t ~context:(module Context : CONTEXT) ~root_ledger ~consensus_local_state ~max_length ~ignore_consensus_local_state - ~persistent_root_instance ?max_frontier_depth () = + ~persistent_root_instance ?max_frontier_depth ?retain_application_data () + = let open Context in let open Deferred.Result.Let_syntax in let%bind () = Deferred.return (assert_no_sync t) in (* read basic information from the database *) - let%bind root, root_transition, best_tip, protocol_states, root_hash = + let%bind ( root + , best_tip + , protocol_states + , root_hash + , { block_tag = root_block_tag + ; protocol_state = root_protocol_state + ; delta_block_chain_proof = root_delta_block_chain_proof + } ) = (let open Result.Let_syntax in let%bind root = Database.get_root t.db in - let root_hash = Root_data.Minimal.Stable.Latest.hash root in - let%bind root_transition = - Database.get_transition t.db ~signature_kind ~proof_cache_db root_hash + let root_hash = Root_data.Minimal.state_hash root in + let%bind root_block_data = + match Root_data.Minimal.block_data_opt root with + | Some block_data -> + Result.return block_data + | None -> + let%map root_transition = + Database.get_transition t.db ~signature_kind ~proof_cache_db + root_hash + in + let block = + Mina_block.Validated.forget root_transition + |> With_hash.data |> Mina_block.read_all_proofs_from_disk + in + (* We're initializing frontier, so there shouldn't be any data preserved at the + state hash's multi-key file storage, and root block won't be validated, so there won't + be an overwrite *) + let block_tag = + State_hash.File_storage.write_values_exn root_hash + ~f:(fun writer -> + State_hash.File_storage.write_value writer + (module Mina_block.Stable.Latest) + block ) + in + let protocol_state = + Mina_block.Validated.header root_transition + |> Mina_block.Header.protocol_state + in + let delta_block_chain_proof = + Mina_block.Validated.delta_block_chain_proof root_transition + in + { Block_data.block_tag; protocol_state; delta_block_chain_proof } in let%bind best_tip = Database.get_best_tip t.db in let%map protocol_states = Database.get_protocol_states_for_root_scan_state t.db in - (root, root_transition, best_tip, protocol_states, root_hash)) + (root, best_tip, protocol_states, root_hash, root_block_data)) |> Result.map_error ~f:(fun err -> `Failure (Database.Error.not_found_message err) ) |> Deferred.return in let root_genesis_state_hash = - root_transition |> Mina_block.Validated.forget |> With_hash.data - |> Mina_block.header |> Mina_block.Header.protocol_state - |> Protocol_state.genesis_state_hash + Protocol_state.genesis_state_hash root_protocol_state in (* construct the root staged ledger in memory *) let%bind root_staged_ledger = let open Deferred.Let_syntax in match%map - construct_staged_ledger_at_root ~proof_cache_db ~precomputed_values - ~root_ledger ~root_transition ~root ~protocol_states + construct_staged_ledger_at_root ~precomputed_values ~root_ledger + ~root_protocol_state ~root ~protocol_states ~signature_kind:t.factory.signature_kind ~logger:t.factory.logger with | Error err -> @@ -296,17 +384,24 @@ module Instance = struct | Ok staged_ledger -> Ok staged_ledger in + let root_state_hash = Root_data.Minimal.state_hash root in (* initialize the new in memory frontier and extensions *) let frontier = Full_frontier.create ~context:(module Context) ~time_controller:t.factory.time_controller + ~staged_ledger:root_staged_ledger ~root_data: - { transition = root_transition - ; staged_ledger = root_staged_ledger - ; protocol_states = + { state_hash = root_state_hash + ; scan_state = Staged_ledger.scan_state root_staged_ledger + ; pending_coinbase = + Staged_ledger.pending_coinbase_collection root_staged_ledger + ; protocol_states_for_scan_state = List.map protocol_states ~f:(With_hash.of_data ~hash_data:Protocol_state.hashes) + ; block_tag = root_block_tag + ; delta_block_chain_proof = root_delta_block_chain_proof + ; protocol_state = root_protocol_state } ~root_ledger:(Root_ledger.as_unmasked root_ledger) ~consensus_local_state ~max_length ~persistent_root_instance @@ -316,15 +411,17 @@ module Instance = struct (Extensions.create ~logger:t.factory.logger frontier) ~f:Result.return in - let visit parent transition = + let visit ~state_hash parent transition = let%bind breadcrumb = - load_transition ~root_genesis_state_hash ~logger ~precomputed_values t - ~parent transition + load_transition ~state_hash ~root_genesis_state_hash + ~logger:t.factory.logger ~precomputed_values ~parent + ~verifier:t.factory.verifier transition in let%map () = apply_diff ~logger ~frontier ~extensions ~ignore_consensus_local_state ~root_ledger (E (New_node (Full breadcrumb))) in + Full_frontier.lighten ?retain_application_data frontier state_hash ; [%log internal] "Breadcrumb_integrated" ; breadcrumb in @@ -342,6 +439,9 @@ module Instance = struct match err with | `Fatal_error exn -> "fatal error -- " ^ Exn.to_string exn + | `Invalid_genesis_protocol_state -> + "loaded block doesn't correspond to the genesis protocol \ + state" | `Invalid_staged_ledger_diff err | `Invalid_staged_ledger_hash err -> "staged ledger diff application failed -- " @@ -358,12 +458,14 @@ end type t = Factory_type.t -let create ~logger ~verifier ~time_controller ~directory ~signature_kind = +let create ~logger ~verifier ~time_controller ~directory ~signature_kind + ~root_history_capacity = { logger ; verifier ; time_controller ; directory ; signature_kind + ; root_history_capacity ; instance = None } @@ -384,15 +486,9 @@ let with_instance_exn t ~f = x let reset_database_exn t ~root_data ~genesis_state_hash = - let open Root_data.Limited in - let open Deferred.Let_syntax in - let root_transition = transition root_data in + let root_state_hash = root_data.Root_data.state_hash in [%log' info t.logger] - ~metadata: - [ ( "state_hash" - , State_hash.to_yojson - @@ Mina_block.Validated.state_hash root_transition ) - ] + ~metadata:[ ("state_hash", State_hash.to_yojson root_state_hash) ] "Resetting transition frontier database to new root" ; let%bind () = destroy_database_exn t in with_instance_exn t ~f:(fun instance -> diff --git a/src/lib/transition_frontier/persistent_frontier/worker.ml b/src/lib/transition_frontier/persistent_frontier/worker.ml index cd54885e956b..67e6b9ef1516 100644 --- a/src/lib/transition_frontier/persistent_frontier/worker.ml +++ b/src/lib/transition_frontier/persistent_frontier/worker.ml @@ -34,13 +34,14 @@ module Worker = struct (* nothing to close *) let close _ = Deferred.unit - let apply_diff (type mutant) ~old_root_hash ~arcs_cache - (diff : mutant Diff.Lite.t) : Database.batch_t -> unit = + let apply_diff (type mutant) ~old_root_hash ~arcs_cache ~root_history_capacity + ~old_root_history (diff : mutant Diff.Lite.t) : Database.batch_t -> unit = match diff with - | New_node (Lite transition) -> - Database.add ~arcs_cache ~transition + | New_node (Lite (state_hash, transition_data)) -> + Database.add ~arcs_cache ~state_hash ~transition_data | Root_transitioned { new_root; garbage = Lite garbage; _ } -> - Database.move_root ~old_root_hash ~new_root ~garbage + Database.move_root ~old_root_hash ~old_root_history + ~root_history_capacity ~new_root ~garbage | Best_tip_changed best_tip_hash -> Database.set_best_tip best_tip_hash @@ -67,8 +68,7 @@ module Worker = struct List.drop_last root_transition_diffs |> Option.value ~default:[] |> List.bind ~f:(fun { new_root; garbage = Lite garbage; _ } -> - (Root_data.Limited.Stable.Latest.hashes new_root).state_hash - :: garbage ) + new_root.state_hash :: garbage ) in let total_root_transition_diff = Option.map final_root_transition_diff @@ -87,17 +87,17 @@ module Worker = struct let apply_funcs = let state_hashes = List.filter_map input ~f:(function - | E (New_node (Lite transition)) -> - Mina_block.Validated.state_hash transition |> Option.some + | E (New_node (Lite (state_hash, _))) -> + Option.some state_hash | _ -> None ) |> State_hash.Set.of_list in let parent_hashes = List.filter_map input ~f:(function - | E (New_node (Lite transition)) -> + | E (New_node (Lite (_, transition))) -> let parent_hash = - Mina_block.Validated.header transition + transition.Block_data.Full.Stable.Latest.header |> Header.protocol_state |> Mina_state.Protocol_state.previous_state_hash in @@ -110,8 +110,11 @@ module Worker = struct let%map.Result old_root_hash = Database.find_arcs_and_root t.db ~arcs_cache ~parent_hashes in + let old_root_history = Database.get_root_history t.db in List.map diffs_to_apply ~f:(fun (Diff.Lite.E.E diff) -> - apply_diff ~old_root_hash ~arcs_cache diff ) + apply_diff + ~root_history_capacity:(Database.root_history_capacity t.db) + ~old_root_hash ~arcs_cache ~old_root_history diff ) in let handle_emitted_proof = function | { Diff.Root_transition.just_emitted_a_proof = true; _ } -> diff --git a/src/lib/transition_frontier/transition_frontier.ml b/src/lib/transition_frontier/transition_frontier.ml index bf4c3b1262d0..3c2311376122 100644 --- a/src/lib/transition_frontier/transition_frontier.ml +++ b/src/lib/transition_frontier/transition_frontier.ml @@ -82,26 +82,34 @@ type Structured_log_events.t += Persisted_frontier_dropped [@@deriving register_event { msg = "Persistent frontier dropped" }] let genesis_root_data ~precomputed_values = - let transition = - Mina_block.Validated.lift @@ Mina_block.genesis ~precomputed_values + let transition, block_tag = Mina_block.genesis ~precomputed_values in + let state_hash = Mina_block.Validated.state_hash transition in + let protocol_state = + Mina_block.Validated.header transition |> Mina_block.Header.protocol_state in let constraint_constants = precomputed_values.constraint_constants in let scan_state = Staged_ledger.Scan_state.empty ~constraint_constants () in (*if scan state is empty the protocol states required is also empty*) - let protocol_states = [] in let pending_coinbase = Or_error.ok_exn (Pending_coinbase.create ~depth:constraint_constants.pending_coinbase_depth () ) in - Root_data.Limited.create ~transition ~scan_state ~pending_coinbase - ~protocol_states + { Root_data.block_tag + ; state_hash + ; scan_state + ; pending_coinbase + ; protocol_states_for_scan_state = [] + ; protocol_state + ; delta_block_chain_proof = + Mina_block.Validated.delta_block_chain_proof transition + } let load_from_persistence_and_start ~context:(module Context : CONTEXT) ~verifier ~consensus_local_state ~max_length ~persistent_root ~persistent_root_instance ~persistent_frontier ~persistent_frontier_instance ~catchup_mode ?max_frontier_depth ?(set_best_tip = true) - ignore_consensus_local_state = + ?retain_application_data ignore_consensus_local_state = let open Context in let open Deferred.Result.Let_syntax in let root_identifier = @@ -143,7 +151,8 @@ let load_from_persistence_and_start ~context:(module Context : CONTEXT) ~root_ledger: (Persistent_root.Instance.snarked_ledger persistent_root_instance) ~consensus_local_state ~ignore_consensus_local_state - ~persistent_root_instance ?max_frontier_depth () + ~persistent_root_instance ?max_frontier_depth ?retain_application_data + () with | Error `Sync_cannot_be_running -> Error (`Failure "sync job is already running on persistent frontier") @@ -207,6 +216,8 @@ let rec load_with_max_length : -> persistent_frontier:Persistent_frontier.t -> catchup_mode:[ `Super ] -> ?set_best_tip:bool + -> ?retain_application_data:bool + -> ?check_arcs:bool -> unit -> ( t , [> `Bootstrap_required @@ -217,7 +228,7 @@ let rec load_with_max_length : fun ~context:(module Context : CONTEXT) ~max_length ?(retry_with_fresh_db = true) ?max_frontier_depth ~verifier ~consensus_local_state ~persistent_root ~persistent_frontier ~catchup_mode - ?set_best_tip () -> + ?set_best_tip ?retain_application_data ?check_arcs () -> let open Context in let open Deferred.Let_syntax in (* TODO: #3053 *) @@ -249,7 +260,7 @@ let rec load_with_max_length : ~verifier ~consensus_local_state ~max_length ~persistent_root ~persistent_root_instance ~catchup_mode ~persistent_frontier ~persistent_frontier_instance ?max_frontier_depth ?set_best_tip - ignore_consensus_local_state + ?retain_application_data ignore_consensus_local_state with | Ok _ as result -> [%str_log trace] Persisted_frontier_loaded ; @@ -310,7 +321,7 @@ let rec load_with_max_length : match time ~label:"Persistent_frontier.Instance.check_database" ~logger @@ fun () -> - Persistent_frontier.Instance.check_database + Persistent_frontier.Instance.check_database ?check_arcs ~genesis_state_hash: (State_hash.With_state_hashes.state_hash precomputed_values.protocol_state_with_hashes ) @@ -354,7 +365,8 @@ let rec load_with_max_length : load_with_max_length ~context:(module Context) ~max_length ~verifier ~consensus_local_state ~persistent_root - ~persistent_frontier ~retry_with_fresh_db:false ~catchup_mode () + ~persistent_frontier ~retry_with_fresh_db:false ~catchup_mode + ?retain_application_data ?check_arcs () >>| Result.map_error ~f:(function | `Persistent_frontier_malformed -> `Failure @@ -382,8 +394,9 @@ let rec load_with_max_length : return res ) let load ?(retry_with_fresh_db = true) ?max_frontier_depth ?set_best_tip - ~context:(module Context : CONTEXT) ~verifier ~consensus_local_state - ~persistent_root ~persistent_frontier ~catchup_mode () = + ?retain_application_data ?check_arcs ~context:(module Context : CONTEXT) + ~verifier ~consensus_local_state ~persistent_root ~persistent_frontier + ~catchup_mode () = let open Context in O1trace.thread "transition_frontier_load" (fun () -> let max_length = @@ -394,7 +407,7 @@ let load ?(retry_with_fresh_db = true) ?max_frontier_depth ?set_best_tip ~context:(module Context) ~max_length ~retry_with_fresh_db ?max_frontier_depth ~verifier ~consensus_local_state ~persistent_root ~persistent_frontier - ~catchup_mode ?set_best_tip () ) + ~catchup_mode ?set_best_tip ?retain_application_data ?check_arcs () ) (* The persistent root and persistent frontier as safe to ignore here * because their lifecycle is longer than the transition frontier's *) @@ -421,6 +434,10 @@ let close ~loc Persistent_root.Instance.close persistent_root_instance ; Ivar.fill_if_empty closed () +let with_persistent_frontier_instance_exn t ~f = + if Option.is_none (Ivar.peek t.closed) then f t.persistent_frontier_instance + else failwith "Transition frontier is closed" + let closed t = Ivar.read t.closed let persistent_root { persistent_root; _ } = persistent_root @@ -449,10 +466,10 @@ let add_breadcrumb_exn t breadcrumb = [ ( "state_hash" , State_hash.to_yojson (Breadcrumb.state_hash (Full_frontier.best_tip t.full_frontier)) ) - ; ( "n" - , `Int (List.length @@ Full_frontier.all_breadcrumbs t.full_frontier) ) + ; ("n", `Int (Full_frontier.size t.full_frontier)) ] "PRE: ($state_hash, $n)" ; + let user_cmd_hashes = Breadcrumb.command_hashes breadcrumb in [%str_log' trace t.logger] (Applying_diffs { diffs = List.map ~f:Diff.Full.E.to_yojson diffs }) ; [%log internal] "Apply_catchup_state_diffs" ; @@ -475,23 +492,15 @@ let add_breadcrumb_exn t breadcrumb = [ ( "state_hash" , State_hash.to_yojson (Breadcrumb.state_hash @@ Full_frontier.best_tip t.full_frontier) ) - ; ( "n" - , `Int (List.length @@ Full_frontier.all_breadcrumbs t.full_frontier) ) + ; ("n", `Int (Full_frontier.size t.full_frontier)) ] "POST: ($state_hash, $n)" ; - let user_cmds = - Mina_block.Validated.valid_commands - @@ Breadcrumb.validated_transition breadcrumb - in - let tx_hash_json command = - User_command.forget_check command - |> Mina_transaction.Transaction_hash.hash_command_with_hashes - |> Mina_transaction.Transaction_hash.to_yojson - in [%str_log' trace t.logger] Added_breadcrumb_user_commands ~metadata: [ ( "user_commands" - , `List (List.map user_cmds ~f:(With_status.to_yojson tx_hash_json)) ) + , `List + (List.map user_cmd_hashes + ~f:Mina_transaction.Transaction_hash.to_yojson ) ) ; ("state_hash", State_hash.to_yojson (Breadcrumb.state_hash breadcrumb)) ] ; let lite_diffs = @@ -516,7 +525,9 @@ let add_breadcrumb_exn t breadcrumb = Extensions.notify t.extensions ~logger ~frontier:t.full_frontier ~diffs_with_mutants in + (* TODO: Drop validated transition from the block *) [%log internal] "Notify_frontier_extensions_done" ; + Full_frontier.lighten t.full_frontier state_hash ; [%log internal] "Add_breadcrumb_to_frontier_done" (* proxy full frontier functions *) @@ -531,12 +542,12 @@ include struct let all_breadcrumbs = proxy1 all_breadcrumbs + let all_state_hashes = proxy1 all_state_hashes + let visualize ~filename = proxy1 (visualize ~filename) let visualize_to_string = proxy1 visualize_to_string - let iter = proxy1 iter - let successors = proxy1 successors let hash_path = proxy1 hash_path @@ -572,21 +583,36 @@ include struct proxy1 protocol_states_for_root_scan_state end +let protocol_states_of_scan_state ~frontier scan_state = + Staged_ledger.Scan_state.required_state_hashes scan_state + |> State_hash.Set.to_list + |> List.fold_until ~init:(Some []) + ~f:(fun acc hash -> + match + Option.map2 (find_protocol_state frontier hash) acc ~f:List.cons + with + | None -> + Stop None + | Some acc' -> + Continue (Some acc') ) + ~finish:Fn.id + +let staged_ledger_aux_and_pending_coinbases frontier state_hash = + let%bind.Option breadcrumb = find frontier state_hash in + let scan_state_protocol_states = protocol_states_of_scan_state ~frontier in + let%map.Option res = + Breadcrumb.staged_ledger_aux_and_pending_coinbases + ~scan_state_protocol_states breadcrumb + in + let staged_ledger_hash = Breadcrumb.staged_ledger_hash breadcrumb in + (res, staged_ledger_hash) + module For_tests = struct open Signature_lib module Ledger_transfer = Mina_ledger.Ledger_transfer.Make (Mina_ledger.Ledger) (Mina_ledger.Ledger.Db) - open Full_frontier.For_tests - - let proxy2 f { full_frontier = x; _ } { full_frontier = y; _ } = f x y - - let equal = proxy2 equal - - let rec deferred_rose_tree_iter (Mina_stdlib.Rose_tree.T (root, trees)) ~f = - let%bind () = f root in - Deferred.List.iter trees ~f:(deferred_rose_tree_iter ~f) (* a helper quickcheck generator which always returns the genesis breadcrumb *) let gen_genesis_breadcrumb ?(logger = Logger.null ()) ~verifier @@ -594,8 +620,8 @@ module For_tests = struct let constraint_constants = precomputed_values.constraint_constants in Quickcheck.Generator.create (fun ~size:_ ~random:_ -> let transition_receipt_time = Some (Time.now ()) in - let genesis_transition = - Mina_block.Validated.lift (Mina_block.genesis ~precomputed_values) + let genesis_transition, genesis_block_tag = + Mina_block.genesis ~precomputed_values in let genesis_ledger = Lazy.force (Precomputed_values.genesis_ledger precomputed_values) @@ -628,10 +654,11 @@ module For_tests = struct in Breadcrumb.create ~validated_transition:genesis_transition ~staged_ledger:genesis_staged_ledger ~just_emitted_a_proof:false - ~transition_receipt_time ) + ~transition_receipt_time ~accounts_created:[] + ~block_tag:genesis_block_tag ) let gen_persistence ?(logger = Logger.null ()) ~verifier - ~(precomputed_values : Precomputed_values.t) () = + ~(precomputed_values : Precomputed_values.t) ~max_length () = let open Core in let root_dir = "/tmp/coda_unit_test" in Quickcheck.Generator.create (fun ~size:_ ~random:_ -> @@ -666,6 +693,7 @@ module For_tests = struct Persistent_frontier.create ~logger ~verifier ~time_controller:(Block_time.Controller.basic ~logger) ~directory:frontier_dir ~signature_kind:Testnet + ~root_history_capacity:(max_length * 2) in Gc.Expert.add_finalizer_exn persistent_root clean_temp_dirs ; Gc.Expert.add_finalizer_exn persistent_frontier (fun x -> @@ -734,7 +762,7 @@ module For_tests = struct in let create_root, root_ledger_accounts = create_root_and_accounts in (* TODO: ensure that rose_tree cannot be longer than k *) - let%bind root, branches, protocol_states = + let%bind root, branches, protocol_states_for_scan_state = let%bind root, protocol_states = gen_root_breadcrumb in let%map (Mina_stdlib.Rose_tree.T (root, branches)) = Quickcheck.Generator.with_size ~size @@ -747,16 +775,19 @@ module For_tests = struct (root, branches, protocol_states) in let root_data = - Root_data.Limited.create - ~transition:(Breadcrumb.validated_transition root) - ~scan_state:(Breadcrumb.staged_ledger root |> Staged_ledger.scan_state) - ~pending_coinbase: - ( Breadcrumb.staged_ledger root - |> Staged_ledger.pending_coinbase_collection ) - ~protocol_states + { Root_data.block_tag = Breadcrumb.block_tag root + ; state_hash = Breadcrumb.state_hash root + ; scan_state = Breadcrumb.staged_ledger root |> Staged_ledger.scan_state + ; pending_coinbase = + Breadcrumb.staged_ledger root + |> Staged_ledger.pending_coinbase_collection + ; protocol_states_for_scan_state + ; protocol_state = Breadcrumb.protocol_state root + ; delta_block_chain_proof = Breadcrumb.delta_block_chain_proof root + } in let%map persistent_root, persistent_frontier = - gen_persistence ~logger ~precomputed_values ~verifier () + gen_persistence ~logger ~precomputed_values ~verifier ~max_length () in Async.Thread_safe.block_on_async_exn (fun () -> Persistent_frontier.reset_database_exn persistent_frontier ~root_data @@ -765,9 +796,7 @@ module For_tests = struct precomputed_values.protocol_state_with_hashes ) ) ; Async.Thread_safe.block_on_async_exn (fun () -> Persistent_root.reset_factory_root_exn persistent_root ~create_root - ~root_state_hash: - ( Root_data.Limited.transition root_data - |> Mina_block.Validated.state_hash ) ) ; + ~root_state_hash:root_data.state_hash ) ; let frontier_result = Async.Thread_safe.block_on_async_exn (fun () -> load_with_max_length ~max_length ~retry_with_fresh_db:false @@ -790,8 +819,10 @@ module For_tests = struct frontier in Async.Thread_safe.block_on_async_exn (fun () -> - Deferred.List.iter ~how:`Sequential branches - ~f:(deferred_rose_tree_iter ~f:(add_breadcrumb_exn frontier)) ) ; + Deferred.List.iter branches ~how:`Sequential + ~f: + (Mina_stdlib.Rose_tree.Deferred.iter + ~f:(add_breadcrumb_exn frontier) ) ) ; Core.Gc.Expert.add_finalizer_exn consensus_local_state (fun consensus_local_state -> Consensus.Data.Local_state.( @@ -800,7 +831,12 @@ module For_tests = struct Consensus.Data.Local_state.( Snapshot.Ledger_snapshot.close @@ next_epoch_ledger consensus_local_state) ) ; - frontier + let all_breadcrumbs = ref [] in + List.iter branches + ~f: + (Mina_stdlib.Rose_tree.iter ~f:(fun b -> + all_breadcrumbs := b :: !all_breadcrumbs ) ) ; + (frontier, !all_breadcrumbs) let gen_with_branch ?logger ~verifier ?trust_system ?consensus_local_state ~precomputed_values @@ -810,7 +846,7 @@ module For_tests = struct ?gen_root_breadcrumb ?(get_branch_root = root) ~max_length ~frontier_size ~branch_size () = let open Quickcheck.Generator.Let_syntax in - let%bind frontier = + let%bind frontier, _ = gen ?logger ~verifier ?trust_system ?consensus_local_state ~precomputed_values ?gen_root_breadcrumb ~create_root_and_accounts ~max_length ~size:frontier_size () diff --git a/src/lib/transition_frontier/transition_frontier.mli b/src/lib/transition_frontier/transition_frontier.mli index 7a818656797d..917a2756265d 100644 --- a/src/lib/transition_frontier/transition_frontier.mli +++ b/src/lib/transition_frontier/transition_frontier.mli @@ -72,6 +72,8 @@ val load : ?retry_with_fresh_db:bool -> ?max_frontier_depth:int -> ?set_best_tip:bool + -> ?retain_application_data:bool + -> ?check_arcs:bool -> context:(module CONTEXT) -> verifier:Verifier.t -> consensus_local_state:Consensus.Data.Local_state.t @@ -88,6 +90,9 @@ val load : val close : loc:string -> t -> unit Deferred.t +val with_persistent_frontier_instance_exn : + t -> f:(Persistent_frontier.Instance.t -> 'a) -> 'a + val closed : t -> unit Deferred.t val add_breadcrumb_exn : t -> Breadcrumb.t -> unit Deferred.t @@ -118,12 +123,17 @@ val rejected_blocks : val validated_blocks : (State_hash.t * Network_peer.Envelope.Sender.t * Block_time.t) Core.Queue.t +val staged_ledger_aux_and_pending_coinbases : + t + -> State_hash.t + -> ( Network_types.Staged_ledger_aux_and_pending_coinbases.data_tag + * Staged_ledger_hash.t ) + option + module For_tests : sig open Core_kernel open Signature_lib - val equal : t -> t -> bool - val gen_genesis_breadcrumb : ?logger:Logger.t -> verifier:Verifier.t @@ -131,13 +141,6 @@ module For_tests : sig -> unit -> Breadcrumb.t Quickcheck.Generator.t - val gen_persistence : - ?logger:Logger.t - -> verifier:Verifier.t - -> precomputed_values:Precomputed_values.t - -> unit - -> (Persistent_root.t * Persistent_frontier.t) Quickcheck.Generator.t - val gen : ?logger:Logger.t -> verifier:Verifier.t @@ -159,7 +162,7 @@ module For_tests : sig -> max_length:int -> size:int -> unit - -> t Quickcheck.Generator.t + -> (t * Breadcrumb.t list) Quickcheck.Generator.t val gen_with_branch : ?logger:Logger.t diff --git a/src/lib/transition_handler/processor.ml b/src/lib/transition_handler/processor.ml index e46e3fa20cd5..4293ac01fd09 100644 --- a/src/lib/transition_handler/processor.ml +++ b/src/lib/transition_handler/processor.ml @@ -132,8 +132,9 @@ let process_transition ~context:(module Context : CONTEXT) ~trust_system let parent_hash = Protocol_state.previous_state_hash (Header.protocol_state header) in - let root_block = - Transition_frontier.(Breadcrumb.block_with_hash @@ root frontier) + let root_consensus_state = + Transition_frontier.( + Breadcrumb.consensus_state_with_hashes @@ root frontier) in let metadata = [ ("state_hash", State_hash.to_yojson transition_hash) ] in let state_hash = transition_hash in @@ -162,7 +163,7 @@ let process_transition ~context:(module Context : CONTEXT) ~trust_system match Mina_block.Validation.validate_frontier_dependencies ~context:(module Context) - ~root_block ~is_block_in_frontier ~to_header:ident + ~root_consensus_state ~is_block_in_frontier ~to_header:ident (Envelope.Incoming.data env) with | Ok _ | Error `Parent_missing_from_frontier -> @@ -193,8 +194,8 @@ let process_transition ~context:(module Context : CONTEXT) ~trust_system match Mina_block.Validation.validate_frontier_dependencies ~context:(module Context) - ~root_block ~is_block_in_frontier ~to_header:Mina_block.header - initially_validated_transition + ~root_consensus_state ~is_block_in_frontier + ~to_header:Mina_block.header initially_validated_transition with | Ok t -> return (Ok t) @@ -428,17 +429,15 @@ let run ~context:(module Context : CONTEXT) ~verifier ~trust_system () ) | `Local_breadcrumb breadcrumb -> let state_hash = - Transition_frontier.Breadcrumb.validated_transition + Transition_frontier.Breadcrumb.state_hash (Cached.peek breadcrumb) - |> Mina_block.Validated.state_hash in Internal_tracing.with_state_hash state_hash @@ fun () -> [%log internal] "Begin_local_block_processing" ; let transition_time = - Transition_frontier.Breadcrumb.validated_transition + Transition_frontier.Breadcrumb.header (Cached.peek breadcrumb) - |> Mina_block.Validated.header |> Mina_block.Header.protocol_state |> Protocol_state.blockchain_state |> Blockchain_state.timestamp |> Block_time.to_time_exn diff --git a/src/lib/transition_router/transition_router.ml b/src/lib/transition_router/transition_router.ml index cd5ef37d0599..b11c4f0eda35 100644 --- a/src/lib/transition_router/transition_router.ml +++ b/src/lib/transition_router/transition_router.ml @@ -618,6 +618,10 @@ let run ?(sync_local_state = true) ?(cache_exceptions = false) Transition_frontier.Persistent_frontier.create ~logger ~verifier ~time_controller ~directory:persistent_frontier_location ~signature_kind + ~root_history_capacity: + ( 2 + * Transition_frontier.global_max_length + precomputed_values.genesis_constants ) in let persistent_root = Transition_frontier.Persistent_root.create ~logger diff --git a/src/lib/uptime_service/uptime_service.ml b/src/lib/uptime_service/uptime_service.ml index 3f53f185e433..d8c02a290076 100644 --- a/src/lib/uptime_service/uptime_service.ml +++ b/src/lib/uptime_service/uptime_service.ml @@ -152,8 +152,10 @@ let send_uptime_data ~logger ~interruptor ~(submitter_keypair : Keypair.t) ~url let block_base64_of_breadcrumb breadcrumb = let external_transition = - breadcrumb |> Transition_frontier.Breadcrumb.block - |> Mina_block.read_all_proofs_from_disk + breadcrumb |> Transition_frontier.Breadcrumb.block_tag + |> State_hash.File_storage.read (module Mina_block.Stable.Latest) + |> Or_error.tag ~tag:"uptime_service" + |> Or_error.ok_exn in let block_string = Binable.to_string (module Mina_block.Stable.Latest) external_transition @@ -200,10 +202,9 @@ let read_all_proofs_for_work_single_spec = ~f_proof:Ledger_proof.Cached.read_proof_from_disk ~f_witness:Transaction_witness.read_all_proofs_from_disk -let send_block_and_transaction_snark ~logger ~constraint_constants ~interruptor - ~url ~snark_worker ~transition_frontier ~peer_id - ~(submitter_keypair : Keypair.t) ~snark_work_fee ~graphql_control_port - ~built_with_commit_sha = +let send_block_and_transaction_snark ~logger ~interruptor ~url ~snark_worker + ~transition_frontier ~peer_id ~(submitter_keypair : Keypair.t) + ~snark_work_fee ~graphql_control_port ~built_with_commit_sha = match Broadcast_pipe.Reader.peek transition_frontier with | None -> (* expected during daemon boot, so not logging as error *) @@ -220,11 +221,10 @@ let send_block_and_transaction_snark ~logger ~constraint_constants ~interruptor ~prover:(Public_key.compress submitter_keypair.public_key) in let best_tip = Transition_frontier.best_tip tf in - let best_tip_block = Transition_frontier.Breadcrumb.block best_tip in - if - List.is_empty - (Mina_block.transactions ~constraint_constants best_tip_block) - then ( + let best_tip_stats = + Transition_frontier.Breadcrumb.command_stats best_tip + in + if (not best_tip_stats.has_coinbase) && best_tip_stats.total = 0 then ( [%log info] "No transactions in block, sending block without SNARK work to \ uptime service" ; @@ -241,29 +241,28 @@ let send_block_and_transaction_snark ~logger ~constraint_constants ~interruptor send_uptime_data ~logger ~interruptor ~submitter_keypair ~url ~state_hash ~produced:false block_data ) else + let get_state state_hash = + match Transition_frontier.find_protocol_state tf state_hash with + | None -> + Error + (Error.createf + "Could not find state_hash %s in transition frontier for \ + uptime service" + (State_hash.to_base58_check state_hash) ) + | Some protocol_state -> + Ok protocol_state + in let best_tip_staged_ledger = Transition_frontier.Breadcrumb.staged_ledger best_tip in - match - Staged_ledger.all_work_pairs best_tip_staged_ledger - ~get_state:(fun state_hash -> - match Transition_frontier.find_protocol_state tf state_hash with - | None -> - Error - (Error.createf - "Could not find state_hash %s in transition frontier \ - for uptime service" - (State_hash.to_base58_check state_hash) ) - | Some protocol_state -> - Ok protocol_state ) - with - | Error e -> + match Staged_ledger.all_work_pairs best_tip_staged_ledger with + (* | Error e -> [%log error] "Could not get SNARK work from best tip staged ledger for uptime \ service" ~metadata:[ ("error", Error_json.error_to_yojson e) ] ; - Interruptible.return () - | Ok [] -> + Interruptible.return () *) + | [] -> [%log info] "No SNARK jobs available for uptime service, sending just the \ block" ; @@ -281,31 +280,23 @@ let send_block_and_transaction_snark ~logger ~constraint_constants ~interruptor in send_uptime_data ~logger ~interruptor ~submitter_keypair ~url ~state_hash ~produced:false block_data - | Ok job_one_or_twos -> ( + | job_one_or_twos -> ( let transitions = List.concat_map job_one_or_twos ~f:One_or_two.to_list - |> List.filter ~f:(function - | Snark_work_lib.Work.Single.Spec.Transition _ -> - true - | Merge _ -> - false ) + |> List.filter + ~f:Staged_ledger.Scan_state.Available_job.is_transition in let staged_ledger_hash = - Mina_block.header best_tip_block - |> Mina_block.Header.protocol_state + Transition_frontier.Breadcrumb.protocol_state best_tip |> Mina_state.Protocol_state.blockchain_state |> Mina_state.Blockchain_state.staged_ledger_hash in match List.find transitions ~f:(fun transition -> - match transition with - | Snark_work_lib.Work.Single.Spec.Transition ({ target; _ }, _) - -> - Pasta_bindings.Fp.equal target.second_pass_ledger - (Staged_ledger_hash.ledger_hash staged_ledger_hash) - | Merge _ -> - (* unreachable *) - failwith "Expected Transition work, not Merge" ) + Option.equal Frozen_ledger_hash.equal + (Some (Staged_ledger_hash.ledger_hash staged_ledger_hash)) + (Staged_ledger.Scan_state.Available_job + .target_second_pass_ledger transition ) ) with | None -> [%log info] @@ -329,9 +320,13 @@ let send_block_and_transaction_snark ~logger ~constraint_constants ~interruptor | Some single_spec -> ( match%bind make_interruptible - (Uptime_snark_worker.perform_single snark_worker - ( message - , read_all_proofs_for_work_single_spec single_spec ) ) + @@ let%bind.Deferred.Or_error single_spec' = + Staged_ledger.Scan_state.Available_job.single_spec + ~get_state single_spec + |> Deferred.return + in + Uptime_snark_worker.perform_single snark_worker + (message, single_spec') with | Error e -> (* error in submitting to process *) @@ -473,9 +468,9 @@ let start ~logger ~uptime_url ~snark_worker_opt ~constraint_constants "Uptime service will attempt to send a block and SNARK work" ; let snark_work_fee = get_snark_work_fee () in send_block_and_transaction_snark ~logger ~interruptor ~url - ~constraint_constants ~snark_worker ~transition_frontier - ~peer_id ~submitter_keypair ~snark_work_fee - ~graphql_control_port ~built_with_commit_sha + ~snark_worker ~transition_frontier ~peer_id + ~submitter_keypair ~snark_work_fee ~graphql_control_port + ~built_with_commit_sha in match get_next_producer_time_opt () with | None -> diff --git a/src/lib/work_partitioner/combining_result.ml b/src/lib/work_partitioner/combining_result.ml index b117231ad524..4c1c01d20a49 100644 --- a/src/lib/work_partitioner/combining_result.ml +++ b/src/lib/work_partitioner/combining_result.ml @@ -50,7 +50,7 @@ let finalize_two ~submitted_result ~other_spec ~in_pool_result ~submitted_half let merge_single_result ~(submitted_result : - (unit, Ledger_proof.Cached.t) Snark_work_lib.Result.Single.Poly.t ) + (unit, Ledger_proof.t) Snark_work_lib.Result.Single.Poly.t ) ~(submitted_half : submitted_half) (current : t) : merge_outcome = match (current, submitted_half) with | Spec_only { spec = `One spec; sok_message = { fee; prover } }, `One -> diff --git a/src/lib/work_partitioner/combining_result.mli b/src/lib/work_partitioner/combining_result.mli index ef6d4760de3d..cc6b34487f55 100644 --- a/src/lib/work_partitioner/combining_result.mli +++ b/src/lib/work_partitioner/combining_result.mli @@ -45,8 +45,7 @@ type merge_outcome = to combine what we have in pool, [t], with the incoming single result [submitted_result] corresponding to incoming half [submitted_half] *) val merge_single_result : - submitted_result: - (unit, Ledger_proof.Cached.t) Snark_work_lib.Result.Single.Poly.t + submitted_result:(unit, Ledger_proof.t) Snark_work_lib.Result.Single.Poly.t -> submitted_half:submitted_half -> t -> merge_outcome diff --git a/src/lib/work_partitioner/work_partitioner.ml b/src/lib/work_partitioner/work_partitioner.ml index 8156f4f098e4..1a2fd1561c7e 100644 --- a/src/lib/work_partitioner/work_partitioner.ml +++ b/src/lib/work_partitioner/work_partitioner.ml @@ -27,11 +27,9 @@ type t = (Work.Spec.Single.t * Work.Id.Single.t * Mina_base.Sok_message.t) option (** When receving a `Two works from the underlying Work_selector, store one of them here, so we could schedule them to another worker. *) - ; proof_cache_db : Proof_cache_tag.cache_db } let create ~(reassignment_timeout : Time.Span.t) ~(logger : Logger.t) - ~(proof_cache_db : Proof_cache_tag.cache_db) ~(signature_kind : Mina_signature_kind.t) : t = let module T = Transaction_snark.Make (struct let constraint_constants = Genesis_constants.Compiled.constraint_constants @@ -49,7 +47,6 @@ let create ~(reassignment_timeout : Time.Span.t) ~(logger : Logger.t) ; zkapp_jobs_sent_by_partitioner = Sent_zkapp_job_pool.create () ; single_jobs_sent_by_partitioner = Sent_single_job_pool.create () ; tmp_slot = None - ; proof_cache_db } (* TODO: Consider remove all works no longer relevant for current frontier, @@ -157,20 +154,22 @@ let convert_single_work_from_selector ~(partitioner : t) | Transition (input, witness) -> ( match witness.transaction with | Command (Zkapp_command zkapp_command) -> + (* TODO: remove this conversion *) + let zkapp_command = + Mina_base.Zkapp_command.write_all_proofs_to_disk + ~signature_kind:Mina_signature_kind.t_DEPRECATED + ~proof_cache_db:(Proof_cache_tag.create_identity_db ()) + zkapp_command + in (* TODO: we have read from disk followed by write to disk in shared function followed by read from disk again. Should consider refactor this. *) - let witness = Transaction_witness.read_all_proofs_from_disk witness in Snark_worker_shared.extract_zkapp_segment_works ~m:partitioner.transaction_snark ~input ~witness ~zkapp_command |> Result.map ~f: (convert_zkapp_command_from_selector ~partitioner ~job ~pairing) | Command (Signed_command _) | Fee_transfer _ | Coinbase _ -> - let job = - Work.With_job_meta.map - ~f_spec:Work.Spec.Single.read_all_proofs_from_disk job - in Sent_single_job_pool.add_now_exn ~id:pairing ~job ~message: "Id generator generated a repeated Id that happens to be \ @@ -178,10 +177,6 @@ let convert_single_work_from_selector ~(partitioner : t) partitioner.single_jobs_sent_by_partitioner ; Ok (Single job) ) | Merge _ -> - let job = - Work.With_job_meta.map - ~f_spec:Work.Spec.Single.read_all_proofs_from_disk job - in Sent_single_job_pool.add_now_exn ~id:pairing ~job ~message: "Id generator generated a repeated Id that happens to be occupied by \ @@ -208,7 +203,7 @@ let schedule_job_from_partitioner ~(partitioner : t) : (* WARN: this should only be called if [partitioner.tmp_slot] is None *) let consume_job_from_selector ~(partitioner : t) ~(sok_message : Mina_base.Sok_message.t) - ~(instances : Work.Spec.Single.t One_or_two.t) : + ~(instances : Work.Spec.Single.Stable.Latest.t One_or_two.t) : (Work.Spec.Partitioned.Stable.Latest.t, _) Result.t = let pairing_id = Id_generator.next_id partitioner.single_id_gen () in Hashtbl.add_exn partitioner.pairing_pool ~key:pairing_id @@ -227,7 +222,8 @@ let consume_job_from_selector ~(partitioner : t) convert_single_work_from_selector ~partitioner ~single_spec:spec2 ~sok_message ~pairing:pairing2 -type work_from_selector = Work.Spec.Single.t One_or_two.t option Lazy.t +type work_from_selector = + Work.Spec.Single.Stable.Latest.t One_or_two.t option Lazy.t let request_from_selector_and_consume_by_partitioner ~(partitioner : t) ~(work_from_selector : work_from_selector) @@ -252,16 +248,9 @@ type submit_result = let submit_into_combining_result ~submitted_result ~partitioner ~combining_result ~submitted_half = - let submitted_result_cached = - Snark_work_lib.Result.Single.Poly.map ~f_spec:Fn.id - ~f_proof: - (Ledger_proof.Cached.write_proof_to_disk - ~proof_cache_db:partitioner.proof_cache_db ) - submitted_result - in match - Combining_result.merge_single_result - ~submitted_result:submitted_result_cached ~submitted_half combining_result + Combining_result.merge_single_result ~submitted_result ~submitted_half + combining_result with | Pending new_combining_result -> `Pending new_combining_result @@ -289,10 +278,8 @@ let submit_into_combining_result ~submitted_result ~partitioner pool, ignoring" ~metadata: [ ( "spec" - , One_or_two.to_yojson - Work.Spec.Single.( - Fn.compose Stable.Latest.to_yojson read_all_proofs_from_disk) - spec ) + , One_or_two.to_yojson Work.Spec.Single.Stable.Latest.to_yojson spec + ) ; ( "result" , Work.Result.Single.Poly.to_yojson (fun () -> `Null) diff --git a/src/lib/work_partitioner/work_partitioner.mli b/src/lib/work_partitioner/work_partitioner.mli index 1c7c44c03661..5e7d122ed909 100644 --- a/src/lib/work_partitioner/work_partitioner.mli +++ b/src/lib/work_partitioner/work_partitioner.mli @@ -25,12 +25,11 @@ type t val create : reassignment_timeout:Time.Span.t -> logger:Logger.t - -> proof_cache_db:Proof_cache_tag.cache_db -> signature_kind:Mina_signature_kind.t -> t type work_from_selector = - Snark_work_lib.Spec.Single.t One_or_two.t option Lazy.t + Snark_work_lib.Spec.Single.Stable.Latest.t One_or_two.t option Lazy.t (** [request_partitioned_work ~sok_message ~work_from_selector ~partitioner] returns a partitioned job from [partitioner], if there is one available. diff --git a/src/lib/work_selector/inputs.ml b/src/lib/work_selector/inputs.ml index 53866a870f25..768fecb19f15 100644 --- a/src/lib/work_selector/inputs.ml +++ b/src/lib/work_selector/inputs.ml @@ -1,117 +1,116 @@ open Core_kernel -open Currency -module Test_inputs = struct - module Transaction_witness = struct - type t = Int.t +(* module Test_inputs = struct + module Transaction_witness = struct + type t = Int.t - let transaction = Fn.id - end + let transaction = Fn.id + end - module Ledger_hash = Int - module Sparse_ledger = Int + module Ledger_hash = Int + module Sparse_ledger = Int - module Transaction = struct - type t = Int.t + module Transaction = struct + type t = Int.t - let yojson_summary t = `Int t - end + let yojson_summary t = `Int t + end - module Ledger_proof_statement = Fee + module Ledger_proof_statement = Fee - module Transaction_protocol_state = struct - type 'a t = 'a - end + module Transaction_protocol_state = struct + type 'a t = 'a + end - module Ledger_proof = struct - type t = Fee.t [@@deriving hash, compare, sexp] + module Ledger_proof = struct + type t = Fee.t [@@deriving hash, compare, sexp] - module Stable = struct - module Latest = struct - type nonrec t = t - end - end + module Stable = struct + module Latest = struct + type nonrec t = t + end + end - module Cached = struct - type nonrec t = t + module Cached = struct + type nonrec t = t - let read_proof_from_disk = Fn.id - end - end + let read_proof_from_disk = Fn.id + end + end - module Transaction_snark_work = struct - module Checked = struct - type t = Fee.t + module Transaction_snark_work = struct + module Checked = struct + type t = Fee.t - let fee = Fn.id + let fee = Fn.id - let prover _ = Key_gen.Sample_keypairs.genesis_winner |> fst - end + let prover _ = Key_gen.Sample_keypairs.genesis_winner |> fst + end - include Checked + include Checked - module Statement = struct - type t = Transaction_snark.Statement.t One_or_two.t - end - end + module Statement = struct + type t = Transaction_snark.Statement.t One_or_two.t + end + end - module Snark_pool = struct - [%%versioned - module Stable = struct - [@@@no_toplevel_latest_type] + module Snark_pool = struct + [%%versioned + module Stable = struct + [@@@no_toplevel_latest_type] - module V2 = struct - type t = Transaction_snark.Statement.Stable.V2.t One_or_two.Stable.V1.t - [@@deriving hash, compare, sexp] + module V2 = struct + type t = Transaction_snark.Statement.Stable.V2.t One_or_two.Stable.V1.t + [@@deriving hash, compare, sexp] - let to_latest = Fn.id - end - end] + let to_latest = Fn.id + end + end] - module Work = Hashable.Make_binable (Stable.Latest) + module Work = Hashable.Make_binable (Stable.Latest) - type t = Currency.Fee.t Work.Table.t + type t = Currency.Fee.t Work.Table.t - let get_completed_work (t : t) = Work.Table.find t + let get_completed_work (t : t) = Work.Table.find t - let create () = Work.Table.create () + let create () = Work.Table.create () - let add_snark t ~work ~fee = - Work.Table.update t work ~f:(function - | None -> - fee - | Some fee' -> - Currency.Fee.min fee fee' ) - end + let add_snark t ~work ~fee = + Work.Table.update t work ~f:(function + | None -> + fee + | Some fee' -> + Currency.Fee.min fee fee' ) + end - module Staged_ledger = struct - type t = - (int, Transaction_snark_work.t) Snark_work_lib.Work.Single.Spec.t List.t + module Staged_ledger = struct + type t = + (int, Transaction_snark_work.t) Snark_work_lib.Work.Single.Spec.t List.t - let work = Fn.id + let work = Fn.id - let all_work_pairs t ~get_state:_ = Ok (One_or_two.group_list t) - end + let all_work_pairs t = (One_or_two.group_list t) + end - module Transition_frontier = struct - type t = Staged_ledger.t + module Transition_frontier = struct + type t = Staged_ledger.t - type best_tip_view = unit + type best_tip_view = unit - let best_tip_pipe : t -> best_tip_view Pipe_lib.Broadcast_pipe.Reader.t = - fun _t -> - let reader, _writer = Pipe_lib.Broadcast_pipe.create () in - reader + let best_tip_pipe : t -> best_tip_view Pipe_lib.Broadcast_pipe.Reader.t = + fun _t -> + let reader, _writer = Pipe_lib.Broadcast_pipe.create () in + reader - let best_tip_staged_ledger = Fn.id + let best_tip_staged_ledger = Fn.id - let get_protocol_state _t _hash = - Ok - (Lazy.force Precomputed_values.for_unit_tests) - .protocol_state_with_hashes - .data - end -end + let get_protocol_state _t _hash = + Ok + (Lazy.force Precomputed_values.for_unit_tests) + .protocol_state_with_hashes + .data + end + end *) module Implementation_inputs = struct open Mina_base diff --git a/src/lib/work_selector/intf.ml b/src/lib/work_selector/intf.ml index 4a0124134099..2ac753debeb9 100644 --- a/src/lib/work_selector/intf.ml +++ b/src/lib/work_selector/intf.ml @@ -72,16 +72,36 @@ module type Inputs_intf = sig module Staged_ledger : sig type t - val all_work_pairs : - t - -> get_state: - (Mina_base.State_hash.t -> Mina_state.Protocol_state.value Or_error.t) - -> ( Transaction_witness.t - , Ledger_proof.Cached.t ) - Snark_work_lib.Work.Single.Spec.t - One_or_two.t - list - Or_error.t + module Scan_state : sig + module Available_job : sig + type t + + (* val single_spec : + get_state: + ( Mina_base.State_hash.t + -> Mina_state.Protocol_state.Value.t Or_error.t ) + -> t + -> ( Transaction_witness.Stable.Latest.t + , Ledger_proof.Stable.Latest.t ) + Snark_work_lib.Spec.Single.Poly.t + Or_error.t + + val single_spec_one_or_two : + get_state: + ( Mina_base.State_hash.t + -> Mina_state.Protocol_state.Value.t Or_error.t ) + -> t One_or_two.t + -> ( Transaction_witness.Stable.Latest.t + , Ledger_proof.t ) + Snark_work_lib.Spec.Single.Poly.t + One_or_two.t + Or_error.t + *) + val statement : t -> Transaction_snark.Statement.t option + end + end + + val all_work_pairs : t -> Scan_state.Available_job.t One_or_two.t list end module Transition_frontier : sig @@ -123,10 +143,7 @@ module type Lib_intf = sig val mark_scheduled : logger:Logger.t -> t - -> ( Transaction_witness.t - , Ledger_proof.Cached.t ) - Snark_work_lib.Work.Single.Spec.t - One_or_two.t + -> Staged_ledger.Scan_state.Available_job.t One_or_two.t -> unit (** [all_unscheduled_expensive_works ~snark_pool ~fee t] filters out all @@ -137,11 +154,7 @@ module type Lib_intf = sig snark_pool:Snark_pool.t -> fee:Fee.t -> t - -> ( Transaction_witness.t - , Ledger_proof.Cached.t ) - Snark_work_lib.Work.Single.Spec.t - One_or_two.t - list + -> Staged_ledger.Scan_state.Available_job.t One_or_two.t list end (**jobs that are not in the snark pool yet*) @@ -187,10 +200,7 @@ end module type Make_selection_method_intf = functor (Lib : Lib_intf) -> Selection_method_intf with type staged_ledger := Lib.Inputs.Staged_ledger.t - and type work := - ( Lib.Inputs.Transaction_witness.t - , Lib.Inputs.Ledger_proof.Cached.t ) - Snark_work_lib.Work.Single.Spec.t + and type work := Lib.Inputs.Staged_ledger.Scan_state.Available_job.t and type snark_pool := Lib.Inputs.Snark_pool.t and type transition_frontier := Lib.Inputs.Transition_frontier.t and module State := Lib.State diff --git a/src/lib/work_selector/random.ml b/src/lib/work_selector/random.ml index 261908beb564..90fa0d3a0569 100644 --- a/src/lib/work_selector/random.ml +++ b/src/lib/work_selector/random.ml @@ -12,7 +12,7 @@ module Make (Lib : Intf.Lib_intf) = struct Some x end -let%test_module "test" = - ( module struct - module Test = Test.Make_test (Make) - end ) +(* let%test_module "test" = + ( module struct + module Test = Test.Make_test (Make) + end ) *) diff --git a/src/lib/work_selector/random_offset.ml b/src/lib/work_selector/random_offset.ml index 09604d498638..36f103b1b83f 100644 --- a/src/lib/work_selector/random_offset.ml +++ b/src/lib/work_selector/random_offset.ml @@ -53,7 +53,7 @@ module Make (Lib : Intf.Lib_intf) = struct Some x end -let%test_module "test" = - ( module struct - module Test = Test.Make_test (Make) - end ) +(* let%test_module "test" = + ( module struct + module Test = Test.Make_test (Make) + end ) *) diff --git a/src/lib/work_selector/sequence.ml b/src/lib/work_selector/sequence.ml index b18a43564825..eb48b29b29df 100644 --- a/src/lib/work_selector/sequence.ml +++ b/src/lib/work_selector/sequence.ml @@ -8,7 +8,7 @@ module Make (Lib : Intf.Lib_intf) = struct Some x end -let%test_module "test" = - ( module struct - module Test = Test.Make_test (Make) - end ) +(* let%test_module "test" = + ( module struct + module Test = Test.Make_test (Make) + end ) *) diff --git a/src/lib/work_selector/test.ml b/src/lib/work_selector/test.ml index 5f7aaa423c24..87c3eddccff8 100644 --- a/src/lib/work_selector/test.ml +++ b/src/lib/work_selector/test.ml @@ -1,114 +1,114 @@ -open Core_kernel -open Async -open Currency -open Pipe_lib +(* open Core_kernel + open Async + open Currency + open Pipe_lib -module Make_test (Make_selection_method : Intf.Make_selection_method_intf) = -struct - module T = Inputs.Test_inputs - module Lib = Work_lib.Make (T) - module Selection_method = Make_selection_method (Lib) + module Make_test (Make_selection_method : Intf.Make_selection_method_intf) = + struct + module T = Inputs.Test_inputs + module Lib = Work_lib.Make (T) + module Selection_method = Make_selection_method (Lib) - let gen_staged_ledger = - (*Staged_ledger for tests is a list of work specs*) - Quickcheck.Generator.list - @@ Snark_work_lib.Work.Single.Spec.gen Int.quickcheck_generator Fee.gen + let gen_staged_ledger = + (*Staged_ledger for tests is a list of work specs*) + Quickcheck.Generator.list + @@ Snark_work_lib.Work.Single.Spec.gen Int.quickcheck_generator Fee.gen - let precomputed_values = Precomputed_values.for_unit_tests + let precomputed_values = Precomputed_values.for_unit_tests - let init_state sl logger = - let tf_reader, tf_writer = Broadcast_pipe.create None in - let work_state = - Lib.State.init ~frontier_broadcast_pipe:tf_reader ~logger - in - let%map () = Broadcast_pipe.Writer.write tf_writer (Some sl) in - work_state + let init_state sl logger = + let tf_reader, tf_writer = Broadcast_pipe.create None in + let work_state = + Lib.State.init ~frontier_broadcast_pipe:tf_reader ~logger + in + let%map () = Broadcast_pipe.Writer.write tf_writer (Some sl) in + work_state - let%test_unit "Workspec chunk doesn't send same things again" = - Backtrace.elide := false ; - let p = 50 in - let snark_pool = T.Snark_pool.create () in - let fee = Currency.Fee.zero in - let logger = Logger.null () in - Quickcheck.test gen_staged_ledger ~trials:100 ~f:(fun sl -> - Async.Thread_safe.block_on_async_exn (fun () -> - let open Deferred.Let_syntax in - let%bind work_state = init_state sl logger in - let rec go i = - [%test_result: Bool.t] - ~message:"Exceeded time expected to exhaust work" ~expect:true - (i <= p) ; - let stuff = - Selection_method.work ~snark_pool ~fee ~logger work_state - in - match stuff with None -> return () | _ -> go (i + 1) - in - go 0 ) ) + let%test_unit "Workspec chunk doesn't send same things again" = + Backtrace.elide := false ; + let p = 50 in + let snark_pool = T.Snark_pool.create () in + let fee = Currency.Fee.zero in + let logger = Logger.null () in + Quickcheck.test gen_staged_ledger ~trials:100 ~f:(fun sl -> + Async.Thread_safe.block_on_async_exn (fun () -> + let open Deferred.Let_syntax in + let%bind work_state = init_state sl logger in + let rec go i = + [%test_result: Bool.t] + ~message:"Exceeded time expected to exhaust work" ~expect:true + (i <= p) ; + let stuff = + Selection_method.work ~snark_pool ~fee ~logger work_state + in + match stuff with None -> return () | _ -> go (i + 1) + in + go 0 ) ) - let gen_snark_pool (works : ('a, 'b) Lib.Work_spec.t One_or_two.t list) fee = - let open Quickcheck.Generator.Let_syntax in - let cheap_work_fee = Option.value_exn Fee.(sub fee one) in - let expensive_work_fee = Option.value_exn Fee.(add fee one) in - let snark_pool = T.Snark_pool.create () in - let rec add_works = function - | [] -> - return () - | work :: rest -> - let%bind fee = - Quickcheck.Generator.of_list [ cheap_work_fee; expensive_work_fee ] - in - T.Snark_pool.add_snark snark_pool ~work ~fee ; - add_works rest - in - let%map () = - add_works (List.map ~f:(One_or_two.map ~f:Lib.Work_spec.statement) works) - in - snark_pool + let gen_snark_pool (works : ('a, 'b) Lib.Work_spec.t One_or_two.t list) fee = + let open Quickcheck.Generator.Let_syntax in + let cheap_work_fee = Option.value_exn Fee.(sub fee one) in + let expensive_work_fee = Option.value_exn Fee.(add fee one) in + let snark_pool = T.Snark_pool.create () in + let rec add_works = function + | [] -> + return () + | work :: rest -> + let%bind fee = + Quickcheck.Generator.of_list [ cheap_work_fee; expensive_work_fee ] + in + T.Snark_pool.add_snark snark_pool ~work ~fee ; + add_works rest + in + let%map () = + add_works (List.map ~f:(One_or_two.map ~f:Lib.Work_spec.statement) works) + in + snark_pool - let%test_unit "selector shouldn't get work that it cannot outbid" = - Backtrace.elide := false ; - let my_fee = Currency.Fee.of_nanomina_int_exn 2 in - let p = 50 in - let logger = Logger.null () in - let g = - let open Quickcheck.Generator.Let_syntax in - let%bind sl = gen_staged_ledger in - let%map pool = - gen_snark_pool - ( T.Staged_ledger.all_work_pairs sl ~get_state:(fun _ -> - Ok - (Lazy.force precomputed_values).protocol_state_with_hashes - .data ) - |> Or_error.ok_exn ) - (Currency.Fee.of_nanomina_int_exn 2) - in - (sl, pool) - in - Quickcheck.test g - ~sexp_of: - [%sexp_of: - (int, Fee.t) Lib.Work_spec.t list * Fee.t T.Snark_pool.Work.Table.t] - ~trials:100 ~f:(fun (sl, snark_pool) -> - Async.Thread_safe.block_on_async_exn (fun () -> - let open Deferred.Let_syntax in - let%bind work_state = init_state sl logger in - let rec go i = - [%test_result: Bool.t] - ~message:"Exceeded time expected to exhaust work" ~expect:true - (i <= p) ; - let work = - Selection_method.work ~snark_pool ~fee:my_fee work_state ~logger - in - match work with - | None -> - return () - | Some job -> - [%test_result: Bool.t] - ~message:"Should not get any cheap jobs" ~expect:true - (Lib.For_tests.does_not_have_better_fee ~snark_pool - ~fee:my_fee - (One_or_two.map job ~f:Lib.Work_spec.statement) ) ; - go (i + 1) - in - go 0 ) ) -end + let%test_unit "selector shouldn't get work that it cannot outbid" = + Backtrace.elide := false ; + let my_fee = Currency.Fee.of_nanomina_int_exn 2 in + let p = 50 in + let logger = Logger.null () in + let g = + let open Quickcheck.Generator.Let_syntax in + let%bind sl = gen_staged_ledger in + let%map pool = + gen_snark_pool + ( T.Staged_ledger.all_work_pairs sl ~get_state:(fun _ -> + Ok + (Lazy.force precomputed_values).protocol_state_with_hashes + .data ) + |> Or_error.ok_exn ) + (Currency.Fee.of_nanomina_int_exn 2) + in + (sl, pool) + in + Quickcheck.test g + ~sexp_of: + [%sexp_of: + (int, Fee.t) Lib.Work_spec.t list * Fee.t T.Snark_pool.Work.Table.t] + ~trials:100 ~f:(fun (sl, snark_pool) -> + Async.Thread_safe.block_on_async_exn (fun () -> + let open Deferred.Let_syntax in + let%bind work_state = init_state sl logger in + let rec go i = + [%test_result: Bool.t] + ~message:"Exceeded time expected to exhaust work" ~expect:true + (i <= p) ; + let work = + Selection_method.work ~snark_pool ~fee:my_fee work_state ~logger + in + match work with + | None -> + return () + | Some job -> + [%test_result: Bool.t] + ~message:"Should not get any cheap jobs" ~expect:true + (Lib.For_tests.does_not_have_better_fee ~snark_pool + ~fee:my_fee + (One_or_two.map job ~f:Lib.Work_spec.statement) ) ; + go (i + 1) + in + go 0 ) ) + end *) diff --git a/src/lib/work_selector/work_lib.ml b/src/lib/work_selector/work_lib.ml index 08f4bae28aa5..6070b78fc57b 100644 --- a/src/lib/work_selector/work_lib.ml +++ b/src/lib/work_selector/work_lib.ml @@ -6,15 +6,22 @@ module Make (Inputs : Intf.Inputs_intf) = struct module Inputs = Inputs module Work_spec = Snark_work_lib.Work.Single.Spec - let yojson_summary t = - let f = function - | Work_spec.Merge _ -> - `List [ `String "merge" ] - | Transition (_, witness) -> - Inputs.Transaction.yojson_summary - (Inputs.Transaction_witness.transaction witness) - in - `List (One_or_two.map ~f t |> One_or_two.to_list) + let yojson_summary _t = + (* TODO uncomment *) + (* let f = function + | Work_spec.Merge _ -> + `List [ `String "merge" ] + | Transition (_, _witness) -> + Inputs.Transaction.yojson_summary + (Inputs.Transaction_witness.transaction witness) + in + `List (One_or_two.map ~f t |> One_or_two.to_list) *) + `List [] + + let statement_of_job_exn job = + Inputs.Staged_ledger.Scan_state.Available_job.statement job + |> Option.value_exn + ~message:"unexpected failure to extract statement from job" module State = struct module Job_key = struct @@ -22,7 +29,7 @@ module Make (Inputs : Intf.Inputs_intf) = struct type t = Transaction_snark.Statement.t One_or_two.t [@@deriving compare, sexp, to_yojson, hash] - let of_job x = One_or_two.map ~f:Work_spec.statement x + let of_job x = One_or_two.map ~f:statement_of_job_exn x end include T @@ -31,11 +38,7 @@ module Make (Inputs : Intf.Inputs_intf) = struct type t = { mutable available_jobs : - ( Inputs.Transaction_witness.t - , Inputs.Ledger_proof.Cached.t ) - Work_spec.t - One_or_two.t - list + Inputs.Staged_ledger.Scan_state.Available_job.t One_or_two.t list (** Jobs received from [frontier_broadcast_pipe], would be updated whenever the pipe has broadcasted new frontier. The works between consecutive frontier broadcasts should be largely @@ -56,6 +59,9 @@ module Make (Inputs : Intf.Inputs_intf) = struct [%log debug] "No frontier, setting available work to be empty" ; t.available_jobs <- [] | Some frontier -> + (* let get_state = + Inputs.Transition_frontier.get_protocol_state frontier + in *) Pipe_lib.Broadcast_pipe.Reader.iter (Inputs.Transition_frontier.best_tip_pipe frontier) ~f:(fun _ -> let best_tip_staged_ledger = @@ -64,15 +70,12 @@ module Make (Inputs : Intf.Inputs_intf) = struct let start_time = Time.now () in ( match Inputs.Staged_ledger.all_work_pairs best_tip_staged_ledger - ~get_state: - (Inputs.Transition_frontier.get_protocol_state - frontier ) with - | Error e -> + (* | Error e -> [%log fatal] "Error occured when updating available work: $error" - ~metadata:[ ("error", Error_json.error_to_yojson e) ] - | Ok new_available_jobs -> + ~metadata:[ ("error", Error_json.error_to_yojson e) ] *) + | new_available_jobs -> let end_time = Time.now () in [%log info] "Updating new available work took $time ms" ~metadata: @@ -128,7 +131,11 @@ module Make (Inputs : Intf.Inputs_intf) = struct t let mark_scheduled ~logger t job = - let statement = One_or_two.map ~f:Work_spec.statement job in + let statement_exn j = + Inputs.Staged_ledger.Scan_state.Available_job.statement j + |> Option.value_exn + in + let statement = One_or_two.map ~f:statement_exn job in (* Log to internal trace all of the newly available jobs. *) [%log internal] "Snark_work_scheduled" ~metadata: @@ -156,12 +163,12 @@ module Make (Inputs : Intf.Inputs_intf) = struct end let get_expensive_work ~snark_pool ~fee - (jobs : ('a, 'b) Work_spec.t One_or_two.t list) : - ('a, 'b) Work_spec.t One_or_two.t list = + (jobs : Inputs.Staged_ledger.Scan_state.Available_job.t One_or_two.t list) + : Inputs.Staged_ledger.Scan_state.Available_job.t One_or_two.t list = O1trace.sync_thread "work_lib_get_expensive_work" (fun () -> List.filter jobs ~f:(fun job -> State.does_not_have_better_fee ~snark_pool ~fee - (One_or_two.map job ~f:Work_spec.statement) ) ) + (One_or_two.map job ~f:statement_of_job_exn) ) ) let all_pending_work ~snark_pool statements = List.filter statements ~f:(fun st -> @@ -170,7 +177,7 @@ module Make (Inputs : Intf.Inputs_intf) = struct let all_work ~snark_pool (state : State.t) = O1trace.sync_thread "work_lib_all_unseen_works" (fun () -> List.map state.available_jobs ~f:(fun job -> - let statement = One_or_two.map ~f:Work_spec.statement job in + let statement = One_or_two.map ~f:statement_of_job_exn job in let fee_prover_opt = Option.map (Inputs.Snark_pool.get_completed_work snark_pool statement) @@ -187,7 +194,7 @@ module Make (Inputs : Intf.Inputs_intf) = struct (*Seen/Unseen jobs that are not in the snark pool yet*) let pending_work_statements ~snark_pool ~fee_opt (state : State.t) = let all_todo_statements = - List.map state.available_jobs ~f:(One_or_two.map ~f:Work_spec.statement) + List.map state.available_jobs ~f:(One_or_two.map ~f:statement_of_job_exn) in let expensive_work statements ~fee = List.filter statements @@ -201,7 +208,7 @@ module Make (Inputs : Intf.Inputs_intf) = struct let completed_work_statements ~snark_pool (state : State.t) = let all_todo_statements = - List.map state.available_jobs ~f:(One_or_two.map ~f:Work_spec.statement) + List.map state.available_jobs ~f:(One_or_two.map ~f:statement_of_job_exn) in all_completed_work ~snark_pool all_todo_statements diff --git a/src/lib/work_selector/work_selector.ml b/src/lib/work_selector/work_selector.ml index fc1e52b95551..72368a25b000 100644 --- a/src/lib/work_selector/work_selector.ml +++ b/src/lib/work_selector/work_selector.ml @@ -1,7 +1,7 @@ module Lib = Work_lib.Make (Inputs.Implementation_inputs) module State = Lib.State -type work = Snark_work_lib.Selector.Single.Spec.t +type work = Staged_ledger.Scan_state.Available_job.t type in_memory_work = Snark_work_lib.Selector.Single.Spec.Stable.Latest.t diff --git a/src/lib/work_selector/work_selector.mli b/src/lib/work_selector/work_selector.mli index 9ac64dd0f8d3..e9cebe8588be 100644 --- a/src/lib/work_selector/work_selector.mli +++ b/src/lib/work_selector/work_selector.mli @@ -1,7 +1,7 @@ module State : Intf.State_intf with type transition_frontier := Transition_frontier.t -type work = Snark_work_lib.Selector.Single.Spec.t +type work = Staged_ledger.Scan_state.Available_job.t type in_memory_work = Snark_work_lib.Selector.Single.Spec.Stable.Latest.t