{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | Utility functions for common use cases
module Database.Beam.Migrate.Simple
  ( autoMigrate
  , simpleSchema
  , simpleMigration
  , runSimpleMigration
  , backendMigrationScript

  , VerificationResult(..)
  , verifySchema

  , IgnorePredicates(..)
  , CheckResult(..)
  , ignoreTables
  , ignoreAll
  , checkSchema

  , createSchema

  , BringUpToDateHooks(..)
  , defaultUpToDateHooks
  , bringUpToDate, bringUpToDateWithHooks

  , haskellSchema

  , module Database.Beam.Migrate.Actions
  , module Database.Beam.Migrate.Types ) where

import           Prelude hiding (log)

import           Database.Beam
import           Database.Beam.Backend
import           Database.Beam.Haskell.Syntax
import           Database.Beam.Migrate.Actions
import           Database.Beam.Migrate.Backend
import           Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck, TableExistsPredicate(..))
import           Database.Beam.Migrate.Log
import           Database.Beam.Migrate.SQL (BeamMigrateSqlBackendDataTypeSyntax)
import           Database.Beam.Migrate.Types

import           Control.Monad.Cont
import           Control.Monad.Writer
import           Control.Monad.State

import qualified Data.HashSet as HS
import           Data.Semigroup (Max(..), Any(..))
import           Data.Typeable
import           Data.Functor
import qualified Data.Text as T

import qualified Control.Monad.Fail as Fail

data BringUpToDateHooks m
  = BringUpToDateHooks
  { forall (m :: * -> *). BringUpToDateHooks m -> m Bool
runIrreversibleHook :: m Bool
    -- ^ Called before we're about to run an irreversible migration step. Return
    -- 'True' to run the step, or 'False' to abort immediately.
  , forall (m :: * -> *). BringUpToDateHooks m -> Int -> Text -> m ()
startStepHook       :: Int -> T.Text -> m ()
    -- ^ Called at the beginning of each step with the step index and description
  , forall (m :: * -> *). BringUpToDateHooks m -> Int -> Text -> m ()
endStepHook         :: Int -> T.Text -> m ()
    -- ^ Called at the end of each step with the step index and description
  , forall (m :: * -> *). BringUpToDateHooks m -> Int -> String -> m ()
runCommandHook      :: Int -> String -> m ()
    -- ^ Called before a command is about to run. The first argument is the step
    -- index and the second is a string representing the command about to be run.

  , forall (m :: * -> *). BringUpToDateHooks m -> m ()
queryFailedHook     :: m ()
    -- ^ Called when a query fails
  , forall (m :: * -> *). BringUpToDateHooks m -> Int -> m ()
discontinuousMigrationsHook
                        :: Int -> m ()
    -- ^ Called when the migration log has a discontinuity at the supplied index
  , forall (m :: * -> *).
BringUpToDateHooks m -> Int -> Text -> Text -> m ()
logMismatchHook     :: Int -> T.Text -> T.Text -> m ()
    -- ^ The migration log at the given index is not what was expected. The
    -- first text is the actual commit id, the second, the expected
  , forall (m :: * -> *). BringUpToDateHooks m -> Int -> m ()
databaseAheadHook   :: Int -> m ()
    -- ^ The database is ahead of the given migrations. The parameter supplies
    -- the number of entries passed the given migrations the database has.
  }

-- | Default set of 'BringUpToDateHooks'. Refuses to run irreversible
-- migrations, and fails in case of error, using 'fail'.
defaultUpToDateHooks :: Fail.MonadFail m => BringUpToDateHooks m
defaultUpToDateHooks :: forall (m :: * -> *). MonadFail m => BringUpToDateHooks m
defaultUpToDateHooks =
  BringUpToDateHooks
  { runIrreversibleHook :: m Bool
runIrreversibleHook = forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , startStepHook :: Int -> Text -> m ()
startStepHook       = \Int
_ Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , endStepHook :: Int -> Text -> m ()
endStepHook         = \Int
_ Text
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , runCommandHook :: Int -> String -> m ()
runCommandHook      = \Int
_ String
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , queryFailedHook :: m ()
queryFailedHook     = forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"Log entry query fails"
  , discontinuousMigrationsHook :: Int -> m ()
discontinuousMigrationsHook =
      \Int
ix -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"Discontinuous migration log: missing migration at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
ix)
  , logMismatchHook :: Int -> Text -> Text -> m ()
logMismatchHook =
      \Int
ix Text
actual Text
expected ->
        forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"Log mismatch at index " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
ix forall a. [a] -> [a] -> [a]
++ String
":\n" forall a. [a] -> [a] -> [a]
++
              String
"  expected: " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
expected forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
              String
"  actual  : " forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
actual)
  , databaseAheadHook :: Int -> m ()
databaseAheadHook =
      \Int
aheadBy ->
        forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"The database is ahead of the known schema by " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
aheadBy forall a. [a] -> [a] -> [a]
++ String
" migration(s)")
  }

