2903

Committed 15 Nov 2024 01:59PM UTC coverage: 36.723% (-25.0%) from 61.682%

Build # 2903

Build Type

Pull #16342

buildkite

Committed by

dkijania

Commit Message

Merge branch 'dkijania/remove_publish_job_from_pr_comp' into dkijania/remove_publish_job_from_pr_dev

Pull Request Pull Request #16342: [DEV] Publish debians only on nightly and stable

Run Details

15 of 40 new or added lines in 14 files covered. (37.5%)

15175 existing lines in 340 files now uncovered.

24554 of 66863 relevant lines covered (36.72%)

20704.91 hits per line

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

37.42

/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 : 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	21✔
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 =	33✔
10	\| Account of 'account	96✔
11	\| Hash of 'hash	×
12	\| Node of 'hash * ('hash, 'account) t * ('hash, 'account) t	×
13	[@@deriving equal, sexp, yojson]	243✔
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 =	54✔
39	{ indexes : ('key * int) list	×
40	; depth : int	×
41	; tree : ('hash, 'account) Tree.Stable.V1.t	×
42	}
43	[@@deriving sexp, yojson]	111✔
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 }	2,364✔
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	2,364✔
121
122	let hash : (Hash.t, Account.t) Tree.t -> Hash.t = function
123	\| Account a ->	496✔
124	Account.data_hash a
125	\| Hash h ->	388✔
126	h
127	\| Node (h, _, _) ->	3,762✔
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	2,750✔
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) =	4,864✔
140	replace_self ~f:(fun mself ->	23,244✔
141	let self =	23,244✔
142	match mself with
143	\| Some self ->	22,936✔
144	self
145	\| None ->	308✔
146	Hash.merge ~height (hash prev_l) (hash prev_r)	308✔
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 =	4,320✔
155	Mina_stdlib.Nonempty_list.(rev hash_node_to_bottom_path \|> uncons)	4,320✔
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	4,320✔
159	List.foldi ~init bottom_to_hash_node_path ~f:build_tail_f	4,320✔
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 ->	4,320✔
173	let tail_l, tail_r =
174	build_tail (Mina_stdlib.Nonempty_list.init fst_el rest)	4,320✔
175	in
176	Tree.Node (h, tail_l, tail_r)	4,320✔
177	\| Node (h, l, r), `Left _ :: rest ->	13,736✔
178	Tree.Node (h, traverse_through_nodes (l, rest), r)	13,736✔
179	\| Node (h, l, r), `Right _ :: rest ->	3,116✔
180	Tree.Node (h, l, traverse_through_nodes (r, rest))	3,116✔
181	\| Node _, [] ->	×
182	failwith "path is shorter than a tree's branch"
183	in
184	traverse_through_nodes (tree0, List.rev path0)	4,864✔
185
186	let add_path (t : t) path account_id account =
187	let index =	704✔
188	List.foldi path ~init:0 ~f:(fun i acc x ->
189	match x with `Right _ -> acc + (1 lsl i) \| `Left _ -> acc )	1,408✔
190	in
191	let replace_self ~f = function	704✔
192	\| `Left h_r ->	660✔
193	(f None, Tree.Hash h_r)	660✔
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	704✔
199	; indexes = (account_id, index) :: t.indexes
200	}
201
202	let add_wide_path_unsafe (t : t) path account_id account =
203	let index =	4,160✔
204	List.foldi path ~init:0 ~f:(fun i acc x ->
205	match x with `Right _ -> acc + (1 lsl i) \| `Left _ -> acc )	6,308✔
206	in
207	let replace_self ~f = function	4,160✔
208	\| `Left (h_l, h_r) ->	22,304✔
209	(f (Some h_l), Tree.Hash h_r)	22,304✔
210	\| `Right (h_l, h_r) ->	4,600✔
211	(Tree.Hash h_l, f (Some h_r))	4,600✔
212	in
213	{ t with
214	tree = add_path_impl ~replace_self t.tree path account	4,160✔
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	4,264✔
232
233	let find_index_exn (t : t) aid =
234	match List.Assoc.find t.indexes ~equal:Account_id.equal aid with	906✔
235	\| Some x ->	906✔
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 =	906✔
247	match (i < 0, tree) with	4,530✔
248	\| true, Tree.Account acct ->	906✔
249	acct
250	\| false, Node (_, l, r) ->	3,624✔
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 =	×
348	{ name : Bounded_types.String.Stable.V1.t; favorite_number : int }	×
UNCOV 349	[@@deriving bin_io, equal, sexp, yojson]	×
350	end
351
352	include T
353
UNCOV 354	let key { name; _ } = name	×
355
UNCOV 356	let data_hash t = Md5.digest_string (Binable.to_string (module T) t)	×
357
358	let gen =
359	let open Quickcheck.Generator.Let_syntax in
360	let%map name = String.quickcheck_generator
361	and favorite_number = Int.quickcheck_generator in
UNCOV 362	{ name; favorite_number }	×
363	end
364
365	module Account_id = struct
366	type t = string [@@deriving sexp, equal, yojson]	×
367	end
368
369	include Make (Hash) (Account_id) (Account)
370
371	let gen =
372	let open Quickcheck.Generator in
373	let open Let_syntax in
374	let indexes max_depth t =
UNCOV 375	let rec go addr d = function	×
UNCOV 376	\| Tree.Account a ->	×
UNCOV 377	[ (Account.key a, addr) ]	×
UNCOV 378	\| Hash _ ->	×
379	[]
UNCOV 380	\| Node (_, l, r) ->	×
UNCOV 381	go addr (d - 1) l @ go (addr lor (1 lsl d)) (d - 1) r	×
382	in
383	go 0 (max_depth - 1) t
384	in
385	let rec prune_hash_branches = function
UNCOV 386	\| Tree.Hash h ->	×
387	Tree.Hash h
UNCOV 388	\| Account a ->	×
389	Account a
UNCOV 390	\| Node (h, l, r) -> (	×
UNCOV 391	match (prune_hash_branches l, prune_hash_branches r) with	×
UNCOV 392	\| Hash _, Hash _ ->	×
393	Hash h
UNCOV 394	\| l, r ->	×
395	Node (h, l, r) )
396	in
397	let rec gen depth =
UNCOV 398	if depth = 0 then Account.gen >>\| fun a -> Tree.Account a	×
399	else
UNCOV 400	let t =	×
401	let sub = gen (depth - 1) in
402	let%map l = sub and r = sub in
UNCOV 403	Tree.Node (Hash.merge ~height:(depth - 1) (hash l) (hash r), l, r)	×
404	in
405	weighted_union
UNCOV 406	[ (1. /. 3., Hash.gen >>\| fun h -> Tree.Hash h); (2. /. 3., t) ]	×
407	in
UNCOV 408	let%bind depth = Int.gen_incl 0 16 in	×
UNCOV 409	let%map tree = gen depth >>\| prune_hash_branches in	×
UNCOV 410	{ T.tree; depth; indexes = indexes depth tree }	×
411
412	let%test_unit "iteri consistent indices with t.indexes" =
UNCOV 413	Quickcheck.test gen ~f:(fun t ->	×
UNCOV 414	let indexes = Int.Set.of_list (t.indexes \|> List.map ~f:snd) in	×
UNCOV 415	iteri t ~f:(fun i _ ->	×
UNCOV 416	[%test_result: bool]	×
417	~message:
418	"Iteri index should be contained in the indexes auxillary \
419	structure"
UNCOV 420	~expect:true (Int.Set.mem indexes i) ) )	×
421
422	let%test_unit "path_test" =
UNCOV 423	Quickcheck.test gen ~f:(fun t ->	×
UNCOV 424	let root = { t with indexes = []; tree = Hash (merkle_root t) } in	×
425	let t' =
426	List.fold t.indexes ~init:root ~f:(fun acc (_, index) ->
UNCOV 427	let account = get_exn t index in	×
UNCOV 428	add_path acc (path_exn t index) (Account.key account) account )	×
429	in
UNCOV 430	assert (Tree.equal Hash.equal Account.equal t'.tree t.tree) )	×
431	end )	42✔

MinaProtocol / mina / 2903

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