MinaProtocol / mina / 411

Committed 24 Jul 2025 03:14PM UTC coverage: 33.188% (-27.7%) from 60.871%

Build # 411

Build Type

push

buildkite

Committed by

web-flow

Commit Message

Merge pull request #17541 from MinaProtocol/brian/merge-compatible-into-develop

Merge compatible into develop

Run Details

164 of 702 new or added lines in 96 files covered. (23.36%)

18243 existing lines in 393 files now uncovered.

23983 of 72264 relevant lines covered (33.19%)

24667.26 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

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

MinaProtocol / mina / 411

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