admission protocol for multigroup denial checks

15 files changed, 164 insertions, 40 deletions

diff --git a/lib/concepts/Tuple.ml b/lib/concepts/Tuple.ml
index 28dadc5..c2da77c 100644
--- a/lib/concepts/Tuple.ml
+++ b/lib/concepts/Tuple.ml
@@ -39,3 +39,8 @@ and Body : Encoding.Record.BODY = struct
 end
 
 let hash tuple = Representation.to_blob tuple |> Hash.hash_of_blob
+
+let to_string {attributes; _} =
+  BatMap.String.bindings attributes
+  |> List.map (fun (a, v) -> a ^ "=" ^ Value.to_string v)
+  |> String.concat " "
diff --git a/lib/kernel/Branch.ml b/lib/kernel/Branch.ml
index 936391c..70e0711 100644
--- a/lib/kernel/Branch.ml
+++ b/lib/kernel/Branch.ml
@@ -118,8 +118,24 @@ module Make (S : Abstract.Storage.STORAGE) = struct
                   ~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, tuples) ->
+                     Path.(to_string ("multigroup" @/ m @/ "denial" @/ d @/ this)), tuples )
+                   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",
diff --git a/lib/kernel/BranchManager.ml b/lib/kernel/BranchManager.ml
index 4d2fb1d..206aae9 100644
--- a/lib/kernel/BranchManager.ml
+++ b/lib/kernel/BranchManager.ml
@@ -6,8 +6,24 @@ 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, tuples) ->
+           ps
+           & path
+             |=| Concepts.Value.String
+                   (String.concat "; " (List.map Concepts.Tuple.to_string tuples)) )
+         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)
@@ -53,12 +69,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
+      (* 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:Denial.check value in
+        let* () = Option.fold ~none:(Ok ()) ~some:admitted value in
         SI.with_transaction storage (fun tx ->
             match
               Utilities.Atomic.mswap head (fun head ->
diff --git a/lib/kernel/EphemeralRelation.ml b/lib/kernel/EphemeralRelation.ml
index ff7bce1..7f1e79c 100644
--- a/lib/kernel/EphemeralRelation.ml
+++ b/lib/kernel/EphemeralRelation.ml
@@ -87,9 +87,7 @@ class ephemeral_relation ?code description value enumerate inputs =
     method contains (tuple : Concepts.Tuple.t) =
       let open Utilities.Result in
       let* cursor = self#enumerate in
-      Fun.protect
-        ~finally:(fun () -> Protocols.Handle.release cursor)
-        (fun () ->
+      Protocols.Handle.releasing cursor (fun () ->
           let* scan = Protocols.Cursor.require cursor in
           Protocols.Cursor.exists scan (fun member ->
               Concepts.Hash.hash_equals (Concepts.Tuple.hash member) (Concepts.Tuple.hash tuple) ) )
diff --git a/lib/kernel/Multigroup.ml b/lib/kernel/Multigroup.ml
index 18c59fb..5a3390d 100644
--- a/lib/kernel/Multigroup.ml
+++ b/lib/kernel/Multigroup.ml
@@ -54,7 +54,7 @@ module Make (S : Abstract.Storage.STORAGE) = struct
   module TAssociative = Prototype.Associative.OfTree (S) (Merkle.StringKey)
   module RMDirectory = Prototype.Directory.OfTree (S) (Merkle.StringKey) (Entry)
 
-  type t = {schemas: T.address}
+  type t = {schemas: T.address; denials: T.address}
 
   module Error = struct
     open Concepts.Condition
@@ -77,15 +77,16 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     let tag = '*'
     let malformed = Error.malformed_multigroup
 
-    let fields {schemas} =
+    let fields {schemas; denials} =
       let open Concepts.Encoding in
-      ["schemas", Value.bencode_of_hash schemas]
+      ["schemas", Value.bencode_of_hash schemas; "denials", Value.bencode_of_hash denials]
 
     let of_fields fields =
       let open Utilities.Result in
       let open Concepts.Encoding in
       let* schemas = Bencode.field "schemas" fields |> fmap Value.hash_of_bencode in
-      Ok {schemas}
+      let* denials = Bencode.field "denials" fields |> fmap Value.hash_of_bencode in
+      Ok {schemas; denials}
   end)
 
   let encode = Representation.to_blob
@@ -167,13 +168,34 @@ module Make (S : Abstract.Storage.STORAGE) = struct
           TAssociative.make ~admit:admit_schema ~storage ~node ~constructor:(fun node' ->
               Ok (make node') ) ] )
 
-  class multigroup ?bind conn value node =
+  let trees tx {schemas; denials} =
+    let open Utilities.Result in
+    let* schemas = node_of tx schemas in
+    let* denials = node_of tx denials in
+    Ok (schemas, denials)
+
+  let held (name, relation) =
+    let open Utilities.Result in
+    Protocols.Handle.releasing relation (fun () ->
+        let* enumerable = Protocols.Enumerable.require relation in
+        let* cursor = Protocols.Enumerable.enumerate enumerable in
+        Protocols.Handle.releasing cursor (fun () ->
+            let* scan = Protocols.Cursor.require cursor in
+            let* first = Protocols.Cursor.next scan in
+            match first with
+            | None -> Ok []
+            | Some tuple ->
+                let* rest = Protocols.Cursor.drain scan () in
+                Ok [name, tuple :: BatFingerTree.to_list rest] ) )
+
+  class multigroup ?bind conn value schema_tree denial_tree =
     object (self)
       inherit Lifecycle.null
       method to_string = "multigroup"
       val multigroup = value
       val storage = conn
-      val node = node (* FIXME: see the comment on Branch.ml *)
+      val schema_tree = schema_tree (* FIXME: see the comment on Branch.ml *)
+      val denial_tree = denial_tree
 
       (* TODO: Add later to the lifecycle management, accounting for
          derived instances. Callers must release the previous handle
@@ -181,25 +203,37 @@ module Make (S : Abstract.Storage.STORAGE) = struct
          last reference is released. *)
       method deriving multigroup' =
         let open Utilities.Result in
-        let* node' =
+        let* schemas', denials' =
           SI.with_transaction storage (fun tx ->
               let* _ = SI.store_blob tx (encode multigroup') in
-              node_of tx multigroup'.schemas )
+              trees tx multigroup' )
         in
-        new multigroup ?bind storage multigroup' node' |> Protocols.Handle.make |> Result.ok
+        new multigroup ?bind storage multigroup' schemas' denials'
+        |> Protocols.Handle.make
+        |> Result.ok
+
+      method check =
+        let open Utilities.Result in
+        let* named = Prototype.Directory.children (relations ?bind storage denial_tree) in
+        List.map held named |> Utilities.List.sequence |> Result.map List.concat
 
       method protocols : Protocols.Handle.protocol list =
         let open Utilities.Result in
+        let derive f node' =
+          Protocols.Handle.require Protocols.Addressable.from node'
+          |> Result.map Protocols.Addressable.address
+          |> fmap (fun addr -> self#deriving (f addr))
+        in
         Protocols.
           [ Addressable.make self;
+            Admission.make self;
             Prototype.Associative.(
               of_properties
-                [ ( "schema",
-                    update_only (fun node' ->
-                        Handle.require Addressable.from node'
-                        |> Result.map Addressable.address
-                        |> fmap (fun addr -> self#deriving {schemas= addr}) ) ) ] );
-            Prototype.Directory.of_properties ["schema", schemas ?bind storage node] ]
+                [ "schema", update_only (derive (fun addr -> {multigroup with schemas= addr}));
+                  "denial", update_only (derive (fun addr -> {multigroup with denials= addr})) ] );
+            Prototype.Directory.of_properties
+              [ "schema", schemas ?bind storage schema_tree;
+                "denial", relations ?bind storage denial_tree ] ]
 
       method hash = encode multigroup |> Concepts.Hash.hash_of_blob
       method address = self#hash
@@ -207,24 +241,27 @@ module Make (S : Abstract.Storage.STORAGE) = struct
 
   let load ?bind conn value =
     let open Utilities.Result in
-    let* node = SI.with_read conn (fun tx -> node_of tx value.schemas) in
-    new multigroup ?bind conn value node |> Protocols.Handle.make |> Result.ok
+    let* schemas, denials = SI.with_read conn (fun tx -> trees tx value) in
+    new multigroup ?bind conn value schemas denials |> Protocols.Handle.make |> Result.ok
 
   let make conn =
     let open Utilities.Result in
     SI.with_transaction conn (fun tx ->
         let* empty = T.empty_under tx in
-        let multigroup = {schemas= empty} in
+        let multigroup = {schemas= empty; denials= empty} in
         let* _ = SI.store_blob tx (encode multigroup) in
-        new multigroup conn multigroup T.empty |> Protocols.Handle.make |> Result.ok )
+        new multigroup conn multigroup T.empty T.empty |> Protocols.Handle.make |> Result.ok )
 
   (* Handed over as the tree shows one, a directory holding its schemas
-     under \schema, a multigroup not stored yet is stored with them. *)
+     under \schema and its denials under \denial, a multigroup not stored
+     yet is stored with them. *)
   let admit _ h =
     let open Utilities.Result in
     let* schemas = admissions "schema" admit_schema h in
+    let* denials = admissions "denial" Entry.admit h in
     Ok
       (fun tx ->
-        let* node = tree_of tx schemas in
-        SI.store_blob tx (encode {schemas= T.hash_of node}) )
+        let* schemas = tree_of tx schemas in
+        let* denials = tree_of tx denials in
+        SI.store_blob tx (encode {schemas= T.hash_of schemas; denials= T.hash_of denials}) )
 end
diff --git a/lib/kernel/Multigroup.mli b/lib/kernel/Multigroup.mli
index 6dcfb2f..fab02df 100644
--- a/lib/kernel/Multigroup.mli
+++ b/lib/kernel/Multigroup.mli
@@ -1,4 +1,5 @@
-(** A multigroup: its schemas, \multigroup\[m]\schema\[s]. *)
+(** A multigroup: its schemas, \multigroup\[m]\schema\[s], and its denials,
+    \multigroup\[m]\denial\[d]. *)
 module Make (S : Abstract.Storage.STORAGE) : sig
   include Merkle.VALUE
 
@@ -9,7 +10,8 @@ module Make (S : Abstract.Storage.STORAGE) : sig
     (Protocols.Handle.t, Concepts.Condition.condition) result
 
   (** a multigroup handed over with no address, as a directory holding its
-      schemas under \schema, to store once the write has begun. *)
+      schemas under \schema and its denials under \denial, to store once the
+      write has begun. *)
   val admit :
     string ->
     Protocols.Handle.t ->
diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml
index 8e7eab0..4e36125 100644
--- a/lib/kernel/Path.ml
+++ b/lib/kernel/Path.ml
@@ -49,9 +49,7 @@ let walking ?missing f g handle path =
    done with them, but never the caller's root.  If you leak one and
    its refcount never drops, nothing under that path gets collected,
    and an exclusive object, like a session, stays locked forever. *)
-let releasing root handle f =
-  Fun.protect ~finally:(fun () -> if handle != root then Protocols.Handle.release handle) f
-
+let releasing root handle f = if handle == root then f () else Protocols.Handle.releasing handle f
 let lookup handle path = walking (fun _ parent -> releasing handle parent) Result.ok handle path
 
 let find handle path =
diff --git a/lib/kernel/Scope.ml b/lib/kernel/Scope.ml
index 95896b4..23698ba 100644
--- a/lib/kernel/Scope.ml
+++ b/lib/kernel/Scope.ml
@@ -21,6 +21,7 @@ let relations {multigroup; schema} =
   Path.("multigroup" @/ multigroup @/ "schema" @/ schema @/ "relation" @/ this)
 
 let path home relation = Path.(of_list (to_list (relations home) @ [relation]))
+let denial multigroup = Path.("multigroup" @/ multigroup @/ "denial" @/ this)
 
 (* A name leaves out, from the left, what it shares with its home. *)
 let resolve home text =
@@ -112,12 +113,16 @@ module Error = struct
       "A relation is named relation, schema:relation or multigroup:schema:relation"
       ("name" |=| Concepts.Value.String name)
 
+  let malformed_denial name =
+    condition "malformed-name" "A denial is named denial or multigroup:denial"
+      ("name" |=| Concepts.Value.String name)
+
   let moved branch =
     condition "serialization-conflict" "The branch moved on while this commit was made; retry it"
       ("branch" |=| Concepts.Value.String branch)
 end
 
-let publish root ~branch ~home bindings =
+let publish ?(denials = []) root ~branch ~home bindings =
   let open Utilities.Result in
   let* changes =
     List.map
@@ -128,6 +133,17 @@ let publish root ~branch ~home bindings =
       bindings
     |> Utilities.List.sequence
   in
+  let* denied =
+    List.map
+      (fun (name, v) ->
+        match String.split_on_char ':' name with
+        | [d] when d <> "" -> Ok (denial home.multigroup, d, v)
+        | [m; d] when m <> "" && d <> "" -> Ok (denial m, d, v)
+        | _ -> Error (Error.malformed_denial name) )
+      denials
+    |> Utilities.List.sequence
+  in
+  let changes = changes @ denied in
   if List.is_empty changes then Ok ()
   else
     let* state = Path.lookup root Path.("system" @/ "branch" @/ branch @/ this) in
diff --git a/lib/kernel/Scope.mli b/lib/kernel/Scope.mli
index aabdc61..83b3309 100644
--- a/lib/kernel/Scope.mli
+++ b/lib/kernel/Scope.mli
@@ -42,6 +42,9 @@ val previous :
 val catalog :
   implementation Protocols.Handle.interface -> (string list, Concepts.Condition.condition) result
 
+(** \multigroup\[m]\schema\[s]\relation, from a branch state. *)
+val relations : home -> Path.t
+
 (** \multigroup\[m]\schema\[s]\relation\[relation], from a branch state. *)
 val path : home -> string -> Path.t
 
@@ -56,8 +59,11 @@ val attribute : home -> string -> string -> string option
     head of \system\branch\[branch], as one successor state. A multigroup
     or schema not there yet is made, and a value with no address is
     stored as a schema stores it: a program as itself, a relation as its
-    tuples. If the head moved meanwhile nothing changes, and it fails. *)
+    tuples. [denials] are named [d], in
+    \denial of the home multigroup, or [m:d], in that of [m]. If the head moved meanwhile, or a multigroup does not
+    admit the state, nothing changes, and it fails. *)
 val publish :
+  ?denials:(string * Protocols.Handle.t option) list ->
   Protocols.Handle.t ->
   branch:string ->
   home:home ->
diff --git a/lib/kernel/Source.ml b/lib/kernel/Source.ml
index 16d2b04..f81499c 100644
--- a/lib/kernel/Source.ml
+++ b/lib/kernel/Source.ml
@@ -74,9 +74,7 @@ let bind root ~within evaluator program =
       (fun directory -> Path.lookup directory Path.(language @/ this))
     |> Result.map_error (fun _ -> Error.no_evaluator evaluator)
   in
-  Fun.protect
-    ~finally:(fun () -> Protocols.Handle.release found)
-    (fun () ->
+  Protocols.Handle.releasing found (fun () ->
       let* found = Protocols.Evaluator.require found in
       Protocols.Evaluator.invoke found program ~within )
 
diff --git a/lib/protocols/Admission.ml b/lib/protocols/Admission.ml
new file mode 100644
index 0000000..5a20105
--- /dev/null
+++ b/lib/protocols/Admission.ml
@@ -0,0 +1,21 @@
+module Error = struct
+  open Concepts.Condition
+
+  let not_admitting () =
+    condition "not-admitting" "A handle was expected to carry the admission protocol and did not"
+      empty
+end
+
+type violations = (string * Concepts.Tuple.t list) list
+
+class type implementation = object
+  method check : (violations, Concepts.Condition.condition) result
+end
+
+type Handle.protocol += Admission of implementation
+type t = implementation
+
+let make impl = Admission (impl :> implementation)
+let from handle = Handle.into handle (function Admission impl -> Some impl | _ -> None)
+let require handle = from handle |> Option.to_result ~none:(Error.not_admitting ())
+let check i = Handle.invoke i (fun o -> o#check)
diff --git a/lib/protocols/Admission.mli b/lib/protocols/Admission.mli
new file mode 100644
index 0000000..235eae7
--- /dev/null
+++ b/lib/protocols/Admission.mli
@@ -0,0 +1,11 @@
+type t
+type violations = (string * Concepts.Tuple.t list) list
+
+class type implementation = object
+  method check : (violations, Concepts.Condition.condition) result
+end
+
+val make : #implementation -> Handle.protocol
+val from : Handle.t -> t Handle.interface option
+val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result
+val check : t Handle.interface -> (violations, Concepts.Condition.condition) result
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
index cdadd4a..c8480a6 100644
--- a/lib/protocols/Handle.ml
+++ b/lib/protocols/Handle.ml
@@ -47,4 +47,5 @@ let release ({valid; _} as handle) =
   valid := false;
   o#release
 
+let releasing handle f = Fun.protect ~finally:(fun () -> release handle) f
 let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h)
diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli
index a354257..5c74521 100644
--- a/lib/protocols/Handle.mli
+++ b/lib/protocols/Handle.mli
@@ -17,6 +17,7 @@ val invoke : 'a interface -> ('a -> 'b) -> 'b
 val copy : t -> t option
 val equal : t -> t -> bool
 val release : t -> unit
+val releasing : t -> (unit -> 'a) -> 'a
 val hash : t -> Concepts.Hash.hash
 val protocols : t -> protocol list
 val to_string : t -> string
diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml
index 9a6e739..af1201b 100644
--- a/lib/protocols/Relation.ml
+++ b/lib/protocols/Relation.ml
@@ -31,9 +31,7 @@ let read relation =
   let* heading = heading relation in
   let* enumerable = Enumerable.require relation in
   let* cursor = Enumerable.enumerate enumerable in
-  Fun.protect
-    ~finally:(fun () -> Handle.release cursor)
-    (fun () ->
+  Handle.releasing cursor (fun () ->
       let* scan = Cursor.require cursor in
       let* tuples = Cursor.drain scan () in
       Ok (heading, BatFingerTree.to_list tuples) )