3 files changed, 174 insertions, 72 deletions

diff --git a/test/unit/kernel/Branch.ml b/test/unit/kernel/Branch.ml
index ebce298..606d8b7 100644
--- a/test/unit/kernel/Branch.ml
+++ b/test/unit/kernel/Branch.ml
@@ -11,23 +11,19 @@ let shelf = K.Scope.path library "shelf"
 let s v = C.Value.String v
 let title = BatMap.String.singleton "title" {P.Schematics.domain= "string"; provenance= []}
 
-let books titles =
-  K.EphemeralRelation.literal title
-    (List.map
-       (fun t -> {C.Tuple.type_= "book"; attributes= BatMap.String.singleton "title" (s t)})
-       titles )
+let book t = {C.Tuple.type_= "book"; attributes= BatMap.String.singleton "title" (s t)}
+let books titles = K.EphemeralRelation.literal title (List.map book titles)
 
 let titles relation = ok (Helpers.titles relation)
 let read root path = titles (ok (K.Path.lookup root path))
 
 (* shelf is a stored FOL program reading book where it is stored *)
 let shelved =
-  K.Source.view ~language:"fol" ~heading:title
-    ( Rnt.Evaluators.FOL.(encode (Base (K.Scope.path library "book")))
-    |> C.Blob.bytes_of_blob
-    |> Bytes.to_string )
+  K.EphemeralRelation.of_program title
+    Rnt.Evaluators.FOL.(program (Base (K.Scope.path library "book")))
 
-let publish root changes = ok (K.Scope.publish root ~branch:"master" ~home:library changes)
+let publish ?denials root changes =
+  ok (K.Scope.publish ?denials root ~branch:"master" ~home:library changes)
 
 let fresh books' =
   let root = ok (Rnt.Scratch.root ()) in
@@ -113,55 +109,162 @@ let a_scope_reads_names_from_its_home () =
   check (option string) "but not another relation's" None
     (K.Scope.attribute library "book" "shelf:title")
 
