Add support for triggers and associated functions

CHANGELOG.md

@@ -1,3 +1,6 @@
+# hpqtypes-extras-1.15.0.0 (2022-??-??)
+* Add support for triggers and trigger functions.
+
 # hpqtypes-extras-1.14.2.0 (2022-??-??)
 * Add support for GHC 9.2.
 * Drop support for GHC < 8.8.

hpqtypes-extras.cabal

@@ -1,6 +1,6 @@
 cabal-version:       2.2
 name:                hpqtypes-extras
-version:             1.14.2.0
+version:             1.15.0.0
 synopsis:            Extra utilities for hpqtypes library
 description:         The following extras for hpqtypes library:
                      .
@@ -68,6 +68,7 @@ library
                  , Database.PostgreSQL.PQTypes.Model.Migration
                  , Database.PostgreSQL.PQTypes.Model.PrimaryKey
                  , Database.PostgreSQL.PQTypes.Model.Table
+                 , Database.PostgreSQL.PQTypes.Model.Trigger
                  , Database.PostgreSQL.PQTypes.SQL.Builder
                  , Database.PostgreSQL.PQTypes.Versions
 
@@ -111,6 +112,7 @@ test-suite  hpqtypes-extras-tests
   ghc-options:        -Wall
 
   build-depends:      base
+                    , containers
                     , exceptions
                     , hpqtypes
                     , hpqtypes-extras

src/Database/PostgreSQL/PQTypes/Checks.hs

@@ -419,12 +419,15 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version)
       indexes <- fetchMany fetchTableIndex
       runQuery_ $ sqlGetForeignKeys table
       fkeys <- fetchMany fetchForeignKey
+      triggers <- getDBTriggers
       return $ mconcat [
           checkColumns 1 tblColumns desc
         , checkPrimaryKey tblPrimaryKey pk
         , checkChecks tblChecks checks
         , checkIndexes tblIndexes indexes
         , checkForeignKeys tblForeignKeys fkeys
+        , checkTriggers tblTriggers $
+            filter (\Trigger{..} -> triggerTable == tblName) triggers
         ]
       where
         fetchTableColumn
@@ -541,6 +544,9 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version)
           , checkNames (fkName tblName) fkeys
           ]
 
+        checkTriggers :: [Trigger] -> [Trigger] -> ValidationResult
+        checkTriggers = checkEquality "TRIGGERs"
+
 -- | Checks whether database is consistent, performing migrations if
 -- necessary. Requires all table names to be in lower case.
 --
@@ -607,6 +613,11 @@ checkDBConsistency options domains tablesWithVersions migrations = do
           expectedMigrationVersions
             = reverse $ take (length presentMigrationVersions) $
               reverse  [0 .. tblVersion table - 1]
+            -- -- TODO: File a separate issue about this with a reproducer!
+            -- = if null presentMigrationVersions
+            --   then []
+            --   else [0 .. tblVersion table - 1]
+
       checkMigrationsListValidity table presentMigrationVersions
         expectedMigrationVersions
 
@@ -814,6 +825,14 @@ checkDBConsistency options domains tablesWithVersions migrations = do
           runSQL_ "COMMIT"
           runQuery_ (sqlDropIndexConcurrently tname idx) `finally` begin
           updateTableVersion
+
+        CreateTriggerMigration trigger@Trigger{..} -> do
+          logInfo_ $ "  Creating function" <+> (unRawSQL $ tfName triggerFunction)
+          runQuery_ $ sqlCreateTriggerFunction triggerFunction
+          logInfo_ $ "  Creating trigger" <+> (unRawSQL $ triggerMakeName triggerName triggerTable)
+          runQuery_ $ sqlCreateTrigger trigger
+          updateTableVersion
+
       where
         logMigration = do
           logInfo_ $ arrListTable mgrTableName

src/Database/PostgreSQL/PQTypes/Migrate.hs

@@ -1,7 +1,8 @@
 module Database.PostgreSQL.PQTypes.Migrate (
   createDomain,
   createTable,
-  createTableConstraints
+  createTableConstraints,
+  createTableTriggers
   ) where
 
 import Control.Monad
