{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
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 )
data Migration backend where
Migration :: (Relational a, Relational b)
=> Table a
-> Table b
-> (Row backend a -> Query backend (Row backend b))
-> Migration backend
type MigrationStep backend = [Migration backend]
migrate :: (MonadSelda m, MonadMask m, Relational a, Relational b)
=> Table a
-> Table b
-> (Row (Backend m) a -> Row (Backend m) b)
-> 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)
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
migrateAll :: (MonadSelda m, MonadMask m)
=> Bool
-> MigrationStep (Backend m)
-> 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)
autoMigrate :: (MonadSelda m, MonadMask m)
=> Bool
-> [MigrationStep (Backend m)]
-> 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)
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
";"]