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

36.59

/src/lib/sparse_ledger_lib/sparse_ledger.ml

(** Sparse Ledger implementation.

    This module provides a space-efficient representation of a Merkle ledger
    where most branches can be stored as hashes without holding the full
    account data. It is parameterized over:
    - the type of Merkle hashes,
    - the type of account identifiers, and
    - the type of account records.

    A sparse ledger stores:
    - [depth]: the height of the binary Merkle tree,
    - [tree]: the partial Merkle tree structure with leaves that may be either
      full accounts or hash placeholders,
    - [indexes]: a mapping from account identifiers to their leaf index in the
      tree.

    The main functionality includes:
    - Creating an empty ledger from a root hash ({!of_hash}),
    - Retrieving accounts by index ({!get_exn}),
    - Modifying accounts at a given index ({!set_exn}),
    - Computing Merkle paths ({!path_exn}),
    - Inserting accounts using Merkle paths ({!add_path}) or precomputed
      sibling hashes ({!add_wide_path_unsafe}),
    - Iterating over all accounts with their indices ({!iteri}),
    - Computing the Merkle root ({!merkle_root}),
    - Looking up the index of a given account ID ({!find_index_exn}).

    {b Warning:}
    - [add_wide_path_unsafe] does not recompute or verify hashes and can
      produce an inconsistent tree if used incorrectly.
    - Functions with [_exn] in their name will raise if the requested index or
      path is invalid.

    This structure is useful for:
    - Incrementally reconstructing a Merkle ledger from partial proofs,
    - Maintaining sparse proofs for a small set of accounts in a large ledger,
    - Efficiently verifying account membership without storing all accounts.

    See the test module for property-based tests ensuring consistency of index
    tracking, Merkle path reconstruction, and hash correctness.
*)

open Core_kernel

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

    module V1 = struct
      type ('hash, 'account) t =
        | Account of 'account
        | Hash of 'hash
        | Node of 'hash * ('hash, 'account) t * ('hash, 'account) t
      [@@deriving equal, sexp, yojson]

      let rec to_latest acct_to_latest = function
        | Account acct ->
            Account (acct_to_latest acct)
        | Hash hash ->
            Hash hash
        | Node (hash, l, r) ->
            Node (hash, to_latest acct_to_latest l, to_latest acct_to_latest r)
    end
  end]

  type ('hash, 'account) t = ('hash, 'account) Stable.Latest.t =
    | Account of 'account
    | Hash of 'hash
    | Node of 'hash * ('hash, 'account) t * ('hash, 'account) t
  [@@deriving equal, sexp, yojson]
