-- | This module documents tools and utilities for running SQL migrations.
--
-- A 'Migration' is (currently) an alias for a 'WriterT' of
module Database.Persist.Sql.Migration
  (
    -- * Types
    Migration
  , CautiousMigration
  , Sql
    -- * Using a 'Migration'
  , showMigration
  , parseMigration
  , parseMigration'
  , printMigration
  , getMigration
  , runMigration
  , runMigrationQuiet
  , runMigrationSilent
  , runMigrationUnsafe
  , runMigrationUnsafeQuiet
  , migrate
  -- * Utilities for constructing migrations
  -- | While 'migrate' is capable of creating a 'Migration' for you, it's not
  -- the only way you can write migrations. You can use these utilities to write
  -- extra steps in your migrations.
  --
  -- As an example, let's say we want to enable the @citext@ extension on
  -- @postgres@ as part of our migrations.
  --
  -- @
  -- 'Database.Persist.TH.share' ['Database.Persist.TH.mkPersist' sqlSettings, 'Database.Persist.TH.mkMigration' "migrateAll"] ...
  --
  -- migration :: 'Migration'
  -- migration = do
  --     'runSqlCommand' $
  --         'rawExecute_' "CREATE EXTENSION IF NOT EXISTS \"citext\";"
  --     migrateAll
  -- @
  --
  -- For raw commands, you can also just write 'addMigration':
  --
  -- @
  -- migration :: 'Migration'
  -- migration = do
  --     'addMigration' "CREATE EXTENSION IF NOT EXISTS \"citext\";"
  --     migrateAll
  -- @
  , reportErrors
  , reportError
  , addMigrations
  , addMigration
  , runSqlCommand
  -- * If something goes wrong...
  , PersistUnsafeMigrationException(..)
  ) where


import Control.Exception (throwIO)
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, isPrefixOf, pack, snoc, unpack)
import qualified Data.Text.IO
import GHC.Stack
import System.IO
import System.IO.Silently (hSilence)

import Database.Persist.Sql.Orphan.PersistStore ()
import Database.Persist.Sql.Raw
import Database.Persist.Sql.Types
import Database.Persist.Sql.Types.Internal
import Database.Persist.Types
import Control.Exception (Exception(..))

type Sql = Text

-- | A list of SQL operations, marked with a safety flag. If the 'Bool' is
-- 'True', then the operation is *unsafe* - it might be destructive, or
-- otherwise not idempotent. If the 'Bool' is 'False', then the operation
-- is *safe*, and can be run repeatedly without issues.
type CautiousMigration = [(Bool, Sql)]

-- | A 'Migration' is a four level monad stack consisting of:
--
-- * @'WriterT' ['Text']@ representing a log of errors in the migrations.
-- * @'WriterT' 'CautiousMigration'@ representing a list of migrations to
--   run, along with whether or not they are safe.
-- * @'ReaderT' 'SqlBackend'@, aka the 'SqlPersistT' transformer for
--   database interop.
-- * @'IO'@ for arbitrary IO.
type Migration = WriterT [Text] (WriterT CautiousMigration (ReaderT SqlBackend IO)) ()

allSql :: CautiousMigration -> [Sql]
allSql :: CautiousMigration -> [Text]
allSql = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd

safeSql :: CautiousMigration -> [Sql]
safeSql :: CautiousMigration -> [Text]
safeSql = CautiousMigration -> [Text]
allSql forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)

-- | Given a 'Migration', this parses it and returns either a list of
-- errors associated with the migration or a list of migrations to do.
parseMigration :: (HasCallStack, MonadIO m) => Migration -> ReaderT SqlBackend m (Either [Text] CautiousMigration)
parseMigration :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m (Either [Text] CautiousMigration)
parseMigration =
    forall {m :: * -> *} {r} {a}.
MonadIO m =>
ReaderT r IO a -> ReaderT r m a
liftIOReader forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall {a} {b}. ([a], b) -> Either [a] b
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w a. Monad m => WriterT w m a -> m w
execWriterT
  where
    go :: ([a], b) -> Either [a] b
