packages feed

beam-migrate 0.4.0.1 → 0.5.0.0

raw patch · 11 files changed

+163/−64 lines, 11 filesdep ~beam-coredep ~dependent-mapdep ~dependent-sumPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: beam-core, dependent-map, dependent-sum, ghc-prim, hashable, haskell-src-exts

API changes (from Hackage documentation)

- Database.Beam.Haskell.Syntax: instance Database.Beam.Backend.SQL.SQL92.HasSqlValueSyntax Database.Beam.Haskell.Syntax.HsExpr GHC.Types.Int
- Database.Beam.Migrate.Serialization: instance Data.GADT.Compare.GCompare Database.Beam.Migrate.Serialization.BeamDeserializerLabel
- Database.Beam.Migrate.Serialization: instance Data.GADT.Compare.GEq Database.Beam.Migrate.Serialization.BeamDeserializerLabel
+ Database.Beam.Haskell.Syntax: instance Database.Beam.Backend.SQL.SQL92.HasSqlValueSyntax Database.Beam.Haskell.Syntax.HsExpr GHC.Int.Int32
+ Database.Beam.Migrate.Serialization: instance Data.GADT.Internal.GCompare Database.Beam.Migrate.Serialization.BeamDeserializerLabel
+ Database.Beam.Migrate.Serialization: instance Data.GADT.Internal.GEq Database.Beam.Migrate.Serialization.BeamDeserializerLabel
+ Database.Beam.Migrate.Simple: CheckResult :: HashSet SomeDatabasePredicate -> HashSet SomeDatabasePredicate -> CheckResult
+ Database.Beam.Migrate.Simple: IgnorePredicates :: (SomeDatabasePredicate -> Any) -> IgnorePredicates
+ Database.Beam.Migrate.Simple: [missingPredicates] :: CheckResult -> HashSet SomeDatabasePredicate
+ Database.Beam.Migrate.Simple: [unIgnorePredicates] :: IgnorePredicates -> SomeDatabasePredicate -> Any
+ Database.Beam.Migrate.Simple: [unexpectedPredicates] :: CheckResult -> HashSet SomeDatabasePredicate
+ Database.Beam.Migrate.Simple: checkSchema :: (Database be db, Monad m) => BeamMigrationBackend be m -> CheckedDatabaseSettings be db -> IgnorePredicates -> m CheckResult
+ Database.Beam.Migrate.Simple: data CheckResult
+ Database.Beam.Migrate.Simple: ignoreAll :: IgnorePredicates
+ Database.Beam.Migrate.Simple: ignoreTables :: (QualifiedName -> Bool) -> IgnorePredicates
+ Database.Beam.Migrate.Simple: instance GHC.Base.Monoid Database.Beam.Migrate.Simple.IgnorePredicates
+ Database.Beam.Migrate.Simple: instance GHC.Base.Semigroup Database.Beam.Migrate.Simple.IgnorePredicates
+ Database.Beam.Migrate.Simple: instance GHC.Classes.Eq Database.Beam.Migrate.Simple.CheckResult
+ Database.Beam.Migrate.Simple: instance GHC.Show.Show Database.Beam.Migrate.Simple.CheckResult
+ Database.Beam.Migrate.Simple: newtype IgnorePredicates
- Database.Beam.Migrate.Backend: [BeamMigrationBackend] :: (MonadBeam be m, HasQBuilder be, BeamMigrateSqlBackend be, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be), BeamSqlBackendCanSerialize be LocalTime, BeamSqlBackendCanSerialize be (Maybe LocalTime), BeamSqlBackendCanSerialize be Text, BeamSqlBackendCanSerialize be SqlNull, Sql92ReasonableMarshaller be) => {backendName :: String, backendConnStringExplanation :: String, backendGetDbConstraints :: m [SomeDatabasePredicate], backendPredicateParsers :: BeamDeserializers be, backendRenderSyntax :: BeamSqlBackendSyntax be -> String, backendFileExtension :: String, backendConvertToHaskell :: HaskellPredicateConverter, backendActionProvider :: ActionProvider be, backendTransact :: forall a. String -> m a -> IO (Either DdlError a)} -> BeamMigrationBackend be m
+ Database.Beam.Migrate.Backend: [BeamMigrationBackend] :: (MonadBeam be m, MonadFail m, HasQBuilder be, BeamMigrateSqlBackend be, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be), BeamSqlBackendCanSerialize be LocalTime, BeamSqlBackendCanSerialize be (Maybe LocalTime), BeamSqlBackendCanSerialize be Text, BeamSqlBackendCanSerialize be SqlNull, Sql92ReasonableMarshaller be) => {backendName :: String, backendConnStringExplanation :: String, backendGetDbConstraints :: m [SomeDatabasePredicate], backendPredicateParsers :: BeamDeserializers be, backendRenderSyntax :: BeamSqlBackendSyntax be -> String, backendFileExtension :: String, backendConvertToHaskell :: HaskellPredicateConverter, backendActionProvider :: ActionProvider be, backendTransact :: forall a. String -> m a -> IO (Either DdlError a)} -> BeamMigrationBackend be m
- Database.Beam.Migrate.Backend: [SomeBeamMigrationBackend] :: (BeamMigrateSqlBackend be, Typeable be) => BeamMigrationBackend be m -> SomeBeamMigrationBackend
+ Database.Beam.Migrate.Backend: [SomeBeamMigrationBackend] :: Typeable be => BeamMigrationBackend be m -> SomeBeamMigrationBackend
- Database.Beam.Migrate.Log: BeamMigrateVersion :: C f Int -> BeamMigrateVersionT f
+ Database.Beam.Migrate.Log: BeamMigrateVersion :: C f Int32 -> BeamMigrateVersionT f
- Database.Beam.Migrate.Log: LogEntry :: C f Int -> C f Text -> C f LocalTime -> LogEntryT f
+ Database.Beam.Migrate.Log: LogEntry :: C f Int32 -> C f Text -> C f LocalTime -> LogEntryT f
- Database.Beam.Migrate.Log: [_beamMigrateVersion] :: BeamMigrateVersionT f -> C f Int
+ Database.Beam.Migrate.Log: [_beamMigrateVersion] :: BeamMigrateVersionT f -> C f Int32
- Database.Beam.Migrate.Log: [_logEntryId] :: LogEntryT f -> C f Int
+ Database.Beam.Migrate.Log: [_logEntryId] :: LogEntryT f -> C f Int32
- Database.Beam.Migrate.Log: beamMigrateSchemaVersion :: Int
+ Database.Beam.Migrate.Log: beamMigrateSchemaVersion :: Int32
- Database.Beam.Migrate.Log: ensureBackendTables :: forall be m. BeamSqlBackendCanSerialize be Text => BeamMigrationBackend be m -> m ()
+ Database.Beam.Migrate.Log: ensureBackendTables :: forall be m. (BeamSqlBackendCanSerialize be Text, MonadFail m) => BeamMigrationBackend be m -> m ()
- Database.Beam.Migrate.Log: getLatestLogEntry :: forall be m. (BeamMigrateSqlBackend be, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be), BeamSqlBackendCanDeserialize be Int, BeamSqlBackendCanDeserialize be LocalTime, BeamSqlBackendSupportsDataType be Text, HasQBuilder be, MonadBeam be m) => m (Maybe LogEntry)
+ Database.Beam.Migrate.Log: getLatestLogEntry :: forall be m. (BeamMigrateSqlBackend be, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be), BeamSqlBackendCanDeserialize be Int32, BeamSqlBackendCanDeserialize be LocalTime, BeamSqlBackendSupportsDataType be Text, HasQBuilder be, MonadBeam be m) => m (Maybe LogEntry)
- Database.Beam.Migrate.Log: recordCommit :: forall be m. (BeamMigrateSqlBackend be, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be), BeamSqlBackendSupportsDataType be Text, BeamSqlBackendCanDeserialize be Int, BeamSqlBackendCanDeserialize be LocalTime, HasQBuilder be, MonadBeam be m) => UUID -> m ()
+ Database.Beam.Migrate.Log: recordCommit :: forall be m. (BeamMigrateSqlBackend be, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be), BeamSqlBackendSupportsDataType be Text, BeamSqlBackendCanDeserialize be Int32, BeamSqlBackendCanDeserialize be LocalTime, HasQBuilder be, MonadBeam be m) => UUID -> m ()
- Database.Beam.Migrate.Simple: autoMigrate :: Database be db => BeamMigrationBackend be m -> CheckedDatabaseSettings be db -> m ()
+ Database.Beam.Migrate.Simple: autoMigrate :: (Database be db, MonadFail m) => BeamMigrationBackend be m -> CheckedDatabaseSettings be db -> m ()
- Database.Beam.Migrate.Simple: bringUpToDate :: (Database be db, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)) => BeamMigrationBackend be m -> MigrationSteps be () (CheckedDatabaseSettings be db) -> m (Maybe (CheckedDatabaseSettings be db))
+ Database.Beam.Migrate.Simple: bringUpToDate :: (Database be db, MonadFail m, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)) => BeamMigrationBackend be m -> MigrationSteps be () (CheckedDatabaseSettings be db) -> m (Maybe (CheckedDatabaseSettings be db))
- Database.Beam.Migrate.Simple: bringUpToDateWithHooks :: forall db be m. (Database be db, HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)) => BringUpToDateHooks m -> BeamMigrationBackend be m -> MigrationSteps be () (CheckedDatabaseSettings be db) -> m (Maybe (CheckedDatabaseSettings be db))
+ Database.Beam.Migrate.Simple: 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))
- Database.Beam.Migrate.Simple: createSchema :: Database be db => BeamMigrationBackend be m -> CheckedDatabaseSettings be db -> m ()
+ Database.Beam.Migrate.Simple: createSchema :: (Database be db, MonadFail m) => BeamMigrationBackend be m -> CheckedDatabaseSettings be db -> m ()
- Database.Beam.Migrate.Simple: defaultUpToDateHooks :: Monad m => BringUpToDateHooks m
+ Database.Beam.Migrate.Simple: defaultUpToDateHooks :: MonadFail m => BringUpToDateHooks m
- Database.Beam.Migrate.Simple: haskellSchema :: MonadBeam be m => BeamMigrationBackend be m -> m String
+ Database.Beam.Migrate.Simple: haskellSchema :: (MonadBeam be m, MonadFail m) => BeamMigrationBackend be m -> m String
- Database.Beam.Migrate.Types: TableCheck :: (forall tbl. Table tbl => QualifiedName -> tbl (TableField tbl) -> SomeDatabasePredicate) -> TableCheck
+ Database.Beam.Migrate.Types: TableCheck :: (forall tbl. Table tbl => QualifiedName -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate) -> TableCheck