@@ -28,6 +29,8 @@ createTable withConstraints table@Table{..} = do
   forM_ tblIndexes $ runQuery_ . sqlCreateIndexMaybeDowntime tblName
   -- Add all the other constraints if applicable.
   when withConstraints $ createTableConstraints table
+  -- Create triggers.
+  createTableTriggers table
   -- Register the table along with its version.
   runQuery_ . sqlInsert "table_versions" $ do
     sqlSet "name" (tblNameText table)
@@ -42,3 +45,8 @@ createTableConstraints Table{..} = when (not $ null addConstraints) $ do
       , map sqlAddValidCheckMaybeDowntime tblChecks
       , map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys
       ]
+
+createTableTriggers :: MonadDB m => Table -> m ()
+createTableTriggers Table{..} = forM_ tblTriggers $ \t -> do
+  runQuery_ . sqlCreateTriggerFunction $ triggerFunction t
+  runQuery_ $ sqlCreateTrigger t

src/Database/PostgreSQL/PQTypes/Model.hs

@@ -9,6 +9,7 @@ module Database.PostgreSQL.PQTypes.Model (
   , module Database.PostgreSQL.PQTypes.Model.Migration
   , module Database.PostgreSQL.PQTypes.Model.PrimaryKey
   , module Database.PostgreSQL.PQTypes.Model.Table
+  , module Database.PostgreSQL.PQTypes.Model.Trigger
   ) where
 
 import Database.PostgreSQL.PQTypes.Model.Check
@@ -21,3 +22,4 @@ import Database.PostgreSQL.PQTypes.Model.Index
 import Database.PostgreSQL.PQTypes.Model.Migration
 import Database.PostgreSQL.PQTypes.Model.PrimaryKey
 import Database.PostgreSQL.PQTypes.Model.Table
+import Database.PostgreSQL.PQTypes.Model.Trigger

src/Database/PostgreSQL/PQTypes/Model/Migration.hs

@@ -33,6 +33,7 @@ import Data.Int
 
 import Database.PostgreSQL.PQTypes.Model.Index
 import Database.PostgreSQL.PQTypes.Model.Table
+import Database.PostgreSQL.PQTypes.Model.Trigger
 import Database.PostgreSQL.PQTypes.SQL.Raw
 
 -- | Migration action to run, either an arbitrary 'MonadDB' action, or
@@ -57,6 +58,9 @@ data MigrationAction m =
       (RawSQL ()) -- ^ Table name
       TableIndex  -- ^ Index
 
+  -- | Migration for creating a trigger.
+  | CreateTriggerMigration Trigger
+
 -- | Migration object.
 data Migration m =
   Migration {
@@ -78,6 +82,7 @@ isStandardMigration Migration{..} =
     DropTableMigration{}               -> False
     CreateIndexConcurrentlyMigration{} -> False
     DropIndexConcurrentlyMigration{}   -> False
+    CreateTriggerMigration{}           -> False
 
 isDropTableMigration :: Migration m -> Bool
 isDropTableMigration Migration{..} =
@@ -86,3 +91,4 @@ isDropTableMigration Migration{..} =
     DropTableMigration{}               -> True
     CreateIndexConcurrentlyMigration{} -> False
     DropIndexConcurrentlyMigration{}   -> False
+    CreateTriggerMigration{}           -> False

src/Database/PostgreSQL/PQTypes/Model/Table.hs

@@ -25,6 +25,7 @@ import Database.PostgreSQL.PQTypes.Model.ColumnType
 import Database.PostgreSQL.PQTypes.Model.ForeignKey
 import Database.PostgreSQL.PQTypes.Model.Index
 import Database.PostgreSQL.PQTypes.Model.PrimaryKey
+import Database.PostgreSQL.PQTypes.Model.Trigger
 
 data TableColumn = TableColumn {
   colName     :: RawSQL ()
@@ -69,6 +70,7 @@ data Table =
 , tblChecks             :: [Check]
 , tblForeignKeys        :: [ForeignKey]
 , tblIndexes            :: [TableIndex]
+, tblTriggers           :: [Trigger]
 , tblInitialSetup       :: Maybe TableInitialSetup
 }
 
@@ -86,6 +88,7 @@ tblTable = Table {
 , tblChecks = []
 , tblForeignKeys = []
 , tblIndexes = []
+, tblTriggers = []
 , tblInitialSetup = Nothing
 }