diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,12 +1,18 @@ +# 0.5.3.0 + +## Added features + +* Added support for creating database schemas and associated tables with `createDatabaseSchema` and `createTableWithSchema`, as well as dropping schemas with `dropDatabaseSchema` (#716). + # 0.5.2.1 -# Added features +## Added features * Loosen some version bounds # 0.5.2.0 -# Addded features +## Addded features * `IN (SELECT ...)` syntax via `inSelectE` 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 @@ -54,13 +54,12 @@ deriving (Show, Eq, Generic) instance Hashable HsImport instance Semigroup HsImport where - (<>) = mappend + HsImportAll <> _ = HsImportAll + _ <> HsImportAll = HsImportAll + (HsImportSome a) <> (HsImportSome b) = + HsImportSome (a <> b) instance Monoid HsImport where mempty = HsImportSome mempty - mappend HsImportAll _ = HsImportAll - mappend _ HsImportAll = HsImportAll - mappend (HsImportSome a) (HsImportSome b) = - HsImportSome (a <> b) importSome :: T.Text -> [ Hs.ImportSpec () ] -> HsImports importSome modNm names = HsImports (M.singleton (Hs.ModuleName () (T.unpack modNm)) @@ -77,11 +76,10 @@ instance Hashable HsImports where hashWithSalt s (HsImports a) = hashWithSalt s (M.assocs a) instance Semigroup HsImports where - (<>) = mappend + (HsImports a) <> (HsImports b) = + HsImports (M.unionWith mappend a b) instance Monoid HsImports where mempty = HsImports mempty - mappend (HsImports a) (HsImports b) = - HsImports (M.unionWith mappend a b) data HsDataType = HsDataType @@ -140,11 +138,10 @@ } instance Semigroup HsAction where - (<>) = mappend + (<>) (HsAction ma ea) (HsAction mb eb) = + HsAction (ma <> mb) (ea <> eb) instance Monoid HsAction where mempty = HsAction [] [] - mappend (HsAction ma ea) (HsAction mb eb) = - HsAction (ma <> mb) (ea <> eb) newtype HsBackendConstraint = HsBackendConstraint { buildHsBackendConstraint :: Hs.Type () -> Hs.Asst () } @@ -154,18 +151,17 @@ | HsBeamBackendNone instance Semigroup (HsBeamBackend f) where - (<>) = mappend + (<>) (HsBeamBackendSingle aTy aExp) (HsBeamBackendSingle bTy _) + | aTy == bTy = HsBeamBackendSingle aTy aExp + | otherwise = HsBeamBackendNone + (<>) a@HsBeamBackendSingle {} _ = a + (<>) _ b@HsBeamBackendSingle {} = b + (<>) HsBeamBackendNone _ = HsBeamBackendNone + (<>) _ HsBeamBackendNone = HsBeamBackendNone + (<>) (HsBeamBackendConstrained a) (HsBeamBackendConstrained b) = + HsBeamBackendConstrained (a <> b) instance Monoid (HsBeamBackend f) where mempty = HsBeamBackendConstrained [] - mappend (HsBeamBackendSingle aTy aExp) (HsBeamBackendSingle bTy _) - | aTy == bTy = HsBeamBackendSingle aTy aExp - | otherwise = HsBeamBackendNone - mappend a@HsBeamBackendSingle {} _ = a - mappend _ b@HsBeamBackendSingle {} = b - mappend HsBeamBackendNone _ = HsBeamBackendNone - mappend _ HsBeamBackendNone = HsBeamBackendNone - mappend (HsBeamBackendConstrained a) (HsBeamBackendConstrained b) = - HsBeamBackendConstrained (a <> b) data HsEntity = HsEntity @@ -189,12 +185,11 @@ } instance Semigroup HsTableConstraintDecls where - (<>) = mappend + (<>) (HsTableConstraintDecls ai ad) (HsTableConstraintDecls bi bd) = + HsTableConstraintDecls (ai <> bi) (ad <> bd) instance Monoid HsTableConstraintDecls where mempty = HsTableConstraintDecls [] [] - mappend (HsTableConstraintDecls ai ad) (HsTableConstraintDecls bi bd) = - HsTableConstraintDecls (ai <> bi) (ad <> bd) data HsModule = HsModule @@ -415,10 +410,9 @@ instance Hashable HsNone instance Semigroup HsNone where - (<>) = mappend + (<>) _ _ = HsNone instance Monoid HsNone where mempty = HsNone - mappend _ _ = HsNone data HsMigrateBackend = HsMigrateBackend @@ -437,10 +431,20 @@ [] -> error "Empty schema name" x:xs -> toNameCase x:xs ++ "_" ++ T.unpack nm +hsSchemaName :: SchemaName -> String +hsSchemaName (SchemaName nm) = T.unpack nm + hsTableVarName, hsTableTypeName :: TableName -> String hsTableVarName = hsMkTableName toLower hsTableTypeName = hsMkTableName toUpper +instance IsSql92DdlSchemaCommandSyntax HsAction where + type Sql92DdlCommandCreateSchemaSyntax HsAction = HsAction + type Sql92DdlCommandDropSchemaSyntax HsAction = HsAction + + createSchemaCmd = id + dropSchemaCmd = id + instance IsSql92DdlCommandSyntax HsAction where type Sql92DdlCommandCreateTableSyntax HsAction = HsAction type Sql92DdlCommandAlterTableSyntax HsAction = HsAction @@ -476,6 +480,20 @@ dropTableSyntax nm = HsAction [ (Nothing, dropTable) ] [] where dropTable = hsApp (hsVar "dropTable") [ hsVar (fromString (hsTableVarName nm)) ] + +instance IsSql92CreateSchemaSyntax HsAction where + type Sql92CreateSchemaSchemaNameSyntax HsAction = SchemaName + createSchemaSyntax (SchemaName nm) = HsAction [ (Nothing, createSchema) ] [] + where + createSchema = hsApp (hsVar "createDatabaseSchema") [ hsVar nm ] + + +instance IsSql92DropSchemaSyntax HsAction where + type Sql92DropSchemaSchemaNameSyntax HsAction = SchemaName + dropSchemaSyntax (SchemaName nm) = HsAction [ (Nothing, dropSchema) ] [] + where + dropSchema = hsApp (hsVar "dropDatabaseSchema") [ hsVar nm ] + instance IsSql92CreateTableSyntax HsAction where type Sql92CreateTableTableNameSyntax HsAction = TableName 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 @@ -77,12 +77,14 @@ , ensuringNot_ , justOne_ + , createSchemaActionProvider , createTableActionProvider , dropTableActionProvider , addColumnProvider , addColumnNullProvider , dropColumnNullProvider , defaultActionProvider + , defaultSchemaActionProvider -- * Solver , Solver(..), FinalSolution(..) @@ -194,7 +196,14 @@ } instance Semigroup (PotentialAction be) where - (<>) = mappend + a <> b = + PotentialAction (actionPreConditions a <> actionPreConditions b) + (actionPostConditions a <> actionPostConditions b) + (actionCommands a <> actionCommands b) + (if T.null (actionEnglish a) then actionEnglish b + else if T.null (actionEnglish b) then actionEnglish a + else actionEnglish a <> "; " <> actionEnglish b) + (actionScore a + actionScore b) -- | 'PotentialAction's can represent edges or paths. Monadically combining two -- 'PotentialAction's results in the path between the source of the first and @@ -202,14 +211,6 @@ -- nothing (i.e., the edge going back to the same database state) instance Monoid (PotentialAction be) where mempty = PotentialAction mempty mempty mempty "" 0 - mappend a b = - PotentialAction (actionPreConditions a <> actionPreConditions b) - (actionPostConditions a <> actionPostConditions b) - (actionCommands a <> actionCommands b) - (if T.null (actionEnglish a) then actionEnglish b - else if T.null (actionEnglish b) then actionEnglish a - else actionEnglish a <> "; " <> actionEnglish b) - (actionScore a + actionScore b) -- | See 'ActionProvider' type ActionProviderFn be = @@ -254,11 +255,7 @@ = ActionProvider { getPotentialActions :: ActionProviderFn be } instance Semigroup (ActionProvider be) where - (<>) = mappend - -instance Monoid (ActionProvider be) where - mempty = ActionProvider (\_ _ -> []) - mappend (ActionProvider a) (ActionProvider b) = + (<>) (ActionProvider a) (ActionProvider b) = ActionProvider $ \pre post -> let aRes = a pre post bRes = b pre post @@ -267,7 +264,12 @@ withStrategy (rparWith (parList rseq)) bRes `seq` aRes ++ bRes -createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int +instance Monoid (ActionProvider be) where + mempty = ActionProvider (\_ _ -> []) + +createSchemaWeight, dropSchemaWeight, createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int +createSchemaWeight = 1000 +dropSchemaWeight = 100 createTableWeight = 500 dropTableWeight = 100 addColumnWeight = 1 @@ -285,6 +287,56 @@ justOne_ [x] = [x] justOne_ _ = [] + +-- IsSql92CreateTableSyntax + +-- | Action provider for SQL92 @CREATE SCHEMA@ actions. +createSchemaActionProvider :: forall be + . ( Typeable be, BeamMigrateOnlySqlSchemaBackend be ) + => ActionProvider be +createSchemaActionProvider = + ActionProvider provider + where + provider :: ActionProviderFn be + provider findPreConditions findPostConditions = + do schemaP@(SchemaExistsPredicate postSchemaName) <- findPostConditions + -- Make sure there's no corresponding predicate in the precondition + ensuringNot_ $ + do SchemaExistsPredicate preSchemaName <- findPreConditions + guard (preSchemaName == postSchemaName) + + let postConditions = [ p schemaP ] + cmd = createSchemaCmd (createSchemaSyntax (schemaName postSchemaName)) + pure (PotentialAction mempty (HS.fromList postConditions) + (Seq.singleton (MigrationCommand cmd MigrationKeepsData)) + ("Create the schema " <> postSchemaName) createSchemaWeight) + +-- | Action provider for SQL92 @DROP SCHEMA@ actions +dropSchemaActionProvider :: forall be + . BeamMigrateOnlySqlSchemaBackend be + => ActionProvider be +dropSchemaActionProvider = + ActionProvider provider + where + -- Look for tables that exist as a precondition but not a post condition + provider :: ActionProviderFn be + provider findPreConditions findPostConditions = + do schemaP@(SchemaExistsPredicate preSchemaNm) <- findPreConditions + ensuringNot_ $ + do SchemaExistsPredicate postSchemaNm <- findPostConditions + guard (preSchemaNm == postSchemaNm) + + relatedPreds <- + pure $ do p'@(SomeDatabasePredicate pred') <- findPreConditions + guard (pred' `predicateCascadesDropOn` schemaP) + pure p' + + -- Now, collect all preconditions that may be related to the dropped table + let cmd = dropSchemaCmd (dropSchemaSyntax (schemaName preSchemaNm)) + pure (PotentialAction (HS.fromList (SomeDatabasePredicate schemaP:relatedPreds)) mempty + (Seq.singleton (MigrationCommand cmd MigrationLosesData)) + ("Drop schema " <> preSchemaNm) dropSchemaWeight) + -- | Action provider for SQL92 @CREATE TABLE@ actions. createTableActionProvider :: forall be . ( Typeable be, BeamMigrateOnlySqlBackend be ) @@ -476,6 +528,8 @@ -- * ALTER TABLE ... ADD COLUMN ... -- * ALTER TABLE ... DROP COLUMN ... -- * ALTER TABLE ... ALTER COLUMN ... SET [NOT] NULL +-- +-- For default schema actions, see 'defaultSchemaActionProvider'. defaultActionProvider :: ( Typeable be , BeamMigrateOnlySqlBackend be ) => ActionProvider be @@ -488,7 +542,20 @@ , dropColumnProvider , addColumnNullProvider - , dropColumnNullProvider ] + , dropColumnNullProvider + ] + +-- | Default action providers for any syntax which supports schemas. +-- +-- In particular, this provides edges consisting of the following statements: +-- +-- * CREATE SCHEMA +-- * DROP SCHEMA +defaultSchemaActionProvider :: ( Typeable be + , BeamMigrateOnlySqlSchemaBackend be ) + => ActionProvider be +defaultSchemaActionProvider + = createSchemaActionProvider <> dropSchemaActionProvider -- | Represents current state of a database graph search. -- 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 @@ -7,8 +7,6 @@ -- -- 1. Ensure the command syntax for your backend satisfies 'Sql92SaneDdlCommandSyntax'. -- 2. Create a value of type 'BeamMigrationBackend' --- 3. For compatibility with @beam-migrate-cli@, export this value in an --- exposed module with the name 'migrationBackend'. -- -- This may sound trivial, but it's a bit more involved. In particular, in order -- to complete step 2, you will have to define several instances for some of @@ -24,8 +22,7 @@ -- -- 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. +-- type. -- -- For an example migrate backend, see "Database.Beam.Sqlite.Migrate" module Database.Beam.Migrate.Backend @@ -116,15 +113,14 @@ = HaskellPredicateConverter (SomeDatabasePredicate -> Maybe SomeDatabasePredicate) instance Semigroup HaskellPredicateConverter where - (<>) = mappend + (HaskellPredicateConverter a) <> (HaskellPredicateConverter b) = + HaskellPredicateConverter $ \r -> a r <|> b r -- | 'HaskellPredicateConverter's can be combined monoidally. instance Monoid HaskellPredicateConverter where mempty = HaskellPredicateConverter $ \_ -> Nothing - mappend (HaskellPredicateConverter a) (HaskellPredicateConverter b) = - HaskellPredicateConverter $ \r -> a r <|> b r --- | Converters for the 'TableExistsPredicate', 'TableHasPrimaryKey', and +-- | Converters for the 'SchemaExistsPredicate', 'TableExistsPredicate', 'TableHasPrimaryKey', and -- 'TableHasColumn' (when supplied with a function to convert a backend data -- type to a haskell one). sql92HsPredicateConverters :: forall fromBe @@ -132,6 +128,7 @@ => (BeamMigrateSqlBackendDataTypeSyntax fromBe -> Maybe HsDataType) -> HaskellPredicateConverter sql92HsPredicateConverters convType = + trivialHsConverter @SchemaExistsPredicate <> trivialHsConverter @TableExistsPredicate <> trivialHsConverter @TableHasPrimaryKey <> hasColumnConverter @fromBe convType diff --git a/Database/Beam/Migrate/Checks.hs b/Database/Beam/Migrate/Checks.hs --- a/Database/Beam/Migrate/Checks.hs +++ b/Database/Beam/Migrate/Checks.hs @@ -22,6 +22,21 @@ import GHC.Generics (Generic) +-- * Schema checks + +-- | Asserts that a schema with the given name exists in a database +data SchemaExistsPredicate = SchemaExistsPredicate Text {-^ Table name -} + deriving (Show, Eq, Ord, Typeable, Generic) +instance Hashable SchemaExistsPredicate +instance DatabasePredicate SchemaExistsPredicate where + englishDescription (SchemaExistsPredicate s) = + "Schema " <> show s <> " must exist" + + serializePredicate (SchemaExistsPredicate s) = + object [ "schema-exists" .= s ] + + predicateSpecificity _ = PredicateSpecificityAllBackends + -- * Table checks -- | Asserts that a table with the given name exists in a database @@ -131,12 +146,18 @@ , HasDataTypeCreatedCheck (BeamMigrateSqlBackendDataTypeSyntax be) ) => BeamDeserializers be beamCheckDeserializers = mconcat - [ beamDeserializer (const deserializeTableExistsPredicate) + [ beamDeserializer (const deserializeSchemaExistsPredicate) + , beamDeserializer (const deserializeTableExistsPredicate) , beamDeserializer (const deserializeTableHasPrimaryKeyPredicate) , beamDeserializer deserializeTableHasColumnPredicate , beamDeserializer deserializeTableColumnHasConstraintPredicate ] where + deserializeSchemaExistsPredicate :: Value -> Parser SomeDatabasePredicate + deserializeSchemaExistsPredicate = + withObject "SchemaExistsPredicate" $ \v -> + SomeDatabasePredicate <$> (SchemaExistsPredicate <$> v .: "schema-exists") + deserializeTableExistsPredicate :: Value -> Parser SomeDatabasePredicate deserializeTableExistsPredicate = withObject "TableExistPredicate" $ \v -> 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 @@ -23,6 +23,7 @@ import Control.Applicative (Const(..)) +import Data.Kind (Type) import Data.Proxy import Data.Text (Text) import Data.Scientific (Scientific) @@ -34,7 +35,7 @@ import GHC.Generics import GHC.TypeLits -class BeamMigrateSqlBackend be => GMigratableTableSettings be (i :: * -> *) fieldCheck where +class BeamMigrateSqlBackend be => GMigratableTableSettings be (i :: Type -> Type) fieldCheck where gDefaultTblSettingsChecks :: Proxy be -> Proxy i -> Bool -> fieldCheck () instance (BeamMigrateSqlBackend be, GMigratableTableSettings be xId fieldCheckId) => @@ -81,7 +82,7 @@ -- * Nullability check -type family NullableStatus (x :: *) :: Bool where +type family NullableStatus (x :: Type) :: Bool where NullableStatus (Maybe x) = 'True NullableStatus x = 'False diff --git a/Database/Beam/Migrate/Log.hs b/Database/Beam/Migrate/Log.hs --- a/Database/Beam/Migrate/Log.hs +++ b/Database/Beam/Migrate/Log.hs @@ -1,5 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} --- | Contains a schema for beam migration tools. Used by the CLI and +-- | Contains a schema for beam migration tools. Used by -- the managed migrations support here. module Database.Beam.Migrate.Log where diff --git a/Database/Beam/Migrate/SQL/Builder.hs b/Database/Beam/Migrate/SQL/Builder.hs --- a/Database/Beam/Migrate/SQL/Builder.hs +++ b/Database/Beam/Migrate/SQL/Builder.hs @@ -28,6 +28,13 @@ SqlSyntaxBuilder deriving Eq +instance IsSql92DdlSchemaCommandSyntax SqlSyntaxBuilder where + type Sql92DdlCommandCreateSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + type Sql92DdlCommandDropSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + + createSchemaCmd = id + dropSchemaCmd = id + instance IsSql92DdlCommandSyntax SqlSyntaxBuilder where type Sql92DdlCommandCreateTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92DdlCommandDropTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder @@ -77,6 +84,18 @@ setNotNullSyntax = SqlSyntaxBuilder (byteString "SET NOT NULL") setNullSyntax = SqlSyntaxBuilder (byteString "DROP NOT NULL") +instance IsSql92CreateSchemaSyntax SqlSyntaxBuilder where + type Sql92CreateSchemaSchemaNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + createSchemaSyntax schName = + SqlSyntaxBuilder $ + byteString "CREATE SCHEMA " <> buildSql schName + +instance IsSql92DropSchemaSyntax SqlSyntaxBuilder where + type Sql92DropSchemaSchemaNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + dropSchemaSyntax schName = + SqlSyntaxBuilder $ + byteString "DROP SCHEMA " <> buildSql schName + instance IsSql92CreateTableSyntax SqlSyntaxBuilder where type Sql92CreateTableTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92CreateTableColumnSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder @@ -123,14 +142,13 @@ deriving (Show, Eq) instance Semigroup SqlConstraintAttributesBuilder where - (<>) = mappend - -instance Monoid SqlConstraintAttributesBuilder where - mempty = SqlConstraintAttributesBuilder Nothing Nothing - mappend a b = + a <> b = SqlConstraintAttributesBuilder (_sqlConstraintAttributeTiming b <|> _sqlConstraintAttributeTiming a) (_sqlConstraintAttributeDeferrable b <|> _sqlConstraintAttributeDeferrable a) + +instance Monoid SqlConstraintAttributesBuilder where + mempty = SqlConstraintAttributesBuilder Nothing Nothing -- | Convert a 'SqlConstraintAttributesBuilder' to its @SQL92@ representation in -- the returned 'ByteString' 'Builder'. 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 @@ -12,6 +12,7 @@ import Data.Aeson (Value) import Data.Hashable +import Data.Kind (Type) import Data.Text (Text) import Data.Typeable #if ! MIN_VERSION_base(4,11,0) @@ -29,6 +30,15 @@ , Sql92ColumnSchemaExpressionSyntax (Sql92DdlCommandColumnSchemaSyntax cmd) ~ Sql92ExpressionSyntax cmd ) +-- | Syntax equalities that any reasonable DDL syntax with schema support would follow, +-- including equalities between beam-migrate and beam-core types. +type Sql92SaneDdlSchemaCommandSyntax cmd = + ( Sql92SaneDdlSchemaCommandSyntaxMigrateOnly cmd + , Sql92ExpressionCastTargetSyntax (Sql92ExpressionSyntax cmd) ~ + Sql92DdlCommandDataTypeSyntax cmd + , Sql92ColumnSchemaExpressionSyntax (Sql92DdlCommandColumnSchemaSyntax cmd) ~ + Sql92ExpressionSyntax cmd ) + -- | Syntax equalities for any reasonable DDL syntax, only including -- types defined here. type Sql92SaneDdlCommandSyntaxMigrateOnly cmd = @@ -41,6 +51,13 @@ Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax cmd) ) +-- | Syntax equalities for any reasonable DDL syntax, only including +-- types defined here. +type Sql92SaneDdlSchemaCommandSyntaxMigrateOnly cmd = + ( Sql92SaneDdlCommandSyntaxMigrateOnly cmd + , IsSql92DdlSchemaCommandSyntax cmd + ) + type Sql92DdlCommandDataTypeSyntax syntax = Sql92ColumnSchemaColumnTypeSyntax (Sql92DdlCommandColumnSchemaSyntax syntax) type Sql92DdlCommandColumnSchemaSyntax syntax = Sql92CreateTableColumnSchemaSyntax (Sql92DdlCommandCreateTableSyntax syntax) @@ -59,27 +76,54 @@ type Sql92DdlCommandAlterTableActionSyntax syntax = Sql92AlterTableAlterTableActionSyntax (Sql92DdlCommandAlterTableSyntax syntax) +-- Creation/deletion of schemas isn't supported by all backends (e.g. sqlite) +-- and therefore is considered separately from other DDL commands such as CREATE TABLE +class ( IsSql92CreateSchemaSyntax (Sql92DdlCommandCreateSchemaSyntax syntax) + , IsSql92DropSchemaSyntax (Sql92DdlCommandDropSchemaSyntax syntax)) => + IsSql92DdlSchemaCommandSyntax syntax where + type Sql92DdlCommandCreateSchemaSyntax syntax :: Type + type Sql92DdlCommandDropSchemaSyntax syntax :: Type + + createSchemaCmd :: Sql92DdlCommandCreateSchemaSyntax syntax -> syntax + dropSchemaCmd :: Sql92DdlCommandDropSchemaSyntax syntax -> syntax + class ( IsSql92CreateTableSyntax (Sql92DdlCommandCreateTableSyntax syntax) , IsSql92DropTableSyntax (Sql92DdlCommandDropTableSyntax syntax) , IsSql92AlterTableSyntax (Sql92DdlCommandAlterTableSyntax syntax)) => IsSql92DdlCommandSyntax syntax where - type Sql92DdlCommandCreateTableSyntax syntax :: * - type Sql92DdlCommandAlterTableSyntax syntax :: * - type Sql92DdlCommandDropTableSyntax syntax :: * + type Sql92DdlCommandCreateTableSyntax syntax :: Type + type Sql92DdlCommandAlterTableSyntax syntax :: Type + type Sql92DdlCommandDropTableSyntax syntax :: Type - createTableCmd :: Sql92DdlCommandCreateTableSyntax syntax -> syntax - dropTableCmd :: Sql92DdlCommandDropTableSyntax syntax -> syntax - alterTableCmd :: Sql92DdlCommandAlterTableSyntax syntax -> syntax + createTableCmd :: Sql92DdlCommandCreateTableSyntax syntax -> syntax + dropTableCmd :: Sql92DdlCommandDropTableSyntax syntax -> syntax + alterTableCmd :: Sql92DdlCommandAlterTableSyntax syntax -> syntax +class IsSql92SchemaNameSyntax (Sql92CreateSchemaSchemaNameSyntax syntax) => + IsSql92CreateSchemaSyntax syntax where + + type Sql92CreateSchemaSchemaNameSyntax syntax :: Type + + createSchemaSyntax :: Sql92CreateSchemaSchemaNameSyntax syntax + -> syntax + +class IsSql92SchemaNameSyntax (Sql92DropSchemaSchemaNameSyntax syntax) => + IsSql92DropSchemaSyntax syntax where + + type Sql92DropSchemaSchemaNameSyntax syntax :: Type + + dropSchemaSyntax :: Sql92DropSchemaSchemaNameSyntax syntax + -> syntax + class ( IsSql92TableConstraintSyntax (Sql92CreateTableTableConstraintSyntax syntax) , IsSql92ColumnSchemaSyntax (Sql92CreateTableColumnSchemaSyntax syntax) , IsSql92TableNameSyntax (Sql92CreateTableTableNameSyntax syntax) ) => IsSql92CreateTableSyntax syntax where - type Sql92CreateTableTableNameSyntax syntax :: * - type Sql92CreateTableColumnSchemaSyntax syntax :: * - type Sql92CreateTableTableConstraintSyntax syntax :: * - type Sql92CreateTableOptionsSyntax syntax :: * + type Sql92CreateTableTableNameSyntax syntax :: Type + type Sql92CreateTableColumnSchemaSyntax syntax :: Type + type Sql92CreateTableTableConstraintSyntax syntax :: Type + type Sql92CreateTableOptionsSyntax syntax :: Type createTableSyntax :: Maybe (Sql92CreateTableOptionsSyntax syntax) -> Sql92CreateTableTableNameSyntax syntax @@ -90,15 +134,15 @@ class IsSql92TableNameSyntax (Sql92DropTableTableNameSyntax syntax) => IsSql92DropTableSyntax syntax where - type Sql92DropTableTableNameSyntax syntax :: * + type Sql92DropTableTableNameSyntax syntax :: Type dropTableSyntax :: Sql92DropTableTableNameSyntax syntax -> syntax class ( IsSql92TableNameSyntax (Sql92AlterTableTableNameSyntax syntax), IsSql92AlterTableActionSyntax (Sql92AlterTableAlterTableActionSyntax syntax) ) => IsSql92AlterTableSyntax syntax where - type Sql92AlterTableTableNameSyntax syntax :: * - type Sql92AlterTableAlterTableActionSyntax syntax :: * + type Sql92AlterTableTableNameSyntax syntax :: Type + type Sql92AlterTableAlterTableActionSyntax syntax :: Type alterTableSyntax :: Sql92AlterTableTableNameSyntax syntax -> Sql92AlterTableAlterTableActionSyntax syntax -> syntax @@ -106,8 +150,8 @@ class ( IsSql92ColumnSchemaSyntax (Sql92AlterTableColumnSchemaSyntax syntax) , IsSql92AlterColumnActionSyntax (Sql92AlterTableAlterColumnActionSyntax syntax) ) => IsSql92AlterTableActionSyntax syntax where - type Sql92AlterTableAlterColumnActionSyntax syntax :: * - type Sql92AlterTableColumnSchemaSyntax syntax :: * + type Sql92AlterTableAlterColumnActionSyntax syntax :: Type + type Sql92AlterTableColumnSchemaSyntax syntax :: Type alterColumnSyntax :: Text -> Sql92AlterTableAlterColumnActionSyntax syntax -> syntax addColumnSyntax :: Text -> Sql92AlterTableColumnSchemaSyntax syntax -> syntax @@ -130,9 +174,9 @@ , IsSql92ExpressionSyntax (Sql92ColumnSchemaExpressionSyntax columnSchema) , Typeable columnSchema, Sql92DisplaySyntax columnSchema, Eq columnSchema, Hashable columnSchema ) => IsSql92ColumnSchemaSyntax columnSchema where - type Sql92ColumnSchemaColumnTypeSyntax columnSchema :: * - type Sql92ColumnSchemaExpressionSyntax columnSchema :: * - type Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema :: * + type Sql92ColumnSchemaColumnTypeSyntax columnSchema :: Type + type Sql92ColumnSchemaExpressionSyntax columnSchema :: Type + type Sql92ColumnSchemaColumnConstraintDefinitionSyntax columnSchema :: Type columnSchemaSyntax :: Sql92ColumnSchemaColumnTypeSyntax columnSchema {-^ Column type -} -> Maybe (Sql92ColumnSchemaExpressionSyntax columnSchema) {-^ Default value -} @@ -157,8 +201,8 @@ , IsSql92ConstraintAttributesSyntax (Sql92ColumnConstraintDefinitionAttributesSyntax constraint) , Typeable constraint ) => IsSql92ColumnConstraintDefinitionSyntax constraint where - type Sql92ColumnConstraintDefinitionConstraintSyntax constraint :: * - type Sql92ColumnConstraintDefinitionAttributesSyntax constraint :: * + type Sql92ColumnConstraintDefinitionConstraintSyntax constraint :: Type + type Sql92ColumnConstraintDefinitionAttributesSyntax constraint :: Type constraintDefinitionSyntax :: Maybe Text -> Sql92ColumnConstraintDefinitionConstraintSyntax constraint -> Maybe (Sql92ColumnConstraintDefinitionAttributesSyntax constraint) @@ -175,9 +219,9 @@ , Typeable (Sql92ColumnConstraintExpressionSyntax constraint) , Typeable constraint ) => IsSql92ColumnConstraintSyntax constraint where - type Sql92ColumnConstraintMatchTypeSyntax constraint :: * - type Sql92ColumnConstraintReferentialActionSyntax constraint :: * - type Sql92ColumnConstraintExpressionSyntax constraint :: * + type Sql92ColumnConstraintMatchTypeSyntax constraint :: Type + type Sql92ColumnConstraintReferentialActionSyntax constraint :: Type + type Sql92ColumnConstraintExpressionSyntax constraint :: Type notNullConstraintSyntax :: constraint uniqueColumnConstraintSyntax :: constraint 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 @@ -8,7 +8,8 @@ ( -- * Table manipulation -- ** Creation and deletion - createTable, dropTable + createTable, createTableWithSchema + , dropTable , preserve -- ** @ALTER TABLE@ @@ -19,6 +20,9 @@ , renameTableTo, renameColumnTo , addColumn, dropColumn + -- * Schema manipulation + , createDatabaseSchema, dropDatabaseSchema, existingDatabaseSchema + -- * Field specification , DefaultValue, Constraint(..), NotNullConstraint @@ -49,6 +53,9 @@ import Control.Monad.Writer.Strict import Control.Monad.State +import Data.Coerce (coerce) +import Data.Kind (Type) +import Data.String (IsString) import Data.Text (Text) import Data.Typeable import qualified Data.Kind as Kind (Constraint) @@ -64,16 +71,70 @@ -- The first argument is the name of the table. -- -- The second argument is a table containing a 'FieldSchema' for each field. --- See documentation on the 'Field' command for more information.c +-- See documentation on the 'Field' command for more information. +-- +-- To create a table in a specific schema, see 'createTableWithSchema'. createTable :: ( Beamable table, Table table , BeamMigrateSqlBackend be ) => Text -> TableSchema be table -> Migration be (CheckedDatabaseEntity be db (TableEntity table)) -createTable newTblName tblSettings = +createTable = createTableWithSchema Nothing + +-- * Schema manipulation + +-- | Represents a database schema. To create one, see 'createDatabaseSchema'. +newtype DatabaseSchema + = MkDatabaseSchema Text + deriving (Eq, Show, IsString) + +-- | Add a @CREATE SCHEMA@ statement to this migration +-- +-- To create a table in a specific schema, see 'createTableWithSchema'. +-- To drop a schema, see 'dropDatabaseSchema'. +-- To materialize an existing schema for use in a migration, see 'existingDatabaseSchema'. +createDatabaseSchema :: BeamMigrateSchemaSqlBackend be + => Text + -> Migration be DatabaseSchema +createDatabaseSchema nm = do + upDown (createSchemaCmd (createSchemaSyntax (schemaName nm))) Nothing + pure $ MkDatabaseSchema nm + +-- | Add a @DROP SCHEMA@ statement to this migration. +-- +-- Depending on the backend, this may fail if the schema is not empty. +-- +-- To create a schema, see 'createDatabaseSchema'. +-- To materialize a 'DatabaseSchema', see 'existingDatabaseSchema +dropDatabaseSchema :: BeamMigrateSchemaSqlBackend be + => DatabaseSchema + -> Migration be () +dropDatabaseSchema (MkDatabaseSchema nm) + = upDown (dropSchemaCmd (dropSchemaSyntax (schemaName nm))) Nothing + +-- | Materialize a schema for use during a migration (for example, to drop it). +existingDatabaseSchema :: Text -> Migration be DatabaseSchema +existingDatabaseSchema = pure . MkDatabaseSchema + +-- | Add a @CREATE TABLE@ statement to this migration, with an explicit schema +-- +-- The first argument is the name of the schema, while the second argument is the name of the table. +-- +-- The second argument is a table containing a 'FieldSchema' for each field. +-- See documentation on the 'Field' command for more information. +-- +-- Note that the database schema is expected to exist; see 'createDatabaseSchema' to create +-- a database schema. +createTableWithSchema :: ( Beamable table, Table table + , BeamMigrateSqlBackend be ) + => Maybe DatabaseSchema -- ^ Schema name, if any + -> Text -- ^ Table name + -> TableSchema be table + -> Migration be (CheckedDatabaseEntity be db (TableEntity table)) +createTableWithSchema maybeSchemaName newTblName tblSettings = do let pkFields = allBeamValues (\(Columnar' (TableFieldSchema name _ _)) -> name) (primaryKey tblSettings) tblConstraints = if null pkFields then [] else [ primaryKeyConstraintSyntax pkFields ] createTableCommand = - createTableSyntax Nothing (tableName Nothing newTblName) + createTableSyntax Nothing (tableName (coerce <$> maybeSchemaName) newTblName) (allBeamValues (\(Columnar' (TableFieldSchema name (FieldSchema schema) _)) -> (name, schema)) tblSettings) tblConstraints command = createTableCmd createTableCommand @@ -81,7 +142,7 @@ tbl' = changeBeamRep (\(Columnar' (TableFieldSchema name _ _)) -> Columnar' (TableField (pure name) name)) tblSettings fieldChecks = changeBeamRep (\(Columnar' (TableFieldSchema _ _ cs)) -> Columnar' (Const cs)) tblSettings - + tblChecks = [ TableCheck (\tblName _ -> Just (SomeDatabasePredicate (TableExistsPredicate tblName))) ] ++ primaryKeyCheck @@ -89,9 +150,22 @@ case allBeamValues (\(Columnar' (TableFieldSchema name _ _)) -> name) (primaryKey tblSettings) of [] -> [] cols -> [ TableCheck (\tblName _ -> Just (SomeDatabasePredicate (TableHasPrimaryKey tblName cols))) ] + + -- If a schema has been defined explicitly, then it should be part of checks + schemaCheck = + case maybeSchemaName of + Nothing -> [] + Just (MkDatabaseSchema sn) -> [ SomeDatabasePredicate (SchemaExistsPredicate sn) ] upDown command Nothing - pure (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable Nothing newTblName newTblName tbl') tblChecks fieldChecks) []) + pure (CheckedDatabaseEntity + (CheckedDatabaseTable + (DatabaseTable (coerce <$> maybeSchemaName) newTblName newTblName tbl') + tblChecks + fieldChecks + ) + schemaCheck + ) -- | Add a @DROP TABLE@ statement to this migration. dropTable :: BeamMigrateSqlBackend be @@ -332,7 +406,7 @@ where checks = [ FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableHasColumn tbl field'' ty :: TableHasColumn be)) ] ++ map (\cns -> FieldCheck (\tbl field'' -> SomeDatabasePredicate (TableColumnHasConstraint tbl field'' cns :: TableColumnHasConstraint be))) constraints -type family IsNotNull (x :: *) :: Kind.Constraint where +type family IsNotNull (x :: Type) :: 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") diff --git a/Database/Beam/Migrate/SQL/Types.hs b/Database/Beam/Migrate/SQL/Types.hs --- a/Database/Beam/Migrate/SQL/Types.hs +++ b/Database/Beam/Migrate/SQL/Types.hs @@ -6,7 +6,9 @@ , FieldSchema(..) , BeamMigrateOnlySqlBackend + , BeamMigrateOnlySqlSchemaBackend , BeamMigrateSqlBackend + , BeamMigrateSchemaSqlBackend , BeamMigrateSql99Backend , BeamSqlBackendConstraintSyntax , BeamSqlBackendColumnConstraintDefinitionSyntax @@ -53,9 +55,20 @@ , Typeable be ) => BeamMigrateOnlySqlBackend be +type BeamMigrateOnlySqlSchemaBackend be + = ( BeamMigrateOnlySqlBackend be + , IsSql92DdlSchemaCommandSyntax (BeamSqlBackendSyntax be) + , Sql92SaneDdlSchemaCommandSyntaxMigrateOnly (BeamSqlBackendSyntax be) + ) + type BeamMigrateSqlBackend be = ( BeamMigrateOnlySqlBackend be , Sql92SaneDdlCommandSyntax (BeamSqlBackendSyntax be) + , BeamSqlBackend be ) + +type BeamMigrateSchemaSqlBackend be = + ( BeamMigrateOnlySqlSchemaBackend be + , Sql92SaneDdlSchemaCommandSyntax (BeamSqlBackendSyntax be) , BeamSqlBackend be ) type BeamMigrateSql99Backend be = diff --git a/Database/Beam/Migrate/Serialization.hs b/Database/Beam/Migrate/Serialization.hs --- a/Database/Beam/Migrate/Serialization.hs +++ b/Database/Beam/Migrate/Serialization.hs @@ -246,21 +246,19 @@ } instance Semigroup (BeamDeserializer be) where - (<>) = mappend + (BeamDeserializer a) <> (BeamDeserializer b) = + BeamDeserializer $ \d o -> + a d o <|> b d o instance Monoid (BeamDeserializer be) where mempty = BeamDeserializer (const (const mzero)) - mappend (BeamDeserializer a) (BeamDeserializer b) = - BeamDeserializer $ \d o -> - a d o <|> b d o instance Semigroup (BeamDeserializers be) where - (<>) = mappend + (BeamDeserializers a) <> (BeamDeserializers b) = + BeamDeserializers (D.unionWithKey (const mappend) a b) instance Monoid (BeamDeserializers be) where mempty = BeamDeserializers mempty - mappend (BeamDeserializers a) (BeamDeserializers b) = - BeamDeserializers (D.unionWithKey (const mappend) a b) -- | Helper function to deserialize data from a 'Maybe' 'Value'. -- 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 @@ -98,13 +98,13 @@ deriving Show instance Semigroup MigrationDataLoss where - (<>) = mappend + MigrationLosesData <> _ = MigrationLosesData + _ <> MigrationLosesData = MigrationLosesData + MigrationKeepsData <> MigrationKeepsData = MigrationKeepsData instance Monoid MigrationDataLoss where mempty = MigrationKeepsData - mappend MigrationLosesData _ = MigrationLosesData - mappend _ MigrationLosesData = MigrationLosesData - mappend MigrationKeepsData MigrationKeepsData = MigrationKeepsData + -- | A migration command along with metadata on whether the command can lose data data MigrationCommand be 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 @@ -15,13 +15,13 @@ import Control.Monad.Writer import Control.Monad.Identity +import Data.Kind (Constraint, Type) import Data.Maybe import Data.Monoid import Data.Proxy import Data.Text (Text) import Data.String -import GHC.Types import GHC.Generics import Lens.Micro (Lens', (&), (^.), (.~), (%~)) @@ -36,7 +36,7 @@ -- | The type of the descriptor for this checked entity. Usually this wraps -- the corresponding 'DatabaseEntityDescriptor' from 'IsDatabaseEntity', along -- with some mechanism for generating 'DatabasePredicate's. - data CheckedDatabaseEntityDescriptor be entity :: * + data CheckedDatabaseEntityDescriptor be entity :: Type -- | Like 'DatabaseEntityDefaultRequirements' but for checked entities type CheckedDatabaseEntityDefaultRequirements be entity :: Constraint @@ -57,7 +57,7 @@ => Text -> CheckedDatabaseEntityDescriptor be entity -- | Like 'DatabaseEntity' but for checked databases -data CheckedDatabaseEntity be (db :: (* -> *) -> *) entityType where +data CheckedDatabaseEntity be (db :: (Type -> Type) -> Type) entityType where CheckedDatabaseEntity :: IsCheckedDatabaseEntity be entityType => CheckedDatabaseEntityDescriptor be entityType -> [ SomeDatabasePredicate ] diff --git a/beam-migrate.cabal b/beam-migrate.cabal --- a/beam-migrate.cabal +++ b/beam-migrate.cabal @@ -1,5 +1,5 @@ name: beam-migrate -version: 0.5.2.1 +version: 0.5.3.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 @@ -13,12 +13,6 @@ library is used to write tooling to support DDL manipulation in your project, or to enable migrations support in beam backends. - For a more turnkey solution for database migrations, consider - the - command line tool. This provides out-of-the-box support for migrations, - schema change management, and version control, based on the features - provided in this library. - homepage: https://travis.athougies.net/projects/beam.html license: MIT license-file: LICENSE @@ -61,27 +55,26 @@ build-depends: base >=4.9 && <5.0, beam-core >=0.10 && <0.11, - text >=1.2 && <2.1, - aeson >=0.11 && <2.2, - bytestring >=0.10 && <0.12, + text >=1.2 && <2.2, + aeson >=0.11 && <2.3, + bytestring >=0.10 && <0.13, free >=4.12 && <5.3, time >=1.6 && <1.13, mtl >=2.2 && <2.4, scientific >=0.3 && <0.4, vector >=0.11 && <0.14, - containers >=0.5 && <0.7, + containers >=0.5 && <0.8, unordered-containers >=0.2 && <0.3, hashable >=1.2 && <1.5, microlens >=0.4 && <0.5, parallel >=3.2 && <3.3, - deepseq >=1.4 && <1.5, - ghc-prim >=0.5 && <0.11, - containers >=0.5 && <0.7, + deepseq >=1.4 && <1.7, + ghc-prim >=0.5 && <0.12, haskell-src-exts >=1.18 && <1.24, pretty >=1.1 && <1.2, dependent-map >=0.2 && <0.5, dependent-sum >=0.4 && <0.8, - pqueue >=1.3 && <1.5, + pqueue >=1.3 && <1.6, uuid-types >=1.0 && <1.1 default-language: Haskell2010 default-extensions: KindSignatures, OverloadedStrings, TypeFamilies, FlexibleContexts,