-- | Equivalent to calling 'bringUpToDateWithHooks' with 'defaultUpToDateHooks'.
--
-- Tries to bring the database up to date, using the database log and the given
-- 'MigrationSteps'. Fails if the migration is irreversible, or an error occurs.
bringUpToDate :: ( Database be db, Fail.MonadFail m
                 , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) )
              => BeamMigrationBackend be m
              -> MigrationSteps be () (CheckedDatabaseSettings be db)
              -> m (Maybe (CheckedDatabaseSettings be db))
bringUpToDate :: forall be (db :: (* -> *) -> *) (m :: * -> *).
(Database be db, MonadFail m,
 HasDataTypeCreatedCheck
   (BeamMigrateSqlBackendDataTypeSyntax be)) =>
BeamMigrationBackend be m
-> MigrationSteps be () (CheckedDatabaseSettings be db)
-> m (Maybe (CheckedDatabaseSettings be db))
bringUpToDate be :: BeamMigrationBackend be m
be@BeamMigrationBackend {} =
  forall (db :: (* -> *) -> *) be (m :: * -> *).
(Database be db, MonadFail m,
 HasDataTypeCreatedCheck
   (BeamMigrateSqlBackendDataTypeSyntax be)) =>
BringUpToDateHooks m
-> BeamMigrationBackend be m
-> MigrationSteps be () (CheckedDatabaseSettings be db)
-> m (Maybe (CheckedDatabaseSettings be db))
bringUpToDateWithHooks forall (m :: * -> *). MonadFail m => BringUpToDateHooks m
defaultUpToDateHooks BeamMigrationBackend be m
be

-- | Check for the beam-migrate log. If it exists, use it and the supplied
-- migrations to bring the database up-to-date. Otherwise, create the log and
-- run all migrations.
--
-- Accepts a set of hooks that can be used to customize behavior. See the
-- documentation for 'BringUpToDateHooks' for more information. Calling this
-- with 'defaultUpToDateHooks' is the same as using 'bringUpToDate'.
bringUpToDateWithHooks :: forall db be m
                        . ( Database be db, Fail.MonadFail m
                          , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) )
                       => BringUpToDateHooks m
                       -> BeamMigrationBackend be m
                       -> MigrationSteps be () (CheckedDatabaseSettings be db)
                       -> m (Maybe (CheckedDatabaseSettings be db))
bringUpToDateWithHooks :: forall (db :: (* -> *) -> *) be (m :: * -> *).
(Database be db, MonadFail m,
 HasDataTypeCreatedCheck
   (BeamMigrateSqlBackendDataTypeSyntax be)) =>
BringUpToDateHooks m
-> BeamMigrationBackend be m
-> MigrationSteps be () (CheckedDatabaseSettings be db)
-> m (Maybe (CheckedDatabaseSettings be db))
bringUpToDateWithHooks BringUpToDateHooks m
hooks be :: BeamMigrationBackend be m
be@(BeamMigrationBackend { backendRenderSyntax :: forall be (m :: * -> *).
BeamMigrationBackend be m -> BeamSqlBackendSyntax be -> String
backendRenderSyntax = BeamSqlBackendSyntax be -> String
renderSyntax' }) MigrationSteps be () (CheckedDatabaseSettings be db)
steps = do
  forall be (m :: * -> *).
(BeamSqlBackendCanSerialize be Text, MonadFail m) =>
BeamMigrationBackend be m -> m ()
ensureBackendTables BeamMigrationBackend be m
be

  [QExprToIdentity
   (LogEntryT (QGenExpr QValueContext be QBaseScope))]
entries <- forall be (m :: * -> *) a.
(MonadBeam be m, BeamSqlBackend be, FromBackendRow be a) =>
SqlSelect be a -> m [a]
runSelectReturningList forall a b. (a -> b) -> a -> b
$ forall be (db :: (* -> *) -> *) res.
(BeamSqlBackend be, HasQBuilder be, Projectible be res) =>
Q be db QBaseScope res -> SqlSelect be (QExprToIdentity res)
select forall a b. (a -> b) -> a -> b
$ forall s a ordering be (db :: (* -> *) -> *).
(Projectible be a, SqlOrderable be ordering,
 ThreadRewritable (QNested s) a) =>
(a -> ordering)
-> Q be db (QNested s) a
-> Q be db s (WithRewrittenThread (QNested s) s a)
orderBy_ (forall be s a. BeamSqlBackend be => QExpr be s a -> QOrd be s a
asc_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *). LogEntryT f -> C f Int32
_logEntryId) forall a b. (a -> b) -> a -> b
$
             forall be (db :: (* -> *) -> *) (table :: (* -> *) -> *) s.
(Database be db, BeamSqlBackend be) =>
DatabaseEntity be db (TableEntity table)
-> Q be db s (table (QExpr be s))
all_ (forall (entity :: * -> *).
BeamMigrateDb entity -> entity (TableEntity LogEntryT)
_beamMigrateLogEntries (forall be (m :: * -> *).
(BeamMigrateSqlBackend be,
 HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be),
 MonadBeam be m) =>
DatabaseSettings be BeamMigrateDb
beamMigrateDb @be @m))
  let verifyMigration :: Int -> T.Text -> Migration be a -> StateT [LogEntry] (WriterT (Max Int) m) a
      verifyMigration :: forall a.
