WIP: Adding trigger support. Need to add migrations of triggers and f…

…unctions

- drop functions when requested
- create triggers when missing
- drop triggers when no longer present in table definition

orville-postgresql/orville-postgresql.cabal

@@ -120,6 +120,8 @@ library
       Orville.PostgreSQL.Expr.Internal.Name.SchemaName
       Orville.PostgreSQL.Expr.Internal.Name.SequenceName
       Orville.PostgreSQL.Expr.Internal.Name.TableName
+      Orville.PostgreSQL.Expr.Internal.Name.TriggerName
+      Orville.PostgreSQL.Expr.Trigger
       Orville.PostgreSQL.Expr.Vacuum
       Orville.PostgreSQL.Internal.Bracket
       Orville.PostgreSQL.Internal.Extra.NonEmpty
@@ -137,7 +139,12 @@ library
       Orville.PostgreSQL.PgCatalog.PgConstraint
       Orville.PostgreSQL.PgCatalog.PgIndex
       Orville.PostgreSQL.PgCatalog.PgNamespace
+      Orville.PostgreSQL.PgCatalog.PgProc
       Orville.PostgreSQL.PgCatalog.PgSequence
+      Orville.PostgreSQL.PgCatalog.PgTrigger
+      Orville.PostgreSQL.Schema.FunctionDefinition
+      Orville.PostgreSQL.Schema.FunctionIdentifier
+      Orville.PostgreSQL.Schema.TriggerDefinition
       Paths_orville_postgresql
   hs-source-dirs:
       src
@@ -188,6 +195,7 @@ test-suite spec
       Test.Expr.TableDefinition
       Test.Expr.TestSchema
       Test.Expr.Time
+      Test.Expr.Trigger
       Test.Expr.Vacuum
       Test.Expr.Where
       Test.FieldDefinition

orville-postgresql/scripts/gen-local-docs.sh

@@ -2,7 +2,7 @@
 
 set -e
 
-docker-compose run \
+docker compose run \
   --no-deps --rm dev \
   stack --stack-yaml stack.yml \
   haddock --force-dirty --no-haddock-deps --haddock-arguments --odir=local-docs

orville-postgresql/scripts/ghci.sh

@@ -1,6 +1,6 @@
 #!/bin/sh
 
-docker-compose run --rm dev \
+docker compose run --rm dev \
   stack --stack-yaml stack-lts-17.3.yml \
   ghci \
   orville-postgresql:lib \

orville-postgresql/scripts/psql.sh

@@ -1,3 +1,3 @@
 #!/bin/sh
 
-docker-compose exec testdb-pg12 psql -U orville_test
+docker compose exec testdb-pg12 psql -U orville_test

orville-postgresql/scripts/release.sh

@@ -2,8 +2,8 @@
 
 case "$1" in
   prepare-candidate)
-    docker-compose run --rm dev cabal sdist
-    docker-compose run --rm dev \
+    docker compose run --rm dev cabal sdist
+    docker compose run --rm dev \
       sh -c \
       'cabal update && \
          cabal \
@@ -20,7 +20,7 @@ case "$1" in
       echo "Please specify the version number to upload."
       exit 1
     else
-      docker-compose run --rm dev \
+      docker compose run --rm dev \
         sh -c \
         "cabal upload dist-newstyle/sdist/orville-postgresql-$version.tar.gz && \
          cabal upload -d dist-newstyle/docs/orville-postgresql-$version-docs.tar.gz"

orville-postgresql/scripts/test-all

@@ -10,7 +10,7 @@
 # development.
 #
 # You can run it via docker by running:
-#   docker-compose run --rm dev ./test-all
+#   docker compose run --rm dev ./test-all
 #
 
 rm -rf test-all-logs

orville-postgresql/scripts/test-loop

