{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
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
, forall (m :: * -> *). BringUpToDateHooks m -> Int -> Text -> m ()
startStepHook :: Int -> T.Text -> m ()
, forall (m :: * -> *). BringUpToDateHooks m -> Int -> Text -> m ()
endStepHook :: Int -> T.Text -> m ()
, forall (m :: * -> *). BringUpToDateHooks m -> Int -> String -> m ()
runCommandHook :: Int -> String -> m ()
, forall (m :: * -> *). BringUpToDateHooks m -> m ()
queryFailedHook :: m ()
, forall (m :: * -> *). BringUpToDateHooks m -> Int -> m ()
discontinuousMigrationsHook
:: Int -> m ()
, forall (m :: * -> *).
BringUpToDateHooks m -> Int -> Text -> Text -> m ()
logMismatchHook :: Int -> T.Text -> T.Text -> m ()
, forall (m :: * -> *). BringUpToDateHooks m -> Int -> m ()
databaseAheadHook :: Int -> m ()
}
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)")
}
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
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 ()
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
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
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
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 ->
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"
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
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
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
data CheckResult = CheckResult
{
CheckResult -> HashSet SomeDatabasePredicate
missingPredicates :: HS.HashSet SomeDatabasePredicate
,
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)
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)
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
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
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
}
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
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))
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"