check tuples against the heading before storing

2 files changed, 39 insertions, 21 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 =
diff --git a/test/unit/kernel/SubstantialRelation.ml b/test/unit/kernel/SubstantialRelation.ml
index b4e90dc..20eb163 100644
--- a/test/unit/kernel/SubstantialRelation.ml
+++ b/test/unit/kernel/SubstantialRelation.ml
@@ -49,13 +49,17 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
            Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric) )
          enumerated )
 
-  let refuse_a_tuple_without_every_attribute conn =
-    let nameless = {alaric with attributes= BatMap.String.remove "name" alaric.attributes} in
-    check bool "storing it fails for the attribute it lacks" true
-      ( match H.relation conn ["name"; "age"] [nameless] with
-      | Error condition ->
-          BatString.starts_with (Concepts.Condition.to_string_hum condition) "missing-attribute"
-      | Ok _ -> false )
+  let refuse_a_tuple_off_its_heading conn =
+    let refused name attributes =
+      match H.relation conn ["name"; "age"] [{alaric with attributes}] with
+      | Error condition -> BatString.starts_with (Concepts.Condition.to_string_hum condition) name
+      | Ok _ -> false
+    in
+    check bool "a tuple lacking an attribute is refused" true
+      (refused "missing-attribute" (BatMap.String.remove "name" alaric.attributes));
+    check bool "a tuple with an attribute too many is refused" true
+      (refused "unexpected-attribute"
+         (BatMap.String.add "salary" (Concepts.Value.Integer 1) alaric.attributes) )
 
   let employee name age =
     { Concepts.Tuple.type_= "employee";
@@ -110,8 +114,8 @@ module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) =
     ( "kernel/substantial-relation",
       [ test_case "contain-and-enumerate" `Quick
           (H.with_connection contain_and_enumerate "substantial-relation-test");
-        test_case "refuse-a-tuple-without-every-attribute" `Quick
-          (H.with_connection refuse_a_tuple_without_every_attribute "substantial-relation-test");
+        test_case "refuse-a-tuple-off-its-heading" `Quick
+          (H.with_connection refuse_a_tuple_off_its_heading "substantial-relation-test");
         test_case "look-up-by-one-attribute" `Quick
           (H.with_connection look_up_by_one_attribute "substantial-relation-test") ] )
 end