1 files changed, 70 insertions, 22 deletions

diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index b0ba06e..25c2e7b 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -1,9 +1,9 @@
 module Make (S : Abstract.Storage.STORAGE) = struct
-  (* Branch has a name, a set of multigroups, and a backlink to the previous state
-     multigroup has a name and a set of schemas
-     schema has a name and a set of relations
+  (* A branch state holds its multigroups and a backlink to the state it
+     succeeded, each multigroup its relations:
 
-     \branch\master\multigroup\universe\schema\sky\relation\planet
+     \system\branch\master\multigroup\universe\relation\planet
+     \system\branch\master\previous\multigroup\universe\relation\planet
    *)
 
   module SI = Storage.Make (S)
@@ -70,7 +70,15 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
   let pointer_of hash = SI.Pointer.make Loader.load (S.Hash hash)
 
-  class branch storage value node =
+  let node_of tx branch =
+    let open Utilities.Result in
+    MultigroupM.find tx branch.multigroups
+    |> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups))
+
+  (* Given [root], the stored programs of this state run through the
+     evaluators registered under it, against this very state, so an
+     earlier state reads as it was. *)
+  class branch ?root storage value node =
     object (self)
       inherit Lifecycle.null
       method to_string = "branch"
@@ -84,15 +92,52 @@ module Make (S : Abstract.Storage.STORAGE) = struct
         let* node' =
           SI.with_transaction storage (fun tx ->
               let* _ = SI.store_blob tx (Representation.to_blob branch'') in
-              MultigroupM.find tx branch'.multigroups
-              |> fmap (Option.to_result ~none:(Error.incomplete_branch branch'.multigroups)) )
+              node_of tx branch' )
         in
-        new branch storage branch'' node' |> Protocols.Handle.make |> Result.ok
+        new branch ?root storage branch'' node' |> Protocols.Handle.make |> Result.ok
+
+      method private previous =
+        match branch.previous with
+        | None -> Ok None
+        | Some pointer ->
+            SI.with_read storage (fun tx ->
+                let open Utilities.Result in
+                let* previous = SI.Pointer.deref tx pointer in
+                let* node = node_of tx previous in
+                Ok (Some (Protocols.Handle.make {<branch = previous; node>})) )
 
       method protocols : Protocols.Handle.protocol list =
+        let bind =
+          Option.map
+            (fun root -> {EphemeralRelation.root; within= Protocols.Handle.make {<>}})
+            root
+        in
+        let multigroups =
+          Prototype.mixture_of node (fun make node ->
+              [ MMAddressable.make ~node:(MultigroupM.into node);
+                MMDirectory.make ~storage ~node ~constructor:(M.load ?bind storage);
+                MMAssociative.make ~admit:M.admit ~storage ~node:(MultigroupM.into node)
+                  ~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok ) ] )
+        in
         let open Utilities.Result in
+        let admits (m, multigroup) =
+          Protocols.Handle.releasing multigroup (fun () ->
+              let* admission = Protocols.Admission.require multigroup in
+              let* violations = Protocols.Admission.check admission in
+              Ok
+                (List.map
+                   (fun (d, witness) ->
+                     Path.(to_string ("multigroup" @/ m @/ "denial" @/ d @/ this)), witness )
+                   violations ) )
+        in
         Protocols.
           [ Addressable.make self;
+            Admission.make
+              object
+                method check =
+                  let* named = Prototype.Directory.children multigroups in
+                  List.map admits named |> Utilities.List.sequence |> Result.map List.concat
+              end;
             Prototype.Associative.(
               of_properties
                 [ ( "multigroup",
@@ -100,28 +145,31 @@ module Make (S : Abstract.Storage.STORAGE) = struct
                         Handle.require Addressable.from node'
                         |> Result.map Addressable.address
                         |> fmap (fun addr -> self#deriving {branch with multigroups= addr}) ) ) ] );
-            Prototype.Directory.of_properties
-              [ ( "multigroup",
-                  Prototype.mixture_of node (fun make node ->
-                      [ MMAddressable.make ~node:(MultigroupM.into node);
-                        MMDirectory.make ~storage ~node ~constructor:(M.wrap storage);
-                        MMAssociative.make ~storage ~node:(MultigroupM.into node)
-                          ~constructor:(fun node' -> MultigroupM.from node' |> make |> Result.ok )
-                      ] ) ) ] ]
+            Directory.make
+              object
+                method list =
+                  Ok
+                    (BatFingerTree.of_list
+                       ( "multigroup"
+                       :: Option.fold ~none:[] ~some:(fun _ -> ["previous"]) branch.previous ) )
+
+                method find =
+                  function
+                  | "multigroup" -> Ok (Some multigroups)
+                  | "previous" -> self#previous
+                  | _ -> Ok None
+              end ]
 
       method hash = Representation.to_blob branch |> Concepts.Hash.hash_of_blob
       method address = self#hash
     end
 
-  let load tx conn addr =
+  let load ?root 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
-    let* node =
-      MultigroupM.find tx branch.multigroups
-      |> fmap (Option.to_result ~none:(Error.incomplete_branch branch.multigroups))
-    in
-    Ok (new branch conn branch node |> Protocols.Handle.make)
+    let* node = node_of tx branch in
+    Ok (new branch ?root conn branch node |> Protocols.Handle.make)
 
   let make conn =
     let open Utilities.Result in