From d512411992a6a2b50fcdf03689129f70f530116f Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Sat, 1 Aug 2026 14:22:05 -0300 Subject: Initialization with Branch State and Index --- lib/concepts/BranchState.ml | 87 ++++++++++++++++++++++++++++++ lib/concepts/BranchState.mli | 17 ++++++ lib/kernel/BranchIndex.ml | 29 ++++++++++ lib/kernel/BranchIndex.mli | 28 ++++++++++ lib/kernel/Initialization.ml | 122 ++++++++++++++++++++++++++++++++++++++++++ lib/kernel/Initialization.mli | 10 ++++ lib/kernel/Merkle.ml | 2 + 7 files changed, 295 insertions(+) create mode 100644 lib/concepts/BranchState.ml create mode 100644 lib/concepts/BranchState.mli create mode 100644 lib/kernel/BranchIndex.ml create mode 100644 lib/kernel/BranchIndex.mli create mode 100644 lib/kernel/Initialization.ml create mode 100644 lib/kernel/Initialization.mli diff --git a/lib/concepts/BranchState.ml b/lib/concepts/BranchState.ml new file mode 100644 index 0000000..e8c6636 --- /dev/null +++ b/lib/concepts/BranchState.ml @@ -0,0 +1,87 @@ +type address = Hash.hash + +(* A branch state records durable branch data only. The runtime registry paths + mounted around it, such as /system/branches/master, are derived at + initialization and should not be persisted as part of [current]. *) +type t = {current: address; history: address; tip: address option} + +module Field = struct + let current = "current" + let history = "history" + let tip = "tip" +end + +module Error = struct + open Condition + + let malformed_branch_state () = + condition "branch-state-malformed" + "A branch state representation did not conform to what was expected" empty + + let malformed_hash length = + condition "branch-state-malformed-hash" "A branch state address was not a valid hash" + ("length" |=| Value.Integer length) +end + +let make ~current ~history ~tip = {current; history; tip} +let current branch_state = branch_state.current +let history branch_state = branch_state.history +let tip branch_state = branch_state.tip +let address_bencode address = Object.Field.address address + +let address_option_bencode = function + | None -> Codec.Bencode.List [] + | Some address -> Codec.Bencode.List [address_bencode address] + +let require_address_bencode = function + | Codec.Bencode.String raw -> + if String.length raw = Hash.size then Ok (Hash.of_raw_string raw) + else Error (Error.malformed_hash (String.length raw)) + | _ -> Error (Error.malformed_branch_state ()) + +let require_address_option key data = + let open Utilities.Result in + let* value = Codec.Bencode.field key data in + let* entries = Codec.Bencode.as_list value in + match entries with + | [] -> Ok None + | [value] -> + let* address = require_address_bencode value in + Ok (Some address) + | _ -> Error (Error.malformed_branch_state ()) + +let equal_address_option left right = + match left, right with + | None, None -> true + | Some left, Some right -> Hash.hash_equals left right + | _ -> false + +module Body = struct + type nonrec t = t + + let tag = 's' + let malformed = Error.malformed_branch_state + + let equal left right = + Hash.hash_equals left.current right.current + && Hash.hash_equals left.history right.history + && equal_address_option left.tip right.tip + + let fields branch_state = + [ Field.current, address_bencode branch_state.current; + Field.history, address_bencode branch_state.history; + Field.tip, address_option_bencode branch_state.tip ] + + let of_fields data = + let open Utilities.Result in + let* current = + Object.Field.require_address ~malformed:Error.malformed_hash Field.current data + in + let* history = + Object.Field.require_address ~malformed:Error.malformed_hash Field.history data + in + let* tip = require_address_option Field.tip data in + Ok {current; history; tip} +end + +include (Object.Codec.Make (Body) : Object.S with type t := t) diff --git a/lib/concepts/BranchState.mli b/lib/concepts/BranchState.mli new file mode 100644 index 0000000..45792cc --- /dev/null +++ b/lib/concepts/BranchState.mli @@ -0,0 +1,17 @@ +type t +type address = Hash.hash + +include Object.S with type t := t + +(** Durable state of one branch head. + + [current] is the branch-visible catalog root, not the runtime namespace + rooted at [/system]. Runtime scaffolding is rebuilt during initialization. + [history] is the ordered commit-stream tree root. [tip] is absent until the + first real commit, so initialization does not create a synthetic commit just + to make the branch non-empty. *) +val make : current:address -> history:address -> tip:address option -> t + +val current : t -> address +val history : t -> address +val tip : t -> address option diff --git a/lib/kernel/BranchIndex.ml b/lib/kernel/BranchIndex.ml new file mode 100644 index 0000000..d1efa9a --- /dev/null +++ b/lib/kernel/BranchIndex.ml @@ -0,0 +1,29 @@ +type address = Concepts.Hash.hash +type root = address +type branch_name = string +type branch_state_root = address + +let default_branch_name = "master" + +module Branch_name = struct + type t = branch_name + + let encode name = Concepts.Codec.Bencode.(String name |> to_blob) + let compare left right = Concepts.Ordering.of_int (String.compare left right) + + let decode blob = + Concepts.Codec.Bencode.of_blob blob |> Utilities.Result.fmap Concepts.Codec.Bencode.as_string +end + +module Make (Store : Abstract.Storage.STORAGE) = struct + module Tree = Merkle.Make (Store) (Branch_name) + + type tree = Tree.node + + let empty = Tree.empty + let hash_of = Tree.hash_of + let persist = Tree.persist + let find = Tree.find + let find_branch = Tree.lookup + let put_branch = Tree.insert +end diff --git a/lib/kernel/BranchIndex.mli b/lib/kernel/BranchIndex.mli new file mode 100644 index 0000000..5a867bf --- /dev/null +++ b/lib/kernel/BranchIndex.mli @@ -0,0 +1,28 @@ +type address = Concepts.Hash.hash +type root = address +type branch_name = string +type branch_state_root = address + +val default_branch_name : branch_name + +module Make (Store : Abstract.Storage.STORAGE) : sig + type tree + + val empty : tree + val hash_of : tree -> root + val persist : Store.transaction -> tree -> (root, Concepts.Condition.condition) result + val find : Store.transaction -> root -> (tree option, Concepts.Condition.condition) result + + val find_branch : + Store.transaction -> + branch_name -> + tree -> + (branch_state_root option, Concepts.Condition.condition) result + + val put_branch : + Store.transaction -> + branch_name -> + branch_state_root -> + tree -> + (tree, Concepts.Condition.condition) result +end diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml new file mode 100644 index 0000000..767dcca --- /dev/null +++ b/lib/kernel/Initialization.ml @@ -0,0 +1,122 @@ +type address = Concepts.Hash.hash +type branch_index_root = address + +let fixed_label = "rnt.initialization" +let fixed_label_address = Concepts.Hash.hash_of_bytes (Bytes.of_string fixed_label) + +module Error = struct + open Concepts.Condition + + let malformed_address length = + condition "initialization-malformed-address" + "The initialization fixed key does not contain a valid address" + ("length" |=| Concepts.Value.Integer length) + + let missing_branch_index address = + condition "initialization-branch-index-missing" + "The initialization fixed key points at a missing branch index" + ("address" |=| Concepts.Value.String (Concepts.Hash.to_raw_string address)) +end + +let address_to_blob address = + Concepts.Object.Field.address address |> Concepts.Codec.Bencode.to_blob + +let address_of_blob blob = + let open Utilities.Result in + let* data = Concepts.Codec.Bencode.of_blob blob in + let* raw = Concepts.Codec.Bencode.as_string data in + if String.length raw = Concepts.Hash.size then Ok (Concepts.Hash.of_raw_string raw) + else Error (Error.malformed_address (String.length raw)) + +module Make (Store : Abstract.Storage.STORAGE) = struct + module Branch_index = BranchIndex.Make (Store) + + let finish tx = function + | Ok value -> + let open Utilities.Result in + let* () = Store.commit tx in + Ok value + | Error condition -> + let _ = Store.abort tx in + Error condition + + let with_transaction connection body = + let open Utilities.Result in + let* tx = Store.start connection in + body tx |> finish tx + + let read_in_transaction tx = + let open Utilities.Result in + let* fixed = Store.get tx fixed_label_address in + match fixed with + | None -> Ok None + | Some fixed -> + let* root = address_of_blob fixed in + let* branch_index = Branch_index.find tx root in + begin match branch_index with + | Some _ -> Ok (Some root) + | None -> Error (Error.missing_branch_index root) + end + + let store_blob tx blob = + let open Utilities.Result in + let address = Concepts.Hash.hash_of_blob blob in + let* () = Store.put tx address blob in + Ok address + + let store_fixed_root tx root = Store.put tx fixed_label_address (address_to_blob root) + + let create_initial_branch_state tx = + let open Utilities.Result in + (* The first branch state has no synthetic "genesis" commit. Both [current] + and [history] point at persisted empty trees; the runtime mounts /system + around those roots after initialization. *) + let* empty_root = Branch_index.persist tx Branch_index.empty in + Concepts.BranchState.make ~current:empty_root ~history:empty_root ~tip:None + |> Concepts.BranchState.to_blob + |> store_blob tx + + let ensure_default_branch tx root branch_index = + let open Utilities.Result in + let* current = Branch_index.find_branch tx BranchIndex.default_branch_name branch_index in + match current with + | Some _ -> Ok root + | None -> + (* Older initialization slices could leave a valid but empty branch + index. Repair it by publishing a new root containing master. *) + let* branch_state = create_initial_branch_state tx in + let* branch_index = + Branch_index.put_branch tx BranchIndex.default_branch_name branch_state branch_index + in + Ok (Branch_index.hash_of branch_index) + + let create_in_transaction tx = + let open Utilities.Result in + let* branch_state = create_initial_branch_state tx in + let* branch_index = + Branch_index.put_branch tx BranchIndex.default_branch_name branch_state Branch_index.empty + in + let root = Branch_index.hash_of branch_index in + let* () = store_fixed_root tx root in + Ok root + + let read connection = with_transaction connection read_in_transaction + + let initialize connection = + with_transaction connection (fun tx -> + let open Utilities.Result in + let* current = read_in_transaction tx in + match current with + | None -> create_in_transaction tx + | Some root -> + let* branch_index = Branch_index.find tx root in + begin match branch_index with + | None -> Error (Error.missing_branch_index root) + | Some branch_index -> + let* root' = ensure_default_branch tx root branch_index in + let* () = + if Concepts.Hash.hash_equals root root' then Ok () else store_fixed_root tx root' + in + Ok root' + end ) +end diff --git a/lib/kernel/Initialization.mli b/lib/kernel/Initialization.mli new file mode 100644 index 0000000..4f98215 --- /dev/null +++ b/lib/kernel/Initialization.mli @@ -0,0 +1,10 @@ +type address = Concepts.Hash.hash +type branch_index_root = address + +val fixed_label : string +val fixed_label_address : address + +module Make (Store : Abstract.Storage.STORAGE) : sig + val read : Store.connection -> (branch_index_root option, Concepts.Condition.condition) result + val initialize : Store.connection -> (branch_index_root, Concepts.Condition.condition) result +end diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index 82fdae0..5bd427f 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -22,6 +22,8 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig val hash_of : node -> address + val persist : S.transaction -> node -> (address, 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 -- cgit v1.2.3 From 07c3ad6114efe808ee595f83f29dd0c79a6f2536 Mon Sep 17 00:00:00 2001 From: Estevan Castilho Date: Sun, 23 Aug 2026 03:04:34 +0000 Subject: B-tree iteration constructs (#49) * Generic `sequence`, finger tree `map2`/`zip` * `fold_left` on B-trees * Finger tree `join` * `iter`, more tests * We do not need `keys` when traversing through a trunk node --- lib/Utilities.ml | 73 +++++++++++++++++++++++++++++++++++++++++----- lib/Utilities.mli | 12 ++++++++ lib/concepts/Relation.ml | 2 +- lib/kernel/Merkle.ml | 51 ++++++++++++++++++++++++++++---- test/unit/kernel/Merkle.ml | 40 +++++++++++++++++++------ 5 files changed, 156 insertions(+), 22 deletions(-) diff --git a/lib/Utilities.ml b/lib/Utilities.ml index 9ae0119..a6b36c7 100644 --- a/lib/Utilities.ml +++ b/lib/Utilities.ml @@ -1,12 +1,71 @@ module Result = struct let ( let* ) = Result.bind let fmap f m = Result.bind m f +end + +module type SEQUENCE = sig + type 'a t + + val empty : 'a t + val cons : 'a -> 'a t -> 'a t + val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end + +module Generic (S : SEQUENCE) = struct + let sequence ms = + let open Result in + S.fold + (fun m acc -> + let* acc = acc in + let* m = m in + Ok (S.cons m acc)) + ms + (Ok S.empty) +end + +module List = struct + module ListSequence : SEQUENCE with type 'a t = 'a list = struct + type 'a t = 'a list + + let empty = [] + let cons x xs = x::xs + let fold = List.fold_right + end + + include Generic (ListSequence) +end + +module FingerTree = struct + module FingerTreeSequence : SEQUENCE with type 'a t = 'a BatFingerTree.t = struct + type 'a t = 'a BatFingerTree.t + + let empty = BatFingerTree.empty + let cons x xs = BatFingerTree.cons xs x + let fold f xs acc = BatFingerTree.fold_right + (Fun.flip f) + acc + xs + end + + include Generic (FingerTreeSequence) + + let map2 f xs ys = + let rec frob xs ys acc = + match BatFingerTree.front xs with + | None -> acc + | Some (xs', x) -> + match BatFingerTree.front ys with + | None -> acc + | Some (ys', y) -> + f x y + |> BatFingerTree.snoc acc + |> frob xs' ys' + in + frob xs ys BatFingerTree.empty + + let zip xs ys = map2 (fun x y -> x, y) xs ys - let sequence ms = List.fold_right - (fun m acc -> - let* acc = acc in - let* m = m in - Ok (m::acc)) - ms - (Ok []) + let join ss sep = + BatFingerTree.print ~first:"" ~last:"" ~sep:sep BatIO.nwrite + |> Fun.flip BatIO.to_string ss end diff --git a/lib/Utilities.mli b/lib/Utilities.mli index cdb53df..2735009 100644 --- a/lib/Utilities.mli +++ b/lib/Utilities.mli @@ -1,5 +1,17 @@ module Result : sig val ( let* ) : ('a, 'e) result -> ('a -> ('b, 'e) result) -> ('b, 'e) result val fmap : ('a -> ('b, 'e) result) -> ('a, 'e) result -> ('b, 'e) result +end + +module List : sig val sequence : ('a, 'b) result list -> ('a list, 'b) result end + +module FingerTree : sig + val map2 : ('a -> 'b -> 'c) -> 'a BatFingerTree.t -> 'b BatFingerTree.t -> 'c BatFingerTree.t + val zip : 'a BatFingerTree.t -> 'b BatFingerTree.t -> ('a * 'b) BatFingerTree.t + + val sequence : ('a, 'b) result BatFingerTree.t -> ('a BatFingerTree.t, 'b) result + + val join : string BatFingerTree.t -> string -> string +end diff --git a/lib/concepts/Relation.ml b/lib/concepts/Relation.ml index a4fb341..ef5ac12 100644 --- a/lib/concepts/Relation.ml +++ b/lib/concepts/Relation.ml @@ -50,7 +50,7 @@ let schema_of_bencode value = |> List.map (fun (name, domain) -> let* domain = Codec.Bencode.as_string domain in Ok (name, domain) ) - |> sequence + |> Utilities.List.sequence |> Result.map schema_of_list module Body = struct diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index 5bd427f..af703d7 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -27,6 +27,8 @@ module type TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> sig 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 + + val fold_left : S.transaction -> ('c -> K.t -> address -> 'c) -> 'c -> node -> ('c, Concepts.Condition.condition) result end module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct @@ -77,7 +79,7 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct let decode_list f data = data |> fmap as_list |> Result.map (List.map f) - |> fmap sequence + |> fmap Utilities.List.sequence |> Result.map BatFingerTree.of_list in function | Tagged ('!', (Dict _ as data)) -> @@ -117,18 +119,18 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct be used for intermediates and the like. *) let hash_of node = to_blob node |> Concepts.Hash.hash_of_blob - let find tx node = + let find tx addr = let open Utilities.Result in - let* data = S.get tx node in + let* data = S.get tx addr in match data with | None -> Ok None | Some data -> let* node = from_blob data in Ok (Some node) - let find' tx node = + let find' tx addr = let open Utilities.Result in - let* child = find tx node in + let* child = find tx addr in match child with | 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!" @@ -282,6 +284,22 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct Ok new_root let remove tx key node = failwith "TODO" [@@warning "-27"] + + let rec fold_left tx f acc = + let open Utilities.Result in + function + | Leaf { keys; values } -> + Utilities.FingerTree.zip keys values + |> BatFingerTree.fold_left (fun acc (k, v) -> f acc k v) acc + |> Result.ok + | Trunk { children; _ } -> + BatFingerTree.fold_left + (fun acc addr -> + let* acc = acc in + let* node = find' tx addr in + fold_left tx f acc node) + (Ok acc) children + end module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> sig @@ -297,6 +315,10 @@ module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VA 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 + + val fold_left : S.transaction -> ('c -> K.t -> V.t -> 'c) -> 'c -> node -> ('c, Concepts.Condition.condition) result + + val iter : S.transaction -> (K.t -> V.t -> 'a) -> node -> (unit, Concepts.Condition.condition) result end module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VALUE) -> struct @@ -321,6 +343,12 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) let* v = V.decode data in Ok (Some v) + let retrieve' tx addr = + let* v = retrieve tx addr in + match v with + | Some v -> Ok v + | None -> failwith "A value was not found on the underlying storage. Either your database is corrupted, or this is a bug on RNT!" + let find = T.find let empty = T.empty let hash_of = T.hash_of @@ -337,4 +365,17 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) | None -> Ok None | Some addr -> retrieve tx addr + let fold_left tx f acc node = + T.fold_left tx + (fun acc k addr -> + let* acc = acc in + let* v = retrieve' tx addr in + Ok (f acc k v)) + (Ok acc) node + |> Result.join + + let iter tx f node = + fold_left tx + (fun _ k v -> f k v |> ignore) + () node end diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml index f12182a..5c610bb 100644 --- a/test/unit/kernel/Merkle.ml +++ b/test/unit/kernel/Merkle.ml @@ -31,15 +31,16 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = 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) "" (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 + 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 persistence conn = let addr = @@ -68,9 +69,29 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = 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) "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 = *) @@ -79,7 +100,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = let suite prefix = ( "merkle/" ^ prefix, [test_case "insert-and-lookup" `Quick (H.with_connection insert_and_lookup "merkle-test"); - test_case "persistence" `Quick (H.with_connection persistence "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) -- cgit v1.2.3