1518

Committed 14 Jul 2026 09:34PM UTC coverage: 33.341% (-1.1%) from 34.396%

Build # 1518

Build Type

push

buildkite

Committed by

web-flow

Commit Message

Merge pull request #19075 from MinaProtocol/dkijania/port-toolbox-sql-fix

port https://github.com/MinaProtocol/mina/pull/19057 to dev

Coverage Stats

25558 of 76656 relevant lines covered (33.34%)

14736.96 hits per line

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

42.5

/src/app/archive_hardfork_toolbox/sql.ml

open Async
open Core
open Caqti_request.Infix

module type CONNECTION = Mina_caqti.CONNECTION

module Protocol_version = struct
  type t = { transaction : int; network : int; patch : int } [@@deriving equal]

  let of_string : string -> t = function
    | version_str -> (
        try
          Scanf.sscanf version_str "%d.%d.%d" (fun transaction network patch ->
              { transaction; network; patch } )
        with _ ->
          failwithf
            "Invalid protocol version string: %s. Expected format \
             <network>.<transaction>.<patch>"
            version_str () )

  let to_string { transaction; network; patch } =
    sprintf "%d.%d.%d" transaction network patch

  let typ =
    let encode { transaction; network; patch } =
      Ok (transaction, network, patch)
    in
    let decode (transaction, network, patch) =
      Ok { transaction; network; patch }
    in
    Caqti_type.(custom ~encode ~decode (t3 int int int))
end

module Block_info = struct
  type t =
    { id : int
    ; height : int64
    ; state_hash : string
    ; protocol_version : Protocol_version.t
    }

  let typ =
    let encode { id; height; state_hash; protocol_version } =
      Ok (id, height, state_hash, protocol_version)
    in
    let decode (id, height, state_hash, protocol_version) =
      Ok { id; height; state_hash; protocol_version }
    in
    Caqti_type.(
      custom ~encode ~decode (t4 int int64 string Protocol_version.typ))
end

let chain_of_query_templated ~start_condition ~join_condition =
  {%string|
    WITH RECURSIVE chain AS (
        SELECT
            b.id AS id,
            b.parent_id AS parent_id,
            b.state_hash AS state_hash,
            b.height AS height,
            b.global_slot_since_genesis AS global_slot_since_genesis,
            b.protocol_version_id AS protocol_version_id
        FROM blocks b
        WHERE %{start_condition}

        UNION ALL

        SELECT
            p.id,
            p.parent_id,
            p.state_hash,
            p.height,
            p.global_slot_since_genesis,
            p.protocol_version_id
        FROM blocks p
        JOIN chain c ON p.id = c.parent_id AND %{join_condition} AND c.parent_id IS NOT NULL
    )
  |}

let chain_of_query =
  chain_of_query_templated ~start_condition:"b.state_hash = $1"
    ~join_condition:"TRUE"

let chain_of_query_until_inclusive =
  chain_of_query_templated ~start_condition:"b.id = $1"
    ~join_condition:"c.id <> $2"

let latest_state_hash (module Conn : CONNECTION) =
  let query =
    Caqti_type.(unit ->! string)
      {%string|
        SELECT state_hash from blocks order by height desc limit 1;
      |}
  in
  Conn.find query ()