Int
-> Text
-> Migration be a
-> StateT [LogEntryT Identity] (WriterT (Max Int) m) a
verifyMigration Int
stepIx Text
stepNm Migration be a
step =
        do [LogEntryT Identity]
log <- forall s (m :: * -> *). MonadState s m => m s
get
           case [LogEntryT Identity]
log of
             [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
             LogEntry Columnar Identity Int32
actId C Identity Text
actStepNm C Identity LocalTime
_:[LogEntryT Identity]
log'
               | forall a b. (Integral a, Num b) => a -> b
fromIntegral Columnar Identity Int32
actId forall a. Eq a => a -> a -> Bool
== Int
stepIx Bool -> Bool -> Bool
&& C Identity Text
actStepNm forall a. Eq a => a -> a -> Bool
== Text
stepNm ->
                   forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall a. a -> Max a
Max Int
stepIx) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *). MonadState s m => s -> m ()
put [LogEntryT Identity]
log'
               | forall a b. (Integral a, Num b) => a -> b
fromIntegral Columnar Identity Int32
actId forall a. Eq a => a -> a -> Bool
/= Int
stepIx ->
                   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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). BringUpToDateHooks m -> Int -> m ()
discontinuousMigrationsHook BringUpToDateHooks m
hooks Int
stepIx
               | Bool
otherwise ->
                   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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
BringUpToDateHooks m -> Int -> Text -> Text -> m ()
logMismatchHook BringUpToDateHooks m
hooks Int
stepIx C Identity Text
actStepNm Text
stepNm
           forall (m :: * -> *) be a.
