diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/kernel/Branch.ml | 24 | ||||
| -rw-r--r-- | lib/kernel/Branch.mli | 3 | ||||
| -rw-r--r-- | lib/kernel/BranchManager.ml | 55 | ||||
| -rw-r--r-- | lib/kernel/Initialization.ml | 4 | ||||
| -rw-r--r-- | lib/kernel/Merkle.ml | 2 |
5 files changed, 56 insertions, 32 deletions
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml index 2aaa9ca..31442f6 100644 --- a/lib/kernel/Branch.ml +++ b/lib/kernel/Branch.ml @@ -52,9 +52,27 @@ module Make (S : Abstract.Storage.STORAGE) = struct Ok { multigroups; previous } end - class branch = object - (* TODO *) + class branch storage value = object + inherit Lifecycle.null + + val storage : S.connection = storage + val branch : t = value + + method protocols : Protocols.Handle.protocol list = [] + + method hash = + Representation.to_blob branch + |> Concepts.Hash.hash_of_blob end - let load _tx _conn _name _addr = failwith "TODO" + let load tx conn addr = + let open Utilities.Result in + let* data = SI.get_req tx (S.Hash addr) in + let* branch = Representation.of_blob data in + Ok (new branch conn branch |> Protocols.Handle.make) + + let make conn = + let open Utilities.Result in + let* empty = SI.with_transaction conn MultigroupM.empty_under in + Ok (new branch conn { multigroups = empty; previous = None } |> Protocols.Handle.make) end diff --git a/lib/kernel/Branch.mli b/lib/kernel/Branch.mli index 02be2ed..82bdbb7 100644 --- a/lib/kernel/Branch.mli +++ b/lib/kernel/Branch.mli @@ -1,5 +1,6 @@ module Make (S : Abstract.Storage.STORAGE) : sig type t - val load : S.transaction -> S.connection -> string -> Concepts.Hash.hash -> (Protocols.Handle.t, Concepts.Condition.condition) result + val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result + val load : S.transaction -> S.connection -> Concepts.Hash.hash -> (Protocols.Handle.t, Concepts.Condition.condition) result end diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml index 596a1cb..c1e4aef 100644 --- a/lib/kernel/BranchManager.ml +++ b/lib/kernel/BranchManager.ml @@ -4,16 +4,6 @@ module Error = struct let invalid_root head = condition "invalid-root" "The root hash for the database state is missing from the backend. Either your storage is corrupted, or this is a bug in RNT!" ("hash" |=| (Concepts.Value.String (Concepts.Hash.to_hum_string head))) - - let no_such_branch branch_name = - condition "no-such-branch" "A branch with the specified name was not found" - ("branch" |=| Concepts.Value.String branch_name) - - let branch_head_mismatch branch_name reference head = - condition "branch-head-mismatch" "The HEAD of the branch did not match what was expected" - ("branch" |=| Concepts.Value.String branch_name & - "reference" |=| Concepts.Value.String (Concepts.Hash.to_hum_string reference) & - "head" |=| Concepts.Value.String (Concepts.Hash.to_hum_string head)) end module Make (S : Abstract.Storage.STORAGE) = struct @@ -44,21 +34,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct let head = Atomic.get head in M.lookup tx branch_name head) - method update branch_name reference new_branch = - let open Utilities.Result in - SI.with_transaction storage (fun tx -> - Utilities.Atomic.mswap head (fun head -> - let* branch = M.lookup tx branch_name head - |> fmap (Option.to_result ~none:(Error.no_such_branch branch_name)) in - if branch = reference then - let* new_head = M.insert tx label new_branch head in - let* _ = persist_root tx label (M.hash_of new_head) in - Ok new_head - else - Error (Error.branch_head_mismatch branch_name reference branch))) - |> Result.map ignore - - method protocols = Protocols.[Directory.make self] + method protocols = Protocols.[Directory.make self; Registry.make self] method list = SI.with_transaction storage (fun tx -> Atomic.get head |> M.keys tx) @@ -68,7 +44,34 @@ module Make (S : Abstract.Storage.STORAGE) = struct let* head = Atomic.get head |> M.lookup tx key in match head with | None -> Ok None - | Some head -> B.load tx storage key head |> Result.map Option.some) + | Some head -> B.load tx storage head |> Result.map Option.some) + + method update key reference value = + let open Utilities.Result in + SI.with_transaction storage (fun tx -> + match + Utilities.Atomic.mswap head (fun head -> + let* branch = M.lookup tx key head |> Result.map_error (fun e -> Some e) in + (* FIXME: we should have an addressable protocol rather than assuming the hash is the content store address *) + let reference = Option.map Protocols.Handle.hash reference in + let value = Option.map Protocols.Handle.hash value in + if branch = reference then + begin + let* new_head = match value with + | Some value -> M.insert tx key value head + | None -> M.remove tx key head + in + let* _ = persist_root tx label (M.hash_of new_head) in + Ok new_head + end + |> Result.map_error (fun e -> Some e) + else + Error None) + with + | Ok _ -> Ok true + | Error None -> Ok false + | Error (Some e) -> Error e) + end let make storage label = diff --git a/lib/kernel/Initialization.ml b/lib/kernel/Initialization.ml index ab91dbc..d213b66 100644 --- a/lib/kernel/Initialization.ml +++ b/lib/kernel/Initialization.ml @@ -6,7 +6,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct let open Protocols in let root = Namespace.make () in let registry = Registry.from root |> Option.get in - let* branch = BM.make conn "rnt-head" in - let* _ = Registry.update registry "branch" None (Some branch) in + let* branch_manager = BM.make conn "rnt-head" in + let* _ = Registry.update registry "branch" None (Some branch_manager) in Ok root end diff --git a/lib/kernel/Merkle.ml b/lib/kernel/Merkle.ml index 05adbd2..b2e341a 100644 --- a/lib/kernel/Merkle.ml +++ b/lib/kernel/Merkle.ml @@ -314,6 +314,7 @@ module type INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) (V : VA val find : S.transaction -> address -> (node option, Concepts.Condition.condition) result val empty : node + val empty_under : S.transaction -> (address, Concepts.Condition.condition) result val hash_of : node -> address @@ -356,6 +357,7 @@ module Interface : INTERFACE = functor (S : Abstract.Storage.STORAGE) (K : KEY) let find = T.find let empty = T.empty + let empty_under = T.empty_under let hash_of = T.hash_of let insert tx k v node = |