diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ -# Revision history for beam-migrate +## 0.3.0.0 -## 0.1.0.0 -- YYYY-mm-dd +* Re-introduce backend parameter as `Database` type class +* Move beam migration log schema to beam-migrate, since many + applications will want to easily manage a database using the + haskell-based migrations +* Add `bringUpToDate` and `bringUpToDateWithHooks` to + `Database.Beam.Migrate.Simple`, which can be used to bring a + database up to date with the given migration. + +## 0.2.0.0 -- 2018-01-20 * First version. Released on an unsuspecting world. diff --git a/Database/Beam/Haskell/Syntax.hs b/Database/Beam/Haskell/Syntax.hs --- a/Database/Beam/Haskell/Syntax.hs +++ b/Database/Beam/Haskell/Syntax.hs @@ -11,7 +11,7 @@ -- for us in @haskell-src-exts@. module Database.Beam.Haskell.Syntax where -import Database.Beam hiding (lookup) +import Database.Beam import Database.Beam.Backend.SQL import Database.Beam.Backend.SQL.Builder import Database.Beam.Migrate.SQL.SQL92 @@ -199,15 +199,15 @@ databaseTypeDecl entities = Hs.DataDecl () (Hs.DataType ()) Nothing declHead [ conDecl ] - (Just deriving_) + [deriving_] where declHead = Hs.DHApp () (Hs.DHead () (Hs.Ident () "Db")) (Hs.UnkindedVar () (Hs.Ident () "entity")) conDecl = Hs.QualConDecl () Nothing Nothing (Hs.RecDecl () (Hs.Ident () "Db") (mkField <$> entities)) - deriving_ = Hs.Deriving () [ Hs.IRule () Nothing Nothing $ - Hs.IHCon () $ Hs.UnQual () $ - Hs.Ident () "Generic" ] + deriving_ = Hs.Deriving () Nothing [ Hs.IRule () Nothing Nothing $ + Hs.IHCon () $ Hs.UnQual () $ + Hs.Ident () "Generic" ] mkField entity = Hs.FieldDecl () [ Hs.Ident () (entityDbFieldName entity) ] (buildHsDbField (hsEntityDbDecl entity) $ @@ -358,13 +358,18 @@ backend = foldMap hsEntityBackend entities syntax = foldMap hsEntitySyntax entities + backendHs = case backend of + HsBeamBackendNone -> error "Can't instantiate Database instance: No backend matches" + HsBeamBackendSingle ty _ -> hsTypeSyntax ty + HsBeamBackendConstrained {} -> tyVarNamed "be" -- TODO constraints + decls = foldMap (map hsDeclSyntax . hsEntityDecls) entities ++ [ databaseTypeDecl entities , migrationTypeDecl backend syntax [] , migrationDecl backend [] migrations entities - , hsInstance "Database" [ tyConNamed "Db" ] [] + , hsInstance "Database" [ backendHs, tyConNamed "Db" ] [] , dbTypeDecl backend syntax , dbDecl backend syntax [] ] @@ -468,7 +473,7 @@ imports = foldMap (\(_, ty) -> hsTypeImports (hsColumnSchemaType ty)) fields tblDecl = Hs.DataDecl () (Hs.DataType ()) Nothing - tblDeclHead [ tblConDecl ] (Just deriving_) + tblDeclHead [ tblConDecl ] [deriving_] tblDeclHead = Hs.DHApp () (Hs.DHead () (Hs.Ident () tyName)) (Hs.UnkindedVar () (Hs.Ident () "f")) tblConDecl = Hs.QualConDecl () Nothing Nothing (Hs.RecDecl () (Hs.Ident () tyConName) tyConFieldDecls) @@ -480,7 +485,7 @@ [ tyVarNamed "f" , hsTypeSyntax (hsColumnSchemaType ty) ])) fields - deriving_ = Hs.Deriving () [ inst "Generic" ] + deriving_ = Hs.Deriving () Nothing [ inst "Generic" ] tblBeamable = hsInstance "Beamable" [ tyConNamed tyName ] [] tblPun = Hs.TypeDecl () (Hs.DHead () (Hs.Ident () tyConName)) @@ -511,7 +516,7 @@ instance IsSql92TableConstraintSyntax HsTableConstraint where primaryKeyConstraintSyntax fields = HsTableConstraint $ \tblNm tblFields -> - let primaryKeyDataDecl = Hs.InsData () (Hs.DataType ()) primaryKeyType [ primaryKeyConDecl ] (Just primaryKeyDeriving) + let primaryKeyDataDecl = Hs.InsData () (Hs.DataType ()) primaryKeyType [ primaryKeyConDecl ] [ primaryKeyDeriving ] tableTypeNm = tblNm <> "T" tableTypeKeyNm = tblNm <> "Key" @@ -520,7 +525,7 @@ primaryKeyType = tyApp (tyConNamed "PrimaryKey") [ tyConNamed (T.unpack tableTypeNm), tyVarNamed "f" ] primaryKeyConDecl = Hs.QualConDecl () Nothing Nothing (Hs.ConDecl () (Hs.Ident () (T.unpack tableTypeKeyNm)) fieldTys) - primaryKeyDeriving = Hs.Deriving () [ inst "Generic" ] + primaryKeyDeriving = Hs.Deriving () Nothing [ inst "Generic" ] primaryKeyTypeDecl = Hs.TypeDecl () (Hs.DHead () (Hs.Ident () (T.unpack tableTypeKeyNm))) (tyApp (tyConNamed "PrimaryKey") @@ -597,6 +602,9 @@ charLengthE = hsApp (hsVar "charLengthE") . pure octetLengthE = hsApp (hsVar "octetLengthE") . pure bitLengthE = hsApp (hsVar "bitLengthE") . pure + lowerE = hsApp (hsVar "lowerE") . pure + upperE = hsApp (hsVar "upperE") . pure + trimE = hsApp (hsVar "trimE") . pure existsE = error "existsE" uniqueE = error "uniqueE" @@ -649,6 +657,9 @@ instance HasSqlValueSyntax HsExpr Int where sqlValueSyntax = hsInt +instance HasSqlValueSyntax HsExpr Bool where + sqlValueSyntax True = hsVar "True" + sqlValueSyntax False = hsVar "False" instance IsSql92FieldNameSyntax HsExpr where qualifiedField tbl nm = hsApp (hsVar "qualifiedField") [ hsStr tbl, hsStr nm ] @@ -856,7 +867,7 @@ instHead = foldl (Hs.IHApp ()) (Hs.IHCon () (Hs.UnQual () (Hs.Ident () (T.unpack classNm)))) params hsDerivingInstance :: T.Text -> [ Hs.Type () ] -> Hs.Decl () -hsDerivingInstance classNm params = Hs.DerivDecl () Nothing (Hs.IRule () Nothing Nothing instHead) +hsDerivingInstance classNm params = Hs.DerivDecl () Nothing Nothing (Hs.IRule () Nothing Nothing instHead) where instHead = foldl (Hs.IHApp ()) (Hs.IHCon () (Hs.UnQual () (Hs.Ident () (T.unpack classNm)))) params @@ -947,5 +958,7 @@ instance Hashable (Hs.ImportSpec ()) instance Hashable (Hs.Namespace ()) instance Hashable (Hs.CName ()) +instance Hashable (Hs.DerivStrategy ()) +instance Hashable (Hs.MaybePromotedName ()) instance Hashable a => Hashable (S.Set a) where hashWithSalt s a = hashWithSalt s (S.toList a) diff --git a/Database/Beam/Migrate.hs b/Database/Beam/Migrate.hs --- a/Database/Beam/Migrate.hs +++ b/Database/Beam/Migrate.hs @@ -34,13 +34,13 @@ -- -- As one final point, @beam-migrate@ can generate schemas in any beam-supported -- SQL DDL syntax. The @beam-migrate@ module provides a DDL syntax for Haskell --- in 'Database.Beam.Haskell.Syntax'. This allows @beam-migrate@ to translate +-- in "Database.Beam.Haskell.Syntax". This allows @beam-migrate@ to translate -- predicate sets into the corresponding Haskell schema and the corresponding -- Haskell migration script. This reflection allows tool based off of -- @beam-migrate@ to support schema generation from an existing database. -- -- For more information on checked databases, see the --- 'Database.Beam.Migrate.Checks' module. +-- "Database.Beam.Migrate.Checks" module. -- -- == Migrations -- @@ -58,12 +58,12 @@ -- script in a given backend syntax, or generate an appropriate -- 'DatabaseSettings' object for use with the rest of the beam ecosystem. -- --- For more information in migrations see 'Database.Beam.Migrate.Types' +-- For more information in migrations see "Database.Beam.Migrate.Types" -- -- == Syntax -- -- For low-level access to the underlying SQL syntax builders, see --- 'Database.Beam.Migrate.Syntax' +-- "Database.Beam.Migrate.SQL.SQL92" -- -- == Advanced features -- diff --git a/Database/Beam/Migrate/Actions.hs b/Database/Beam/Migrate/Actions.hs --- a/Database/Beam/Migrate/Actions.hs +++ b/Database/Beam/Migrate/Actions.hs @@ -127,7 +127,7 @@ -- their source (user or from previous actions) , dbStateKey :: !(HS.HashSet SomeDatabasePredicate) -- ^ HS.fromMap of 'dbStateCurrentState', for maximal sharing - , dbStateCmdSequence :: !(Seq.Seq cmd) + , dbStateCmdSequence :: !(Seq.Seq (MigrationCommand cmd)) -- ^ The current sequence of commands we've committed to in this state } deriving Show @@ -168,16 +168,13 @@ -- Given a particular starting point, the destination database is the database -- where each predicate in 'actionPreConditions' has been removed and each -- predicate in 'actionPostConditions' has been added. --- --- --- data PotentialAction cmd = PotentialAction { actionPreConditions :: !(HS.HashSet SomeDatabasePredicate) -- ^ Preconditions that will no longer apply , actionPostConditions :: !(HS.HashSet SomeDatabasePredicate) -- ^ Conditions that will apply after we're done - , actionCommands :: !(Seq.Seq cmd) + , actionCommands :: !(Seq.Seq (MigrationCommand cmd)) -- ^ The sequence of commands that accomplish this movement in the database -- graph. For an edge, 'actionCommands' contains one command; for a path, it -- will contain more. @@ -276,7 +273,7 @@ -- | Action provider for SQL92 @CREATE TABLE@ actions. createTableActionProvider :: forall cmd - . ( Sql92SaneDdlCommandSyntax cmd + . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) ) => ActionProvider cmd createTableActionProvider = @@ -319,11 +316,13 @@ cmd = createTableCmd (createTableSyntax Nothing postTblNm colsSyntax tblConstraints) tblConstraints = [ primaryKeyConstraintSyntax primaryKey ] colsSyntax = map (\(colNm, type_, cs) -> (colNm, columnSchemaSyntax type_ Nothing cs Nothing)) columns - pure (PotentialAction mempty (HS.fromList postConditions) (Seq.singleton cmd) ("Create the table " <> postTblNm) createTableWeight) + pure (PotentialAction mempty (HS.fromList postConditions) + (Seq.singleton (MigrationCommand cmd MigrationKeepsData)) + ("Create the table " <> postTblNm) createTableWeight) -- | Action provider for SQL92 @DROP TABLE@ actions dropTableActionProvider :: forall cmd - . ( Sql92SaneDdlCommandSyntax cmd + . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) ) => ActionProvider cmd dropTableActionProvider = @@ -345,11 +344,13 @@ -- Now, collect all preconditions that may be related to the dropped table let cmd = dropTableCmd (dropTableSyntax preTblNm) pure ({-trace ("Dropping table " <> show preTblNm <> " would drop " <> show relatedPreds) $ -} - PotentialAction (HS.fromList (SomeDatabasePredicate tblP:relatedPreds)) mempty (Seq.singleton cmd) ("Drop table " <> preTblNm) dropTableWeight) + PotentialAction (HS.fromList (SomeDatabasePredicate tblP:relatedPreds)) mempty + (Seq.singleton (MigrationCommand cmd MigrationLosesData)) + ("Drop table " <> preTblNm) dropTableWeight) -- | Action provider for SQL92 @ALTER TABLE ... ADD COLUMN ...@ actions addColumnProvider :: forall cmd - . ( Sql92SaneDdlCommandSyntax cmd + . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) ) => ActionProvider cmd addColumnProvider = @@ -369,13 +370,13 @@ let cmd = alterTableCmd (alterTableSyntax tblNm (addColumnSyntax colNm schema)) schema = columnSchemaSyntax colType Nothing [] Nothing pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP]) - (Seq.singleton cmd) + (Seq.singleton (MigrationCommand cmd MigrationKeepsData)) ("Add column " <> colNm <> " to " <> tblNm) (addColumnWeight + fromIntegral (T.length tblNm + T.length colNm))) -- | Action provider for SQL92 @ALTER TABLE ... DROP COLUMN ...@ actions dropColumnProvider :: forall cmd - . ( Sql92SaneDdlCommandSyntax cmd + . ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) ) => ActionProvider cmd dropColumnProvider = ActionProvider provider @@ -399,13 +400,13 @@ let cmd = alterTableCmd (alterTableSyntax tblNm (dropColumnSyntax colNm)) pure (PotentialAction (HS.fromList (SomeDatabasePredicate colP:relatedPreds)) mempty - (Seq.singleton cmd) + (Seq.singleton (MigrationCommand cmd MigrationLosesData)) ("Drop column " <> colNm <> " from " <> tblNm) (dropColumnWeight + fromIntegral (T.length tblNm + T.length colNm))) -- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET NULL@ addColumnNullProvider :: forall cmd - . Sql92SaneDdlCommandSyntax cmd + . Sql92SaneDdlCommandSyntaxMigrateOnly cmd => ActionProvider cmd addColumnNullProvider = ActionProvider provider where @@ -422,12 +423,13 @@ guard (tblNm == tblNm'' && colNm == colNm') let cmd = alterTableCmd (alterTableSyntax tblNm (alterColumnSyntax colNm setNotNullSyntax)) - pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP]) (Seq.singleton cmd) + pure (PotentialAction mempty (HS.fromList [SomeDatabasePredicate colP]) + (Seq.singleton (MigrationCommand cmd MigrationKeepsData)) ("Add not null constraint to " <> colNm <> " on " <> tblNm) 100) -- | Action provider for SQL92 @ALTER TABLE ... ALTER COLUMN ... SET NOT NULL@ dropColumnNullProvider :: forall cmd - . Sql92SaneDdlCommandSyntax cmd + . Sql92SaneDdlCommandSyntaxMigrateOnly cmd => ActionProvider cmd dropColumnNullProvider = ActionProvider provider where @@ -444,7 +446,8 @@ guard (tblNm == tblNm'' && colNm == colNm') let cmd = alterTableCmd (alterTableSyntax tblNm (alterColumnSyntax colNm setNullSyntax)) - pure (PotentialAction (HS.fromList [SomeDatabasePredicate colP]) mempty (Seq.singleton cmd) + pure (PotentialAction (HS.fromList [SomeDatabasePredicate colP]) mempty + (Seq.singleton (MigrationCommand cmd MigrationKeepsData)) ("Drop not null constraint for " <> colNm <> " on " <> tblNm) 100) -- | Default action providers for any SQL92 compliant syntax. @@ -456,7 +459,7 @@ -- * ALTER TABLE ... ADD COLUMN ... -- * ALTER TABLE ... DROP COLUMN ... -- * ALTER TABLE ... ALTER COLUMN ... SET [NOT] NULL -defaultActionProvider :: ( Sql92SaneDdlCommandSyntax cmd +defaultActionProvider :: ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) ) => ActionProvider cmd defaultActionProvider = @@ -492,7 +495,7 @@ -- from injecting arbitrary actions. Instead the caller is limited to choosing -- only valid actions as provided by the suppled 'ActionProvider'. data Solver cmd where - ProvideSolution :: [cmd] -> Solver cmd + ProvideSolution :: [ MigrationCommand cmd ] -> Solver cmd SearchFailed :: [ DatabaseState cmd ] -> Solver cmd ChooseActions :: { choosingActionsAtState :: !(DatabaseState cmd) -- ^ The current node we're searching at @@ -511,7 +514,7 @@ -- | Represents the final results of a search data FinalSolution cmd - = Solved [ cmd ] + = Solved [ MigrationCommand cmd ] -- ^ The search found a path from the source to the destination database, -- and has provided a set of commands that would work | Candidates [ DatabaseState cmd ] diff --git a/Database/Beam/Migrate/Backend.hs b/Database/Beam/Migrate/Backend.hs --- a/Database/Beam/Migrate/Backend.hs +++ b/Database/Beam/Migrate/Backend.hs @@ -19,14 +19,14 @@ -- deserialize them from JSON. Finally, if your backend has custom -- 'DatabasePredicate's you will have to provide appropriate 'ActionProvider's -- to discover potential actions for your backend. See the documentation for --- 'Database.Beam.Migrate.Actions' for more information. +-- "Database.Beam.Migrate.Actions" for more information. -- -- Tools may be interested in the 'SomeBeamMigrationBackend' data type which -- provides a monomorphic type to wrap the polymorphic 'BeamMigrationBackend' -- type. Currently, @beam-migrate-cli@ uses this type to get the underlying -- 'BeamMigrationBackend' via the @hint@ package. -- --- For an example migrate backend, see 'Database.Beam.Sqlite.Migrates' +-- For an example migrate backend, see "Database.Beam.Sqlite.Migrate" module Database.Beam.Migrate.Backend ( BeamMigrationBackend(..) , DdlError @@ -69,7 +69,7 @@ -- | Backends should create a value of this type and export it in an exposed -- module under the name 'migrationBackend'. See the module documentation for -- more details. -data BeamMigrationBackend be commandSyntax hdl where +data BeamMigrationBackend commandSyntax be hdl m where BeamMigrationBackend :: ( MonadBeam commandSyntax be hdl m , Typeable be @@ -92,7 +92,7 @@ , backendConvertToHaskell :: HaskellPredicateConverter , backendActionProvider :: ActionProvider commandSyntax , backendTransact :: forall a. String -> m a -> IO (Either DdlError a) - } -> BeamMigrationBackend be commandSyntax hdl + } -> BeamMigrationBackend commandSyntax be hdl m -- | Monomorphic wrapper for use with plugin loaders that cannot handle -- polymorphism @@ -101,7 +101,7 @@ , IsSql92DdlCommandSyntax commandSyntax , IsSql92Syntax commandSyntax , Sql92SanityCheck commandSyntax ) => - BeamMigrationBackend be commandSyntax hdl + BeamMigrationBackend commandSyntax be hdl m -> SomeBeamMigrationBackend -- | In order to support Haskell schema generation, backends need to provide a diff --git a/Database/Beam/Migrate/Generics/Tables.hs b/Database/Beam/Migrate/Generics/Tables.hs --- a/Database/Beam/Migrate/Generics/Tables.hs +++ b/Database/Beam/Migrate/Generics/Tables.hs @@ -26,6 +26,7 @@ import Data.Text (Text) import Data.Scientific (Scientific) import Data.Time.Calendar (Day) +import Data.Time (TimeOfDay) import Data.Int import Data.Word @@ -69,6 +70,14 @@ gDefaultTblSettingsChecks syntax _ _ = K1 (to (gDefaultTblSettingsChecks syntax (Proxy :: Proxy (Rep (embeddedTbl Identity))) True)) +instance ( Generic (embeddedTbl (Nullable (Const [FieldCheck]))) + , IsSql92DdlCommandSyntax syntax + , GMigratableTableSettings syntax (Rep (embeddedTbl (Nullable Identity))) (Rep (embeddedTbl (Nullable (Const [FieldCheck])))) ) => + GMigratableTableSettings syntax (Rec0 (embeddedTbl (Nullable Identity))) (Rec0 (embeddedTbl (Nullable (Const [FieldCheck])))) where + + gDefaultTblSettingsChecks syntax _ _ = + K1 (to (gDefaultTblSettingsChecks syntax (Proxy :: Proxy (Rep (embeddedTbl (Nullable Identity)))) True)) + -- * Nullability check type family NullableStatus (x :: *) :: Bool where @@ -129,13 +138,6 @@ -> dataTypeSyntax instance (IsSql92DataTypeSyntax dataTypeSyntax, HasDefaultSqlDataType dataTypeSyntax ty) => - HasDefaultSqlDataType dataTypeSyntax (Auto ty) where - defaultSqlDataType _ = defaultSqlDataType (Proxy @ty) -instance (IsSql92ColumnSchemaSyntax columnSchemaSyntax, HasDefaultSqlDataTypeConstraints columnSchemaSyntax ty) => - HasDefaultSqlDataTypeConstraints columnSchemaSyntax (Auto ty) where - defaultSqlDataTypeConstraints _ = defaultSqlDataTypeConstraints (Proxy @ty) - -instance (IsSql92DataTypeSyntax dataTypeSyntax, HasDefaultSqlDataType dataTypeSyntax ty) => HasDefaultSqlDataType dataTypeSyntax (Maybe ty) where defaultSqlDataType _ = defaultSqlDataType (Proxy @ty) instance (IsSql92ColumnSchemaSyntax columnSchemaSyntax, HasDefaultSqlDataTypeConstraints columnSchemaSyntax ty) => @@ -188,6 +190,10 @@ instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Day where defaultSqlDataType _ _ = dateType instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax Day + +instance IsSql92DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax TimeOfDay where + defaultSqlDataType _ _ = timeType Nothing False +instance IsSql92ColumnSchemaSyntax columnSchemaSyntax => HasDefaultSqlDataTypeConstraints columnSchemaSyntax TimeOfDay instance IsSql99DataTypeSyntax dataTypeSyntax => HasDefaultSqlDataType dataTypeSyntax Bool where defaultSqlDataType _ _ = booleanType diff --git a/Database/Beam/Migrate/Log.hs b/Database/Beam/Migrate/Log.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Migrate/Log.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +-- | Contains a schema for beam migration tools. Used by the CLI and +-- the managed migrations support here. +module Database.Beam.Migrate.Log where + +import Database.Beam +import Database.Beam.Backend.SQL +import Database.Beam.Migrate +import Database.Beam.Migrate.Backend + +import Control.Monad (when) + +import Data.String (fromString) +import Data.Text (Text) +import Data.Time (LocalTime) +import Data.UUID (UUID) + +data LogEntryT f + = LogEntry + { _logEntryId :: C f Int + , _logEntryCommitId :: C f Text + , _logEntryDate :: C f LocalTime + } deriving Generic + +instance Beamable LogEntryT +type LogEntry = LogEntryT Identity +deriving instance Show LogEntry + +instance Table LogEntryT where + data PrimaryKey LogEntryT f = LogEntryKey (C f Int) + deriving Generic + primaryKey = LogEntryKey <$> _logEntryId + +instance Beamable (PrimaryKey LogEntryT) + +type LogEntryKey = PrimaryKey LogEntryT Identity +deriving instance Show LogEntryKey + +newtype BeamMigrateVersionT f + = BeamMigrateVersion + { _beamMigrateVersion :: C f Int + } deriving Generic + +instance Beamable BeamMigrateVersionT +type BeamMigrateVersion = BeamMigrateVersionT Identity +deriving instance Show BeamMigrateVersion + +instance Table BeamMigrateVersionT where + data PrimaryKey BeamMigrateVersionT f = BeamMigrateVersionKey (C f Int) + deriving Generic + primaryKey = BeamMigrateVersionKey <$> _beamMigrateVersion + +instance Beamable (PrimaryKey BeamMigrateVersionT) + +type BeamMigrateVersionKey = PrimaryKey BeamMigrateVersionT Identity +deriving instance Show BeamMigrateVersionKey + +-- Database +data BeamMigrateDb entity + = BeamMigrateDb + { _beamMigrateVersionTbl :: entity (TableEntity BeamMigrateVersionT) + , _beamMigrateLogEntries :: entity (TableEntity LogEntryT) + } deriving Generic + +instance Database be BeamMigrateDb + +beamMigratableDb :: forall cmd be hdl m + . ( Sql92SaneDdlCommandSyntax cmd + , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) + , MonadBeam cmd be hdl m ) + => CheckedDatabaseSettings be BeamMigrateDb +beamMigratableDb = runMigrationSilenced $ beamMigrateDbMigration @cmd @be @hdl @m + +beamMigrateDb :: forall be cmd hdl m + . ( Sql92SaneDdlCommandSyntax cmd + , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) + , MonadBeam cmd be hdl m ) + => DatabaseSettings be BeamMigrateDb +beamMigrateDb = unCheckDatabase $ beamMigratableDb @cmd @be @hdl @m + +beamMigrateDbMigration :: forall cmd be hdl m + . ( Sql92SaneDdlCommandSyntax cmd + , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) + , MonadBeam cmd be hdl m ) + => Migration cmd (CheckedDatabaseSettings be BeamMigrateDb) +beamMigrateDbMigration = + BeamMigrateDb <$> createTable "beam_version" + (BeamMigrateVersion (field "version" int notNull)) + <*> createTable "beam_migration" + (LogEntry (field "id" int notNull) (field "commitId" (varchar Nothing) notNull) + (field "date" timestamp notNull)) + +beamMigrateSchemaVersion :: Int +beamMigrateSchemaVersion = 1 + +getLatestLogEntry :: forall be cmd hdl m + . ( IsSql92Syntax cmd + , HasQBuilder (Sql92SelectSyntax cmd) + , Sql92ReasonableMarshaller be + , Sql92SanityCheck cmd + , Sql92SaneDdlCommandSyntax cmd + , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) + , MonadBeam cmd be hdl m ) + => m (Maybe LogEntry) +getLatestLogEntry = + runSelectReturningOne (select $ + limit_ 1 $ + orderBy_ (desc_ . _logEntryId) $ + all_ (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m))) + +updateSchemaToCurrent :: forall be cmd hdl m + . ( IsSql92Syntax cmd + , Sql92SanityCheck cmd + , Sql92ReasonableMarshaller be + , Sql92SaneDdlCommandSyntax cmd + , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) + , MonadBeam cmd be hdl m ) + => m () +updateSchemaToCurrent = + runInsert (insert (_beamMigrateVersionTbl (beamMigrateDb @be @cmd @hdl @m)) (insertValues [BeamMigrateVersion beamMigrateSchemaVersion])) + +recordCommit :: forall be cmd hdl m + . ( IsSql92Syntax cmd + , Sql92SanityCheck cmd + , Sql92SaneDdlCommandSyntax cmd + , HasQBuilder (Sql92SelectSyntax cmd) + , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) + , HasSqlValueSyntax (Sql92ValueSyntax cmd) Text + , Sql92ReasonableMarshaller be + , MonadBeam cmd be hdl m ) + => UUID -> m () +recordCommit commitId = do + let commitIdTxt = fromString (show commitId) + + logEntry <- getLatestLogEntry + let nextLogEntryId = maybe 0 (succ . _logEntryId) logEntry + + runInsert (insert (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m)) + (insertExpressions + [ LogEntry (val_ nextLogEntryId) + (val_ commitIdTxt) + currentTimestamp_])) + +-- Ensure the backend tables exist +ensureBackendTables :: forall be cmd hdl m + . BeamMigrationBackend cmd be hdl m + -> m () +ensureBackendTables be@BeamMigrationBackend { backendGetDbConstraints = getCs } = + do backendSchemaBuilt <- checkForBackendTables be + if backendSchemaBuilt + then continueMigrate + else createSchema + + where + doStep cmd = runNoReturn cmd + + continueMigrate = do + maxVersion <- + runSelectReturningOne $ select $ + aggregate_ (\v -> max_ (_beamMigrateVersion v)) $ + all_ (_beamMigrateVersionTbl (beamMigrateDb @be @cmd @hdl @m)) + + case maxVersion of + Nothing -> cleanAndCreateSchema + Just Nothing -> cleanAndCreateSchema + Just (Just maxVersion') + | maxVersion' > beamMigrateSchemaVersion -> + fail "This database is being managed by a newer version of beam-migrate" + | maxVersion' < beamMigrateSchemaVersion -> + fail "This database is being managed by an older version of beam-migrate, but there are no older versions" + | otherwise -> pure () + + cleanAndCreateSchema = do + cs <- getCs + let migrationLogExists = any (== p (TableExistsPredicate "beam_migration")) cs + + when migrationLogExists $ do + Just totalCnt <- + runSelectReturningOne $ select $ + aggregate_ (\_ -> as_ @Int countAll_) $ + all_ (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m)) + when (totalCnt > 0) (fail "beam-migrate: No versioning information, but log entries present") + runNoReturn (dropTableCmd (dropTableSyntax "beam_migration")) + + runNoReturn (dropTableCmd (dropTableSyntax "beam_version")) + + createSchema + + createSchema = do + _ <- executeMigration doStep (beamMigrateDbMigration @cmd @be @hdl @m) + updateSchemaToCurrent + +checkForBackendTables :: BeamMigrationBackend cmd be hdl m -> m Bool +checkForBackendTables BeamMigrationBackend { backendGetDbConstraints = getCs } = + do cs <- getCs + pure (any (== p (TableExistsPredicate "beam_version")) cs) diff --git a/Database/Beam/Migrate/SQL/BeamExtensions.hs b/Database/Beam/Migrate/SQL/BeamExtensions.hs --- a/Database/Beam/Migrate/SQL/BeamExtensions.hs +++ b/Database/Beam/Migrate/SQL/BeamExtensions.hs @@ -31,4 +31,4 @@ -- information. class IsSql92ColumnSchemaSyntax syntax => IsBeamSerialColumnSchemaSyntax syntax where - genericSerial :: FieldReturnType 'False 'False syntax (SqlSerial Int) a => Text -> a + genericSerial :: FieldReturnType 'True 'False syntax (SqlSerial Int) a => Text -> a diff --git a/Database/Beam/Migrate/SQL/SQL92.hs b/Database/Beam/Migrate/SQL/SQL92.hs --- a/Database/Beam/Migrate/SQL/SQL92.hs +++ b/Database/Beam/Migrate/SQL/SQL92.hs @@ -15,16 +15,24 @@ -- * Convenience type synonyms --- | Command syntaxes that can be used to issue DDL commands. +-- | Syntax equalities that any reasonable DDL syntax would follow, +-- including equalities between beam-migrate and beam-core types. type Sql92SaneDdlCommandSyntax cmd = + ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd + , Sql92ColumnSchemaExpressionSyntax (Sql92DdlCommandColumnSchemaSyntax cmd) ~ + Sql92ExpressionSyntax cmd ) + +-- | Syntax equalities for any reasonable DDL syntax, only including +-- types defined here. +type Sql92SaneDdlCommandSyntaxMigrateOnly cmd = ( IsSql92DdlCommandSyntax cmd , Sql92SerializableDataTypeSyntax (Sql92DdlCommandDataTypeSyntax cmd) , Sql92SerializableConstraintDefinitionSyntax (Sql92DdlCommandConstraintDefinitionSyntax cmd) , Typeable (Sql92DdlCommandColumnSchemaSyntax cmd) , Sql92AlterTableColumnSchemaSyntax (Sql92AlterTableAlterTableActionSyntax (Sql92DdlCommandAlterTableSyntax cmd)) ~ - Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax cmd) ) - + Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax cmd) + ) type Sql92DdlCommandDataTypeSyntax syntax = Sql92ColumnSchemaColumnTypeSyntax (Sql92DdlCommandColumnSchemaSyntax syntax) diff --git a/Database/Beam/Migrate/SQL/Tables.hs b/Database/Beam/Migrate/SQL/Tables.hs --- a/Database/Beam/Migrate/SQL/Tables.hs +++ b/Database/Beam/Migrate/SQL/Tables.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Database.Beam.Migrate.SQL.Tables ( -- * Table manipulation @@ -23,7 +24,7 @@ , field - , defaultTo_, notNull + , defaultTo_, notNull, unique , int, smallint, bigint , char, varchar, double , characterLargeObject, binaryLargeObject, array @@ -31,7 +32,7 @@ , timestamp, timestamptz , binary, varbinary - , maybeType, autoType + , maybeType -- ** Internal classes -- Provided without documentation for use in type signatures @@ -58,6 +59,7 @@ import Data.Typeable import Data.Time (LocalTime, TimeOfDay) import Data.Scientific (Scientific) +import qualified Data.Kind as Kind (Constraint) import GHC.TypeLits @@ -120,14 +122,16 @@ -- | Monad representing a series of @ALTER TABLE@ statements newtype TableMigration syntax a = TableMigration (WriterT [Sql92DdlCommandAlterTableSyntax syntax] (State (Text, [TableCheck])) a) + deriving (Monad, Applicative, Functor) -- | @ALTER TABLE ... RENAME TO@ command renameTableTo :: Sql92SaneDdlCommandSyntax syntax => Text -> table ColumnMigration -> TableMigration syntax (table ColumnMigration) renameTableTo newName oldTbl = TableMigration $ do - (curNm, _) <- get + (curNm, chks) <- get tell [ alterTableSyntax curNm (renameTableToSyntax newName) ] + put (newName, chks) return oldTbl -- | @ALTER TABLE ... RENAME COLUMN ... TO ...@ command @@ -268,10 +272,17 @@ = Constraint (Sql92ColumnConstraintDefinitionConstraintSyntax (Sql92ColumnSchemaColumnConstraintDefinitionSyntax syntax)) +newtype NotNullConstraint syntax + = NotNullConstraint (Constraint syntax) + -- | The SQL92 @NOT NULL@ constraint -notNull :: IsSql92ColumnSchemaSyntax syntax => Constraint syntax -notNull = Constraint notNullConstraintSyntax +notNull :: IsSql92ColumnSchemaSyntax syntax => NotNullConstraint syntax +notNull = NotNullConstraint (Constraint notNullConstraintSyntax) +-- | SQL @UNIQUE@ constraint +unique :: IsSql92ColumnSchemaSyntax syntax => Constraint syntax +unique = Constraint uniqueColumnConstraintSyntax + -- ** Data types -- | SQL92 @INTEGER@ data type @@ -353,11 +364,6 @@ maybeType :: DataType syntax a -> DataType syntax (Maybe a) maybeType (DataType sqlTy) = DataType sqlTy --- | Wrap a 'DataType' in 'Auto' -autoType :: DataType syntax a -> DataType syntax (Auto a) -autoType (DataType sqlTy) = DataType sqlTy - - -- ** 'field' variable arity classes class FieldReturnType (defaultGiven :: Bool) (collationGiven :: Bool) syntax resTy a | a -> syntax resTy where @@ -379,6 +385,12 @@ field' defaultGiven collationGiven nm ty default_' collation constraints (Constraint e) = field' defaultGiven collationGiven nm ty default_' collation (constraints ++ [ constraintDefinitionSyntax Nothing e Nothing ]) +instance ( FieldReturnType defaultGiven collationGiven syntax resTy (Constraint syntax -> a) + , IsNotNull resTy ) => + FieldReturnType defaultGiven collationGiven syntax resTy (NotNullConstraint syntax -> a) where + field' defaultGiven collationGiven nm ty default_' collation constraints (NotNullConstraint c) = + field' defaultGiven collationGiven nm ty default_' collation constraints c + instance ( FieldReturnType 'True collationGiven syntax resTy a , TypeError ('Text "Only one DEFAULT clause can be given per 'field' invocation") ) => FieldReturnType 'True collationGiven syntax resTy (DefaultValue syntax resTy -> a) where @@ -401,3 +413,9 @@ TableFieldSchema nm (FieldSchema (columnSchemaSyntax ty default_' constraints collation)) checks where checks = [ FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableHasColumn tbl field'' ty :: TableHasColumn syntax)) ] ++ map (\cns -> FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableColumnHasConstraint tbl field'' cns :: TableColumnHasConstraint syntax))) constraints + +type family IsNotNull (x :: *) :: Kind.Constraint where + IsNotNull (Maybe x) = TypeError ('Text "You used Database.Beam.Migrate.notNull on a column with type" ':$$: + 'ShowType (Maybe x) ':$$: + 'Text "Either remove 'notNull' from your migration or 'Maybe' from your table") + IsNotNull x = () diff --git a/Database/Beam/Migrate/Simple.hs b/Database/Beam/Migrate/Simple.hs --- a/Database/Beam/Migrate/Simple.hs +++ b/Database/Beam/Migrate/Simple.hs @@ -1,25 +1,175 @@ - +{-# LANGUAGE AllowAmbiguousTypes #-} -- | Utility functions for common use cases module Database.Beam.Migrate.Simple - ( simpleSchema, simpleMigration - , runSimpleMigration, backendMigrationScript + ( autoMigrate + , simpleSchema + , simpleMigration + , runSimpleMigration + , backendMigrationScript + , VerificationResult(..) + , verifySchema + + , createSchema + + , BringUpToDateHooks(..) + , defaultUpToDateHooks + , bringUpToDate, bringUpToDateWithHooks + , module Database.Beam.Migrate.Actions , module Database.Beam.Migrate.Types ) where -import Database.Beam -import Database.Beam.Backend.SQL -import Database.Beam.Migrate.Backend -import Database.Beam.Migrate.Types -import Database.Beam.Migrate.Actions +import Prelude hiding (log) +import Database.Beam +import Database.Beam.Backend.SQL +import Database.Beam.Migrate.Backend +import Database.Beam.Migrate.Types +import Database.Beam.Migrate.Actions +import Database.Beam.Migrate.Log + +import Control.Monad.Cont +import Control.Monad.Writer +import Control.Monad.State + +import qualified Data.HashSet as HS +import Data.Semigroup (Max(..)) import qualified Data.Text as T +data BringUpToDateHooks m + = BringUpToDateHooks + { 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. + , startStepHook :: Int -> T.Text -> m () + -- ^ Called at the beginning of each step with the step index and description + , endStepHook :: Int -> T.Text -> m () + -- ^ Called at the end of each step with the step index and description + , 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. + + , queryFailedHook :: m () + -- ^ Called when a query fails + , discontinuousMigrationsHook + :: Int -> m () + -- ^ Called when the migration log has a discontinuity at the supplied index + , 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 + , 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 :: Monad m => BringUpToDateHooks m +defaultUpToDateHooks = + BringUpToDateHooks + { runIrreversibleHook = pure False + , startStepHook = \_ _ -> pure () + , endStepHook = \_ _ -> pure () + , runCommandHook = \_ _ -> pure () + , queryFailedHook = fail "Log entry query fails" + , discontinuousMigrationsHook = + \ix -> fail ("Discontinuous migration log: missing migration at " ++ show ix) + , logMismatchHook = + \ix actual expected -> + 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)") + } + +-- | 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 + => BeamMigrationBackend cmd be hdl m + -> MigrationSteps cmd () (CheckedDatabaseSettings be db) + -> m (Maybe (CheckedDatabaseSettings be db)) +bringUpToDate be@BeamMigrationBackend {} = + bringUpToDateWithHooks defaultUpToDateHooks 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 cmd be hdl m + . Database be db + => BringUpToDateHooks m + -> BeamMigrationBackend cmd be hdl m + -> MigrationSteps cmd () (CheckedDatabaseSettings be db) + -> m (Maybe (CheckedDatabaseSettings be db)) +bringUpToDateWithHooks hooks be@(BeamMigrationBackend { backendRenderSyntax = renderSyntax' }) steps = do + ensureBackendTables be + + entries <- runSelectReturningList $ select $ + all_ (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m)) + let verifyMigration :: Int -> T.Text -> Migration cmd a -> StateT [LogEntry] (WriterT (Max Int) m) a + verifyMigration stepIx stepNm step = + do log <- get + case log of + [] -> pure () + LogEntry actId actStepNm _:log' + | actId == stepIx && actStepNm == stepNm -> + tell (Max stepIx) >> put log' + | actId /= stepIx -> + lift . lift $ discontinuousMigrationsHook hooks stepIx + | otherwise -> + lift . lift $ logMismatchHook hooks stepIx actStepNm stepNm + executeMigration (\_ -> pure ()) step + + (futureEntries, Max lastCommit) <- + runWriterT (execStateT (runMigrationSteps 0 Nothing steps verifyMigration) entries <* + tell (Max (-1))) + + case futureEntries of + _:_ -> databaseAheadHook hooks (length futureEntries) + [] -> pure () + + -- Check data loss + shouldRunMigration <- + flip runContT (\_ -> pure True) $ + runMigrationSteps (lastCommit + 1) Nothing steps + (\_ _ step -> do + case migrationDataLoss step of + MigrationLosesData -> + ContT $ \_ -> runIrreversibleHook hooks + MigrationKeepsData -> + executeMigration (\_ -> pure ()) step) + + if shouldRunMigration + then Just <$> + runMigrationSteps (lastCommit + 1) Nothing steps + (\stepIx stepName step -> + do startStepHook hooks stepIx stepName + ret <- + executeMigration + (\cmd -> do + runCommandHook hooks stepIx (renderSyntax' cmd) + runNoReturn cmd) + step + + runInsert $ insert (_beamMigrateLogEntries (beamMigrateDb @be @cmd @hdl @m)) $ + insertExpressions [ LogEntry (val_ stepIx) (val_ stepName) currentTimestamp_ ] + endStepHook hooks stepIx stepName + + return ret) + else pure 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 db +simpleSchema :: Database be db => ActionProvider cmd -> CheckedDatabaseSettings be db -> Maybe [cmd] @@ -27,9 +177,44 @@ let allChecks = collectChecks settings solver = heuristicSolver provider [] allChecks in case finalSolution solver of - Solved cmds -> Just cmds + Solved cmds -> Just (fmap migrationCommand cmds) Candidates {} -> 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 + => BeamMigrationBackend cmd be hdl m + -> CheckedDatabaseSettings be db + -> m () +createSchema BeamMigrationBackend { backendActionProvider = actions } db = + case simpleSchema actions db of + Nothing -> fail "createSchema: Could not determine schema" + Just cmds -> + mapM_ runNoReturn 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 + => BeamMigrationBackend cmd be hdl m + -> CheckedDatabaseSettings be db + -> m () +autoMigrate BeamMigrationBackend { backendActionProvider = actions + , backendGetDbConstraints = getCs } + db = + do actual <- getCs + let expected = collectChecks db + case finalSolution (heuristicSolver actions actual expected) of + Candidates {} -> 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" + -- | 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. @@ -37,8 +222,8 @@ -- 'BeamMigrationBackend's can usually be found in a module named -- @Database.Beam..Migrate@ with the name@migrationBackend@ simpleMigration :: ( MonadBeam cmd be handle m - , Database db ) - => BeamMigrationBackend be cmd handle + , Database be db ) + => BeamMigrationBackend cmd be handle m -> handle -> CheckedDatabaseSettings be db -> IO (Maybe [cmd]) @@ -50,14 +235,35 @@ solver = heuristicSolver action pre post case finalSolution solver of - Solved cmds -> pure (Just cmds) + Solved cmds -> pure (Just (fmap migrationCommand cmds)) Candidates {} -> pure Nothing +-- | Result type for 'verifySchema' +data VerificationResult + = VerificationSucceeded + | VerificationFailed [SomeDatabasePredicate] + deriving 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 cmd be handle m ) + => BeamMigrationBackend cmd be handle 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)) + -- | Run a sequence of commands on a database -runSimpleMigration :: MonadBeam cmd be hdl m +runSimpleMigration :: forall cmd be hdl m . MonadBeam cmd be hdl m => hdl -> [cmd] -> IO () runSimpleMigration hdl = - withDatabase hdl . mapM_ runNoReturn + withDatabase @cmd @be @hdl @m hdl . mapM_ 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 diff --git a/Database/Beam/Migrate/Types.hs b/Database/Beam/Migrate/Types.hs --- a/Database/Beam/Migrate/Types.hs +++ b/Database/Beam/Migrate/Types.hs @@ -17,6 +17,7 @@ -- -- The functions in this section can be used to modify 'CheckedDatabaseSettings' objects. , CheckedFieldModification + , checkedFieldNamed , modifyCheckedTable , checkedTableModification @@ -36,14 +37,13 @@ , MigrationStep(..), MigrationSteps(..) , Migration, MigrationF(..) - , migrationStepsToMigration, runMigrationSilenced - , runMigrationVerbose, executeMigration - , eraseMigrationType, migrationStep, upDown + , MigrationCommand(..), MigrationDataLoss(..) - , migrateScript, evaluateDatabase, stepNames ) where + , runMigrationSteps, runMigrationSilenced + , executeMigration, eraseMigrationType, migrationStep + , upDown, migrationDataLoss -import Database.Beam -import Database.Beam.Backend + , migrateScript, evaluateDatabase, stepNames ) where import Database.Beam.Migrate.Types.CheckedEntities import Database.Beam.Migrate.Types.Predicates @@ -57,12 +57,18 @@ -- * Migration types +-- | Represents a particular step in a migration data MigrationStep syntax next where MigrationStep :: Text -> Migration syntax a -> (a -> next) -> MigrationStep syntax next deriving instance Functor (MigrationStep syntax) + +-- | A series of 'MigrationStep's that take a database from the schema in @from@ +-- to the one in @to@. Use the 'migrationStep' function and the arrow interface +-- to sequence 'MigrationSteps'. newtype MigrationSteps syntax from to = MigrationSteps (Kleisli (F (MigrationStep syntax)) from to) deriving (Category, Arrow) +-- | Free monadic function for 'Migration's data MigrationF syntax next where MigrationRunCommand :: { _migrationUpCommand :: syntax {-^ What to execute when applying the migration -} @@ -70,48 +76,83 @@ , _migrationNext :: next } -> MigrationF syntax next deriving instance Functor (MigrationF syntax) + +-- | A sequence of potentially reversible schema update commands type Migration syntax = F (MigrationF syntax) +-- | Information on whether a 'MigrationCommand' loses data. You can +-- monoidally combine these to get the potential data loss for a +-- sequence of commands. +data MigrationDataLoss + = MigrationLosesData + -- ^ The command loses data + | MigrationKeepsData + -- ^ The command keeps all data + deriving Show -migrationStepsToMigration :: Int -> Maybe Int - -> MigrationSteps syntax () a - -> (forall a'. Text -> Migration syntax a' -> IO a') - -> IO a -migrationStepsToMigration firstIdx lastIdx (MigrationSteps steps) runMigration = +instance Monoid MigrationDataLoss where + mempty = MigrationKeepsData + mappend MigrationLosesData _ = MigrationLosesData + mappend _ MigrationLosesData = MigrationLosesData + mappend MigrationKeepsData MigrationKeepsData = MigrationKeepsData + +-- | A migration command along with metadata on wheth +data MigrationCommand cmd + = MigrationCommand + { migrationCommand :: cmd + -- ^ The command to run + , migrationCommandDataLossPossible :: MigrationDataLoss + -- ^ Information on whether the migration loses data + } deriving Show + +-- | Run the migration steps between the given indices, using a custom execution function. +runMigrationSteps :: Monad m + => Int -- ^ Zero-based index of the first step to run + -> Maybe Int -- ^ Index of the last step to run, or 'Nothing' to run every step + -> MigrationSteps syntax () a -- ^ The set of steps to run + -> (forall a'. Int -> Text -> Migration syntax a' -> m a') + -- ^ Callback for each step. Called with the step index, the + -- step description and the migration. + -> m a +runMigrationSteps firstIdx lastIdx (MigrationSteps steps) runMigration = runF (runKleisli steps ()) finish step 0 where finish x _ = pure x step (MigrationStep nm doStep next) i = if i >= firstIdx && maybe True (i <) lastIdx - then runMigration nm doStep >>= \x -> next x (i + 1) + then runMigration i nm doStep >>= \x -> next x (i + 1) else next (runMigrationSilenced doStep) (i + 1) +-- | Get the result of a migration, without running any steps runMigrationSilenced :: Migration syntax a -> a runMigrationSilenced m = runF m id step where step (MigrationRunCommand _ _ next) = next -runMigrationVerbose :: MonadBeam syntax be hdl m => (syntax -> String) - -> Migration syntax a -> m a -runMigrationVerbose renderMigrationSyntax steps = - runF steps finish step - where finish = pure - step (MigrationRunCommand up _ next) = - do liftIO (putStrLn (renderMigrationSyntax up)) - runNoReturn up - next - +-- | Remove the explicit source and destination schemas from a 'MigrationSteps' object eraseMigrationType :: a -> MigrationSteps syntax a a' -> MigrationSteps syntax () () eraseMigrationType a (MigrationSteps steps) = MigrationSteps (arr (const a) >>> steps >>> arr (const ())) +-- | Create a 'MigrationSteps' from the given description and migration function. migrationStep :: Text -> (a -> Migration syntax a') -> MigrationSteps syntax a a' migrationStep stepName migration = MigrationSteps (Kleisli (\a -> liftF (MigrationStep stepName (migration a) id))) +-- | Given a command in the forward direction, and an optional one in the +-- reverse direction, construct a 'Migration' that performs the given +-- command. Multiple commands can be sequenced monadically. upDown :: syntax -> Maybe syntax -> Migration syntax () upDown up down = liftF (MigrationRunCommand up down ()) -migrateScript :: forall syntax m a. - Monoid m => (Text -> m) -> (syntax -> m) -> MigrationSteps syntax () a -> m +-- | Given functions to render a migration step description and the underlying +-- syntax, create a script for the given 'MigrationSteps'. +migrateScript :: forall syntax m a. Monoid m + => (Text -> m) + -- ^ Called at the beginning of each 'MigrationStep' with the step description + -> (syntax -> m) + -- ^ Called for each command in the migration step + -> MigrationSteps syntax () a + -- ^ The set of steps to run + -> m migrateScript renderMigrationHeader renderMigrationSyntax (MigrationSteps steps) = runF (runKleisli steps ()) (\_ x -> x) (\(MigrationStep header migration next) x -> @@ -131,16 +172,26 @@ doStep (MigrationRunCommand cmd _ next) = runSyntax cmd *> next +-- | Given a migration, get the potential data loss, if it's run top-down +migrationDataLoss :: Migration syntax a -> MigrationDataLoss +migrationDataLoss go = runF go (\_ -> MigrationKeepsData) + (\(MigrationRunCommand _ x next) -> + case x of + Nothing -> MigrationLosesData + _ -> next) + +-- | Run a 'MigrationSteps' without executing any of the commands against a +-- database. evaluateDatabase :: forall syntax a. MigrationSteps syntax () a -> a evaluateDatabase (MigrationSteps f) = runF (runKleisli f ()) id (\(MigrationStep _ migration next) -> next (runMigration migration)) where runMigration :: forall a'. Migration syntax a' -> a' runMigration migration = runF migration id (\(MigrationRunCommand _ _ next) -> next) +-- | Collect the names of all steps in hte given 'MigrationSteps' stepNames :: forall syntax a. MigrationSteps syntax () a -> [Text] stepNames (MigrationSteps f) = runF (runKleisli f ()) (\_ x -> x) (\(MigrationStep nm migration next) x -> next (runMigration migration) (x ++ [nm])) [] where runMigration :: forall a'. Migration syntax a' -> a' runMigration migration = runF migration id (\(MigrationRunCommand _ _ next) -> next) --- * Checked database entities diff --git a/Database/Beam/Migrate/Types/CheckedEntities.hs b/Database/Beam/Migrate/Types/CheckedEntities.hs --- a/Database/Beam/Migrate/Types/CheckedEntities.hs +++ b/Database/Beam/Migrate/Types/CheckedEntities.hs @@ -63,13 +63,13 @@ -- | Convert a 'CheckedDatabaseSettings' to a regular 'DatabaseSettings'. The -- return value is suitable for use in any regular beam query or DML statement. -unCheckDatabase :: forall be db. Database db => CheckedDatabaseSettings be db -> DatabaseSettings be db +unCheckDatabase :: forall be db. Database be db => CheckedDatabaseSettings be db -> DatabaseSettings be db unCheckDatabase db = runIdentity $ zipTables (Proxy @be) (\(CheckedDatabaseEntity x _) _ -> pure $ DatabaseEntity (unCheck x)) db db -- | A @beam-migrate@ database schema is defined completely by the set of -- predicates that apply to it. This function allows you to access this -- definition for a 'CheckedDatabaseSettings' object. -collectChecks :: forall be db. Database db => CheckedDatabaseSettings be db -> [ SomeDatabasePredicate ] +collectChecks :: forall be db. Database be db => CheckedDatabaseSettings be db -> [ SomeDatabasePredicate ] collectChecks db = let (_ :: CheckedDatabaseSettings be db, a) = runWriter $ zipTables (Proxy @be) (\(CheckedDatabaseEntity entity cs :: CheckedDatabaseEntity be db entityType) b -> @@ -132,6 +132,9 @@ = CheckedFieldModification (TableField tbl a -> TableField tbl a) ([FieldCheck] -> [FieldCheck]) + +checkedFieldNamed :: Text -> CheckedFieldModification tbl a +checkedFieldNamed t = CheckedFieldModification (\_ -> TableField t) id instance IsString (CheckedFieldModification tbl a) where fromString s = CheckedFieldModification (const . TableField . fromString $ s) id diff --git a/beam-migrate.cabal b/beam-migrate.cabal --- a/beam-migrate.cabal +++ b/beam-migrate.cabal @@ -1,8 +1,5 @@ --- Initial beam-migrate.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: beam-migrate -version: 0.2.0.0 +version: 0.3.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 @@ -31,7 +28,7 @@ category: Database build-type: Simple extra-source-files: ChangeLog.md -cabal-version: >=1.10 +cabal-version: 1.18 library exposed-modules: Database.Beam.Migrate @@ -48,6 +45,8 @@ Database.Beam.Migrate.SQL.SQL92 Database.Beam.Migrate.SQL.BeamExtensions + Database.Beam.Migrate.Log + Database.Beam.Migrate.Generics Database.Beam.Migrate.Simple @@ -59,13 +58,13 @@ Database.Beam.Migrate.SQL.Types Database.Beam.Migrate.Types.CheckedEntities Database.Beam.Migrate.Types.Predicates - -- other-extensions: + build-depends: base >=4.9 && <4.11, - beam-core ==0.6.0.0, + beam-core >=0.7 && <0.8, text >=1.2 && <1.3, aeson >=0.11 && <1.3, bytestring >=0.10 && <0.11, - free >=4.12 && <4.13, + free >=4.12 && <5.1, time >=1.6 && <1.10, mtl >=2.2 && <2.3, scientific >=0.3 && <0.4, @@ -77,12 +76,12 @@ deepseq >=1.4 && <1.5, ghc-prim >=0.5 && <0.6, containers >=0.5 && <0.6, - haskell-src-exts >=1.18 && <1.20, + haskell-src-exts >=1.20 && <1.21, pretty >=1.1 && <1.2, dependent-map >=0.2 && <0.3, dependent-sum >=0.4 && <0.5, - pqueue >=1.3 && <1.4 - -- hs-source-dirs: + pqueue >=1.3 && <1.5, + uuid >=1.3 && <1.4 default-language: Haskell2010 default-extensions: KindSignatures, OverloadedStrings, TypeFamilies, FlexibleContexts, StandaloneDeriving, GADTs, DeriveFunctor, RankNTypes, ScopedTypeVariables,