go ([], b
sql) = forall a b. b -> Either a b
Right b
sql
    go ([a]
errs, b
_) = forall a b. a -> Either a b
Left [a]
errs

    liftIOReader :: ReaderT r IO a -> ReaderT r m a
liftIOReader (ReaderT r -> IO a
m) = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. r -> IO a
m

-- | Like 'parseMigration', but instead of returning the value in an
-- 'Either' value, it calls 'error' on the error values.
parseMigration' :: (HasCallStack, MonadIO m) => Migration -> ReaderT SqlBackend m CautiousMigration
parseMigration' :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m CautiousMigration
parseMigration' Migration
m = do
  Either [Text] CautiousMigration
x <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m (Either [Text] CautiousMigration)
parseMigration Migration
m
  case Either [Text] CautiousMigration
x of
      Left [Text]
errs -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
unpack [Text]
errs
      Right CautiousMigration
sql -> forall (m :: * -> *) a. Monad m => a -> m a
return CautiousMigration
sql

-- | Prints a migration.
printMigration :: (HasCallStack, MonadIO m) => Migration -> ReaderT SqlBackend m ()
printMigration :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m ()
printMigration Migration
m = forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m [Text]
showMigration Migration
m
               forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
Data.Text.IO.putStrLn)

-- | Convert a 'Migration' to a list of 'Text' values corresponding to their
-- 'Sql' statements.
showMigration :: (HasCallStack, MonadIO m) => Migration -> ReaderT SqlBackend m [Text]
showMigration :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m [Text]
showMigration Migration
m = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Char -> Text
snoc Char
';') forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Migration -> ReaderT SqlBackend m [Text]
getMigration Migration
m

-- | Return all of the 'Sql' values associated with the given migration.
-- Calls 'error' if there's a parse error on any migration.
getMigration :: (MonadIO m, HasCallStack) => Migration -> ReaderT SqlBackend m [Sql]
getMigration :: forall (m :: * -> *).
(MonadIO m, HasCallStack) =>
Migration -> ReaderT SqlBackend m [Text]
getMigration Migration
m = do
  CautiousMigration
mig <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m CautiousMigration
parseMigration' Migration
m
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CautiousMigration -> [Text]
allSql CautiousMigration
mig

-- | Runs a migration. If the migration fails to parse or if any of the
-- migrations are unsafe, then this throws a 'PersistUnsafeMigrationException'.
runMigration :: MonadIO m
             => Migration
             -> ReaderT SqlBackend m ()
runMigration :: forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m ()
runMigration Migration
m = forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> Bool -> ReaderT SqlBackend m [Text]
runMigration' Migration
m Bool
False forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Same as 'runMigration', but does not report the individual migrations on
-- stderr. Instead it returns a list of the executed SQL commands.
--
-- This is a safer/more robust alternative to 'runMigrationSilent', but may be
-- less silent for some persistent implementations, most notably
-- persistent-postgresql
--
-- @since 2.10.2
runMigrationQuiet :: MonadIO m
                  => Migration
                  -> ReaderT SqlBackend m [Text]
runMigrationQuiet :: forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationQuiet Migration
m = forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> Bool -> ReaderT SqlBackend m [Text]
runMigration' Migration
m Bool
True

-- | Same as 'runMigration', but returns a list of the SQL commands executed
-- instead of printing them to stderr.
--
-- This function silences the migration by remapping 'stderr'. As a result, it
-- is not thread-safe and can clobber output from other parts of the program.
-- This implementation method was chosen to also silence postgresql migration
-- output on stderr, but is not recommended!
runMigrationSilent :: MonadUnliftIO m
                   => Migration
                   -> ReaderT SqlBackend m [Text]
runMigrationSilent :: forall (m :: * -> *).
MonadUnliftIO m =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationSilent Migration
m = forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT SqlBackend m a -> IO a
run ->
  forall a. [Handle] -> IO a -> IO a
hSilence [Handle
stderr] forall a b. (a -> b) -> a -> b
$ forall a. ReaderT SqlBackend m a -> IO a
run forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> Bool -> ReaderT SqlBackend m [Text]
runMigration' Migration
m Bool
True