Applicative m =>
(BeamSqlBackendSyntax be -> m ()) -> Migration be a -> m a
executeMigration (\BeamSqlBackendSyntax be
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Migration be a
step

  ([QExprToIdentity
   (LogEntryT (QGenExpr QValueContext be QBaseScope))]
futureEntries, Max Int
lastCommit) <-
    forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (forall (m :: * -> *) be a.
Monad m =>
Int
-> Maybe Int
-> MigrationSteps be () a
-> (forall a'. Int -> Text -> Migration be a' -> m a')
-> m a
runMigrationSteps Int
0 forall a. Maybe a
Nothing MigrationSteps be () (CheckedDatabaseSettings be db)
steps forall a.
Int
-> Text
-> Migration be a
-> StateT [LogEntryT Identity] (WriterT (Max Int) m) a
verifyMigration) [QExprToIdentity
   (LogEntryT (QGenExpr QValueContext be QBaseScope))]
entries forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
                forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (forall a. a -> Max a
Max (-Int
1)))

  case [QExprToIdentity
   (LogEntryT (QGenExpr QValueContext be QBaseScope))]
futureEntries of
    QExprToIdentity (LogEntryT (QGenExpr QValueContext be QBaseScope))
_:[QExprToIdentity
   (LogEntryT (QGenExpr QValueContext be QBaseScope))]
_ -> forall (m :: * -> *). BringUpToDateHooks m -> Int -> m ()
databaseAheadHook BringUpToDateHooks m
hooks (forall (t :: * -> *) a. Foldable t => t a -> Int
length [QExprToIdentity
   (LogEntryT (QGenExpr QValueContext be QBaseScope))]
futureEntries)
    [] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  -- Check data loss
  Bool
shouldRunMigration <-
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {k} (r :: k) (m :: k -> *) a.
ContT r m a -> (a -> m r) -> m r
runContT (\CheckedDatabaseSettings be db
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) be a.
Monad m =>
Int
-> Maybe Int
-> MigrationSteps be () a
-> (forall a'. Int -> Text -> Migration be a' -> m a')
-> m a
runMigrationSteps (Int
lastCommit forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing MigrationSteps be () (CheckedDatabaseSettings be db)
steps
      (\Int
_ Text
_ Migration be a'
step -> do
          case forall be a. Migration be a -> MigrationDataLoss
migrationDataLoss Migration be a'
step of
            MigrationDataLoss
MigrationLosesData ->
              forall {k} (r :: k) (m :: k -> *) a.
((a -> m r) -> m r) -> ContT r m a
ContT forall a b. (a -> b) -> a -> b
$ \a' -> m Bool
_ -> forall (m :: * -> *). BringUpToDateHooks m -> m Bool
runIrreversibleHook BringUpToDateHooks m
hooks
            MigrationDataLoss
MigrationKeepsData ->
              forall (m :: * -> *) be a.
Applicative m =>
(BeamSqlBackendSyntax be -> m ()) -> Migration be a -> m a
executeMigration (\BeamSqlBackendSyntax be
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Migration be a'
step)

  if Bool
shouldRunMigration
    then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         forall (m :: * -> *) be a.
Monad m =>
Int
-> Maybe Int
-> MigrationSteps be () a
-> (forall a'. Int -> Text -> Migration be a' -> m a')
-> m a
runMigrationSteps (Int
lastCommit forall a. Num a => a -> a -> a
+ Int
1) forall a. Maybe a
Nothing MigrationSteps be () (CheckedDatabaseSettings be db)
steps
           (\Int
stepIx Text
stepName Migration be a'
step ->
              do forall (m :: * -> *). BringUpToDateHooks m -> Int -> Text -> m ()
startStepHook BringUpToDateHooks m
hooks Int
stepIx Text
stepName
                 a'
ret <-
                   forall (m :: * -> *) be a.
Applicative m =>
(BeamSqlBackendSyntax be -> m ()) -> Migration be a -> m a
executeMigration
                     (\BeamSqlBackendSyntax be
cmd -> do
                         forall (m :: * -> *). BringUpToDateHooks m -> Int -> String -> m ()
runCommandHook BringUpToDateHooks m
hooks Int
stepIx (BeamSqlBackendSyntax be -> String
renderSyntax' BeamSqlBackendSyntax be
cmd)
                         forall be (m :: * -> *).
MonadBeam be m =>
BeamSqlBackendSyntax be -> m ()
runNoReturn BeamSqlBackendSyntax be
cmd)
                     Migration be a'
step

                 forall be (m :: * -> *) (table :: (* -> *) -> *).
(BeamSqlBackend be, MonadBeam be m) =>
SqlInsert be table -> m ()
runInsert forall a b. (a -> b) -> a -> b
$ forall be (table :: (* -> *) -> *) s (db :: (* -> *) -> *).
(BeamSqlBackend be,
 ProjectibleWithPredicate AnyType () Text (table (QField s))) =>
DatabaseEntity be db (TableEntity table)
-> SqlInsertValues be (table (QExpr be s)) -> SqlInsert be table
insert (forall (entity :: * -> *).
BeamMigrateDb entity -> entity (TableEntity LogEntryT)
_beamMigrateLogEntries (forall be (m :: * -> *).
(BeamMigrateSqlBackend be,
 HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be),
 MonadBeam be m) =>
DatabaseSettings be BeamMigrateDb
beamMigrateDb @be @m)) forall a b. (a -> b) -> a -> b
$
                   forall be (table :: (* -> *) -> *) s.
(BeamSqlBackend be, Beamable table) =>
(forall s'. [table (QExpr be s')])
-> SqlInsertValues be (table (QExpr be s))
insertExpressions [ forall (f :: * -> *).
C f Int32 -> C f Text -> C f LocalTime -> LogEntryT f
LogEntry (forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
stepIx) (forall a. SqlValable a => HaskellLiteralForQExpr a -> a
val_ Text
stepName) forall be ctxt s. BeamSqlBackend be => QGenExpr ctxt be s LocalTime
currentTimestamp_ ]
                 forall (m :: * -> *). BringUpToDateHooks m -> Int -> Text -> m ()
endStepHook BringUpToDateHooks m
hooks Int
stepIx Text
stepName

                 forall (m :: * -> *) a. Monad m => a -> m a
return a'
ret)
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Attempt to find a SQL schema given an 'ActionProvider' and a checked
-- database. Returns 'Nothing' if no schema could be found, which usually means
-- you have chosen the wrong 'ActionProvider', or the backend you're using is
-- buggy.
simpleSchema :: Database be db
             => ActionProvider be
             -> CheckedDatabaseSettings be db
             -> Maybe [BeamSqlBackendSyntax be]
simpleSchema :: forall be (db :: (* -> *) -> *).
Database be db =>
ActionProvider be
-> CheckedDatabaseSettings be db -> Maybe [BeamSqlBackendSyntax be]
simpleSchema ActionProvider be
provider CheckedDatabaseSettings be db
settings =
  let allChecks :: [SomeDatabasePredicate]
allChecks = forall be (db :: (* -> *) -> *).
Database be db =>
CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
collectChecks CheckedDatabaseSettings be db
settings
      solver :: Solver be
solver    = forall be.
ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
heuristicSolver ActionProvider be
provider [] [SomeDatabasePredicate]
allChecks
  in case forall be. Solver be -> FinalSolution be
finalSolution Solver be
solver of
       Solved [MigrationCommand be]
cmds -> forall a. a -> Maybe a
Just (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall be. MigrationCommand be -> BeamSqlBackendSyntax be
migrationCommand [MigrationCommand be]
cmds)
       Candidates {} -> forall a. Maybe a
Nothing

-- | Given a 'CheckedDatabaseSettings' and a 'BeamMigrationBackend',
-- attempt to create the schema from scratch in the current database.
--
-- May 'fail' if we cannot find a schema
createSchema :: (Database be db, Fail.MonadFail m)
             => BeamMigrationBackend be m
             -> CheckedDatabaseSettings be db
             -> m ()
createSchema :: forall be (db :: (* -> *) -> *) (m :: * -> *).
(Database be db, MonadFail m) =>
BeamMigrationBackend be m -> CheckedDatabaseSettings be db -> m ()
createSchema BeamMigrationBackend { backendActionProvider :: forall be (m :: * -> *).
BeamMigrationBackend be m -> ActionProvider be
backendActionProvider = ActionProvider be
actions } CheckedDatabaseSettings be db
db =
  case forall be (db :: (* -> *) -> *).
Database be db =>
ActionProvider be
-> CheckedDatabaseSettings be db -> Maybe [BeamSqlBackendSyntax be]
simpleSchema ActionProvider be
actions CheckedDatabaseSettings be db
db of
    Maybe [BeamSqlBackendSyntax be]
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"createSchema: Could not determine schema"
    Just [BeamSqlBackendSyntax be]
cmds ->
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall be (m :: * -> *).
MonadBeam be m =>
BeamSqlBackendSyntax be -> m ()
runNoReturn [BeamSqlBackendSyntax be]
cmds

-- | Given a 'BeamMigrationBackend', attempt to automatically bring the current
-- database up-to-date with the given 'CheckedDatabaseSettings'. Fails (via
-- 'fail') if this involves an irreversible migration (one that may result in
-- data loss).
autoMigrate :: (Database be db, Fail.MonadFail m)
            => BeamMigrationBackend be m
            -> CheckedDatabaseSettings be db
            -> m ()
autoMigrate :: forall be (db :: (* -> *) -> *) (m :: * -> *).
(Database be db, MonadFail m) =>
BeamMigrationBackend be m -> CheckedDatabaseSettings be db -> m ()
autoMigrate BeamMigrationBackend { backendActionProvider :: forall be (m :: * -> *).
BeamMigrationBackend be m -> ActionProvider be
backendActionProvider = ActionProvider be
actions
                                 , backendGetDbConstraints :: forall be (m :: * -> *).
BeamMigrationBackend be m -> m [SomeDatabasePredicate]
backendGetDbConstraints = m [SomeDatabasePredicate]
getCs }
            CheckedDatabaseSettings be db
db =
  do [SomeDatabasePredicate]
actual <- m [SomeDatabasePredicate]
getCs
     let expected :: [SomeDatabasePredicate]
expected = forall be (db :: (* -> *) -> *).
Database be db =>
CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
collectChecks CheckedDatabaseSettings be db
db
     case forall be. Solver be -> FinalSolution be
finalSolution (forall be.
ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
heuristicSolver ActionProvider be
actions [SomeDatabasePredicate]
actual [SomeDatabasePredicate]
expected) of
       Candidates {} -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"autoMigrate: Could not determine migration"
       Solved [MigrationCommand be]
cmds ->
         -- Check if any of the commands are irreversible
         case forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap forall be. MigrationCommand be -> MigrationDataLoss
migrationCommandDataLossPossible [MigrationCommand be]
cmds of
           MigrationDataLoss
MigrationKeepsData -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall be (m :: * -> *).
MonadBeam be m =>
BeamSqlBackendSyntax be -> m ()
runNoReturn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall be. MigrationCommand be -> BeamSqlBackendSyntax be
migrationCommand) [MigrationCommand be]
cmds
           MigrationDataLoss
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"autoMigrate: Not performing automatic migration due to data loss"

-- | Given a migration backend, a handle to a database, and a checked database,
-- attempt to find a schema. This should always return 'Just', unless the
-- backend has incomplete migrations support.
--
-- 'BeamMigrationBackend's can usually be found in a module named
-- @Database.Beam.<Backend>.Migrate@ with the name@migrationBackend@
simpleMigration :: ( MonadBeam be m
                 ,   Database be db )
                => (forall a. handle -> m a -> IO a)
                -> BeamMigrationBackend be m
                -> handle
                -> CheckedDatabaseSettings be db
                -> IO (Maybe [BeamSqlBackendSyntax be])
simpleMigration :: forall be (m :: * -> *) (db :: (* -> *) -> *) handle.
(MonadBeam be m, Database be db) =>
(forall a. handle -> m a -> IO a)
-> BeamMigrationBackend be m
-> handle
-> CheckedDatabaseSettings be db
-> IO (Maybe [BeamSqlBackendSyntax be])
simpleMigration forall a. handle -> m a -> IO a
runner BeamMigrationBackend { backendGetDbConstraints :: forall be (m :: * -> *).
BeamMigrationBackend be m -> m [SomeDatabasePredicate]
backendGetDbConstraints = m [SomeDatabasePredicate]
getCs
                                            , backendActionProvider :: forall be (m :: * -> *).
BeamMigrationBackend be m -> ActionProvider be
backendActionProvider = ActionProvider be
action } handle
hdl CheckedDatabaseSettings be db
db = do
  [SomeDatabasePredicate]
pre <- forall a. handle -> m a -> IO a
runner handle
hdl m [SomeDatabasePredicate]
getCs

  let post :: [SomeDatabasePredicate]
post = forall be (db :: (* -> *) -> *).
Database be db =>
CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
collectChecks CheckedDatabaseSettings be db
db
      solver :: Solver be
solver = forall be.
ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
heuristicSolver ActionProvider be
action [SomeDatabasePredicate]
pre [SomeDatabasePredicate]
post

  case forall be. Solver be -> FinalSolution be
finalSolution Solver be
solver of
    Solved [MigrationCommand be]
cmds -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall be. MigrationCommand be -> BeamSqlBackendSyntax be
migrationCommand [MigrationCommand be]
cmds))
    Candidates {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- | Result type for 'verifySchema'
data VerificationResult
  = VerificationSucceeded
  | VerificationFailed [SomeDatabasePredicate]
  deriving Int -> VerificationResult -> ShowS
[VerificationResult] -> ShowS
VerificationResult -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [VerificationResult] -> ShowS
$cshowList :: [VerificationResult] -> ShowS
show :: VerificationResult -> String
$cshow :: VerificationResult -> String
showsPrec :: Int -> VerificationResult -> ShowS
$cshowsPrec :: Int -> VerificationResult -> ShowS
Show

-- | Verify that the given, beam database matches the actual
-- schema. On success, returns 'VerificationSucceeded', on failure,
-- returns 'VerificationFailed' and a list of missing predicates.
verifySchema :: ( Database be db, MonadBeam be m )
             => BeamMigrationBackend be m
             -> CheckedDatabaseSettings be db
             -> m VerificationResult
verifySchema :: forall be (db :: (* -> *) -> *) (m :: * -> *).
(Database be db, MonadBeam be m) =>
BeamMigrationBackend be m
-> CheckedDatabaseSettings be db -> m VerificationResult
verifySchema BeamMigrationBackend be m
backend CheckedDatabaseSettings be db
db = do
  CheckResult
result <- forall be (db :: (* -> *) -> *) (m :: * -> *).
(Database be db, Monad m) =>
BeamMigrationBackend be m
-> CheckedDatabaseSettings be db
-> IgnorePredicates
-> m CheckResult
checkSchema BeamMigrationBackend be m
backend CheckedDatabaseSettings be db
db IgnorePredicates
ignoreAll
  if forall a. HashSet a -> Bool
HS.null forall a b. (a -> b) -> a -> b
$ CheckResult -> HashSet SomeDatabasePredicate
missingPredicates CheckResult
result
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure VerificationResult
VerificationSucceeded
    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [SomeDatabasePredicate] -> VerificationResult
VerificationFailed forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
HS.toList forall a b. (a -> b) -> a -> b
$ CheckResult -> HashSet SomeDatabasePredicate
missingPredicates CheckResult
result

-- | Result type for 'checkSchema'
data CheckResult = CheckResult
  { -- | Expected predicates from the 'CheckedDatabaseSettings' which were not
    -- found in the live database
    CheckResult -> HashSet SomeDatabasePredicate
missingPredicates :: HS.HashSet SomeDatabasePredicate
  , -- | Predicates found in the live database which are not present in the
    -- 'CheckedDatabaseSettings' and are not ignored
    CheckResult -> HashSet SomeDatabasePredicate
unexpectedPredicates :: HS.HashSet SomeDatabasePredicate
  } deriving (CheckResult -> CheckResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CheckResult -> CheckResult -> Bool
$c/= :: CheckResult -> CheckResult -> Bool
== :: CheckResult -> CheckResult -> Bool
$c== :: CheckResult -> CheckResult -> Bool
Eq, Int -> CheckResult -> ShowS
[CheckResult] -> ShowS
CheckResult -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CheckResult] -> ShowS
$cshowList :: [CheckResult] -> ShowS
show :: CheckResult -> String
$cshow :: CheckResult -> String
showsPrec :: Int -> CheckResult -> ShowS
$cshowsPrec :: Int -> CheckResult -> ShowS
Show)

