{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}

{- |
Copyright : Flipstone Technology Partners 2023
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, migrationLockId)
  , defaultOptions
  , autoMigrateSchema
  , SchemaItem (..)
  , schemaItemSummary
  , MigrationPlan
  , generateMigrationPlan
  , migrationPlanSteps
  , executeMigrationPlan
  , MigrationStep
  , MigrationDataError
  , 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.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.PgCatalog as PgCatalog
import qualified Orville.PostgreSQL.Raw.RawSql as RawSql
import qualified Orville.PostgreSQL.Schema as Schema

{- |
  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

{- |
  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 :: SchemaItem -> String
schemaItemSummary SchemaItem
item =
  case SchemaItem
item of
    SchemaTable TableDefinition key writeEntity readEntity
tableDef ->
      String
"Table " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TableIdentifier -> String
Orville.tableIdToString (TableDefinition key writeEntity readEntity -> TableIdentifier
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> TableIdentifier
Orville.tableIdentifier TableDefinition key writeEntity readEntity
tableDef)
    SchemaDropTable TableIdentifier
tableId ->
      String
"Drop table " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TableIdentifier -> String
Orville.tableIdToString TableIdentifier
tableId
    SchemaSequence SequenceDefinition
sequenceDef ->
      String
"Sequence " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SequenceIdentifier -> String
Orville.sequenceIdToString (SequenceDefinition -> SequenceIdentifier
Orville.sequenceIdentifier SequenceDefinition
sequenceDef)
    SchemaDropSequence SequenceIdentifier
sequenceId ->
      String
"Drop sequence " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SequenceIdentifier -> String
Orville.sequenceIdToString SequenceIdentifier
sequenceId

{- |
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
  { MigrationPlan -> [MigrationStep]
i_transactionalSteps :: [MigrationStep]
  , MigrationPlan -> [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 :: MigrationPlan -> [MigrationStep]
migrationPlanSteps MigrationPlan
plan =
  MigrationPlan -> [MigrationStep]
i_transactionalSteps MigrationPlan
plan [MigrationStep] -> [MigrationStep] -> [MigrationStep]
forall a. Semigroup a => a -> a -> a
<> MigrationPlan -> [MigrationStep]
i_concurrentIndexSteps MigrationPlan
plan

mkMigrationPlan :: [MigrationStepWithType] -> MigrationPlan
mkMigrationPlan :: [MigrationStepWithType] -> MigrationPlan
mkMigrationPlan [MigrationStepWithType]
steps =
  let
    ([MigrationStepWithType]
transactionalSteps, [MigrationStepWithType]
concurrentIndexSteps) =
      (MigrationStepWithType -> Bool)
-> [MigrationStepWithType]
-> ([MigrationStepWithType], [MigrationStepWithType])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition MigrationStepWithType -> Bool
isMigrationStepTransactional
        ([MigrationStepWithType]
 -> ([MigrationStepWithType], [MigrationStepWithType]))
-> ([MigrationStepWithType] -> [MigrationStepWithType])
-> [MigrationStepWithType]
-> ([MigrationStepWithType], [MigrationStepWithType])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MigrationStepWithType -> StepType)
-> [MigrationStepWithType] -> [MigrationStepWithType]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn MigrationStepWithType -> StepType
migrationStepType
        ([MigrationStepWithType]
 -> ([MigrationStepWithType], [MigrationStepWithType]))
-> [MigrationStepWithType]
-> ([MigrationStepWithType], [MigrationStepWithType])
forall a b. (a -> b) -> a -> b
$ [MigrationStepWithType]
steps
  in
    MigrationPlan
      { i_transactionalSteps :: [MigrationStep]
i_transactionalSteps = (MigrationStepWithType -> MigrationStep)
-> [MigrationStepWithType] -> [MigrationStep]
forall a b. (a -> b) -> [a] -> [b]
map MigrationStepWithType -> MigrationStep
migrationStep [MigrationStepWithType]
transactionalSteps
      , i_concurrentIndexSteps :: [MigrationStep]
i_concurrentIndexSteps = (MigrationStepWithType -> MigrationStep)
-> [MigrationStepWithType] -> [MigrationStep]
forall a b. (a -> b) -> [a] -> [b]
map MigrationStepWithType -> MigrationStep
migrationStep [MigrationStepWithType]
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 -> MigrationStep
MigrationStep -> RawSql
(MigrationStep -> RawSql)
-> (RawSql -> MigrationStep) -> SqlExpression MigrationStep
forall a. (a -> RawSql) -> (RawSql -> a) -> SqlExpression a
$ctoRawSql :: MigrationStep -> RawSql
toRawSql :: MigrationStep -> RawSql
$cunsafeFromRawSql :: RawSql -> MigrationStep
unsafeFromRawSql :: RawSql -> MigrationStep
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
  { MigrationStepWithType -> StepType
migrationStepType :: StepType
  , MigrationStepWithType -> MigrationStep
migrationStep :: MigrationStep
  }

mkMigrationStepWithType ::
  RawSql.SqlExpression sql =>
  StepType ->
  sql ->
  MigrationStepWithType
mkMigrationStepWithType :: forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType StepType
stepType sql
sql =
  MigrationStepWithType
    { migrationStepType :: StepType
migrationStepType = StepType
stepType
    , migrationStep :: MigrationStep
migrationStep = RawSql -> MigrationStep
MigrationStep (sql -> RawSql
forall a. SqlExpression a => a -> RawSql
RawSql.toRawSql sql
sql)
    }

isMigrationStepTransactional :: MigrationStepWithType -> Bool
isMigrationStepTransactional :: MigrationStepWithType -> Bool
isMigrationStepTransactional MigrationStepWithType
stepWithType =
  case MigrationStepWithType -> StepType
migrationStepType MigrationStepWithType
stepWithType of
    StepType
DropForeignKeys -> Bool
True
    StepType
DropUniqueConstraints -> Bool
True
    StepType
DropIndexes -> Bool
True
    StepType
AddRemoveTablesAndColumns -> Bool
True
    StepType
AddIndexesTransactionally -> Bool
True
    StepType
AddUniqueConstraints -> Bool
True
    StepType
AddForeignKeys -> Bool
True
    StepType
AddIndexesConcurrently -> Bool
False

{- |
  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
  = DropForeignKeys
  | DropUniqueConstraints
  | DropIndexes
  | AddRemoveTablesAndColumns
  | AddIndexesTransactionally
  | AddUniqueConstraints
  | AddForeignKeys
  | AddIndexesConcurrently
  deriving
    ( -- | @since 1.0.0.0
      StepType -> StepType -> Bool
(StepType -> StepType -> Bool)
-> (StepType -> StepType -> Bool) -> Eq StepType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StepType -> StepType -> Bool
== :: StepType -> StepType -> Bool
$c/= :: StepType -> StepType -> Bool
/= :: StepType -> StepType -> Bool
Eq
    , -- | @since 1.0.0.0
      Eq StepType
Eq StepType
-> (StepType -> StepType -> Ordering)
-> (StepType -> StepType -> Bool)
-> (StepType -> StepType -> Bool)
-> (StepType -> StepType -> Bool)
-> (StepType -> StepType -> Bool)
-> (StepType -> StepType -> StepType)
-> (StepType -> StepType -> StepType)
-> Ord StepType
StepType -> StepType -> Bool
StepType -> StepType -> Ordering
StepType -> StepType -> StepType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StepType -> StepType -> Ordering
compare :: StepType -> StepType -> Ordering
$c< :: StepType -> StepType -> Bool
< :: StepType -> StepType -> Bool
$c<= :: StepType -> StepType -> Bool
<= :: StepType -> StepType -> Bool
$c> :: StepType -> StepType -> Bool
> :: StepType -> StepType -> Bool
$c>= :: StepType -> StepType -> Bool
>= :: StepType -> StepType -> Bool
$cmax :: StepType -> StepType -> StepType
max :: StepType -> StepType -> StepType
$cmin :: StepType -> StepType -> StepType
min :: StepType -> StepType -> StepType
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
      Int -> MigrationDataError -> String -> String
[MigrationDataError] -> String -> String
MigrationDataError -> String
(Int -> MigrationDataError -> String -> String)
-> (MigrationDataError -> String)
-> ([MigrationDataError] -> String -> String)
-> Show MigrationDataError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> MigrationDataError -> String -> String
showsPrec :: Int -> MigrationDataError -> String -> String
$cshow :: MigrationDataError -> String
show :: MigrationDataError -> String
$cshowList :: [MigrationDataError] -> String -> String
showList :: [MigrationDataError] -> String -> String
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
  { MigrationOptions -> Bool
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
  , MigrationOptions -> Bool
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
  , MigrationOptions -> MigrationLockId
migrationLockId :: MigrationLock.MigrationLockId
  -- ^
  --       The 'MigrationLock.MigrationLockId' that will be use to ensure only
  --       one application is running migrations at a time. The default value
  --       is 'MigrationLock.defaultLockId'. You may want to change this if you
  --       want to run concurrent index creations separately from the rest of
  --       the schema changes without blocking one another.
  --
  --       @since 1.0.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
defaultOptions =
  MigrationOptions
    { runSchemaChanges :: Bool
runSchemaChanges = Bool
True
    , runConcurrentIndexCreations :: Bool
runConcurrentIndexCreations = Bool
True
    , migrationLockId :: MigrationLockId
migrationLockId = MigrationLockId
MigrationLock.defaultLockId
    }

{- |
  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 :: forall (m :: * -> *).
MonadOrville m =>
MigrationOptions -> [SchemaItem] -> m ()
autoMigrateSchema MigrationOptions
options [SchemaItem]
schemaItems =
  MigrationLockId -> m () -> m ()
forall (m :: * -> *) a.
MonadOrville m =>
MigrationLockId -> m a -> m a
MigrationLock.withMigrationLock (MigrationOptions -> MigrationLockId
migrationLockId MigrationOptions
options) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    MigrationPlan
plan <- [SchemaItem] -> m MigrationPlan
forall (m :: * -> *).
MonadOrville m =>
[SchemaItem] -> m MigrationPlan
generateMigrationPlanWithoutLock [SchemaItem]
schemaItems
    MigrationOptions -> MigrationPlan -> m ()
forall (m :: * -> *).
MonadOrville m =>
MigrationOptions -> MigrationPlan -> m ()
executeMigrationPlanWithoutLock MigrationOptions
options MigrationPlan
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 :: forall (m :: * -> *).
MonadOrville m =>
MigrationOptions -> [SchemaItem] -> m MigrationPlan
generateMigrationPlan MigrationOptions
options =
  MigrationLockId -> m MigrationPlan -> m MigrationPlan
forall (m :: * -> *) a.
MonadOrville m =>
MigrationLockId -> m a -> m a
MigrationLock.withMigrationLock (MigrationOptions -> MigrationLockId
migrationLockId MigrationOptions
options)
    (m MigrationPlan -> m MigrationPlan)
-> ([SchemaItem] -> m MigrationPlan)
-> [SchemaItem]
-> m MigrationPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SchemaItem] -> m MigrationPlan
forall (m :: * -> *).
MonadOrville m =>
[SchemaItem] -> m MigrationPlan
generateMigrationPlanWithoutLock

generateMigrationPlanWithoutLock :: Orville.MonadOrville m => [SchemaItem] -> m MigrationPlan
generateMigrationPlanWithoutLock :: forall (m :: * -> *).
MonadOrville m =>
[SchemaItem] -> m MigrationPlan
generateMigrationPlanWithoutLock [SchemaItem]
schemaItems =
  m MigrationPlan -> m MigrationPlan
forall (m :: * -> *) a. MonadOrville m => m a -> m a
Orville.withTransaction (m MigrationPlan -> m MigrationPlan)
-> m MigrationPlan -> m MigrationPlan
forall a b. (a -> b) -> a -> b
$ do
    NamespaceName
currentNamespace <- m NamespaceName
forall (m :: * -> *). MonadOrville m => m NamespaceName
findCurrentNamespace

    let
      pgCatalogRelations :: [(NamespaceName, RelationName)]
pgCatalogRelations = (SchemaItem -> (NamespaceName, RelationName))
-> [SchemaItem] -> [(NamespaceName, RelationName)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NamespaceName -> SchemaItem -> (NamespaceName, RelationName)
schemaItemPgCatalogRelation NamespaceName
currentNamespace) [SchemaItem]
schemaItems

    DatabaseDescription
dbDesc <- [(NamespaceName, RelationName)] -> m DatabaseDescription
forall (m :: * -> *).
MonadOrville m =>
[(NamespaceName, RelationName)] -> m DatabaseDescription
PgCatalog.describeDatabaseRelations [(NamespaceName, RelationName)]
pgCatalogRelations

    case (SchemaItem -> Either MigrationDataError [MigrationStepWithType])
-> [SchemaItem]
-> Either MigrationDataError [[MigrationStepWithType]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (NamespaceName
-> DatabaseDescription
-> SchemaItem
-> Either MigrationDataError [MigrationStepWithType]
calculateMigrationSteps NamespaceName
currentNamespace DatabaseDescription
dbDesc) [SchemaItem]
schemaItems of
      Left MigrationDataError
err ->
        IO MigrationPlan -> m MigrationPlan
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MigrationPlan -> m MigrationPlan)
-> (MigrationDataError -> IO MigrationPlan)
-> MigrationDataError
-> m MigrationPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationDataError -> IO MigrationPlan
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (MigrationDataError -> m MigrationPlan)
-> MigrationDataError -> m MigrationPlan
forall a b. (a -> b) -> a -> b
$ MigrationDataError
err
      Right [[MigrationStepWithType]]
migrationSteps ->
        MigrationPlan -> m MigrationPlan
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MigrationPlan -> m MigrationPlan)
-> ([[MigrationStepWithType]] -> MigrationPlan)
-> [[MigrationStepWithType]]
-> m MigrationPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MigrationStepWithType] -> MigrationPlan
mkMigrationPlan ([MigrationStepWithType] -> MigrationPlan)
-> ([[MigrationStepWithType]] -> [MigrationStepWithType])
-> [[MigrationStepWithType]]
-> MigrationPlan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[MigrationStepWithType]] -> [MigrationStepWithType]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[MigrationStepWithType]] -> m MigrationPlan)
-> [[MigrationStepWithType]] -> m MigrationPlan
forall a b. (a -> b) -> a -> b
$ [[MigrationStepWithType]]
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 :: forall (m :: * -> *).
MonadOrville m =>
MigrationOptions -> MigrationPlan -> m ()
executeMigrationPlan MigrationOptions
options =
  MigrationLockId -> m () -> m ()
forall (m :: * -> *) a.
MonadOrville m =>
MigrationLockId -> m a -> m a
MigrationLock.withMigrationLock (MigrationOptions -> MigrationLockId
migrationLockId MigrationOptions
options)
    (m () -> m ()) -> (MigrationPlan -> m ()) -> MigrationPlan -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationOptions -> MigrationPlan -> m ()
forall (m :: * -> *).
MonadOrville m =>
MigrationOptions -> MigrationPlan -> m ()
executeMigrationPlanWithoutLock MigrationOptions
options

executeMigrationPlanWithoutLock ::
  Orville.MonadOrville m =>
  MigrationOptions ->
  MigrationPlan ->
  m ()
executeMigrationPlanWithoutLock :: forall (m :: * -> *).
MonadOrville m =>
MigrationOptions -> MigrationPlan -> m ()
executeMigrationPlanWithoutLock MigrationOptions
options MigrationPlan
plan = do
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
runSchemaChanges MigrationOptions
options)
    (m () -> m ()) -> (MigrationPlan -> m ()) -> MigrationPlan -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m () -> m ()
forall (m :: * -> *) a. MonadOrville m => m a -> m a
Orville.withTransaction
    (m () -> m ()) -> (MigrationPlan -> m ()) -> MigrationPlan -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MigrationStep] -> m ()
forall (m :: * -> *). MonadOrville m => [MigrationStep] -> m ()
executeMigrationStepsWithoutTransaction
    ([MigrationStep] -> m ())
-> (MigrationPlan -> [MigrationStep]) -> MigrationPlan -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationPlan -> [MigrationStep]
i_transactionalSteps
    (MigrationPlan -> m ()) -> MigrationPlan -> m ()
forall a b. (a -> b) -> a -> b
$ MigrationPlan
plan

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MigrationOptions -> Bool
runConcurrentIndexCreations MigrationOptions
options)
    (m () -> m ())
