Branch registration

8 files changed, 90 insertions, 35 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 =
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
index 23af476..524386b 100644
--- a/lib/protocols/Handle.ml
+++ b/lib/protocols/Handle.ml
@@ -39,6 +39,8 @@ let copy handle =
 let equal h1 h2 =
   Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash
 
+let hash h = (object_of h)#hash
+
 let release ({ valid; _ } as handle) =
   let o = object_of handle in
   valid := false;
diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli
index fb93cdd..f36c95e 100644
--- a/lib/protocols/Handle.mli
+++ b/lib/protocols/Handle.mli
@@ -20,3 +20,5 @@ val invoke : 'a interface -> ('a -> 'b) -> 'b
 val copy : t -> t option
 val equal : t -> t -> bool
 val release : t -> unit
+
+val hash : t -> Concepts.Hash.hash
diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml
index 8e7ef56..1f1a768 100644
--- a/test/integration/Registration.ml
+++ b/test/integration/Registration.ml
@@ -5,11 +5,38 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
 
   module H = Helpers.Storage.Make (S) (C)
   module I = Kernel.Initialization.Make (S)
+  module B = Kernel.Branch.Make (S)
+
+  module Error = struct
+    open Concepts.Condition
+
+    let not_found () = condition "not-found" "An expected object was not present" empty
+  end
 
   let run conn =
-    (* let open Utilities.Result in *)
-    let _root = I.initialize conn |> Helpers.condition_as_failure in
-    ()
+    let open Utilities.Result in
+    let open Protocols in
+    let registration =
+      begin
+        let* root = I.initialize conn in
+        let* root = Directory.from root |> Option.to_result ~none:(Error.not_found ()) in
+        let* bm = Directory.find root "branch" |> fmap (Option.to_result ~none:(Error.not_found ())) in
+        let* bm = Registry.from bm |> Option.to_result ~none:(Error.not_found ()) in
+        let* branch = B.make conn in
+        Registry.update bm "master" None (Some branch)
+      end
+      |> Helpers.condition_as_failure in
+    let presence =
+      begin
+        let* root = I.initialize conn in
+        let* root = Directory.from root |> Option.to_result ~none:(Error.not_found ()) in
+        let* bm = Directory.find root "branch" |> fmap (Option.to_result ~none:(Error.not_found ())) in
+        let* bm = Directory.from bm |> Option.to_result ~none:(Error.not_found ()) in
+        Directory.find bm "master" |> Result.map Option.is_some
+      end
+      |> Helpers.condition_as_failure in
+    check bool "" true registration;
+    check bool "" true presence
 
   let suite prefix =
     ( "registration/" ^ prefix,