tests

3 files changed, 33 insertions, 10 deletions

diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index a371a0c..4d2fb1d 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -53,9 +53,12 @@ module Make (S : Abstract.Storage.STORAGE) = struct
             | None -> Ok None
             | Some head -> B.load ?root tx storage head |> Result.map Option.some )
 
+      (* a head moves only to a valid 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:Denial.check value in
         SI.with_transaction storage (fun tx ->
             match
               Utilities.Atomic.mswap head (fun head ->
diff --git a/test/integration/Registration.ml b/test/integration/Registration.ml
index 5430270..2060ae6 100644
--- a/test/integration/Registration.ml
+++ b/test/integration/Registration.ml
@@ -6,7 +6,6 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
   module I = Kernel.Initialization.Make (S)
   module B = Kernel.Branch.Make (S)
   module M = Kernel.Multigroup.Make (S)
-  module Sc = Kernel.Schema.Make (S)
   module E = Kernel.EphemeralRelation.Make (S)
 
   let book =
@@ -27,20 +26,18 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
     let open Utilities.Result in
     begin
       let* root = I.initialize ~evaluators:["fol", Evaluators.FOL.make ()] conn in
-      let* schema = Sc.make conn in
       let* relation = H.relation conn ["title"; "author"] [titled "SQL and Relational Theory"] in
       let* view =
         E.persist conn ~name:"shelf" ~evaluator:Evaluators.FOL.name
           ~code:Evaluators.FOL.(encode (Project (Base book, BatFingerTree.singleton "title")))
           (BatMap.String.singleton "title" {Protocols.Schematics.domain= "string"; provenance= []})
       in
-      let* schema =
-        Kernel.Path.(
-          assoc_all schema
-            ["relation" @/ this, "book", Some relation; "relation" @/ this, "shelf", Some view] )
-      in
       let* multigroup = M.make conn in
-      let* multigroup = Kernel.Path.(assoc multigroup ("schema" @/ this) "default" (Some schema)) in
+      let relations = Kernel.Path.("schema" @/ "default" @/ "relation" @/ this) in
+      let* multigroup =
+        Kernel.Path.assoc_all multigroup
+          [relations, "book", Some relation; relations, "shelf", Some view]
+      in
       let* branch = B.make conn in
       let* branch' =
         Kernel.Path.(assoc branch ("multigroup" @/ this) "library" (Some multigroup))
diff --git a/test/unit/kernel/Branch.ml b/test/unit/kernel/Branch.ml
index ee42463..ebce298 100644
--- a/test/unit/kernel/Branch.ml
+++ b/test/unit/kernel/Branch.ml
@@ -102,7 +102,8 @@ let a_scope_reads_names_from_its_home () =
   check (option (list Helpers.value)) "what is not there is not found" None (found "stock");
   check
     (option (list Helpers.value))
-    "four parts name an attribute, not a relation" None (found "library:default:book:title");
+    "four parts name an attribute, not a relation" None
+    (found "library:default:book:title");
   let catalog = ok (K.Scope.catalog (ok (K.Scope.require scope))) in
   check (list string) "the catalog is every relation of the state"
     ["library:default:book"; "library:default:shelf"; "store:archive:old"; "store:default:stock"]
@@ -134,6 +135,26 @@ let a_stored_relation_is_viewed_and_a_program_run () =
   check bool "an unqualified name is the system's" true
     (Result.is_error (K.Source.run root ~language:"toy" ~within:root "that"))
 
+(* shelf, stored as a denial, says no book may be shelved *)
+let a_head_moves_only_to_a_valid_state () =
+  let root = fresh [] in
+  publish root ["denial:no-books", Some shelved];
+  let head = ok (K.Path.lookup root master) in
+  let proposed =
+    ok
+      (K.Path.assoc_all head
+         [ ( K.Path.("multigroup" @/ "library" @/ "schema" @/ "default" @/ "relation" @/ this),
+             "book",
+             Some (books ["Codd"]) ) ] )
+  in
+  check bool "a state with a book is judged invalid without landing" true
+    (Result.is_error (K.Denial.check proposed));
+  check bool "publishing it is refused" true
+    (Result.is_error
+       (K.Scope.publish root ~branch:"master" ~home:library ["book", Some (books ["Codd"])]) );
+  check bool "and the head stays" true
+    (C.Hash.hash_equals (address head) (address (ok (K.Path.lookup root master))))
+
 let suites () =
   [ ( "kernel/branch",
       [ test_case "reads-as-of-each-state" `Quick reads_as_of_each_state;
@@ -141,4 +162,6 @@ let suites () =
         test_case "unbinding-removes-a-relation" `Quick unbinding_removes_a_relation;
         test_case "a-scope-reads-names-from-its-home" `Quick a_scope_reads_names_from_its_home;
         test_case "a-stored-relation-is-viewed-and-a-program-run" `Quick
-          a_stored_relation_is_viewed_and_a_program_run ] ) ]
+          a_stored_relation_is_viewed_and_a_program_run;
+        test_case "a-head-moves-only-to-a-valid-state" `Quick a_head_moves_only_to_a_valid_state ] )
+  ]