From b60c67be7aaddb1a45a747bc6ac0402ab5d3a945 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 1 Aug 2026 00:22:52 +0000 Subject: Make the interface a bit friendlier --- lib/kernel/Merkle.ml | 103 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 79 insertions(+), 24 deletions(-) diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index 1fd364f..f58935f 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -1,25 +1,30 @@ -module type KEY = sig +module type VALUE = sig type t val encode : t -> Concepts.Representation.blob - val compare : t -> t -> Concepts.Ordering.ordering val decode : Concepts.Representation.blob -> (t, Concepts.Condition.condition) result end +module type KEY = sig + include VALUE + + val compare : t -> t -> Concepts.Ordering.ordering +end + module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig type address = Concepts.Hash.hash - type 'a node + type node - val find : S.transaction -> address -> ('a node option, Concepts.Condition.condition) result + val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result - val empty : 'a node + val empty : node - val hash_of : 'a node -> address + val hash_of : node -> address - val insert : S.transaction -> 'a node -> K.t -> address -> ('a node, Concepts.Condition.condition) result - val remove : S.transaction -> 'a node -> K.t -> ('a node, Concepts.Condition.condition) result - val lookup : S.transaction -> 'a node -> K.t -> (address option, Concepts.Condition.condition) result + val insert : S.transaction -> K.t -> address -> node -> (node, Concepts.Condition.condition) result + val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result + val lookup : S.transaction -> K.t -> node -> (address option, Concepts.Condition.condition) result end module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct @@ -31,7 +36,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let malformed_node () = condition "malformed-node" "A node representation did not conform to what was expected" empty end - type 'a node = + type node = Leaf of { keys : K.t BatFingerTree.t; values : address BatFingerTree.t } @@ -123,7 +128,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct | Some child -> Ok child | None -> failwith "A child node was not found on the underlying storage. Either your database is corrupted, or this is a bug on RNT!" - let rec lookup tx node key = + let rec lookup tx key node = let open Utilities.Result in let i, found = lookup1 (keys_of node) key in match node with @@ -131,7 +136,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct if found then Ok (Some (BatFingerTree.get values i)) else Ok None | Trunk { children; _ } -> let* child = BatFingerTree.get children (if found then i+1 else i) |> find' tx in - lookup tx child key + lookup tx key child let persist tx node = let open Utilities.Result in @@ -140,7 +145,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let* () = S.put tx addr data in Ok addr - type 'a op = Update of address * 'a node | Split of address * K.t * address + type op = Update of address * node | Split of address * K.t * address let emplace i v ft = let size = BatFingerTree.size ft in @@ -156,7 +161,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct |> BatFingerTree.append fl |> (Fun.flip BatFingerTree.append) fr - let insert1 node key value = + let insert1 key value node = let i, present = lookup1 (keys_of node) key in match node with | Leaf ({ keys; values } as leaf) -> @@ -237,17 +242,17 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let* addr = persist tx node in Ok (Update (addr, node)) - let rec insert' tx node key value = + let rec insert' tx key value node = let open Utilities.Result in match node with | Leaf _ -> - insert1 node key value + insert1 key value node |> commit_node tx | Trunk { keys; children } -> let i, found = lookup1 keys key in let i = if found then i+1 else i in let* child = BatFingerTree.get children i |> find' tx in - let* r = insert' tx child key value in + let* r = insert' tx key value child in match r with | Update (addr, _) -> Trunk { keys; children = BatFingerTree.set children i addr } @@ -257,9 +262,9 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct children = BatFingerTree.set children i l |> emplace (i + 1) r } |> commit_node tx - let insert tx node key value = + let insert tx key value node = let open Utilities.Result in - let* op = insert' tx node key value in + let* op = insert' tx key value node in match op with | Update (_, node) -> Ok node | Split (l, p, r) -> @@ -271,10 +276,60 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let* _ = persist tx new_root in Ok new_root - let remove tx node key = failwith "TODO" [@@warning "-27"] + let remove tx key node = failwith "TODO" [@@warning "-27"] end -(* module type UTILS = functor (T : TREE) (V : VALUE) -> sig *) -(* val insert : S.transaction -> 'a node -> 'a key -> V.t -> ('a node, Concepts.Condition.condition) result *) -(* val lookup : S.transaction -> 'a node -> 'a key -> (V.t option, Concepts.Condition.condition) result *) -(* end *) +module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig + type address + type node + + val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result + + val empty : node + + val hash_of : node -> address + + val insert : S.transaction -> K.t -> V.t -> node -> (node, Concepts.Condition.condition) result + val remove : S.transaction -> K.t -> node -> (node, Concepts.Condition.condition) result + val lookup : S.transaction -> K.t -> node -> (V.t option, Concepts.Condition.condition) result +end + +module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> struct + module T = Make (S) (K) + + type address = T.address + type node = T.node + + open Utilities.Result + + let intern tx v = + let data = V.encode v in + let addr = Concepts.Hash.hash_of_blob data in + let* () = S.put tx addr data in + Ok addr + + let retrieve tx addr = + let* data = S.get tx addr in + match data with + | None -> Ok None + | Some data -> + let* v = V.decode data in + Ok (Some v) + + let find = T.find + let empty = T.empty + let hash_of = T.hash_of + + let insert tx k v node = + let* addr = intern tx v in + T.insert tx k addr node + + let remove = T.remove + + let lookup tx k node = + let* addr = T.lookup tx k node in + match addr with + | None -> Ok None + | Some addr -> retrieve tx addr + +end -- cgit v1.2.3 From a26d8bbd4dd854c17a57d38ef8d8fa0361cc5d7c Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 1 Aug 2026 00:30:46 +0000 Subject: Move storage-related helpers to `Helpers` --- test/Helpers.ml | 25 +++++++++++++++++++++++++ test/unit/backend/Storage.ml | 27 ++++----------------------- 2 files changed, 29 insertions(+), 23 deletions(-) diff --git a/test/Helpers.ml b/test/Helpers.ml index bf34b82..784170c 100644 --- a/test/Helpers.ml +++ b/test/Helpers.ml @@ -17,3 +17,28 @@ let condition_as_failure = function let pp_value ppf v = Format.pp_print_string ppf (Concepts.Value.to_string v) let value = Alcotest.testable pp_value Concepts.Value.equal + +module Storage = struct + module type CONFIGURATOR = sig + val configure : string -> Rnt.Concepts.Configuration.term + end + + module LMDB_Configurator : CONFIGURATOR = struct + let configure base = + let open Sexplib.Sexp in + List [Atom "lmdb"; List [Atom "path"; Atom base]; List [Atom "mode"; Atom "420"]] + |> Rnt.Concepts.Configuration.term_of_sexp + end + + module Make (S : Abstract.Storage.STORAGE) (C : CONFIGURATOR) = struct + let with_connection f dir () = + with_temporary_directory dir begin fun dir -> + begin + let open Utilities.Result in + let* conn = S.connect (C.configure dir) in + Ok (f conn) + end + |> condition_as_failure + end + end +end diff --git a/test/unit/backend/Storage.ml b/test/unit/backend/Storage.ml index 91db411..76bda8b 100644 --- a/test/unit/backend/Storage.ml +++ b/test/unit/backend/Storage.ml @@ -1,21 +1,9 @@ open Rnt -module type CONFIGURATOR = sig - val configure : string -> Rnt.Concepts.Configuration.term -end - -module Make (S : Abstract.Storage.STORAGE) (C : CONFIGURATOR) = struct +module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct open Alcotest - let with_connection f () = - Helpers.with_temporary_directory "storage-test" begin fun dir -> - begin - let open Utilities.Result in - let* conn = S.connect (C.configure dir) in - Ok (f conn) - end - |> Helpers.condition_as_failure - end + module H = Helpers.Storage.Make (S) (C) let storage_and_retrieval conn = let key = Concepts.Hash.hash_of_value (Concepts.Value.String "value") in @@ -38,16 +26,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : CONFIGURATOR) = struct let suite prefix = ( "storage/" ^ prefix, - [test_case "storage-and-retrieval" `Quick (with_connection storage_and_retrieval)] ) -end - -module LMDB_Configurator : CONFIGURATOR = struct - let configure base = - let open Sexplib.Sexp in - List [Atom "lmdb"; List [Atom "path"; Atom base]; List [Atom "mode"; Atom "420"]] - |> Rnt.Concepts.Configuration.term_of_sexp + [test_case "storage-and-retrieval" `Quick (H.with_connection storage_and_retrieval "storage-test")] ) end -module LMDB = Make (Rnt.Backend.Storage.LMDB) (LMDB_Configurator) +module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) let suites () = [LMDB.suite "lmdb"] -- cgit v1.2.3 From a3f9ee8f227c94646bcc0a2269127b4fe369ebc0 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 1 Aug 2026 00:31:00 +0000 Subject: Some tests for the merkle tree --- test/test_rnt.ml | 1 + test/unit/kernel/Merkle.ml | 55 ++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 56 insertions(+) create mode 100644 test/unit/kernel/Merkle.ml diff --git a/test/test_rnt.ml b/test/test_rnt.ml index a2a8e84..d46be1e 100644 --- a/test/test_rnt.ml +++ b/test/test_rnt.ml @@ -2,5 +2,6 @@ let all_suites = Unit.Concepts.Serialization.suites () @ Unit.Backend.Storage.suites () @ Unit.Backend.Lifecycle.suites () + @ Unit.Kernel.Merkle.suites () let () = Alcotest.run "RNT" all_suites diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml new file mode 100644 index 0000000..a08426f --- /dev/null +++ b/test/unit/kernel/Merkle.ml @@ -0,0 +1,55 @@ +open Rnt + +module StringKey : Rnt.Kernel.Merkle.KEY with type t = string = struct + type t = string + + let encode s = String.to_bytes s |> Concepts.Representation.blob_of_bytes + let compare s1 s2 = String.compare s1 s2 |> Concepts.Ordering.of_int + let decode b = Concepts.Representation.bytes_of_blob b |> String.of_bytes |> Result.ok +end + +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) (StringKey) (StringKey) + + (* TODO: be a bit more comprehensive (ideally, we want to test splits as well) *) + let storage_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 + Ok (v1, v2, v3, v3', bogus) + end + |> Helpers.condition_as_failure + in + check (option string) "" (Some "v1") v1; + check (option string) "" (Some "v2") v2; + check (option string) "" (Some "v3") v3; + check (option string) "" (Some "toodles") v3'; + check (option string) "" None bogus + + (* TODO: this will need `remove` *) + (* let determinism _conn = *) + (* () *) + + let suite prefix = + ( "merkle/" ^ prefix, + [test_case "storage-and-lookup" `Quick (H.with_connection storage_and_lookup "merkle-test")]) +end + +module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) + +let suites () = [LMDB.suite "lmdb"] -- cgit v1.2.3 From 9cbaf09aaefb7e358bb18ac2eb31b0493f4b2fbb Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 1 Aug 2026 00:34:42 +0000 Subject: Be a bit more specific on this TODO --- lib/kernel/Merkle.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index f58935f..82fdae0 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -109,7 +109,10 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let to_blob node = to_bencode node |> Concepts.Codec.Bencode.to_blob - (* FIXME *) + (* TODO: we should probably cache this inside the node itself rather + than recalculating it every time. We could also allow the user to + create "uninterned" nodes that are not storage-backed, that could + be used for intermediates and the like. *) let hash_of node = to_blob node |> Concepts.Hash.hash_of_blob let find tx node = -- cgit v1.2.3 From b7a09b8c8913b26eb22b98aa77a324a1c23736e2 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sat, 1 Aug 2026 01:27:42 +0000 Subject: Actually test persistence --- test/unit/kernel/Merkle.ml | 36 ++++++++++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml index a08426f..f12182a 100644 --- a/test/unit/kernel/Merkle.ml +++ b/test/unit/kernel/Merkle.ml @@ -15,7 +15,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = module T = Rnt.Kernel.Merkle.Interface (S) (StringKey) (StringKey) (* TODO: be a bit more comprehensive (ideally, we want to test splits as well) *) - let storage_and_lookup conn = + let insert_and_lookup conn = let v1, v2, v3, v3', bogus = begin let open Utilities.Result in @@ -41,13 +41,45 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = check (option string) "" (Some "toodles") v3'; check (option string) "" None bogus + 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) "" (Some "v1") v1; + check (option string) "" (Some "v2") v2; + check (option string) "" (Some "v3") v3 + (* TODO: this will need `remove` *) (* let determinism _conn = *) (* () *) let suite prefix = ( "merkle/" ^ prefix, - [test_case "storage-and-lookup" `Quick (H.with_connection storage_and_lookup "merkle-test")]) + [test_case "insert-and-lookup" `Quick (H.with_connection insert_and_lookup "merkle-test"); + test_case "persistence" `Quick (H.with_connection persistence "merkle-test")]) end module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator) -- cgit v1.2.3