-- | Run the given migration against the database. If the migration fails
-- to parse, or there are any unsafe migrations, then this will error at
-- runtime. This returns a list of the migrations that were executed.
runMigration'
    :: (HasCallStack, MonadIO m)
    => Migration
    -> Bool -- ^ is silent?
    -> ReaderT SqlBackend m [Text]
runMigration' :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> Bool -> ReaderT SqlBackend m [Text]
runMigration' Migration
m Bool
silent = do
    CautiousMigration
mig <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m CautiousMigration
parseMigration' Migration
m
    if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a, b) -> a
fst CautiousMigration
mig
        then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ CautiousMigration -> PersistUnsafeMigrationException
PersistUnsafeMigrationException CautiousMigration
mig
        else forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadIO m =>
Bool -> Text -> ReaderT SqlBackend m Text
executeMigrate Bool
silent) forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
sortMigrations forall a b. (a -> b) -> a -> b
$ CautiousMigration -> [Text]
safeSql CautiousMigration
mig

-- | Like 'runMigration', but this will perform the unsafe database
-- migrations instead of erroring out.
runMigrationUnsafe :: MonadIO m
                   => Migration
                   -> ReaderT SqlBackend m ()
runMigrationUnsafe :: forall (m :: * -> *).
MonadIO m =>
Migration -> ReaderT SqlBackend m ()
runMigrationUnsafe Migration
m = forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Bool -> Migration -> ReaderT SqlBackend m [Text]
runMigrationUnsafe' Bool
False Migration
m forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Same as 'runMigrationUnsafe', but returns a list of the SQL commands
-- executed instead of printing them to stderr.
--
-- @since 2.10.2
runMigrationUnsafeQuiet :: (HasCallStack, MonadIO m)
                        => Migration
                        -> ReaderT SqlBackend m [Text]
runMigrationUnsafeQuiet :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m [Text]
runMigrationUnsafeQuiet = forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Bool -> Migration -> ReaderT SqlBackend m [Text]
runMigrationUnsafe' Bool
True

runMigrationUnsafe' :: (HasCallStack, MonadIO m)
                    => Bool
                    -> Migration
                    -> ReaderT SqlBackend m [Text]
runMigrationUnsafe' :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Bool -> Migration -> ReaderT SqlBackend m [Text]
runMigrationUnsafe' Bool
silent Migration
m = do
    CautiousMigration
mig <- forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Migration -> ReaderT SqlBackend m CautiousMigration
parseMigration' Migration
m
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
MonadIO m =>
Bool -> Text -> ReaderT SqlBackend m Text
executeMigrate Bool
silent) forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
sortMigrations forall a b. (a -> b) -> a -> b
$ CautiousMigration -> [Text]
allSql CautiousMigration
mig

executeMigrate :: MonadIO m => Bool -> Text -> ReaderT SqlBackend m Text
executeMigrate :: forall (m :: * -> *).
MonadIO m =>
Bool -> Text -> ReaderT SqlBackend m Text
executeMigrate Bool
silent Text
s = do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
silent forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ [Char]
"Migrating: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
s
    forall (m :: * -> *) backend.
(MonadIO m, BackendCompatible SqlBackend backend) =>
Text -> [PersistValue] -> ReaderT backend m ()
rawExecute Text
s []
    forall (m :: * -> *) a. Monad m => a -> m a
return Text
s

-- | Sort the alter DB statements so tables are created before constraints are
-- added.
sortMigrations :: [Sql] -> [Sql]
sortMigrations :: [Text] -> [Text]
sortMigrations [Text]
x =
    forall a. (a -> Bool) -> [a] -> [a]
filter Text -> Bool
isCreate [Text]
x forall a. [a] -> [a] -> [a]
++ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
isCreate) [Text]
x
  where
    -- Note the use of lower-case e. This (hack) allows backends to explicitly
    -- choose to have this special sorting applied.
    isCreate :: Text -> Bool
isCreate Text
t = [Char] -> Text
pack [Char]
"CREATe " Text -> Text -> Bool
`isPrefixOf` Text
t