end

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

    module V2 = struct
      type ('hash, 'key, 'account) t =
        { indexes : ('key * int) list
        ; depth : int
        ; tree : ('hash, 'account) Tree.Stable.V1.t
        }
      [@@deriving sexp, yojson]
    end
  end]

  type ('hash, 'key, 'account) t = ('hash, 'key, 'account) Stable.Latest.t =
    { indexes : ('key * int) list
    ; depth : int
    ; tree : ('hash, 'account) Tree.t
    }
  [@@deriving sexp, yojson]
end

module type S = sig
  type hash

  type account_id

  type account

  type t = (hash, account_id, account) T.t [@@deriving sexp, yojson]

  val of_hash : depth:int -> hash -> t

  val get_exn : t -> int -> account

  val path_exn : t -> int -> [ `Left of hash | `Right of hash ] list

  val set_exn : t -> int -> account -> t

  val find_index_exn : t -> account_id -> int

  val add_path :
    t -> [ `Left of hash | `Right of hash ] list -> account_id -> account -> t

  (** Same as [add_path], but using the hashes provided in the wide merkle path
      instead of recomputing them.
      This is unsafe: the hashes are not checked or recomputed.
  *)
  val add_wide_path_unsafe :
       t
    -> [ `Left of hash * hash | `Right of hash * hash ] list
    -> account_id
    -> account
    -> t

  val iteri : t -> f:(int -> account -> unit) -> unit

  val merkle_root : t -> hash

  val depth : t -> int
end

let tree { T.tree; _ } = tree

let of_hash ~depth h = { T.indexes = []; depth; tree = Hash h }

module Make (Hash : sig
  type t [@@deriving equal, sexp, yojson, compare]

  val merge : height:int -> t -> t -> t
end) (Account_id : sig
  type t [@@deriving equal, sexp, yojson]
end) (Account : sig
  type t [@@deriving equal, sexp, yojson]

  val data_hash : t -> Hash.t
end) : sig
  include
    S
      with type hash := Hash.t
       and type account_id := Account_id.t
       and type account := Account.t

  val hash : (Hash.t, Account.t) Tree.t -> Hash.t
end = struct
  type t = (Hash.t, Account_id.t, Account.t) T.t [@@deriving sexp, yojson]

  let of_hash ~depth (hash : Hash.t) = of_hash ~depth hash

  let hash : (Hash.t, Account.t) Tree.t -> Hash.t = function
    | Account a ->
        Account.data_hash a
    | Hash h ->
        h
    | Node (h, _, _) ->
        h

  type index = int [@@deriving sexp, yojson]

  let depth { T.depth; _ } = depth

  let merkle_root { T.tree; _ } = hash tree

  let add_path_impl ~replace_self tree0 path0 account =
    (* Takes height, left and right children and builds a pair of sibling nodes
       one level up *)
    let build_tail_f height (prev_l, prev_r) =
      replace_self ~f:(fun mself ->
          let self =
            match mself with
            | Some self ->
                self
            | None ->
                Hash.merge ~height (hash prev_l) (hash prev_r)
          in
          Tree.Node (self, prev_l, prev_r) )
    in
    (* Builds the tail of path, i.e. part of the path that is not present in
       the current ledger and we just add it all the way down to account
       using the path *)
    let build_tail hash_node_to_bottom_path =
      let bottom_el, bottom_to_hash_node_path =
        Mina_stdlib.Nonempty_list.(rev hash_node_to_bottom_path |> uncons)
      in
      (* Left and right branches of a node that is parent of the bottom node *)
      let init = replace_self ~f:(Fn.const (Tree.Account account)) bottom_el in
      List.foldi ~init bottom_to_hash_node_path ~f:build_tail_f
    in
    (* Traverses the tree along path, collecting nodes and untraversed sibling hashes
        Stops when encounters `Hash` or `Account` node.

       Returns the last visited node (`Hash` or `Account`), remainder of path and
       collected node/sibling hashes in bottom-to-top order.
    *)
    let rec traverse_through_nodes = function
      | Tree.Account _, _ :: _ ->
          failwith "path is longer than a tree's branch"
      | Account _, [] | Tree.Hash _, [] ->
          Tree.Account account
      | Tree.Hash h, fst_el :: rest ->
          let tail_l, tail_r =
            build_tail (Mina_stdlib.Nonempty_list.init fst_el rest)
          in
          Tree.Node (h, tail_l, tail_r)
      | Node (h, l, r), `Left _ :: rest ->
          Tree.Node (h, traverse_through_nodes (l, rest), r)
      | Node (h, l, r), `Right _ :: rest ->
          Tree.Node (h, l, traverse_through_nodes (r, rest))
      | Node _, [] ->
          failwith "path is shorter than a tree's branch"
    in
    traverse_through_nodes (tree0, List.rev path0)

  let add_path (t : t) path account_id account =
    let index =
      List.foldi path ~init:0 ~f:(fun i acc x ->
          match x with `Right _ -> acc + (1 lsl i) | `Left _ -> acc )
    in
    let replace_self ~f = function
      | `Left h_r ->
          (f None, Tree.Hash h_r)
      | `Right h_l ->
          (Tree.Hash h_l, f None)
    in
    { t with
      tree = add_path_impl ~replace_self t.tree path account
    ; indexes = (account_id, index) :: t.indexes
    }

  let add_wide_path_unsafe (t : t) path account_id account =
    let index =
      List.foldi path ~init:0 ~f:(fun i acc x ->
          match x with `Right _ -> acc + (1 lsl i) | `Left _ -> acc )
    in
    let replace_self ~f = function
      | `Left (h_l, h_r) ->
          (f (Some h_l), Tree.Hash h_r)
      | `Right (h_l, h_r) ->
          (Tree.Hash h_l, f (Some h_r))
    in
    { t with
      tree = add_path_impl ~replace_self t.tree path account
    ; indexes = (account_id, index) :: t.indexes
    }

  let iteri (t : t) ~f =
    let rec go acc i tree ~f =
      match tree with
      | Tree.Account a ->
          f acc a
      | Hash _ ->
          ()
      | Node (_, l, r) ->
          go acc (i - 1) l ~f ;
          go (acc + (1 lsl i)) (i - 1) r ~f
    in
    go 0 (t.depth - 1) t.tree ~f

  let ith_bit idx i = (idx lsr i) land 1 = 1

  let find_index_exn (t : t) aid =
    match List.Assoc.find t.indexes ~equal:Account_id.equal aid with
    | Some x ->
        x
    | None ->
        failwithf
          !"Sparse_ledger.find_index_exn: %{sexp:Account_id.t} not in %{sexp: \
            Account_id.t list}"
          aid
          (List.map t.indexes ~f:fst)
          ()

  let get_exn ({ T.tree; depth; _ } as t) idx =
    let rec go i tree =
      match (i < 0, tree) with
      | true, Tree.Account acct ->
          acct
      | false, Node (_, l, r) ->
          let go_right = ith_bit idx i in
          if go_right then go (i - 1) r else go (i - 1) l
      | _ ->
          let expected_kind = if i < 0 then "n account" else " node" in
          let kind =
            match tree with
            | Account _ ->
                "n account"
            | Hash _ ->
                " hash"
            | Node _ ->
                " node"
          in
          failwithf
            !"Sparse_ledger.get: Bad index %i. Expected a%s, but got a%s at \
              depth %i. Tree = %{sexp:t}, tree_depth = %d"
            idx expected_kind kind (depth - i) t depth ()
    in
    go (depth - 1) tree

  let set_exn (t : t) idx acct =
    let rec go i tree =
      match (i < 0, tree) with
      | true, Tree.Account _ ->
          Tree.Account acct
      | false, Node (_, l, r) ->
          let l, r =
            let go_right = ith_bit idx i in
            if go_right then (l, go (i - 1) r) else (go (i - 1) l, r)
          in
          Node (Hash.merge ~height:i (hash l) (hash r), l, r)
      | _ ->
          let expected_kind = if i < 0 then "n account" else " node" in
          let kind =
            match tree with
            | Account _ ->
                "n account"
            | Hash _ ->
                " hash"
            | Node _ ->
                " node"
          in
          failwithf
            "Sparse_ledger.set: Bad index %i. Expected a%s, but got a%s at \
             depth %i."
            idx expected_kind kind (t.depth - i) ()
    in
    { t with tree = go (t.depth - 1) t.tree }

  let path_exn { T.tree; depth; _ } idx =
    let rec go acc i tree =
      if i < 0 then acc
      else
        match tree with
        | Tree.Account _ ->
            failwithf "Sparse_ledger.path: Bad depth at index %i." idx ()
        | Hash _ ->
            failwithf "Sparse_ledger.path: Dead end at index %i." idx ()
        | Node (_, l, r) ->
            let go_right = ith_bit idx i in
            if go_right then go (`Right (hash l) :: acc) (i - 1) r
            else go (`Left (hash r) :: acc) (i - 1) l
    in
    go [] (depth - 1) tree
end

type ('hash, 'key, 'account) t = ('hash, 'key, 'account) T.t [@@deriving yojson]

let%test_module "sparse-ledger-test" =
  ( module struct
    module Hash = struct
      type t = Core_kernel.Md5.t [@@deriving sexp, compare]

      let equal h1 h2 = Int.equal (compare h1 h2) 0

      let to_yojson md5 = `String (Core_kernel.Md5.to_hex md5)

      let of_yojson = function
        | `String x ->
            Or_error.try_with (fun () -> Core_kernel.Md5.of_hex_exn x)
            |> Result.map_error ~f:Error.to_string_hum
        | _ ->
            Error "Expected a hex-encoded MD5 hash"

      let merge ~height x y =
        let open Md5 in
        digest_string
          (sprintf "sparse-ledger_%03d" height ^ to_binary x ^ to_binary y)

      let gen =
        Quickcheck.Generator.map String.quickcheck_generator
          ~f:Md5.digest_string
    end

    module Account = struct
      module T = struct
        type t =
          { name : Mina_stdlib.Bounded_types.String.Stable.V1.t
          ; favorite_number : int
          }
        [@@deriving bin_io, equal, sexp, yojson]
      end

      include T

      let key { name; _ } = name

      let data_hash t = Md5.digest_string (Binable.to_string (module T) t)

      let gen =
        let open Quickcheck.Generator.Let_syntax in
        let%map name = String.quickcheck_generator
        and favorite_number = Int.quickcheck_generator in
        { name; favorite_number }
    end

    module Account_id = struct
      type t = string [@@deriving sexp, equal, yojson]
    end

    include Make (Hash) (Account_id) (Account)

    let gen =
      let open Quickcheck.Generator in
      let open Let_syntax in
      let indexes max_depth t =
        let rec go addr d = function
          | Tree.Account a ->
              [ (Account.key a, addr) ]
          | Hash _ ->
              []
          | Node (_, l, r) ->
              go addr (d - 1) l @ go (addr lor (1 lsl d)) (d - 1) r
        in
        go 0 (max_depth - 1) t
      in
      let rec prune_hash_branches = function
        | Tree.Hash h ->
            Tree.Hash h
        | Account a ->
            Account a
        | Node (h, l, r) -> (
            match (prune_hash_branches l, prune_hash_branches r) with
            | Hash _, Hash _ ->
                Hash h
            | l, r ->
                Node (h, l, r) )
      in
      let rec gen depth =
        if depth = 0 then Account.gen >>| fun a -> Tree.Account a
        else
          let t =
            let sub = gen (depth - 1) in
            let%map l = sub and r = sub in
            Tree.Node (Hash.merge ~height:(depth - 1) (hash l) (hash r), l, r)
          in
          weighted_union
            [ (1. /. 3., Hash.gen >>| fun h -> Tree.Hash h); (2. /. 3., t) ]
      in
      let%bind depth = Int.gen_incl 0 16 in
      let%map tree = gen depth >>| prune_hash_branches in
      { T.tree; depth; indexes = indexes depth tree }

    let%test_unit "iteri consistent indices with t.indexes" =
      Quickcheck.test gen ~f:(fun t ->
          let indexes = Int.Set.of_list (t.indexes |> List.map ~f:snd) in
          iteri t ~f:(fun i _ ->
              [%test_result: bool]
                ~message:
                  "Iteri index should be contained in the indexes auxillary \
                   structure"
                ~expect:true (Int.Set.mem indexes i) ) )

    let%test_unit "path_test" =
      Quickcheck.test gen ~f:(fun t ->
          let root = { t with indexes = []; tree = Hash (merkle_root t) } in
          let t' =
            List.fold t.indexes ~init:root ~f:(fun acc (_, index) ->
                let account = get_exn t index in
                add_path acc (path_exn t index) (Account.key account) account )
          in
          assert (Tree.equal Hash.equal Account.equal t'.tree t.tree) )
  end )

1	(** Sparse Ledger implementation.
2
3	This module provides a space-efficient representation of a Merkle ledger
4	where most branches can be stored as hashes without holding the full
5	account data. It is parameterized over:
6	- the type of Merkle hashes,
7	- the type of account identifiers, and
8	- the type of account records.
9
10	A sparse ledger stores:
11	- [depth]: the height of the binary Merkle tree,
12	- [tree]: the partial Merkle tree structure with leaves that may be either
13	full accounts or hash placeholders,
14	- [indexes]: a mapping from account identifiers to their leaf index in the
15	tree.
16
17	The main functionality includes:
18	- Creating an empty ledger from a root hash ({!of_hash}),
19	- Retrieving accounts by index ({!get_exn}),
20	- Modifying accounts at a given index ({!set_exn}),
21	- Computing Merkle paths ({!path_exn}),
22	- Inserting accounts using Merkle paths ({!add_path}) or precomputed
23	sibling hashes ({!add_wide_path_unsafe}),
24	- Iterating over all accounts with their indices ({!iteri}),
25	- Computing the Merkle root ({!merkle_root}),
26	- Looking up the index of a given account ID ({!find_index_exn}).
27
28	{b Warning:}
29	- [add_wide_path_unsafe] does not recompute or verify hashes and can
30	produce an inconsistent tree if used incorrectly.
31	- Functions with [_exn] in their name will raise if the requested index or
32	path is invalid.
33
34	This structure is useful for:
35	- Incrementally reconstructing a Merkle ledger from partial proofs,
36	- Maintaining sparse proofs for a small set of accounts in a large ledger,
37	- Efficiently verifying account membership without storing all accounts.
38
39	See the test module for property-based tests ensuring consistency of index
40	tracking, Merkle path reconstruction, and hash correctness.
41	*)
42		144✔
43	open Core_kernel
44
45	module Tree = struct
46	[%%versioned
47	module Stable = struct
48	[@@@no_toplevel_latest_type]
49
50	module V1 = struct
51	type ('hash, 'account) t =	148✔
UNCOV 52	\| Account of 'account	×
53	\| Hash of 'hash	×
54	\| Node of 'hash * ('hash, 'account) t * ('hash, 'account) t	×
55	[@@deriving equal, sexp, yojson]	432✔
56
57	let rec to_latest acct_to_latest = function
58	\| Account acct ->	×
59	Account (acct_to_latest acct)	×
60	\| Hash hash ->	×
61	Hash hash
62	\| Node (hash, l, r) ->	×
63	Node (hash, to_latest acct_to_latest l, to_latest acct_to_latest r)	×
64	end
65	end]
66
67	type ('hash, 'account) t = ('hash, 'account) Stable.Latest.t =	×
68	\| Account of 'account	×
69	\| Hash of 'hash	×
70	\| Node of 'hash * ('hash, 'account) t * ('hash, 'account) t	×
71	[@@deriving equal, sexp, yojson]	×
72	end
73
74	module T = struct
75	[%%versioned
76	module Stable = struct
77	[@@@no_toplevel_latest_type]
78
79	module V2 = struct
80	type ('hash, 'key, 'account) t =	292✔
81	{ indexes : ('key * int) list	×
82	; depth : int	×
83	; tree : ('hash, 'account) Tree.Stable.V1.t	×
84	}
85	[@@deriving sexp, yojson]	720✔
86	end
87	end]
88
89	type ('hash, 'key, 'account) t = ('hash, 'key, 'account) Stable.Latest.t =	×
90	{ indexes : ('key * int) list	×
91	; depth : int	×
92	; tree : ('hash, 'account) Tree.t	×
93	}
94	[@@deriving sexp, yojson]	×
95	end
96
97	module type S = sig
98	type hash
99
100	type account_id
101
102	type account
103
104	type t = (hash, account_id, account) T.t [@@deriving sexp, yojson]
105
106	val of_hash : depth:int -> hash -> t
107
108	val get_exn : t -> int -> account
109
110	val path_exn : t -> int -> [ `Left of hash \| `Right of hash ] list
111
112	val set_exn : t -> int -> account -> t
113
114	val find_index_exn : t -> account_id -> int
115
116	val add_path :
117	t -> [ `Left of hash \| `Right of hash ] list -> account_id -> account -> t
118
119	(** Same as [add_path], but using the hashes provided in the wide merkle path
120	instead of recomputing them.
121	This is unsafe: the hashes are not checked or recomputed.
122	*)
123	val add_wide_path_unsafe :
124	t
125	-> [ `Left of hash * hash \| `Right of hash * hash ] list
126	-> account_id
127	-> account
128	-> t
129
130	val iteri : t -> f:(int -> account -> unit) -> unit
131
132	val merkle_root : t -> hash
133
134	val depth : t -> int
135	end
136
137	let tree { T.tree; _ } = tree	×
138
139	let of_hash ~depth h = { T.indexes = []; depth; tree = Hash h }	11,684✔
140
141	module Make (Hash : sig
142	type t [@@deriving equal, sexp, yojson, compare]
143
144	val merge : height:int -> t -> t -> t
145	end) (Account_id : sig
146	type t [@@deriving equal, sexp, yojson]
147	end) (Account : sig
148	type t [@@deriving equal, sexp, yojson]
149
150	val data_hash : t -> Hash.t
151	end) : sig
152	include
153	S
154	with type hash := Hash.t
155	and type account_id := Account_id.t
156	and type account := Account.t
157
158	val hash : (Hash.t, Account.t) Tree.t -> Hash.t
159	end = struct
160	type t = (Hash.t, Account_id.t, Account.t) T.t [@@deriving sexp, yojson]	×
161
162	let of_hash ~depth (hash : Hash.t) = of_hash ~depth hash	11,684✔
163
164	let hash : (Hash.t, Account.t) Tree.t -> Hash.t = function
165	\| Account a ->	12,472✔
166	Account.data_hash a
167	\| Hash h ->	22,684✔
168	h
169	\| Node (h, _, _) ->	22,350✔
170	h
171
172	type index = int [@@deriving sexp, yojson]	×
173
174	let depth { T.depth; _ } = depth	×
175
176	let merkle_root { T.tree; _ } = hash tree	10,922✔
177
178	let add_path_impl ~replace_self tree0 path0 account =
179	(* Takes height, left and right children and builds a pair of sibling nodes
180	one level up *)
181	let build_tail_f height (prev_l, prev_r) =	122,608✔
182	replace_self ~f:(fun mself ->	419,444✔
183	let self =	419,444✔
184	match mself with
185	\| Some self ->	396,792✔
186	self
187	\| None ->	22,652✔
188	Hash.merge ~height (hash prev_l) (hash prev_r)	22,652✔
189	in
190	Tree.Node (self, prev_l, prev_r) )
191	in
192	(* Builds the tail of path, i.e. part of the path that is not present in
193	the current ledger and we just add it all the way down to account
194	using the path *)
195	let build_tail hash_node_to_bottom_path =
196	let bottom_el, bottom_to_hash_node_path =	67,072✔
197	Mina_stdlib.Nonempty_list.(rev hash_node_to_bottom_path \|> uncons)	67,072✔
198	in
199	(* Left and right branches of a node that is parent of the bottom node *)
200	let init = replace_self ~f:(Fn.const (Tree.Account account)) bottom_el in	67,072✔
201	List.foldi ~init bottom_to_hash_node_path ~f:build_tail_f	67,072✔
202	in
203	(* Traverses the tree along path, collecting nodes and untraversed sibling hashes
204	Stops when encounters `Hash` or `Account` node.
205
206	Returns the last visited node (`Hash` or `Account`), remainder of path and
207	collected node/sibling hashes in bottom-to-top order.
208	*)
209	let rec traverse_through_nodes = function
210	\| Tree.Account _, _ :: _ ->	×
211	failwith "path is longer than a tree's branch"
212	\| Account _, [] \| Tree.Hash _, [] ->	112✔
213	Tree.Account account
214	\| Tree.Hash h, fst_el :: rest ->	67,072✔
215	let tail_l, tail_r =
216	build_tail (Mina_stdlib.Nonempty_list.init fst_el rest)	67,072✔
217	in
218	Tree.Node (h, tail_l, tail_r)	67,072✔
219	\| Node (h, l, r), `Left _ :: rest ->	1,668,990✔
220	Tree.Node (h, traverse_through_nodes (l, rest), r)	1,668,990✔
221	\| Node (h, l, r), `Right _ :: rest ->	569,278✔
222	Tree.Node (h, l, traverse_through_nodes (r, rest))	569,278✔
223	\| Node _, [] ->	×
224	failwith "path is shorter than a tree's branch"
225	in
226	traverse_through_nodes (tree0, List.rev path0)	122,608✔
227
228	let add_path (t : t) path account_id account =
229	let index =	48,608✔
230	List.foldi path ~init:0 ~f:(fun i acc x ->
231	match x with `Right _ -> acc + (1 lsl i) \| `Left _ -> acc )	119,392✔
232	in
233	let replace_self ~f = function	48,608✔
234	\| `Left h_r ->	46,956✔
235	(f None, Tree.Hash h_r)	46,956✔
236	\| `Right h_l ->	×
237	(Tree.Hash h_l, f None)	×
238	in
239	{ t with
240	tree = add_path_impl ~replace_self t.tree path account	48,608✔
241	; indexes = (account_id, index) :: t.indexes
242	}
243
244	let add_wide_path_unsafe (t : t) path account_id account =
245	let index =	74,000✔
246	List.foldi path ~init:0 ~f:(fun i acc x ->
247	match x with `Right _ -> acc + (1 lsl i) \| `Left _ -> acc )	496,340✔
248	in
249	let replace_self ~f = function	74,000✔
250	\| `Left (h_l, h_r) ->	393,106✔
251	(f (Some h_l), Tree.Hash h_r)	393,106✔
252	\| `Right (h_l, h_r) ->	46,454✔
253	(Tree.Hash h_l, f (Some h_r))	46,454✔
254	in
255	{ t with
256	tree = add_path_impl ~replace_self t.tree path account	74,000✔
257	; indexes = (account_id, index) :: t.indexes
258	}
259
260	let iteri (t : t) ~f =
261	let rec go acc i tree ~f =	×
262	match tree with	×
263	\| Tree.Account a ->	×
264	f acc a
265	\| Hash _ ->	×
266	()
267	\| Node (_, l, r) ->	×
268	go acc (i - 1) l ~f ;
269	go (acc + (1 lsl i)) (i - 1) r ~f	×
270	in
271	go 0 (t.depth - 1) t.tree ~f
272
273	let ith_bit idx i = (idx lsr i) land 1 = 1	15,860✔
274
275	let find_index_exn (t : t) aid =
276	match List.Assoc.find t.indexes ~equal:Account_id.equal aid with	3,224✔
277	\| Some x ->	3,224✔
278	x
279	\| None ->	×
280	failwithf
281	!"Sparse_ledger.find_index_exn: %{sexp:Account_id.t} not in %{sexp: \	×
282	Account_id.t list}"
283	aid
284	(List.map t.indexes ~f:fst)	×
285	()
286
287	let get_exn ({ T.tree; depth; _ } as t) idx =
288	let rec go i tree =	3,224✔
289	match (i < 0, tree) with	18,444✔
290	\| true, Tree.Account acct ->	3,224✔
291	acct
292	\| false, Node (_, l, r) ->	15,220✔
293	let go_right = ith_bit idx i in
294	if go_right then go (i - 1) r else go (i - 1) l	1,040✔
295	\| _ ->	×
296	let expected_kind = if i < 0 then "n account" else " node" in	×
297	let kind =
298	match tree with
299	\| Account _ ->	×
300	"n account"
301	\| Hash _ ->	×
302	" hash"
303	\| Node _ ->	×
304	" node"
305	in
306	failwithf
307	!"Sparse_ledger.get: Bad index %i. Expected a%s, but got a%s at \	×
308	depth %i. Tree = %{sexp:t}, tree_depth = %d"
309	idx expected_kind kind (depth - i) t depth ()
310	in
311	go (depth - 1) tree
312
313	let set_exn (t : t) idx acct =
314	let rec go i tree =	160✔
315	match (i < 0, tree) with	800✔
316	\| true, Tree.Account _ ->	160✔
317	Tree.Account acct
318	\| false, Node (_, l, r) ->	640✔
319	let l, r =
320	let go_right = ith_bit idx i in
321	if go_right then (l, go (i - 1) r) else (go (i - 1) l, r)	160✔
322	in
323	Node (Hash.merge ~height:i (hash l) (hash r), l, r)	640✔
324	\| _ ->	×
325	let expected_kind = if i < 0 then "n account" else " node" in	×
326	let kind =
327	match tree with
328	\| Account _ ->	×
329	"n account"
330	\| Hash _ ->	×
331	" hash"
332	\| Node _ ->	×
333	" node"
334	in
335	failwithf
336	"Sparse_ledger.set: Bad index %i. Expected a%s, but got a%s at \
337	depth %i."
338	idx expected_kind kind (t.depth - i) ()
339	in
340	{ t with tree = go (t.depth - 1) t.tree }	160✔
341
342	let path_exn { T.tree; depth; _ } idx =
343	let rec go acc i tree =	×
344	if i < 0 then acc	×
345	else
346	match tree with	×
347	\| Tree.Account _ ->	×
348	failwithf "Sparse_ledger.path: Bad depth at index %i." idx ()
349	\| Hash _ ->	×
350	failwithf "Sparse_ledger.path: Dead end at index %i." idx ()
351	\| Node (_, l, r) ->	×
352	let go_right = ith_bit idx i in
353	if go_right then go (`Right (hash l) :: acc) (i - 1) r	×
354	else go (`Left (hash r) :: acc) (i - 1) l	×
355	in
356	go [] (depth - 1) tree
357	end
358
359	type ('hash, 'key, 'account) t = ('hash, 'key, 'account) T.t [@@deriving yojson]	×
360
361	let%test_module "sparse-ledger-test" =
362	( module struct
363	module Hash = struct
364	type t = Core_kernel.Md5.t [@@deriving sexp, compare]	×
365
366	let equal h1 h2 = Int.equal (compare h1 h2) 0	×
367
368	let to_yojson md5 = `String (Core_kernel.Md5.to_hex md5)	×
369
370	let of_yojson = function
371	\| `String x ->	×
372	Or_error.try_with (fun () -> Core_kernel.Md5.of_hex_exn x)	×
373	\|> Result.map_error ~f:Error.to_string_hum
374	\| _ ->	×
375	Error "Expected a hex-encoded MD5 hash"
376
377	let merge ~height x y =
378	let open Md5 in	×
379	digest_string
380	(sprintf "sparse-ledger_%03d" height ^ to_binary x ^ to_binary y)	×
381
382	let gen =
383	Quickcheck.Generator.map String.quickcheck_generator	×
384	~f:Md5.digest_string
385	end
386
387	module Account = struct
388	module T = struct
389	type t =	×
390	{ name : Mina_stdlib.Bounded_types.String.Stable.V1.t	×
391	; favorite_number : int	×
392	}
393	[@@deriving bin_io, equal, sexp, yojson]	×
394	end
395
396	include T
397
398	let key { name; _ } = name	×
399
400	let data_hash t = Md5.digest_string (Binable.to_string (module T) t)	×
401
402	let gen =
403	let open Quickcheck.Generator.Let_syntax in
404	let%map name = String.quickcheck_generator
405	and favorite_number = Int.quickcheck_generator in
406	{ name; favorite_number }	×
407	end
408
409	module Account_id = struct
410	type t = string [@@deriving sexp, equal, yojson]	×
411	end
412
413	include Make (Hash) (Account_id) (Account)
414
415	let gen =
416	let open Quickcheck.Generator in
417	let open Let_syntax in
418	let indexes max_depth t =
419	let rec go addr d = function	×
420	\| Tree.Account a ->	×
421	[ (Account.key a, addr) ]	×
422	\| Hash _ ->	×
423	[]
424	\| Node (_, l, r) ->	×
425	go addr (d - 1) l @ go (addr lor (1 lsl d)) (d - 1) r	×
426	in
427	go 0 (max_depth - 1) t
428	in
429	let rec prune_hash_branches = function
430	\| Tree.Hash h ->	×
431	Tree.Hash h
432	\| Account a ->	×
433	Account a
434	\| Node (h, l, r) -> (	×
435	match (prune_hash_branches l, prune_hash_branches r) with	×
436	\| Hash _, Hash _ ->	×
437	Hash h
438	\| l, r ->	×
439	Node (h, l, r) )
440	in
441	let rec gen depth =
442	if depth = 0 then Account.gen >>\| fun a -> Tree.Account a	×
443	else
444	let t =	×
445	let sub = gen (depth - 1) in
446	let%map l = sub and r = sub in
447	Tree.Node (Hash.merge ~height:(depth - 1) (hash l) (hash r), l, r)	×
448	in
449	weighted_union
450	[ (1. /. 3., Hash.gen >>\| fun h -> Tree.Hash h); (2. /. 3., t) ]	×
451	in
452	let%bind depth = Int.gen_incl 0 16 in	×
453	let%map tree = gen depth >>\| prune_hash_branches in	×
454	{ T.tree; depth; indexes = indexes depth tree }	×
455
456	let%test_unit "iteri consistent indices with t.indexes" =
457	Quickcheck.test gen ~f:(fun t ->	×
458	let indexes = Int.Set.of_list (t.indexes \|> List.map ~f:snd) in	×
459	iteri t ~f:(fun i _ ->	×
460	[%test_result: bool]	×
461	~message:
462	"Iteri index should be contained in the indexes auxillary \
463	structure"
464	~expect:true (Int.Set.mem indexes i) ) )	×
465
466	let%test_unit "path_test" =
467	Quickcheck.test gen ~f:(fun t ->	×
468	let root = { t with indexes = []; tree = Hash (merkle_root t) } in	×
469	let t' =
470	List.fold t.indexes ~init:root ~f:(fun acc (_, index) ->
471	let account = get_exn t index in	×
472	add_path acc (path_exn t index) (Account.key account) account )	×
473	in
474	assert (Tree.equal Hash.equal Account.equal t'.tree t.tree) )	×
475	end )	288✔

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