(* Returns the first block of a specific protocol version.
   NOTE: There exists some emergency HF that doesn't bump up protocol version. *)
let first_block_of_protocol_version (module Conn : CONNECTION)
    ~(v : Protocol_version.t) =
  let query =
    (Protocol_version.typ ->? Block_info.typ)
      {%string|
        SELECT blocks.id, height, state_hash, protocol_versions.transaction, protocol_versions.network, protocol_versions.patch
        FROM blocks INNER JOIN protocol_versions
          ON blocks.protocol_version_id = protocol_versions.id
        WHERE protocol_versions.transaction = $1::int
          AND protocol_versions.network = $2::int
          AND protocol_versions.patch = $3::int
          AND global_slot_since_hard_fork = 0
        ORDER BY id ASC
        LIMIT 1;
      |}
  in
  Conn.find_opt query v

let block_info_by_state_hash (module Conn : CONNECTION) ~state_hash =
  let query =
    Caqti_type.(string ->? Block_info.typ)
      {%string|
        SELECT blocks.id, height, state_hash, protocol_versions.transaction, protocol_versions.network, protocol_versions.patch
        FROM blocks INNER JOIN protocol_versions
          ON blocks.protocol_version_id = protocol_versions.id
        WHERE state_hash = ?
        LIMIT 1;
      |}
  in
  Conn.find_opt query state_hash

let blocks_info_by_height (module Conn : CONNECTION) ~height =
  let query =
    Caqti_type.(int64 ->* Block_info.typ)
      {%string|
        SELECT blocks.id, height, state_hash, protocol_versions.transaction, protocol_versions.network, protocol_versions.patch
        FROM blocks INNER JOIN protocol_versions
          ON blocks.protocol_version_id = protocol_versions.id
        WHERE height = ?;
      |}
  in
  Conn.collect_list query height

(* Auto-detect the latest hard-fork boundary: the parent of the highest hard-fork
   block (global_slot_since_hard_fork = 0). The genesis block also has
   global_slot_since_hard_fork = 0 but has no parent, so it is excluded. The
   returned block is the last pre-fork block that should remain canonical, and its
   protocol version is the pre-fork one whose chain we want to finalize. *)
let parent_of_latest_fork_block (module Conn : CONNECTION) =
  let query =
    Caqti_type.(unit ->? Block_info.typ)
      {%string|
        SELECT parent.id, parent.height, parent.state_hash, pv.transaction, pv.network, pv.patch
        FROM blocks fork
        INNER JOIN blocks parent ON parent.id = fork.parent_id
        INNER JOIN protocol_versions pv ON parent.protocol_version_id = pv.id
        WHERE fork.global_slot_since_hard_fork = 0
          AND fork.parent_id IS NOT NULL
        ORDER BY fork.height DESC
        LIMIT 1;
      |}
  in
  Conn.find_opt query ()

(* Context about the hard fork just above the target: the post-fork genesis block
   (global_slot_since_hard_fork = 0) and its parent (the last pre-fork block). *)
module Fork_context = struct
  type t =
    { fork_state_hash : string
    ; fork_height : int64
    ; fork_slot : int64
    ; fork_chain_status : string
    ; parent_state_hash : string option
    ; parent_height : int64 option
    }

  let typ =
    let encode
        { fork_state_hash
        ; fork_height
        ; fork_slot
        ; fork_chain_status
        ; parent_state_hash
        ; parent_height
        } =
      Ok
        ( (fork_state_hash, fork_height, fork_slot)
        , (fork_chain_status, parent_state_hash, parent_height) )
    in
    let decode
        ( (fork_state_hash, fork_height, fork_slot)
        , (fork_chain_status, parent_state_hash, parent_height) ) =
      Ok
        { fork_state_hash
        ; fork_height
        ; fork_slot
        ; fork_chain_status
        ; parent_state_hash
        ; parent_height
        }
    in
    Caqti_type.(
      custom ~encode ~decode
        (t2 (t3 string int64 int64) (t3 string (option string) (option int64))))
end

(* The first hard-fork block (global_slot_since_hard_fork = 0) strictly above the
   target height, i.e. the post-fork genesis, together with its parent. Its slot
   is used as an upper bound for orphaning so that, when the fork does NOT bump the
   protocol version (some emergency hard forks), the post-fork chain — which shares
   the protocol version with the pre-fork chain — is not orphaned. Returns None
   when there is no hard fork above the target (e.g. the tip is pre-fork). *)
let fork_block_above_height (module Conn : CONNECTION) ~height =
  let query =
    Caqti_type.(int64 ->? Fork_context.typ)
      {%string|
        SELECT fork.state_hash, fork.height, fork.global_slot_since_genesis,
               fork.chain_status::text, parent.state_hash, parent.height
        FROM blocks fork
        LEFT JOIN blocks parent ON parent.id = fork.parent_id
        WHERE fork.global_slot_since_hard_fork = 0
          AND fork.height > ?
        ORDER BY fork.global_slot_since_genesis ASC
        LIMIT 1;
      |}
  in
  Conn.find_opt query height

(* The blocks that will be orphaned: same protocol version, below the fork
   boundary and within the slot filter, not on the canonical chain to the target,
   and not already orphaned. These are the competing / leftover blocks. *)
let blocks_to_orphan (module Conn : CONNECTION) ~canonical_block_ids
    ~stop_at_slot ~fork_boundary_slot ~protocol_version =
  let query =
    Caqti_type.(
      t4 (option int) Mina_caqti.array_int_typ Protocol_version.typ
        (option int64)
      ->* t3 int64 string string)
      {%string|
        SELECT height, state_hash, chain_status::text
        FROM blocks
        WHERE ($1 IS NULL OR $1::int <= global_slot_since_genesis)
          AND ($6 IS NULL OR global_slot_since_genesis < $6::bigint)
          AND NOT (id = ANY($2::int[]))
          AND chain_status <> 'orphaned'::chain_status_type
          AND protocol_version_id = (
            SELECT id FROM protocol_versions
            WHERE transaction = $3::int
              AND network = $4::int
              AND patch = $5::int
            LIMIT 1
          )
        ORDER BY height ASC;
      |}
  in
  Conn.collect_list query
    ( stop_at_slot
    , Array.of_list canonical_block_ids
    , protocol_version
    , fork_boundary_slot )

(* Counts, over the blocks the conversion would touch (subject to the same slot
   and fork-boundary filters as the mutation), how many would become orphaned and
   how many currently-pending blocks change status in each direction. *)
let conversion_summary_counts (module Conn : CONNECTION) ~canonical_block_ids
    ~stop_at_slot ~fork_boundary_slot ~protocol_version =
  let query =
    Caqti_type.(
      t4 (option int) Mina_caqti.array_int_typ Protocol_version.typ
        (option int64)
      ->! t3 int int int)
      {%string|
        SELECT
          COUNT(*) FILTER (WHERE NOT (id = ANY($2::int[])))::int,
          COUNT(*) FILTER (WHERE chain_status = 'pending'::chain_status_type
                             AND id = ANY($2::int[]))::int,
          COUNT(*) FILTER (WHERE chain_status = 'pending'::chain_status_type
                             AND NOT (id = ANY($2::int[])))::int
        FROM blocks
        WHERE ($1 IS NULL OR $1::int <= global_slot_since_genesis)
          AND ($6 IS NULL OR global_slot_since_genesis < $6::bigint)
          AND protocol_version_id = (
            SELECT id FROM protocol_versions
            WHERE transaction = $3::int
              AND network = $4::int
              AND patch = $5::int
            LIMIT 1
          );
      |}
  in
  Conn.find query
    ( stop_at_slot
    , Array.of_list canonical_block_ids
    , protocol_version
    , fork_boundary_slot )

(* The blocks in the canonical set that are NOT already canonical, i.e. the ones
   actually being healed. Used to print a concise, meaningful list instead of the
   whole ancestry (most of which is already canonical). *)
let noncanonical_blocks_in_set (module Conn : CONNECTION) ~canonical_block_ids =
  let query =
    Caqti_type.(Mina_caqti.array_int_typ ->* t3 int64 string string)
      {%string|
        SELECT height, state_hash, chain_status::text
        FROM blocks
        WHERE id = ANY(?::int[])
          AND chain_status <> 'canonical'::chain_status_type
        ORDER BY height ASC;
      |}
  in
  Conn.collect_list query (Array.of_list canonical_block_ids)

let mark_pending_blocks_as_canonical_or_orphaned (module Conn : CONNECTION)
    ~canonical_block_ids ~stop_at_slot ~fork_boundary_slot ~protocol_version =
  let mutation =
    Caqti_type.(
      t4 (option int) Mina_caqti.array_int_typ Protocol_version.typ
        (option int64)
      ->. Caqti_type.unit)
      {%string|
        UPDATE blocks
        SET chain_status = CASE
            WHEN id = ANY($2::int[]) THEN 'canonical'::chain_status_type
            ELSE 'orphaned'::chain_status_type
        END
        WHERE ($1 IS NULL OR $1::int <= global_slot_since_genesis)
          -- Never touch blocks at or beyond the fork boundary: when the fork does
          -- not bump the protocol version, those are the post-fork chain and must
          -- stay canonical. Canonical-set members are always pre-fork, so the
          -- extra clause keeps them included.
          AND (id = ANY($2::int[])
               OR $6 IS NULL
               OR global_slot_since_genesis < $6::bigint)
          AND protocol_version_id = (
            SELECT id FROM protocol_versions
            WHERE transaction = $3::int
              AND network = $4::int
              AND patch = $5::int
            LIMIT 1
          );
      |}
  in
  Conn.exec mutation
    ( stop_at_slot
    , Array.of_list canonical_block_ids
    , protocol_version
    , fork_boundary_slot )

let blocks_between_both_inclusive (module Conn : CONNECTION) ~latest_block_id
    ~oldest_block_id : (Block_info.t list, Caqti_error.t) Deferred.Result.t =
  let query =
    Caqti_type.(t2 int int ->* Block_info.typ)
      {%string|
        %{chain_of_query_until_inclusive}
        SELECT chain.id, height, state_hash, protocol_versions.transaction, protocol_versions.network, protocol_versions.patch
        FROM chain INNER JOIN protocol_versions
          ON chain.protocol_version_id = protocol_versions.id
        ORDER BY height ASC
      |}
  in
  Conn.collect_list query (latest_block_id, oldest_block_id)

let is_in_best_chain (module Conn : CONNECTION) ~tip_hash ~check_hash
    ~check_height ~check_slot =
  let query =
    Caqti_type.(t4 string string int int64 ->! bool)
      {%string|
        %{chain_of_query}
        SELECT EXISTS (
          SELECT 1 FROM chain
          WHERE state_hash = $2
            AND height = $3
            AND global_slot_since_genesis = $4
        );
      |}
  in
  Conn.find query (tip_hash, check_hash, check_height, check_slot)

let num_of_confirmations (module Conn : CONNECTION) ~latest_state_hash
    ~fork_slot =
  let query =
    Caqti_type.(t2 string int ->! int)
      {%string|
        %{chain_of_query}
        SELECT COUNT(*) FROM chain
        WHERE global_slot_since_genesis > $2;
      |}
  in
  Conn.find query (latest_state_hash, fork_slot)

let number_of_commands_since_block_query block_commands_table =
  Caqti_type.(t2 string int ->! int)
    {%string|
      %{chain_of_query}
      SELECT COUNT(bc.block_id)::int AS command_count
      FROM chain
      LEFT JOIN %{block_commands_table} bc
          ON chain.id = bc.block_id
      WHERE chain.global_slot_since_genesis > $2;
    |}

let number_of_user_commands_since_block (module Conn : CONNECTION)
    ~fork_state_hash ~fork_slot =
  Conn.find
    (number_of_commands_since_block_query "blocks_user_commands")
    (fork_state_hash, fork_slot)

let number_of_internal_commands_since_block (module Conn : CONNECTION)
    ~fork_state_hash ~fork_slot =
  Conn.find
    (number_of_commands_since_block_query "blocks_internal_commands")
    (fork_state_hash, fork_slot)

let number_of_zkapps_commands_since_block (module Conn : CONNECTION)
    ~fork_state_hash ~fork_slot =
  Conn.find
    (number_of_commands_since_block_query "blocks_zkapp_commands")
    (fork_state_hash, fork_slot)

let last_fork_block (module Conn : CONNECTION) =
  let query =
    Caqti_type.(unit ->! t2 string int64)
      {%string|
        SELECT state_hash, global_slot_since_genesis FROM blocks
        WHERE global_slot_since_hard_fork = 0
        ORDER BY height DESC
        LIMIT 1;
      |}
  in
  Conn.find query ()

let fetch_latest_migration_history (module Conn : CONNECTION) =
  let query =
    Caqti_type.(unit ->? t3 string string string)
      {%string|
        SELECT
          status, protocol_version, migration_version
        FROM migration_history
        ORDER BY commit_start_at DESC
        LIMIT 1;
      |}
  in
  Conn.find_opt query ()

(* Fetches last filled block before stop transaction slot.

   Every block in mina should have internal commands since system transactions (like coinbase, fee transfer etc)
   are implemented as internal commands. It CAN have zero user commands and zero zkapp commands,
   but it should have internal commands.

   However, in context of hard fork, we want to stop including any transactions
   in the blocks after specified slot (called stop transaction slot). No internal, user or zkapp commands should be included in the blocks after that slot.
   Blocks can still be produced with no transactions, to keep chain progressing and give us confirmations but
   only from stop transaction slot till stop network slot, where we completely stop the chain.
   Knowing above we can detect last filled block by only looking at internal transactions occurrence.
   Therefore our fork candidate is the block with highest height that has internal transaction included in it.
*)

let fetch_last_filled_block (module Conn : CONNECTION) =
  let query =
    Caqti_type.(unit ->! t3 string int64 int)
      {%string|
        SELECT b.state_hash, b.global_slot_since_genesis, b.height
        FROM blocks b
        INNER JOIN blocks_internal_commands bic ON b.id = bic.block_id
        ORDER BY b.height DESC
        LIMIT 1;
      |}
  in
  Conn.find query ()

1	open Async
2	open Core
3	open Caqti_request.Infix
4
5	module type CONNECTION = Mina_caqti.CONNECTION
6
7	module Protocol_version = struct
8	type t = { transaction : int; network : int; patch : int } [@@deriving equal]	×
9
10	let of_string : string -> t = function
11	\| version_str -> (	×
12	try
13	Scanf.sscanf version_str "%d.%d.%d" (fun transaction network patch ->	×
14	{ transaction; network; patch } )	×
15	with _ ->	×
16	failwithf
17	"Invalid protocol version string: %s. Expected format \
18	<network>.<transaction>.<patch>"
19	version_str () )
20
21	let to_string { transaction; network; patch } =
22	sprintf "%d.%d.%d" transaction network patch	×
23
24	let typ =
25	let encode { transaction; network; patch } =
26	Ok (transaction, network, patch)	×
27	in
28	let decode (transaction, network, patch) =
29	Ok { transaction; network; patch }	2✔
30	in
31	Caqti_type.(custom ~encode ~decode (t3 int int int))	11✔
32	end
33
34	module Block_info = struct
35	type t =
36	{ id : int
37	; height : int64
38	; state_hash : string
39	; protocol_version : Protocol_version.t
40	}
41
42	let typ =
43	let encode { id; height; state_hash; protocol_version } =
44	Ok (id, height, state_hash, protocol_version)	×
45	in
46	let decode (id, height, state_hash, protocol_version) =
47	Ok { id; height; state_hash; protocol_version }	2✔
48	in
49	Caqti_type.(
50	custom ~encode ~decode (t4 int int64 string Protocol_version.typ))	11✔
51	end
52
53	let chain_of_query_templated ~start_condition ~join_condition =
54	{%string\|
55	WITH RECURSIVE chain AS (
56	SELECT
57	b.id AS id,
58	b.parent_id AS parent_id,
59	b.state_hash AS state_hash,
60	b.height AS height,
61	b.global_slot_since_genesis AS global_slot_since_genesis,
62	b.protocol_version_id AS protocol_version_id
63	FROM blocks b
64	WHERE %{start_condition}
65
66	UNION ALL
67
68	SELECT
69	p.id,
70	p.parent_id,
71	p.state_hash,
72	p.height,
73	p.global_slot_since_genesis,
74	p.protocol_version_id
75	FROM blocks p
76	JOIN chain c ON p.id = c.parent_id AND %{join_condition} AND c.parent_id IS NOT NULL
77	)
78	\|}
79
80	let chain_of_query =
81	chain_of_query_templated ~start_condition:"b.state_hash = $1"
82	~join_condition:"TRUE"
83
84	let chain_of_query_until_inclusive =
85	chain_of_query_templated ~start_condition:"b.id = $1"
86	~join_condition:"c.id <> $2"
87
88	let latest_state_hash (module Conn : CONNECTION) =
89	let query =	2✔
90	Caqti_type.(unit ->! string)	2✔
91	{%string\|
92	SELECT state_hash from blocks order by height desc limit 1;
93	\|}
94	in
95	Conn.find query ()	2✔
96
97	(* Returns the first block of a specific protocol version.
98	NOTE: There exists some emergency HF that doesn't bump up protocol version. *)
99	let first_block_of_protocol_version (module Conn : CONNECTION)
100	~(v : Protocol_version.t) =
101	let query =	×
102	(Protocol_version.typ ->? Block_info.typ)	×
103	{%string\|
104	SELECT blocks.id, height, state_hash, protocol_versions.transaction, protocol_versions.network, protocol_versions.patch
105	FROM blocks INNER JOIN protocol_versions
106	ON blocks.protocol_version_id = protocol_versions.id
107	WHERE protocol_versions.transaction = $1::int
108	AND protocol_versions.network = $2::int
109	AND protocol_versions.patch = $3::int
110	AND global_slot_since_hard_fork = 0
111	ORDER BY id ASC
112	LIMIT 1;
113	\|}
114	in
115	Conn.find_opt query v	×
116
117	let block_info_by_state_hash (module Conn : CONNECTION) ~state_hash =
118	let query =	2✔
119	Caqti_type.(string ->? Block_info.typ)	2✔
120	{%string\|
121	SELECT blocks.id, height, state_hash, protocol_versions.transaction, protocol_versions.network, protocol_versions.patch
122	FROM blocks INNER JOIN protocol_versions
123	ON blocks.protocol_version_id = protocol_versions.id
124	WHERE state_hash = ?
125	LIMIT 1;
126	\|}
127	in
128	Conn.find_opt query state_hash	2✔
129
130	let blocks_info_by_height (module Conn : CONNECTION) ~height =
131	let query =	×
132	Caqti_type.(int64 ->* Block_info.typ)	×
133	{%string\|
134	SELECT blocks.id, height, state_hash, protocol_versions.transaction, protocol_versions.network, protocol_versions.patch
135	FROM blocks INNER JOIN protocol_versions
136	ON blocks.protocol_version_id = protocol_versions.id
137	WHERE height = ?;
138	\|}
139	in
140	Conn.collect_list query height	×
141
142	(* Auto-detect the latest hard-fork boundary: the parent of the highest hard-fork
143	block (global_slot_since_hard_fork = 0). The genesis block also has
144	global_slot_since_hard_fork = 0 but has no parent, so it is excluded. The
145	returned block is the last pre-fork block that should remain canonical, and its
146	protocol version is the pre-fork one whose chain we want to finalize. *)
147	let parent_of_latest_fork_block (module Conn : CONNECTION) =
148	let query =	×
149	Caqti_type.(unit ->? Block_info.typ)	×
150	{%string\|
151	SELECT parent.id, parent.height, parent.state_hash, pv.transaction, pv.network, pv.patch
152	FROM blocks fork
153	INNER JOIN blocks parent ON parent.id = fork.parent_id
154	INNER JOIN protocol_versions pv ON parent.protocol_version_id = pv.id
155	WHERE fork.global_slot_since_hard_fork = 0
156	AND fork.parent_id IS NOT NULL
157	ORDER BY fork.height DESC
158	LIMIT 1;
159	\|}
160	in
161	Conn.find_opt query ()	×
162
163	(* Context about the hard fork just above the target: the post-fork genesis block
164	(global_slot_since_hard_fork = 0) and its parent (the last pre-fork block). *)
165	module Fork_context = struct
166	type t =
167	{ fork_state_hash : string
168	; fork_height : int64
169	; fork_slot : int64
170	; fork_chain_status : string
171	; parent_state_hash : string option
172	; parent_height : int64 option
173	}
174
175	let typ =
176	let encode
177	{ fork_state_hash
178	; fork_height
179	; fork_slot
180	; fork_chain_status
181	; parent_state_hash
182	; parent_height
183	} =
184	Ok	×
185	( (fork_state_hash, fork_height, fork_slot)
186	, (fork_chain_status, parent_state_hash, parent_height) )
187	in
188	let decode
189	( (fork_state_hash, fork_height, fork_slot)
190	, (fork_chain_status, parent_state_hash, parent_height) ) =
191	Ok	×
192	{ fork_state_hash
193	; fork_height
194	; fork_slot
195	; fork_chain_status
196	; parent_state_hash
197	; parent_height
198	}
199	in
200	Caqti_type.(
201	custom ~encode ~decode	11✔
202	(t2 (t3 string int64 int64) (t3 string (option string) (option int64))))	11✔
203	end
204
205	(* The first hard-fork block (global_slot_since_hard_fork = 0) strictly above the
206	target height, i.e. the post-fork genesis, together with its parent. Its slot
207	is used as an upper bound for orphaning so that, when the fork does NOT bump the
208	protocol version (some emergency hard forks), the post-fork chain — which shares
209	the protocol version with the pre-fork chain — is not orphaned. Returns None
210	when there is no hard fork above the target (e.g. the tip is pre-fork). *)
211	let fork_block_above_height (module Conn : CONNECTION) ~height =
212	let query =	×
213	Caqti_type.(int64 ->? Fork_context.typ)	×
214	{%string\|
215	SELECT fork.state_hash, fork.height, fork.global_slot_since_genesis,
216	fork.chain_status::text, parent.state_hash, parent.height
217	FROM blocks fork
218	LEFT JOIN blocks parent ON parent.id = fork.parent_id
219	WHERE fork.global_slot_since_hard_fork = 0
220	AND fork.height > ?
221	ORDER BY fork.global_slot_since_genesis ASC
222	LIMIT 1;
223	\|}
224	in
225	Conn.find_opt query height	×
226
227	(* The blocks that will be orphaned: same protocol version, below the fork
228	boundary and within the slot filter, not on the canonical chain to the target,
229	and not already orphaned. These are the competing / leftover blocks. *)
230	let blocks_to_orphan (module Conn : CONNECTION) ~canonical_block_ids
231	~stop_at_slot ~fork_boundary_slot ~protocol_version =
232	let query =	×
233	Caqti_type.(
234	t4 (option int) Mina_caqti.array_int_typ Protocol_version.typ	×
235	(option int64)	×
236	->* t3 int64 string string)	×
237	{%string\|
238	SELECT height, state_hash, chain_status::text
239	FROM blocks
240	WHERE ($1 IS NULL OR $1::int <= global_slot_since_genesis)
241	AND ($6 IS NULL OR global_slot_since_genesis < $6::bigint)
242	AND NOT (id = ANY($2::int[]))
243	AND chain_status <> 'orphaned'::chain_status_type
244	AND protocol_version_id = (
245	SELECT id FROM protocol_versions
246	WHERE transaction = $3::int
247	AND network = $4::int
248	AND patch = $5::int
249	LIMIT 1
250	)
251	ORDER BY height ASC;
252	\|}
253	in
254	Conn.collect_list query	×
255	( stop_at_slot
256	, Array.of_list canonical_block_ids	×
257	, protocol_version
258	, fork_boundary_slot )
259
260	(* Counts, over the blocks the conversion would touch (subject to the same slot
261	and fork-boundary filters as the mutation), how many would become orphaned and
262	how many currently-pending blocks change status in each direction. *)
263	let conversion_summary_counts (module Conn : CONNECTION) ~canonical_block_ids
264	~stop_at_slot ~fork_boundary_slot ~protocol_version =
265	let query =	×
266	Caqti_type.(
267	t4 (option int) Mina_caqti.array_int_typ Protocol_version.typ	×
268	(option int64)	×
269	->! t3 int int int)	×
270	{%string\|
271	SELECT
272	COUNT(*) FILTER (WHERE NOT (id = ANY($2::int[])))::int,
273	COUNT(*) FILTER (WHERE chain_status = 'pending'::chain_status_type
274	AND id = ANY($2::int[]))::int,
275	COUNT(*) FILTER (WHERE chain_status = 'pending'::chain_status_type
276	AND NOT (id = ANY($2::int[])))::int
277	FROM blocks
278	WHERE ($1 IS NULL OR $1::int <= global_slot_since_genesis)
279	AND ($6 IS NULL OR global_slot_since_genesis < $6::bigint)
280	AND protocol_version_id = (
281	SELECT id FROM protocol_versions
282	WHERE transaction = $3::int
283	AND network = $4::int
284	AND patch = $5::int
285	LIMIT 1
286	);
287	\|}
288	in
289	Conn.find query	×
290	( stop_at_slot
291	, Array.of_list canonical_block_ids	×
292	, protocol_version
293	, fork_boundary_slot )
294
295	(* The blocks in the canonical set that are NOT already canonical, i.e. the ones
296	actually being healed. Used to print a concise, meaningful list instead of the
297	whole ancestry (most of which is already canonical). *)
298	let noncanonical_blocks_in_set (module Conn : CONNECTION) ~canonical_block_ids =
299	let query =	×
300	Caqti_type.(Mina_caqti.array_int_typ ->* t3 int64 string string)	×
301	{%string\|
302	SELECT height, state_hash, chain_status::text
303	FROM blocks
304	WHERE id = ANY(?::int[])
305	AND chain_status <> 'canonical'::chain_status_type
306	ORDER BY height ASC;
307	\|}
308	in
309	Conn.collect_list query (Array.of_list canonical_block_ids)	×
310
311	let mark_pending_blocks_as_canonical_or_orphaned (module Conn : CONNECTION)
312	~canonical_block_ids ~stop_at_slot ~fork_boundary_slot ~protocol_version =
313	let mutation =	×
314	Caqti_type.(
315	t4 (option int) Mina_caqti.array_int_typ Protocol_version.typ	×
316	(option int64)	×
317	->. Caqti_type.unit)	×
318	{%string\|
319	UPDATE blocks
320	SET chain_status = CASE
321	WHEN id = ANY($2::int[]) THEN 'canonical'::chain_status_type
322	ELSE 'orphaned'::chain_status_type
323	END
324	WHERE ($1 IS NULL OR $1::int <= global_slot_since_genesis)
325	-- Never touch blocks at or beyond the fork boundary: when the fork does
326	-- not bump the protocol version, those are the post-fork chain and must
327	-- stay canonical. Canonical-set members are always pre-fork, so the
328	-- extra clause keeps them included.
329	AND (id = ANY($2::int[])
330	OR $6 IS NULL
331	OR global_slot_since_genesis < $6::bigint)
332	AND protocol_version_id = (
333	SELECT id FROM protocol_versions
334	WHERE transaction = $3::int
335	AND network = $4::int
336	AND patch = $5::int
337	LIMIT 1
338	);
339	\|}
340	in
341	Conn.exec mutation	×
342	( stop_at_slot
343	, Array.of_list canonical_block_ids	×
344	, protocol_version
345	, fork_boundary_slot )
346
347	let blocks_between_both_inclusive (module Conn : CONNECTION) ~latest_block_id
348	~oldest_block_id : (Block_info.t list, Caqti_error.t) Deferred.Result.t =
349	let query =	×
350	Caqti_type.(t2 int int ->* Block_info.typ)	×
351	{%string\|
352	%{chain_of_query_until_inclusive}
353	SELECT chain.id, height, state_hash, protocol_versions.transaction, protocol_versions.network, protocol_versions.patch
354	FROM chain INNER JOIN protocol_versions
355	ON chain.protocol_version_id = protocol_versions.id
356	ORDER BY height ASC
357	\|}
358	in
359	Conn.collect_list query (latest_block_id, oldest_block_id)	×
360
361	let is_in_best_chain (module Conn : CONNECTION) ~tip_hash ~check_hash
362	~check_height ~check_slot =
363	let query =	2✔
364	Caqti_type.(t4 string string int int64 ->! bool)	2✔
365	{%string\|
366	%{chain_of_query}
367	SELECT EXISTS (
368	SELECT 1 FROM chain
369	WHERE state_hash = $2
370	AND height = $3
371	AND global_slot_since_genesis = $4
372	);
373	\|}
374	in
375	Conn.find query (tip_hash, check_hash, check_height, check_slot)	2✔
376
377	let num_of_confirmations (module Conn : CONNECTION) ~latest_state_hash
378	~fork_slot =
379	let query =	2✔
380	Caqti_type.(t2 string int ->! int)	2✔
381	{%string\|
382	%{chain_of_query}
383	SELECT COUNT(*) FROM chain
384	WHERE global_slot_since_genesis > $2;
385	\|}
386	in
387	Conn.find query (latest_state_hash, fork_slot)	2✔
388
389	let number_of_commands_since_block_query block_commands_table =
390	Caqti_type.(t2 string int ->! int)	6✔
391	{%string\|
392	%{chain_of_query}
393	SELECT COUNT(bc.block_id)::int AS command_count
394	FROM chain
395	LEFT JOIN %{block_commands_table} bc
396	ON chain.id = bc.block_id
397	WHERE chain.global_slot_since_genesis > $2;
398	\|}
399
400	let number_of_user_commands_since_block (module Conn : CONNECTION)
401	~fork_state_hash ~fork_slot =
402	Conn.find	2✔
403	(number_of_commands_since_block_query "blocks_user_commands")	2✔
404	(fork_state_hash, fork_slot)
405
406	let number_of_internal_commands_since_block (module Conn : CONNECTION)
407	~fork_state_hash ~fork_slot =
408	Conn.find	2✔
409	(number_of_commands_since_block_query "blocks_internal_commands")	2✔
410	(fork_state_hash, fork_slot)
411
412	let number_of_zkapps_commands_since_block (module Conn : CONNECTION)
413	~fork_state_hash ~fork_slot =
414	Conn.find	2✔
415	(number_of_commands_since_block_query "blocks_zkapp_commands")	2✔
416	(fork_state_hash, fork_slot)
417
418	let last_fork_block (module Conn : CONNECTION) =
419	let query =	1✔
420	Caqti_type.(unit ->! t2 string int64)	1✔
421	{%string\|
422	SELECT state_hash, global_slot_since_genesis FROM blocks
423	WHERE global_slot_since_hard_fork = 0
424	ORDER BY height DESC
425	LIMIT 1;
426	\|}
427	in
428	Conn.find query ()	1✔
429
430	let fetch_latest_migration_history (module Conn : CONNECTION) =
431	let query =	2✔
432	Caqti_type.(unit ->? t3 string string string)	2✔
433	{%string\|
434	SELECT
435	status, protocol_version, migration_version
436	FROM migration_history
437	ORDER BY commit_start_at DESC
438	LIMIT 1;
439	\|}
440	in
441	Conn.find_opt query ()	2✔
442
443	(* Fetches last filled block before stop transaction slot.
444
445	Every block in mina should have internal commands since system transactions (like coinbase, fee transfer etc)
446	are implemented as internal commands. It CAN have zero user commands and zero zkapp commands,
447	but it should have internal commands.
448
449	However, in context of hard fork, we want to stop including any transactions
450	in the blocks after specified slot (called stop transaction slot). No internal, user or zkapp commands should be included in the blocks after that slot.
451	Blocks can still be produced with no transactions, to keep chain progressing and give us confirmations but
452	only from stop transaction slot till stop network slot, where we completely stop the chain.
453	Knowing above we can detect last filled block by only looking at internal transactions occurrence.
454	Therefore our fork candidate is the block with highest height that has internal transaction included in it.
455	*)
456
457	let fetch_last_filled_block (module Conn : CONNECTION) =
458	let query =	2✔
459	Caqti_type.(unit ->! t3 string int64 int)	2✔
460	{%string\|
461	SELECT b.state_hash, b.global_slot_since_genesis, b.height
462	FROM blocks b
463	INNER JOIN blocks_internal_commands bic ON b.id = bic.block_id
464	ORDER BY b.height DESC
465	LIMIT 1;
466	\|}
467	in
468	Conn.find query ()	2✔

MinaProtocol / mina / 1518

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