1 files changed, 21 insertions, 5 deletions

diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index 3531748..886d100 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -6,8 +6,21 @@ module Error = struct
       "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 refused violations =
+    condition "refused" "The state is not admitted: a denial in it holds tuples"
+      (List.fold_left
+         (fun ps (path, witness) ->
+           ps & path |=| Concepts.Value.String (Concepts.Tuple.to_string witness) )
+         empty violations )
 end
 
+let admitted state =
+  let open Utilities.Result in
+  let* admission = Protocols.Admission.require state in
+  let* violations = Protocols.Admission.check admission in
+  if violations = [] then Ok () else Error (Error.refused violations)
+
 module Make (S : Abstract.Storage.STORAGE) = struct
   module M = Merkle.Make (S) (Merkle.StringKey)
   module SI = Storage.Make (S)
@@ -28,7 +41,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let data = Concepts.Hash.blob_of_hash addr in
     S.put tx (S.Label label) data
 
-  class manager storage label head =
+  class manager ?root storage label head =
     object (self)
       inherit Lifecycle.null
       inherit Identity.of_id
@@ -51,11 +64,14 @@ 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 head |> Result.map Option.some )
+            | Some head -> B.load ?root tx storage head |> Result.map Option.some )
 
+      (* a head moves only to an admitted state, judged before the head is
+         taken, since judging may run stored programs that read storage *)
       method update key reference value =
         let open Utilities.Result in
         let open Protocols in
+        let* () = Option.fold ~none:(Ok ()) ~some:admitted value in
         SI.with_transaction storage (fun tx ->
             match
               Utilities.Atomic.mswap head (fun head ->
@@ -92,14 +108,14 @@ module Make (S : Abstract.Storage.STORAGE) = struct
             | Error (Some e) -> Error e )
     end
 
-  let make storage label =
+  let make ?root storage label =
     let open Utilities.Result in
     SI.with_transaction storage (fun tx ->
         let* addr = root_for tx label in
         match addr with
-        | None -> Ok (new manager storage label M.empty |> Protocols.Handle.make)
+        | None -> Ok (new manager ?root storage label M.empty |> Protocols.Handle.make)
         | Some addr ->
             let* head = M.find tx addr in
             let* head = Option.to_result ~none:(Error.invalid_root addr) head in
-            Ok (new manager storage label head |> Protocols.Handle.make) )
+            Ok (new manager ?root storage label head |> Protocols.Handle.make) )
 end