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
|
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)
(* 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 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") ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
let suites () = [LMDB.suite]
|