-(* A toy language answers a stored relation with its own name, and a run
-   with the source it was given. *)
-let a_stored_relation_is_viewed_and_a_program_run () =
+type K.Program.kind += Title of string | Endless | Shout of K.Path.t
+
+let endless () =
+  K.EphemeralRelation.instantiate title
+    ~modes:(fun () -> Ok [C.(Mode.mode [] Cardinality.Countable)])
+    {K.EphemeralRelation.name= None; schematics= `Temporary title; pointer= None}
+    (fun () ->
+      Ok
+        (K.Generator.cursor_of (fun ~yield ->
+             let rec from n = yield (book (string_of_int n)); from (n + 1) in
+             from 0 ) ) )
+
+(* A toy language: "endless" answers titles without end, "shout r" the
+   titles of relation r in capitals, and anything else itself as a title. *)
+let parse source =
+  match String.split_on_char ' ' source with
+  | ["endless"] -> Endless
+  | ["shout"; name] -> Shout (K.Scope.path library name)
+  | _ -> Title source
+
+let shout within path =
+  let open Rnt.Utilities.Result in
+  let* relation = K.Path.lookup within path in
+  let* heard = P.Handle.releasing relation (fun () -> Helpers.titles relation) in
+  Ok
+    (books
+       (List.filter_map
+          (function C.Value.String t -> Some (String.uppercase_ascii t) | _ -> None)
+          heard ) )
+
+let toy ?(evaluations = ref 0) () =
+  P.Handle.make
+    object (self)
+      inherit K.Lifecycle.null
+      inherit K.Identity.of_id
+      method to_string = "toy-evaluator"
+      method parse source = Ok (parse source)
+
+      method eval kind _ ~within =
+        incr evaluations;
+        match kind with
+        | Title text -> Ok (books [text])
+        | Endless -> Ok (endless ())
+        | Shout path -> shout within path
+        | _ -> Error (C.Condition.condition "foreign-program" "Not a toy program" C.Condition.empty)
+
+      method protocols : P.Handle.protocol list = [P.Evaluator.make self]
+    end
+
+let with_toys ?evaluations root =
+  ignore (ok (K.Initialization.mount root "toys"));
+  ignore
+    (ok
+       (K.Path.update root K.Path.("toys" @/ "evaluator" @/ this) "toy" None
+          (Some (toy ?evaluations ())) ) )
+
+let toy_program ?root evaluator source = K.Program.make ?root ~evaluator ~source (parse source)
+
+let run root program =
+  Result.bind (P.Executable.require program) (fun executable ->
+      P.Executable.invoke executable [] ~within:root )
+
+let a_program_runs_through_the_evaluator_it_names () =
   let root = fresh ["Codd"] in
-  let answer text = Ok (books [text]) in
-  let toy =
-    K.Source.evaluator ~language:"toy"
-      ~view:(fun ~within:_ ~name source -> answer (name ^ " of " ^ source))
-      (fun ~within:_ source -> answer source)
-  in
-  let _ = ok (K.Initialization.mount root "toys") in
-  ok (K.Source.register root ~scope:"toys" ~language:"toy" toy);
-  publish root ["named", Some (K.Source.view ~language:"toys:toy" ~heading:title "this")];
-  check (list Helpers.value) "read from the branch, the view is asked for it by name"
-    [s "named of this"]
+  with_toys root;
+  publish root
+    ["named", Some (K.EphemeralRelation.of_program title (toy_program "toys:toy" "this"))];
+  check (list Helpers.value) "stored in a branch and read back, it runs"
+    [s "this"]
     (read root (under master (K.Scope.path library "named")));
-  check (list Helpers.value) "run, the program is just run"
+  check (list Helpers.value) "run directly, it runs"
     [s "that"]
-    (titles (ok (K.Source.run root ~language:"toys:toy" ~within:root "that")));
+    (titles (ok (run root (toy_program ~root "toys:toy" "that"))));
   check bool "an unqualified name is the system's" true
-    (Result.is_error (K.Source.run root ~language:"toy" ~within:root "that"))
+    (Result.is_error (run root (toy_program ~root "toy" "that")))
+
+(* shelf, from fresh, is a FOL program reading book *)
+let evaluators_read_each_other () =
+  let root = fresh ["Codd"] in
+  with_toys root;
+  let stored name program = name, Some (K.EphemeralRelation.of_program title program) in
+  publish root
+    [ stored "toy-shelf" (toy_program "toys:toy" "Date");
+      stored "fol-over-toy" Rnt.Evaluators.FOL.(program (Base (K.Scope.path library "toy-shelf")));
+      stored "toy-over-fol" (toy_program "toys:toy" "shout shelf") ];
+  check (list Helpers.value) "FOL reads the relation a toy program generates"
+    [s "Date"]
+    (read root (under master (K.Scope.path library "fol-over-toy")));
+  check (list Helpers.value) "a toy program shouts the relation a FOL program generates"
+    [s "CODD"]
+    (read root (under master (K.Scope.path library "toy-over-fol")))
 
 (* shelf, stored as a denial, says no book may be shelved *)
-let a_head_moves_only_to_a_valid_state () =
+let denied state = List.map fst (ok (P.Admission.check (ok (P.Admission.require state))))
+let no_books = "\\multigroup\\library\\denial\\no-books"
+
+let a_head_moves_only_to_an_admitted_state () =
   let root = fresh [] in
-  publish root ["denial:no-books", Some shelved];
+  publish root ~denials:["no-books", Some shelved] [];
   let head = ok (K.Path.lookup root master) in
+  check (list string) "the head is admitted" [] (denied head);
   let proposed =
-    ok
-      (K.Path.assoc_all head
-         [ ( K.Path.("multigroup" @/ "library" @/ "schema" @/ "default" @/ "relation" @/ this),
-             "book",
-             Some (books ["Codd"]) ) ] )
+    ok (K.Path.assoc_all head [K.Scope.relations library, "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 (list string) "a state with a book is not, and says by which denial" [no_books]
+    (denied 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))))
 
+(* a denial of multigroup audit reads library's books *)
+let a_rule_spans_multigroups () =
+  let root = fresh [] in
+  publish root ~denials:["audit:no-books", Some shelved] ["loan", Some (books ["Codd"])];
+  check bool "a commit to library is judged by audit" true
+    (Result.is_error
+       (K.Scope.publish root ~branch:"master" ~home:library ["book", Some (books ["Codd"])]) );
+  check (list Helpers.value) "one audit's denial does not mind lands"
+    [s "Codd"]
+    (read root (under master (K.Scope.path library "loan")))
+
+let a_denial_without_end_cannot_be_installed () =
+  let root = fresh [] in
+  with_toys root;
+  let endless = K.EphemeralRelation.of_program title (toy_program "toys:toy" "endless") in
+  match K.Scope.publish root ~branch:"master" ~home:library ~denials:["endless", Some endless] [] with
+  | Ok () -> fail "a denial without end was installed"
+  | Error condition ->
+      check bool "the state holding it cannot be judged" true
+        (BatString.starts_with (C.Condition.to_string_hum condition) "unjudgeable-denial")
+
+let a_denial_program_runs_once_per_judgement () =
+  let root = fresh [] in
+  let evaluations = ref 0 in
+  with_toys ~evaluations root;
+  let dated = K.EphemeralRelation.of_program title (toy_program "toys:toy" "Date") in
+  check bool "a denial holding a book refuses the commit" true
+    (Result.is_error
+       (K.Scope.publish root ~branch:"master" ~home:library ~denials:["dated", Some dated] []) );
+  check int "and its program ran once to judge it" 1 !evaluations
+
 let suites () =
   [ ( "kernel/branch",
       [ test_case "reads-as-of-each-state" `Quick reads_as_of_each_state;
         test_case "a-batch-is-one-successor" `Quick a_batch_is_one_successor;
         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;
-        test_case "a-head-moves-only-to-a-valid-state" `Quick a_head_moves_only_to_a_valid_state ] )
-  ]
+        test_case "a-program-runs-through-the-evaluator-it-names" `Quick
+          a_program_runs_through_the_evaluator_it_names;
+        test_case "evaluators-read-each-other" `Quick evaluators_read_each_other;
+        test_case "a-head-moves-only-to-an-admitted-state" `Quick
+          a_head_moves_only_to_an_admitted_state;
+        test_case "a-rule-spans-multigroups" `Quick a_rule_spans_multigroups;
+        test_case "a-denial-without-end-cannot-be-installed" `Quick
+          a_denial_without_end_cannot_be_installed;
+        test_case "a-denial-program-runs-once-per-judgement" `Quick
+          a_denial_program_runs_once_per_judgement ] ) ]
diff --git a/test/unit/kernel/EphemeralRelation.ml b/test/unit/kernel/EphemeralRelation.ml
index 7f113ef..c9742f0 100644
--- a/test/unit/kernel/EphemeralRelation.ml
+++ b/test/unit/kernel/EphemeralRelation.ml
@@ -12,11 +12,21 @@ let description =
     { Protocols.Schematics.domain= "integer";
       provenance= [{Protocols.Schematics.source= ["example"]; attribute= "value"}] }
 