-- | Selects a class of predicates to ignore if detected (e.g. metadata tables
-- for migrations, other schemas, etc.).
newtype IgnorePredicates = IgnorePredicates
  { IgnorePredicates -> SomeDatabasePredicate -> Any
unIgnorePredicates :: SomeDatabasePredicate -> Any
  } deriving (NonEmpty IgnorePredicates -> IgnorePredicates
IgnorePredicates -> IgnorePredicates -> IgnorePredicates
forall b. Integral b => b -> IgnorePredicates -> IgnorePredicates
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> IgnorePredicates -> IgnorePredicates
$cstimes :: forall b. Integral b => b -> IgnorePredicates -> IgnorePredicates
sconcat :: NonEmpty IgnorePredicates -> IgnorePredicates
$csconcat :: NonEmpty IgnorePredicates -> IgnorePredicates
<> :: IgnorePredicates -> IgnorePredicates -> IgnorePredicates
$c<> :: IgnorePredicates -> IgnorePredicates -> IgnorePredicates
Semigroup, Semigroup IgnorePredicates
IgnorePredicates
[IgnorePredicates] -> IgnorePredicates
IgnorePredicates -> IgnorePredicates -> IgnorePredicates
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [IgnorePredicates] -> IgnorePredicates
$cmconcat :: [IgnorePredicates] -> IgnorePredicates
mappend :: IgnorePredicates -> IgnorePredicates -> IgnorePredicates
$cmappend :: IgnorePredicates -> IgnorePredicates -> IgnorePredicates
mempty :: IgnorePredicates
$cmempty :: IgnorePredicates
Monoid)

