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,14 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version)
       indexes <- fetchMany fetchTableIndex
       runQuery_ $ sqlGetForeignKeys table
       fkeys <- fetchMany fetchForeignKey
+      triggers <- getDBTriggers tblName
       return $ mconcat [
           checkColumns 1 tblColumns desc
         , checkPrimaryKey tblPrimaryKey pk
         , checkChecks tblChecks checks
         , checkIndexes tblIndexes indexes
         , checkForeignKeys tblForeignKeys fkeys
+        , checkTriggers tblTriggers triggers
         ]
       where
         fetchTableColumn
@@ -541,6 +543,17 @@ checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version)
           , checkNames (fkName tblName) fkeys
           ]
 
+        checkTriggers :: [Trigger] -> [Trigger] -> ValidationResult
+        checkTriggers defs triggers =
+          mapValidationResult id mapErrs $ checkEquality "TRIGGERs" defs triggers
+          where
+            mapErrs []      = []
+            mapErrs errmsgs = errmsgs <>
+              [ "(HINT: If WHEN clauses are equal modulo number of parentheses, whitespace, \
+                \case of variables or type casts used in conditions, just copy and paste \
+                \expected output into source code.)"
+              ]
+
 -- | Checks whether database is consistent, performing migrations if
 -- necessary. Requires all table names to be in lower case.
 --
@@ -601,6 +614,7 @@ checkDBConsistency options domains tablesWithVersions migrations = do
 
     validateMigrations :: m ()
     validateMigrations = forM_ tables $ \table -> do
+      -- FIXME: https://github.com/scrive/hpqtypes-extras/issues/73
       let presentMigrationVersions
             = [ mgrFrom | Migration{..} <- migrations
                         , mgrTableName == tblName table ]

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,6 @@ createTableConstraints Table{..} = when (not $ null addConstraints) $ do
       , map sqlAddValidCheckMaybeDowntime tblChecks
       , map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys
       ]
+
+createTableTriggers :: MonadDB m => Table -> m ()
+createTableTriggers = mapM_ createTrigger . tblTriggers

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/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
 }