-let temporary = {Ephemeral.name= None; schematics= `Temporary description; program= None}
+let temporary = {Ephemeral.name= None; schematics= `Temporary description; pointer= None}
 
 let over ?inputs ?(value = temporary) members =
-  Ephemeral.instantiate ?inputs description value (fun () ->
-      Ok (Rnt.Kernel.Generator.cursor_of (fun ~yield -> List.iter yield members; Ok ())) )
+  Ephemeral.instantiate ?inputs description value
+    ~modes:(fun () -> Ok [Concepts.(Mode.mode [] (Cardinality.bounded (List.length members)))])
+    (fun () -> Ok (Rnt.Kernel.Generator.cursor_of (fun ~yield -> List.iter yield members; Ok ())))
+
+let endless () =
+  Ephemeral.instantiate description temporary
+    ~modes:(fun () -> Ok [Concepts.(Mode.mode [] Cardinality.Countable)])
+    (fun () ->
+      Ok
+        (Rnt.Kernel.Generator.cursor_of (fun ~yield ->
+             let rec from n = yield (member n); from (n + 1) in
+             from 0 ) ) )
 
 let values tuples =
   BatFingerTree.to_list tuples
@@ -55,6 +65,17 @@ let decides_membership () =
   check bool "a member is held" true holds;
   check bool "a stranger is refused" false rejects
 