-- | Ignore predicates relating to tables matching the given name predicate.
ignoreTables :: (QualifiedName -> Bool) -> IgnorePredicates
ignoreTables :: (QualifiedName -> Bool) -> IgnorePredicates
ignoreTables QualifiedName -> Bool
shouldIgnore = (SomeDatabasePredicate -> Any) -> IgnorePredicates
IgnorePredicates forall a b. (a -> b) -> a -> b
$ \(SomeDatabasePredicate p
dp) ->
  case forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast p
dp of
    Just (TableExistsPredicate QualifiedName
name) -> Bool -> Any
Any forall a b. (a -> b) -> a -> b
$ QualifiedName -> Bool
shouldIgnore QualifiedName
name
    Maybe TableExistsPredicate
Nothing -> Bool -> Any
Any Bool
False

-- | Ignore any unknown predicates. This probably only makes sense to use if
-- you are only querying and not writing to the database.
ignoreAll :: IgnorePredicates
ignoreAll :: IgnorePredicates
ignoreAll = (SomeDatabasePredicate -> Any) -> IgnorePredicates
IgnorePredicates forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ Bool -> Any
Any Bool
True

-- | Checks the given database settings against the live database. This is
-- similar to 'verifySchema', but detects and returns unknown predicates that
-- are true about the live database (e.g. unknown tables, fields, etc.).
checkSchema
  :: (Database be db, Monad m)
  => BeamMigrationBackend be m
  -> CheckedDatabaseSettings be db
  -> IgnorePredicates
  -> m CheckResult
