Multigroup registration stub

3 files changed, 22 insertions, 8 deletions

diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index e5e36cf..c8ffa62 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -38,7 +38,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   let encode = Representation.to_blob
   let decode = Representation.of_blob
 
-  class multigroup conn value node = object
+  class multigroup conn value node = object (self)
     inherit Lifecycle.null
 
     method to_string = "multigroup"
@@ -48,15 +48,18 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     val node = node (* FIXME: see the comment on Branch.ml *)
 
     method protocols : Protocols.Handle.protocol list =
-      [ Prototype.Directory.of_properties
-          [ "relation", Prototype.mixture
-                          [ RMDirectory.make
-                              ~storage ~node
-                              ~constructor:(R.wrap storage) ] ] ]
+      Protocols.[ Addressable.make self;
+                  Prototype.Directory.of_properties
+                    [ "relation", Prototype.mixture
+                                    [ RMDirectory.make
+                                        ~storage ~node
+                                        ~constructor:(R.wrap storage) ] ] ]
 
     method hash =
       Representation.to_blob multigroup
       |> Concepts.Hash.hash_of_blob
+
+    method address = self#hash
   end
 
   let wrap conn value =
@@ -64,4 +67,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let* node = SI.with_transaction conn (fun tx -> RelationM.find tx value.relations)
                 |> fmap (Option.to_result ~none:(Error.incomplete_multigroup value.relations)) in
     new multigroup conn value node |> Protocols.Handle.make |> Result.ok
+
+  let make conn =
+    let open Utilities.Result in
+    SI.with_transaction conn (fun tx ->
+        let* empty = RelationM.empty_under tx in
+        let multigroup = { relations = empty } in
+        let* _ = SI.store_blob tx (Representation.to_blob multigroup) in
+        new multigroup conn multigroup RelationM.empty |> Protocols.Handle.make |> Result.ok)
 end
diff --git a/lib/kernel/Multigroup.mli b/lib/kernel/Multigroup.mli
index 88aee30..fc58dad 100644
--- a/lib/kernel/Multigroup.mli
+++ b/lib/kernel/Multigroup.mli
@@ -5,5 +5,5 @@ module Make (S : Abstract.Storage.STORAGE) : sig
   val decode : Concepts.Blob.t -> (t, Concepts.Condition.condition) result
 
   val wrap : S.connection -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result
-
+  val make : S.connection -> (Protocols.Handle.t, Concepts.Condition.condition) result
 end
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 25ce09a..b83c9b2 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -23,13 +23,16 @@ let walking f g handle path =
     | x::xs ->
        let open Utilities.Result in
        let open Protocols in
-       let* dir = Handle.require Directory.from handle in
+       let* dir =
+         Handle.require Directory.from handle
+         |> Result.map_error Concepts.Condition.(complement ("before-segment" |=| Concepts.Value.String x)) in
        let* elem = Directory.find dir x in
        match elem with
        | None -> Error (Error.path_not_found path)
        | Some elem -> f x handle (fun () -> walk elem xs)
   in
   walk handle path
+  |> Result.map_error Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string path)))
 
 let lookup = walking (fun _ _ f -> f ()) Result.ok