|
|
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"
|> fmap (T.insert tx "k2" "v2")
|> fmap (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"
|> fmap (T.insert tx "k2" "v2")
|> fmap (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"
|> fmap (T.insert tx "k2" "v2")
|> fmap (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 = *)
(* () *)
let suite prefix =
( "merkle/" ^ prefix,
[ 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") ] )
end
module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)
let suites () = [LMDB.suite "lmdb"]
|