checkSchema :: forall be (db :: (* -> *) -> *) (m :: * -> *).
(Database be db, Monad m) =>
BeamMigrationBackend be m
-> CheckedDatabaseSettings be db
-> IgnorePredicates
-> m CheckResult
checkSchema BeamMigrationBackend be m
backend CheckedDatabaseSettings be db
db (IgnorePredicates SomeDatabasePredicate -> Any
ignore) = do
  HashSet SomeDatabasePredicate
actual <- forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall be (m :: * -> *).
BeamMigrationBackend be m -> m [SomeDatabasePredicate]
backendGetDbConstraints BeamMigrationBackend be m
backend
  let expected :: HashSet SomeDatabasePredicate
expected = forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList forall a b. (a -> b) -> a -> b
$ forall be (db :: (* -> *) -> *).
Database be db =>
CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
collectChecks CheckedDatabaseSettings be db
db
      missing :: HashSet SomeDatabasePredicate
missing = HashSet SomeDatabasePredicate
expected forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
actual
      extra :: HashSet SomeDatabasePredicate
extra = HashSet SomeDatabasePredicate
actual forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
expected
      ignored :: HashSet SomeDatabasePredicate
ignored = forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter (Any -> Bool
getAny forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeDatabasePredicate -> Any
ignore) HashSet SomeDatabasePredicate
extra
      unexpected :: HashSet SomeDatabasePredicate
unexpected = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter HashSet SomeDatabasePredicate
extra forall a b. (a -> b) -> a -> b
$ \sdp :: SomeDatabasePredicate
sdp@(SomeDatabasePredicate p
dp) ->
        Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *). Foldable t => t Bool -> Bool
