{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
-- | Functionality for upgrading a table from one schema to another.
module Database.Selda.Migrations
  ( Migration (..)
  , migrate, migrateM, migrateAll, autoMigrate
  ) where
import Control.Monad (void, when)
import Control.Monad.Catch ( MonadMask, MonadThrow(..) )
import Database.Selda.Backend.Internal
    ( MonadSelda(..), SeldaBackend(runStmt), withBackend )
import Database.Selda.Column ( Row )
import Database.Selda.Frontend
    ( MonadIO(liftIO),
      queryInto,
      transaction,
      withoutForeignKeyEnforcement,
      OnError(..),
      createTableWithoutIndexes,
      createTableIndexes )
import Database.Selda.Generic ( Relational )
import Database.Selda.Query ( select )
import Database.Selda.Query.Type ( Query )
import Database.Selda.Table.Type ( Table(..) )
import Database.Selda.Table.Validation (ValidationError (..))
import Database.Selda.Types (mkTableName, fromTableName, rawTableName)
import Database.Selda.Validation
    ( TableDiff(TableOK), validateTable, validateSchema, diffTable )

-- | Wrapper for user with 'migrateAll', enabling multiple migrations to be
--   packed into the same list:
--
-- > migrateAll
-- >   [ Migration m1_from m1_to m1_upgrade
-- >   , Migration m2_from m2_to m2_upgrade
-- >   , ...
-- >   ]
data Migration backend where
  Migration :: (Relational a, Relational b)
            => Table a
            -> Table b
            -> (Row backend a -> Query backend (Row backend b))
            -> Migration backend

-- | A migration step is zero or more migrations that need to be performed in
--   a single transaction in order to keep the database consistent.
type MigrationStep backend = [Migration backend]

-- | Migrate the first table into the second, using the given function to
--   migrate all records to the new schema.
--   Both table schemas are validated before starting the migration, and the
--   source table is validated against what's currently in the database.
--
--   The migration is performed as a transaction, ensuring that either the
--   entire migration passes, or none of it does.
migrate :: (MonadSelda m, MonadMask m, Relational a, Relational b)
        => Table a -- ^ Table to migrate from.
        -> Table b -- ^ Table to migrate to.
        -> (Row (Backend m) a -> Row (Backend m) b)
                   -- ^ Mapping from old to new table.
        -> m ()
migrate :: forall (m :: * -> *) a b.
(MonadSelda m, MonadMask m, Relational a, Relational b) =>
Table a
-> Table b -> (Row (Backend m) a -> Row (Backend m) b) -> m ()
migrate Table a
t1 Table b
t2 Row (Backend m) a -> Row (Backend m) b
upg = forall (m :: * -> *) a b.
(MonadSelda m, MonadMask m, Relational a, Relational b) =>
Table a
-> Table b
-> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b))
-> m ()
migrateM Table a
t1 Table b
t2 (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Row (Backend m) a -> Row (Backend m) b
upg)

-- | Like 'migrate', but allows the column upgrade to access
--   the entire database.
migrateM :: (MonadSelda m, MonadMask m, Relational a, Relational b)
         => Table a
         -> Table b
         -> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b))
         -> m ()
migrateM :: forall (m :: * -> *) a b.
(MonadSelda m, MonadMask m, Relational a, Relational b) =>
Table a
-> Table b
-> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b))
-> m ()
migrateM Table a
t1 Table b
t2 Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)
upg = forall (m :: * -> *).
(MonadSelda m, MonadMask m) =>
Bool -> MigrationStep (Backend m) -> m ()
migrateAll Bool
True [forall a b backend.
(Relational a, Relational b) =>
Table a
-> Table b
-> (Row backend a -> Query backend (Row backend b))
-> Migration backend
Migration Table a
t1 Table b
t2 Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)
upg]

wrap :: (MonadSelda m, MonadMask m) => Bool -> m a -> m a
wrap :: forall (m :: * -> *) a.
(MonadSelda m, MonadMask m) =>
Bool -> m a -> m a
wrap Bool
enforceFKs
  | Bool