@@ -3,13 +3,13 @@
 set -e
 
 if [ $# != 1 ]; then
-  echo "Usage: docker-compose run --rm dev ./test-loop <stack-yaml>"
+  echo "Usage: docker compose run --rm dev ./test-loop <stack-yaml>"
   exit 1
 fi
 
 STACK_YAML="$1"
 
-echo "Starting test loop using $STACK_YAML. Use \`docker-compose run --rm dev ./test-loop <stack-yaml>\` to change the stack file used."
+echo "Starting test loop using $STACK_YAML. Use \`docker compose run --rm dev ./test-loop <stack-yaml>\` to change the stack file used."
 
 # This used to use ghcid, but I was not able to get ghcid to both run the test
 # suite *and* compile the sample project to detect errors there.  stack test

orville-postgresql/scripts/up.sh

@@ -2,11 +2,11 @@
 
 export STACK_YAML_FILE=$1
 
-# dev is specified here so that docker-compose up will only attached to the dev
+# dev is specified here so that docker compose up will only attached to the dev
 # container and not the db container. A number of the tests produce errors logs
 # in the database container which are expected for negative testing (e.g.
 # primary key violations, not null violations). These logs end up interspersed
 # throughout the test results, which is annoying. If you need to see the logs
-# for debugging, you can run `docker-compose logs testdb`, or just run
-# `docker-compose up` directly.
-docker-compose up dev
+# for debugging, you can run `docker compose logs testdb`, or just run
+# `docker compose up` directly.
+docker compose up dev

orville-postgresql/src/Orville/PostgreSQL.hs

@@ -101,6 +101,8 @@ module Orville.PostgreSQL
   , TableDefinition.addTableConstraints
   , TableDefinition.tableIndexes
   , TableDefinition.addTableIndexes
+  , TableDefinition.tableTriggers
+  , TableDefinition.addTableTriggers
   , TableDefinition.dropColumns
   , TableDefinition.columnsToDrop
   , TableDefinition.tableIdentifier
@@ -148,6 +150,11 @@ module Orville.PostgreSQL
   , IndexDefinition.AttributeBasedIndexMigrationKey (AttributeBasedIndexMigrationKey, indexKeyUniqueness, indexKeyColumns)
   , IndexDefinition.NamedIndexMigrationKey
   , IndexDefinition.indexMigrationKey
+  , TriggerDefinition.TriggerDefinition
+  , TriggerDefinition.beforeInsert
+  , TriggerDefinition.mkNamedTriggerDefinition
+  , TriggerDefinition.TriggerMigrationKey (NamedTriggerKey)
+  , TriggerDefinition.triggerMigrationKey
   , PrimaryKey.PrimaryKey
   , PrimaryKey.primaryKey
   , PrimaryKey.compositePrimaryKey
@@ -325,6 +332,20 @@ module Orville.PostgreSQL
   , SequenceIdentifier.sequenceIdSchemaNameString
   , SequenceIdentifier.sequenceIdToString
 
+    -- * Functions for defining and working PostgreSQL functions
+  , FunctionDefinition.FunctionDefinition
+  , FunctionDefinition.mkTriggerFunction
+  , FunctionDefinition.mkCreateFunctionExpr
+  , FunctionDefinition.functionIdentifier
+  , FunctionIdentifier.FunctionIdentifier
+  , FunctionIdentifier.unqualifiedNameToFunctionId
+  , FunctionIdentifier.functionIdUnqualifiedNameString
+  , FunctionIdentifier.functionIdQualifiedName
+  , FunctionIdentifier.setFunctionIdSchema
+  , FunctionIdentifier.functionIdSchemaNameString
+  , FunctionIdentifier.functionIdToString
+  , Expr.plpgsql
+
     -- * Numeric types
   , SqlType.integer
   , SqlType.serial
@@ -392,9 +413,12 @@ import qualified Orville.PostgreSQL.OrvilleState as OrvilleState
 import qualified Orville.PostgreSQL.Raw.Connection as Connection
 import qualified Orville.PostgreSQL.Raw.SqlCommenter as SqlCommenter
 import qualified Orville.PostgreSQL.Schema.ConstraintDefinition as ConstraintDefinition
+import qualified Orville.PostgreSQL.Schema.FunctionDefinition as FunctionDefinition
+import qualified Orville.PostgreSQL.Schema.FunctionIdentifier as FunctionIdentifier
 import qualified Orville.PostgreSQL.Schema.IndexDefinition as IndexDefinition
 import qualified Orville.PostgreSQL.Schema.PrimaryKey as PrimaryKey
 import qualified Orville.PostgreSQL.Schema.SequenceDefinition as SequenceDefinition
 import qualified Orville.PostgreSQL.Schema.SequenceIdentifier as SequenceIdentifier
 import qualified Orville.PostgreSQL.Schema.TableDefinition as TableDefinition
 import qualified Orville.PostgreSQL.Schema.TableIdentifier as TableIdentifier
+import qualified Orville.PostgreSQL.Schema.TriggerDefinition as TriggerDefinition

orville-postgresql/src/Orville/PostgreSQL/AutoMigration.hs

@@ -89,6 +89,21 @@ data SchemaItem where
     Orville.SequenceIdentifier ->
     SchemaItem
 
+  -- |
+  --    Constructs a 'SchemaItem' from a 'Orville.FunctionDefinition'.
+  -- @since 1.1.0.0
+  SchemaFunction ::
+    Orville.FunctionDefinition ->
+    SchemaItem
+
+  -- |
+  --    Constructs a 'SchemaItem' that will drop the specified table if it is
+  --    found in the database.
+  -- @since 1.1.0.0
+  SchemaDropFunction ::
+    Orville.FunctionIdentifier ->
+    SchemaItem
+
 {- |
   Returns a one-line string describing the 'SchemaItem', suitable for a human
   to identify it in a list of output.
@@ -109,6 +124,10 @@ schemaItemSummary item =
       "Sequence " <> Orville.sequenceIdToString (Orville.sequenceIdentifier sequenceDef)
     SchemaDropSequence sequenceId ->
       "Drop sequence " <> Orville.sequenceIdToString sequenceId
+    SchemaFunction functionDef ->
+      "Function " <> Orville.functionIdToString (Orville.functionIdentifier functionDef)
+    SchemaDropFunction functionId ->
+      "Drop function " <> Orville.functionIdToString functionId
 
 {- |
 A 'MigrationPlan' contains an ordered list of migration steps. Each one is a
@@ -198,6 +217,7 @@ isMigrationStepTransactional stepWithType =
     DropUniqueConstraints -> True
     DropIndexes -> True
     AddRemoveTablesAndColumns -> True
+    AddFunctions -> True
     AddIndexesTransactionally -> True
     AddUniqueConstraints -> True
     AddForeignKeys -> True
@@ -212,14 +232,18 @@ isMigrationStepTransactional stepWithType =
 @since 1.0.0.0
 -}
 data StepType
-  = DropForeignKeys
-  | DropUniqueConstraints
-  | DropIndexes
-  | AddRemoveTablesAndColumns
-  | AddIndexesTransactionally
-  | AddUniqueConstraints
-  | AddForeignKeys
-  | AddIndexesConcurrently
+  = DropForeignKeys -- @since 1.0.0.0
+  | DropUniqueConstraints -- @since 1.0.0.0
+  | DropIndexes -- @since 1.0.0.0
+  -- | DropTriggers -- @since 1.1.0.0
+  -- | DropFunctions -- @since 1.1.0.0
+  | AddRemoveTablesAndColumns -- @since 1.0.0.0
+  | AddFunctions -- @since 1.1.0.0
+  -- | AddTriggers -- @since 1.1.0.0
+  | AddIndexesTransactionally -- @since 1.0.0.0
+  | AddUniqueConstraints -- @since 1.0.0.0
+  | AddForeignKeys -- @since 1.0.0.0
+  | AddIndexesConcurrently -- @since 1.0.0.0
   deriving
     ( -- | @since 1.0.0.0
       Eq
@@ -346,9 +370,17 @@ generateMigrationPlanWithoutLock schemaItems =
     currentNamespace <- findCurrentNamespace
 
     let
-      pgCatalogRelations = fmap (schemaItemPgCatalogRelation currentNamespace) schemaItems
+      pgCatalogRelations =
+        Maybe.mapMaybe
+          (schemaItemPgCatalogRelation currentNamespace)
+           schemaItems
+
+      pgCatalogFunctions =
+        Maybe.mapMaybe
+          (schemaItemPgCatalogFunction currentNamespace)
+           schemaItems
 
-    dbDesc <- PgCatalog.describeDatabaseRelations pgCatalogRelations
+    dbDesc <- PgCatalog.describeDatabase pgCatalogRelations pgCatalogFunctions
 
     case traverse (calculateMigrationSteps currentNamespace dbDesc) schemaItems of
       Left err ->
@@ -483,6 +515,26 @@ calculateMigrationSteps currentNamespace dbDesc schemaItem =
                   (Expr.dropSequenceExpr Nothing (Orville.sequenceIdQualifiedName sequenceId))
               ]
 
+    SchemaFunction functionDef ->
+      Right $
+        let
+          (schemaName, procName) =
+            functionIdToPgCatalogNames currentNamespace (Orville.functionIdentifier functionDef)
+        in
+          case PgCatalog.lookupProcedure (schemaName, procName) dbDesc of
+            Nothing ->
+              [ mkMigrationStepWithType
+                 AddFunctions
+                 (Orville.mkCreateFunctionExpr functionDef)
+              ]
+
+            Just _proc ->
+              [
+              ]
+
+    SchemaDropFunction _functionDef ->
+      Right []
+
 {- |
   Builds 'MigrationStep's that will perform table creation. This function
   assumes the table does not exist. The migration step it produces will fail if
@@ -1079,20 +1131,53 @@ pgAttributeBasedIndexMigrationKey indexDesc = do
       , IndexDefinition.indexKeyColumns = fieldNames
       }
 
+{- |
+  Retrieves from a 'SchemaItem' the relation (if any) that the schema item relates to
+  so that the migration infrastructure can look up data about it in the PostgreSQL
+  catalog for planning migration steps.
+-}
 schemaItemPgCatalogRelation ::
   PgCatalog.NamespaceName ->
   SchemaItem ->
-  (PgCatalog.NamespaceName, PgCatalog.RelationName)
+  Maybe (PgCatalog.NamespaceName, PgCatalog.RelationName)
 schemaItemPgCatalogRelation currentNamespace item =
   case item of
     SchemaTable tableDef ->
-      tableIdToPgCatalogNames currentNamespace (Orville.tableIdentifier tableDef)
+      Just $ tableIdToPgCatalogNames currentNamespace (Orville.tableIdentifier tableDef)
     SchemaDropTable tableId ->
-      tableIdToPgCatalogNames currentNamespace tableId
+      Just $ tableIdToPgCatalogNames currentNamespace tableId
     SchemaSequence sequenceDef ->
-      sequenceIdToPgCatalogNames currentNamespace (Orville.sequenceIdentifier sequenceDef)
+      Just $ sequenceIdToPgCatalogNames currentNamespace (Orville.sequenceIdentifier sequenceDef)
     SchemaDropSequence sequenceId ->
-      sequenceIdToPgCatalogNames currentNamespace sequenceId
+      Just $ sequenceIdToPgCatalogNames currentNamespace sequenceId
+    SchemaFunction _functionDef ->
+      Nothing
+    SchemaDropFunction _functionId ->
+      Nothing
+
+{- |
+  Retrieves from a 'SchemaItem' the function (if any) that the schema item relates to
+  so that the migration infrastructure can look up data about it in the PostgreSQL
+  catalog for planning migration steps.
+-}
+schemaItemPgCatalogFunction ::
+  PgCatalog.NamespaceName ->
+  SchemaItem ->
+  Maybe (PgCatalog.NamespaceName, PgCatalog.ProcName)
+schemaItemPgCatalogFunction currentNamespace item =
+  case item of
+    SchemaTable _tableDef ->
+      Nothing
+    SchemaDropTable _tableId ->
+      Nothing
+    SchemaSequence _sequenceDef ->
+      Nothing
+    SchemaDropSequence _sequenceId ->
+      Nothing
+    SchemaFunction functionDef ->
+      Just $ functionIdToPgCatalogNames currentNamespace (Orville.functionIdentifier functionDef)
+    SchemaDropFunction functionId ->
+      Just $ functionIdToPgCatalogNames currentNamespace functionId
 
 tableIdToPgCatalogNames ::
   PgCatalog.NamespaceName ->
@@ -1112,6 +1197,24 @@ tableIdToPgCatalogNames currentNamespace tableId =
   in
     (actualNamespace, relationName)
 
+functionIdToPgCatalogNames ::
+  PgCatalog.NamespaceName ->
+  Orville.FunctionIdentifier ->
+  (PgCatalog.NamespaceName, PgCatalog.ProcName)
+functionIdToPgCatalogNames currentNamespace functionId =
+  let
+    actualNamespace =
+      maybe currentNamespace String.fromString
+        . Orville.functionIdSchemaNameString
+        $ functionId
+
+    relationName =
+      String.fromString
+        . Orville.functionIdUnqualifiedNameString
+        $ functionId
+  in
+    (actualNamespace, relationName)
+
 mkAlterSequenceSteps ::
   Orville.SequenceDefinition ->
   PgCatalog.PgSequence ->

orville-postgresql/src/Orville/PostgreSQL/Expr.hs

@@ -62,6 +62,7 @@ module Orville.PostgreSQL.Expr
   , module Orville.PostgreSQL.Expr.Update
   , module Orville.PostgreSQL.Expr.ValueExpression
   , module Orville.PostgreSQL.Expr.WhereClause
+  , module Orville.PostgreSQL.Expr.Trigger
   , module Orville.PostgreSQL.Expr.Vacuum
   )
 where
@@ -93,6 +94,7 @@ import Orville.PostgreSQL.Expr.TableDefinition
 import Orville.PostgreSQL.Expr.TableReferenceList
 import Orville.PostgreSQL.Expr.Time
 import Orville.PostgreSQL.Expr.Transaction
+import Orville.PostgreSQL.Expr.Trigger
 import Orville.PostgreSQL.Expr.Update
 import Orville.PostgreSQL.Expr.Vacuum
 import Orville.PostgreSQL.Expr.ValueExpression