2903

Committed 15 Nov 2024 01:59PM UTC coverage: 36.723% (-25.0%) from 61.682%

Build # 2903

Build Type

Pull #16342

buildkite

Committed by

dkijania

Commit Message

Merge branch 'dkijania/remove_publish_job_from_pr_comp' into dkijania/remove_publish_job_from_pr_dev

Pull Request Pull Request #16342: [DEV] Publish debians only on nightly and stable

Run Details

15 of 40 new or added lines in 14 files covered. (37.5%)

15175 existing lines in 340 files now uncovered.

24554 of 66863 relevant lines covered (36.72%)

20704.91 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

59.18

/src/lib/mina_block/validation.ml

(* TODO: refactor
   - validations need to be simplified and merged
     - also need to think if data-carrying validations makes sense or not
   - initial validation properties should all be combined, with different validation entrypoints for each use case
   - frontier validation needs re-thought
*)

open Async_kernel
open Core_kernel
open Mina_base
open Mina_state
open Consensus.Data
include Validation_types

module type CONTEXT = sig
  val logger : Logger.t

  val constraint_constants : Genesis_constants.Constraint_constants.t

  val consensus_constants : Consensus.Constants.t
end

let validation (_, v) = v

let header_with_hash (b, _) = b

let header (b, _) = With_hash.data b

let block_with_hash (b, _) = b

let block (b, _) = With_hash.data b

let wrap t : fully_invalid_with_block = (t, fully_invalid)