enforceFKs = forall (m :: * -> *) a. (MonadSelda m, MonadMask m) => m a -> m a
transaction
  | Bool
otherwise  = forall (m :: * -> *) a. (MonadSelda m, MonadMask m) => m a -> m a
withoutForeignKeyEnforcement

-- | Perform all given migrations as a single transaction.
migrateAll :: (MonadSelda m, MonadMask m)
           => Bool -- ^ Enforce foreign keys during migration?
           -> MigrationStep (Backend m) -- ^ Migration step to perform.
           -> m ()
migrateAll :: forall (m :: * -> *).
(MonadSelda m, MonadMask m) =>
Bool -> MigrationStep (Backend m) -> m ()
migrateAll Bool
fks =
  forall (m :: * -> *) a.
(MonadSelda m, MonadMask m) =>
Bool -> m a -> m a
wrap Bool
fks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Migration Table a
t1 Table b
t2 Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)
upg) -> forall (m :: * -> *) a b.
(MonadSelda m, MonadThrow m, Relational a, Relational b) =>
Table a
-> Table b
-> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b))
-> m ()
migrateInternal Table a
t1 Table b
t2 Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)
upg)

-- | Given a list of migration steps in ascending chronological order, finds
--   the latest migration step starting state that matches the current database,
--   and performs all migrations from that point until the end of the list.
--   The whole operation is performed as a single transaction.
--
--   If no matching starting state is found, a 'ValidationError' is thrown.
--   If the database is already in the state specified by the end state of the
--   final step, no migration is performed.
--
--   Note that when looking for a matching starting state, index methods for
--   indexed columns are not taken into account. Two columns @c1@ and @c2@ are
--   considered to be identical if @c1@ is indexed with index method @foo@ and
--   @c2@ is indexed with index method @bar@.
autoMigrate :: (MonadSelda m, MonadMask m)
            => Bool -- ^ Enforce foreign keys during migration?
            -> [MigrationStep (Backend m)] -- ^ Migration steps to perform.
            -> m ()
autoMigrate :: forall (m :: * -> *).
(MonadSelda m, MonadMask m) =>
Bool -> [MigrationStep (Backend m)] -> m ()
autoMigrate Bool
_ [] = do
  forall (m :: * -> *) a. Monad m => a -> m a
return ()
autoMigrate Bool
fks [MigrationStep (Backend m)]
steps = forall (m :: * -> *) a.
(MonadSelda m, MonadMask m) =>
Bool -> m a -> m a
wrap Bool
fks forall a b. (a -> b) -> a -> b
$ do
    [TableDiff]
diffs <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m TableDiff]
finalState
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
/= TableDiff
TableOK) [TableDiff]
diffs) forall a b. (a -> b) -> a -> b
$ do
      [MigrationStep (Backend m)]
steps' <- forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {t :: * -> *} {backend}.
(Traversable t, MonadThrow m, MonadSelda m) =>
[t (Migration backend)] -> m [t (Migration backend)]
calculateSteps [MigrationStep (Backend m)]
revSteps
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ MigrationStep (Backend m) -> m ()
performStep [MigrationStep (Backend m)]
steps'
  where
    revSteps :: [MigrationStep (Backend m)]
revSteps = forall a. [a] -> [a]
reverse [MigrationStep (Backend m)]
steps
    finalState :: [m TableDiff]
finalState = [forall (m :: * -> *) a. MonadSelda m => Table a -> m TableDiff
diffTable Table b
to | Migration Table a
_ Table b
to Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)
_ <- forall a. [a] -> a
head [MigrationStep (Backend m)]
revSteps]

    calculateSteps :: [t (Migration backend)] -> m [t (Migration backend)]
calculateSteps (t (Migration backend)
step:[t (Migration backend)]
ss) = do
      t TableDiff
diffs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Migration Table a
from Table b
_ Row backend a -> Query backend (Row backend b)
_) -> forall (m :: * -> *) a. MonadSelda m => Table a -> m TableDiff
diffTable Table a
from) t (Migration backend)
step
      if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== TableDiff