+let refuses_to_scan_without_end () =
+  match Protocols.Relation.require (endless ()) with
+  | Error condition -> fail (Concepts.Condition.to_string_hum condition)
+  | Ok relation -> (
+    match Protocols.Relation.contains relation (member 9) with
+    | Error condition ->
+        check bool "it fails as undecidable instead of scanning" true
+          (BatString.starts_with (Concepts.Condition.to_string_hum condition)
+             "undecidable-membership" )
+    | Ok _ -> fail "an endless relation with no test decided membership" )
+
 let describes_itself () =
   let described =
     begin
@@ -83,7 +104,7 @@ let addressed_once_persisted () =
   let persisted code =
     { Ephemeral.name= Some "example";
       schematics= `Persisted (Concepts.Hash.hash_of_int 1);
-      program= Some {Ephemeral.evaluator= "fol"; code= Concepts.Hash.hash_of_int code} }
+      pointer= Some {Ephemeral.evaluator= "fol"; code= Concepts.Hash.hash_of_int code} }
   in
   let address value =
     Protocols.Addressable.from (over ~value []) |> Option.map Protocols.Addressable.address
@@ -97,9 +118,9 @@ let releasing_releases_its_inputs () =
   let released = ref false in
   let input =
     object
-      method reference = true
-      method release = released := true
-      method hash = Concepts.Hash.hash_of_int 0
+      inherit Rnt.Kernel.Lifecycle.null
+      inherit Rnt.Kernel.Identity.of_id
+      method! release = released := true
       method to_string = "input"
       method protocols : Protocols.Handle.protocol list = []
     end
@@ -113,6 +134,7 @@ let suites () =
   [ ( "kernel/ephemeral-relation",
       [ test_case "enumerates-every-member" `Quick enumerates_every_member;
         test_case "decides-membership" `Quick decides_membership;
+        test_case "refuses-to-scan-without-end" `Quick refuses_to_scan_without_end;
         test_case "describes-itself" `Quick describes_itself;
         test_case "addressed-once-persisted" `Quick addressed_once_persisted;
         test_case "releasing-releases-its-inputs" `Quick releasing_releases_its_inputs ] ) ]
diff --git a/test/unit/kernel/Session.ml b/test/unit/kernel/Session.ml
index 79ad5a2..edb22c4 100644
--- a/test/unit/kernel/Session.ml
+++ b/test/unit/kernel/Session.ml
@@ -25,7 +25,7 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
         let* _ = update root ("system" @/ "branch" @/ this) "client" None (Some branch) in
         let* tip = address branch in
         let session = Session.make conn {Protocols.Session.snapshot= tip} in
-        let* _ = update root ("system" @/ "session" @/ this) "client" None (Some session) in
+        let* _ = update root ("system" @/ "session" @/ this) "client" None (Protocols.Handle.copy session) in
         let library =
           "system" @/ "session" @/ "client" @/ "branch" @/ "multigroup" @/ "library" @/ this
         in
@@ -55,32 +55,9 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
     check bool "the session reconstructs the pinned branch" true pinned;
     check bool "the session refuses derivation through it" true refused
 
-  let single_handle conn =
-    let refused, reacquired =
-      begin
-        let open Utilities.Result in
-        let open Rnt.Kernel.Path in
-        let* root = I.initialize conn in
-        let* branch = B.make conn in
-        let* tip = address branch in
-        let session = Session.make conn {Protocols.Session.snapshot= tip} in
-        let* _ = update root ("system" @/ "session" @/ this) "client" None (Some session) in
-        let client = "system" @/ "session" @/ "client" @/ this in
-        let* _ = lookup root ("system" @/ "session" @/ "client" @/ "branch" @/ this) in
-        let* held = lookup root client in
-        let refused = finds root client in
-        Protocols.Handle.release held;
-        Ok (refused, finds root client)
-      end
-      |> Helpers.condition_as_failure
-    in
-    check bool "a second handle to the session is refused" false refused;
-    check bool "releasing the handle frees the session" true reacquired
-
   let suite =
     ( "kernel/session",
-      [ test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test");
-        test_case "single-handle" `Quick (H.with_connection single_handle "session-single-test") ] )
+      [test_case "pin-and-follow" `Quick (H.with_connection pin_and_follow "session-test")] )
 end
 
 module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)