or
          [ SomeDatabasePredicate
sdp forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet SomeDatabasePredicate
ignored
          , forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall a b. (a -> b) -> a -> b
$ forall a. HashSet a -> [a]
HS.toList HashSet SomeDatabasePredicate
ignored forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(SomeDatabasePredicate p
ignoredDp) ->
              p
dp forall p p'.
(DatabasePredicate p, DatabasePredicate p') =>
p -> p' -> Bool
`predicateCascadesDropOn` p
ignoredDp
          ]

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CheckResult
    { missingPredicates :: HashSet SomeDatabasePredicate
missingPredicates = HashSet SomeDatabasePredicate
missing
    , unexpectedPredicates :: HashSet SomeDatabasePredicate
unexpectedPredicates = HashSet SomeDatabasePredicate
unexpected
    }

-- | Run a sequence of commands on a database
runSimpleMigration :: MonadBeam be m
                   => (forall a. hdl -> m a -> IO a)
                   -> hdl -> [BeamSqlBackendSyntax be] -> IO ()
runSimpleMigration :: forall be (m :: * -> *) hdl.
MonadBeam be m =>
(forall a. hdl -> m a -> IO a)
-> hdl -> [BeamSqlBackendSyntax be] -> IO ()
runSimpleMigration forall a. hdl -> m a -> IO a
runner hdl
hdl =
  forall a. hdl -> m a -> IO a
runner hdl
hdl 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_ forall be (m :: * -> *).
MonadBeam be m =>
BeamSqlBackendSyntax be -> m ()
runNoReturn

-- | Given a function to convert a command to a 'String', produce a script that
-- will execute the given migration. Usually, the function you provide
-- eventually calls 'displaySyntax' to rendere the command.
backendMigrationScript :: BeamSqlBackend be
                       => (BeamSqlBackendSyntax be -> String)
                       -> Migration be a
                       -> String
backendMigrationScript :: forall be a.
BeamSqlBackend be =>
(BeamSqlBackendSyntax be -> String) -> Migration be a -> String
backendMigrationScript BeamSqlBackendSyntax be -> String
render Migration be a
mig =
  forall be m a.
(Monoid m, Semigroup m, BeamSqlBackend be) =>
(Text -> m)
-> (BeamSqlBackendSyntax be -> m) -> MigrationSteps be () a -> m
migrateScript ((forall a. [a] -> [a] -> [a]
++String
"\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ((forall a. [a] -> [a] -> [a]
++String
"\n") forall b c a. (b -> c) -> (a -> b) -> a -> c
. BeamSqlBackendSyntax be -> String
render) (forall a be a'.
Text -> (a -> Migration be a') -> MigrationSteps be a a'
migrationStep Text
"Migration Script" (\() -> Migration be a
mig))

-- | Given a 'BeamMigrationBackend', get a string representing a Haskell module
-- that would be a good starting point for further development.
--
-- For example, for a postgres database named @chinook@
--
-- > import Database.Beam.Migrate.Simple
-- > import Database.Beam.Postgres (runBeamPostgres)
-- > import Database.Beam.Postgres.Migrate (migrationBackend)
-- > import Database.PostgreSQL.Simple
-- >
-- > getSchema :: IO String
-- > getSchema = do pg <- connectPostgreSQL
-- >                runBeamPostgres pg (haskellSchema migrationBackend)
--
-- Backends that have a migration backend typically export it under the module
-- name @Database.Beam./Backend/.Migrate@.
haskellSchema :: (MonadBeam be m, Fail.MonadFail m)
              => BeamMigrationBackend be m
              -> m String
haskellSchema :: forall be (m :: * -> *).
(MonadBeam be m, MonadFail m) =>
BeamMigrationBackend be m -> m String
haskellSchema BeamMigrationBackend { backendGetDbConstraints :: forall be (m :: * -> *).
BeamMigrationBackend be m -> m [SomeDatabasePredicate]
backendGetDbConstraints = m [SomeDatabasePredicate]
getCs
                                   , backendConvertToHaskell :: forall be (m :: * -> *).
BeamMigrationBackend be m -> HaskellPredicateConverter
backendConvertToHaskell = HaskellPredicateConverter SomeDatabasePredicate -> Maybe SomeDatabasePredicate
conv2Hs } = do
  [SomeDatabasePredicate]
constraints <- m [SomeDatabasePredicate]
getCs
  let hsConstraints :: [SomeDatabasePredicate]
hsConstraints = [ SomeDatabasePredicate
hsConstraint | SomeDatabasePredicate
c <- [SomeDatabasePredicate]
constraints, Just SomeDatabasePredicate
hsConstraint <- [ SomeDatabasePredicate -> Maybe SomeDatabasePredicate
conv2Hs SomeDatabasePredicate
c ] ]

      solver :: Solver HsMigrateBackend
solver = forall be.
ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
heuristicSolver (forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
defaultActionProvider @HsMigrateBackend) [] [SomeDatabasePredicate]
hsConstraints

  case forall be. Solver be -> FinalSolution be
finalSolution Solver HsMigrateBackend
solver of
    Solved [MigrationCommand HsMigrateBackend]
cmds   ->
      let hsModule :: HsModule
hsModule = String -> [HsAction] -> HsModule
hsActionsToModule String
"NewBeamSchema" (forall a b. (a -> b) -> [a] -> [b]
map forall be. MigrationCommand be -> BeamSqlBackendSyntax be
migrationCommand [MigrationCommand HsMigrateBackend]
cmds)
      in case HsModule -> Either String String
renderHsSchema HsModule
hsModule of
           Left String
err -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"Error writing Haskell schema: " forall a. [a] -> [a] -> [a]
++ String
err)
           Right String
modStr -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
modStr
    Candidates {} -> forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"Could not form Haskell schema"