-> ([MigrationStep] -> m ()) -> [MigrationStep] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [MigrationStep] -> m ()
forall (m :: * -> *). MonadOrville m => [MigrationStep] -> m ()
executeMigrationStepsWithoutTransaction
    ([MigrationStep] -> m ()) -> [MigrationStep] -> m ()
forall a b. (a -> b) -> a -> b
$ MigrationPlan -> [MigrationStep]
i_concurrentIndexSteps
    (MigrationPlan -> [MigrationStep])
-> MigrationPlan -> [MigrationStep]
forall a b. (a -> b) -> a -> b
$ MigrationPlan
plan

executeMigrationStepsWithoutTransaction :: Orville.MonadOrville m => [MigrationStep] -> m ()
executeMigrationStepsWithoutTransaction :: forall (m :: * -> *). MonadOrville m => [MigrationStep] -> m ()
executeMigrationStepsWithoutTransaction =
  (MigrationStep -> m ()) -> [MigrationStep] -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (QueryType -> MigrationStep -> m ()
forall (m :: * -> *) sql.
(MonadOrville m, SqlExpression sql) =>
QueryType -> sql -> m ()
Orville.executeVoid QueryType
Orville.DDLQuery)

calculateMigrationSteps ::
  PgCatalog.NamespaceName ->
  PgCatalog.DatabaseDescription ->
  SchemaItem ->
  Either MigrationDataError [MigrationStepWithType]
calculateMigrationSteps :: NamespaceName
-> DatabaseDescription
-> SchemaItem
-> Either MigrationDataError [MigrationStepWithType]
calculateMigrationSteps NamespaceName
currentNamespace DatabaseDescription
dbDesc SchemaItem
schemaItem =
  case SchemaItem
schemaItem of
    SchemaTable TableDefinition key writeEntity readEntity
tableDef ->
      [MigrationStepWithType]
-> Either MigrationDataError [MigrationStepWithType]
forall a b. b -> Either a b
Right ([MigrationStepWithType]
 -> Either MigrationDataError [MigrationStepWithType])
-> [MigrationStepWithType]
-> Either MigrationDataError [MigrationStepWithType]
forall a b. (a -> b) -> a -> b
$
        let
          (NamespaceName
schemaName, RelationName
tableName) =
            NamespaceName -> TableIdentifier -> (NamespaceName, RelationName)
tableIdToPgCatalogNames
              NamespaceName
currentNamespace
              (TableDefinition key writeEntity readEntity -> TableIdentifier
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> TableIdentifier
Orville.tableIdentifier TableDefinition key writeEntity readEntity
tableDef)
        in
          case RelationKind
-> (NamespaceName, RelationName)
-> DatabaseDescription
-> Maybe RelationDescription
PgCatalog.lookupRelationOfKind RelationKind
PgCatalog.OrdinaryTable (NamespaceName
schemaName, RelationName
tableName) DatabaseDescription
dbDesc of
            Maybe RelationDescription
Nothing ->
              NamespaceName
-> TableDefinition key writeEntity readEntity
-> [MigrationStepWithType]
forall key writeEntity readEntity.
NamespaceName
-> TableDefinition key writeEntity readEntity
-> [MigrationStepWithType]
mkCreateTableSteps NamespaceName
currentNamespace TableDefinition key writeEntity readEntity
tableDef
            Just RelationDescription
relationDesc ->
              NamespaceName
-> RelationDescription
-> TableDefinition key writeEntity readEntity
-> [MigrationStepWithType]
forall key writeEntity readEntity.
NamespaceName
-> RelationDescription
-> TableDefinition key writeEntity readEntity
-> [MigrationStepWithType]
mkAlterTableSteps NamespaceName
currentNamespace RelationDescription
relationDesc TableDefinition key writeEntity readEntity
tableDef
    SchemaDropTable TableIdentifier
tableId ->
      [MigrationStepWithType]
-> Either MigrationDataError [MigrationStepWithType]
forall a b. b -> Either a b
Right ([MigrationStepWithType]
 -> Either MigrationDataError [MigrationStepWithType])
-> [MigrationStepWithType]
-> Either MigrationDataError [MigrationStepWithType]
forall a b. (a -> b) -> a -> b
$
        let
          (NamespaceName
schemaName, RelationName
tableName) =
            NamespaceName -> TableIdentifier -> (NamespaceName, RelationName)
tableIdToPgCatalogNames NamespaceName
currentNamespace TableIdentifier
tableId
        in
          case (NamespaceName, RelationName)
-> DatabaseDescription -> Maybe RelationDescription
PgCatalog.lookupRelation (NamespaceName
schemaName, RelationName
tableName) DatabaseDescription
dbDesc of
            Maybe RelationDescription
Nothing ->
              []
            Just RelationDescription
_ ->
              let
                dropTableExpr :: DropTableExpr
dropTableExpr =
                  Maybe IfExists -> Qualified TableName -> DropTableExpr
Expr.dropTableExpr
                    Maybe IfExists
forall a. Maybe a
Nothing
                    (TableIdentifier -> Qualified TableName
Orville.tableIdQualifiedName TableIdentifier
tableId)
              in
                [StepType -> DropTableExpr -> MigrationStepWithType
forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType StepType
AddRemoveTablesAndColumns DropTableExpr
dropTableExpr]
    SchemaSequence SequenceDefinition
sequenceDef ->
      let
        (NamespaceName
schemaName, RelationName
sequenceName) =
          NamespaceName
-> SequenceIdentifier -> (NamespaceName, RelationName)
sequenceIdToPgCatalogNames
            NamespaceName
currentNamespace
            (SequenceDefinition -> SequenceIdentifier
Orville.sequenceIdentifier SequenceDefinition
sequenceDef)
      in
        case RelationKind
-> (NamespaceName, RelationName)
-> DatabaseDescription
-> Maybe RelationDescription
PgCatalog.lookupRelationOfKind RelationKind
PgCatalog.Sequence (NamespaceName
schemaName, RelationName
sequenceName) DatabaseDescription
dbDesc of
          Maybe RelationDescription
Nothing ->
            [MigrationStepWithType]
-> Either MigrationDataError [MigrationStepWithType]
forall a b. b -> Either a b
Right
              [ StepType -> CreateSequenceExpr -> MigrationStepWithType
forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType
                  StepType
AddRemoveTablesAndColumns
                  (SequenceDefinition -> CreateSequenceExpr
Orville.mkCreateSequenceExpr SequenceDefinition
sequenceDef)
              ]
          Just RelationDescription
relationDesc ->
            case RelationDescription -> Maybe PgSequence
PgCatalog.relationSequence RelationDescription
relationDesc of
              Maybe PgSequence
Nothing ->
                MigrationDataError
-> Either MigrationDataError [MigrationStepWithType]
forall a b. a -> Either a b
Left (MigrationDataError
 -> Either MigrationDataError [MigrationStepWithType])
