check tuples against the heading before storing

1 files changed, 26 insertions, 12 deletions

diff --git a/lib/kernel/SubstantialRelation.ml b/lib/kernel/SubstantialRelation.ml
index 3e7945d..fd6df6f 100644
--- a/lib/kernel/SubstantialRelation.ml
+++ b/lib/kernel/SubstantialRelation.ml
@@ -24,6 +24,11 @@ module Make (S : Abstract.Storage.STORAGE) = struct
       condition "missing-attribute" "A tuple to store has no value for an attribute of its relation"
         ("attribute" |=| Concepts.Value.String name)
 
+    let unexpected_attribute name =
+      condition "unexpected-attribute"
+        "A tuple to store has an attribute its relation does not have"
+        ("attribute" |=| Concepts.Value.String name)
+
     let unindexed_attribute name =
       condition "unindexed-attribute" "A relation was looked up on an attribute it has no index for"
         ("attribute" |=| Concepts.Value.String name)
@@ -198,27 +203,36 @@ module Make (S : Abstract.Storage.STORAGE) = struct
     |> Result.map (fun description ->
         new substantial_relation connection relation description |> Protocols.Handle.make )
 
-  let index tx attribute hashed =
-    let open Utilities.Result in
-    let* entries =
-      List.map
-        (fun (hash, tuple) ->
-          match BatMap.String.find_opt attribute tuple.Concepts.Tuple.attributes with
-          | Some value -> Ok (prefix value ^ Concepts.Hash.to_raw_string hash, hash)
-          | None -> Error (Error.missing_attribute attribute) )
-        hashed
-      |> Utilities.List.sequence
+  let conform description () {Concepts.Tuple.attributes; _} =
+    let outside one other =
+      List.find_opt
+        (fun (name, _) -> not (BatMap.String.mem name other))
+        (BatMap.String.bindings one)
     in
-    Index.of_list tx entries |> Result.map (fun node -> attribute, Index.hash_of node)
+    match outside description attributes, outside attributes description with
+    | Some (name, _), _ -> Error (Error.missing_attribute name)
+    | None, Some (name, _) -> Error (Error.unexpected_attribute name)
+    | None, None -> Ok ()
+
+  let index tx hashed attribute =
+    List.map
+      (fun (hash, tuple) ->
+        ( prefix (BatMap.String.find attribute tuple.Concepts.Tuple.attributes)
+          ^ Concepts.Hash.to_raw_string hash,
+          hash ) )
+      hashed
+    |> Index.of_list tx
+    |> Result.map (fun node -> attribute, Index.hash_of node)
 
   let store tx description tuples =
     let open Utilities.Result in
+    let* () = Utilities.List.foldm_left (conform description) () tuples in
     let* schematics = store_schema tx description in
     let hashed = List.map (fun tuple -> Concepts.Tuple.hash tuple, tuple) tuples in
     let* node = TupleSet.of_list tx hashed in
     let* indexes =
       BatMap.String.bindings description
-      |> List.map (fun (attribute, _) -> index tx attribute hashed)
+      |> List.map (fun (attribute, _) -> index tx hashed attribute)
       |> Utilities.List.sequence
     in
     let relation =