MinaProtocol / mina / 767

Committed 04 Nov 2025 01:59PM UTC coverage: 32.374% (-4.5%) from 36.902%

Build # 767

Build Type

push

buildkite

Committed by

web-flow

Commit Message

Merge pull request #18063 from MinaProtocol/lyh/compat-into-dev-nov4-2025

Merge compatible into develop Nov. 4th 2025

Run Details

87 of 228 new or added lines in 10 files covered. (38.16%)

3416 existing lines in 136 files now uncovered.

23591 of 72871 relevant lines covered (32.37%)

26590.67 hits per line

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

2.33

/src/lib/network_pool/snark_pool_diff.ml

open Core_kernel
open Async_kernel
module Work = Transaction_snark_work.Statement
module Ledger_proof = Ledger_proof
module Work_info = Transaction_snark_work.Info
open Network_peer

module Rejected = struct
  [%%versioned
  module Stable = struct
    [@@@no_toplevel_latest_type]

    module V1 = struct
      type t = unit [@@deriving to_yojson]

      let to_latest = Fn.id
    end
  end]

  type t = Stable.Latest.t [@@deriving to_yojson]
end

module Make
    (Transition_frontier : T)
    (Pool : Intf.Snark_resource_pool_intf
              with type transition_frontier := Transition_frontier.t) :
  Intf.Snark_pool_diff_intf with type resource_pool := Pool.t = struct
  type t = Mina_wire_types.Network_pool.Snark_pool.Diff_versioned.V2.t =
    | Add_solved_work of Work.t * Ledger_proof.t One_or_two.t Priced_proof.t
    | Empty

  module Cached = struct
    type t =
      | Add_solved_work of
          Transaction_snark_work.Statement.t
          * Ledger_proof.Cached.t One_or_two.t Priced_proof.t
      | Empty

    let read_all_proofs_from_disk =
      let map_proofs =
        Priced_proof.map
          ~f:(One_or_two.map ~f:Ledger_proof.Cached.read_proof_from_disk)
      in
      function
      | Add_solved_work (work, proofs) ->
          Mina_wire_types.Network_pool.Snark_pool.Diff_versioned.V2
          .Add_solved_work
            (work, map_proofs proofs)
      | Empty ->
          Empty

    let write_all_proofs_to_disk ~proof_cache_db =
      let map_proofs =
        Priced_proof.map
          ~f:
            (One_or_two.map
               ~f:(Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db) )
      in
      function
      | Mina_wire_types.Network_pool.Snark_pool.Diff_versioned.V2
        .Add_solved_work (work, proofs) ->
          (Add_solved_work (work, map_proofs proofs) : t)
      | Empty ->
          Empty
  end

  type verified = Cached.t

  let t_of_verified = Cached.read_all_proofs_from_disk

  type rejected = Rejected.t

  let label = Pool.label

  let reject_overloaded_diff _ = ()

  type compact =
    { work_ids : int One_or_two.t
    ; fee : Currency.Fee.t
    ; prover : Signature_lib.Public_key.Compressed.t
    }
  [@@deriving yojson, hash]

  let to_compact = function
    | Add_solved_work (work, { proof = _; fee = { fee; prover } }) ->
        Some
          { work_ids = Transaction_snark_work.Statement.work_ids work
          ; fee
          ; prover
          }
    | Empty ->
        None

  let compact_json t = to_compact t |> Option.map ~f:compact_to_yojson

  let empty = Empty

  (* snark pool diffs are not bundled, so size is always 1 *)
  let size _ = 1

  let score = function
    | Add_solved_work (_w, p) ->
        One_or_two.length p.proof
    | Empty ->
        1

  (* Effectively disable rate limitting *)
  let max_per_15_seconds = 100000

  let summary = function
    | Add_solved_work (work, { proof = _; fee }) ->
        Printf.sprintf
          !"Snark_pool_diff for work %s added with fee-prover %s"
          (Yojson.Safe.to_string @@ Work.compact_json work)
          (Yojson.Safe.to_string @@ Mina_base.Fee_with_prover.to_yojson fee)
    | Empty ->
        "empty Snark_pool_diff"

  let is_empty _ = false

  let of_result
      (res :
        ( (_, _) Snark_work_lib.Work.Single.Spec.t Snark_work_lib.Work.Spec.t
        , Ledger_proof.t )
        Snark_work_lib.Work.Result.t ) =
    Add_solved_work
      ( One_or_two.map res.spec.instances
          ~f:Snark_work_lib.Work.Single.Spec.statement
      , { proof = res.proofs
        ; fee = { fee = res.spec.fee; prover = res.prover }
        } )

  (** Check whether there is a proof with lower fee in the pool.
      Returns [Ok ()] is the [~fee] would be the lowest in pool.
  *)
  let has_no_lower_fee pool work ~fee ~sender =
    let reject_and_log_if_local reason =
      [%log' trace (Pool.get_logger pool)]
        "Rejecting snark work $work from $sender: $reason"
        ~metadata:
          [ ("work", Work.compact_json work)
          ; ("sender", Envelope.Sender.to_yojson sender)
          ; ( "reason"
            , Error_json.error_to_yojson
              @@ Intf.Verification_error.to_error reason )
          ] ;
      Result.fail reason
    in
    match Pool.request_proof pool work with
    | None ->
        Ok ()
    | Some { fee = { fee = prev; _ }; _ } ->
        let cmp_res = Currency.Fee.compare fee prev in
        if cmp_res < 0 then Ok ()
        else if cmp_res = 0 then
          reject_and_log_if_local Intf.Verification_error.Fee_equal
        else reject_and_log_if_local Intf.Verification_error.Fee_higher

  let verify pool ({ data; sender; _ } as t : t Envelope.Incoming.t) =
    match data with
    | Empty ->
        Deferred.Result.fail
        @@ Intf.Verification_error.Invalid
             (Error.of_string "empty snark pool diff")
    | Add_solved_work (work, ({ Priced_proof.fee; _ } as p)) ->
        let is_local = match sender with Local -> true | _ -> false in
        let open Deferred.Result in
        let cache_t () =
          Envelope.Incoming.map
            ~f:
              (Cached.write_all_proofs_to_disk
                 ~proof_cache_db:(Pool.proof_cache_db pool) )
            t
        in
        let verify () =
          Pool.verify_and_act pool ~work:(work, p) ~sender >>| cache_t
        in
        (*reject higher priced gossiped proofs*)
        if is_local then verify ()
        else
          Deferred.return (has_no_lower_fee pool work ~fee:fee.fee ~sender)
          >>= verify

  (* This is called after verification has occurred.*)
  let unsafe_apply (pool : Pool.t) (t : Cached.t Envelope.Incoming.t) =
    let { Envelope.Incoming.data = diff; sender; _ } = t in
    match diff with
    | Empty ->
        Error (`Other (Error.of_string "cannot apply empty snark pool diff"))
    | Add_solved_work (work, { Priced_proof.proof; fee }) -> (
        let is_local = match sender with Local -> true | _ -> false in
        let to_or_error = function
          | `Statement_not_referenced ->
              Error (`Other (Error.of_string "statement not referenced"))
          | `Added ->
              Ok (diff, ())
        in
        match has_no_lower_fee pool work ~fee:fee.fee ~sender with
        | Ok () ->
            let%map.Result accepted, rejected =
              Pool.add_snark ~is_local pool ~work ~proof ~fee |> to_or_error
            in
            (`Accept, Cached.read_all_proofs_from_disk accepted, rejected)
        | Error e ->
            if is_local then
              Error
                (`Locally_generated (Cached.read_all_proofs_from_disk diff, ()))
            else Error (`Other (Intf.Verification_error.to_error e)) )

  type Structured_log_events.t +=
    | Snark_work_received of { work : compact; sender : Envelope.Sender.t }
    [@@deriving
      register_event { msg = "Received Snark-pool diff $work from $sender" }]

  let update_metrics ~logger ~log_gossip_heard
      (Envelope.Incoming.{ data = diff; sender; _ } : t Envelope.Incoming.t)
      valid_cb =
    Mina_metrics.(Counter.inc_one Network.gossip_messages_received) ;
    Mina_metrics.(Gauge.inc_one Network.snark_pool_diff_received) ;
    if log_gossip_heard then
      Option.iter (to_compact diff) ~f:(fun work ->
          [%str_log debug] (Snark_work_received { work; sender }) ) ;
    Mina_metrics.(Counter.inc_one Network.Snark_work.received) ;
    Mina_net2.Validation_callback.set_message_type valid_cb `Snark_work

  let log_internal ?reason ~logger msg = function
    | { Envelope.Incoming.data = Empty; _ } ->
        ()
    | { data = Add_solved_work (work, { fee = { fee; prover }; _ }); sender; _ }
      ->
        let metadata =
          [ ("work_ids", Transaction_snark_work.Statement.compact_json work)
          ; ("fee", Currency.Fee.to_yojson fee)
          ; ("prover", Signature_lib.Public_key.Compressed.to_yojson prover)
          ]
        in
        let metadata =
          match sender with
          | Remote addr ->
              ("sender", `String (Core.Unix.Inet_addr.to_string @@ Peer.ip addr))
              :: metadata
          | Local ->
              metadata
        in
        let metadata =
          Option.value_map reason
            ~f:(fun r -> List.cons ("reason", `String r))
            ~default:ident metadata
        in
        [%log internal] "%s" ("Snark_work_" ^ msg) ~metadata
end

1	open Core_kernel	122✔
2	open Async_kernel
3	module Work = Transaction_snark_work.Statement
4	module Ledger_proof = Ledger_proof
5	module Work_info = Transaction_snark_work.Info
6	open Network_peer
7
8	module Rejected = struct
9	[%%versioned
10	module Stable = struct
11	[@@@no_toplevel_latest_type]
12
13	module V1 = struct
14	type t = unit [@@deriving to_yojson]	×
15
16	let to_latest = Fn.id
17	end
18	end]
19
20	type t = Stable.Latest.t [@@deriving to_yojson]	×
21	end
22
23	module Make
24	(Transition_frontier : T)
25	(Pool : Intf.Snark_resource_pool_intf
26	with type transition_frontier := Transition_frontier.t) :
27	Intf.Snark_pool_diff_intf with type resource_pool := Pool.t = struct
28	type t = Mina_wire_types.Network_pool.Snark_pool.Diff_versioned.V2.t =
29	\| Add_solved_work of Work.t * Ledger_proof.t One_or_two.t Priced_proof.t
30	\| Empty
31
32	module Cached = struct
33	type t =
34	\| Add_solved_work of
35	Transaction_snark_work.Statement.t
36	* Ledger_proof.Cached.t One_or_two.t Priced_proof.t
37	\| Empty
38
39	let read_all_proofs_from_disk =
40	let map_proofs =
41	Priced_proof.map
42	~f:(One_or_two.map ~f:Ledger_proof.Cached.read_proof_from_disk)
43	in
44	function
45	\| Add_solved_work (work, proofs) ->	×
46	Mina_wire_types.Network_pool.Snark_pool.Diff_versioned.V2
47	.Add_solved_work
48	(work, map_proofs proofs)	×
49	\| Empty ->	×
50	Empty
51
52	let write_all_proofs_to_disk ~proof_cache_db =
53	let map_proofs =	×
54	Priced_proof.map
55	~f:
56	(One_or_two.map
57	~f:(Ledger_proof.Cached.write_proof_to_disk ~proof_cache_db) )
58	in
59	function
60	\| Mina_wire_types.Network_pool.Snark_pool.Diff_versioned.V2	×
61	.Add_solved_work (work, proofs) ->
62	(Add_solved_work (work, map_proofs proofs) : t)	×
63	\| Empty ->	×
64	Empty
65	end
66
67	type verified = Cached.t
68
69	let t_of_verified = Cached.read_all_proofs_from_disk
70
71	type rejected = Rejected.t
72
73	let label = Pool.label
74
75	let reject_overloaded_diff _ = ()	×
76
77	type compact =	×
78	{ work_ids : int One_or_two.t	×
79	; fee : Currency.Fee.t	×
80	; prover : Signature_lib.Public_key.Compressed.t	×
81	}
82	[@@deriving yojson, hash]	×
83
84	let to_compact = function
85	\| Add_solved_work (work, { proof = _; fee = { fee; prover } }) ->	×
86	Some
87	{ work_ids = Transaction_snark_work.Statement.work_ids work	×
88	; fee
89	; prover
90	}
91	\| Empty ->	×
92	None
93
94	let compact_json t = to_compact t \|> Option.map ~f:compact_to_yojson	×
95
96	let empty = Empty
97
98	(* snark pool diffs are not bundled, so size is always 1 *)
99	let size _ = 1	×
100
101	let score = function
102	\| Add_solved_work (_w, p) ->	×
103	One_or_two.length p.proof
104	\| Empty ->	×
105	1
106
107	(* Effectively disable rate limitting *)
108	let max_per_15_seconds = 100000
109
110	let summary = function
111	\| Add_solved_work (work, { proof = _; fee }) ->	×
112	Printf.sprintf
113	!"Snark_pool_diff for work %s added with fee-prover %s"
114	(Yojson.Safe.to_string @@ Work.compact_json work)	×
115	(Yojson.Safe.to_string @@ Mina_base.Fee_with_prover.to_yojson fee)	×
116	\| Empty ->	×
117	"empty Snark_pool_diff"
118
119	let is_empty _ = false	×
120
121	let of_result
122	(res :
123	( (_, _) Snark_work_lib.Work.Single.Spec.t Snark_work_lib.Work.Spec.t
124	, Ledger_proof.t )
125	Snark_work_lib.Work.Result.t ) =
126	Add_solved_work	×
127	( One_or_two.map res.spec.instances	×
128	~f:Snark_work_lib.Work.Single.Spec.statement
129	, { proof = res.proofs
130	; fee = { fee = res.spec.fee; prover = res.prover }
131	} )
132
133	(** Check whether there is a proof with lower fee in the pool.
134	Returns [Ok ()] is the [~fee] would be the lowest in pool.
135	*)
136	let has_no_lower_fee pool work ~fee ~sender =
137	let reject_and_log_if_local reason =	×
138	[%log' trace (Pool.get_logger pool)]	×
139	"Rejecting snark work $work from $sender: $reason"
140	~metadata:
141	[ ("work", Work.compact_json work)	×
142	; ("sender", Envelope.Sender.to_yojson sender)	×
143	; ( "reason"
144	, Error_json.error_to_yojson	×
145	@@ Intf.Verification_error.to_error reason )	×
146	] ;
147	Result.fail reason	×
148	in
149	match Pool.request_proof pool work with
150	\| None ->	×
151	Ok ()
152	\| Some { fee = { fee = prev; _ }; _ } ->	×
153	let cmp_res = Currency.Fee.compare fee prev in
154	if cmp_res < 0 then Ok ()	×
155	else if cmp_res = 0 then	×
156	reject_and_log_if_local Intf.Verification_error.Fee_equal	×
157	else reject_and_log_if_local Intf.Verification_error.Fee_higher	×
158
159	let verify pool ({ data; sender; _ } as t : t Envelope.Incoming.t) =
160	match data with	×
161	\| Empty ->	×
162	Deferred.Result.fail
163	@@ Intf.Verification_error.Invalid
164	(Error.of_string "empty snark pool diff")	×
165	\| Add_solved_work (work, ({ Priced_proof.fee; _ } as p)) ->	×
166	let is_local = match sender with Local -> true \| _ -> false in	×
167	let open Deferred.Result in
168	let cache_t () =
169	Envelope.Incoming.map	×
170	~f:
171	(Cached.write_all_proofs_to_disk
172	~proof_cache_db:(Pool.proof_cache_db pool) )	×
173	t
174	in
175	let verify () =
176	Pool.verify_and_act pool ~work:(work, p) ~sender >>\| cache_t	×
177	in
178	(reject higher priced gossiped proofs)
179	if is_local then verify ()	×
180	else
181	Deferred.return (has_no_lower_fee pool work ~fee:fee.fee ~sender)	×
182	>>= verify
183
184	(* This is called after verification has occurred.*)
185	let unsafe_apply (pool : Pool.t) (t : Cached.t Envelope.Incoming.t) =
186	let { Envelope.Incoming.data = diff; sender; _ } = t in	×
187	match diff with
188	\| Empty ->	×
189	Error (`Other (Error.of_string "cannot apply empty snark pool diff"))	×
190	\| Add_solved_work (work, { Priced_proof.proof; fee }) -> (	×
191	let is_local = match sender with Local -> true \| _ -> false in	×
192	let to_or_error = function
193	\| `Statement_not_referenced ->	×
194	Error (`Other (Error.of_string "statement not referenced"))	×
195	\| `Added ->	×
196	Ok (diff, ())
197	in
198	match has_no_lower_fee pool work ~fee:fee.fee ~sender with
199	\| Ok () ->	×
200	let%map.Result accepted, rejected =
201	Pool.add_snark ~is_local pool ~work ~proof ~fee \|> to_or_error	×
202	in
203	(`Accept, Cached.read_all_proofs_from_disk accepted, rejected)	×
204	\| Error e ->	×
205	if is_local then
206	Error	×
207	(`Locally_generated (Cached.read_all_proofs_from_disk diff, ()))	×
208	else Error (`Other (Intf.Verification_error.to_error e)) )	×
209
210	type Structured_log_events.t +=
211	\| Snark_work_received of { work : compact; sender : Envelope.Sender.t }	×
212	[@@deriving
UNCOV 213	register_event { msg = "Received Snark-pool diff $work from $sender" }]	×
214
215	let update_metrics ~logger ~log_gossip_heard
216	(Envelope.Incoming.{ data = diff; sender; _ } : t Envelope.Incoming.t)
217	valid_cb =
218	Mina_metrics.(Counter.inc_one Network.gossip_messages_received) ;	×
219	Mina_metrics.(Gauge.inc_one Network.snark_pool_diff_received) ;	×
220	if log_gossip_heard then
221	Option.iter (to_compact diff) ~f:(fun work ->	×
222	[%str_log debug] (Snark_work_received { work; sender }) ) ;	×
223	Mina_metrics.(Counter.inc_one Network.Snark_work.received) ;	×
224	Mina_net2.Validation_callback.set_message_type valid_cb `Snark_work
225
226	let log_internal ?reason ~logger msg = function
227	\| { Envelope.Incoming.data = Empty; _ } ->	×
228	()
229	\| { data = Add_solved_work (work, { fee = { fee; prover }; _ }); sender; _ }	×
230	->
231	let metadata =
232	[ ("work_ids", Transaction_snark_work.Statement.compact_json work)	×
233	; ("fee", Currency.Fee.to_yojson fee)	×
234	; ("prover", Signature_lib.Public_key.Compressed.to_yojson prover)	×
235	]
236	in
237	let metadata =
238	match sender with
239	\| Remote addr ->	×
240	("sender", `String (Core.Unix.Inet_addr.to_string @@ Peer.ip addr))	×
241	:: metadata
242	\| Local ->	×
243	metadata
244	in
245	let metadata =
246	Option.value_map reason
247	~f:(fun r -> List.cons ("reason", `String r))	×
248	~default:ident metadata
249	in
250	[%log internal] "%s" ("Snark_work_" ^ msg) ~metadata	×
251	end	122✔

MinaProtocol / mina / 767

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