diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +# hpqtypes-extras-1.16.0.0 (2022-05-20) +* Trigger functions are now part of triggers and have their names generated. + # hpqtypes-extras-1.15.0.0 (2022-05-11) * Add support for GHC 9.2. * Drop support for GHC < 8.8. diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: hpqtypes-extras -version: 1.15.0.0 +version: 1.16.0.0 synopsis: Extra utilities for hpqtypes library description: The following extras for hpqtypes library: . diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -543,10 +543,11 @@ , checkNames (fkName tblName) fkeys ] - checkTriggers :: [Trigger] -> [Trigger] -> ValidationResult + checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult checkTriggers defs triggers = - mapValidationResult id mapErrs $ checkEquality "TRIGGERs" defs triggers + mapValidationResult id mapErrs $ checkEquality "TRIGGERs" defs' triggers where + defs' = map (\t -> (t, triggerFunctionMakeName $ triggerName t)) defs mapErrs [] = [] mapErrs errmsgs = errmsgs <> [ "(HINT: If WHEN clauses are equal modulo number of parentheses, whitespace, \ diff --git a/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs b/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs @@ -8,12 +8,8 @@ -- For details, see . module Database.PostgreSQL.PQTypes.Model.Trigger ( - -- * Trigger functions - TriggerFunction(..) - , sqlCreateTriggerFunction - , sqlDropTriggerFunction -- * Triggers - , TriggerEvent(..) + TriggerEvent(..) , Trigger(..) , triggerMakeName , triggerBaseName @@ -22,6 +18,10 @@ , createTrigger , dropTrigger , getDBTriggers + -- * Trigger functions + , sqlCreateTriggerFunction + , sqlDropTriggerFunction + , triggerFunctionMakeName ) where import Data.Bits (testBit) @@ -35,49 +35,6 @@ import qualified Data.Set as Set import qualified Data.Text as Text --- | Function associated with a trigger. --- --- @since 1.15.0.0 -data TriggerFunction = TriggerFunction { - tfName :: RawSQL () - -- ^ The function's name. - , tfSource :: RawSQL () - -- ^ The functions's body source code. -} deriving (Show) - -instance Eq TriggerFunction where - -- Since the functions have no arguments, it's impossible to create two functions with - -- the same name. Therefore comparing functions only by their names is enough in this - -- case. The assumption is, of course, that the database schema is only changed using - -- this framework. - f1 == f2 = tfName f1 == tfName f2 - --- | Build an SQL statement for creating a trigger function. --- --- Since we only support @CONSTRAINT@ triggers, the function will always @RETURN TRIGGER@ --- and will have no parameters. --- --- @since 1.15.0.0 -sqlCreateTriggerFunction :: TriggerFunction -> RawSQL () -sqlCreateTriggerFunction TriggerFunction{..} = - "CREATE FUNCTION" - <+> tfName - <> "()" - <+> "RETURNS TRIGGER" - <+> "AS $$" - <+> tfSource - <+> "$$" - <+> "LANGUAGE PLPGSQL" - <+> "VOLATILE" - <+> "RETURNS NULL ON NULL INPUT" - --- | Build an SQL statement for dropping a trigger function. --- --- @since 1.15.0.0 -sqlDropTriggerFunction :: TriggerFunction -> RawSQL () -sqlDropTriggerFunction TriggerFunction{..} = - "DROP FUNCTION" <+> tfName <+> "RESTRICT" - -- | Trigger event name. -- -- @since 1.15.0.0 @@ -112,10 +69,20 @@ , triggerWhen :: Maybe (RawSQL ()) -- ^ The condition that specifies whether the trigger should fire. Corresponds to the -- @WHEN ( __condition__ )@ in the trigger definition. - , triggerFunction :: TriggerFunction + , triggerFunction :: RawSQL () -- ^ The function to execute when the trigger fires. -} deriving (Eq, Show) +} deriving (Show) +instance Eq Trigger where + t1 == t2 = + triggerTable t1 == triggerTable t2 + && triggerName t1 == triggerName t2 + && triggerEvents t1 == triggerEvents t2 + && triggerDeferrable t1 == triggerDeferrable t2 + && triggerInitiallyDeferred t1 == triggerInitiallyDeferred t2 + && triggerWhen t1 == triggerWhen t2 + -- Function source code is not guaranteed to be equal, so we ignore it. + -- | Make a trigger name that can be used in SQL. -- -- Given a base @name@ and @tableName@, return a new name that will be used as the @@ -173,7 +140,7 @@ else "INITIALLY IMMEDIATE" in deferrable <+> deferred trgWhen = maybe "" (\w -> "WHEN (" <+> w <+> ")") triggerWhen - trgFunction = tfName triggerFunction + trgFunction = triggerFunctionMakeName triggerName -- | Build an SQL statement that drops a trigger. @@ -198,7 +165,7 @@ createTrigger :: MonadDB m => Trigger -> m () createTrigger trigger = do -- TODO: Use 'withTransaction' here? That would mean adding MonadMask... - runQuery_ . sqlCreateTriggerFunction $ triggerFunction trigger + runQuery_ $ sqlCreateTriggerFunction trigger runQuery_ $ sqlCreateTrigger trigger -- | Drop the trigger from the database. @@ -210,12 +177,13 @@ -- 'sqlDropTrigger'. -- TODO: Use 'withTransaction' here? That would mean adding MonadMask... runQuery_ $ sqlDropTrigger trigger - runQuery_ . sqlDropTriggerFunction $ triggerFunction trigger + runQuery_ $ sqlDropTriggerFunction trigger -- | Get all noninternal triggers from the database. -- -- Run a query that returns all triggers associated with the given table and marked as --- @tgisinternal = false@. +-- @tgisinternal = false@. The second item in the returned tuple is the trigger's function +-- name. -- -- Note that, in the background, to get the trigger's @WHEN@ clause and the source code of -- the attached function, the entire query that had created the trigger is received using @@ -224,7 +192,7 @@ -- originally typed. -- -- @since 1.15.0 -getDBTriggers :: forall m. MonadDB m => RawSQL () -> m [Trigger] +getDBTriggers :: forall m. MonadDB m => RawSQL () -> m [(Trigger, RawSQL ())] getDBTriggers tableName = do runQuery_ . sqlSelect "pg_trigger t" $ do sqlResult "t.tgname::text" -- name @@ -236,7 +204,7 @@ -- example, if the original query had excessive whitespace in it, it won't be in this -- result. sqlResult "pg_get_triggerdef(t.oid, true)::text" - sqlResult "p.proname::text" -- name + sqlResult "p.proname::text" sqlResult "p.prosrc" -- text sqlResult "c.relname::text" sqlJoinOn "pg_proc p" "t.tgfoid = p.oid" @@ -245,16 +213,18 @@ sqlWhereEq "c.relname" $ unRawSQL tableName fetchMany getTrigger where - getTrigger :: (String, Int16, Bool, Bool, String, String, String, String) -> Trigger + getTrigger :: (String, Int16, Bool, Bool, String, String, String, String) -> (Trigger, RawSQL ()) getTrigger (tgname, tgtype, tgdeferrable, tginitdeferrable, triggerdef, proname, prosrc, tblName) = - Trigger { triggerTable = tableName' - , triggerName = triggerBaseName (unsafeSQL tgname) tableName' - , triggerEvents = trgEvents - , triggerDeferrable = tgdeferrable - , triggerInitiallyDeferred = tginitdeferrable - , triggerWhen = tgrWhen - , triggerFunction = TriggerFunction (unsafeSQL proname) (unsafeSQL prosrc) - } + ( Trigger { triggerTable = tableName' + , triggerName = triggerBaseName (unsafeSQL tgname) tableName' + , triggerEvents = trgEvents + , triggerDeferrable = tgdeferrable + , triggerInitiallyDeferred = tginitdeferrable + , triggerWhen = tgrWhen + , triggerFunction = unsafeSQL prosrc + } + , unsafeSQL proname + ) where tableName' :: RawSQL () tableName' = unsafeSQL tblName @@ -299,4 +269,40 @@ trgUpdateOf columnsSQL = let columns = map (unsafeSQL . Text.unpack) . Text.splitOn ", " $ unRawSQL columnsSQL in TriggerUpdateOf columns + +-- | Build an SQL statement for creating a trigger function. +-- +-- Since we only support @CONSTRAINT@ triggers, the function will always @RETURN TRIGGER@ +-- and will have no parameters. +-- +-- @since 1.15.0.0 +sqlCreateTriggerFunction :: Trigger -> RawSQL () +sqlCreateTriggerFunction Trigger{..} = + "CREATE FUNCTION" + <+> triggerFunctionMakeName triggerName + <> "()" + <+> "RETURNS TRIGGER" + <+> "AS $$" + <+> triggerFunction + <+> "$$" + <+> "LANGUAGE PLPGSQL" + <+> "VOLATILE" + <+> "RETURNS NULL ON NULL INPUT" + +-- | Build an SQL statement for dropping a trigger function. +-- +-- @since 1.15.0.0 +sqlDropTriggerFunction :: Trigger -> RawSQL () +sqlDropTriggerFunction Trigger{..} = + "DROP FUNCTION" <+> triggerFunctionMakeName triggerName <+> "RESTRICT" + +-- | Make a trigger function name that can be used in SQL. +-- +-- Given a base @name@, return a new name that will be used as the actual name +-- of the trigger function in an SQL query. The returned name is in the format +-- @trgfun\__\@. +-- +-- @since 1.16.0.0 +triggerFunctionMakeName :: RawSQL () -> RawSQL () +triggerFunctionMakeName name = "trgfun__" <> name diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -839,7 +839,7 @@ , triggerDeferrable = False , triggerInitiallyDeferred = False , triggerWhen = Nothing - , triggerFunction = TriggerFunction "function_1" $ + , triggerFunction = "begin" <+> " perform true;" <+> " return null;" @@ -849,7 +849,7 @@ bankTrigger2 :: Trigger bankTrigger2 = bankTrigger1 - { triggerFunction = TriggerFunction "function_2" $ + { triggerFunction = "begin" <+> " return null;" <+> "end;" @@ -863,7 +863,7 @@ , triggerDeferrable = True , triggerInitiallyDeferred = True , triggerWhen = Nothing - , triggerFunction = TriggerFunction "function_3" $ + , triggerFunction = "begin" <+> " perform true;" <+> " return null;" @@ -913,16 +913,6 @@ verify [bankTrigger1] True do - let msg = "checkDatabase fails if triggers differ in function name" - ts = [ tableBankSchema1 { tblVersion = 2 - , tblTriggers = [bankTrigger1] - } - ] - ms = [ createTriggerMigration 1 bankTrigger2 ] - triggerStep msg $ do - assertException msg $ migrate ts ms - - do -- Attempt to create the same triggers twice. Should fail with a DBException saying -- that function already exists. let msg = "database exception is raised if trigger is created twice" @@ -1124,7 +1114,8 @@ verify :: (MonadIO m, MonadDB m, HasCallStack) => [Trigger] -> Bool -> m () verify triggers present = do dbTriggers <- getDBTriggers "bank" - let ok = and $ map (`elem` dbTriggers) triggers + let trgs = map fst dbTriggers + ok = and $ map (`elem` trgs) triggers err = "Triggers " <> (if present then "" else "not ") <> "present in the database." trans = if present then id else not liftIO . assertBool err $ trans ok @@ -1145,8 +1136,8 @@ recreateTriggerDB = do runSQL_ "DROP TRIGGER IF EXISTS trg__bank__trigger_1 ON bank;" runSQL_ "DROP TRIGGER IF EXISTS trg__bank__trigger_2 ON bank;" - runSQL_ "DROP FUNCTION IF EXISTS function_1;" - runSQL_ "DROP FUNCTION IF EXISTS function_2;" + runSQL_ "DROP FUNCTION IF EXISTS trgfun__trigger_1;" + runSQL_ "DROP FUNCTION IF EXISTS trgfun__trigger_2;" runSQL_ "DROP TABLE IF EXISTS bank;" runSQL_ "DELETE FROM table_versions WHERE name = 'bank'"; migrate [tableBankSchema1] [createTableMigration tableBankSchema1]