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/kernel/BranchIndex.ml | 29 ++++++++++ lib/kernel/BranchIndex.mli | 28 ++++++++++ lib/kernel/Initialization.ml | 122 ++++++++++++++++++++++++++++++++++++++++++ lib/kernel/Initialization.mli | 10 ++++ lib/kernel/Merkle.ml | 2 + 5 files changed, 191 insertions(+) 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 (limited to 'lib/kernel') 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/kernel/Merkle.ml | 51 ++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 46 insertions(+), 5 deletions(-) (limited to 'lib/kernel') 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 -- cgit v1.2.3