-> (String -> MigrationDataError)
-> String
-> Either MigrationDataError [MigrationStepWithType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> MigrationDataError
PgCatalogInvariantViolated (String -> Either MigrationDataError [MigrationStepWithType])
-> String -> Either MigrationDataError [MigrationStepWithType]
forall a b. (a -> b) -> a -> b
$
                  String
"Sequence "
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> NamespaceName -> String
PgCatalog.namespaceNameToString NamespaceName
schemaName
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> RelationName -> String
PgCatalog.relationNameToString RelationName
sequenceName
                    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" was found in the 'pg_class' table but no corresponding 'pg_sequence' row was found"
              Just PgSequence
pgSequence ->
                [MigrationStepWithType]
-> Either MigrationDataError [MigrationStepWithType]
forall a b. b -> Either a b
Right ([MigrationStepWithType]
 -> Either MigrationDataError [MigrationStepWithType])
-> [MigrationStepWithType]
-> Either MigrationDataError [MigrationStepWithType]
forall a b. (a -> b) -> a -> b
$
                  SequenceDefinition -> PgSequence -> [MigrationStepWithType]
mkAlterSequenceSteps SequenceDefinition
sequenceDef PgSequence
pgSequence
    SchemaDropSequence SequenceIdentifier
sequenceId ->
      [MigrationStepWithType]
-> Either MigrationDataError [MigrationStepWithType]
forall a b. b -> Either a b
Right ([MigrationStepWithType]
 -> Either MigrationDataError [MigrationStepWithType])
-> [MigrationStepWithType]
-> Either MigrationDataError [MigrationStepWithType]
forall a b. (a -> b) -> a -> b
$
        let
          (NamespaceName
schemaName, RelationName
sequenceName) =
            NamespaceName
-> SequenceIdentifier -> (NamespaceName, RelationName)
sequenceIdToPgCatalogNames NamespaceName
currentNamespace SequenceIdentifier
sequenceId
        in
          case RelationKind
-> (NamespaceName, RelationName)
-> DatabaseDescription
-> Maybe RelationDescription
PgCatalog.lookupRelationOfKind RelationKind
PgCatalog.Sequence (NamespaceName
schemaName, RelationName
sequenceName) DatabaseDescription
dbDesc of
            Maybe RelationDescription
Nothing ->
              []
            Just RelationDescription
_ ->
              [ StepType -> DropSequenceExpr -> MigrationStepWithType
forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType
                  StepType
AddRemoveTablesAndColumns
                  (Maybe IfExists -> Qualified SequenceName -> DropSequenceExpr
Expr.dropSequenceExpr Maybe IfExists
forall a. Maybe a
Nothing (SequenceIdentifier -> Qualified SequenceName
Orville.sequenceIdQualifiedName SequenceIdentifier
sequenceId))
              ]

{- |
  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 :: forall key writeEntity readEntity.
NamespaceName
-> TableDefinition key writeEntity readEntity
-> [MigrationStepWithType]
mkCreateTableSteps NamespaceName
currentNamespace TableDefinition key writeEntity readEntity
tableDef =
  let
    tableName :: Qualified TableName
tableName =
      TableDefinition key writeEntity readEntity -> Qualified TableName
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> Qualified TableName
Orville.tableName TableDefinition key writeEntity readEntity
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 :: CreateTableExpr
createTableExpr =
      Qualified TableName
-> [ColumnDefinition]
-> Maybe PrimaryKeyExpr
-> [TableConstraint]
-> CreateTableExpr
Expr.createTableExpr
        Qualified TableName
tableName
        (TableDefinition key writeEntity readEntity -> [ColumnDefinition]
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> [ColumnDefinition]
Orville.mkTableColumnDefinitions TableDefinition key writeEntity readEntity
tableDef)
        (TableDefinition key writeEntity readEntity -> Maybe PrimaryKeyExpr
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> Maybe PrimaryKeyExpr
Orville.mkTablePrimaryKeyExpr TableDefinition key writeEntity readEntity
tableDef)
        []

    addConstraintActions :: [(StepType, AlterTableAction)]
addConstraintActions =
      (ConstraintDefinition -> [(StepType, AlterTableAction)])
-> [ConstraintDefinition] -> [(StepType, AlterTableAction)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (NamespaceName
-> Set ConstraintMigrationKey
-> ConstraintDefinition
-> [(StepType, AlterTableAction)]
mkAddConstraintActions NamespaceName
currentNamespace Set ConstraintMigrationKey
forall a. Set a
Set.empty)
        (TableConstraints -> [ConstraintDefinition]
Schema.tableConstraintDefinitions (TableConstraints -> [ConstraintDefinition])
-> TableConstraints -> [ConstraintDefinition]
forall a b. (a -> b) -> a -> b
$ TableDefinition key writeEntity readEntity -> TableConstraints
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> TableConstraints
Orville.tableConstraints TableDefinition key writeEntity readEntity
tableDef)

    addIndexSteps :: [MigrationStepWithType]
addIndexSteps =
      (IndexDefinition -> [MigrationStepWithType])
-> Map IndexMigrationKey IndexDefinition -> [MigrationStepWithType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (Set IndexMigrationKey
-> Qualified TableName
-> IndexDefinition
-> [MigrationStepWithType]
mkAddIndexSteps Set IndexMigrationKey
forall a. Set a
Set.empty Qualified TableName
tableName)
        (TableDefinition key writeEntity readEntity
-> Map IndexMigrationKey IndexDefinition
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity
-> Map IndexMigrationKey IndexDefinition
Orville.tableIndexes TableDefinition key writeEntity readEntity
tableDef)
  in
    StepType -> CreateTableExpr -> MigrationStepWithType
forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType StepType
AddRemoveTablesAndColumns CreateTableExpr
createTableExpr
      MigrationStepWithType
-> [MigrationStepWithType] -> [MigrationStepWithType]
forall a. a -> [a] -> [a]
: Qualified TableName
-> [(StepType, AlterTableAction)] -> [MigrationStepWithType]
mkConstraintSteps Qualified TableName
tableName [(StepType, AlterTableAction)]
addConstraintActions
        [MigrationStepWithType]
-> [MigrationStepWithType] -> [MigrationStepWithType]
forall a. Semigroup a => a -> a -> a
<> [MigrationStepWithType]
addIndexSteps

{- |
  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 :: forall key writeEntity readEntity.
NamespaceName
-> RelationDescription
-> TableDefinition key writeEntity readEntity
-> [MigrationStepWithType]
mkAlterTableSteps NamespaceName
currentNamespace RelationDescription
relationDesc TableDefinition key writeEntity readEntity
tableDef =
  let
    addAlterColumnActions :: [AlterTableAction]
addAlterColumnActions =
      [[AlterTableAction]] -> [AlterTableAction]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[AlterTableAction]] -> [AlterTableAction])
-> [[AlterTableAction]] -> [AlterTableAction]
forall a b. (a -> b) -> a -> b
$
        SqlMarshaller writeEntity readEntity
-> [[AlterTableAction]]
-> (MarshallerField writeEntity
    -> [[AlterTableAction]] -> [[AlterTableAction]])
-> [[AlterTableAction]]
forall writeEntity readEntity result.
SqlMarshaller writeEntity readEntity
-> result
-> (MarshallerField writeEntity -> result -> result)
-> result
Orville.foldMarshallerFields
          (AnnotatedSqlMarshaller writeEntity readEntity
-> SqlMarshaller writeEntity readEntity
forall writeEntity readEntity.
AnnotatedSqlMarshaller writeEntity readEntity
-> SqlMarshaller writeEntity readEntity
Orville.unannotatedSqlMarshaller (AnnotatedSqlMarshaller writeEntity readEntity
 -> SqlMarshaller writeEntity readEntity)
-> AnnotatedSqlMarshaller writeEntity readEntity
-> SqlMarshaller writeEntity readEntity
forall a b. (a -> b) -> a -> b
$ TableDefinition key writeEntity readEntity
-> AnnotatedSqlMarshaller writeEntity readEntity
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity
-> AnnotatedSqlMarshaller writeEntity readEntity
Orville.tableMarshaller TableDefinition key writeEntity readEntity
tableDef)
          []
          (ReadOnlyColumnOption
-> (forall nullability a.
    FieldDefinition nullability a -> [AlterTableAction])
-> MarshallerField writeEntity
-> [[AlterTableAction]]
-> [[AlterTableAction]]
forall result entity.
ReadOnlyColumnOption
-> (forall nullability a. FieldDefinition nullability a -> result)
-> MarshallerField entity
-> [result]
-> [result]
Orville.collectFromField ReadOnlyColumnOption
Orville.IncludeReadOnlyColumns (RelationDescription
-> FieldDefinition nullability a -> [AlterTableAction]
forall nullability a.
RelationDescription
-> FieldDefinition nullability a -> [AlterTableAction]
mkAddAlterColumnActions RelationDescription
relationDesc))

    dropColumnActions :: [AlterTableAction]
dropColumnActions =
      (PgAttribute -> [AlterTableAction])
-> Map AttributeName PgAttribute -> [AlterTableAction]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (TableDefinition key writeEntity readEntity
-> PgAttribute -> [AlterTableAction]
forall key readEntity writeEntity.
TableDefinition key readEntity writeEntity
-> PgAttribute -> [AlterTableAction]
mkDropColumnActions TableDefinition key writeEntity readEntity
tableDef)
        (RelationDescription -> Map AttributeName PgAttribute
PgCatalog.relationAttributes RelationDescription
relationDesc)

    existingConstraints :: Set ConstraintMigrationKey
existingConstraints =
      [ConstraintMigrationKey] -> Set ConstraintMigrationKey
forall a. Ord a => [a] -> Set a
Set.fromList
        ([ConstraintMigrationKey] -> Set ConstraintMigrationKey)
-> (RelationDescription -> [ConstraintMigrationKey])
-> RelationDescription
-> Set ConstraintMigrationKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstraintDescription -> Maybe ConstraintMigrationKey)
-> [ConstraintDescription] -> [ConstraintMigrationKey]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe ConstraintDescription -> Maybe ConstraintMigrationKey
pgConstraintMigrationKey
        ([ConstraintDescription] -> [ConstraintMigrationKey])
-> (RelationDescription -> [ConstraintDescription])
-> RelationDescription
-> [ConstraintMigrationKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationDescription -> [ConstraintDescription]
PgCatalog.relationConstraints
        (RelationDescription -> Set ConstraintMigrationKey)
-> RelationDescription -> Set ConstraintMigrationKey
forall a b. (a -> b) -> a -> b
$ RelationDescription
relationDesc

    constraintsToKeep :: Set ConstraintMigrationKey
constraintsToKeep =
      (ConstraintMigrationKey -> ConstraintMigrationKey)
-> Set ConstraintMigrationKey -> Set ConstraintMigrationKey
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (NamespaceName -> ConstraintMigrationKey -> ConstraintMigrationKey
setDefaultSchemaNameOnConstraintKey NamespaceName
currentNamespace)
        (Set ConstraintMigrationKey -> Set ConstraintMigrationKey)
-> (TableDefinition key writeEntity readEntity
    -> Set ConstraintMigrationKey)
-> TableDefinition key writeEntity readEntity
-> Set ConstraintMigrationKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableConstraints -> Set ConstraintMigrationKey
Schema.tableConstraintKeys
        (TableConstraints -> Set ConstraintMigrationKey)
-> (TableDefinition key writeEntity readEntity -> TableConstraints)
-> TableDefinition key writeEntity readEntity
-> Set ConstraintMigrationKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableDefinition key writeEntity readEntity -> TableConstraints
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> TableConstraints
Orville.tableConstraints
        (TableDefinition key writeEntity readEntity
 -> Set ConstraintMigrationKey)
-> TableDefinition key writeEntity readEntity
-> Set ConstraintMigrationKey
forall a b. (a -> b) -> a -> b
$ TableDefinition key writeEntity readEntity
tableDef

    addConstraintActions :: [(StepType, AlterTableAction)]
addConstraintActions =
      (ConstraintDefinition -> [(StepType, AlterTableAction)])
-> [ConstraintDefinition] -> [(StepType, AlterTableAction)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (NamespaceName
-> Set ConstraintMigrationKey
-> ConstraintDefinition
-> [(StepType, AlterTableAction)]
mkAddConstraintActions NamespaceName
currentNamespace Set ConstraintMigrationKey
existingConstraints)
        (TableConstraints -> [ConstraintDefinition]
Schema.tableConstraintDefinitions (TableConstraints -> [ConstraintDefinition])
-> TableConstraints -> [ConstraintDefinition]
forall a b. (a -> b) -> a -> b
$ TableDefinition key writeEntity readEntity -> TableConstraints
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> TableConstraints
Orville.tableConstraints TableDefinition key writeEntity readEntity
tableDef)

    dropConstraintActions :: [(StepType, AlterTableAction)]
dropConstraintActions =
      (ConstraintDescription -> [(StepType, AlterTableAction)])
-> [ConstraintDescription] -> [(StepType, AlterTableAction)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (Set ConstraintMigrationKey
-> ConstraintDescription -> [(StepType, AlterTableAction)]
mkDropConstraintActions Set ConstraintMigrationKey
constraintsToKeep)
        (RelationDescription -> [ConstraintDescription]
PgCatalog.relationConstraints RelationDescription
relationDesc)

    systemIndexOids :: Set Oid
systemIndexOids =
      [Oid] -> Set Oid
forall a. Ord a => [a] -> Set a
Set.fromList
        ([Oid] -> Set Oid)
-> (RelationDescription -> [Oid]) -> RelationDescription -> Set Oid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConstraintDescription -> Maybe Oid)
-> [ConstraintDescription] -> [Oid]
forall a b. (a -> Maybe b) -> [a] -> [b]
Maybe.mapMaybe (PgConstraint -> Maybe Oid
pgConstraintImpliedIndexOid (PgConstraint -> Maybe Oid)
-> (ConstraintDescription -> PgConstraint)
-> ConstraintDescription
-> Maybe Oid
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintDescription -> PgConstraint
PgCatalog.constraintRecord)
        ([ConstraintDescription] -> [Oid])
-> (RelationDescription -> [ConstraintDescription])
-> RelationDescription
-> [Oid]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationDescription -> [ConstraintDescription]
PgCatalog.relationConstraints
        (RelationDescription -> Set Oid) -> RelationDescription -> Set Oid
forall a b. (a -> b) -> a -> b
$ RelationDescription
relationDesc

    isSystemIndex :: IndexDescription -> Bool
isSystemIndex IndexDescription
indexDesc =
      Oid -> Set Oid -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member
        (PgIndex -> Oid
PgCatalog.pgIndexPgClassOid (PgIndex -> Oid) -> PgIndex -> Oid
forall a b. (a -> b) -> a -> b
$ IndexDescription -> PgIndex
PgCatalog.indexRecord IndexDescription
indexDesc)
        Set Oid
systemIndexOids

    existingIndexes :: Set IndexMigrationKey
existingIndexes =
      [IndexMigrationKey] -> Set IndexMigrationKey
forall a. Ord a => [a] -> Set a
Set.fromList
        ([IndexMigrationKey] -> Set IndexMigrationKey)
-> (RelationDescription -> [IndexMigrationKey])
-> RelationDescription
-> Set IndexMigrationKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndexDescription -> [IndexMigrationKey])
-> [IndexDescription] -> [IndexMigrationKey]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap IndexDescription -> [IndexMigrationKey]
pgIndexMigrationKeys
        ([IndexDescription] -> [IndexMigrationKey])
-> (RelationDescription -> [IndexDescription])
-> RelationDescription
-> [IndexMigrationKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IndexDescription -> Bool)
-> [IndexDescription] -> [IndexDescription]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (IndexDescription -> Bool) -> IndexDescription -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexDescription -> Bool
isSystemIndex)
        ([IndexDescription] -> [IndexDescription])
-> (RelationDescription -> [IndexDescription])
-> RelationDescription
-> [IndexDescription]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationDescription -> [IndexDescription]
PgCatalog.relationIndexes
        (RelationDescription -> Set IndexMigrationKey)
-> RelationDescription -> Set IndexMigrationKey
forall a b. (a -> b) -> a -> b
$ RelationDescription
relationDesc

    indexesToKeep :: Set IndexMigrationKey
indexesToKeep =
      Map IndexMigrationKey IndexDefinition -> Set IndexMigrationKey
forall k a. Map k a -> Set k
Map.keysSet
        (Map IndexMigrationKey IndexDefinition -> Set IndexMigrationKey)
-> (TableDefinition key writeEntity readEntity
    -> Map IndexMigrationKey IndexDefinition)
-> TableDefinition key writeEntity readEntity
-> Set IndexMigrationKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableDefinition key writeEntity readEntity
-> Map IndexMigrationKey IndexDefinition
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity
-> Map IndexMigrationKey IndexDefinition
Orville.tableIndexes
        (TableDefinition key writeEntity readEntity
 -> Set IndexMigrationKey)
-> TableDefinition key writeEntity readEntity
-> Set IndexMigrationKey
forall a b. (a -> b) -> a -> b
$ TableDefinition key writeEntity readEntity
tableDef

    addIndexSteps :: [MigrationStepWithType]
addIndexSteps =
      (IndexDefinition -> [MigrationStepWithType])
-> Map IndexMigrationKey IndexDefinition -> [MigrationStepWithType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (Set IndexMigrationKey
-> Qualified TableName
-> IndexDefinition
-> [MigrationStepWithType]
mkAddIndexSteps Set IndexMigrationKey
existingIndexes Qualified TableName
tableName)
        (TableDefinition key writeEntity readEntity
-> Map IndexMigrationKey IndexDefinition
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity
-> Map IndexMigrationKey IndexDefinition
Orville.tableIndexes TableDefinition key writeEntity readEntity
tableDef)

    dropIndexSteps :: [MigrationStepWithType]
dropIndexSteps =
      (IndexDescription -> [MigrationStepWithType])
-> [IndexDescription] -> [MigrationStepWithType]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap
        (Set IndexMigrationKey
-> Set Oid -> IndexDescription -> [MigrationStepWithType]
mkDropIndexSteps Set IndexMigrationKey
indexesToKeep Set Oid
systemIndexOids)
        (RelationDescription -> [IndexDescription]
PgCatalog.relationIndexes RelationDescription
relationDesc)

    tableName :: Qualified TableName
tableName =
      TableDefinition key writeEntity readEntity -> Qualified TableName
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> Qualified TableName
Orville.tableName TableDefinition key writeEntity readEntity
tableDef
  in
    Qualified TableName
-> [AlterTableAction] -> [MigrationStepWithType]
mkAlterColumnSteps Qualified TableName
tableName ([AlterTableAction]
addAlterColumnActions [AlterTableAction] -> [AlterTableAction] -> [AlterTableAction]
forall a. Semigroup a => a -> a -> a
<> [AlterTableAction]
dropColumnActions)
      [MigrationStepWithType]
-> [MigrationStepWithType] -> [MigrationStepWithType]
forall a. Semigroup a => a -> a -> a
<> Qualified TableName
-> [(StepType, AlterTableAction)] -> [MigrationStepWithType]
mkConstraintSteps Qualified TableName
tableName ([(StepType, AlterTableAction)]
addConstraintActions [(StepType, AlterTableAction)]
-> [(StepType, AlterTableAction)] -> [(StepType, AlterTableAction)]
forall a. Semigroup a => a -> a -> a
<> [(StepType, AlterTableAction)]
dropConstraintActions)
      [MigrationStepWithType]
-> [MigrationStepWithType] -> [MigrationStepWithType]
forall a. Semigroup a => a -> a -> a
<> [MigrationStepWithType]
addIndexSteps
      [MigrationStepWithType]
-> [MigrationStepWithType] -> [MigrationStepWithType]
forall a. Semigroup a => a -> a -> a
<> [MigrationStepWithType]
dropIndexSteps

{- |
  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.Qualified Expr.TableName ->
  [(StepType, Expr.AlterTableAction)] ->
  [MigrationStepWithType]
mkConstraintSteps :: Qualified TableName
-> [(StepType, AlterTableAction)] -> [MigrationStepWithType]
mkConstraintSteps Qualified TableName
tableName [(StepType, AlterTableAction)]
actions =
  let
    mkMapEntry ::
      (StepType, Expr.AlterTableAction) ->
      (StepType, NonEmpty Expr.AlterTableAction)
    mkMapEntry :: (StepType, AlterTableAction)
-> (StepType, NonEmpty AlterTableAction)
mkMapEntry (StepType
keyType, AlterTableAction
action) =
      (StepType
keyType, (AlterTableAction
action AlterTableAction -> [AlterTableAction] -> NonEmpty AlterTableAction
forall a. a -> [a] -> NonEmpty a
:| []))

    addStep :: StepType
-> NonEmpty AlterTableAction
-> [MigrationStepWithType]
-> [MigrationStepWithType]
addStep StepType
stepType NonEmpty AlterTableAction
actionExprs [MigrationStepWithType]
steps =
      StepType -> AlterTableExpr -> MigrationStepWithType
forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType StepType
stepType (Qualified TableName -> NonEmpty AlterTableAction -> AlterTableExpr
Expr.alterTableExpr Qualified TableName
tableName NonEmpty AlterTableAction
actionExprs) MigrationStepWithType
-> [MigrationStepWithType] -> [MigrationStepWithType]
forall a. a -> [a] -> [a]
: [MigrationStepWithType]
steps
  in
    (StepType
 -> NonEmpty AlterTableAction
 -> [MigrationStepWithType]
 -> [MigrationStepWithType])
-> [MigrationStepWithType]
-> Map StepType (NonEmpty AlterTableAction)
-> [MigrationStepWithType]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey StepType
-> NonEmpty AlterTableAction
-> [MigrationStepWithType]
-> [MigrationStepWithType]
addStep []
      (Map StepType (NonEmpty AlterTableAction)
 -> [MigrationStepWithType])
-> ([(StepType, AlterTableAction)]
    -> Map StepType (NonEmpty AlterTableAction))
-> [(StepType, AlterTableAction)]
-> [MigrationStepWithType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty AlterTableAction
 -> NonEmpty AlterTableAction -> NonEmpty AlterTableAction)
-> [(StepType, NonEmpty AlterTableAction)]
-> Map StepType (NonEmpty AlterTableAction)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith NonEmpty AlterTableAction
-> NonEmpty AlterTableAction -> NonEmpty AlterTableAction
forall a. Semigroup a => a -> a -> a
(<>)
      ([(StepType, NonEmpty AlterTableAction)]
 -> Map StepType (NonEmpty AlterTableAction))
-> ([(StepType, AlterTableAction)]
    -> [(StepType, NonEmpty AlterTableAction)])
-> [(StepType, AlterTableAction)]
-> Map StepType (NonEmpty AlterTableAction)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((StepType, AlterTableAction)
 -> (StepType, NonEmpty AlterTableAction))
-> [(StepType, AlterTableAction)]
-> [(StepType, NonEmpty AlterTableAction)]
forall a b. (a -> b) -> [a] -> [b]
map (StepType, AlterTableAction)
-> (StepType, NonEmpty AlterTableAction)
mkMapEntry
      ([(StepType, AlterTableAction)] -> [MigrationStepWithType])
-> [(StepType, AlterTableAction)] -> [MigrationStepWithType]
forall a b. (a -> b) -> a -> b
$ [(StepType, AlterTableAction)]
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.Qualified Expr.TableName ->
  [Expr.AlterTableAction] ->
  [MigrationStepWithType]
mkAlterColumnSteps :: Qualified TableName
-> [AlterTableAction] -> [MigrationStepWithType]
mkAlterColumnSteps Qualified TableName
tableName [AlterTableAction]
actionExprs =
  case [AlterTableAction] -> Maybe (NonEmpty AlterTableAction)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [AlterTableAction]
actionExprs of
    Maybe (NonEmpty AlterTableAction)
Nothing ->
      []
    Just NonEmpty AlterTableAction
nonEmptyActionExprs ->
      [StepType -> AlterTableExpr -> MigrationStepWithType
forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType StepType
AddRemoveTablesAndColumns (Qualified TableName -> NonEmpty AlterTableAction -> AlterTableExpr
Expr.alterTableExpr Qualified TableName
tableName NonEmpty AlterTableAction
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 :: forall nullability a.
RelationDescription
-> FieldDefinition nullability a -> [AlterTableAction]
mkAddAlterColumnActions RelationDescription
relationDesc FieldDefinition nullability a
fieldDef =
  let
    pgAttributeName :: AttributeName
pgAttributeName =
      String -> AttributeName
forall a. IsString a => String -> a
String.fromString (FieldName -> String
Orville.fieldNameToString (FieldName -> String) -> FieldName -> String
forall a b. (a -> b) -> a -> b
$ FieldDefinition nullability a -> FieldName
forall nullability a. FieldDefinition nullability a -> FieldName
Orville.fieldName FieldDefinition nullability a
fieldDef)
  in
    case AttributeName -> RelationDescription -> Maybe PgAttribute
PgCatalog.lookupAttribute AttributeName
pgAttributeName RelationDescription
relationDesc of
      Just PgAttribute
attr
        | PgAttribute -> Bool
PgCatalog.isOrdinaryColumn PgAttribute
attr ->
            let
              sqlType :: SqlType a
sqlType =
                FieldDefinition nullability a -> SqlType a
forall nullability a. FieldDefinition nullability a -> SqlType a
Orville.fieldType FieldDefinition nullability a
fieldDef

              typeIsChanged :: Bool
typeIsChanged =
                (SqlType a -> Oid
forall a. SqlType a -> Oid
Orville.sqlTypeOid SqlType a
sqlType Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
/= PgAttribute -> Oid
PgCatalog.pgAttributeTypeOid PgAttribute
attr)
                  Bool -> Bool -> Bool
|| (SqlType a -> Maybe Int32
forall a. SqlType a -> Maybe Int32
Orville.sqlTypeMaximumLength SqlType a
sqlType Maybe Int32 -> Maybe Int32 -> Bool
forall a. Eq a => a -> a -> Bool
/= PgAttribute -> Maybe Int32
PgCatalog.pgAttributeMaxLength PgAttribute
attr)

              columnName :: ColumnName
columnName =
                FieldDefinition nullability a -> ColumnName
forall nullability a. FieldDefinition nullability a -> ColumnName
Orville.fieldColumnName FieldDefinition nullability a
fieldDef

              dataType :: DataType
dataType =
                SqlType a -> DataType
forall a. SqlType a -> DataType
Orville.sqlTypeExpr SqlType a
sqlType

              alterType :: [AlterTableAction]
alterType = do
                Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
typeIsChanged
                [ColumnName -> DataType -> Maybe UsingClause -> AlterTableAction
Expr.alterColumnType ColumnName
columnName DataType
dataType (UsingClause -> Maybe UsingClause
forall a. a -> Maybe a
Just (UsingClause -> Maybe UsingClause)
-> UsingClause -> Maybe UsingClause
forall a b. (a -> b) -> a -> b
$ ColumnName -> DataType -> UsingClause
Expr.usingCast ColumnName
columnName DataType
dataType)]

              nullabilityIsChanged :: Bool
nullabilityIsChanged =
                FieldDefinition nullability a -> Bool
forall nullability a. FieldDefinition nullability a -> Bool
Orville.fieldIsNotNullable FieldDefinition nullability a
fieldDef Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= PgAttribute -> Bool
PgCatalog.pgAttributeIsNotNull PgAttribute
attr

              nullabilityAction :: AlterNotNull
nullabilityAction =
                if FieldDefinition nullability a -> Bool
forall nullability a. FieldDefinition nullability a -> Bool
Orville.fieldIsNotNullable FieldDefinition nullability a
fieldDef
                  then AlterNotNull
Expr.setNotNull
                  else AlterNotNull
Expr.dropNotNull

              alterNullability :: [AlterTableAction]
alterNullability = do
                Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
nullabilityIsChanged
                [ColumnName -> AlterNotNull -> AlterTableAction
Expr.alterColumnNullability (FieldDefinition nullability a -> ColumnName
forall nullability a. FieldDefinition nullability a -> ColumnName
Orville.fieldColumnName FieldDefinition nullability a
fieldDef) AlterNotNull
nullabilityAction]

              maybeExistingDefault :: Maybe PgAttributeDefault
maybeExistingDefault =
                PgAttribute -> RelationDescription -> Maybe PgAttributeDefault
PgCatalog.lookupAttributeDefault PgAttribute
attr RelationDescription
relationDesc

              maybeDefaultExpr :: Maybe ValueExpression
maybeDefaultExpr =
                DefaultValue a -> ValueExpression
forall a. DefaultValue a -> ValueExpression
Orville.defaultValueExpression
                  (DefaultValue a -> ValueExpression)
-> Maybe (DefaultValue a) -> Maybe ValueExpression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldDefinition nullability a -> Maybe (DefaultValue a)
forall nullability a.
FieldDefinition nullability a -> Maybe (DefaultValue a)
Orville.fieldDefaultValue FieldDefinition nullability a
fieldDef

              (Maybe AlterTableAction
dropDefault, Maybe AlterTableAction
setDefault) =
                case (Maybe PgAttributeDefault
maybeExistingDefault, Maybe ValueExpression
maybeDefaultExpr) of
                  (Maybe PgAttributeDefault
Nothing, Maybe ValueExpression
Nothing) ->
                    (Maybe AlterTableAction
forall a. Maybe a
Nothing, Maybe AlterTableAction
forall a. Maybe a
Nothing)
                  (Just PgAttributeDefault
_, Maybe ValueExpression
Nothing) ->
                    if SqlType a -> Bool
forall a. SqlType a -> Bool
Orville.sqlTypeDontDropImplicitDefaultDuringMigrate SqlType a
sqlType
                      then (Maybe AlterTableAction
forall a. Maybe a
Nothing, Maybe AlterTableAction
forall a. Maybe a
Nothing)
                      else
                        ( AlterTableAction -> Maybe AlterTableAction
forall a. a -> Maybe a
Just (ColumnName -> AlterTableAction
Expr.alterColumnDropDefault ColumnName
columnName)
                        , Maybe AlterTableAction
forall a. Maybe a
Nothing
                        )
                  (Maybe PgAttributeDefault
Nothing, Just ValueExpression
newDefault) ->
                    ( Maybe AlterTableAction
forall a. Maybe a
Nothing
                    , AlterTableAction -> Maybe AlterTableAction
forall a. a -> Maybe a
Just (ColumnName -> ValueExpression -> AlterTableAction
forall valueExpression.
SqlExpression valueExpression =>
ColumnName -> valueExpression -> AlterTableAction
Expr.alterColumnSetDefault ColumnName
columnName ValueExpression
newDefault)
                    )
                  (Just PgAttributeDefault
oldDefault, Just ValueExpression
newDefault) ->
                    let
                      oldDefaultExprBytes :: ByteString
oldDefaultExprBytes =
                        Text -> ByteString
Enc.encodeUtf8
                          (Text -> ByteString)
-> (PgAttributeDefault -> Text) -> PgAttributeDefault -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgAttributeDefault -> Text
PgCatalog.pgAttributeDefaultExpression
                          (PgAttributeDefault -> ByteString)
-> PgAttributeDefault -> ByteString
forall a b. (a -> b) -> a -> b
$ PgAttributeDefault
oldDefault

                      newDefaultExprBytes :: ByteString
newDefaultExprBytes =
                        ValueExpression -> ByteString
forall sql. SqlExpression sql => sql -> ByteString
RawSql.toExampleBytes ValueExpression
newDefault
                    in
                      if ByteString
oldDefaultExprBytes ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
newDefaultExprBytes
                        then (Maybe AlterTableAction
forall a. Maybe a
Nothing, Maybe AlterTableAction
forall a. Maybe a
Nothing)
                        else
                          ( AlterTableAction -> Maybe AlterTableAction
forall a. a -> Maybe a
Just (ColumnName -> AlterTableAction
Expr.alterColumnDropDefault ColumnName
columnName)
                          , AlterTableAction -> Maybe AlterTableAction
forall a. a -> Maybe a
Just (ColumnName -> ValueExpression -> AlterTableAction
forall valueExpression.
SqlExpression valueExpression =>
ColumnName -> valueExpression -> AlterTableAction
Expr.alterColumnSetDefault ColumnName
columnName ValueExpression
newDefault)
                          )
            in
              Maybe AlterTableAction -> [AlterTableAction]
forall a. Maybe a -> [a]
Maybe.maybeToList Maybe AlterTableAction
dropDefault [AlterTableAction] -> [AlterTableAction] -> [AlterTableAction]
forall a. Semigroup a => a -> a -> a
<> [AlterTableAction]
alterType [AlterTableAction] -> [AlterTableAction] -> [AlterTableAction]
forall a. Semigroup a => a -> a -> a
<> Maybe AlterTableAction -> [AlterTableAction]
forall a. Maybe a -> [a]
Maybe.maybeToList Maybe AlterTableAction
setDefault [AlterTableAction] -> [AlterTableAction] -> [AlterTableAction]
forall a. Semigroup a => a -> a -> a
<> [AlterTableAction]
alterNullability
      Maybe PgAttribute
_ ->
        -- 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.
        [ColumnDefinition -> AlterTableAction
Expr.addColumn (FieldDefinition nullability a -> ColumnDefinition
forall nullability a.
FieldDefinition nullability a -> ColumnDefinition
Orville.fieldColumnDefinition FieldDefinition nullability a
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 :: forall key readEntity writeEntity.
TableDefinition key readEntity writeEntity
-> PgAttribute -> [AlterTableAction]
mkDropColumnActions TableDefinition key readEntity writeEntity
tableDef PgAttribute
attr = do
  let
    attrName :: String
attrName =
      AttributeName -> String
PgCatalog.attributeNameToString (AttributeName -> String) -> AttributeName -> String
forall a b. (a -> b) -> a -> b
$ PgAttribute -> AttributeName
PgCatalog.pgAttributeName PgAttribute
attr

  Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> [()]) -> Bool -> [()]
forall a b. (a -> b) -> a -> b
$ String -> Set String -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member String
attrName (TableDefinition key readEntity writeEntity -> Set String
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> Set String
Orville.columnsToDrop TableDefinition key readEntity writeEntity
tableDef)

  [ColumnName -> AlterTableAction
Expr.dropColumn (ColumnName -> AlterTableAction) -> ColumnName -> AlterTableAction
forall a b. (a -> b) -> a -> b
$ String -> ColumnName
Expr.columnName String
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 :: NamespaceName -> ConstraintMigrationKey -> ConstraintMigrationKey
setDefaultSchemaNameOnConstraintKey NamespaceName
currentNamespace ConstraintMigrationKey
constraintKey =
  case ConstraintMigrationKey -> Maybe TableIdentifier
Orville.constraintKeyForeignTable ConstraintMigrationKey
constraintKey of
    Maybe TableIdentifier
Nothing ->
      ConstraintMigrationKey
constraintKey
    Just TableIdentifier
foreignTable ->
      case TableIdentifier -> Maybe String
Orville.tableIdSchemaNameString TableIdentifier
foreignTable of
        Maybe String
Nothing ->
          ConstraintMigrationKey
constraintKey
            { constraintKeyForeignTable :: Maybe TableIdentifier
Orville.constraintKeyForeignTable =
                TableIdentifier -> Maybe TableIdentifier
forall a. a -> Maybe a
Just (TableIdentifier -> Maybe TableIdentifier)
-> TableIdentifier -> Maybe TableIdentifier
forall a b. (a -> b) -> a -> b
$
                  String -> TableIdentifier -> TableIdentifier
Orville.setTableIdSchema
                    (NamespaceName -> String
PgCatalog.namespaceNameToString NamespaceName
currentNamespace)
                    TableIdentifier
foreignTable
            }
        Just String
_ ->
          ConstraintMigrationKey
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 :: NamespaceName
-> Set ConstraintMigrationKey
-> ConstraintDefinition
-> [(StepType, AlterTableAction)]
mkAddConstraintActions NamespaceName
currentNamespace Set ConstraintMigrationKey
existingConstraints ConstraintDefinition
constraintDef =
  let
    constraintKey :: ConstraintMigrationKey
constraintKey =
      NamespaceName -> ConstraintMigrationKey -> ConstraintMigrationKey
setDefaultSchemaNameOnConstraintKey NamespaceName
currentNamespace (ConstraintMigrationKey -> ConstraintMigrationKey)
-> ConstraintMigrationKey -> ConstraintMigrationKey
forall a b. (a -> b) -> a -> b
$
        ConstraintDefinition -> ConstraintMigrationKey
Orville.constraintMigrationKey ConstraintDefinition
constraintDef

    stepType :: StepType
stepType =
      case ConstraintMigrationKey -> ConstraintKeyType
Orville.constraintKeyType ConstraintMigrationKey
constraintKey of
        ConstraintKeyType
Orville.UniqueConstraint -> StepType
AddUniqueConstraints
        ConstraintKeyType
Orville.ForeignKeyConstraint -> StepType
AddForeignKeys
  in
    if ConstraintMigrationKey -> Set ConstraintMigrationKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ConstraintMigrationKey
constraintKey Set ConstraintMigrationKey
existingConstraints
      then []
      else [(StepType
stepType, TableConstraint -> AlterTableAction
Expr.addConstraint (ConstraintDefinition -> TableConstraint
Orville.constraintSqlExpr ConstraintDefinition
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 :: Set ConstraintMigrationKey
-> ConstraintDescription -> [(StepType, AlterTableAction)]
mkDropConstraintActions Set ConstraintMigrationKey
constraintsToKeep ConstraintDescription
constraint =
  case ConstraintDescription -> Maybe ConstraintMigrationKey
pgConstraintMigrationKey ConstraintDescription
constraint of
    Maybe ConstraintMigrationKey
Nothing ->
      []
    Just ConstraintMigrationKey
constraintKey ->
      if ConstraintMigrationKey -> Set ConstraintMigrationKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ConstraintMigrationKey
constraintKey Set ConstraintMigrationKey
constraintsToKeep
        then []
        else
          let
            constraintName :: ConstraintName
constraintName =
              String -> ConstraintName
Expr.constraintName
                (String -> ConstraintName)
-> (ConstraintDescription -> String)
-> ConstraintDescription
-> ConstraintName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintName -> String
PgCatalog.constraintNameToString
                (ConstraintName -> String)
-> (ConstraintDescription -> ConstraintName)
-> ConstraintDescription
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgConstraint -> ConstraintName
PgCatalog.pgConstraintName
                (PgConstraint -> ConstraintName)
-> (ConstraintDescription -> PgConstraint)
-> ConstraintDescription
-> ConstraintName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstraintDescription -> PgConstraint
PgCatalog.constraintRecord
                (ConstraintDescription -> ConstraintName)
-> ConstraintDescription -> ConstraintName
forall a b. (a -> b) -> a -> b
$ ConstraintDescription
constraint

            stepType :: StepType
stepType =
              case ConstraintMigrationKey -> ConstraintKeyType
Orville.constraintKeyType ConstraintMigrationKey
constraintKey of
                ConstraintKeyType
Orville.UniqueConstraint -> StepType
DropUniqueConstraints
                ConstraintKeyType
Orville.ForeignKeyConstraint -> StepType
DropForeignKeys
          in
            [(StepType
stepType, ConstraintName -> AlterTableAction
Expr.dropConstraint ConstraintName
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 :: ConstraintDescription -> Maybe ConstraintMigrationKey
pgConstraintMigrationKey ConstraintDescription
constraintDesc =
  let
    toOrvilleConstraintKeyType :: ConstraintType -> Maybe ConstraintKeyType
toOrvilleConstraintKeyType ConstraintType
pgConType =
      case ConstraintType
pgConType of
        ConstraintType
PgCatalog.UniqueConstraint -> ConstraintKeyType -> Maybe ConstraintKeyType
forall a. a -> Maybe a
Just ConstraintKeyType
Orville.UniqueConstraint
        ConstraintType
PgCatalog.ForeignKeyConstraint -> ConstraintKeyType -> Maybe ConstraintKeyType
forall a. a -> Maybe a
Just ConstraintKeyType
Orville.ForeignKeyConstraint
        ConstraintType
_ -> Maybe ConstraintKeyType
forall a. Maybe a
Nothing

    constraint :: PgConstraint
constraint =
      ConstraintDescription -> PgConstraint
PgCatalog.constraintRecord ConstraintDescription
constraintDesc

    pgAttributeNamesToFieldNames :: [PgAttribute] -> [FieldName]
pgAttributeNamesToFieldNames =
      (PgAttribute -> FieldName) -> [PgAttribute] -> [FieldName]
forall a b. (a -> b) -> [a] -> [b]
map (String -> FieldName
Orville.stringToFieldName (String -> FieldName)
-> (PgAttribute -> String) -> PgAttribute -> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttributeName -> String
PgCatalog.attributeNameToString (AttributeName -> String)
-> (PgAttribute -> AttributeName) -> PgAttribute -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgAttribute -> AttributeName
PgCatalog.pgAttributeName)

    foreignRelationTableId :: PgCatalog.ForeignRelationDescription -> Orville.TableIdentifier
    foreignRelationTableId :: ForeignRelationDescription -> TableIdentifier
foreignRelationTableId ForeignRelationDescription
foreignRelationDesc =
      let
        relationName :: String
relationName =
          RelationName -> String
PgCatalog.relationNameToString
            (RelationName -> String)
-> (ForeignRelationDescription -> RelationName)
-> ForeignRelationDescription
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgClass -> RelationName
PgCatalog.pgClassRelationName
            (PgClass -> RelationName)
-> (ForeignRelationDescription -> PgClass)
-> ForeignRelationDescription
-> RelationName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignRelationDescription -> PgClass
PgCatalog.foreignRelationClass
            (ForeignRelationDescription -> String)
-> ForeignRelationDescription -> String
forall a b. (a -> b) -> a -> b
$ ForeignRelationDescription
foreignRelationDesc

        namespaceName :: String
namespaceName =
          NamespaceName -> String
PgCatalog.namespaceNameToString
            (NamespaceName -> String)
-> (ForeignRelationDescription -> NamespaceName)
-> ForeignRelationDescription
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgNamespace -> NamespaceName
PgCatalog.pgNamespaceName
            (PgNamespace -> NamespaceName)
-> (ForeignRelationDescription -> PgNamespace)
-> ForeignRelationDescription
-> NamespaceName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignRelationDescription -> PgNamespace
PgCatalog.foreignRelationNamespace
            (ForeignRelationDescription -> String)
-> ForeignRelationDescription -> String
forall a b. (a -> b) -> a -> b
$ ForeignRelationDescription
foreignRelationDesc
      in
        String -> TableIdentifier -> TableIdentifier
Orville.setTableIdSchema String
namespaceName (TableIdentifier -> TableIdentifier)
-> TableIdentifier -> TableIdentifier
forall a b. (a -> b) -> a -> b
$
          String -> TableIdentifier
Orville.unqualifiedNameToTableId String
relationName
  in
    do
      ConstraintKeyType
keyType <- ConstraintType -> Maybe ConstraintKeyType
toOrvilleConstraintKeyType (PgConstraint -> ConstraintType
PgCatalog.pgConstraintType PgConstraint
constraint)
      ConstraintMigrationKey -> Maybe ConstraintMigrationKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConstraintMigrationKey -> Maybe ConstraintMigrationKey)
-> ConstraintMigrationKey -> Maybe ConstraintMigrationKey
forall a b. (a -> b) -> a -> b
$
        Orville.ConstraintMigrationKey
          { constraintKeyType :: ConstraintKeyType
Orville.constraintKeyType = ConstraintKeyType
keyType
          , constraintKeyColumns :: Maybe [FieldName]
Orville.constraintKeyColumns =
              ([PgAttribute] -> [FieldName])
-> Maybe [PgAttribute] -> Maybe [FieldName]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                [PgAttribute] -> [FieldName]
pgAttributeNamesToFieldNames
                (ConstraintDescription -> Maybe [PgAttribute]
PgCatalog.constraintKey ConstraintDescription
constraintDesc)
          , constraintKeyForeignTable :: Maybe TableIdentifier
Orville.constraintKeyForeignTable =
              (ForeignRelationDescription -> TableIdentifier)
-> Maybe ForeignRelationDescription -> Maybe TableIdentifier
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignRelationDescription -> TableIdentifier
foreignRelationTableId (ConstraintDescription -> Maybe ForeignRelationDescription
PgCatalog.constraintForeignRelation ConstraintDescription
constraintDesc)
          , constraintKeyForeignColumns :: Maybe [FieldName]
Orville.constraintKeyForeignColumns =
              ([PgAttribute] -> [FieldName])
-> Maybe [PgAttribute] -> Maybe [FieldName]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
                [PgAttribute] -> [FieldName]
pgAttributeNamesToFieldNames
                (ConstraintDescription -> Maybe [PgAttribute]
PgCatalog.constraintForeignKey ConstraintDescription
constraintDesc)
          , constraintKeyForeignKeyOnUpdateAction :: Maybe ForeignKeyAction
Orville.constraintKeyForeignKeyOnUpdateAction =
              PgConstraint -> Maybe ForeignKeyAction
PgCatalog.pgConstraintForeignKeyOnUpdateType (PgConstraint -> Maybe ForeignKeyAction)
-> PgConstraint -> Maybe ForeignKeyAction
forall a b. (a -> b) -> a -> b
$ ConstraintDescription -> PgConstraint
PgCatalog.constraintRecord ConstraintDescription
constraintDesc
          , constraintKeyForeignKeyOnDeleteAction :: Maybe ForeignKeyAction
Orville.constraintKeyForeignKeyOnDeleteAction =
              PgConstraint -> Maybe ForeignKeyAction
PgCatalog.pgConstraintForeignKeyOnDeleteType (PgConstraint -> Maybe ForeignKeyAction)
-> PgConstraint -> Maybe ForeignKeyAction
forall a b. (a -> b) -> a -> b
$ ConstraintDescription -> PgConstraint
PgCatalog.constraintRecord ConstraintDescription
constraintDesc
          }

{- |
  Builds migration steps to create an index if it does not exist.

@since 1.0.0.0
-}
mkAddIndexSteps ::
  Set.Set IndexDefinition.IndexMigrationKey ->
  Expr.Qualified Expr.TableName ->
  Orville.IndexDefinition ->
  [MigrationStepWithType]
mkAddIndexSteps :: Set IndexMigrationKey
-> Qualified TableName
-> IndexDefinition
-> [MigrationStepWithType]
mkAddIndexSteps Set IndexMigrationKey
existingIndexes Qualified TableName
tableName IndexDefinition
indexDef =
  let
    indexKey :: IndexMigrationKey
indexKey =
      IndexDefinition -> IndexMigrationKey
IndexDefinition.indexMigrationKey IndexDefinition
indexDef

    indexStep :: StepType
indexStep =
      case IndexDefinition -> IndexCreationStrategy
Orville.indexCreationStrategy IndexDefinition
indexDef of
        IndexCreationStrategy
Orville.Transactional -> StepType
AddIndexesTransactionally
        IndexCreationStrategy
Orville.Concurrent -> StepType
AddIndexesConcurrently
  in
    if IndexMigrationKey -> Set IndexMigrationKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member IndexMigrationKey
indexKey Set IndexMigrationKey
existingIndexes
      then []
      else [StepType -> CreateIndexExpr -> MigrationStepWithType
forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType StepType
indexStep (IndexDefinition -> Qualified TableName -> CreateIndexExpr
Orville.indexCreateExpr IndexDefinition
indexDef Qualified TableName
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 ->
  PgCatalog.IndexDescription ->
  [MigrationStepWithType]
mkDropIndexSteps :: Set IndexMigrationKey
-> Set Oid -> IndexDescription -> [MigrationStepWithType]
mkDropIndexSteps Set IndexMigrationKey
indexesToKeep Set Oid
systemIndexOids IndexDescription
indexDesc =
  case IndexDescription -> [IndexMigrationKey]
pgIndexMigrationKeys IndexDescription
indexDesc of
    [] ->
      []
    [IndexMigrationKey]
indexKeys ->
      let
        pgClass :: PgClass
pgClass =
          IndexDescription -> PgClass
PgCatalog.indexPgClass IndexDescription
indexDesc

        indexName :: IndexName
indexName =
          String -> IndexName
Expr.indexName
            (String -> IndexName)
-> (PgClass -> String) -> PgClass -> IndexName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationName -> String
PgCatalog.relationNameToString
            (RelationName -> String)
-> (PgClass -> RelationName) -> PgClass -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgClass -> RelationName
PgCatalog.pgClassRelationName
            (PgClass -> IndexName) -> PgClass -> IndexName
forall a b. (a -> b) -> a -> b
$ PgClass
pgClass

        indexOid :: Oid
indexOid =
          PgClass -> Oid
PgCatalog.pgClassOid PgClass
pgClass
      in
        if (IndexMigrationKey -> Bool) -> [IndexMigrationKey] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((IndexMigrationKey -> Set IndexMigrationKey -> Bool)
-> Set IndexMigrationKey -> IndexMigrationKey -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip IndexMigrationKey -> Set IndexMigrationKey -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Set IndexMigrationKey
indexesToKeep) [IndexMigrationKey]
indexKeys
          Bool -> Bool -> Bool
|| Oid -> Set Oid -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Oid
indexOid Set Oid
systemIndexOids
          then []
          else [StepType -> DropIndexExpr -> MigrationStepWithType
forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType StepType
DropIndexes (IndexName -> DropIndexExpr
Expr.dropIndexExpr IndexName
indexName)]

{- |
  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 -> Maybe Oid
pgConstraintImpliedIndexOid PgConstraint
pgConstraint =
  case PgConstraint -> ConstraintType
PgCatalog.pgConstraintType PgConstraint
pgConstraint of
    ConstraintType
PgCatalog.PrimaryKeyConstraint ->
      Oid -> Maybe Oid
forall a. a -> Maybe a
Just (Oid -> Maybe Oid) -> Oid -> Maybe Oid
forall a b. (a -> b) -> a -> b
$ PgConstraint -> Oid
PgCatalog.pgConstraintIndexOid PgConstraint
pgConstraint
    ConstraintType
PgCatalog.UniqueConstraint ->
      Oid -> Maybe Oid
forall a. a -> Maybe a
Just (Oid -> Maybe Oid) -> Oid -> Maybe Oid
forall a b. (a -> b) -> a -> b
$ PgConstraint -> Oid
PgCatalog.pgConstraintIndexOid PgConstraint
pgConstraint
    ConstraintType
PgCatalog.ExclusionConstraint ->
      Oid -> Maybe Oid
forall a. a -> Maybe a
Just (Oid -> Maybe Oid) -> Oid -> Maybe Oid
forall a b. (a -> b) -> a -> b
$ PgConstraint -> Oid
PgCatalog.pgConstraintIndexOid PgConstraint
pgConstraint
    ConstraintType
PgCatalog.CheckConstraint ->
      Maybe Oid
forall a. Maybe a
Nothing
    ConstraintType
PgCatalog.ForeignKeyConstraint ->
      Maybe Oid
forall a. Maybe a
Nothing
    ConstraintType
PgCatalog.ConstraintTrigger ->
      Maybe Oid
forall a. Maybe a
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 :: IndexDescription -> [IndexMigrationKey]
pgIndexMigrationKeys IndexDescription
indexDesc =
  let
    mkNamedIndexKey :: IndexMigrationKey
mkNamedIndexKey =
      String -> IndexMigrationKey
IndexDefinition.NamedIndexKey
        (String -> IndexMigrationKey)
-> (IndexDescription -> String)
-> IndexDescription
-> IndexMigrationKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RelationName -> String
PgCatalog.relationNameToString
        (RelationName -> String)
-> (IndexDescription -> RelationName) -> IndexDescription -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgClass -> RelationName
PgCatalog.pgClassRelationName
        (PgClass -> RelationName)
-> (IndexDescription -> PgClass)
-> IndexDescription
-> RelationName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexDescription -> PgClass
PgCatalog.indexPgClass
        (IndexDescription -> IndexMigrationKey)
-> IndexDescription -> IndexMigrationKey
forall a b. (a -> b) -> a -> b
$ IndexDescription
indexDesc
    mkAttributeBasedIndexKey :: [IndexMigrationKey]
mkAttributeBasedIndexKey =
      case IndexDescription -> Maybe AttributeBasedIndexMigrationKey
pgAttributeBasedIndexMigrationKey IndexDescription
indexDesc of
        Just AttributeBasedIndexMigrationKey
standardKey ->
          [AttributeBasedIndexMigrationKey -> IndexMigrationKey
IndexDefinition.AttributeBasedIndexKey AttributeBasedIndexMigrationKey
standardKey]
        Maybe AttributeBasedIndexMigrationKey
Nothing ->
          []
  in
    [IndexMigrationKey
mkNamedIndexKey] [IndexMigrationKey] -> [IndexMigrationKey] -> [IndexMigrationKey]
forall a. [a] -> [a] -> [a]
++ [IndexMigrationKey]
mkAttributeBasedIndexKey

pgAttributeBasedIndexMigrationKey ::
  PgCatalog.IndexDescription ->
  Maybe IndexDefinition.AttributeBasedIndexMigrationKey
pgAttributeBasedIndexMigrationKey :: IndexDescription -> Maybe AttributeBasedIndexMigrationKey
pgAttributeBasedIndexMigrationKey IndexDescription
indexDesc = do
  let
    indexMemberToFieldName :: IndexMember -> Maybe FieldName
indexMemberToFieldName IndexMember
member =
      case IndexMember
member of
        PgCatalog.IndexAttribute PgAttribute
attr ->
          FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just (String -> FieldName
Orville.stringToFieldName (String -> FieldName)
-> (PgAttribute -> String) -> PgAttribute -> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AttributeName -> String
PgCatalog.attributeNameToString (AttributeName -> String)
-> (PgAttribute -> AttributeName) -> PgAttribute -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PgAttribute -> AttributeName
PgCatalog.pgAttributeName (PgAttribute -> FieldName) -> PgAttribute -> FieldName
forall a b. (a -> b) -> a -> b
$ PgAttribute
attr)
        IndexMember
PgCatalog.IndexExpression ->
          Maybe FieldName
forall a. Maybe a
Nothing

    uniqueness :: IndexUniqueness
uniqueness =
      if PgIndex -> Bool
PgCatalog.pgIndexIsUnique (IndexDescription -> PgIndex
PgCatalog.indexRecord IndexDescription
indexDesc)
        then IndexUniqueness
Orville.UniqueIndex
        else IndexUniqueness
Orville.NonUniqueIndex

  [FieldName]
fieldNames <- (IndexMember -> Maybe FieldName)
-> [IndexMember] -> Maybe [FieldName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse IndexMember -> Maybe FieldName
indexMemberToFieldName (IndexDescription -> [IndexMember]
PgCatalog.indexMembers IndexDescription
indexDesc)
  AttributeBasedIndexMigrationKey
-> Maybe AttributeBasedIndexMigrationKey
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AttributeBasedIndexMigrationKey
 -> Maybe AttributeBasedIndexMigrationKey)
-> AttributeBasedIndexMigrationKey
-> Maybe AttributeBasedIndexMigrationKey
forall a b. (a -> b) -> a -> b
$
    IndexDefinition.AttributeBasedIndexMigrationKey
      { indexKeyUniqueness :: IndexUniqueness
IndexDefinition.indexKeyUniqueness = IndexUniqueness
uniqueness
      , indexKeyColumns :: [FieldName]
IndexDefinition.indexKeyColumns = [FieldName]
fieldNames
      }

schemaItemPgCatalogRelation ::
  PgCatalog.NamespaceName ->
  SchemaItem ->
  (PgCatalog.NamespaceName, PgCatalog.RelationName)
schemaItemPgCatalogRelation :: NamespaceName -> SchemaItem -> (NamespaceName, RelationName)
schemaItemPgCatalogRelation NamespaceName
currentNamespace SchemaItem
item =
  case SchemaItem
item of
    SchemaTable TableDefinition key writeEntity readEntity
tableDef ->
      NamespaceName -> TableIdentifier -> (NamespaceName, RelationName)
tableIdToPgCatalogNames NamespaceName
currentNamespace (TableDefinition key writeEntity readEntity -> TableIdentifier
forall key writeEntity readEntity.
TableDefinition key writeEntity readEntity -> TableIdentifier
Orville.tableIdentifier TableDefinition key writeEntity readEntity
tableDef)
    SchemaDropTable TableIdentifier
tableId ->
      NamespaceName -> TableIdentifier -> (NamespaceName, RelationName)
tableIdToPgCatalogNames NamespaceName
currentNamespace TableIdentifier
tableId
    SchemaSequence SequenceDefinition
sequenceDef ->
      NamespaceName
-> SequenceIdentifier -> (NamespaceName, RelationName)
sequenceIdToPgCatalogNames NamespaceName
currentNamespace (SequenceDefinition -> SequenceIdentifier
Orville.sequenceIdentifier SequenceDefinition
sequenceDef)
    SchemaDropSequence SequenceIdentifier
sequenceId ->
      NamespaceName
-> SequenceIdentifier -> (NamespaceName, RelationName)
sequenceIdToPgCatalogNames NamespaceName
currentNamespace SequenceIdentifier
sequenceId

tableIdToPgCatalogNames ::
  PgCatalog.NamespaceName ->
  Orville.TableIdentifier ->
  (PgCatalog.NamespaceName, PgCatalog.RelationName)
tableIdToPgCatalogNames :: NamespaceName -> TableIdentifier -> (NamespaceName, RelationName)
tableIdToPgCatalogNames NamespaceName
currentNamespace TableIdentifier
tableId =
  let
    actualNamespace :: NamespaceName
actualNamespace =
      NamespaceName
-> (String -> NamespaceName) -> Maybe String -> NamespaceName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NamespaceName
currentNamespace String -> NamespaceName
forall a. IsString a => String -> a
String.fromString
        (Maybe String -> NamespaceName)
-> (TableIdentifier -> Maybe String)
-> TableIdentifier
-> NamespaceName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIdentifier -> Maybe String
Orville.tableIdSchemaNameString
        (TableIdentifier -> NamespaceName)
-> TableIdentifier -> NamespaceName
forall a b. (a -> b) -> a -> b
$ TableIdentifier
tableId

    relationName :: RelationName
relationName =
      String -> RelationName
forall a. IsString a => String -> a
String.fromString
        (String -> RelationName)
-> (TableIdentifier -> String) -> TableIdentifier -> RelationName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TableIdentifier -> String
Orville.tableIdUnqualifiedNameString
        (TableIdentifier -> RelationName)
-> TableIdentifier -> RelationName
forall a b. (a -> b) -> a -> b
$ TableIdentifier
tableId
  in
    (NamespaceName
actualNamespace, RelationName
relationName)

mkAlterSequenceSteps ::
  Orville.SequenceDefinition ->
  PgCatalog.PgSequence ->
  [MigrationStepWithType]
mkAlterSequenceSteps :: SequenceDefinition -> PgSequence -> [MigrationStepWithType]
mkAlterSequenceSteps SequenceDefinition
sequenceDef PgSequence
pgSequence =
  let
    ifChanged ::
      Eq a =>
      (a -> expr) ->
      (PgCatalog.PgSequence -> a) ->
      (Orville.SequenceDefinition -> a) ->
      Maybe expr
    ifChanged :: forall a expr.
Eq a =>
(a -> expr)
-> (PgSequence -> a) -> (SequenceDefinition -> a) -> Maybe expr
ifChanged a -> expr
mkChange PgSequence -> a
getOld SequenceDefinition -> a
getNew =
      if PgSequence -> a
getOld PgSequence
pgSequence a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== SequenceDefinition -> a
getNew SequenceDefinition
sequenceDef
        then Maybe expr
forall a. Maybe a
Nothing
        else expr -> Maybe expr
forall a. a -> Maybe a
Just (expr -> Maybe expr)
-> (SequenceDefinition -> expr) -> SequenceDefinition -> Maybe expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> expr
mkChange (a -> expr)
-> (SequenceDefinition -> a) -> SequenceDefinition -> expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SequenceDefinition -> a
getNew (SequenceDefinition -> Maybe expr)
-> SequenceDefinition -> Maybe expr
forall a b. (a -> b) -> a -> b
$ SequenceDefinition
sequenceDef

    mbIncrementByExpr :: Maybe IncrementByExpr
mbIncrementByExpr =
      (Int64 -> IncrementByExpr)
-> (PgSequence -> Int64)
-> (SequenceDefinition -> Int64)
-> Maybe IncrementByExpr
forall a expr.
Eq a =>
(a -> expr)
-> (PgSequence -> a) -> (SequenceDefinition -> a) -> Maybe expr
ifChanged Int64 -> IncrementByExpr
Expr.incrementBy PgSequence -> Int64
PgCatalog.pgSequenceIncrement SequenceDefinition -> Int64
Orville.sequenceIncrement

    mbMinValueExpr :: Maybe MinValueExpr
mbMinValueExpr =
      (Int64 -> MinValueExpr)
-> (PgSequence -> Int64)
-> (SequenceDefinition -> Int64)
-> Maybe MinValueExpr
forall a expr.
Eq a =>
(a -> expr)
-> (PgSequence -> a) -> (SequenceDefinition -> a) -> Maybe expr
ifChanged Int64 -> MinValueExpr
Expr.minValue PgSequence -> Int64
PgCatalog.pgSequenceMin SequenceDefinition -> Int64
Orville.sequenceMinValue

    mbMaxValueExpr :: Maybe MaxValueExpr
mbMaxValueExpr =
      (Int64 -> MaxValueExpr)
-> (PgSequence -> Int64)
-> (SequenceDefinition -> Int64)
-> Maybe MaxValueExpr
forall a expr.
Eq a =>
(a -> expr)
-> (PgSequence -> a) -> (SequenceDefinition -> a) -> Maybe expr
ifChanged Int64 -> MaxValueExpr
Expr.maxValue PgSequence -> Int64
PgCatalog.pgSequenceMax SequenceDefinition -> Int64
Orville.sequenceMaxValue

    mbStartWithExpr :: Maybe StartWithExpr
mbStartWithExpr =
      (Int64 -> StartWithExpr)
-> (PgSequence -> Int64)
-> (SequenceDefinition -> Int64)
-> Maybe StartWithExpr
forall a expr.
Eq a =>
(a -> expr)
-> (PgSequence -> a) -> (SequenceDefinition -> a) -> Maybe expr
ifChanged Int64 -> StartWithExpr
Expr.startWith PgSequence -> Int64
PgCatalog.pgSequenceStart SequenceDefinition -> Int64
Orville.sequenceStart

    mbCacheExpr :: Maybe CacheExpr
mbCacheExpr =
      (Int64 -> CacheExpr)
-> (PgSequence -> Int64)
-> (SequenceDefinition -> Int64)
-> Maybe CacheExpr
forall a expr.
Eq a =>
(a -> expr)
-> (PgSequence -> a) -> (SequenceDefinition -> a) -> Maybe expr
ifChanged Int64 -> CacheExpr
Expr.cache PgSequence -> Int64
PgCatalog.pgSequenceCache SequenceDefinition -> Int64
Orville.sequenceCache

    mbCycleExpr :: Maybe CycleExpr
mbCycleExpr =
      (Bool -> CycleExpr)
-> (PgSequence -> Bool)
-> (SequenceDefinition -> Bool)
-> Maybe CycleExpr
forall a expr.
Eq a =>
(a -> expr)
-> (PgSequence -> a) -> (SequenceDefinition -> a) -> Maybe expr
ifChanged Bool -> CycleExpr
Expr.cycleIfTrue PgSequence -> Bool
PgCatalog.pgSequenceCycle SequenceDefinition -> Bool
Orville.sequenceCycle

    applyChange :: (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)
    applyChange :: forall a b. (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)
applyChange (Bool
changed, Maybe a -> b
exprF) Maybe a
mbArg =
      (Bool
changed Bool -> Bool -> Bool
|| Maybe a -> Bool
forall a. Maybe a -> Bool
Maybe.isJust Maybe a
mbArg, Maybe a -> b
exprF Maybe a
mbArg)

    (Bool
anyChanges, AlterSequenceExpr
migrateSequenceExpr) =
      (Bool
False, Qualified SequenceName
-> Maybe IncrementByExpr
-> Maybe MinValueExpr
-> Maybe MaxValueExpr
-> Maybe StartWithExpr
-> Maybe CacheExpr
-> Maybe CycleExpr
-> AlterSequenceExpr
Expr.alterSequenceExpr (SequenceDefinition -> Qualified SequenceName
Orville.sequenceName SequenceDefinition
sequenceDef))
        (Bool,
 Maybe IncrementByExpr
 -> Maybe MinValueExpr
 -> Maybe MaxValueExpr
 -> Maybe StartWithExpr
 -> Maybe CacheExpr
 -> Maybe CycleExpr
 -> AlterSequenceExpr)
-> Maybe IncrementByExpr
-> (Bool,
    Maybe MinValueExpr
    -> Maybe MaxValueExpr
    -> Maybe StartWithExpr
    -> Maybe CacheExpr
    -> Maybe CycleExpr
    -> AlterSequenceExpr)
forall a b. (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)
`applyChange` Maybe IncrementByExpr
mbIncrementByExpr
        (Bool,
 Maybe MinValueExpr
 -> Maybe MaxValueExpr
 -> Maybe StartWithExpr
 -> Maybe CacheExpr
 -> Maybe CycleExpr
 -> AlterSequenceExpr)
-> Maybe MinValueExpr
-> (Bool,
    Maybe MaxValueExpr
    -> Maybe StartWithExpr
    -> Maybe CacheExpr
    -> Maybe CycleExpr
    -> AlterSequenceExpr)
forall a b. (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)
`applyChange` Maybe MinValueExpr
mbMinValueExpr
        (Bool,
 Maybe MaxValueExpr
 -> Maybe StartWithExpr
 -> Maybe CacheExpr
 -> Maybe CycleExpr
 -> AlterSequenceExpr)
-> Maybe MaxValueExpr
-> (Bool,
    Maybe StartWithExpr
    -> Maybe CacheExpr -> Maybe CycleExpr -> AlterSequenceExpr)
forall a b. (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)
`applyChange` Maybe MaxValueExpr
mbMaxValueExpr
        (Bool,
 Maybe StartWithExpr
 -> Maybe CacheExpr -> Maybe CycleExpr -> AlterSequenceExpr)
-> Maybe StartWithExpr
-> (Bool, Maybe CacheExpr -> Maybe CycleExpr -> AlterSequenceExpr)
forall a b. (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)
`applyChange` Maybe StartWithExpr
mbStartWithExpr
        (Bool, Maybe CacheExpr -> Maybe CycleExpr -> AlterSequenceExpr)
-> Maybe CacheExpr -> (Bool, Maybe CycleExpr -> AlterSequenceExpr)
forall a b. (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)
`applyChange` Maybe CacheExpr
mbCacheExpr
        (Bool, Maybe CycleExpr -> AlterSequenceExpr)
-> Maybe CycleExpr -> (Bool, AlterSequenceExpr)
forall a b. (Bool, Maybe a -> b) -> Maybe a -> (Bool, b)
`applyChange` Maybe CycleExpr
mbCycleExpr
  in
    if Bool
anyChanges
      then [StepType -> AlterSequenceExpr -> MigrationStepWithType
forall sql.
SqlExpression sql =>
StepType -> sql -> MigrationStepWithType
mkMigrationStepWithType StepType
AddRemoveTablesAndColumns AlterSequenceExpr
migrateSequenceExpr]
      else []

sequenceIdToPgCatalogNames ::
  PgCatalog.NamespaceName ->
  Orville.SequenceIdentifier ->
  (PgCatalog.NamespaceName, PgCatalog.RelationName)
sequenceIdToPgCatalogNames :: NamespaceName
-> SequenceIdentifier -> (NamespaceName, RelationName)
sequenceIdToPgCatalogNames NamespaceName
currentNamespace SequenceIdentifier
sequenceId =
  let
    actualNamespace :: NamespaceName
actualNamespace =
      NamespaceName
-> (String -> NamespaceName) -> Maybe String -> NamespaceName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NamespaceName
currentNamespace String -> NamespaceName
forall a. IsString a => String -> a
String.fromString
        (Maybe String -> NamespaceName)
-> (SequenceIdentifier -> Maybe String)
-> SequenceIdentifier
-> NamespaceName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SequenceIdentifier -> Maybe String
Orville.sequenceIdSchemaNameString
        (SequenceIdentifier -> NamespaceName)
-> SequenceIdentifier -> NamespaceName
forall a b. (a -> b) -> a -> b
$ SequenceIdentifier
sequenceId

    relationName :: RelationName
relationName =
      String -> RelationName
forall a. IsString a => String -> a
String.fromString
        (String -> RelationName)
-> (SequenceIdentifier -> String)
-> SequenceIdentifier
-> RelationName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SequenceIdentifier -> String
Orville.sequenceIdUnqualifiedNameString
        (SequenceIdentifier -> RelationName)
-> SequenceIdentifier -> RelationName
forall a b. (a -> b) -> a -> b
$ SequenceIdentifier
sequenceId
  in
    (NamespaceName
actualNamespace, RelationName
relationName)

currentNamespaceQuery :: Expr.QueryExpr
currentNamespaceQuery :: QueryExpr
currentNamespaceQuery =
  SelectClause -> SelectList -> Maybe TableExpr -> QueryExpr
Expr.queryExpr
    (SelectExpr -> SelectClause
Expr.selectClause (Maybe Distinct -> SelectExpr
Expr.selectExpr Maybe Distinct
forall a. Maybe a
Nothing))
    ( [DerivedColumn] -> SelectList
Expr.selectDerivedColumns
        [ ValueExpression -> ColumnName -> DerivedColumn
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.
            (String -> ValueExpression
forall a. SqlExpression a => String -> a
RawSql.unsafeSqlExpression String
"current_schema")
            (FieldDefinition NotNull NamespaceName -> ColumnName
forall nullability a. FieldDefinition nullability a -> ColumnName
Orville.fieldColumnName FieldDefinition NotNull NamespaceName
PgCatalog.namespaceNameField)
        ]
    )
    Maybe TableExpr
forall a. Maybe a
Nothing

findCurrentNamespace :: Orville.MonadOrville m => m PgCatalog.NamespaceName
findCurrentNamespace :: forall (m :: * -> *). MonadOrville m => m NamespaceName
findCurrentNamespace = do
  [NamespaceName]
results <-
    QueryType
-> QueryExpr
-> AnnotatedSqlMarshaller NamespaceName NamespaceName
-> m [NamespaceName]
forall (m :: * -> *) sql writeEntity readEntity.
(MonadOrville m, SqlExpression sql) =>
QueryType
-> sql
-> AnnotatedSqlMarshaller writeEntity readEntity
-> m [readEntity]
Orville.executeAndDecode
      QueryType
Orville.SelectQuery
      QueryExpr
currentNamespaceQuery
      (SqlMarshaller NamespaceName NamespaceName
-> AnnotatedSqlMarshaller NamespaceName NamespaceName
forall writeEntity readEntity.
SqlMarshaller writeEntity readEntity
-> AnnotatedSqlMarshaller writeEntity readEntity
Orville.annotateSqlMarshallerEmptyAnnotation (SqlMarshaller NamespaceName NamespaceName
 -> AnnotatedSqlMarshaller NamespaceName NamespaceName)
-> SqlMarshaller NamespaceName NamespaceName
-> AnnotatedSqlMarshaller NamespaceName NamespaceName
forall a b. (a -> b) -> a -> b
$ (NamespaceName -> NamespaceName)
-> FieldDefinition NotNull NamespaceName
-> SqlMarshaller NamespaceName NamespaceName
forall writeEntity fieldValue nullability.
(writeEntity -> fieldValue)
-> FieldDefinition nullability fieldValue
-> SqlMarshaller writeEntity fieldValue
Orville.marshallField NamespaceName -> NamespaceName
forall a. a -> a
id FieldDefinition NotNull NamespaceName
PgCatalog.namespaceNameField)

  IO NamespaceName -> m NamespaceName
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NamespaceName -> m NamespaceName)
-> IO NamespaceName -> m NamespaceName
forall a b. (a -> b) -> a -> b
$
    case [NamespaceName]
results of
      [NamespaceName
schemaAndCatalog] ->
        NamespaceName -> IO NamespaceName
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure NamespaceName
schemaAndCatalog
      [] ->
        MigrationDataError -> IO NamespaceName
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (MigrationDataError -> IO NamespaceName)
-> MigrationDataError -> IO NamespaceName
forall a b. (a -> b) -> a -> b
$ String -> MigrationDataError
UnableToDiscoverCurrentSchema String
"No results returned by current_schema query"
      [NamespaceName]
_ ->
        MigrationDataError -> IO NamespaceName
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (MigrationDataError -> IO NamespaceName)
-> MigrationDataError -> IO NamespaceName
forall a b. (a -> b) -> a -> b
$ String -> MigrationDataError
UnableToDiscoverCurrentSchema String
"Multiple results returned by current_schema query"