/src-extra/extensions/Database/HsSqlPpp/Extensions/CreateAssertion.lhs
Haskell | 250 lines | 212 code | 35 blank | 3 comment | 18 complexity | c750a5ab5a38a1f951ea188e3a8aaa51 MD5 | raw file
Possible License(s): BSD-3-Clause
1 2sketch 3------ 4 5something like an implementation of the rarely implemented create 6assertion sql syntax 7 8The basic approach is to analyze the constraint expression to get a 9list of ultimately reference tables, then: 10 11create a check function which returns a bool to say whether the 12expression is true, 13 14create a trigger and trigger function for each table which calls all 15the check functions who reference this table and raise if any are 16false 17 18when we add a constraint which references a table with an existing 19constraint, we add the new check function, and create or replace the 20trigger function with the new check function added to the existing 21ones, which avoids having to also drop and create the trigger 22 23could add an optimisation to say that if there are no crud statements 24inbetween two constraints, we can skip creating the first trigger 25function, and change create or replace to create on the second one, 26and move the add trigger down. Also - want to try to limit any crud to 27using the table values extension, which may be relevant to this. 28 29todo/ issues 30------------ 31 32add catalog entries. not null and key constrainsts are part of a 33table, but the regular check and foreign key constraints possibly 34could appear in assertion catalog along with the constraints added by 35this extension 36 37the logic which determines which tables are referenced by an 38expression is a bit dodgy: it only copes with all the create 39assertions being set in one ast, so we can load one file, then load 40another file later and it do the right thing. 41 42this logic is also wrong for functions - it doesn't take into account 43function overloading, to fix this need to type check to determine 44which exact functions are called, might be a bit tricky, since we run 45extensions on asts which only neccessarily type check after all the 46extensions have been applied. 47 48Since pg has no multiple updates, some sort of hack may be needed for 49some updates in combination with some constraints. 50 51I'm pretty sure the constraint system works fine as long as 52* you never change the columns on a table after adding a constraint 53* you only add constraints, never change or remove them 54* all database transactions are run one at a time, serialised 55 (actually serialised, not just using sql isolation serializable). 56 57If any of these assumptions are broken, you might break your database, 58load bad data in or get weird errors for stuff that should work. 59 60foreign keys without having to create a view first i.e. a literal 61view expression in the constraint. 62 63alternative key syntax to remove the distinction between primary key 64and unique not null? 65 66could add support for check constraints referring to multiple rows in 67same table? don't want to allow check constraints which refer to other 68tables. Maybe go further: following tutorial d, only allow key and not 69null constraints in create table or alter table, and move chek and 70foreign keys out to create assertions or shorthand wrappers? Inline 71constraints can be more readable though? 72 73maybe add a parser extension to parse: 74 75 create assertion constraint_name check(expression); 76 77add some syntax to say: 78not too sure about how this all works, write a seperate bunch of 79code to read all the constraints either out of the catalog or from the 80source, then use the final version of the sql code, type check it, and 81use the type check information to check all the constraints seem to 82have been added ok. 83 84* here are some example sets of relation values which should be 85 accepted by the constraint 86* here are some which should not be accepted by the constraint 87 88and have a way to check these (this stuff goes in the client program 89using the constraints). 90 91add supplemental expressions for error reporting: so instead of 92 saying x constraint failed, can run through the expressions one at a 93 time and when one passes or fails or something can give a more 94 useful error message depending on how it failed. 95 96~~~~ 97=== ghetto test thing 98want to write some tests for this constraint system just as a sanity 99check for now: 100arbitrary check e.g. cardinality < 5 101arbitrary check multiple tables e.g. sum cardinality of two tables 102check without acceleration?: 103fk 104fk to view 105unique 106x,y in board size range from another table 107 108for each check: 109check adding constraint to invalid tables throws 110check adding constraint to valid tables OK 111insert OK data into constrained tables 112insert bad data into constrained tables 113 114accelerated checks 115fk to view 116x,y in board size range 117check acceleration for normal checks & fk without pg? 118 119pg accelerated checks: 120just check pg catalog to see if inserted 121check 122fk 123unique 124 125all todo: yes, that means there is no direct testing of any of the 126constraint stuff... 127~~~~~ 128 129not too sure about how this all works, write a seperate bunch of 130code to read all the constraints either out of the catalog or from the 131source, then use the final version of the sql code, type check it, and 132use the type check information to check all the constraints seem to 133have been added ok. 134 135---------------------------- 136 137Tests/examples in CreateAssertionTests.lhs 138 139> {-# LANGUAGE QuasiQuotes, ScopedTypeVariables, TupleSections #-} 140> 141> module Database.HsSqlPpp.Extensions.CreateAssertion 142> (createAssertion) where 143> 144> --import Data.Generics 145> import Data.Generics.Uniplate.Data 146> --import Debug.Trace 147> import Control.Monad.State 148> import Data.Maybe 149> 150> import Database.HsSqlPpp.Ast 151> import Database.HsSqlPpp.Parser 152> import Database.HsSqlPpp.Utils.Utils 153> import Database.HsSqlPpp.Quote 154> import Database.HsSqlPpp.Extensions.AstUtils 155> import Database.HsSqlPpp.Annotation 156 157implementation 158============== 159 160when we go through, need to record the constraints we've already 161seen. using transformBiM with state monad, gives us the constraints in 162reverse order of the statement list, so chuck three reverses in there 163to make it work right. 164 165> createAssertion :: [Statement] -> [Statement] 166> createAssertion ast = reverse $ 167> (\f -> evalState (transformBiM f (reverse ast)) ([] :: ConstraintRecord)) $ \x -> 168> case x of 169> s@[sqlStmt| select create_assertion($s(name) 170> ,$s(exprtext));|] : tl -> do 171> existing <- get 172> let (new, rast) = makeConstraintDdl existing name exprtext 173> put new 174> return $ replaceSourcePos s rast ++ tl 175> x1 -> return x1 176> where 177> asti = getAstInfo ast 178> makeConstraintDdl :: ConstraintRecord -> String -> String -> (ConstraintRecord, [Statement]) 179> makeConstraintDdl cons name exprText = 180> let expr = either (error . show) id 181> $ parseScalarExpr "" exprText 182> in (newcons cons (tableNames expr) name 183> ,reverse (makeCheckFn name expr : extras cons name expr)) 184> extras :: ConstraintRecord -> String -> ScalarExpr -> [Statement] 185> extras cons name expr = flip concatMap (tableNames expr) $ \tn -> 186> let ec = existingConstraints tn cons 187> in if null ec 188> then [makeTriggerFn False tn [name] 189> ,makeTrigger tn] 190> else [makeTriggerFn True tn (name:ec)] 191> tableNames expr = let y = getReferencedTableList asti expr 192> in y 193> newcons cons tns nm = foldr (uncurry (insertWith (++))) cons (map (,[nm]) tns) 194> existingConstraints tn cons = fromMaybe [] $ lookup tn cons 195> 196> type ConstraintRecord = [(String,[String])] -- tablename, list of constraint names 197> 198> makeCheckFn :: String -> ScalarExpr -> Statement 199> makeCheckFn name expr = 200> let checkfn = "check_con_" ++ name 201> in [sqlStmt| 202> create function $(checkfn)() returns bool as $xxx$ 203> begin 204> return $(expr); 205> end; 206> $xxx$ language plpgsql stable; 207> |] 208> 209> makeTriggerFn :: Bool -> String -> [String] -> Statement 210> makeTriggerFn r tn nms = 211> let trigopname = tn ++ "_constraint_trigger_operator" 212> ifs :: [Statement] 213> ifs = map makeIf nms 214> -- using template approach cos can't get antistatement -> [statement] working 215> template = [sqlStmt| 216> create function $(trigopname)() returns trigger as $xxx$ 217> begin 218> null; 219> return OLD; 220> end; 221> $xxx$ language plpgsql stable; 222> |] 223> rep = if r 224> then transformBi $ \x -> 225> case x of 226> NoReplace -> Replace 227> x1 -> x1 228> else id 229> in flip transformBi (rep template) $ \x -> 230> case x of 231> NullStatement _ : tl -> ifs ++ tl 232> x1 -> x1 233> where 234> makeIf nm = let chk = "check_con_" ++ nm 235> errMsg = "update violates database constraint " ++ nm 236> in [pgsqlStmt| 237> if not $(chk)() then 238> raise exception '$(errMsg)'; 239> end if; 240> |] 241> 242> makeTrigger :: String -> Statement 243> makeTrigger tn = let trigname = tn ++ "_constraint_trigger" 244> opname = tn ++ "_constraint_trigger_operator" 245> in [sqlStmt| 246> create trigger $(trigname) 247> after insert or update or delete on $(tn) 248> for each statement 249> execute procedure $(opname)(); 250> |]