{-# 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(..))
import           Data.Typeable
import           Data.Functor
import qualified Data.Text as T

import qualified Control.Monad.Fail as Fail

data BringUpToDateHooks m
  = BringUpToDateHooks
  { 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.
  , BringUpToDateHooks m -> Int -> Text -> m ()
startStepHook       :: Int -> T.Text -> m ()
    -- ^ Called at the beginning of each step with the step index and description
  , BringUpToDateHooks m -> Int -> Text -> m ()
endStepHook         :: Int -> T.Text -> m ()
    -- ^ Called at the end of each step with the step index and description
  , 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.

  , BringUpToDateHooks m -> m ()
queryFailedHook     :: m ()
    -- ^ Called when a query fails
  , BringUpToDateHooks m -> Int -> m ()
discontinuousMigrationsHook
                        :: Int -> m ()
    -- ^ Called when the migration log has a discontinuity at the supplied index
  , 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
  , 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 :: BringUpToDateHooks m
defaultUpToDateHooks =
  BringUpToDateHooks :: forall (m :: * -> *).
m Bool
-> (Int -> Text -> m ())
-> (Int -> Text -> m ())
-> (Int -> String -> m ())
-> m ()
-> (Int -> m ())
-> (Int -> Text -> Text -> m ())
-> (Int -> m ())
-> BringUpToDateHooks m
BringUpToDateHooks
  { runIrreversibleHook :: m Bool
runIrreversibleHook = Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  , startStepHook :: Int -> Text -> m ()
startStepHook       = \Int
_ Text
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , endStepHook :: Int -> Text -> m ()
endStepHook         = \Int
_ Text
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , runCommandHook :: Int -> String -> m ()
runCommandHook      = \Int
_ String
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  , queryFailedHook :: m ()
queryFailedHook     = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"Log entry query fails"
  , discontinuousMigrationsHook :: Int -> m ()
discontinuousMigrationsHook =
      \Int
ix -> String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"Discontinuous migration log: missing migration at " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ix)
  , logMismatchHook :: Int -> Text -> Text -> m ()
logMismatchHook =
      \Int
ix Text
actual Text
expected ->
        String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"Log mismatch at index " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"  expected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
expected String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String
"  actual  : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack Text
actual)
  , databaseAheadHook :: Int -> m ()
databaseAheadHook =
      \Int
aheadBy ->
        String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String
"The database is ahead of the known schema by " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
aheadBy String -> String -> String
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 :: BeamMigrationBackend be m
-> MigrationSteps be () (CheckedDatabaseSettings be db)
-> m (Maybe (CheckedDatabaseSettings be db))
bringUpToDate be :: BeamMigrationBackend be m
be@BeamMigrationBackend {} =
  BringUpToDateHooks m
-> BeamMigrationBackend be m
-> MigrationSteps be () (CheckedDatabaseSettings be db)
-> m (Maybe (CheckedDatabaseSettings be db))
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
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 :: 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
  BeamMigrationBackend be m -> m ()
forall be (m :: * -> *).
(BeamSqlBackendCanSerialize be Text, MonadFail m) =>
BeamMigrationBackend be m -> m ()
ensureBackendTables BeamMigrationBackend be m
be

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

  ([LogEntryT Identity]
futureEntries, Max Int
lastCommit) <-
    WriterT (Max Int) m [LogEntryT Identity]
-> m ([LogEntryT Identity], Max Int)
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (StateT
  [LogEntryT Identity]
  (WriterT (Max Int) m)
  (CheckedDatabaseSettings be db)
-> [LogEntryT Identity] -> WriterT (Max Int) m [LogEntryT Identity]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Int
-> Maybe Int
-> MigrationSteps be () (CheckedDatabaseSettings be db)
-> (forall a'.
    Int
    -> Text
    -> Migration be a'
    -> StateT [LogEntryT Identity] (WriterT (Max Int) m) a')
-> StateT
     [LogEntryT Identity]
     (WriterT (Max Int) m)
     (CheckedDatabaseSettings be db)
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 Maybe Int
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) [LogEntryT Identity]
entries WriterT (Max Int) m [LogEntryT Identity]
-> WriterT (Max Int) m ()
-> WriterT (Max Int) m [LogEntryT Identity]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
                Max Int -> WriterT (Max Int) m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Int -> Max Int
forall a. a -> Max a
Max (-Int
1)))

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

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

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

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

                 a' -> m a'
forall (m :: * -> *) a. Monad m => a -> m a
return a'
ret)
    else Maybe (CheckedDatabaseSettings be db)