TableOK) t TableDiff
diffs
        then forall (m :: * -> *) a. Monad m => a -> m a
return [t (Migration backend)
step]
        else (t (Migration backend)
stepforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t (Migration backend)] -> m [t (Migration backend)]
calculateSteps [t (Migration backend)]
ss
    calculateSteps [] = do
      forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> ValidationError
ValidationError String
"no starting state matches the current state of the database"

    performStep :: MigrationStep (Backend m) -> m ()
performStep = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Migration Table a
t1 Table b
t2 Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)
upg) -> forall (m :: * -> *) a b.
(MonadSelda m, MonadThrow m, Relational a, Relational b) =>
Table a
-> Table b
-> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b))
-> m ()
migrateInternal Table a
t1 Table b
t2 Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)
upg)

-- | Workhorse for migration.
--   Is NOT performed as a transaction, so exported functions need to
--   properly wrap calls this function.
migrateInternal :: (MonadSelda m, MonadThrow m, Relational a, Relational b)
                => Table a
                -> Table b
                -> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b))
                -> m ()
migrateInternal :: forall (m :: * -> *) a b.
(MonadSelda m, MonadThrow m, Relational a, Relational b) =>
Table a
-> Table b
-> (Row (Backend m) a -> Query (Backend m) (Row (Backend m) b))
-> m ()
migrateInternal Table a
t1 Table b
t2 Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)
upg = forall (m :: * -> *) a.
MonadSelda m =>
(SeldaBackend (Backend m) -> m a) -> m a
withBackend forall a b. (a -> b) -> a -> b
$ \SeldaBackend (Backend m)
b -> do
    forall (m :: * -> *) a.
(MonadSelda m, MonadThrow m) =>
Table a -> m ()
validateTable Table a
t1
    forall (m :: * -> *) a. MonadThrow m => Table a -> m ()
validateSchema Table b
t2
    forall (m :: * -> *) a. MonadSelda m => OnError -> Table a -> m ()
createTableWithoutIndexes OnError
Fail Table b
t2'
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadSelda m, Relational a) =>
Table a -> Query (Backend m) (Row (Backend m) a) -> m Int
queryInto Table b
t2' forall a b. (a -> b) -> a -> b
$ forall a s. Relational a => Table a -> Query s (Row s a)
select Table a
t1 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Row (Backend m) a -> Query (Backend m) (Row (Backend m) b)
upg
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b.
SeldaBackend b -> Text -> [Param] -> IO (Int, [[SqlValue]])
runStmt SeldaBackend (Backend m)
b (TableName -> Text
dropQuery (forall a. Table a -> TableName
tableName Table a
t1)) []
    forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall b.
SeldaBackend b -> Text -> [Param] -> IO (Int, [[SqlValue]])
runStmt SeldaBackend (Backend m)
b Text
renameQuery []
    forall (m :: * -> *) a. MonadSelda m => OnError -> Table a -> m ()
createTableIndexes OnError
Fail Table b
t2
  where
    t2' :: Table b
t2' = Table b
t2 {tableName :: TableName
tableName = Text -> TableName
mkTableName Text
newName} forall a. a -> a -> a
`asTypeOf` Table b
t2
    newName :: Text
newName = forall a. Monoid a => [a] -> a
mconcat [Text
"__selda_migration_", TableName -> Text
rawTableName (forall a. Table a -> TableName
tableName Table b
t2)]
    renameQuery :: Text
renameQuery = forall a. Monoid a => [a] -> a
mconcat
      [ Text
"ALTER TABLE ", Text
newName
      , Text
" RENAME TO ", TableName -> Text
fromTableName (forall a. Table a -> TableName
tableName Table b
t2), Text
";"
      ]
    dropQuery :: TableName -> Text
dropQuery TableName
t = forall a. Monoid a => [a] -> a
mconcat [Text
"DROP TABLE ", TableName -> Text
fromTableName TableName
t, Text
";"]