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 +20/−0
- Database/Beam/Haskell/Syntax.hs +6/−1
- Database/Beam/Migrate/Backend.hs +3/−2
- Database/Beam/Migrate/Generics.hs +2/−2
- Database/Beam/Migrate/Generics/Tables.hs +9/−6
- Database/Beam/Migrate/Log.hs +12/−9
- Database/Beam/Migrate/SQL/Tables.hs +2/−2
- Database/Beam/Migrate/Simple.hs +90/−27
- Database/Beam/Migrate/Types/CheckedEntities.hs +9/−5
- Database/Beam/Migrate/Types/Predicates.hs +2/−2
- beam-migrate.cabal +8/−8
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