Commit 4b840d51 authored by Sophie Herold's avatar Sophie Herold 🌼

Adds support for triggers (closes #3)

parent 35ea15b8
v0.11.0.0
- Adds support for reading type defintions from type.d
- Adds support for TRIGGERs
- Fixes upgrades failing if types exist
v0.10.0.0
- Adds support for reading setup.yml from STDIN
- Adds "did you mean" for YamSql fields
......
......@@ -10,7 +10,7 @@ update-and-build: update build
update:
cabal sandbox init
cabal update
cabal install -ffast --force-reinstalls --only-dependencies --disable-optimization
cabal install -ffast --only-dependencies --disable-optimization
test:
cabal configure --disable-optimization --enable-coverage --enable-tests
......
......@@ -80,7 +80,7 @@ Those are the YamSql files for the project:
schemas:
- math
schema_dirs:
- schemas
- ./schemas
```
```yaml
......
......@@ -72,6 +72,7 @@ library
Database.HamSql.Internal.Stmt.Schema
Database.HamSql.Internal.Stmt.Sequence
Database.HamSql.Internal.Stmt.Table
Database.HamSql.Internal.Stmt.Trigger
Database.HamSql.Internal.Stmt.Type
Database.YamSql.Internal.Obj.Check
Database.YamSql.Internal.Obj.Domain
......@@ -80,6 +81,7 @@ library
Database.YamSql.Internal.Obj.Schema
Database.YamSql.Internal.Obj.Sequence
Database.YamSql.Internal.Obj.Table
Database.YamSql.Internal.Obj.Trigger
Database.YamSql.Internal.Obj.Type
Paths_hamsql
......
......@@ -79,6 +79,7 @@ deployedTables schema = do
fks <- deployedForeignKeys (schema, table)
uniques <- deployedUniqueConstraints (schema, table)
checks <- deployedTableChecks (schema, table)
trs <- deployedTriggers (schema, table)
return
Table
{ tableName = table
......@@ -94,6 +95,7 @@ deployedTables schema = do
, tablePrivUpdate = Nothing
, tablePrivDelete = Nothing
, tableTemplates = Nothing
, tableTriggers = presetEmpty trs
}
qry =
[sql|
......@@ -137,8 +139,59 @@ deployedColumns tbl = map toColumn <$> psqlQry qry (Only $ toSqlCode tbl)
NOT attisdropped
AND attnum > 0
AND attrelid = ?::regclass::oid
ORDER BY attname
|]
deployedTriggers :: (SqlName, SqlName) -> SqlT [Trigger]
deployedTriggers tbl = do
trs <- psqlQry qry (Only $ toSqlCode tbl)
return $ map toTrigger trs
where
toTrigger (trname, trdesc, trevents, trcond, trorient, trtiming, trcall, cols) =
Trigger
{ triggerName = trname
, triggerDescription = fromMaybe "" trdesc
, triggerMoment = trtiming
, triggerEvents =
map (fixUpd (fromPGArray <$> cols)) $ fromPGArray trevents
, triggerForEach = trorient
, triggerCondition = trcond
, triggerExecute =
fromMaybe trcall $ stripPrefix "EXECUTE PROCEDURE " trcall
}
fixUpd :: Maybe [Text] -> Text -> Text
fixUpd (Just ys) x
| x == "UPDATE" = x <> " OF " <> intercalate ", " ys
| otherwise = x
fixUpd _ x = x
qry =
[sql|
SELECT
inf.trigger_name,
pg_catalog.obj_description(tr.oid, 'pg_trigger') AS desc,
(SELECT
array_agg(i.event_manipulation::text)
FROM information_schema.triggers i
WHERE i.trigger_schema = inf.trigger_schema AND i.trigger_name = inf.trigger_name )
AS events,
inf.action_condition,
inf.action_orientation,
inf.action_timing,
inf.action_statement,
(
SELECT array_agg(col.attname)
FROM pg_catalog.pg_attribute col
WHERE col.attrelid = tr.tgrelid AND col.attnum = ANY(tr.tgattr))
AS cols
FROM pg_catalog.pg_trigger tr
JOIN pg_catalog.pg_class cl ON tr.tgrelid = cl.oid
JOIN pg_catalog.pg_namespace ns ON ns.oid = cl.relnamespace
JOIN information_schema.triggers inf
ON inf.trigger_schema = ns.nspname AND inf.trigger_name = tr.tgname
WHERE tr.tgrelid = ?::regclass::oid
GROUP BY 1, 2, 4, 5, 6, 7, 8, inf.trigger_schema;
|]
deployedTableChecks :: (SqlName, SqlName) -> SqlT [Check]
deployedTableChecks tbl = do
cons <- psqlQry qry (Only $ toSqlCode tbl)
......@@ -305,6 +358,7 @@ deployedFunctions schema = do
JOIN pg_catalog.pg_language AS l
ON p.prolang = l.oid
WHERE pronamespace::regnamespace = ?::regnamespace
ORDER BY proname
|]
deployedDomains :: SqlName -> SqlT [Domain]
......@@ -314,7 +368,7 @@ deployedDomains schema = do
where
toDomain (domname, domdesc, domtype, domdefault) = do
constraints <- deployedDomainConstraints (schema, domname)
return $
return
Domain
{ domainName = domname
, domainDescription = fromMaybe "" domdesc
......@@ -361,9 +415,9 @@ deployedDomainConstraints dom = do
deployedSequences :: SqlName -> SqlT [Sequence]
deployedSequences schema = do
seqs <- psqlQry qry1 (Only $ toSqlCode schema)
map toSequence <$> head <$> sequence <$> mapM doQry2 seqs
(map toSequence . head) . sequence <$> mapM doQry2 seqs
where
doQry2 (n, desc) = psqlQry (qry2 (n :: Text)) (Only $ (desc :: Maybe Text))
doQry2 (n, desc) = psqlQry (qry2 (n :: Text)) (Only (desc :: Maybe Text))
toSequence (seqname, seqstartvalue, seqincrementby, seqmaxvalue, seqminvalue, seqcachevalue, seqiscycled, seqdesc) =
Sequence
{ sequenceName = seqname
......@@ -399,7 +453,7 @@ deployedTypes schema = do
where
toType (typname, typdesc) = do
elements <- map toElement <$> deployedColumns (schema, typname)
return $
return
Type
{ typeName = typname
, typeDescription = fromMaybe "" typdesc
......
......@@ -16,6 +16,7 @@ import Database.HamSql.Internal.Stmt.Role ()
import Database.HamSql.Internal.Stmt.Schema ()
import Database.HamSql.Internal.Stmt.Sequence ()
import Database.HamSql.Internal.Stmt.Table ()
import Database.HamSql.Internal.Stmt.Trigger ()
import Database.HamSql.Internal.Stmt.Type ()
allSchemaElements :: Schema -> [SetupElement]
......@@ -28,8 +29,12 @@ allSchemaElements schema =
toElemList schemaTables schema ++
toElemList schemaTypes schema ++
concat
[ map (SetupElement . (\x -> SqlContext (schema, table, x))) $
tableColumns table
[ map
(SetupElement . (\x -> SqlContext (schema, table, x)))
(tableColumns table) ++
map
(SetupElement . (\x -> SqlContext (schema, table, x)))
(fromMaybe [] $ tableTriggers table)
| table <- fromMaybe [] $ schemaTables schema
]
where
......
......@@ -127,7 +127,7 @@ instance ToSqlStmts (SqlContext (Schema, Table, Column)) where
maybePrefix " ON DELETE " (columnOnRefDelete c)
-- CREATE SEQUENCE (for type SERIAL)
stmtsSerialSequence
| columnIsSerial /= Nothing = toSqlStmts context serialSequenceContext
| isJust columnIsSerial = toSqlStmts context serialSequenceContext
| otherwise = [Nothing]
-- Helpers
stmtAlterColumn t x =
......@@ -184,7 +184,7 @@ instance ToSqlStmts (SqlContext (Schema, Table)) where
-- table comment
, stmtCommentOn obj (tableDescription t)
] ++
(concat $ maybeMap (stmtCheck obj) (tableChecks t)) ++
concat (maybeMap (stmtCheck obj) (tableChecks t)) ++
-- grant rights to roles
maybeMap (sqlGrant "SELECT") (tablePrivSelect t) ++
maybeMap (sqlGrant "UPDATE") (tablePrivUpdate t) ++
......
-- This file is part of HamSql
--
-- Copyright 2016 by it's authors.
-- Copyright 2017 by it's authors.
-- Some rights reserved. See COPYING, AUTHORS.
{-# LANGUAGE FlexibleInstances #-}
......@@ -9,48 +9,28 @@ module Database.HamSql.Internal.Stmt.Trigger where
import qualified Data.Text as T
import Database.HamSql.Internal.Stmt.Basic
import Database.HamSql.Internal.Stmt.Function
import Database.HamSql.Internal.Stmt.Function ()
instance ToSqlStmts (SqlContextSqo Trigger) where
toSqlStmts = stmtsDeployTrigger
stmtsDeployTrigger :: SetupContext -> SqlContextSqo Trigger -> [Maybe SqlStmt]
stmtsDeployTrigger context obj@SqlContextSqo { sqlSqoSchema = s
, sqlSqoObject = t
} =
stmtsDeployFunction context (SqlContextSqoArgtypes s triggerFunction) ++
map triggerStmt (triggerTables t)
where
triggerFunction =
Function
{ functionName = triggerName t
, functionDescription = triggerDescription t
, functionReturns = SqlType "trigger"
, functionParameters = Nothing
, functionTemplates = Nothing
, functionTemplateData = Nothing
, functionReturnsColumns = Nothing
, functionVariables = triggerVariables t
-- TODO: trigger owner?
, functionPrivExecute = Just []
, functionSecurityDefiner = Just True
-- TODO: trigger owner?
, functionOwner = Nothing
, functionLanguage = triggerLanguage t
, functionBody = triggerBody t
}
triggerStmt tbl =
newSqlStmt SqlCreateTrigger obj $
"CREATE TRIGGER " <> toSqlCode (triggerName t) <> " " <> triggerMoment t <>
" " <>
T.intercalate " OR " (triggerEvents t) <>
" ON " <>
toSqlCode tbl <>
" FOR EACH " <>
triggerForEach t <>
condition (triggerCondition t) <>
" EXECUTE PROCEDURE " <>
sqlIdCode obj <>
"()"
condition Nothing = ""
condition (Just x) = " WHEN " <> x <> " "
instance ToSqlStmts (SqlContext (Schema, Table, Trigger)) where
toSqlStmts _ obj@(SqlContext (s, tabl, t)) = [triggerStmt, triggerComment]
where
triggerComment =
newSqlStmt SqlComment obj $
"COMMENT ON TRIGGER " <> toSqlCode (triggerName t) <> " ON " <>
sqlIdCode (SqlContext (s, tabl)) <>
" IS " <>
toSqlCodeString (triggerDescription t)
triggerStmt =
newSqlStmt SqlCreateTrigger obj $
"CREATE TRIGGER " <> toSqlCode (triggerName t) <> " " <> triggerMoment t <>
" " <>
T.intercalate " OR " (triggerEvents t) <>
" ON " <>
sqlIdCode (SqlContext (s, tabl)) <>
" FOR EACH " <>
triggerForEach t <>
condition (triggerCondition t) <>
" EXECUTE PROCEDURE " <>
triggerExecute t
condition Nothing = ""
condition (Just x) = " WHEN (" <> x <> ") "
......@@ -51,7 +51,7 @@ schemaToDirTree schema =
toYml :: ToJSON a => a -> B.ByteString
toYml =
encodePretty $
setConfCompare (comparing ymlOrd) $ (setConfDropNull True) defConfig
setConfCompare (comparing ymlOrd) $ setConfDropNull True defConfig
doWrite :: FilePath -> DirTree B.ByteString -> IO (AnchoredDirTree ())
doWrite p x = writeDirectoryWith B.writeFile (p :/ x)
......
......@@ -13,6 +13,7 @@ module Database.YamSql.Internal.Obj.Schema
, module Database.YamSql.Internal.Obj.Role
, module Database.YamSql.Internal.Obj.Sequence
, module Database.YamSql.Internal.Obj.Table
, module Database.YamSql.Internal.Obj.Trigger
, module Database.YamSql.Internal.Obj.Type
) where
......@@ -24,6 +25,7 @@ import Database.YamSql.Internal.Obj.Function
import Database.YamSql.Internal.Obj.Role
import Database.YamSql.Internal.Obj.Sequence
import Database.YamSql.Internal.Obj.Table
import Database.YamSql.Internal.Obj.Trigger
import Database.YamSql.Internal.Obj.Type
-- Schema --
......@@ -81,6 +83,10 @@ instance ToSqlId (SqlContext (Schema, Domain)) where
sqlId (SqlContext (s, x)) =
SqlId $ SqlObj SQL_DOMAIN (schemaName s <.> domainName x)
instance ToSqlId (SqlContext (Schema, Table, Trigger)) where
sqlId (SqlContext (s, x, y)) =
SqlId $ SqlObj SQL_TRIGGER (schemaName s <.> tableName x, triggerName y)
instance ToSqlId (SqlContext (Schema, Function)) where
sqlId (SqlContext (s, x)) =
SqlId $
......
......@@ -3,6 +3,7 @@ module Database.YamSql.Internal.Obj.Table where
import Database.YamSql.Internal.Basic
import Database.YamSql.Internal.Commons
import Database.YamSql.Internal.Obj.Check
import Database.YamSql.Internal.Obj.Trigger
data Table = Table
{ tableName :: SqlName
......@@ -17,6 +18,7 @@ data Table = Table
, tablePrivInsert :: Maybe [SqlName]
, tablePrivUpdate :: Maybe [SqlName]
, tablePrivDelete :: Maybe [SqlName]
, tableTriggers :: Maybe [Trigger]
, tableTemplates :: Maybe [SqlName]
} deriving (Data, Generic, Show)
......
......@@ -8,19 +8,16 @@
module Database.YamSql.Internal.Obj.Trigger where
import Database.YamSql.Internal.Basic
import Database.YamSql.Internal.Commons
--import Database.YamSql.Internal.Commons
data Trigger = Trigger
{ triggerName :: SqlName
, triggerDescription :: Text
, triggerTables :: [SqlName]
, triggerMoment :: Text
, triggerEvents :: [Text]
, triggerForEach :: Text
, triggerCondition :: Maybe Text
, triggerLanguage :: Maybe Text
, triggerVariables :: Maybe [Variable]
, triggerBody :: Maybe Text
, triggerExecute :: Text
} deriving (Generic, Show, Data)
instance FromJSON Trigger where
......@@ -29,6 +26,11 @@ instance FromJSON Trigger where
instance ToJSON Trigger where
toJSON = toYamSqlJson
instance ToSqlIdPart Trigger where
sqlIdPart = triggerName
sqlIdPartType = const "TRIGGER"
data SQL_TRIGGER =
SQL_TRIGGER
deriving (SqlObjType, Show)
instance ToSqlCode SQL_TRIGGER where
toSqlCode = const "TRIGGER"
type TriggerTemplate = Trigger
......@@ -41,12 +41,12 @@ main =
[ selfTestStmt "test/setups/self-test.yml"
, selfTestStruct
, selfTestUpgrade "test/setups/self-test.yml"
, selfTestUpgradeDelete "test/setups/self-test-empty.yml"
, selfTestUpgrade "test/setups/self-test.yml"
--, selfTestUpgradeDelete "test/setups/self-test-empty.yml"
--, selfTestUpgrade "test/setups/self-test.yml"
]
, testGroup
"self test stmt only"
[selfTestStmt "test/setups/self-test-stmt.yml"]
[] --[selfTestStmt "test/setups/self-test-stmt.yml"]
]
]
......
---
name: trig
description: Trigger function
language: plpgsql
returns: trigger
---
BEGIN
RETURN NULL;
END;
......@@ -19,3 +19,20 @@ unique:
columns: [x1]
- [x1, X3]
- [x1]
triggers:
- name: T1
description: First trigger
events:
- INSERT
- UPDATE OF x1, x2
for_each: ROW
moment: AFTER
condition: "true"
execute: '"self-test".trig(''kleiner text'', ''73'')'
- name: T2
description: Sec trigger
events:
- INSERT
for_each: ROW
moment: AFTER
execute: '"self-test".trig()'
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment