orville-postgresql-1.1.0.0: src/Orville/PostgreSQL/AutoMigration.hs
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
{- |
Copyright : Flipstone Technology Partners 2023-2025
License : MIT
Stability : Stable
Facilities for performing some database migrations automatically.
See 'autoMigrateSchema' as a primary, high-level entry point.
@since 1.0.0.0
-}
module Orville.PostgreSQL.AutoMigration
( MigrationOptions (runSchemaChanges, runConcurrentIndexCreations, migrationLockOptions)
, defaultOptions
, autoMigrateSchema
, SchemaItem (..)
, schemaItemSummary
, MigrationPlan
, generateMigrationPlan
, migrationPlanSteps
, executeMigrationPlan
, MigrationStep
, MigrationDataError
, MigrationLock.MigrationLockOptions
, MigrationLock.defaultLockOptions
, MigrationLock.migrationLockId
, MigrationLock.maxLockAttempts
, MigrationLock.delayBetweenLockAttemptsMicros
, MigrationLock.lockDelayVariationMicros
, MigrationLock.MigrationLockId
, MigrationLock.defaultLockId
, MigrationLock.nextLockId
, MigrationLock.withMigrationLock
, MigrationLock.MigrationLockError
)
where
import Control.Exception.Safe (Exception, throwIO)
import Control.Monad (guard, when)
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (traverse_)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import qualified Data.Set as Set
import qualified Data.String as String
import qualified Data.Text as T
import qualified Data.Text.Encoding as Enc
import qualified Database.PostgreSQL.LibPQ as LibPQ
import qualified Orville.PostgreSQL as Orville
import qualified Orville.PostgreSQL.Expr as Expr
import qualified Orville.PostgreSQL.Internal.IndexDefinition as IndexDefinition
import qualified Orville.PostgreSQL.Internal.MigrationLock as MigrationLock
import qualified Orville.PostgreSQL.Marshall as Marshall
import qualified Orville.PostgreSQL.PgCatalog as PgCatalog
import qualified Orville.PostgreSQL.Raw.RawSql as RawSql
import qualified Orville.PostgreSQL.Schema as Schema
import qualified Orville.PostgreSQL.Schema.TableIdentifier as TableIdentifier
{- | A 'SchemaItem' represents a single item in a database schema such as a table,
index or constraint. The constructor functions below can be used to create
items from other types (such as 'Orville.TableDefinition') to put them into
a list to be used with 'autoMigrateSchema'.
@since 1.0.0.0
-}
data SchemaItem where
-- | Constructs a 'SchemaItem' from a 'Orville.TableDefinition'.
--
-- @since 1.0.0.0
SchemaTable ::
Orville.TableDefinition key writeEntity readEntity ->
SchemaItem
-- | Constructs a 'SchemaItem' that will drop the specified table if it is
-- found in the database.
--
-- @since 1.0.0.0
SchemaDropTable ::
Orville.TableIdentifier ->
SchemaItem
-- | Constructs a 'SchemaItem' from a 'Orville.SequenceDefinition'.
--
-- @since 1.0.0.0
SchemaSequence ::
Orville.SequenceDefinition ->
SchemaItem
-- | Constructs a 'SchemaItem' that will drop the specified table if it is
-- found in the database.
--
-- @since 1.0.0.0
SchemaDropSequence ::
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
-- | Constructs a 'SchemaItem' from a 'Orville.ExtensionName', that will load the extension.
--
-- @since 1.1.0.0
SchemaExtension ::
Orville.ExtensionIdentifier ->
SchemaItem
-- | Constructs a 'SchemaItem' that will unload the postgresql extension if it is found in the
-- database.
--
-- @since 1.1.0.0
SchemaDropExtension ::
Orville.ExtensionIdentifier ->
SchemaItem
{- | Returns a one-line string describing the 'SchemaItem', suitable for a human
to identify it in a list of output.
For example, a 'SchemaItem' constructed via 'SchemaTable' gives @Table <table
name>@.
@since 1.0.0.0
-}
schemaItemSummary :: SchemaItem -> String
schemaItemSummary item =
case item of
SchemaTable tableDef ->
"Table " <> Orville.tableIdToString (Orville.tableIdentifier tableDef)
SchemaDropTable tableId ->
"Drop table " <> Orville.tableIdToString tableId
SchemaSequence sequenceDef ->
"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
SchemaExtension extension ->
"Extension " <> Orville.extensionIdToString extension
SchemaDropExtension extension ->
"Drop Extension " <> Orville.extensionIdToString extension
{- |
A 'MigrationPlan' contains an ordered list of migration steps. Each one is a
single DDL statement to make a specific database change. The steps are ordered
such that dependencies from earlier steps will be in place before a later step
is executed (e.g. new columns are added before foreign keys referring to them).
While most steps are executed together in a single transaction this is not
possible for indexes being created concurrently. Any such steps are executed
last after the transaction for the rest of the schema changes has been
successfully committed.
@since 1.0.0.0
-}
data MigrationPlan = MigrationPlan
{ i_transactionalSteps :: [MigrationStep]
, i_concurrentIndexSteps :: [MigrationStep]
}
{- | Returns all the 'MigrationStep's found in a 'MigrationPlan' together in a
single list. This is useful if you merely want to examine the steps of a plan
rather than execute them. You should always use 'executeMigrationPlan' to
execute a migration plan to ensure that the transactional steps are done
within a transaction while the concurrent index steps are done afterward
outside of it.
@since 1.0.0.0
-}
migrationPlanSteps :: MigrationPlan -> [MigrationStep]
migrationPlanSteps plan =
i_transactionalSteps plan <> i_concurrentIndexSteps plan
mkMigrationPlan :: [MigrationStepWithType] -> MigrationPlan
mkMigrationPlan steps =
let
(transactionalSteps, concurrentIndexSteps) =
List.partition isMigrationStepTransactional
. List.sortOn migrationStepType
$ steps
in
MigrationPlan
{ i_transactionalSteps = fmap migrationStep transactionalSteps
, i_concurrentIndexSteps = fmap migrationStep concurrentIndexSteps
}
{- | A single SQL statement that will be executed in order to migrate the database
to the desired result. You can use 'generateMigrationPlan' to get a list
of these yourself for inspection and debugging.
@since 1.0.0.0
-}
newtype MigrationStep
= MigrationStep RawSql.RawSql
deriving
( -- | @since 1.0.0.0
RawSql.SqlExpression
)
{- | This type is used internally by Orville to order the migration steps after
they have been created. It is not exposed outside this module.
@since 1.0.0.0
-}
data MigrationStepWithType = MigrationStepWithType
{ migrationStepType :: StepType
, migrationStep :: MigrationStep
}
mkMigrationStepWithType ::
RawSql.SqlExpression sql =>
StepType ->
sql ->
MigrationStepWithType
mkMigrationStepWithType stepType sql =
MigrationStepWithType
{ migrationStepType = stepType
, migrationStep = MigrationStep (RawSql.toRawSql sql)
}
isMigrationStepTransactional :: MigrationStepWithType -> Bool
isMigrationStepTransactional stepWithType =
case migrationStepType stepWithType of
DropForeignKeys -> True
DropUniqueConstraints -> True
DropIndexes -> True
DropTriggers -> True
DropFunctions -> True
DropExtensions -> True
AddExtensions -> True
AddRemoveTablesAndColumns -> True
AddFunctions -> True
AddTriggers -> True
AddIndexesTransactionally -> True
AddUniqueConstraints -> True
AddForeignKeys -> True
AddIndexesConcurrently -> False
SetComments -> True
{- | Indicates the kind of operation being performed by a 'MigrationStep' so
that the steps can be ordered in a sequence that is guaranteed to succeed.
The order of the constructors below indicates the order in which steps will
be run.
@since 1.0.0.0
-}
data StepType
= -- | @since 1.0.0.0
DropForeignKeys
| -- | @since 1.0.0.0
DropUniqueConstraints
| -- | @since 1.0.0.0
DropIndexes
| -- | @since 1.1.0.0
DropTriggers
| -- | @since 1.1.0.0
DropFunctions
| -- | @since 1.1.0.0
DropExtensions
| -- | @since 1.1.0.0
AddExtensions
| -- | @since 1.0.0.0
AddRemoveTablesAndColumns
| -- | @since 1.1.0.0
AddFunctions
| -- | @since 1.1.0.0
AddTriggers
| -- | @since 1.0.0.0
AddIndexesTransactionally
| -- | @since 1.0.0.0
AddUniqueConstraints
| -- | @since 1.0.0.0
AddForeignKeys
| -- | @since 1.0.0.0
AddIndexesConcurrently
| -- | @since 1.1.0.0
SetComments
deriving
( -- | @since 1.0.0.0
Eq
, -- | @since 1.0.0.0
Ord
)
{- | A 'MigrationDataError' will be thrown from the migration functions if data
necessary for migration cannot be found.
@since 1.0.0.0
-}
data MigrationDataError
= UnableToDiscoverCurrentSchema String
| PgCatalogInvariantViolated String
deriving
( -- | @since 1.0.0.0
Show
)
-- | @since 1.0.0.0
instance Exception MigrationDataError
{- |
Options to control how 'autoMigrateSchema' and similar functions behave. You
should use 'defaultOptions' to construct a 'MigrationOptions' value
and then use the record accessors to change any values you want to customize.
@since 1.0.0.0
-}
data MigrationOptions = MigrationOptions
{ runSchemaChanges :: Bool
-- ^
-- Indicates whether the normal schema changes (other than concurrent index
-- creations) should be run. The default value is 'True'. You may want to
-- disable this if you wish to run concurrent index creations separately
-- from the rest of the schema changes.
--
-- @since 1.0.0.0
, runConcurrentIndexCreations :: Bool
-- ^
-- Indicates whether indexes with the 'Orville.Concurrent' creation strategy
-- will be created. The default value is 'True'. You may want to disable
-- this if you wish to run concurrent index creations separately from the
-- rest of the schema changes.
--
-- @since 1.0.0.0
, migrationLockOptions :: MigrationLock.MigrationLockOptions
-- ^
-- The 'MigrationLock.MigrationLockOptions' that will be used to ensure only
-- one application is running migrations at a time. The default value
-- is 'MigrationLock.defaultLockOptions'. You may want to change these if you
-- your application has special migration needs. For instance, you might specify
-- a custom lock id along with migrating just concurrent indexes to allow them
-- to run separately from the rest of the schema changes without blocking one
-- another.
--
-- @since 1.1.0.0
}
{- |
The default 'MigrationOptions', which is to run both the schema changes and
concurrent index creations together using the default Orville migration lock.
@since 1.0.0.0
-}
defaultOptions :: MigrationOptions
defaultOptions =
MigrationOptions
{ runSchemaChanges = True
, runConcurrentIndexCreations = True
, migrationLockOptions = MigrationLock.defaultLockOptions
}
{- | This function compares the list of 'SchemaItem's provided against the current
schema found in the database to determine whether any migrations are
necessary. If any changes need to be made, this function executes. You can
call 'generateMigrationPlan' and 'executeMigrationPlan' yourself if you want
to have more control over the process, but must then take care to ensure that
the schema has not changed between the two calls. This function uses a
PostgreSQL advisory lock to ensure that no other calls to 'autoMigrateSchema'
(potentially on other processes) attempt to modify the schema at the same
time.
@since 1.0.0.0
-}
autoMigrateSchema ::
Orville.MonadOrville m =>
MigrationOptions ->
[SchemaItem] ->
m ()
autoMigrateSchema options schemaItems =
MigrationLock.withMigrationLock (migrationLockOptions options) $ do
plan <- generateMigrationPlanWithoutLock schemaItems
executeMigrationPlanWithoutLock options plan
{- | Compares the list of 'SchemaItem's provided against the current schema found
in the database and returns a 'MigrationPlan' that could be executed to make
the database schema match the items given.
You can execute the 'MigrationPlan' yourself using the 'executeMigrationPlan'
convenience function, though 'autoMigrateSchema' is usually a better option
because it uses a database lock to ensure that no other processes are also
using 'autoMigrateSchema' to apply migrations at the same time. If you use
'generateMigrationPlan' and 'executeMigrationPlan' separately, you are
responsible for ensuring that the schema has not changed between the time the
plan is generated and executed yourself.
@since 1.0.0.0
-}
generateMigrationPlan ::
Orville.MonadOrville m =>
MigrationOptions ->
[SchemaItem] ->
m MigrationPlan
generateMigrationPlan options =
MigrationLock.withMigrationLock (migrationLockOptions options)
. generateMigrationPlanWithoutLock
generateMigrationPlanWithoutLock :: Orville.MonadOrville m => [SchemaItem] -> m MigrationPlan
generateMigrationPlanWithoutLock schemaItems =
Orville.withTransaction $ do
currentNamespace <- findCurrentNamespace
let
pgCatalogRelations =
Maybe.mapMaybe
(schemaItemPgCatalogRelation currentNamespace)
schemaItems
pgCatalogFunctions =
Maybe.mapMaybe
(schemaItemPgCatalogFunction currentNamespace)
schemaItems
pgCatalogExtensions =
Maybe.mapMaybe schemaItemPgCatalogExtension schemaItems
dbDesc <- PgCatalog.describeDatabase pgCatalogRelations pgCatalogFunctions pgCatalogExtensions
case traverse (calculateMigrationSteps currentNamespace dbDesc) schemaItems of
Left err ->
liftIO . throwIO $ err
Right migrationSteps ->
pure . mkMigrationPlan . concat $ migrationSteps
{- | Executes a 'MigrationPlan' that has been previously devised via
'generateMigrationPlan'. Normally all the steps in a migration plan are
executed in a transaction so that they will all be applied together
successfully or all rolled-back if one of them fails. Any indexes using the
'Orville.Concurrent' creation strategy cannot be created this way, however,
because PostgreSQL does not allow @CREATE INDEX CONCURRENTLY@ to be used from
inside a transaction. If a 'MigrationPlan' includes any indexes whose
creation strategy is set to 'Orville.Concurrent', Orville will create indexes
after the rest of the migration steps have been committed successfully. This
function will wait until all of the migration steps that it runs to finish
before returning. If one of the concurrent indexes fails during creation, it
will be left in an invalid state (as is the default PostgreSQL behavior). You
should check on the status of indexes created this way manually to ensure
they were created successfully. If they could not be, you can drop them and
Orville will re-attempt creating them the next time migration is performed.
@since 1.0.0.0
-}
executeMigrationPlan ::
Orville.MonadOrville m =>
MigrationOptions ->
MigrationPlan ->
m ()
executeMigrationPlan options =
MigrationLock.withMigrationLock (migrationLockOptions options)
. executeMigrationPlanWithoutLock options
executeMigrationPlanWithoutLock ::
Orville.MonadOrville m =>
MigrationOptions ->
MigrationPlan ->
m ()
executeMigrationPlanWithoutLock options plan = do
when (runSchemaChanges options)
. Orville.withTransaction
. executeMigrationStepsWithoutTransaction
. i_transactionalSteps
$ plan
when (runConcurrentIndexCreations options)
. executeMigrationStepsWithoutTransaction
$ i_concurrentIndexSteps plan
executeMigrationStepsWithoutTransaction :: Orville.MonadOrville m => [MigrationStep] -> m ()
executeMigrationStepsWithoutTransaction =
traverse_ (Orville.executeVoid Orville.DDLQuery)
calculateMigrationSteps ::
PgCatalog.NamespaceName ->
PgCatalog.DatabaseDescription ->
SchemaItem ->
Either MigrationDataError [MigrationStepWithType]
calculateMigrationSteps currentNamespace dbDesc schemaItem =
case schemaItem of
SchemaTable tableDef ->
Right $
let
(schemaName, tableName) =
tableIdToPgCatalogNames
currentNamespace
(Orville.tableIdentifier tableDef)
in
case PgCatalog.lookupRelationOfKind PgCatalog.OrdinaryTable (schemaName, tableName) dbDesc of
Nothing ->
mkCreateTableSteps currentNamespace tableDef
Just relationDesc ->
mkAlterTableSteps currentNamespace relationDesc tableDef
SchemaDropTable tableId ->
Right $
let
(schemaName, tableName) =
tableIdToPgCatalogNames currentNamespace tableId
in
case PgCatalog.lookupRelation (schemaName, tableName) dbDesc of
Nothing ->
[]
Just _ ->
let
dropTableExpr =
Expr.dropTableExpr
Nothing
(Orville.tableIdQualifiedName tableId)
in
[mkMigrationStepWithType AddRemoveTablesAndColumns dropTableExpr]
SchemaSequence sequenceDef ->
let
(schemaName, sequenceName) =
sequenceIdToPgCatalogNames
currentNamespace
(Orville.sequenceIdentifier sequenceDef)
in
case PgCatalog.lookupRelationOfKind PgCatalog.Sequence (schemaName, sequenceName) dbDesc of
Nothing ->
Right
[ mkMigrationStepWithType
AddRemoveTablesAndColumns
(Orville.mkCreateSequenceExpr sequenceDef)
]
Just relationDesc ->
case PgCatalog.relationSequence relationDesc of
Nothing ->
Left . PgCatalogInvariantViolated $
"Sequence "
<> PgCatalog.namespaceNameToString schemaName
<> "."
<> PgCatalog.relationNameToString sequenceName
<> " was found in the 'pg_class' table but no corresponding 'pg_sequence' row was found"
Just pgSequence ->
Right $
mkAlterSequenceSteps sequenceDef pgSequence
SchemaDropSequence sequenceId ->
Right $
let
(schemaName, sequenceName) =
sequenceIdToPgCatalogNames currentNamespace sequenceId
in
case PgCatalog.lookupRelationOfKind PgCatalog.Sequence (schemaName, sequenceName) dbDesc of
Nothing ->
[]
Just _ ->
[ mkMigrationStepWithType
AddRemoveTablesAndColumns
(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 Nothing)
]
Just pgProc ->
if PgCatalog.pgProcSource pgProc == T.pack (Orville.functionSource functionDef)
then []
else
[ mkMigrationStepWithType
AddFunctions
(Orville.mkCreateFunctionExpr functionDef (Just Expr.orReplace))
]
SchemaDropFunction functionId ->
Right $
let
(schemaName, procName) =
functionIdToPgCatalogNames currentNamespace functionId
in
case PgCatalog.lookupProcedure (schemaName, procName) dbDesc of
Nothing ->
[]
Just _proc ->
[ mkMigrationStepWithType
DropFunctions
(Expr.dropFunction Nothing (Orville.functionIdQualifiedName functionId))
]
SchemaExtension extension ->
Right $
let
catalogExtensionName = extensionIdToPgCatalogName extension
in
case PgCatalog.lookupExtension catalogExtensionName dbDesc of
Nothing ->
[ mkMigrationStepWithType
AddExtensions
(Expr.createExtensionExpr (Orville.extensionIdName extension) Nothing (Just Expr.extensionCascadeExpr))
]
Just _pgExtension ->
[]
SchemaDropExtension extension ->
Right $
let
catalogExtensionName = extensionIdToPgCatalogName extension
in
case PgCatalog.lookupExtension catalogExtensionName dbDesc of
Nothing ->
[]
Just _pgExtension ->
[ mkMigrationStepWithType
DropExtensions
(Expr.dropExtensionExpr (Orville.extensionIdName extension) Nothing Nothing)
]
{- | Builds 'MigrationStep's that will perform table creation. This function
assumes the table does not exist. The migration step it produces will fail if
the table already exists in its schema. Multiple steps may be required to
create the table if foreign keys exist to that reference other tables, which
may not have been created yet.
@since 1.0.0.0
-}
mkCreateTableSteps ::
PgCatalog.NamespaceName ->
Orville.TableDefinition key writeEntity readEntity ->
[MigrationStepWithType]
mkCreateTableSteps currentNamespace tableDef =
let
tableName =
Orville.tableName tableDef
-- constraints are not included in the create table expression because
-- they are added in a separate migration step to avoid ordering problems
-- when creating multiple tables with interrelated foreign keys.
createTableExpr =
Expr.createTableExpr
tableName
(Orville.mkTableColumnDefinitions tableDef)
(Orville.mkTablePrimaryKeyExpr tableDef)
[]
commentSteps = mkCreateTableCommentSteps tableDef
addConstraintActions =
concatMap
(mkAddConstraintActions currentNamespace Set.empty)
(Schema.tableConstraintDefinitions $ Orville.tableConstraints tableDef)
addIndexSteps =
concatMap
(mkAddIndexSteps Set.empty tableName)
(Orville.tableIndexes tableDef)
addTriggerSteps =
concatMap
(mkAddTriggerSteps Set.empty tableName)
(Orville.tableTriggers tableDef)
in
mkMigrationStepWithType AddRemoveTablesAndColumns createTableExpr
: mkConstraintSteps tableName addConstraintActions
<> addIndexSteps
<> addTriggerSteps
<> commentSteps
mkCreateTableCommentSteps ::
Orville.TableDefinition key writeEntity readEntity ->
[MigrationStepWithType]
mkCreateTableCommentSteps tableDef =
let
mbCommentTableStep =
fmap
( mkMigrationStepWithType SetComments
. Expr.commentTableExpr (Schema.tableName tableDef)
. Just
. Expr.commentText
)
(Schema.tableComment tableDef)
tableId = Orville.tableIdentifier tableDef
mbCommentColumnStep colName =
fmap
( mkMigrationStepWithType SetComments
. Expr.commentColumnExpr
(Schema.tableIdSchemaName tableId)
(Schema.tableIdUnqualifiedName tableId)
colName
. Just
. Expr.commentText
. T.pack
)
mbCommentColumnsSteps =
Orville.foldMarshallerFields
(Orville.unannotatedSqlMarshaller $ Schema.tableMarshaller tableDef)
[]
( Orville.collectFromField
Orville.IncludeReadOnlyColumns
( const $ \fieldDef ->
mbCommentColumnStep
(Orville.fieldNameToColumnName $ Orville.fieldName fieldDef)
(Orville.fieldDescription fieldDef)
)
)
in
Maybe.catMaybes (mbCommentTableStep : mbCommentColumnsSteps)
{- | Builds migration steps that are required to create or alter the table's
schema to make it match the given table definition.
This function uses the given relation description to determine what
alterations need to be performed. If there is nothing to do, an empty list
will be returned.
@since 1.0.0.0
-}
mkAlterTableSteps ::
PgCatalog.NamespaceName ->
PgCatalog.RelationDescription ->
Orville.TableDefinition key writeEntity readEntity ->
[MigrationStepWithType]
mkAlterTableSteps currentNamespace relationDesc tableDef =
let
addAlterColumnActions =
concat $
Orville.foldMarshallerFields
(Orville.unannotatedSqlMarshaller $ Orville.tableMarshaller tableDef)
[]
(Orville.collectFromField Orville.IncludeReadOnlyColumns (const (mkAddAlterColumnActions relationDesc)))
dropColumnActions =
concatMap
(mkDropColumnActions tableDef)
(PgCatalog.relationAttributes relationDesc)
existingConstraints =
Set.fromList
. Maybe.mapMaybe pgConstraintMigrationKey
. PgCatalog.relationConstraints
$ relationDesc
constraintsToKeep =
Set.map (setDefaultSchemaNameOnConstraintKey currentNamespace)
. Schema.tableConstraintKeys
. Orville.tableConstraints
$ tableDef
addConstraintActions =
concatMap
(mkAddConstraintActions currentNamespace existingConstraints)
(Schema.tableConstraintDefinitions $ Orville.tableConstraints tableDef)
dropConstraintActions =
concatMap
(mkDropConstraintActions constraintsToKeep)
(PgCatalog.relationConstraints relationDesc)
systemIndexOids =
Set.fromList
. Maybe.mapMaybe (pgConstraintImpliedIndexOid . PgCatalog.constraintRecord)
. PgCatalog.relationConstraints
$ relationDesc
isSystemIndex indexDesc =
Set.member
(PgCatalog.pgIndexPgClassOid $ PgCatalog.indexRecord indexDesc)
systemIndexOids
existingIndexes =
Set.fromList
. concatMap pgIndexMigrationKeys
. filter (not . isSystemIndex)
. PgCatalog.relationIndexes
$ relationDesc
indexesToKeep =
Map.keysSet
. Orville.tableIndexes
$ tableDef
addIndexSteps =
concatMap
(mkAddIndexSteps existingIndexes tableName)
(Orville.tableIndexes tableDef)
dropIndexSteps =
concatMap
(mkDropIndexSteps indexesToKeep systemIndexOids . TableIdentifier.tableIdSchemaName $ Orville.tableIdentifier tableDef)
(PgCatalog.relationIndexes relationDesc)
existingTriggers =
Set.fromList
. fmap pgTriggerMigrationKey
. PgCatalog.relationTriggers
$ relationDesc
triggersToKeep =
Map.keysSet
. Orville.tableTriggers
$ tableDef
addTriggerSteps =
concatMap
(mkAddTriggerSteps existingTriggers tableName)
(Orville.tableTriggers tableDef)
dropTriggerSteps =
concatMap
(mkDropTriggerSteps triggersToKeep tableName)
(PgCatalog.relationTriggers relationDesc)
commentSteps = mkCommentSteps relationDesc tableDef
tableName =
Orville.tableName tableDef
in
mkAlterColumnSteps tableName (addAlterColumnActions <> dropColumnActions)
<> mkConstraintSteps tableName (addConstraintActions <> dropConstraintActions)
<> addIndexSteps
<> dropIndexSteps
<> addTriggerSteps
<> dropTriggerSteps
<> commentSteps
{- | Consolidates alter table actions (which should all be related to adding and
dropping constraints) into migration steps based on their 'StepType'. Actions
with the same 'StepType' will be performed togethir in a single @ALTER TABLE@
statement.
@since 1.0.0.0
-}
mkConstraintSteps ::
Expr.QualifiedOrUnqualified Expr.TableName ->
[(StepType, Expr.AlterTableAction)] ->
[MigrationStepWithType]
mkConstraintSteps tableName actions =
let
mkMapEntry ::
(StepType, Expr.AlterTableAction) ->
(StepType, NonEmpty Expr.AlterTableAction)
mkMapEntry (keyType, action) =
(keyType, action :| [])
addStep stepType actionExprs steps =
mkMigrationStepWithType stepType (Expr.alterTableExpr tableName actionExprs) : steps
in
Map.foldrWithKey addStep []
. Map.fromListWith (<>)
. fmap mkMapEntry
$ actions
{- | If there are any alter table actions for adding or removing columns, creates a migration
step to perform them. Otherwise returns an empty list.
@since 1.0.0.0
-}
mkAlterColumnSteps ::
Expr.QualifiedOrUnqualified Expr.TableName ->
[Expr.AlterTableAction] ->
[MigrationStepWithType]
mkAlterColumnSteps tableName actionExprs =
case nonEmpty actionExprs of
Nothing ->
[]
Just nonEmptyActionExprs ->
[mkMigrationStepWithType AddRemoveTablesAndColumns (Expr.alterTableExpr tableName nonEmptyActionExprs)]
{- | Builds 'Expr.AlterTableAction' expressions to bring the database schema in
line with the given 'Orville.FieldDefinition', or none if no change is
required.
@since 1.0.0.0
-}
mkAddAlterColumnActions ::
PgCatalog.RelationDescription ->
Orville.FieldDefinition nullability a ->
[Expr.AlterTableAction]
mkAddAlterColumnActions relationDesc fieldDef =
let
pgAttributeName =
String.fromString (Orville.fieldNameToString $ Orville.fieldName fieldDef)
in
case PgCatalog.lookupAttribute pgAttributeName relationDesc of
Just attr
| PgCatalog.isOrdinaryColumn attr ->
let
sqlType =
Orville.fieldType fieldDef
typeIsChanged =
(Orville.sqlTypeOid sqlType /= PgCatalog.pgAttributeTypeOid attr)
|| (Orville.sqlTypeMaximumLength sqlType /= PgCatalog.pgAttributeMaxLength attr)
columnName =
Orville.fieldNameToColumnName $ Orville.fieldName fieldDef
dataType =
Orville.sqlTypeExpr sqlType
alterType = do
guard typeIsChanged
[Expr.alterColumnType columnName dataType (Just $ Expr.usingCast columnName dataType)]
nullabilityIsChanged =
Orville.fieldIsNotNullable fieldDef /= PgCatalog.pgAttributeIsNotNull attr
nullabilityAction =
if Orville.fieldIsNotNullable fieldDef
then Expr.setNotNull
else Expr.dropNotNull
alterNullability = do
guard nullabilityIsChanged
[Expr.alterColumnNullability columnName nullabilityAction]
maybeExistingDefault =
PgCatalog.lookupAttributeDefault attr relationDesc
maybeDefaultExpr =
Orville.defaultValueExpression
<$> Orville.fieldDefaultValue fieldDef
(dropDefault, setDefault) =
case (maybeExistingDefault, maybeDefaultExpr) of
(Nothing, Nothing) ->
(Nothing, Nothing)
(Just _, Nothing) ->
if Orville.sqlTypeDontDropImplicitDefaultDuringMigrate sqlType
then (Nothing, Nothing)
else
( Just (Expr.alterColumnDropDefault columnName)
, Nothing
)
(Nothing, Just newDefault) ->
( Nothing
, Just (Expr.alterColumnSetDefault columnName newDefault)
)
(Just oldDefault, Just newDefault) ->
let
oldDefaultExprBytes =
Enc.encodeUtf8
. PgCatalog.pgAttributeDefaultExpression
$ oldDefault
newDefaultExprBytes =
RawSql.toExampleBytes newDefault
in
if oldDefaultExprBytes == newDefaultExprBytes
then (Nothing, Nothing)
else
( Just (Expr.alterColumnDropDefault columnName)
, Just (Expr.alterColumnSetDefault columnName newDefault)
)
alterIdentity =
case (Marshall.fieldIdentityGeneration fieldDef, PgCatalog.pgAttributeIdentity attr) of
(Nothing, Nothing) -> mempty
(Just Marshall.GeneratedAlways, Just Marshall.GeneratedAlways) -> mempty
(Just Marshall.GeneratedByDefault, Just Marshall.GeneratedByDefault) -> mempty
(Nothing, Just _) ->
pure $ Expr.alterColumnDropIdentity columnName Nothing
(Just Marshall.GeneratedAlways, Nothing) ->
pure $ Expr.alterColumnAddIdentity columnName Expr.alwaysColumnIdentityGeneration
(Just Marshall.GeneratedAlways, Just _existing) ->
[Expr.alterColumnDropIdentity columnName Nothing, Expr.alterColumnAddIdentity columnName Expr.alwaysColumnIdentityGeneration]
(Just Marshall.GeneratedByDefault, Nothing) ->
pure $ Expr.alterColumnAddIdentity columnName Expr.byDefaultColumnIdentityGeneration
(Just Marshall.GeneratedByDefault, Just _existing) ->
[Expr.alterColumnDropIdentity columnName Nothing, Expr.alterColumnAddIdentity columnName Expr.byDefaultColumnIdentityGeneration]
in
Maybe.maybeToList dropDefault
<> alterType
<> Maybe.maybeToList setDefault
<> alterNullability
<> alterIdentity
_ ->
-- Either the column doesn't exist in the table _OR_ it's a system
-- column. If it's a system column, attempting to add it will result
-- in an error that will be reported to the user. We could explicitly
-- return an error from this function, but that would make the error
-- reporting inconsistent with the handling in create table, where we
-- must rely on the database to raise the error because the table
-- does not yet exist for us to discover a conflict with system
-- attributes.
[Expr.addColumn (Orville.fieldColumnDefinition fieldDef)]
{- | Builds 'Expr.AlterTableAction' expressions for the given attribute to make
the database schema match the given 'Orville.TableDefinition'. This function
is only responsible for handling cases where the attribute does not have a
correspending 'Orville.FieldDefinition'. See 'mkAlterTableSteps' for those
cases.
@since 1.0.0.0
-}
mkDropColumnActions ::
Orville.TableDefinition key readEntity writeEntity ->
PgCatalog.PgAttribute ->
[Expr.AlterTableAction]
mkDropColumnActions tableDef attr = do
let
attrName =
PgCatalog.attributeNameToString $ PgCatalog.pgAttributeName attr
guard $ Set.member attrName (Orville.columnsToDrop tableDef)
[Expr.dropColumn $ Expr.columnName attrName]
{- | Sets the schema name on a constraint to the given namespace when the
constraint has no namespace explicitly given. This is important for Orville
to discover whether a constraint from a table definition matches a constraint
found to already exist in the database because constraints in the database
always have schema names included with them.
@since 1.0.0.0
-}
setDefaultSchemaNameOnConstraintKey ::
PgCatalog.NamespaceName ->
Orville.ConstraintMigrationKey ->
Orville.ConstraintMigrationKey
setDefaultSchemaNameOnConstraintKey currentNamespace constraintKey =
case Orville.constraintKeyForeignTable constraintKey of
Nothing ->
constraintKey
Just foreignTable ->
case Orville.tableIdSchemaNameString foreignTable of
Nothing ->
constraintKey
{ Orville.constraintKeyForeignTable =
Just $
Orville.setTableIdSchema
(PgCatalog.namespaceNameToString currentNamespace)
foreignTable
}
Just _ ->
constraintKey
{- | Builds 'Expr.AlterTableAction' expressions to create the given table
constraint if it does not exist.
@since 1.0.0.0
-}
mkAddConstraintActions ::
PgCatalog.NamespaceName ->
Set.Set Orville.ConstraintMigrationKey ->
Orville.ConstraintDefinition ->
[(StepType, Expr.AlterTableAction)]
mkAddConstraintActions currentNamespace existingConstraints constraintDef =
let
constraintKey =
setDefaultSchemaNameOnConstraintKey currentNamespace $
Orville.constraintMigrationKey constraintDef
stepType =
case Orville.constraintKeyType constraintKey of
Orville.UniqueConstraint -> AddUniqueConstraints
Orville.ForeignKeyConstraint -> AddForeignKeys
in
if Set.member constraintKey existingConstraints
then []
else [(stepType, Expr.addConstraint (Orville.constraintSqlExpr constraintDef))]
{- | Builds 'Expr.AlterTableAction' expressions to drop the given table
constraint if it should not exist.
@since 1.0.0.0
-}
mkDropConstraintActions ::
Set.Set Orville.ConstraintMigrationKey ->
PgCatalog.ConstraintDescription ->
[(StepType, Expr.AlterTableAction)]
mkDropConstraintActions constraintsToKeep constraint =
case pgConstraintMigrationKey constraint of
Nothing ->
[]
Just constraintKey ->
if Set.member constraintKey constraintsToKeep
then []
else
let
constraintName =
Expr.constraintName
. PgCatalog.constraintNameToString
. PgCatalog.pgConstraintName
. PgCatalog.constraintRecord
$ constraint
stepType =
case Orville.constraintKeyType constraintKey of
Orville.UniqueConstraint -> DropUniqueConstraints
Orville.ForeignKeyConstraint -> DropForeignKeys
in
[(stepType, Expr.dropConstraint constraintName)]
{- | Builds the orville migration key for a description of an existing constraint
so that it can be compared with constraints found in a table definition.
Constraint keys built this way always have a schema name populated, so it's
important to set the schema names for the constraints found in the table
definition before comparing them. See 'setDefaultSchemaNameOnConstraintKey'.
If the description is for a kind of constraint that Orville does not support,
'Nothing' is returned.
@since 1.0.0.0
-}
pgConstraintMigrationKey ::
PgCatalog.ConstraintDescription ->
Maybe Orville.ConstraintMigrationKey
pgConstraintMigrationKey constraintDesc =
let
toOrvilleConstraintKeyType pgConType =
case pgConType of
PgCatalog.UniqueConstraint -> Just Orville.UniqueConstraint
PgCatalog.ForeignKeyConstraint -> Just Orville.ForeignKeyConstraint
_ -> Nothing
constraint =
PgCatalog.constraintRecord constraintDesc
pgAttributeNamesToFieldNames :: [PgCatalog.PgAttribute] -> [Orville.FieldName]
pgAttributeNamesToFieldNames =
fmap (Orville.stringToFieldName . PgCatalog.attributeNameToString . PgCatalog.pgAttributeName)
foreignRelationTableId :: PgCatalog.ForeignRelationDescription -> Orville.TableIdentifier
foreignRelationTableId foreignRelationDesc =
let
relationName =
PgCatalog.relationNameToString
. PgCatalog.pgClassRelationName
. PgCatalog.foreignRelationClass
$ foreignRelationDesc
namespaceName =
PgCatalog.namespaceNameToString
. PgCatalog.pgNamespaceName
. PgCatalog.foreignRelationNamespace
$ foreignRelationDesc
in
Orville.setTableIdSchema namespaceName $
Orville.unqualifiedNameToTableId relationName
in
do
keyType <- toOrvilleConstraintKeyType (PgCatalog.pgConstraintType constraint)
pure $
Orville.ConstraintMigrationKey
{ Orville.constraintKeyType = keyType
, Orville.constraintKeyColumns =
fmap
pgAttributeNamesToFieldNames
(PgCatalog.constraintKey constraintDesc)
, Orville.constraintKeyForeignTable =
fmap foreignRelationTableId (PgCatalog.constraintForeignRelation constraintDesc)
, Orville.constraintKeyForeignColumns =
fmap
pgAttributeNamesToFieldNames
(PgCatalog.constraintForeignKey constraintDesc)
, Orville.constraintKeyForeignKeyOnUpdateAction =
PgCatalog.pgConstraintForeignKeyOnUpdateType $ PgCatalog.constraintRecord constraintDesc
, Orville.constraintKeyForeignKeyOnDeleteAction =
PgCatalog.pgConstraintForeignKeyOnDeleteType $ PgCatalog.constraintRecord constraintDesc
}
{- | Builds migration steps to create an index if it does not exist.
@since 1.0.0.0
-}
mkAddIndexSteps ::
Set.Set IndexDefinition.IndexMigrationKey ->
Expr.QualifiedOrUnqualified Expr.TableName ->
Orville.IndexDefinition ->
[MigrationStepWithType]
mkAddIndexSteps existingIndexes tableName indexDef =
let
indexKey =
IndexDefinition.indexMigrationKey indexDef
indexStep =
case Orville.indexCreationStrategy indexDef of
Orville.Transactional -> AddIndexesTransactionally
Orville.Concurrent -> AddIndexesConcurrently
in
if Set.member indexKey existingIndexes
then []
else [mkMigrationStepWithType indexStep (Orville.indexCreateExpr indexDef tableName)]
{- | Builds migration steps to drop an index if it should not exist.
@since 1.0.0.0
-}
mkDropIndexSteps ::
Set.Set IndexDefinition.IndexMigrationKey ->
Set.Set LibPQ.Oid ->
Maybe Expr.SchemaName ->
PgCatalog.IndexDescription ->
[MigrationStepWithType]
mkDropIndexSteps indexesToKeep systemIndexOids mSchema indexDesc =
case pgIndexMigrationKeys indexDesc of
[] ->
[]
indexKeys ->
let
pgClass =
PgCatalog.indexPgClass indexDesc
indexName =
Expr.indexName
. PgCatalog.relationNameToString
. PgCatalog.pgClassRelationName
$ pgClass
qualifiedIndexName = case mSchema of
Just schema -> Expr.untrackQualified $ Expr.qualifyIndex schema indexName
Nothing -> Expr.unqualified indexName
indexOid =
PgCatalog.pgClassOid pgClass
in
if any (flip Set.member indexesToKeep) indexKeys
|| Set.member indexOid systemIndexOids
then []
else [mkMigrationStepWithType DropIndexes (Expr.dropIndexExpr qualifiedIndexName)]
{- | Builds migration steps to create a trigger if it does not exist.
@since 1.1.0.0
-}
mkAddTriggerSteps ::
Set.Set Schema.TriggerMigrationKey ->
Expr.QualifiedOrUnqualified Expr.TableName ->
Orville.TriggerDefinition ->
[MigrationStepWithType]
mkAddTriggerSteps existingTriggers tableName triggerDef =
let
triggerKey =
Schema.triggerMigrationKey triggerDef
in
if Set.member triggerKey existingTriggers
then []
else [mkMigrationStepWithType AddTriggers (Orville.mkCreateTriggerExpr triggerDef Nothing tableName)]
{- | Builds migration steps to drop an trigger if it should not exist.
@since 1.1.0.0
-}
mkDropTriggerSteps ::
Set.Set Schema.TriggerMigrationKey ->
Expr.QualifiedOrUnqualified Expr.TableName ->
PgCatalog.PgTrigger ->
[MigrationStepWithType]
mkDropTriggerSteps triggersToKeep tableName pgTrigger =
let
migrationKey =
pgTriggerMigrationKey pgTrigger
triggerName =
Expr.triggerName
. PgCatalog.triggerNameToString
. PgCatalog.pgTriggerName
$ pgTrigger
in
if Set.member migrationKey triggersToKeep || PgCatalog.pgTriggerIsInternal pgTrigger
then []
else [mkMigrationStepWithType DropTriggers (Expr.dropTrigger Nothing triggerName tableName)]
mkCommentSteps ::
PgCatalog.RelationDescription ->
Orville.TableDefinition key writeEntity readEntity ->
[MigrationStepWithType]
mkCommentSteps relationDesc tableDef =
let
tableName = Orville.tableName tableDef
commentTableStep =
if PgCatalog.relationComment relationDesc == Schema.tableComment tableDef
then []
else
[ mkMigrationStepWithType
SetComments
( Expr.commentTableExpr
tableName
(fmap Expr.commentText (Schema.tableComment tableDef))
)
]
commentColumnsSteps =
Maybe.catMaybes $
Orville.foldMarshallerFields
(Orville.unannotatedSqlMarshaller $ Orville.tableMarshaller tableDef)
[]
( Orville.collectFromField
Orville.IncludeReadOnlyColumns
(const . mkCommentColumnStep relationDesc $ Orville.tableIdentifier tableDef)
)
in
commentTableStep <> commentColumnsSteps
mkCommentColumnStep ::
PgCatalog.RelationDescription ->
Schema.TableIdentifier ->
Orville.FieldDefinition n a ->
Maybe MigrationStepWithType
mkCommentColumnStep relationDesc tableId fieldDef =
let
fieldAttributeName =
String.fromString (Orville.fieldNameToString $ Orville.fieldName fieldDef)
currentFieldComment =
PgCatalog.lookupAttributeComment fieldAttributeName relationDesc
targetFieldComment =
fmap T.pack (Orville.fieldDescription fieldDef)
in
if currentFieldComment == targetFieldComment
then Nothing
else
Just $
mkMigrationStepWithType
SetComments
( Expr.commentColumnExpr
(Schema.tableIdSchemaName tableId)
(Schema.tableIdUnqualifiedName tableId)
(Orville.fieldNameToColumnName $ Orville.fieldName fieldDef)
(fmap Expr.commentText targetFieldComment)
)
{- | Primary Key, Unique, and Exclusion constraints automatically create indexes
that we don't want orville to consider for the purposes of migrations. This
function checks the constraint type and returns the OID of the supporting
index if the constraint is one of these types.
Foreign key constraints also have a supporting index OID in @pg_catalog@, but
this index is not automatically created due to the constraint, so we don't
return the index's OID for that case.
@since 1.0.0.0
-}
pgConstraintImpliedIndexOid :: PgCatalog.PgConstraint -> Maybe LibPQ.Oid
pgConstraintImpliedIndexOid pgConstraint =
case PgCatalog.pgConstraintType pgConstraint of
PgCatalog.PrimaryKeyConstraint ->
Just $ PgCatalog.pgConstraintIndexOid pgConstraint
PgCatalog.UniqueConstraint ->
Just $ PgCatalog.pgConstraintIndexOid pgConstraint
PgCatalog.ExclusionConstraint ->
Just $ PgCatalog.pgConstraintIndexOid pgConstraint
PgCatalog.CheckConstraint ->
Nothing
PgCatalog.ForeignKeyConstraint ->
Nothing
PgCatalog.ConstraintTrigger ->
Nothing
{- | Builds the orville migration keys given a description of an existing index
so that it can be compared with indexs found in a table definition.
If the description includes expressions as members of the index rather than
simple attributes, 'Nothing' is returned.
@since 1.0.0.0
-}
pgIndexMigrationKeys ::
PgCatalog.IndexDescription ->
[IndexDefinition.IndexMigrationKey]
pgIndexMigrationKeys indexDesc =
let
mkNamedIndexKey =
IndexDefinition.NamedIndexKey
. PgCatalog.relationNameToString
. PgCatalog.pgClassRelationName
. PgCatalog.indexPgClass
$ indexDesc
mkAttributeBasedIndexKey =
case pgAttributeBasedIndexMigrationKey indexDesc of
Just standardKey ->
[IndexDefinition.AttributeBasedIndexKey standardKey]
Nothing ->
[]
in
mkNamedIndexKey : mkAttributeBasedIndexKey
pgAttributeBasedIndexMigrationKey ::
PgCatalog.IndexDescription ->
Maybe IndexDefinition.AttributeBasedIndexMigrationKey
pgAttributeBasedIndexMigrationKey indexDesc = do
let
indexMemberToFieldName member =
case member of
PgCatalog.IndexAttribute attr ->
Just (Orville.stringToFieldName . PgCatalog.attributeNameToString . PgCatalog.pgAttributeName $ attr)
PgCatalog.IndexExpression ->
Nothing
uniqueness =
if PgCatalog.pgIndexIsUnique (PgCatalog.indexRecord indexDesc)
then Orville.UniqueIndex
else Orville.NonUniqueIndex
fieldNames <- traverse indexMemberToFieldName (PgCatalog.indexMembers indexDesc)
pure $
IndexDefinition.AttributeBasedIndexMigrationKey
{ IndexDefinition.indexKeyUniqueness = uniqueness
, IndexDefinition.indexKeyColumns = fieldNames
}
{- | Builds the orville migration key given a description of an existing trigger
so that it can be compared with triggers found in a table definition.
If the description includes expressions as members of the trigger rather than
simple attributes, 'Nothing' is returned.
@since 1.1.0.0
-}
pgTriggerMigrationKey ::
PgCatalog.PgTrigger ->
Schema.TriggerMigrationKey
pgTriggerMigrationKey =
Schema.NamedTriggerKey
. PgCatalog.triggerNameToString
. PgCatalog.pgTriggerName
{- | 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 ->
Maybe (PgCatalog.NamespaceName, PgCatalog.RelationName)
schemaItemPgCatalogRelation currentNamespace item =
case item of
SchemaTable tableDef ->
Just $ tableIdToPgCatalogNames currentNamespace (Orville.tableIdentifier tableDef)
SchemaDropTable tableId ->
Just $ tableIdToPgCatalogNames currentNamespace tableId
SchemaSequence sequenceDef ->
Just $ sequenceIdToPgCatalogNames currentNamespace (Orville.sequenceIdentifier sequenceDef)
SchemaDropSequence sequenceId ->
Just $ sequenceIdToPgCatalogNames currentNamespace sequenceId
SchemaFunction _functionDef ->
Nothing
SchemaDropFunction _functionId ->
Nothing
SchemaExtension _extension ->
Nothing
SchemaDropExtension _extension ->
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
SchemaExtension _extension ->
Nothing
SchemaDropExtension _extension ->
Nothing
{- | Retrieves from a 'SchemaItem' the extension (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.
-}
schemaItemPgCatalogExtension ::
SchemaItem ->
Maybe PgCatalog.ExtensionName
schemaItemPgCatalogExtension item =
case item of
SchemaTable _tableDef ->
Nothing
SchemaDropTable _tableId ->
Nothing
SchemaSequence _sequenceDef ->
Nothing
SchemaDropSequence _sequenceId ->
Nothing
SchemaFunction _functionDef ->
Nothing
SchemaDropFunction _functionId ->
Nothing
SchemaExtension extension ->
Just $ extensionIdToPgCatalogName extension
SchemaDropExtension extension ->
Just $ extensionIdToPgCatalogName extension
tableIdToPgCatalogNames ::
PgCatalog.NamespaceName ->
Orville.TableIdentifier ->
(PgCatalog.NamespaceName, PgCatalog.RelationName)
tableIdToPgCatalogNames currentNamespace tableId =
let
actualNamespace =
maybe currentNamespace String.fromString
. Orville.tableIdSchemaNameString
$ tableId
relationName =
String.fromString
. Orville.tableIdUnqualifiedNameString
$ 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)
extensionIdToPgCatalogName ::
Orville.ExtensionIdentifier ->
PgCatalog.ExtensionName
extensionIdToPgCatalogName =
String.fromString . Orville.extensionIdToString
mkAlterSequenceSteps ::
Orville.SequenceDefinition ->
PgCatalog.PgSequence ->
[MigrationStepWithType]
mkAlterSequenceSteps sequenceDef pgSequence =
let
ifChanged ::
Eq a =>
(a -> expr) ->
(PgCatalog.PgSequence -> a) ->
(Orville.SequenceDefinition -> a) ->
Maybe expr
ifChanged mkChange getOld getNew =
if getOld pgSequence == getNew sequenceDef
then Nothing
else Just . mkChange . getNew $ sequenceDef
mbIncrementByExpr =
ifChanged Expr.incrementBy PgCatalog.pgSequenceIncrement Orville.sequenceIncrement
mbMinValueExpr =
ifChanged Expr.minValue PgCatalog.pgSequenceMin Orville.sequenceMinValue
mbMaxValueExpr =
ifChanged Expr.maxValue PgCatalog.pgSequenceMax Orville.sequenceMaxValue
mbStartWithExpr =
ifChanged Expr.startWith PgCatalog.pgSequenceStart Orville.sequenceStart
mbCacheExpr =
ifChanged Expr.cache PgCatalog.pgSequenceCache Orville.sequenceCache
mbCycleExpr =
ifChanged Expr.cycleIfTrue PgCatalog.pgSequenceCycle Orville.sequenceCycle
applyChange :: (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)
applyChange (changed, exprF) mbArg =
(changed || Maybe.isJust mbArg, exprF mbArg)
(anyChanges, migrateSequenceExpr) =
(False, Expr.alterSequenceExpr (Orville.sequenceName sequenceDef))
`applyChange` mbIncrementByExpr
`applyChange` mbMinValueExpr
`applyChange` mbMaxValueExpr
`applyChange` mbStartWithExpr
`applyChange` mbCacheExpr
`applyChange` mbCycleExpr
in
if anyChanges
then [mkMigrationStepWithType AddRemoveTablesAndColumns migrateSequenceExpr]
else []
sequenceIdToPgCatalogNames ::
PgCatalog.NamespaceName ->
Orville.SequenceIdentifier ->
(PgCatalog.NamespaceName, PgCatalog.RelationName)
sequenceIdToPgCatalogNames currentNamespace sequenceId =
let
actualNamespace =
maybe currentNamespace String.fromString
. Orville.sequenceIdSchemaNameString
$ sequenceId
relationName =
String.fromString
. Orville.sequenceIdUnqualifiedNameString
$ sequenceId
in
(actualNamespace, relationName)
currentNamespaceQuery :: Expr.QueryExpr
currentNamespaceQuery =
Expr.queryExpr
(Expr.selectClause (Expr.selectExpr Nothing))
( Expr.selectDerivedColumns
[ Expr.deriveColumnAs
-- current_schema is a special reserved word in postgresql. If you
-- put it in quotes it tries to treat it as a regular column name,
-- which then can't be found as a column in the query.
(RawSql.unsafeSqlExpression "current_schema")
(Orville.fieldNameToColumnName $ Orville.fieldName PgCatalog.namespaceNameField)
]
)
Nothing
findCurrentNamespace :: Orville.MonadOrville m => m PgCatalog.NamespaceName
findCurrentNamespace = do
results <-
Orville.executeAndDecode
Orville.SelectQuery
currentNamespaceQuery
(Orville.annotateSqlMarshallerEmptyAnnotation $ Orville.marshallField id PgCatalog.namespaceNameField)
liftIO $
case results of
[schemaAndCatalog] ->
pure schemaAndCatalog
[] ->
throwIO $ UnableToDiscoverCurrentSchema "No results returned by current_schema query"
_ ->
throwIO $ UnableToDiscoverCurrentSchema "Multiple results returned by current_schema query"