1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
|
open Rnt
module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct
open Alcotest
module H = Helpers.Storage.Make (S) (C)
module T =
Rnt.Kernel.Merkle.Interface (S) (Rnt.Kernel.Merkle.StringKey) (Rnt.Kernel.Merkle.StringKey)
module M = Rnt.Kernel.Merkle.Make (S) (Rnt.Kernel.Merkle.StringKey)
(* TODO: be a bit more comprehensive (ideally, we want to test splits as well) *)
let insert_and_lookup conn =
let v1, v2, v3, v3', bogus =
begin
let open Utilities.Result in
let* tx = S.start conn in
let* node =
T.empty |> T.insert tx "k1" "v1" |>> T.insert tx "k2" "v2" |>> T.insert tx "k3" "v3"
in
let* node' = T.insert tx "k3" "toodles" node in
let* v1 = T.lookup tx "k1" node in
let* v2 = T.lookup tx "k2" node in
let* v3 = T.lookup tx "k3" node in
let* v3' = T.lookup tx "k3" node' in
let* bogus = T.lookup tx "fnord" node in
let* () = S.abort tx in
Ok (v1, v2, v3, v3', bogus)
end
|> Helpers.condition_as_failure
in
check (option string) "that in-memory reads from the first write work properly" (Some "v1") v1;
check (option string) "that in-memory reads from the second write work properly" (Some "v2") v2;
check (option string) "that in-memory reads from the third write work properly" (Some "v3") v3;
check (option string) "that in-memory reads from a value replacement work properly"
(Some "toodles") v3';
check (option string) "that in-memory reads from a non-existent key returns nothing" None bogus
let batching conn =
let intermediate, final =
begin
let open Utilities.Result in
let* tx = S.start conn in
let intermediate = ref None in
let* final =
T.with_batch tx (fun () ->
let* i = T.empty |> T.insert tx "tree" "maple" in
intermediate := Some (T.hash_of i);
T.insert tx "tree" "spruce" i )
in
let* () = S.commit tx in
Ok (Option.get !intermediate, T.hash_of final)
end
|> Helpers.condition_as_failure
in
let i_node, f_node =
begin
let open Utilities.Result in
let* tx = S.start conn in
let* intermediate = T.find tx intermediate in
let* final = T.find tx final in
Ok (intermediate, final)
end
|> Helpers.condition_as_failure
in
check bool "that the intermediate node does not get persisted" true (Option.is_none i_node);
check bool "that the final node does get persisted" true (Option.is_some f_node)
let persistence conn =
let addr =
begin
let open Utilities.Result in
let* tx = S.start conn in
let* node =
T.empty |> T.insert tx "k1" "v1" |>> T.insert tx "k2" "v2" |>> T.insert tx "k3" "v3"
in
let* () = S.commit tx in
Ok (T.hash_of node)
end
|> Helpers.condition_as_failure
in
let v1, v2, v3 =
begin
let open Utilities.Result in
let* tx = S.start conn in
let* node = T.find tx addr |> Result.map Option.get in
let* v1 = T.lookup tx "k1" node in
let* v2 = T.lookup tx "k2" node in
let* v3 = T.lookup tx "k3" node in
Ok (v1, v2, v3)
end
|> Helpers.condition_as_failure
in
check (option string) "that on-disk reads from the first write work properly" (Some "v1") v1;
check (option string) "that on-disk reads from the second write work properly" (Some "v2") v2;
check (option string) "that on-disk reads from the third write work properly" (Some "v3") v3
let iteration conn =
let keys, values =
begin
let open Utilities.Result in
let* tx = S.start conn in
let* node =
T.empty |> T.insert tx "k1" "v1" |>> T.insert tx "k2" "v2" |>> T.insert tx "k3" "v3"
in
let* keys = T.fold_left tx (fun acc k _ -> k :: acc) [] node |> Result.map List.rev in
let* values = T.fold_left tx (fun acc _ v -> v :: acc) [] node |> Result.map List.rev in
let* () = S.abort tx in
Ok (keys, values)
end
|> Helpers.condition_as_failure
in
check (list string) "that keys are properly enumerated from left to right" ["k1"; "k2"; "k3"]
keys;
check (list string) "that values are properly enumerated from left to right" ["v1"; "v2"; "v3"]
values
(* TODO: this will need `remove` *)
(* let determinism _conn = *)
(* () *)
(* Enough keys for the tree to grow trunks, so removal reaches through
them and empties whole leaves. *)
let removal conn =
let kept, gone, keys, emptied =
begin
let open Utilities.Result in
let* tx = S.start conn in
let key i = Printf.sprintf "k%03d" i in
let all = List.init 300 key in
let* full = List.fold_left (fun node k -> node |>> T.insert tx k k) (Ok T.empty) all in
let evens = List.filteri (fun i _ -> i mod 2 = 0) all in
let* half = List.fold_left (fun node k -> node |>> T.remove tx k) (Ok full) evens in
let* kept = T.lookup tx (key 1) half in
let* gone = T.lookup tx (key 2) half in
let* keys = T.keys tx half in
let* none = List.fold_left (fun node k -> node |>> T.remove tx k) (Ok half) all in
let* () = S.abort tx in
Ok (kept, gone, BatFingerTree.to_list keys, T.hash_of none)
end
|> Helpers.condition_as_failure
in
check (option string) "a key not removed stays" (Some "k001") kept;
check (option string) "a removed key is gone" None gone;
check (list string) "exactly the odd keys remain"
(List.init 150 (fun i -> Printf.sprintf "k%03d" ((2 * i) + 1)))
keys;
check bool "removing every key leaves the empty tree" true
(Concepts.Hash.hash_equals emptied (T.hash_of T.empty))
let range conn =
let key i = Printf.sprintf "k%04d" i in
let all = List.init 500 key in
let from_on k = List.filter (fun k' -> k' >= k) all in
let whole, present, absent, before, after, bounded, stopped =
begin
let open Utilities.Result in
let* tx = S.start conn in
let scrambled = List.init 500 (fun i -> key (i * 7919 mod 500)) in
let* root =
List.fold_left
(fun node k -> node |>> M.insert tx k (Concepts.Hash.hash_of_bytes (Bytes.of_string k)))
(Ok M.empty) scrambled
in
let walk ?from ?until () =
M.fold_left ?from ?until tx (fun acc k _ -> k :: acc) [] root |> Result.map List.rev
in
let* whole = walk () in
let* present = walk ~from:"k0200" () in
let* absent = walk ~from:"k0200a" () in
let* before = walk ~from:"a" () in
let* after = walk ~from:"z" () in
let* bounded = walk ~from:"k0200" ~until:(fun k -> k >= "k0300") () in
let* stopped = walk ~until:(fun _ -> true) () in
let* () = S.abort tx in
Ok (whole, present, absent, before, after, bounded, stopped)
end
|> Helpers.condition_as_failure
in
check (list string) "a walk with no range visits every key in order" all whole;
check (list string) "a walk from a stored key starts at it" (from_on "k0200") present;
check (list string) "a walk from an absent key starts at the next one" (from_on "k0201") absent;
check (list string) "a walk from before the first key visits every key" all before;
check (list string) "a walk from past the last key visits nothing" [] after;
check (list string) "a walk stops before the first key until accepts"
(List.init 100 (fun i -> key (200 + i)))
bounded;
check (list string) "a walk that stops at once visits nothing" [] stopped
let suite =
( "kernel/merkle",
[ test_case "insert-and-lookup" `Quick (H.with_connection insert_and_lookup "merkle-test");
test_case "batching" `Quick (H.with_connection batching "merkle-test");
test_case "persistence" `Quick (H.with_connection persistence "merkle-test");
test_case "iteration" `Quick (H.with_connection iteration "merkle-test");
test_case "removal" `Quick (H.with_connection removal "merkle-test");
test_case "range" `Quick (H.with_connection range "merkle-test") ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
let suites () = [LMDB.suite]
|