-- |  Given a list of old entity definitions and a new 'EntityDef' in
-- @val@, this creates a 'Migration' to update the old list of definitions
-- with the new one.
migrate :: [EntityDef]
        -> EntityDef
        -> Migration
migrate :: [EntityDef] -> EntityDef -> Migration
migrate [EntityDef]
allDefs EntityDef
val = do
    SqlBackend
conn <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    Either [Text] CautiousMigration
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ SqlBackend
-> [EntityDef]
-> (Text -> IO Statement)
-> EntityDef
-> IO (Either [Text] CautiousMigration)
connMigrateSql SqlBackend
conn [EntityDef]
allDefs (SqlBackend -> Text -> IO Statement
getStmtConn SqlBackend
conn) EntityDef
val
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Text] -> Migration
reportErrors CautiousMigration -> Migration
addMigrations Either [Text] CautiousMigration
res

-- | Report a single error in a 'Migration'.
--
-- @since 2.9.2
reportError :: Text -> Migration
reportError :: Text -> Migration
reportError = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Report multiple errors in a 'Migration'.
--
-- @since 2.9.2
reportErrors :: [Text] -> Migration
reportErrors :: [Text] -> Migration
reportErrors = forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell

-- | Add a migration to the migration plan.
--
-- @since 2.9.2
addMigration
    :: Bool
    -- ^ Is the migration unsafe to run? (eg a destructive or non-idempotent
    -- update on the schema). If 'True', the migration is *unsafe*, and will
    -- need to be run manually later. If 'False', the migration is *safe*, and
    -- can be run any number of times.
    -> Sql
    -- ^ A 'Text' value representing the command to run on the database.
    -> Migration
addMigration :: Bool -> Text -> Migration
addMigration Bool
isUnsafe Text
sql = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell [(Bool
isUnsafe, Text
sql)])

-- | Add a 'CautiousMigration' (aka a @[('Bool', 'Text')]@) to the
-- migration plan.
--
-- @since 2.9.2
addMigrations
    :: CautiousMigration
    -> Migration
addMigrations :: CautiousMigration -> Migration
addMigrations = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell

-- | Run an action against the database during a migration. Can be useful for eg
-- creating Postgres extensions:
--
-- @
-- runSqlCommand $ 'rawExecute' "CREATE EXTENSION IF NOT EXISTS \"uuid-ossp\";" []
-- @
--
-- @since 2.13.0.0
runSqlCommand :: SqlPersistT IO () -> Migration
runSqlCommand :: SqlPersistT IO () -> Migration
runSqlCommand = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | An exception indicating that Persistent refused to run some unsafe
-- migrations. Contains a list of pairs where the Bool tracks whether the
-- migration was unsafe (True means unsafe), and the Sql is the sql statement
-- for the migration.
--
-- @since 2.11.1.0
newtype PersistUnsafeMigrationException
  = PersistUnsafeMigrationException [(Bool, Sql)]

-- | This 'Show' instance renders an error message suitable for printing to the
-- console. This is a little dodgy, but since GHC uses Show instances when
-- displaying uncaught exceptions, we have little choice.
instance Show PersistUnsafeMigrationException where
  show :: PersistUnsafeMigrationException -> [Char]
show (PersistUnsafeMigrationException CautiousMigration
mig) =
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [Char]
"\n\nDatabase migration: manual intervention required.\n"
      , [Char]
"The unsafe actions are prefixed by '***' below:\n\n"
      , [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Bool, Text) -> [Char]
displayMigration CautiousMigration
mig
      ]
    where
      displayMigration :: (Bool, Sql) -> String
      displayMigration :: (Bool, Text) -> [Char]
displayMigration (Bool
True,  Text
s) = [Char]
"*** " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
s forall a. [a] -> [a] -> [a]
++ [Char]
";"
      displayMigration (Bool
False, Text
s) = [Char]
"    " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
unpack Text
s forall a. [a] -> [a] -> [a]
++ [Char]
";"

instance Exception PersistUnsafeMigrationException