2863

Committed 05 Nov 2024 06:20PM UTC coverage: 30.754% (-16.6%) from 47.311%

Build # 2863

Build Type

push

buildkite

Committed by

web-flow

Commit Message

Merge pull request #16296 from MinaProtocol/dkijania/more_multi_jobs

more multi jobs in CI

Run Details

20276 of 65930 relevant lines covered (30.75%)

8631.7 hits per line

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

1.24

/src/lib/transition_frontier/persistent_frontier/database.ml

open Async_kernel
open Core
open Mina_base
open Mina_block
open Frontier_base

(* TODO: cache state body hashes in db to avoid re-hashing on load (#10293) *)

(* TODO: bundle together with other writes by sharing batch requests between
 * function calls in this module (#3738) *)

let rec deferred_list_result_iter ls ~f =
  let open Deferred.Result.Let_syntax in
  match ls with
  | [] ->
      return ()
  | h :: t ->
      let%bind () = f h in
      deferred_list_result_iter t ~f

(* TODO: should debug assert garbage checks be added? *)
open Result.Let_syntax

(* TODO: implement versions with module versioning. For
 * now, this is just stubbed so we can add db migrations
 * later. (#3736) *)
let version = 2

module Schema = struct
  module Keys = struct
    module String = String

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

        module V1 = struct
          type t = Bounded_types.String.Stable.V1.t * State_hash.Stable.V1.t

          let to_latest = Fn.id
        end
      end]
    end
  end

  [@@@warning "-22"]

  type _ t =
    | Db_version : int t
    | Transition : State_hash.Stable.V1.t -> Mina_block.Stable.V2.t t
    | Arcs : State_hash.Stable.V1.t -> State_hash.Stable.V1.t list t
    | Root : Root_data.Minimal.Stable.V2.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

  [@@@warning "+22"]

  let to_string : type a. a t -> string = function
    | Db_version ->
        "Db_version"
    | Transition _ ->
        "Transition _"
    | Arcs _ ->
        "Arcs _"
    | Root ->
        "Root"
    | Best_tip ->
        "Best_tip"
    | Protocol_states_for_root_scan_state ->
        "Protocol_states_for_root_scan_state"

  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]
    | Arcs _ ->
        [%bin_type_class: State_hash.Stable.Latest.t list]
    | Root ->
        [%bin_type_class: Root_data.Minimal.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]

  (* 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) :
         (module Binable.S with type t = data)
      -> to_gadt:(data -> a t)
      -> of_gadt:(a t -> data)
      -> a t Bin_prot.Type_class.t =
   fun (module M) ~to_gadt ~of_gadt ->
    let ({ shape; writer = { size; write }; reader = { read; vtag_read } }
          : data Bin_prot.Type_class.t ) =
      [%bin_type_class: M.t]
    in
    { shape
    ; writer =
        { size = Fn.compose size of_gadt
        ; write = (fun buffer ~pos gadt -> write buffer ~pos (of_gadt gadt))
        }
    ; reader =
        { read = (fun buffer ~pos_ref -> to_gadt (read buffer ~pos_ref))
        ; vtag_read =
            (fun buffer ~pos_ref number ->
              to_gadt (vtag_read buffer ~pos_ref number) )
        }
    }

  (* HACK: The OCaml compiler thought the pattern matching in of_gadts was
     non-exhaustive. However, it should not be since I constrained the
     polymorphic type *)
  let[@warning "-8"] binable_key_type (type a) :
      a t -> a t Bin_prot.Type_class.t = function
    | Db_version ->
        gadt_input_type_class
          (module Keys.String)
          ~to_gadt:(fun _ -> Db_version)
          ~of_gadt:(fun Db_version -> "db_version")
    | Transition _ ->
        gadt_input_type_class
          (module Keys.Prefixed_state_hash.Stable.Latest)
          ~to_gadt:(fun (_, hash) -> Transition hash)
          ~of_gadt:(fun (Transition hash) -> ("transition", hash))
    | Arcs _ ->
        gadt_input_type_class
          (module Keys.Prefixed_state_hash.Stable.Latest)
          ~to_gadt:(fun (_, hash) -> Arcs hash)
          ~of_gadt:(fun (Arcs hash) -> ("arcs", hash))
    | Root ->
        gadt_input_type_class
          (module Keys.String)
          ~to_gadt:(fun _ -> Root)
          ~of_gadt:(fun Root -> "root")
    | Best_tip ->
        gadt_input_type_class
          (module Keys.String)
          ~to_gadt:(fun _ -> Best_tip)
          ~of_gadt:(fun Best_tip -> "best_tip")
    | Protocol_states_for_root_scan_state ->
        gadt_input_type_class
          (module Keys.String)
          ~to_gadt:(fun _ -> Protocol_states_for_root_scan_state)
          ~of_gadt:(fun Protocol_states_for_root_scan_state ->
            "protocol_states_in_root_scan_state" )
end

module Error = struct
  type not_found_member =
    [ `Root
    | `Best_tip
    | `Frontier_hash
    | `Root_transition
    | `Best_tip_transition
    | `Parent_transition of State_hash.t
    | `New_root_transition
    | `Old_root_transition
    | `Transition of State_hash.t
    | `Arcs of State_hash.t
    | `Protocol_states_for_root_scan_state ]

  type not_found = [ `Not_found of not_found_member ]

  type raised = [ `Raised of Error.t ]

  type t = [ not_found | raised | `Invalid_version ]

  let not_found_message (`Not_found member) =
    let member_name, member_id =
      match member with
      | `Root ->
          ("root", None)
      | `Best_tip ->
          ("best tip", None)
      | `Frontier_hash ->
          ("frontier hash", None)
      | `Root_transition ->
          ("root transition", None)
      | `Best_tip_transition ->
          ("best tip transition", None)
      | `Parent_transition hash ->
          ("parent transition", Some hash)
      | `New_root_transition ->
          ("new root transition", None)
      | `Old_root_transition ->
          ("old root transition", None)
      | `Transition hash ->
          ("transition", Some hash)
      | `Arcs hash ->
          ("arcs", Some hash)
      | `Protocol_states_for_root_scan_state ->
          ("protocol states in root scan state", None)
    in
    let additional_context =
      Option.map member_id ~f:(fun id ->
          Printf.sprintf " (hash = %s)" (State_hash.raw_hash_bytes id) )
      |> Option.value ~default:""
    in
    Printf.sprintf "%s not found%s" member_name additional_context

  let message = function
    | `Invalid_version ->
        "invalid version"
    | `Not_found _ as err ->
        not_found_message err
    | `Raised err ->
        sprintf "Raised %s" (Error.to_string_hum err)
end

module Rocks = Rocksdb.Serializable.GADT.Make (Schema)

type t = { directory : string; logger : Logger.t; db : Rocks.t }

let create ~logger ~directory =
  if not (Result.is_ok (Unix.access directory [ `Exists ])) then
    Unix.mkdir ~perm:0o766 directory ;
  { directory; logger; db = Rocks.create directory }

let close t = Rocks.close t.db

open Schema
open Rocks

type batch_t = Batch.t

let get_if_exists db ~default ~key =
  match get db ~key with Some x -> x | None -> default

let get db ~key ~error =
  match get db ~key with Some x -> Ok x | None -> Error error

(* TODO: check that best tip is connected to root *)
(* TODO: check for garbage *)
let check t ~genesis_state_hash =
  Or_error.try_with (fun () ->
      let check_version () =
        match get_if_exists t.db ~key:Db_version ~default:0 with
        | 0 ->
            Error `Not_initialized
        | v when v = version ->
            Ok ()
        | _ ->
            Error `Invalid_version
      in
      (* checks the pointers, frontier hash, and checks pointer references *)
      let check_base () =
        let%bind root =
          get t.db ~key:Root ~error:(`Corrupt (`Not_found `Root))
        in
        let root_hash = Root_data.Minimal.hash root in
        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))
        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))
        in
        (root_hash, root_transition)
      in
      let rec check_arcs pred_hash =
        let%bind successors =
          get t.db ~key:(Arcs pred_hash)
            ~error:(`Corrupt (`Not_found (`Arcs pred_hash)))
        in
        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)))
            in
            check_arcs 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.header |> Mina_block.Header.protocol_state
      in
      let%bind () =
        let persisted_genesis_state_hash =
          Mina_state.Protocol_state.genesis_state_hash root_protocol_state
        in
        if State_hash.equal persisted_genesis_state_hash genesis_state_hash then
          Ok ()
        else Error (`Genesis_state_mismatch persisted_genesis_state_hash)
      in
      let%map () = check_arcs root_hash in
      root_block |> Mina_block.header |> Header.protocol_state
      |> Mina_state.Protocol_state.blockchain_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 open Root_data.Limited in
  let root_state_hash, root_transition =
    let t = Mina_block.Validated.forget (transition root_data) in
    ( State_hash.With_state_hashes.state_hash t
    , State_hash.With_state_hashes.data t )
  in
  [%log' trace t.logger]
    ~metadata:[ ("root_data", Root_data.Limited.to_yojson root_data) ]
    "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 ~data:(Root_data.Minimal.of_limited root_data) ;
      Batch.set batch ~key:Best_tip ~data:root_state_hash ;
      Batch.set batch ~key:Protocol_states_for_root_scan_state
        ~data:(protocol_states root_data |> List.map ~f:With_hash.data) )

let find_arcs_and_root t ~(arcs_cache : State_hash.t list State_hash.Table.t)
    ~parent_hashes =
  let f h = Rocks.Key.Some_key (Arcs h) in
  let values =
    get_batch t.db ~keys:(Some_key Root :: List.map parent_hashes ~f)
  in
  let populate res parent_hash arc_opt =
    let%bind.Result () = res in
    match arc_opt with
    | Some (Key.Some_key_value (Arcs _, (data : State_hash.t list))) ->
        State_hash.Table.set arcs_cache ~key:parent_hash ~data ;
        Result.return ()
    | _ ->
        Error (`Not_found (`Arcs parent_hash))
  in
  match values with
  | Some (Some_key_value (Root, (old_root : Root_data.Minimal.Stable.V2.t)))
    :: arcs ->
      let%map.Result () =
        List.fold2_exn ~init:(Result.return ()) ~f:populate parent_hashes arcs
      in
      old_root
  | _ ->
      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 parent_hash =
    With_hash.data transition |> Mina_block.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:[] ;
  fun batch ->
    Batch.set batch ~key:(Transition hash) ~data:(With_hash.data transition) ;
    Batch.set batch ~key:(Arcs hash) ~data:[] ;
    Batch.set batch ~key:(Arcs parent_hash) ~data:(hash :: parent_arcs)

let move_root ~old_root ~new_root ~garbage =
  let open Root_data.Limited in
  let old_root_hash = Root_data.Minimal.hash old_root in
  fun batch ->
    Batch.set batch ~key:Root ~data:(Root_data.Minimal.of_limited new_root) ;
    Batch.set batch ~key:Protocol_states_for_root_scan_state
      ~data:(List.map ~f:With_hash.data (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) )

let get_transition 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.header
    |> Mina_block.Header.protocol_state
    |> Mina_state.Protocol_state.previous_state_hash
  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 block)

let get_arcs t hash = get t.db ~key:(Arcs hash) ~error:(`Not_found (`Arcs hash))

let get_root t = get t.db ~key:Root ~error:(`Not_found `Root)

let get_protocol_states_for_root_scan_state t =
  get t.db ~key:Protocol_states_for_root_scan_state
    ~error:(`Not_found `Protocol_states_for_root_scan_state)

let get_root_hash t =
  let%map root = get_root t in
  Root_data.Minimal.hash root

let get_best_tip t = get t.db ~key:Best_tip ~error:(`Not_found `Best_tip)

let set_best_tip data = Batch.set ~key:Best_tip ~data

let rec crawl_successors t hash ~init ~f =
  let open Deferred.Result.Let_syntax in
  let%bind successors = Deferred.return (get_arcs t hash) in
  deferred_list_result_iter successors ~f:(fun succ_hash ->
      let%bind transition = Deferred.return (get_transition t succ_hash) in
      let%bind init' =
        Deferred.map (f init transition)
          ~f:(Result.map_error ~f:(fun err -> `Crawl_error err))
      in
      crawl_successors t succ_hash ~init:init' ~f )

let with_batch t = Batch.with_batch t.db

1	open Async_kernel	3✔
2	open Core
3	open Mina_base
4	open Mina_block
5	open Frontier_base
6
7	(* TODO: cache state body hashes in db to avoid re-hashing on load (#10293) *)
8
9	(* TODO: bundle together with other writes by sharing batch requests between
10	* function calls in this module (#3738) *)
11
12	let rec deferred_list_result_iter ls ~f =
13	let open Deferred.Result.Let_syntax in	×
14	match ls with
15	\| [] ->	×
16	return ()
17	\| h :: t ->	×
18	let%bind () = f h in	×
19	deferred_list_result_iter t ~f	×
20
21	(* TODO: should debug assert garbage checks be added? *)
22	open Result.Let_syntax
23
24	(* TODO: implement versions with module versioning. For
25	* now, this is just stubbed so we can add db migrations
26	* later. (#3736) *)
27	let version = 2
28
29	module Schema = struct
30	module Keys = struct
31	module String = String
32
33	module Prefixed_state_hash = struct
34	[%%versioned
35	module Stable = struct
36	[@@@no_toplevel_latest_type]
37
38	module V1 = struct
39	type t = Bounded_types.String.Stable.V1.t * State_hash.Stable.V1.t	3✔
40
41	let to_latest = Fn.id
42	end
43	end]
44	end
45	end
46
47	[@@@warning "-22"]
48
49	type _ t =
50	\| Db_version : int t
51	\| Transition : State_hash.Stable.V1.t -> Mina_block.Stable.V2.t t
52	\| Arcs : State_hash.Stable.V1.t -> State_hash.Stable.V1.t list t
53	\| Root : Root_data.Minimal.Stable.V2.t t
54	\| Best_tip : State_hash.Stable.V1.t t
55	\| Protocol_states_for_root_scan_state
56	: Mina_state.Protocol_state.Value.Stable.V2.t list t
57
58	[@@@warning "+22"]
59
60	let to_string : type a. a t -> string = function
61	\| Db_version ->	×
62	"Db_version"
63	\| Transition _ ->	×
64	"Transition _"
65	\| Arcs _ ->	×
66	"Arcs _"
67	\| Root ->	×
68	"Root"
69	\| Best_tip ->	×
70	"Best_tip"
71	\| Protocol_states_for_root_scan_state ->	×
72	"Protocol_states_for_root_scan_state"
73
74	let binable_data_type (type a) : a t -> a Bin_prot.Type_class.t = function
75	\| Db_version ->	×
76	[%bin_type_class: int]
77	\| Transition _ ->	×
78	[%bin_type_class: Mina_block.Stable.Latest.t]
79	\| Arcs _ ->	×
80	[%bin_type_class: State_hash.Stable.Latest.t list]
81	\| Root ->	×
82	[%bin_type_class: Root_data.Minimal.Stable.Latest.t]
83	\| Best_tip ->	×
84	[%bin_type_class: State_hash.Stable.Latest.t]
85	\| Protocol_states_for_root_scan_state ->	×
86	[%bin_type_class: Mina_state.Protocol_state.Value.Stable.Latest.t list]
87
88	(* HACK: a simple way to derive Bin_prot.Type_class.t for each case of a GADT *)
89	let gadt_input_type_class (type data a) :
90	(module Binable.S with type t = data)
91	-> to_gadt:(data -> a t)
92	-> of_gadt:(a t -> data)
93	-> a t Bin_prot.Type_class.t =
94	fun (module M) ~to_gadt ~of_gadt ->
95	let ({ shape; writer = { size; write }; reader = { read; vtag_read } }	×
96	: data Bin_prot.Type_class.t ) =
97	[%bin_type_class: M.t]
98	in
99	{ shape
100	; writer =
101	{ size = Fn.compose size of_gadt	×
102	; write = (fun buffer ~pos gadt -> write buffer ~pos (of_gadt gadt))	×
103	}
104	; reader =
105	{ read = (fun buffer ~pos_ref -> to_gadt (read buffer ~pos_ref))	×
106	; vtag_read =
107	(fun buffer ~pos_ref number ->
108	to_gadt (vtag_read buffer ~pos_ref number) )	×
109	}
110	}
111
112	(* HACK: The OCaml compiler thought the pattern matching in of_gadts was
113	non-exhaustive. However, it should not be since I constrained the
114	polymorphic type *)
115	let[@warning "-8"] binable_key_type (type a) :
116	a t -> a t Bin_prot.Type_class.t = function
117	\| Db_version ->	×
118	gadt_input_type_class
119	(module Keys.String)
120	~to_gadt:(fun _ -> Db_version)	×
121	~of_gadt:(fun Db_version -> "db_version")	×
122	\| Transition _ ->	×
123	gadt_input_type_class
124	(module Keys.Prefixed_state_hash.Stable.Latest)
125	~to_gadt:(fun (_, hash) -> Transition hash)	×
126	~of_gadt:(fun (Transition hash) -> ("transition", hash))	×
127	\| Arcs _ ->	×
128	gadt_input_type_class
129	(module Keys.Prefixed_state_hash.Stable.Latest)
130	~to_gadt:(fun (_, hash) -> Arcs hash)	×
131	~of_gadt:(fun (Arcs hash) -> ("arcs", hash))	×
132	\| Root ->	×
133	gadt_input_type_class
134	(module Keys.String)
135	~to_gadt:(fun _ -> Root)	×
136	~of_gadt:(fun Root -> "root")	×
137	\| Best_tip ->	×
138	gadt_input_type_class
139	(module Keys.String)
140	~to_gadt:(fun _ -> Best_tip)	×
141	~of_gadt:(fun Best_tip -> "best_tip")	×
142	\| Protocol_states_for_root_scan_state ->	×
143	gadt_input_type_class
144	(module Keys.String)
145	~to_gadt:(fun _ -> Protocol_states_for_root_scan_state)	×
146	~of_gadt:(fun Protocol_states_for_root_scan_state ->
147	"protocol_states_in_root_scan_state" )	×
148	end
149
150	module Error = struct
151	type not_found_member =
152	[ `Root
153	\| `Best_tip
154	\| `Frontier_hash
155	\| `Root_transition
156	\| `Best_tip_transition
157	\| `Parent_transition of State_hash.t
158	\| `New_root_transition
159	\| `Old_root_transition
160	\| `Transition of State_hash.t
161	\| `Arcs of State_hash.t
162	\| `Protocol_states_for_root_scan_state ]
163
164	type not_found = [ `Not_found of not_found_member ]
165
166	type raised = [ `Raised of Error.t ]
167
168	type t = [ not_found \| raised \| `Invalid_version ]
169
170	let not_found_message (`Not_found member) =
171	let member_name, member_id =	×
172	match member with
173	\| `Root ->	×
174	("root", None)
175	\| `Best_tip ->	×
176	("best tip", None)
177	\| `Frontier_hash ->	×
178	("frontier hash", None)
179	\| `Root_transition ->	×
180	("root transition", None)
181	\| `Best_tip_transition ->	×
182	("best tip transition", None)
183	\| `Parent_transition hash ->	×
184	("parent transition", Some hash)
185	\| `New_root_transition ->	×
186	("new root transition", None)
187	\| `Old_root_transition ->	×
188	("old root transition", None)
189	\| `Transition hash ->	×
190	("transition", Some hash)
191	\| `Arcs hash ->	×
192	("arcs", Some hash)
193	\| `Protocol_states_for_root_scan_state ->	×
194	("protocol states in root scan state", None)
195	in
196	let additional_context =
197	Option.map member_id ~f:(fun id ->	×
198	Printf.sprintf " (hash = %s)" (State_hash.raw_hash_bytes id) )	×
199	\|> Option.value ~default:""
200	in
201	Printf.sprintf "%s not found%s" member_name additional_context	×
202
203	let message = function
204	\| `Invalid_version ->	×
205	"invalid version"
206	\| `Not_found _ as err ->	×
207	not_found_message err
208	\| `Raised err ->	×
209	sprintf "Raised %s" (Error.to_string_hum err)	×
210	end
211
212	module Rocks = Rocksdb.Serializable.GADT.Make (Schema)
213
214	type t = { directory : string; logger : Logger.t; db : Rocks.t }
215
216	let create ~logger ~directory =
217	if not (Result.is_ok (Unix.access directory [ `Exists ])) then	×
218	Unix.mkdir ~perm:0o766 directory ;	×
219	{ directory; logger; db = Rocks.create directory }	×
220
221	let close t = Rocks.close t.db	×
222
223	open Schema
224	open Rocks
225
226	type batch_t = Batch.t
227
228	let get_if_exists db ~default ~key =
229	match get db ~key with Some x -> x \| None -> default	×
230
231	let get db ~key ~error =
232	match get db ~key with Some x -> Ok x \| None -> Error error	×
233
234	(* TODO: check that best tip is connected to root *)
235	(* TODO: check for garbage *)
236	let check t ~genesis_state_hash =
237	Or_error.try_with (fun () ->	×
238	let check_version () =	×
239	match get_if_exists t.db ~key:Db_version ~default:0 with	×
240	\| 0 ->	×
241	Error `Not_initialized
242	\| v when v = version ->	×
243	Ok ()	×
244	\| _ ->	×
245	Error `Invalid_version
246	in
247	(* checks the pointers, frontier hash, and checks pointer references *)
248	let check_base () =
249	let%bind root =
250	get t.db ~key:Root ~error:(`Corrupt (`Not_found `Root))	×
251	in
252	let root_hash = Root_data.Minimal.hash root in	×
253	let%bind best_tip =
254	get t.db ~key:Best_tip ~error:(`Corrupt (`Not_found `Best_tip))	×
255	in
256	let%bind root_transition =
257	get t.db ~key:(Transition root_hash)	×
258	~error:(`Corrupt (`Not_found `Root_transition))
259	in
260	let%bind _ =
261	get t.db ~key:Protocol_states_for_root_scan_state	×
262	~error:(`Corrupt (`Not_found `Protocol_states_for_root_scan_state))
263	in
264	let%map _ =
265	get t.db ~key:(Transition best_tip)	×
266	~error:(`Corrupt (`Not_found `Best_tip_transition))
267	in
268	(root_hash, root_transition)	×
269	in
270	let rec check_arcs pred_hash =
271	let%bind successors =
272	get t.db ~key:(Arcs pred_hash)	×
273	~error:(`Corrupt (`Not_found (`Arcs pred_hash)))
274	in
275	List.fold successors ~init:(Ok ()) ~f:(fun acc succ_hash ->	×
276	let%bind () = acc in
277	let%bind _ =
278	get t.db ~key:(Transition succ_hash)	×
279	~error:(`Corrupt (`Not_found (`Transition succ_hash)))
280	in
281	check_arcs succ_hash )	×
282	in
283	let%bind () = check_version () in	×
284	let%bind root_hash, root_block = check_base () in	×
285	let root_protocol_state =	×
286	root_block \|> Mina_block.header \|> Mina_block.Header.protocol_state	×
287	in
288	let%bind () =
289	let persisted_genesis_state_hash =
290	Mina_state.Protocol_state.genesis_state_hash root_protocol_state
291	in
292	if State_hash.equal persisted_genesis_state_hash genesis_state_hash then	×
293	Ok ()	×
294	else Error (`Genesis_state_mismatch persisted_genesis_state_hash)	×
295	in
296	let%map () = check_arcs root_hash in	×
297	root_block \|> Mina_block.header \|> Header.protocol_state	×
298	\|> Mina_state.Protocol_state.blockchain_state	×
299	\|> Mina_state.Blockchain_state.snarked_ledger_hash )
300	\|> Result.map_error ~f:(fun err -> `Corrupt (`Raised err))	×
301	\|> Result.join
302
303	let initialize t ~root_data =
304	let open Root_data.Limited in	×
305	let root_state_hash, root_transition =
306	let t = Mina_block.Validated.forget (transition root_data) in	×
307	( State_hash.With_state_hashes.state_hash t	×
308	, State_hash.With_state_hashes.data t )	×
309	in
310	[%log' trace t.logger]	×
311	~metadata:[ ("root_data", Root_data.Limited.to_yojson root_data) ]	×
312	"Initializing persistent frontier database with $root_data" ;
313	Batch.with_batch t.db ~f:(fun batch ->	×
314	Batch.set batch ~key:Db_version ~data:version ;	×
315	Batch.set batch ~key:(Transition root_state_hash) ~data:root_transition ;	×
316	Batch.set batch ~key:(Arcs root_state_hash) ~data:[] ;	×
317	Batch.set batch ~key:Root ~data:(Root_data.Minimal.of_limited root_data) ;	×
318	Batch.set batch ~key:Best_tip ~data:root_state_hash ;	×
319	Batch.set batch ~key:Protocol_states_for_root_scan_state	×
320	~data:(protocol_states root_data \|> List.map ~f:With_hash.data) )	×
321
322	let find_arcs_and_root t ~(arcs_cache : State_hash.t list State_hash.Table.t)
323	~parent_hashes =
324	let f h = Rocks.Key.Some_key (Arcs h) in	×
325	let values =
326	get_batch t.db ~keys:(Some_key Root :: List.map parent_hashes ~f)	×
327	in
328	let populate res parent_hash arc_opt =	×
329	let%bind.Result () = res in
330	match arc_opt with	×
331	\| Some (Key.Some_key_value (Arcs _, (data : State_hash.t list))) ->	×
332	State_hash.Table.set arcs_cache ~key:parent_hash ~data ;
333	Result.return ()	×
334	\| _ ->	×
335	Error (`Not_found (`Arcs parent_hash))
336	in
337	match values with
338	\| Some (Some_key_value (Root, (old_root : Root_data.Minimal.Stable.V2.t)))	×
339	:: arcs ->
340	let%map.Result () =
341	List.fold2_exn ~init:(Result.return ()) ~f:populate parent_hashes arcs	×
342	in
343	old_root	×
344	\| _ ->	×
345	Error (`Not_found `Old_root_transition)
346
347	let add ~arcs_cache ~transition =
348	let transition = Mina_block.Validated.forget transition in	×
349	let hash = State_hash.With_state_hashes.state_hash transition in	×
350	let parent_hash =	×
351	With_hash.data transition \|> Mina_block.header \|> Header.protocol_state	×
352	\|> Mina_state.Protocol_state.previous_state_hash
353	in
354	let parent_arcs = State_hash.Table.find_exn arcs_cache parent_hash in	×
355	State_hash.Table.set arcs_cache ~key:parent_hash ~data:(hash :: parent_arcs) ;	×
356	State_hash.Table.set arcs_cache ~key:hash ~data:[] ;	×
357	fun batch ->	×
358	Batch.set batch ~key:(Transition hash) ~data:(With_hash.data transition) ;	×
359	Batch.set batch ~key:(Arcs hash) ~data:[] ;	×
360	Batch.set batch ~key:(Arcs parent_hash) ~data:(hash :: parent_arcs)	×
361
362	let move_root ~old_root ~new_root ~garbage =
363	let open Root_data.Limited in	×
364	let old_root_hash = Root_data.Minimal.hash old_root in
365	fun batch ->	×
366	Batch.set batch ~key:Root ~data:(Root_data.Minimal.of_limited new_root) ;	×
367	Batch.set batch ~key:Protocol_states_for_root_scan_state	×
368	~data:(List.map ~f:With_hash.data (protocol_states new_root)) ;	×
369	List.iter (old_root_hash :: garbage) ~f:(fun node_hash ->	×
370	(* because we are removing entire forks of the tree, there is
371	* no need to have extra logic to any remove arcs to the node
372	* we are deleting since there we are deleting all of a node's
373	* parents as well
374	*)
375	Batch.remove batch ~key:(Transition node_hash) ;	×
376	Batch.remove batch ~key:(Arcs node_hash) )	×
377
378	let get_transition t hash =
379	let%map transition =
380	get t.db ~key:(Transition hash) ~error:(`Not_found (`Transition hash))	×
381	in
382	let block =	×
383	{ With_hash.data = transition
384	; hash =
385	{ State_hash.State_hashes.state_hash = hash; state_body_hash = None }
386	}
387	in
388	let parent_hash =
389	block \|> With_hash.data \|> Mina_block.header	×
390	\|> Mina_block.Header.protocol_state	×
391	\|> Mina_state.Protocol_state.previous_state_hash
392	in
393	(* TODO: the delta transition chain proof is incorrect (same behavior the daemon used to have, but we should probably fix this?) *)
394	Mina_block.Validated.unsafe_of_trusted_block	×
395	~delta_block_chain_proof:(Mina_stdlib.Nonempty_list.singleton parent_hash)	×
396	(`This_block_is_trusted_to_be_safe block)
397
398	let get_arcs t hash = get t.db ~key:(Arcs hash) ~error:(`Not_found (`Arcs hash))	×
399
400	let get_root t = get t.db ~key:Root ~error:(`Not_found `Root)	×
401
402	let get_protocol_states_for_root_scan_state t =
403	get t.db ~key:Protocol_states_for_root_scan_state	×
404	~error:(`Not_found `Protocol_states_for_root_scan_state)
405
406	let get_root_hash t =
407	let%map root = get_root t in	×
408	Root_data.Minimal.hash root	×
409
410	let get_best_tip t = get t.db ~key:Best_tip ~error:(`Not_found `Best_tip)	×
411
412	let set_best_tip data = Batch.set ~key:Best_tip ~data	×
413
414	let rec crawl_successors t hash ~init ~f =
415	let open Deferred.Result.Let_syntax in	×
416	let%bind successors = Deferred.return (get_arcs t hash) in	×
417	deferred_list_result_iter successors ~f:(fun succ_hash ->	×
418	let%bind transition = Deferred.return (get_transition t succ_hash) in	×
419	let%bind init' =
420	Deferred.map (f init transition)	×
421	~f:(Result.map_error ~f:(fun err -> `Crawl_error err))	×
422	in
423	crawl_successors t succ_hash ~init:init' ~f )	×
424
425	let with_batch t = Batch.with_batch t.db	×

MinaProtocol / mina / 2863

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