fix multigroup deriving and tests

1 files changed, 22 insertions, 0 deletions

diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index 01675f0..1417a65 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -79,9 +79,31 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       val storage = conn
       val node = node (* FIXME: see the comment on Branch.ml *)
 
+      (* TODO: Add later to the lifecycle management, accounting for
+         derived instances. Callers must release the previous handle
+         when done with it so its instance can be cleaned up after the
+         last reference is released. *)
+      method deriving multigroup' =
+        let open Utilities.Result in
+        let* node' =
+          SI.with_transaction storage (fun tx ->
+              let* _ = SI.store_blob tx (Representation.to_blob multigroup') in
+              RelationM.find tx multigroup'.relations
+              |> fmap (Option.to_result ~none:(Error.incomplete_multigroup multigroup'.relations)) )
+        in
+        new multigroup storage multigroup' node' |> Protocols.Handle.make |> Result.ok
+
       method protocols : Protocols.Handle.protocol list =
+        let open Utilities.Result in
         Protocols.
           [ Addressable.make self;
+            Prototype.Associative.(
+              of_properties
+                [ ( "relation",
+                    update_only (fun node' ->
+                        Handle.require Addressable.from node'
+                        |> Result.map Addressable.address
+                        |> fmap (fun addr -> self#deriving {relations= addr}) ) ) ] );
             Prototype.Directory.of_properties
               [ ( "relation",
                   Prototype.mixture_of node (fun make node ->