Files

ChangeLog.md view
@@ -1,3 +1,23 @@+# 0.5.0.0++## Interface changes++ * Removed instances for machine-dependent ambiguous integer types `Int` and `Word`+ * Require `MonadFail` for `BeamMigrationBackend`++## Added features++ * GHC 8.8 support+ * `checkSchema`: Like `verifySchema`, but detects and returns unexpected+   predicates found in the live database++## Bug fixes++ * Map `Int16` to `smallIntType` instead of `intType`+ * Suppress creation of primary key constraints for tables with no primary keys++## 0.4.0.0+ ## 0.3.2.0  Added `haskellSchema` shortcut
Database/Beam/Haskell/Syntax.hs view
@@ -23,6 +23,7 @@  import           Data.Char (toLower, toUpper) import           Data.Hashable+import           Data.Int import           Data.List (find, nub) import qualified Data.Map as M import           Data.Maybe@@ -717,7 +718,7 @@   notDeferrableAttributeSyntax = HsNone   deferrableAttributeSyntax = HsNone -instance HasSqlValueSyntax HsExpr Int where+instance HasSqlValueSyntax HsExpr Int32 where   sqlValueSyntax = hsInt instance HasSqlValueSyntax HsExpr Bool where   sqlValueSyntax True = hsVar "True"@@ -954,7 +955,11 @@ beamMigrateSqlBackend :: HsBackendConstraint beamMigrateSqlBackend =   HsBackendConstraint $ \beTy ->+#if MIN_VERSION_haskell_src_exts(1, 22, 0)+  Hs.TypeA () (Hs.TyApp () (Hs.TyCon () (Hs.UnQual () (Hs.Ident () "BeamMigrateSqlBackend"))) beTy)+#else   Hs.ClassA () (Hs.UnQual () (Hs.Ident () "BeamMigrateSqlBackend")) [ beTy ]+#endif   
Database/Beam/Migrate/Backend.hs view
@@ -54,6 +54,7 @@ import           Database.Beam.Haskell.Syntax  import           Control.Applicative+import qualified Control.Monad.Fail as Fail  #if ! MIN_VERSION_base(4,11,0) import           Data.Semigroup@@ -73,6 +74,7 @@ data BeamMigrationBackend be m where   BeamMigrationBackend ::     ( MonadBeam be m+    , Fail.MonadFail m     , HasQBuilder be     , BeamMigrateSqlBackend be     , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)@@ -95,8 +97,7 @@ -- | Monomorphic wrapper for use with plugin loaders that cannot handle -- polymorphism data SomeBeamMigrationBackend where-  SomeBeamMigrationBackend :: ( BeamMigrateSqlBackend be-                              , Typeable be )+  SomeBeamMigrationBackend :: Typeable be                            => BeamMigrationBackend be m                            -> SomeBeamMigrationBackend 
Database/Beam/Migrate/Generics.hs view
@@ -3,7 +3,7 @@ -- | Support for creating checked databases from Haskell ADTs, using 'Generic's. -- -- For more information, see--- <http://tathougies.github.io/beam/schema-guide/migrations/ the manual>+-- <https://haskell-beam.github.io/beam/schema-guide/migrations/ the manual>  module Database.Beam.Migrate.Generics  ( -- * Default checked database settings@@ -24,7 +24,7 @@  -- | Produce a checked database for the given Haskell database type ----- See <http://tathougies.github.io/beam/schema-guide/migrations/ the manual>+-- See <https://haskell-beam.github.io/beam/schema-guide/migrations/ the manual> -- for more information on the defaults. defaultMigratableDbSettings   :: forall be db.
Database/Beam/Migrate/Generics/Tables.hs view
@@ -13,6 +13,7 @@   ) where  import Database.Beam+import Database.Beam.Backend.Internal.Compat import Database.Beam.Backend.SQL  import Database.Beam.Migrate.Types.Predicates@@ -31,6 +32,7 @@ import Data.Word  import GHC.Generics+import GHC.TypeLits  class BeamMigrateSqlBackend be => GMigratableTableSettings be (i :: * -> *) fieldCheck where   gDefaultTblSettingsChecks :: Proxy be -> Proxy i -> Bool -> fieldCheck ()@@ -134,18 +136,13 @@  -- TODO Not sure if individual databases will want to customize these types -instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Int where-  defaultSqlDataType _ _ _ = intType instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Int32 where   defaultSqlDataType _ _ _ = intType instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Int16 where-  defaultSqlDataType _ _ _ = intType+  defaultSqlDataType _ _ _ = smallIntType instance ( BeamMigrateSqlBackend be, BeamSqlT071Backend be ) => HasDefaultSqlDataType be Int64 where     defaultSqlDataType _ _ _ = bigIntType -instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Word where-  defaultSqlDataType _ _ _ = numericType (Just (10, Nothing))- instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Word16 where   defaultSqlDataType _ _ _ = numericType (Just (5, Nothing)) instance BeamMigrateSqlBackend be => HasDefaultSqlDataType be Word32 where@@ -172,3 +169,9 @@  instance BeamMigrateSql99Backend be => HasDefaultSqlDataType be Bool where   defaultSqlDataType _ _ _ = booleanType++instance (TypeError (PreferExplicitSize Int Int32), BeamMigrateSqlBackend be) => HasDefaultSqlDataType be Int where+  defaultSqlDataType _ = defaultSqlDataType (Proxy @Int32)++instance (TypeError (PreferExplicitSize Word Word32), BeamMigrateSqlBackend be) => HasDefaultSqlDataType be Word where+  defaultSqlDataType _ _ _ = numericType (Just (10, Nothing))
Database/Beam/Migrate/Log.hs view
@@ -11,15 +11,18 @@  import Control.Monad (when) +import Data.Int import Data.String (fromString) import Data.Text (Text) import Data.Time (LocalTime) import Data.UUID.Types (UUID) import Data.Maybe (fromMaybe) +import qualified Control.Monad.Fail as Fail+ data LogEntryT f   = LogEntry-  { _logEntryId       :: C f Int+  { _logEntryId       :: C f Int32   , _logEntryCommitId :: C f Text   , _logEntryDate     :: C f LocalTime   } deriving Generic@@ -29,7 +32,7 @@ deriving instance Show LogEntry  instance Table LogEntryT where-  data PrimaryKey LogEntryT f = LogEntryKey (C f Int)+  data PrimaryKey LogEntryT f = LogEntryKey (C f Int32)     deriving Generic   primaryKey = LogEntryKey <$> _logEntryId @@ -40,7 +43,7 @@  newtype BeamMigrateVersionT f   = BeamMigrateVersion-  { _beamMigrateVersion :: C f Int+  { _beamMigrateVersion :: C f Int32   } deriving Generic  instance Beamable BeamMigrateVersionT@@ -48,7 +51,7 @@ deriving instance Show BeamMigrateVersion  instance Table BeamMigrateVersionT where-  data PrimaryKey BeamMigrateVersionT f = BeamMigrateVersionKey (C f Int)+  data PrimaryKey BeamMigrateVersionT f = BeamMigrateVersionKey (C f Int32)     deriving Generic   primaryKey = BeamMigrateVersionKey <$> _beamMigrateVersion @@ -92,13 +95,13 @@                       (LogEntry (field "id" int notNull) (field "commitId" (varchar Nothing) notNull)                                 (field "date" timestamp notNull)) -beamMigrateSchemaVersion :: Int+beamMigrateSchemaVersion :: Int32 beamMigrateSchemaVersion = 1  getLatestLogEntry :: forall be m                    . ( BeamMigrateSqlBackend be                      , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)-                     , BeamSqlBackendCanDeserialize be Int+                     , BeamSqlBackendCanDeserialize be Int32                      , BeamSqlBackendCanDeserialize be LocalTime                      , BeamSqlBackendSupportsDataType be Text                      , HasQBuilder be@@ -124,7 +127,7 @@              . ( BeamMigrateSqlBackend be                , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be)                , BeamSqlBackendSupportsDataType be Text-               , BeamSqlBackendCanDeserialize be Int+               , BeamSqlBackendCanDeserialize be Int32                , BeamSqlBackendCanDeserialize be LocalTime                , HasQBuilder be                , MonadBeam be m )@@ -143,7 +146,7 @@  -- Ensure the backend tables exist ensureBackendTables :: forall be m-                     . BeamSqlBackendCanSerialize be Text+                     . (BeamSqlBackendCanSerialize be Text, Fail.MonadFail m)                     => BeamMigrationBackend be m                     -> m () ensureBackendTables be@BeamMigrationBackend { backendGetDbConstraints = getCs } =@@ -179,7 +182,7 @@         totalCnt <-           fmap (fromMaybe 0) $ -- Should never return 'Nothing', but this prevents an irrefutable pattern match           runSelectReturningOne $ select $-          aggregate_ (\_ -> as_ @Int countAll_) $+          aggregate_ (\_ -> as_ @Int32 countAll_) $           all_ (_beamMigrateLogEntries (beamMigrateDb @be @m))         when (totalCnt > 0) (fail "beam-migrate: No versioning information, but log entries present")         runNoReturn (dropTableCmd (dropTableSyntax (tableName Nothing "beam_migration")))
Database/Beam/Migrate/SQL/Tables.hs view
@@ -80,13 +80,13 @@           fieldChecks = changeBeamRep (\(Columnar' (TableFieldSchema _ _ cs)) -> Columnar' (Const cs)) tblSettings -         tblChecks = [ TableCheck (\tblName _ -> SomeDatabasePredicate (TableExistsPredicate tblName)) ] +++         tblChecks = [ TableCheck (\tblName _ -> Just (SomeDatabasePredicate (TableExistsPredicate tblName))) ] ++                      primaryKeyCheck           primaryKeyCheck =            case allBeamValues (\(Columnar' (TableFieldSchema name _ _)) -> name) (primaryKey tblSettings) of              [] -> []-             cols -> [ TableCheck (\tblName _ -> SomeDatabasePredicate (TableHasPrimaryKey tblName cols)) ]+             cols -> [ TableCheck (\tblName _ -> Just (SomeDatabasePredicate (TableHasPrimaryKey tblName cols))) ]       upDown command Nothing      pure (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable Nothing newTblName newTblName tbl') tblChecks fieldChecks) [])
Database/Beam/Migrate/Simple.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Utility functions for common use cases module Database.Beam.Migrate.Simple   ( autoMigrate@@ -10,6 +11,12 @@   , VerificationResult(..)   , verifySchema +  , IgnorePredicates(..)+  , CheckResult(..)+  , ignoreTables+  , ignoreAll+  , checkSchema+   , createSchema    , BringUpToDateHooks(..)@@ -28,7 +35,7 @@ import           Database.Beam.Haskell.Syntax import           Database.Beam.Migrate.Actions import           Database.Beam.Migrate.Backend-import           Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck)+import           Database.Beam.Migrate.Checks (HasDataTypeCreatedCheck, TableExistsPredicate(..)) import           Database.Beam.Migrate.Log import           Database.Beam.Migrate.SQL (BeamMigrateSqlBackendDataTypeSyntax) import           Database.Beam.Migrate.Types@@ -39,8 +46,12 @@  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   { runIrreversibleHook :: m Bool@@ -69,31 +80,31 @@  -- | Default set of 'BringUpToDateHooks'. Refuses to run irreversible -- migrations, and fails in case of error, using 'fail'.-defaultUpToDateHooks :: Monad m => BringUpToDateHooks m+defaultUpToDateHooks :: Fail.MonadFail m => BringUpToDateHooks m defaultUpToDateHooks =   BringUpToDateHooks   { runIrreversibleHook = pure False   , startStepHook       = \_ _ -> pure ()   , endStepHook         = \_ _ -> pure ()   , runCommandHook      = \_ _ -> pure ()-  , queryFailedHook     = fail "Log entry query fails"+  , queryFailedHook     = Fail.fail "Log entry query fails"   , discontinuousMigrationsHook =-      \ix -> fail ("Discontinuous migration log: missing migration at " ++ show ix)+      \ix -> Fail.fail ("Discontinuous migration log: missing migration at " ++ show ix)   , logMismatchHook =       \ix actual expected ->-        fail ("Log mismatch at index " ++ show ix ++ ":\n" +++        Fail.fail ("Log mismatch at index " ++ show ix ++ ":\n" ++               "  expected: " ++ T.unpack expected ++ "\n" ++               "  actual  : " ++ T.unpack actual)   , databaseAheadHook =       \aheadBy ->-        fail ("The database is ahead of the known schema by " ++ show aheadBy ++ " migration(s)")+        Fail.fail ("The database is ahead of the known schema by " ++ show aheadBy ++ " 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+bringUpToDate :: ( Database be db, Fail.MonadFail m                  , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) )               => BeamMigrationBackend be m               -> MigrationSteps be () (CheckedDatabaseSettings be db)@@ -109,7 +120,7 @@ -- documentation for 'BringUpToDateHooks' for more information. Calling this -- with 'defaultUpToDateHooks' is the same as using 'bringUpToDate'. bringUpToDateWithHooks :: forall db be m-                        . ( Database be db+                        . ( Database be db, Fail.MonadFail m                           , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) )                        => BringUpToDateHooks m                        -> BeamMigrationBackend be m@@ -126,9 +137,9 @@            case log of              [] -> pure ()              LogEntry actId actStepNm _:log'-               | actId == stepIx && actStepNm == stepNm ->+               | fromIntegral actId == stepIx && actStepNm == stepNm ->                    tell (Max stepIx) >> put log'-               | actId /= stepIx ->+               | fromIntegral actId /= stepIx ->                    lift . lift $ discontinuousMigrationsHook hooks stepIx                | otherwise ->                    lift . lift $ logMismatchHook hooks stepIx actStepNm stepNm@@ -166,7 +177,7 @@                      step                   runInsert $ insert (_beamMigrateLogEntries (beamMigrateDb @be @m)) $-                   insertExpressions [ LogEntry (val_ stepIx) (val_ stepName) currentTimestamp_ ]+                   insertExpressions [ LogEntry (val_ $ fromIntegral stepIx) (val_ stepName) currentTimestamp_ ]                  endStepHook hooks stepIx stepName                   return ret)@@ -191,13 +202,13 @@ -- attempt to create the schema from scratch in the current database. -- -- May 'fail' if we cannot find a schema-createSchema :: Database be db+createSchema :: (Database be db, Fail.MonadFail m)              => BeamMigrationBackend be m              -> CheckedDatabaseSettings be db              -> m () createSchema BeamMigrationBackend { backendActionProvider = actions } db =   case simpleSchema actions db of-    Nothing -> fail "createSchema: Could not determine schema"+    Nothing -> Fail.fail "createSchema: Could not determine schema"     Just cmds ->         mapM_ runNoReturn cmds @@ -205,7 +216,7 @@ -- 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+autoMigrate :: (Database be db, Fail.MonadFail m)             => BeamMigrationBackend be m             -> CheckedDatabaseSettings be db             -> m ()@@ -215,12 +226,12 @@   do actual <- getCs      let expected = collectChecks db      case finalSolution (heuristicSolver actions actual expected) of-       Candidates {} -> fail "autoMigrate: Could not determine migration"+       Candidates {} -> Fail.fail "autoMigrate: Could not determine migration"        Solved cmds ->          -- Check if any of the commands are irreversible          case foldMap migrationCommandDataLossPossible cmds of            MigrationKeepsData -> mapM_ (runNoReturn . migrationCommand) cmds-           _ -> fail "autoMigrate: Not performing automatic migration due to data loss"+           _ -> Fail.fail "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@@ -259,16 +270,68 @@              => BeamMigrationBackend be m              -> CheckedDatabaseSettings be db              -> m VerificationResult-verifySchema BeamMigrationBackend { backendGetDbConstraints = getConstraints } db =-  do actualSchema <- HS.fromList <$> getConstraints-     let expectedSchema = HS.fromList (collectChecks db)-         missingPredicates = expectedSchema `HS.difference` actualSchema-     if HS.null missingPredicates-       then pure VerificationSucceeded-       else pure (VerificationFailed (HS.toList missingPredicates))+verifySchema backend db = do+  result <- checkSchema backend db ignoreAll+  if HS.null $ missingPredicates result+    then pure VerificationSucceeded+    else pure $ VerificationFailed $ HS.toList $ missingPredicates result --- | Run a sequence of commands on a database+-- | Result type for 'checkSchema'+data CheckResult = CheckResult+  { -- | Expected predicates from the 'CheckedDatabaseSettings' which were not+    -- found in the live database+    missingPredicates :: HS.HashSet SomeDatabasePredicate+  , -- | Predicates found in the live database which are not present in the+    -- 'CheckedDatabaseSettings' and are not ignored+    unexpectedPredicates :: HS.HashSet SomeDatabasePredicate+  } deriving (Eq, Show) +-- | Selects a class of predicates to ignore if detected (e.g. metadata tables+-- for migrations, other schemas, etc.).+newtype IgnorePredicates = IgnorePredicates+  { unIgnorePredicates :: SomeDatabasePredicate -> Any+  } deriving (Semigroup, Monoid)++-- | Ignore predicates relating to tables matching the given name predicate.+ignoreTables :: (QualifiedName -> Bool) -> IgnorePredicates+ignoreTables shouldIgnore = IgnorePredicates $ \(SomeDatabasePredicate dp) ->+  case cast dp of+    Just (TableExistsPredicate name) -> Any $ shouldIgnore name+    Nothing -> Any 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 $ const $ Any 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 backend db (IgnorePredicates ignore) = do+  actual <- HS.fromList <$> backendGetDbConstraints backend+  let expected = HS.fromList $ collectChecks db+      missing = expected `HS.difference` actual+      extra = actual `HS.difference` expected+      ignored = HS.filter (getAny . ignore) extra+      unexpected = flip HS.filter extra $ \sdp@(SomeDatabasePredicate dp) ->+        not $ or+          [ sdp `HS.member` ignored+          , or $ HS.toList ignored <&> \(SomeDatabasePredicate ignoredDp) ->+              dp `predicateCascadesDropOn` ignoredDp+          ]++  return $ CheckResult+    { missingPredicates = missing+    , unexpectedPredicates = unexpected+    }++-- | Run a sequence of commands on a database runSimpleMigration :: MonadBeam be m                    => (forall a. hdl -> m a -> IO a)                    -> hdl -> [BeamSqlBackendSyntax be] -> IO ()@@ -301,7 +364,7 @@ -- -- Backends that have a migration backend typically export it under the module -- name @Database.Beam./Backend/.Migrate@.-haskellSchema :: MonadBeam be m+haskellSchema :: (MonadBeam be m, Fail.MonadFail m)               => BeamMigrationBackend be m               -> m String haskellSchema BeamMigrationBackend { backendGetDbConstraints = getCs@@ -315,6 +378,6 @@     Solved cmds   ->       let hsModule = hsActionsToModule "NewBeamSchema" (map migrationCommand cmds)       in case renderHsSchema hsModule of-           Left err -> fail ("Error writing Haskell schema: " ++ err)+           Left err -> Fail.fail ("Error writing Haskell schema: " ++ err)            Right modStr -> pure modStr-    Candidates {} -> fail "Could not form Haskell schema"+    Candidates {} -> Fail.fail "Could not form Haskell schema"
Database/Beam/Migrate/Types/CheckedEntities.hs view
@@ -15,6 +15,7 @@ import Control.Monad.Writer import Control.Monad.Identity +import Data.Maybe import Data.Proxy import Data.Text (Text) import Data.String@@ -117,7 +118,7 @@    unChecked f (CheckedDatabaseTable x cks fcks) = fmap (\x' -> CheckedDatabaseTable x' cks fcks) (f x)   collectEntityChecks (CheckedDatabaseTable dt tblChecks tblFieldChecks) =-    map (\(TableCheck mkCheck) -> mkCheck (qname dt) (dbTableSettings dt)) tblChecks <>+    catMaybes (map (\(TableCheck mkCheck) -> mkCheck (qname dt) (dbTableSettings dt)) tblChecks) <>     execWriter (zipBeamFieldsM (\(Columnar' fd) c@(Columnar' (Const fieldChecks)) ->                                     tell (map (\(FieldCheck mkCheck) -> mkCheck (qname dt) (fd ^. fieldName)) fieldChecks) >>                                     pure c)@@ -125,10 +126,13 @@    checkedDbEntityAuto tblTypeName =     let tblChecks =-          [ TableCheck (\tblName _ -> SomeDatabasePredicate (TableExistsPredicate tblName))-          , TableCheck (\tblName tblFields ->-                           let pkFields = allBeamValues (\(Columnar' fd) -> fd ^. fieldName) (primaryKey tblFields)-                           in SomeDatabasePredicate (TableHasPrimaryKey tblName pkFields)) ]+          [ TableCheck $ \tblName _ ->+              Just (SomeDatabasePredicate (TableExistsPredicate tblName))+          , TableCheck $ \tblName tblFields ->+              case allBeamValues (\(Columnar' fd) -> fd ^. fieldName) (primaryKey tblFields) of+                [] -> Nothing+                pkFields -> Just (SomeDatabasePredicate (TableHasPrimaryKey tblName pkFields))+          ]          fieldChecks = to (gDefaultTblSettingsChecks (Proxy @be) (Proxy @(Rep (tbl Identity))) False)     in CheckedDatabaseTable (dbEntityAuto tblTypeName) tblChecks fieldChecks
Database/Beam/Migrate/Types/Predicates.hs view
@@ -127,8 +127,8 @@ qnameAsTableName :: IsSql92TableNameSyntax syntax => QualifiedName -> syntax qnameAsTableName (QualifiedName sch t) = tableName sch t --- | A predicate that depends on the name of a table as well as its fields-newtype TableCheck = TableCheck (forall tbl. Table tbl => QualifiedName -> tbl (TableField tbl) -> SomeDatabasePredicate)+-- | An optional predicate that depends on the name of a table as well as its fields+newtype TableCheck = TableCheck (forall tbl. Table tbl => QualifiedName -> tbl (TableField tbl) -> Maybe SomeDatabasePredicate)  -- | A predicate that depends on the name of a domain type newtype DomainCheck = DomainCheck (QualifiedName -> SomeDatabasePredicate)
beam-migrate.cabal view
@@ -1,5 +1,5 @@ name:                beam-migrate-version:             0.4.0.1+version:             0.5.0.0 synopsis:            SQL DDL support and migrations support library for Beam description:         This package provides type classes to allow backends to implement                      SQL DDL support for beam. This allows you to use beam syntax to@@ -60,7 +60,7 @@                        Database.Beam.Migrate.Types.Predicates    build-depends:       base                 >=4.9     && <5.0,-                       beam-core            >=0.8     && <0.9,+                       beam-core            >=0.9     && <0.10,                        text                 >=1.2     && <1.3,                        aeson                >=0.11    && <1.5,                        bytestring           >=0.10    && <0.11,@@ -71,16 +71,16 @@                        vector               >=0.11    && <0.13,                        containers           >=0.5     && <0.7,                        unordered-containers >=0.2     && <0.3,-                       hashable             >=1.2     && <1.3,+                       hashable             >=1.2     && <1.4,                        microlens            >=0.4     && <0.5,                        parallel             >=3.2     && <3.3,                        deepseq              >=1.4     && <1.5,-                       ghc-prim             >=0.5     && <0.6,+                       ghc-prim             >=0.5     && <0.7,                        containers           >=0.5     && <0.7,-                       haskell-src-exts     >=1.18    && <1.22,+                       haskell-src-exts     >=1.18    && <1.24,                        pretty               >=1.1     && <1.2,-                       dependent-map        >=0.2     && <0.3,-                       dependent-sum        >=0.4     && <0.6,+                       dependent-map        >=0.2     && <0.5,+                       dependent-sum        >=0.4     && <0.8,                        pqueue               >=1.3     && <1.5,                        uuid-types           >=1.0     && <1.1   default-language:    Haskell2010@@ -99,5 +99,5 @@  source-repository head   type: git-  location: https://github.com/tathougies/beam.git+  location: https://github.com/haskell-beam/beam.git   subdir: beam-migrate