@@ -22,7 +22,7 @@ import qualified Data.List as L
2222
2323-- the isomorphic building blocks should not be arbitrarily combined; for example, combing restrict and union on the same target relvar does not make sense as that would create effects at a distance in the secondary schema
2424
25−data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs|
25+data SchemaExpr = AddSubschema SchemaName SchemaIsomorphs |
2626 RemoveSubschema SchemaName
2727 deriving (Generic, Binary)
2828
@@ -34,13 +34,15 @@ isomorphs (Schema i) = i
3434-- A schema is fully isomorphic iff all relvars in the base context are in the "out" relvars, but only once.
3535--TODO: add relvar must appear exactly once constraint
3636validateSchema :: Schema -> DatabaseContext -> Maybe SchemaError
37−validateSchema potentialSchema baseContext = if not (S.null rvDiff) then
38− Just (RelVarReferencesMissing rvDiff)
39− else if not (null duplicateNames) then
40− Just (RelVarReferencedMoreThanOnce (head duplicateNames))
41− else
42− Nothing
37+validateSchema potentialSchema baseContext = do
38+ if not (S.null rvDiff) then
39+ Just (RelVarReferencesMissing rvDiff)
40+ else if not (null duplicateNames) then
41+ Just (RelVarReferencedMoreThanOnce (head duplicateNames))
42+ else
43+ Nothing
4344 where
45+ --check that the predicate for IsoUnion and IsoRestrict holds right now
4446 duplicateNames = dupes (L.sort outRvNamesList)
4547 outRvNamesList = concat (map isomorphOutRelVarNames (isomorphs potentialSchema))
4648 expectedRelVars = M.keysSet (relationVariables baseContext)
@@ -74,31 +76,31 @@ isomorphsOutRelVarNames morphs = S.fromList (foldr rvnames [] morphs)
7476 where
7577 rvnames morph acc = acc ++ isomorphOutRelVarNames morph
7678
79+-- | Check that all mentioned relvars are actually present in the current schema.
80+validateRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError ()
81+validateRelationalExprInSchema schema relExprIn = relExprMogrify (\expr -> case expr of
82+ RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)
83+ ex -> Right ex) relExprIn >> pure ()
84+ where
85+ validRelVarNames = isomorphsInRelVarNames (isomorphs schema)
86+
7787processRelationalExprInSchema :: Schema -> RelationalExpr -> Either RelationalError RelationalExpr
78−processRelationalExprInSchema (Schema morphs) relExprIn = do
88+processRelationalExprInSchema schema relExprIn = do
7989 --validate that all rvs are present in the virtual schema- this prevents relation variables being referenced in the underlying schema (falling through the transformation)
8090 let processRelExpr rexpr morph = relExprMogrify (relExprMorph morph) rexpr
81− -- validate all in relvar names so that the actual relvar names don't leak through as errors
82− validRelVarNames = isomorphsInRelVarNames morphs
83− _ <- relExprMogrify (\expr -> case expr of
84− RelationVariable rv () | S.notMember rv validRelVarNames -> Left (RelVarNotDefinedError rv)
85− ex -> Right ex) relExprIn
86−
87− foldM processRelExpr relExprIn morphs
91+ validateRelationalExprInSchema schema relExprIn
92+ foldM processRelExpr relExprIn (isomorphs schema)
93+
94+validateDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError ()
95+validateDatabaseContextExprInSchema schema dbExpr = mapM_ (\morph -> databaseContextExprMorph morph (\e -> validateRelationalExprInSchema schema e >> pure e) dbExpr) (isomorphs schema) >> pure ()
8896
8997processDatabaseContextExprInSchema :: Schema -> DatabaseContextExpr -> Either RelationalError DatabaseContextExpr
9098processDatabaseContextExprInSchema schema@(Schema morphs) dbExpr = do
91− let processDbExpr expr morph = case expr of
92− Assign rv _ | notMember rv -> badRv rv
93− Insert rv _ | notMember rv -> badRv rv
94− Update rv _ _ | notMember rv -> badRv rv
95− MultipleExpr exprs -> MultipleExpr <$> mapM (processDatabaseContextExprInSchema schema) exprs
96− e -> databaseContextExprMorph morph relExprMogrifier e
97− relExprMogrifier = processRelationalExprInSchema schema
98− badRv rv = Left (RelVarNotDefinedError rv)
99− notMember rv = S.notMember rv validRelVarNames
100− validRelVarNames = isomorphsInRelVarNames morphs
101− foldM processDbExpr dbExpr morphs
99+ let relExprMogrifier = processRelationalExprInSchema schema
100+ --validate that all mentioned relvars are in the valid set
101+ _ <- validateDatabaseContextExprInSchema schema dbExpr
102+ --perform the morph
103+ foldM (\ex morph -> databaseContextExprMorph morph relExprMogrifier ex) dbExpr morphs
102104
103105-- re-evaluate- it's not possible to display an incdep that may be for a foreign key to a relvar which is not available in the subschema!
104106-- weird compromise: allow inclusion dependencies failures not in the subschema to be propagated- in the worst case, only the inclusion dependency's name is leaked.
@@ -109,7 +111,6 @@ applySchemaToInclusionDependencies (Schema morphs) incDeps =
109111 let incDepMorph incDep = --check that the mentioned relvars are in fact in the current schema
110112 M.update incDepMorph incDeps
111113 -}
112−
113114
114115-- | Morph a relational expression in one schema to another isomorphic schema.
115116relExprMorph :: SchemaIsomorph -> (RelationalExpr -> Either RelationalError RelationalExpr)