123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181 |
- module Database.Persist.Sql.Migration
- ( parseMigration
- , parseMigration'
- , printMigration
- , showMigration
- , getMigration
- , runMigration
- , runMigrationSilent
- , runMigrationUnsafe
- , migrate
-
- , reportErrors
- , reportError
- , addMigrations
- , addMigration
- ) where
- import Control.Monad (liftM, unless)
- import Control.Monad.IO.Unlift
- import Control.Monad.Trans.Class (MonadTrans (..))
- import Control.Monad.Trans.Reader (ReaderT (..), ask)
- import Control.Monad.Trans.Writer
- import Data.Text (Text, unpack, snoc, isPrefixOf, pack)
- import qualified Data.Text.IO
- import System.IO
- import System.IO.Silently (hSilence)
- import Database.Persist.Sql.Types
- import Database.Persist.Sql.Raw
- import Database.Persist.Types
- import Database.Persist.Sql.Orphan.PersistStore()
- allSql :: CautiousMigration -> [Sql]
- allSql = map snd
- safeSql :: CautiousMigration -> [Sql]
- safeSql = allSql . filter (not . fst)
- parseMigration :: MonadIO m => Migration -> ReaderT SqlBackend m (Either [Text] CautiousMigration)
- parseMigration =
- liftIOReader . liftM go . runWriterT . execWriterT
- where
- go ([], sql) = Right sql
- go (errs, _) = Left errs
- liftIOReader (ReaderT m) = ReaderT $ liftIO . m
- parseMigration' :: MonadIO m => Migration -> ReaderT SqlBackend m (CautiousMigration)
- parseMigration' m = do
- x <- parseMigration m
- case x of
- Left errs -> error $ unlines $ map unpack errs
- Right sql -> return sql
- printMigration :: MonadIO m => Migration -> ReaderT SqlBackend m ()
- printMigration m = showMigration m
- >>= mapM_ (liftIO . Data.Text.IO.putStrLn)
- showMigration :: MonadIO m => Migration -> ReaderT SqlBackend m [Text]
- showMigration m = map (flip snoc ';') `liftM` getMigration m
- getMigration :: MonadIO m => Migration -> ReaderT SqlBackend m [Sql]
- getMigration m = do
- mig <- parseMigration' m
- return $ allSql mig
- runMigration :: MonadIO m
- => Migration
- -> ReaderT SqlBackend m ()
- runMigration m = runMigration' m False >> return ()
- runMigrationSilent :: MonadUnliftIO m
- => Migration
- -> ReaderT SqlBackend m [Text]
- runMigrationSilent m = withRunInIO $ \run ->
- hSilence [stderr] $ run $ runMigration' m True
- runMigration'
- :: MonadIO m
- => Migration
- -> Bool
- -> ReaderT SqlBackend m [Text]
- runMigration' m silent = do
- mig <- parseMigration' m
- if any fst mig
- then error $ concat
- [ "\n\nDatabase migration: manual intervention required.\n"
- , "The unsafe actions are prefixed by '***' below:\n\n"
- , unlines $ map displayMigration mig
- ]
- else mapM (executeMigrate silent) $ sortMigrations $ safeSql mig
- where
- displayMigration :: (Bool, Sql) -> String
- displayMigration (True, s) = "*** " ++ unpack s ++ ";"
- displayMigration (False, s) = " " ++ unpack s ++ ";"
- runMigrationUnsafe :: MonadIO m
- => Migration
- -> ReaderT SqlBackend m ()
- runMigrationUnsafe m = do
- mig <- parseMigration' m
- mapM_ (executeMigrate False) $ sortMigrations $ allSql mig
- executeMigrate :: MonadIO m => Bool -> Text -> ReaderT SqlBackend m Text
- executeMigrate silent s = do
- unless silent $ liftIO $ hPutStrLn stderr $ "Migrating: " ++ unpack s
- rawExecute s []
- return s
- sortMigrations :: [Sql] -> [Sql]
- sortMigrations x =
- filter isCreate x ++ filter (not . isCreate) x
- where
-
-
- isCreate t = pack "CREATe " `isPrefixOf` t
- migrate :: [EntityDef]
- -> EntityDef
- -> Migration
- migrate allDefs val = do
- conn <- lift $ lift ask
- res <- liftIO $ connMigrateSql conn allDefs (getStmtConn conn) val
- either reportErrors addMigrations res
- reportError :: Text -> Migration
- reportError = tell . pure
- reportErrors :: [Text] -> Migration
- reportErrors = tell
- addMigration
- :: Bool
-
-
- -> Sql
-
- -> Migration
- addMigration isSafe sql = lift (tell [(isSafe, sql)])
- addMigrations
- :: CautiousMigration
- -> Migration
- addMigrations = lift . tell
|