hpqtypes-extras 1.15.0.0 → 1.16.0.0

raw patch · 5 files changed

+85/−84 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +3/−0
• hpqtypes-extras.cabal +1/−1
• src/Database/PostgreSQL/PQTypes/Checks.hs +3/−2
• src/Database/PostgreSQL/PQTypes/Model/Trigger.hs +71/−65
• test/Main.hs +7/−16

@@ -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.

@@ -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:                      .

@@ -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, \

@@ -8,12 +8,8 @@ -- For details, see <https://www.postgresql.org/docs/11/sql-createtrigger.html>.  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\__\<name\>@.+--+-- @since 1.16.0.0+triggerFunctionMakeName :: RawSQL () -> RawSQL ()+triggerFunctionMakeName name = "trgfun__" <> name 

@@ -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]