module Unsafe = struct
  let set_valid_time_received :
         ( [ `Time_received ] * unit Truth.false_t
         , 'genesis_state
         , 'proof
         , 'delta_block_chain
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , 'protocol_versions )
         t
      -> ( [ `Time_received ] * unit Truth.true_t
         , 'genesis_state
         , 'proof
         , 'delta_block_chain
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , 'protocol_versions )
         t = function
    | ( (`Time_received, Truth.False)
      , genesis_state
      , proof
      , delta_block_chain
      , frontier_dependencies
      , staged_ledger_diff
      , protocol_versions ) ->
        ( (`Time_received, Truth.True ())
        , genesis_state
        , proof
        , delta_block_chain
        , frontier_dependencies
        , staged_ledger_diff
        , protocol_versions )

  let set_valid_proof :
         ( 'time_received
         , 'genesis_state
         , [ `Proof ] * unit Truth.false_t
         , 'delta_block_chain
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , 'protocol_versions )
         t
      -> ( 'time_received
         , 'genesis_state
         , [ `Proof ] * unit Truth.true_t
         , 'delta_block_chain
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , 'protocol_versions )
         t = function
    | ( time_received
      , genesis_state
      , (`Proof, Truth.False)
      , delta_block_chain
      , frontier_dependencies
      , staged_ledger_diff
      , protocol_versions ) ->
        ( time_received
        , genesis_state
        , (`Proof, Truth.True ())
        , delta_block_chain
        , frontier_dependencies
        , staged_ledger_diff
        , protocol_versions )

  let set_valid_genesis_state :
         ( 'time_received
         , [ `Genesis_state ] * unit Truth.false_t
         , 'proof
         , 'delta_block_chain
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , 'protocol_versions )
         t
      -> ( 'time_received
         , [ `Genesis_state ] * unit Truth.true_t
         , 'proof
         , 'delta_block_chain
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , 'protocol_versions )
         t = function
    | ( time_received
      , (`Genesis_state, Truth.False)
      , proof
      , delta_block_chain
      , frontier_dependencies
      , staged_ledger_diff
      , protocol_versions ) ->
        ( time_received
        , (`Genesis_state, Truth.True ())
        , proof
        , delta_block_chain
        , frontier_dependencies
        , staged_ledger_diff
        , protocol_versions )

  let set_valid_delta_block_chain :
         ( 'time_received
         , 'genesis_state
         , 'proof
         , [ `Delta_block_chain ]
           * State_hash.t Mina_stdlib.Nonempty_list.t Truth.false_t
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , 'protocol_versions )
         t
      -> State_hash.t Mina_stdlib.Nonempty_list.t
      -> ( 'time_received
         , 'genesis_state
         , 'proof
         , [ `Delta_block_chain ]
           * State_hash.t Mina_stdlib.Nonempty_list.t Truth.true_t
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , 'protocol_versions )
         t =
   fun validation hashes ->
    match validation with
    | ( time_received
      , genesis_state
      , proof
      , (`Delta_block_chain, Truth.False)
      , frontier_dependencies
      , staged_ledger_diff
      , protocol_versions ) ->
        ( time_received
        , genesis_state
        , proof
        , (`Delta_block_chain, Truth.True hashes)
        , frontier_dependencies
        , staged_ledger_diff
        , protocol_versions )

  let set_valid_frontier_dependencies :
         ( 'time_received
         , 'genesis_state
         , 'proof
         , 'delta_block_chain
         , [ `Frontier_dependencies ] * unit Truth.false_t
         , 'staged_ledger_diff
         , 'protocol_versions )
         t
      -> ( 'time_received
         , 'genesis_state
         , 'proof
         , 'delta_block_chain
         , [ `Frontier_dependencies ] * unit Truth.true_t
         , 'staged_ledger_diff
         , 'protocol_versions )
         t = function
    | ( time_received
      , genesis_state
      , proof
      , delta_block_chain
      , (`Frontier_dependencies, Truth.False)
      , staged_ledger_diff
      , protocol_versions ) ->
        ( time_received
        , genesis_state
        , proof
        , delta_block_chain
        , (`Frontier_dependencies, Truth.True ())
        , staged_ledger_diff
        , protocol_versions )

  let set_valid_staged_ledger_diff :
         ( 'time_received
         , 'genesis_state
         , 'proof
         , 'delta_block_chain
         , 'frontier_dependencies
         , [ `Staged_ledger_diff ] * unit Truth.false_t
         , 'protocol_versions )
         t
      -> ( 'time_received
         , 'genesis_state
         , 'proof
         , 'delta_block_chain
         , 'frontier_dependencies
         , [ `Staged_ledger_diff ] * unit Truth.true_t
         , 'protocol_versions )
         t = function
    | ( time_received
      , genesis_state
      , proof
      , delta_block_chain
      , frontier_dependencies
      , (`Staged_ledger_diff, Truth.False)
      , protocol_versions ) ->
        ( time_received
        , genesis_state
        , proof
        , delta_block_chain
        , frontier_dependencies
        , (`Staged_ledger_diff, Truth.True ())
        , protocol_versions )

  let set_valid_protocol_versions :
         ( 'time_received
         , 'genesis_state
         , 'proof
         , 'delta_block_chain
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , [ `Protocol_versions ] * unit Truth.false_t )
         t
      -> ( 'time_received
         , 'genesis_state
         , 'proof
         , 'delta_block_chain
         , 'frontier_dependencies
         , 'staged_ledger_diff
         , [ `Protocol_versions ] * unit Truth.true_t )
         t = function
    | ( time_received
      , genesis_state
      , proof
      , delta_block_chain
      , frontier_dependencies
      , staged_ledger_diff
      , (`Protocol_versions, Truth.False) ) ->
        ( time_received
        , genesis_state
        , proof
        , delta_block_chain
        , frontier_dependencies
        , staged_ledger_diff
        , (`Protocol_versions, Truth.True ()) )
end

let validate_time_received ~(precomputed_values : Precomputed_values.t)
    ~time_received (t, validation) =
  let consensus_state =
    t |> With_hash.data |> Header.protocol_state
    |> Protocol_state.consensus_state
  in
  let constants = precomputed_values.consensus_constants in
  let received_unix_timestamp =
    Block_time.to_span_since_epoch time_received |> Block_time.Span.to_ms
  in
  match
    Consensus.Hooks.received_at_valid_time ~constants consensus_state
      ~time_received:received_unix_timestamp
  with
  | Ok () ->
      Ok (t, Unsafe.set_valid_time_received validation)
  | Error err ->
      Error (`Invalid_time_received err)

let skip_time_received_validation `This_block_was_not_received_via_gossip
    (t, validation) =
  (t, Unsafe.set_valid_time_received validation)

let validate_genesis_protocol_state ~genesis_state_hash (t, validation) =
  let state = t |> With_hash.data |> Header.protocol_state in
  if
    State_hash.equal
      (Protocol_state.genesis_state_hash state)
      genesis_state_hash
  then Ok (t, Unsafe.set_valid_genesis_state validation)
  else Error `Invalid_genesis_protocol_state

let skip_genesis_protocol_state_validation `This_block_was_generated_internally
    (t, validation) =
  (t, Unsafe.set_valid_genesis_state validation)

let reset_genesis_protocol_state_validation (block_with_hash, validation) =
  match validation with
  | ( time_received
    , (`Genesis_state, Truth.True ())
    , proof
    , delta_block_chain
    , frontier_dependencies
    , staged_ledger_diff
    , protocol_versions ) ->
      ( block_with_hash
      , ( time_received
        , (`Genesis_state, Truth.False)
        , proof
        , delta_block_chain
        , frontier_dependencies
        , staged_ledger_diff
        , protocol_versions ) )
  | _ ->
      failwith "why can't this be refuted?"

let validate_proofs ~verifier ~genesis_state_hash tvs =
  let to_verify =
    List.filter_map tvs ~f:(fun (t, _validation) ->
        if
          State_hash.equal
            (State_hash.With_state_hashes.state_hash t)
            genesis_state_hash
        then
          (* Don't require a valid proof for the genesis block, since the
             peer may not have one.
          *)
          None
        else
          let header = With_hash.data t in
          Some
            (Blockchain_snark.Blockchain.create
               ~state:(Header.protocol_state header)
               ~proof:(Header.protocol_state_proof header) ) )
  in
  match%map.Deferred
    match to_verify with
    | [] ->
        (* Skip calling the verifier, nothing here to verify. *)
        return (Ok (Ok ()))
    | _ ->
        Verifier.verify_blockchain_snarks verifier to_verify
  with
  | Ok (Ok ()) ->
      Ok
        (List.map tvs ~f:(fun (t, validation) ->
             (t, Unsafe.set_valid_proof validation) ) )
  | Ok (Error err) ->
      Error (`Invalid_proof err)
  | Error e ->
      Error (`Verifier_error e)

let validate_single_proof ~verifier ~genesis_state_hash t =
  let open Deferred.Result.Let_syntax in
  let%map res = validate_proofs ~verifier ~genesis_state_hash [ t ] in
  List.hd_exn res

let skip_proof_validation `This_block_was_generated_internally (t, validation) =
  (t, Unsafe.set_valid_proof validation)

let extract_delta_block_chain_witness = function
  | _, _, _, (`Delta_block_chain, Truth.True delta_block_chain_witness), _, _, _
    ->
      delta_block_chain_witness
  | _ ->
      failwith "why can't this be refuted?"

let validate_delta_block_chain (t, validation) =
  let header = t |> With_hash.data in
  match
    Transition_chain_verifier.verify
      ~target_hash:
        (header |> Header.protocol_state |> Protocol_state.previous_state_hash)
      ~transition_chain_proof:(Header.delta_block_chain_proof header)
  with
  | Some hashes ->
      Ok (t, Unsafe.set_valid_delta_block_chain validation hashes)
  | None ->
      Error `Invalid_delta_block_chain_proof

let skip_delta_block_chain_validation `This_block_was_not_received_via_gossip
    (t, validation) =
  let previous_protocol_state_hash =
    t |> With_hash.data |> Block.header |> Header.protocol_state
    |> Protocol_state.previous_state_hash
  in
  ( t
  , Unsafe.set_valid_delta_block_chain validation
      (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) =
  let module Context = struct
    include Context

    let logger =
      Logger.extend logger
        [ ( "selection_context"
          , `String "Mina_block.Validation.validate_frontier_dependencies" )
        ]
  end in
  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
  let consensus_state =
    Fn.compose Protocol_state.consensus_state protocol_state
  in
  let%bind () =
    Result.ok_if_true
      (not @@ is_block_in_frontier hash)
      ~error:`Already_in_frontier
  in
  let%bind () =
    (* need pervasive (=) in scope for comparing polymorphic variant *)
    let ( = ) = Stdlib.( = ) in
    Result.ok_if_true
      ( `Take
      = Consensus.Hooks.select
          ~context:(module Context)
          ~existing:root_consensus_state
          ~candidate:(With_hash.map ~f:consensus_state t) )
      ~error:`Not_selected_over_frontier_root
  in
  let%map () =
    Result.ok_if_true
      (is_block_in_frontier parent_hash)
      ~error:`Parent_missing_from_frontier
  in
  (t, Unsafe.set_valid_frontier_dependencies validation)

let skip_frontier_dependencies_validation
    (_ :
      [ `This_block_belongs_to_a_detached_subtree
      | `This_block_was_loaded_from_persistence ] ) (t, validation) =
  (t, Unsafe.set_valid_frontier_dependencies validation)

let reset_frontier_dependencies_validation (transition_with_hash, validation) =
  match validation with
  | ( time_received
    , genesis_state
    , proof
    , delta_block_chain
    , (`Frontier_dependencies, Truth.True ())
    , staged_ledger_diff
    , protocol_versions ) ->
      ( transition_with_hash
      , ( time_received
        , genesis_state
        , proof
        , delta_block_chain
        , (`Frontier_dependencies, Truth.False)
        , staged_ledger_diff
        , protocol_versions ) )
  | _ ->
      failwith "why can't this be refuted?"

let validate_staged_ledger_diff ?skip_staged_ledger_verification ~logger
    ~get_completed_work ~precomputed_values ~verifier ~parent_staged_ledger
    ~parent_protocol_state (t, validation) =
  [%log internal] "Validate_staged_ledger_diff" ;
  let block = With_hash.data t in
  let header = Block.header block in
  let protocol_state = Header.protocol_state header in
  let blockchain_state = Protocol_state.blockchain_state protocol_state in
  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 apply_start_time = Core.Time.now () in
  let body_ref_from_header = Blockchain_state.body_reference blockchain_state in
  let body_ref_computed = Staged_ledger_diff.Body.compute_reference body 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 ( `Hash_after_applying staged_ledger_hash
                           , `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)
         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
    |> Deferred.Result.map_error ~f:(fun e ->
           `Staged_ledger_application_failed e )
  in
  [%log debug]
    ~metadata:
      [ ( "time_elapsed"
        , `Float Core.Time.(Span.to_ms @@ diff (now ()) apply_start_time) )
      ]
    "Staged_ledger.apply 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, _) ->
        Ledger_proof.snarked_ledger_hash proof
  in
  let hash_errors =
    Result.combine_errors_unit
      [ ( if
          Staged_ledger_hash.equal staged_ledger_hash
            (Blockchain_state.staged_ledger_hash blockchain_state)
        then Ok ()
        else Error `Incorrect_target_staged_ledger_hash )
      ; ( if
          Frozen_ledger_hash.equal snarked_ledger_hash
            (Blockchain_state.snarked_ledger_hash blockchain_state)
        then Ok ()
        else Error `Incorrect_target_snarked_ledger_hash )
      ]
  in
  Deferred.return
  @@
  match hash_errors with
  | Ok () ->
      Ok
        ( `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 )
  | Error errors ->
      Error (`Invalid_staged_ledger_diff errors)

let validate_staged_ledger_hash
    (`Staged_ledger_already_materialized staged_ledger_hash) (t, validation) =
  let state =
    t |> With_hash.data |> Block.header |> Header.protocol_state
    |> Protocol_state.blockchain_state
  in
  if
    Staged_ledger_hash.equal staged_ledger_hash
      (Blockchain_state.staged_ledger_hash state)
  then Ok (t, Unsafe.set_valid_staged_ledger_diff validation)
  else Error `Staged_ledger_hash_mismatch

let skip_staged_ledger_diff_validation `This_block_has_a_trusted_staged_ledger
    (t, validation) =
  (t, Unsafe.set_valid_staged_ledger_diff validation)

let reset_staged_ledger_diff_validation (transition_with_hash, validation) =
  match validation with
  | ( time_received
    , genesis_state
    , proof
    , delta_block_chain
    , frontier_dependencies
    , (`Staged_ledger_diff, Truth.True ())
    , protocol_versions ) ->
      ( transition_with_hash
      , ( time_received
        , genesis_state
        , proof
        , delta_block_chain
        , frontier_dependencies
        , (`Staged_ledger_diff, Truth.False)
        , protocol_versions ) )
  | _ ->
      failwith "why can't this be refuted?"

let validate_protocol_versions (t, validation) =
  let { Header.valid_current; valid_next; matches_daemon } =
    t |> With_hash.data |> Header.protocol_version_status
  in
  if not (valid_current && valid_next) then Error `Invalid_protocol_version
  else if not matches_daemon then Error `Mismatched_protocol_version
  else Ok (t, Unsafe.set_valid_protocol_versions validation)

let skip_protocol_versions_validation `This_block_has_valid_protocol_versions
    (t, validation) =
  (t, Unsafe.set_valid_protocol_versions validation)

let with_body (header_with_hash, validation) body =
  ( With_hash.map ~f:(fun header -> Block.create ~header ~body) header_with_hash
  , validation )

let wrap_header t : fully_invalid_with_header = (t, fully_invalid)

let to_header (b, v) = (With_hash.map ~f:Block.header b, v)

1	(* TODO: refactor
2	- validations need to be simplified and merged
3	- also need to think if data-carrying validations makes sense or not
4	- initial validation properties should all be combined, with different validation entrypoints for each use case
5	- frontier validation needs re-thought
6	*)
7		16✔
8	open Async_kernel
9	open Core_kernel
10	open Mina_base
11	open Mina_state
12	open Consensus.Data
13	include Validation_types
14
15	module type CONTEXT = sig
16	val logger : Logger.t
17
18	val constraint_constants : Genesis_constants.Constraint_constants.t
19
20	val consensus_constants : Consensus.Constants.t
21	end
22
23	let validation (_, v) = v	×
24
25	let header_with_hash (b, _) = b	3✔
26
27	let header (b, _) = With_hash.data b	×
28
29	let block_with_hash (b, _) = b	206✔
30
31	let block (b, _) = With_hash.data b	6✔
32
33	let wrap t : fully_invalid_with_block = (t, fully_invalid)	6✔
34
35	module Unsafe = struct
36	let set_valid_time_received :
37	( [ `Time_received ] * unit Truth.false_t
38	, 'genesis_state
39	, 'proof
40	, 'delta_block_chain
41	, 'frontier_dependencies
42	, 'staged_ledger_diff
43	, 'protocol_versions )
44	t
45	-> ( [ `Time_received ] * unit Truth.true_t
46	, 'genesis_state
47	, 'proof
48	, 'delta_block_chain
49	, 'frontier_dependencies
50	, 'staged_ledger_diff
51	, 'protocol_versions )
52	t = function
53	\| ( (`Time_received, Truth.False)	6✔
54	, genesis_state
55	, proof
56	, delta_block_chain
57	, frontier_dependencies
58	, staged_ledger_diff
59	, protocol_versions ) ->
60	( (`Time_received, Truth.True ())
61	, genesis_state
62	, proof
63	, delta_block_chain
64	, frontier_dependencies
65	, staged_ledger_diff
66	, protocol_versions )
67
68	let set_valid_proof :
69	( 'time_received
70	, 'genesis_state
71	, [ `Proof ] * unit Truth.false_t
72	, 'delta_block_chain
73	, 'frontier_dependencies
74	, 'staged_ledger_diff
75	, 'protocol_versions )
76	t
77	-> ( 'time_received
78	, 'genesis_state
79	, [ `Proof ] * unit Truth.true_t
80	, 'delta_block_chain
81	, 'frontier_dependencies
82	, 'staged_ledger_diff
83	, 'protocol_versions )
84	t = function
85	\| ( time_received	6✔
86	, genesis_state
87	, (`Proof, Truth.False)
88	, delta_block_chain
89	, frontier_dependencies
90	, staged_ledger_diff
91	, protocol_versions ) ->
92	( time_received
93	, genesis_state
94	, (`Proof, Truth.True ())
95	, delta_block_chain
96	, frontier_dependencies
97	, staged_ledger_diff
98	, protocol_versions )
99
100	let set_valid_genesis_state :
101	( 'time_received
102	, [ `Genesis_state ] * unit Truth.false_t
103	, 'proof
104	, 'delta_block_chain
105	, 'frontier_dependencies
106	, 'staged_ledger_diff
107	, 'protocol_versions )
108	t
109	-> ( 'time_received
110	, [ `Genesis_state ] * unit Truth.true_t
111	, 'proof
112	, 'delta_block_chain
113	, 'frontier_dependencies
114	, 'staged_ledger_diff
115	, 'protocol_versions )
116	t = function
117	\| ( time_received	6✔
118	, (`Genesis_state, Truth.False)
119	, proof
120	, delta_block_chain
121	, frontier_dependencies
122	, staged_ledger_diff
123	, protocol_versions ) ->
124	( time_received
125	, (`Genesis_state, Truth.True ())
126	, proof
127	, delta_block_chain
128	, frontier_dependencies
129	, staged_ledger_diff
130	, protocol_versions )
131
132	let set_valid_delta_block_chain :
133	( 'time_received
134	, 'genesis_state
135	, 'proof
136	, [ `Delta_block_chain ]
137	* State_hash.t Mina_stdlib.Nonempty_list.t Truth.false_t
138	, 'frontier_dependencies
139	, 'staged_ledger_diff
140	, 'protocol_versions )
141	t
142	-> State_hash.t Mina_stdlib.Nonempty_list.t
143	-> ( 'time_received
144	, 'genesis_state
145	, 'proof
146	, [ `Delta_block_chain ]
147	* State_hash.t Mina_stdlib.Nonempty_list.t Truth.true_t
148	, 'frontier_dependencies
149	, 'staged_ledger_diff
150	, 'protocol_versions )
151	t =
152	fun validation hashes ->
153	match validation with	6✔
154	\| ( time_received	6✔
155	, genesis_state
156	, proof
157	, (`Delta_block_chain, Truth.False)
158	, frontier_dependencies
159	, staged_ledger_diff
160	, protocol_versions ) ->
161	( time_received
162	, genesis_state
163	, proof
164	, (`Delta_block_chain, Truth.True hashes)
165	, frontier_dependencies
166	, staged_ledger_diff
167	, protocol_versions )
168
169	let set_valid_frontier_dependencies :
170	( 'time_received
171	, 'genesis_state
172	, 'proof
173	, 'delta_block_chain
174	, [ `Frontier_dependencies ] * unit Truth.false_t
175	, 'staged_ledger_diff
176	, 'protocol_versions )
177	t
178	-> ( 'time_received
179	, 'genesis_state
180	, 'proof
181	, 'delta_block_chain
182	, [ `Frontier_dependencies ] * unit Truth.true_t
183	, 'staged_ledger_diff
184	, 'protocol_versions )
185	t = function
UNCOV 186	\| ( time_received	×
187	, genesis_state
188	, proof
189	, delta_block_chain
190	, (`Frontier_dependencies, Truth.False)
191	, staged_ledger_diff
192	, protocol_versions ) ->
193	( time_received
194	, genesis_state
195	, proof
196	, delta_block_chain
197	, (`Frontier_dependencies, Truth.True ())
198	, staged_ledger_diff
199	, protocol_versions )
200
201	let set_valid_staged_ledger_diff :
202	( 'time_received
203	, 'genesis_state
204	, 'proof
205	, 'delta_block_chain
206	, 'frontier_dependencies
207	, [ `Staged_ledger_diff ] * unit Truth.false_t
208	, 'protocol_versions )
209	t
210	-> ( 'time_received
211	, 'genesis_state
212	, 'proof
213	, 'delta_block_chain
214	, 'frontier_dependencies
215	, [ `Staged_ledger_diff ] * unit Truth.true_t
216	, 'protocol_versions )
217	t = function
218	\| ( time_received	200✔
219	, genesis_state
220	, proof
221	, delta_block_chain
222	, frontier_dependencies
223	, (`Staged_ledger_diff, Truth.False)
224	, protocol_versions ) ->
225	( time_received
226	, genesis_state
227	, proof
228	, delta_block_chain
229	, frontier_dependencies
230	, (`Staged_ledger_diff, Truth.True ())
231	, protocol_versions )
232
233	let set_valid_protocol_versions :
234	( 'time_received
235	, 'genesis_state
236	, 'proof
237	, 'delta_block_chain
238	, 'frontier_dependencies
239	, 'staged_ledger_diff
240	, [ `Protocol_versions ] * unit Truth.false_t )
241	t
242	-> ( 'time_received
243	, 'genesis_state
244	, 'proof
245	, 'delta_block_chain
246	, 'frontier_dependencies
247	, 'staged_ledger_diff
248	, [ `Protocol_versions ] * unit Truth.true_t )
249	t = function
250	\| ( time_received	6✔
251	, genesis_state
252	, proof
253	, delta_block_chain
254	, frontier_dependencies
255	, staged_ledger_diff
256	, (`Protocol_versions, Truth.False) ) ->
257	( time_received
258	, genesis_state
259	, proof
260	, delta_block_chain
261	, frontier_dependencies
262	, staged_ledger_diff
263	, (`Protocol_versions, Truth.True ()) )
264	end
265
266	let validate_time_received ~(precomputed_values : Precomputed_values.t)
267	~time_received (t, validation) =
268	let consensus_state =	×
269	t \|> With_hash.data \|> Header.protocol_state	×
270	\|> Protocol_state.consensus_state
271	in
272	let constants = precomputed_values.consensus_constants in	×
273	let received_unix_timestamp =
274	Block_time.to_span_since_epoch time_received \|> Block_time.Span.to_ms	×
275	in
276	match	×
277	Consensus.Hooks.received_at_valid_time ~constants consensus_state
278	~time_received:received_unix_timestamp
279	with
280	\| Ok () ->	×
281	Ok (t, Unsafe.set_valid_time_received validation)	×
282	\| Error err ->	×
283	Error (`Invalid_time_received err)
284
285	let skip_time_received_validation `This_block_was_not_received_via_gossip
286	(t, validation) =
287	(t, Unsafe.set_valid_time_received validation)	6✔
288
289	let validate_genesis_protocol_state ~genesis_state_hash (t, validation) =
290	let state = t \|> With_hash.data \|> Header.protocol_state in	6✔
291	if	6✔
292	State_hash.equal
293	(Protocol_state.genesis_state_hash state)	6✔
294	genesis_state_hash
295	then Ok (t, Unsafe.set_valid_genesis_state validation)	6✔
296	else Error `Invalid_genesis_protocol_state	×
297
298	let skip_genesis_protocol_state_validation `This_block_was_generated_internally
299	(t, validation) =
300	(t, Unsafe.set_valid_genesis_state validation)	×
301
302	let reset_genesis_protocol_state_validation (block_with_hash, validation) =
303	match validation with	×
304	\| ( time_received	×
305	, (`Genesis_state, Truth.True ())
306	, proof
307	, delta_block_chain
308	, frontier_dependencies
309	, staged_ledger_diff
310	, protocol_versions ) ->
311	( block_with_hash
312	, ( time_received
313	, (`Genesis_state, Truth.False)
314	, proof
315	, delta_block_chain
316	, frontier_dependencies
317	, staged_ledger_diff
318	, protocol_versions ) )
319	\| _ ->	×
320	failwith "why can't this be refuted?"
321
322	let validate_proofs ~verifier ~genesis_state_hash tvs =
323	let to_verify =	6✔
324	List.filter_map tvs ~f:(fun (t, _validation) ->
325	if	6✔
326	State_hash.equal
327	(State_hash.With_state_hashes.state_hash t)	6✔
328	genesis_state_hash
329	then
330	(* Don't require a valid proof for the genesis block, since the
331	peer may not have one.
332	*)
333	None	6✔
334	else
UNCOV 335	let header = With_hash.data t in	×
UNCOV 336	Some	×
337	(Blockchain_snark.Blockchain.create
UNCOV 338	~state:(Header.protocol_state header)	×
UNCOV 339	~proof:(Header.protocol_state_proof header) ) )	×
340	in
341	match%map.Deferred
342	match to_verify with
343	\| [] ->	6✔
344	(* Skip calling the verifier, nothing here to verify. *)
345	return (Ok (Ok ()))	6✔
UNCOV 346	\| _ ->	×
UNCOV 347	Verifier.verify_blockchain_snarks verifier to_verify	×
348	with
349	\| Ok (Ok ()) ->	6✔
350	Ok
351	(List.map tvs ~f:(fun (t, validation) ->	6✔
352	(t, Unsafe.set_valid_proof validation) ) )	6✔
353	\| Ok (Error err) ->	×
354	Error (`Invalid_proof err)
355	\| Error e ->	×
356	Error (`Verifier_error e)
357
358	let validate_single_proof ~verifier ~genesis_state_hash t =
359	let open Deferred.Result.Let_syntax in	6✔
360	let%map res = validate_proofs ~verifier ~genesis_state_hash [ t ] in	6✔
361	List.hd_exn res	6✔
362
363	let skip_proof_validation `This_block_was_generated_internally (t, validation) =
364	(t, Unsafe.set_valid_proof validation)	×
365
366	let extract_delta_block_chain_witness = function
367	\| _, _, _, (`Delta_block_chain, Truth.True delta_block_chain_witness), _, _, _	×
368	->
369	delta_block_chain_witness
370	\| _ ->	×
371	failwith "why can't this be refuted?"
372
373	let validate_delta_block_chain (t, validation) =
UNCOV 374	let header = t \|> With_hash.data in	×
UNCOV 375	match	×
376	Transition_chain_verifier.verify
377	~target_hash:
UNCOV 378	(header \|> Header.protocol_state \|> Protocol_state.previous_state_hash)	×
UNCOV 379	~transition_chain_proof:(Header.delta_block_chain_proof header)	×
380	with
UNCOV 381	\| Some hashes ->	×
UNCOV 382	Ok (t, Unsafe.set_valid_delta_block_chain validation hashes)	×
383	\| None ->	×
384	Error `Invalid_delta_block_chain_proof
385
386	let skip_delta_block_chain_validation `This_block_was_not_received_via_gossip
387	(t, validation) =
388	let previous_protocol_state_hash =	6✔
389	t \|> With_hash.data \|> Block.header \|> Header.protocol_state	6✔
390	\|> Protocol_state.previous_state_hash
391	in
392	( t	6✔
393	, Unsafe.set_valid_delta_block_chain validation	6✔
394	(Mina_stdlib.Nonempty_list.singleton previous_protocol_state_hash) )	6✔
395
396	let validate_frontier_dependencies ~to_header
397	~context:(module Context : CONTEXT) ~root_block ~is_block_in_frontier
398	(t, validation) =
399	let module Context = struct	3✔
400	include Context
401
402	let logger =
403	Logger.extend logger	3✔
404	[ ( "selection_context"
405	, `String "Mina_block.Validation.validate_frontier_dependencies" )
406	]
407	end in
408	let open Result.Let_syntax in
409	let hash = State_hash.With_state_hashes.state_hash t in
410	let protocol_state = Fn.compose Header.protocol_state to_header in	3✔
411	let root_consensus_state =	3✔
412	With_hash.map
413	~f:
414	(Fn.compose Protocol_state.consensus_state	3✔
415	(Fn.compose Header.protocol_state Block.header) )	3✔
416	root_block
417	in
418	let parent_hash =	3✔
419	Protocol_state.previous_state_hash (protocol_state @@ With_hash.data t)	3✔
420	in
421	let consensus_state =	3✔
422	Fn.compose Protocol_state.consensus_state protocol_state
423	in
424	let%bind () =
425	Result.ok_if_true	3✔
426	(not @@ is_block_in_frontier hash)	3✔
427	~error:`Already_in_frontier
428	in
429	let%bind () =
430	(* need pervasive (=) in scope for comparing polymorphic variant *)
431	let ( = ) = Stdlib.( = ) in
UNCOV 432	Result.ok_if_true	×
433	( `Take
434	= Consensus.Hooks.select
435	~context:(module Context)
436	~existing:root_consensus_state
UNCOV 437	~candidate:(With_hash.map ~f:consensus_state t) )	×
438	~error:`Not_selected_over_frontier_root
439	in
440	let%map () =
UNCOV 441	Result.ok_if_true	×
UNCOV 442	(is_block_in_frontier parent_hash)	×
443	~error:`Parent_missing_from_frontier
444	in
UNCOV 445	(t, Unsafe.set_valid_frontier_dependencies validation)	×
446
447	let skip_frontier_dependencies_validation
448	(_ :
449	[ `This_block_belongs_to_a_detached_subtree
450	\| `This_block_was_loaded_from_persistence ] ) (t, validation) =
UNCOV 451	(t, Unsafe.set_valid_frontier_dependencies validation)	×
452
453	let reset_frontier_dependencies_validation (transition_with_hash, validation) =
454	match validation with	6✔
455	\| ( time_received	6✔
456	, genesis_state
457	, proof
458	, delta_block_chain
459	, (`Frontier_dependencies, Truth.True ())
460	, staged_ledger_diff
461	, protocol_versions ) ->
462	( transition_with_hash
463	, ( time_received
464	, genesis_state
465	, proof
466	, delta_block_chain
467	, (`Frontier_dependencies, Truth.False)
468	, staged_ledger_diff
469	, protocol_versions ) )
470	\| _ ->	×
471	failwith "why can't this be refuted?"
472
473	let validate_staged_ledger_diff ?skip_staged_ledger_verification ~logger
474	~get_completed_work ~precomputed_values ~verifier ~parent_staged_ledger
475	~parent_protocol_state (t, validation) =
476	[%log internal] "Validate_staged_ledger_diff" ;	200✔
477	let block = With_hash.data t in	200✔
478	let header = Block.header block in	200✔
479	let protocol_state = Header.protocol_state header in	200✔
480	let blockchain_state = Protocol_state.blockchain_state protocol_state in	200✔
481	let consensus_state = Protocol_state.consensus_state protocol_state in	200✔
482	let global_slot = Consensus_state.global_slot_since_genesis consensus_state in	200✔
483	let body = Block.body block in	200✔
484	let apply_start_time = Core.Time.now () in	200✔
485	let body_ref_from_header = Blockchain_state.body_reference blockchain_state in	200✔
486	let body_ref_computed = Staged_ledger_diff.Body.compute_reference body in	200✔
487	let%bind.Deferred.Result () =
488	if Blake2.equal body_ref_computed body_ref_from_header then
489	Deferred.Result.return ()	200✔
490	else Deferred.Result.fail `Invalid_body_reference	×
491	in
492	let%bind.Deferred.Result ( `Hash_after_applying staged_ledger_hash
493	, `Ledger_proof proof_opt
494	, `Staged_ledger transitioned_staged_ledger
495	, `Pending_coinbase_update _ ) =
496	Staged_ledger.apply ?skip_verification:skip_staged_ledger_verification	200✔
497	~get_completed_work
498	~constraint_constants:
499	precomputed_values.Precomputed_values.constraint_constants ~global_slot
500	~logger ~verifier parent_staged_ledger
501	(Staged_ledger_diff.Body.staged_ledger_diff body)	200✔
502	~current_state_view:
503	Mina_state.Protocol_state.(Body.view @@ body parent_protocol_state)	200✔
504	~state_and_body_hash:
505	(let body_hash =
506	Protocol_state.(Body.hash @@ body parent_protocol_state)	200✔
507	in
508	( (Protocol_state.hashes_with_body parent_protocol_state ~body_hash)	200✔
509	.state_hash
510	, body_hash ) )
511	~coinbase_receiver:(Consensus_state.coinbase_receiver consensus_state)	200✔
512	~supercharge_coinbase:
513	(Consensus_state.supercharge_coinbase consensus_state)	200✔
514	~zkapp_cmd_limit_hardcap:
515	precomputed_values.Precomputed_values.genesis_constants
516	.zkapp_cmd_limit_hardcap
517	\|> Deferred.Result.map_error ~f:(fun e ->	200✔
518	`Staged_ledger_application_failed e )	×
519	in
520	[%log debug]	200✔
521	~metadata:
522	[ ( "time_elapsed"
523	, `Float Core.Time.(Span.to_ms @@ diff (now ()) apply_start_time) )	200✔
524	]
525	"Staged_ledger.apply takes $time_elapsed" ;
526	let snarked_ledger_hash =	200✔
527	match proof_opt with
528	\| None ->	200✔
529	(There was no proof emitted, snarked ledger hash shouldn't change)
530	Protocol_state.snarked_ledger_hash parent_protocol_state	200✔
531	\| Some (proof, _) ->	×
532	Ledger_proof.snarked_ledger_hash proof	×
533	in
534	let hash_errors =
535	Result.combine_errors_unit
536	[ ( if
537	Staged_ledger_hash.equal staged_ledger_hash
538	(Blockchain_state.staged_ledger_hash blockchain_state)	200✔
539	then Ok ()	200✔
540	else Error `Incorrect_target_staged_ledger_hash )	×
541	; ( if
542	Frozen_ledger_hash.equal snarked_ledger_hash
543	(Blockchain_state.snarked_ledger_hash blockchain_state)	200✔
544	then Ok ()	200✔
545	else Error `Incorrect_target_snarked_ledger_hash )	×
546	]
547	in
548	Deferred.return	200✔
549	@@
550	match hash_errors with
551	\| Ok () ->	200✔
552	Ok
553	( `Just_emitted_a_proof (Option.is_some proof_opt)	200✔
554	, `Block_with_validation
555	(t, Unsafe.set_valid_staged_ledger_diff validation)	200✔
556	, `Staged_ledger transitioned_staged_ledger )
557	\| Error errors ->	×
558	Error (`Invalid_staged_ledger_diff errors)
559
560	let validate_staged_ledger_hash
561	(`Staged_ledger_already_materialized staged_ledger_hash) (t, validation) =
UNCOV 562	let state =	×
UNCOV 563	t \|> With_hash.data \|> Block.header \|> Header.protocol_state	×
564	\|> Protocol_state.blockchain_state
565	in
UNCOV 566	if	×
567	Staged_ledger_hash.equal staged_ledger_hash
UNCOV 568	(Blockchain_state.staged_ledger_hash state)	×
UNCOV 569	then Ok (t, Unsafe.set_valid_staged_ledger_diff validation)	×
570	else Error `Staged_ledger_hash_mismatch	×
571
572	let skip_staged_ledger_diff_validation `This_block_has_a_trusted_staged_ledger
573	(t, validation) =
574	(t, Unsafe.set_valid_staged_ledger_diff validation)	×
575
576	let reset_staged_ledger_diff_validation (transition_with_hash, validation) =
577	match validation with	206✔
578	\| ( time_received	206✔
579	, genesis_state
580	, proof
581	, delta_block_chain
582	, frontier_dependencies
583	, (`Staged_ledger_diff, Truth.True ())
584	, protocol_versions ) ->
585	( transition_with_hash
586	, ( time_received
587	, genesis_state
588	, proof
589	, delta_block_chain
590	, frontier_dependencies
591	, (`Staged_ledger_diff, Truth.False)
592	, protocol_versions ) )
593	\| _ ->	×
594	failwith "why can't this be refuted?"
595
596	let validate_protocol_versions (t, validation) =
597	let { Header.valid_current; valid_next; matches_daemon } =	6✔
598	t \|> With_hash.data \|> Header.protocol_version_status	6✔
599	in
600	if not (valid_current && valid_next) then Error `Invalid_protocol_version	×
601	else if not matches_daemon then Error `Mismatched_protocol_version	×
602	else Ok (t, Unsafe.set_valid_protocol_versions validation)	6✔
603
604	let skip_protocol_versions_validation `This_block_has_valid_protocol_versions
605	(t, validation) =
606	(t, Unsafe.set_valid_protocol_versions validation)	×
607
608	let with_body (header_with_hash, validation) body =
609	( With_hash.map ~f:(fun header -> Block.create ~header ~body) header_with_hash	6✔
610	, validation )
611
612	let wrap_header t : fully_invalid_with_header = (t, fully_invalid)	×
613
614	let to_header (b, v) = (With_hash.map ~f:Block.header b, v)	2✔

MinaProtocol / mina / 2903

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous