{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
module Database.Selda.Migrations
( Migration (..)
, migrate, migrateM, migrateAll, autoMigrate
) where
import Control.Monad (void, when)
import Control.Monad.Catch
import Database.Selda hiding (from)
import Database.Selda.Backend.Internal
import Database.Selda.Table.Type (tableName)
import Database.Selda.Table.Validation (ValidationError (..))
import Database.Selda.Types (mkTableName, fromTableName, rawTableName)
import Database.Selda.Validation
data Migration where
Migration :: (Relational a, Relational b)
=> Table a
-> Table b
-> (Row s a -> Query s (Row s b))
-> Migration
type MigrationStep = [Migration]
migrate :: (MonadSelda m, MonadMask m, Relational a, Relational b)
=> Table a
-> Table b
-> (Row () a -> Row () b)
-> m ()
migrate t1 t2 upg = migrateM t1 t2 ((pure :: a -> Query () a) . upg)
migrateM :: (MonadSelda m, MonadMask m, Relational a, Relational b)
=> Table a
-> Table b
-> (Row s a -> Query s (Row s b))
-> m ()
migrateM t1 t2 upg = migrateAll True [Migration t1 t2 upg]
wrap :: (MonadSelda m, MonadMask m) => Bool -> m a -> m a
wrap enforceFKs
| enforceFKs = transaction
| otherwise = withoutForeignKeyEnforcement
migrateAll :: (MonadSelda m, MonadMask m)
=> Bool
-> MigrationStep
-> m ()
migrateAll fks =
wrap fks . mapM_ (\(Migration t1 t2 upg) -> migrateInternal t1 t2 upg)
autoMigrate :: (MonadSelda m, MonadMask m)
=> Bool
-> [MigrationStep]
-> m ()
autoMigrate _ [] = do
return ()
autoMigrate fks steps = wrap fks $ do
diffs <- sequence finalState
when (any (/= TableOK) diffs) $ do
steps' <- reverse <$> calculateSteps revSteps
mapM_ performStep steps'
where
revSteps = reverse steps
finalState = [diffTable to | Migration _ to _ <- head revSteps]
calculateSteps (step:ss) = do
diffs <- mapM (\(Migration from _ _) -> diffTable from) step
if all (== TableOK) diffs
then return [step]
else (step:) <$> calculateSteps ss
calculateSteps [] = do
throwM $ ValidationError "no starting state matches the current state of the database"
performStep = mapM_ (\(Migration t1 t2 upg) -> migrateInternal t1 t2 upg)
migrateInternal :: (MonadSelda m, MonadThrow m, Relational a, Relational b)
=> Table a
-> Table b
-> (Row s a -> Query s (Row s b))
-> m ()
migrateInternal t1 t2 upg = do
validateTable t1
validateSchema t2
backend <- seldaBackend
createTable t2'
void . queryInto t2' $ select t1 >>= upg
void . liftIO $ runStmt backend (dropQuery (tableName t1)) []
void . liftIO $ runStmt backend renameQuery []
where
t2' = t2 {tableName = mkTableName newName} `asTypeOf` t2
newName = mconcat ["__selda_migration_", rawTableName (tableName t2)]
renameQuery = mconcat
[ "ALTER TABLE ", newName
, " RENAME TO ", fromTableName (tableName t2), ";"
]
dropQuery t = mconcat ["DROP TABLE ", fromTableName t, ";"]