-> m (Maybe (CheckedDatabaseSettings be db))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (CheckedDatabaseSettings be db)
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 :: ActionProvider be
-> CheckedDatabaseSettings be db -> Maybe [BeamSqlBackendSyntax be]
simpleSchema ActionProvider be
provider CheckedDatabaseSettings be db
settings =
  let allChecks :: [SomeDatabasePredicate]
allChecks = CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
forall be (db :: (* -> *) -> *).
Database be db =>
CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
collectChecks CheckedDatabaseSettings be db
settings
      solver :: Solver be
solver    = ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
forall be.
ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
heuristicSolver ActionProvider be
provider [] [SomeDatabasePredicate]
allChecks
  in case Solver be -> FinalSolution be
forall be. Solver be -> FinalSolution be
finalSolution Solver be
solver of
       Solved [MigrationCommand be]
cmds -> [BeamSqlBackendSyntax be] -> Maybe [BeamSqlBackendSyntax be]
forall a. a -> Maybe a
Just ((MigrationCommand be -> BeamSqlBackendSyntax be)
-> [MigrationCommand be] -> [BeamSqlBackendSyntax be]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MigrationCommand be -> BeamSqlBackendSyntax be
forall be. MigrationCommand be -> BeamSqlBackendSyntax be
migrationCommand [MigrationCommand be]
cmds)
       Candidates {} -> Maybe [BeamSqlBackendSyntax be]
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 :: 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 ActionProvider be
-> CheckedDatabaseSettings be db -> Maybe [BeamSqlBackendSyntax be]
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 -> String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
"createSchema: Could not determine schema"
    Just [BeamSqlBackendSyntax be]
cmds ->
        (BeamSqlBackendSyntax be -> m ())
-> [BeamSqlBackendSyntax be] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BeamSqlBackendSyntax be -> m ()
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 :: 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 = CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
forall be (db :: (* -> *) -> *).
Database be db =>
CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
collectChecks CheckedDatabaseSettings be db
db
     case Solver be -> FinalSolution be
forall be. Solver be -> FinalSolution be
finalSolution (ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
forall be.
ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
heuristicSolver ActionProvider be
actions [SomeDatabasePredicate]
actual [SomeDatabasePredicate]
expected) of
       Candidates {} -> String -> m ()
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 (MigrationCommand be -> MigrationDataLoss)
-> [MigrationCommand be] -> MigrationDataLoss
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap MigrationCommand be -> MigrationDataLoss
forall be. MigrationCommand be -> MigrationDataLoss
migrationCommandDataLossPossible [MigrationCommand be]
cmds of
           MigrationDataLoss
MigrationKeepsData -> (MigrationCommand be -> m ()) -> [MigrationCommand be] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (BeamSqlBackendSyntax be -> m ()
forall be (m :: * -> *).
MonadBeam be m =>
BeamSqlBackendSyntax be -> m ()
runNoReturn (BeamSqlBackendSyntax be -> m ())
-> (MigrationCommand be -> BeamSqlBackendSyntax be)
-> MigrationCommand be
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MigrationCommand be -> BeamSqlBackendSyntax be
forall be. MigrationCommand be -> BeamSqlBackendSyntax be
migrationCommand) [MigrationCommand be]
cmds
           MigrationDataLoss
_ -> String -> m ()
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 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 <- handle -> m [SomeDatabasePredicate] -> IO [SomeDatabasePredicate]
forall a. handle -> m a -> IO a
runner handle
hdl m [SomeDatabasePredicate]
getCs

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

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

-- | Result type for 'verifySchema'
data VerificationResult
  = VerificationSucceeded
  | VerificationFailed [SomeDatabasePredicate]
  deriving Int -> VerificationResult -> String -> String
[VerificationResult] -> String -> String
VerificationResult -> String
(Int -> VerificationResult -> String -> String)
-> (VerificationResult -> String)
-> ([VerificationResult] -> String -> String)
-> Show VerificationResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [VerificationResult] -> String -> String
$cshowList :: [VerificationResult] -> String -> String
show :: VerificationResult -> String
$cshow :: VerificationResult -> String
showsPrec :: Int -> VerificationResult -> String -> String
$cshowsPrec :: Int -> VerificationResult -> String -> String
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 :: BeamMigrationBackend be m
-> CheckedDatabaseSettings be db -> m VerificationResult
verifySchema BeamMigrationBackend be m
backend CheckedDatabaseSettings be db
db = do
  CheckResult
