aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Utilities.ml73
-rw-r--r--lib/Utilities.mli12
-rw-r--r--lib/kernel/Initialization.ml122
-rw-r--r--lib/kernel/Initialization.mli10
-rw-r--r--lib/kernel/Merkle.ml51
-rw-r--r--test/unit/kernel/Merkle.ml40
6 files changed, 288 insertions, 20 deletions
diff --git a/lib/Utilities.ml b/lib/Utilities.ml
index 52483b3..e4ee9c3 100644
--- a/lib/Utilities.ml
+++ b/lib/Utilities.ml
@@ -7,14 +7,73 @@ end
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
module Option = struct
diff --git a/lib/Utilities.mli b/lib/Utilities.mli
index 9661796..f149889 100644
--- a/lib/Utilities.mli
+++ b/lib/Utilities.mli
@@ -7,6 +7,9 @@ end
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
@@ -20,3 +23,12 @@ module Atomic : sig
(* This is silly *)
val mswap : 'a Atomic.t -> ('a -> ('a, 'b) result) -> ('a Atomic.t, '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/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 c2c2932..ababb03 100644
--- a/lib/kernel/Merkle.ml
+++ b/lib/kernel/Merkle.ml
@@ -23,9 +23,13 @@ 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
+
+ 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
@@ -76,7 +80,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)) ->
@@ -116,7 +120,7 @@ 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 (S.Hash node) in
match data with
@@ -125,9 +129,9 @@ module Make : TREE = functor (S : Abstract.Storage.STORAGE) (K : KEY) -> struct
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!"
@@ -283,6 +287,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
@@ -298,6 +318,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
@@ -322,6 +346,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
@@ -338,6 +368,19 @@ 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
module StringKey : KEY with type t = string = struct
diff --git a/test/unit/kernel/Merkle.ml b/test/unit/kernel/Merkle.ml
index 6fd493a..d5a075e 100644
--- a/test/unit/kernel/Merkle.ml
+++ b/test/unit/kernel/Merkle.ml
@@ -23,15 +23,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 =
@@ -60,9 +61,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 = *)
@@ -71,7 +92,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)
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-04 20:23:28 +0000