result <- BeamMigrationBackend be m
-> CheckedDatabaseSettings be db
-> IgnorePredicates
-> m CheckResult
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 HashSet SomeDatabasePredicate -> Bool
forall a. HashSet a -> Bool
HS.null (HashSet SomeDatabasePredicate -> Bool)
-> HashSet SomeDatabasePredicate -> Bool
forall a b. (a -> b) -> a -> b
$ CheckResult -> HashSet SomeDatabasePredicate
missingPredicates CheckResult
result
    then VerificationResult -> m VerificationResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure VerificationResult
VerificationSucceeded
    else VerificationResult -> m VerificationResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure (VerificationResult -> m VerificationResult)
-> VerificationResult -> m VerificationResult
forall a b. (a -> b) -> a -> b
$ [SomeDatabasePredicate] -> VerificationResult
VerificationFailed ([SomeDatabasePredicate] -> VerificationResult)
-> [SomeDatabasePredicate] -> VerificationResult
forall a b. (a -> b) -> a -> b
$ HashSet SomeDatabasePredicate -> [SomeDatabasePredicate]
forall a. HashSet a -> [a]
HS.toList (HashSet SomeDatabasePredicate -> [SomeDatabasePredicate])
-> HashSet SomeDatabasePredicate -> [SomeDatabasePredicate]
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
(CheckResult -> CheckResult -> Bool)
-> (CheckResult -> CheckResult -> Bool) -> Eq CheckResult
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 -> String -> String
[CheckResult] -> String -> String
CheckResult -> String
(Int -> CheckResult -> String -> String)
-> (CheckResult -> String)
-> ([CheckResult] -> String -> String)
-> Show CheckResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [CheckResult] -> String -> String
$cshowList :: [CheckResult] -> String -> String
show :: CheckResult -> String
$cshow :: CheckResult -> String
showsPrec :: Int -> CheckResult -> String -> String
$cshowsPrec :: Int -> CheckResult -> String -> String
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 (b -> IgnorePredicates -> IgnorePredicates
NonEmpty IgnorePredicates -> IgnorePredicates
IgnorePredicates -> IgnorePredicates -> IgnorePredicates
(IgnorePredicates -> IgnorePredicates -> IgnorePredicates)
-> (NonEmpty IgnorePredicates -> IgnorePredicates)
-> (forall b.
    Integral b =>
    b -> IgnorePredicates -> IgnorePredicates)
-> Semigroup 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 :: 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
Semigroup IgnorePredicates
-> IgnorePredicates
-> (IgnorePredicates -> IgnorePredicates -> IgnorePredicates)
-> ([IgnorePredicates] -> IgnorePredicates)
-> Monoid 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
$cp1Monoid :: Semigroup 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 ((SomeDatabasePredicate -> Any) -> IgnorePredicates)
-> (SomeDatabasePredicate -> Any) -> IgnorePredicates
forall a b. (a -> b) -> a -> b
$ \(SomeDatabasePredicate p
dp) ->
  case p -> Maybe TableExistsPredicate
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast p
dp of
    Just (TableExistsPredicate QualifiedName
name) -> Bool -> Any
Any (Bool -> Any) -> Bool -> 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 ((SomeDatabasePredicate -> Any) -> IgnorePredicates)
-> (SomeDatabasePredicate -> Any) -> IgnorePredicates
forall a b. (a -> b) -> a -> b
$ Any -> SomeDatabasePredicate -> Any
forall a b. a -> b -> a
const (Any -> SomeDatabasePredicate -> Any)
-> Any -> SomeDatabasePredicate -> Any
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 :: 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 <- [SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate)
-> m [SomeDatabasePredicate] -> m (HashSet SomeDatabasePredicate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BeamMigrationBackend be m -> m [SomeDatabasePredicate]
forall be (m :: * -> *).
BeamMigrationBackend be m -> m [SomeDatabasePredicate]
backendGetDbConstraints BeamMigrationBackend be m
backend
  let expected :: HashSet SomeDatabasePredicate
expected = [SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([SomeDatabasePredicate] -> HashSet SomeDatabasePredicate)
-> [SomeDatabasePredicate] -> HashSet SomeDatabasePredicate
forall a b. (a -> b) -> a -> b
$ CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
forall be (db :: (* -> *) -> *).
Database be db =>
CheckedDatabaseSettings be db -> [SomeDatabasePredicate]
collectChecks CheckedDatabaseSettings be db
db
      missing :: HashSet SomeDatabasePredicate
missing = HashSet SomeDatabasePredicate
expected HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
actual
      extra :: HashSet SomeDatabasePredicate
extra = HashSet SomeDatabasePredicate
actual HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. (Eq a, Hashable a) => HashSet a -> HashSet a -> HashSet a
`HS.difference` HashSet SomeDatabasePredicate
expected
      ignored :: HashSet SomeDatabasePredicate
ignored = (SomeDatabasePredicate -> Bool)
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter (Any -> Bool
getAny (Any -> Bool)
-> (SomeDatabasePredicate -> Any) -> SomeDatabasePredicate -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeDatabasePredicate -> Any
ignore) HashSet SomeDatabasePredicate
extra
      unexpected :: HashSet SomeDatabasePredicate
unexpected = ((SomeDatabasePredicate -> Bool)
 -> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate)
-> HashSet SomeDatabasePredicate
-> (SomeDatabasePredicate -> Bool)
-> HashSet SomeDatabasePredicate
forall a b c. (a -> b -> c) -> b -> a -> c
flip (SomeDatabasePredicate -> Bool)
-> HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate
forall a. (a -> Bool) -> HashSet a -> HashSet a
HS.filter HashSet SomeDatabasePredicate
extra ((SomeDatabasePredicate -> Bool) -> HashSet SomeDatabasePredicate)
-> (SomeDatabasePredicate -> Bool) -> HashSet SomeDatabasePredicate
forall a b. (a -> b) -> a -> b
$ \sdp :: SomeDatabasePredicate
sdp@(SomeDatabasePredicate p
dp) ->
        Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
          [ SomeDatabasePredicate
sdp SomeDatabasePredicate -> HashSet SomeDatabasePredicate -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet SomeDatabasePredicate
ignored
          , [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ HashSet SomeDatabasePredicate -> [SomeDatabasePredicate]
forall a. HashSet a -> [a]
HS.toList HashSet SomeDatabasePredicate
ignored [SomeDatabasePredicate]
-> (SomeDatabasePredicate -> Bool) -> [Bool]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(SomeDatabasePredicate p
ignoredDp) ->
              p
dp p -> p -> Bool
forall p p'.
(DatabasePredicate p, DatabasePredicate p') =>
p -> p' -> Bool
`predicateCascadesDropOn` p
ignoredDp
          ]

  CheckResult -> m CheckResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CheckResult -> m CheckResult) -> CheckResult -> m CheckResult
forall a b. (a -> b) -> a -> b
$ CheckResult :: HashSet SomeDatabasePredicate
-> HashSet SomeDatabasePredicate -> CheckResult
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 a. hdl -> m a -> IO a)
-> hdl -> [BeamSqlBackendSyntax be] -> IO ()
runSimpleMigration forall a. hdl -> m a -> IO a
runner hdl
hdl =
  hdl -> m () -> IO ()
forall a. hdl -> m a -> IO a
runner hdl
hdl (m () -> IO ())
-> ([BeamSqlBackendSyntax be] -> m ())
-> [BeamSqlBackendSyntax be]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BeamSqlBackendSyntax be -> m ())
-> [BeamSqlBackendSyntax be] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ BeamSqlBackendSyntax be -> m ()
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 :: (BeamSqlBackendSyntax be -> String) -> Migration be a -> String
backendMigrationScript BeamSqlBackendSyntax be -> String
render Migration be a
mig =
  (Text -> String)
-> (BeamSqlBackendSyntax be -> String)
-> MigrationSteps be () a
-> String
forall be m a.
(Monoid m, Semigroup m, BeamSqlBackend be) =>
(Text -> m)
-> (BeamSqlBackendSyntax be -> m) -> MigrationSteps be () a -> m
migrateScript ((String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n") (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ((String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\n") (String -> String)
-> (BeamSqlBackendSyntax be -> String)
-> BeamSqlBackendSyntax be
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BeamSqlBackendSyntax be -> String
render) (Text -> (() -> Migration be a) -> MigrationSteps be () a
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 :: 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 = ActionProvider HsMigrateBackend
-> [SomeDatabasePredicate]
-> [SomeDatabasePredicate]
-> Solver HsMigrateBackend
forall be.
ActionProvider be
-> [SomeDatabasePredicate] -> [SomeDatabasePredicate] -> Solver be
heuristicSolver ((Typeable HsMigrateBackend,
 BeamMigrateOnlySqlBackend HsMigrateBackend) =>
ActionProvider HsMigrateBackend
forall be.
(Typeable be, BeamMigrateOnlySqlBackend be) =>
ActionProvider be
defaultActionProvider @HsMigrateBackend) [] [SomeDatabasePredicate]
hsConstraints

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