Added support for dropping schemas

beam-migrate/ChangeLog.md

@@ -2,7 +2,7 @@
 
 ## Added features
 
-* Added support for creating database schemas and associated tables with `createDatabaseSchema` and `createTableWithSchema` (#716).
+* 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
 

beam-migrate/Database/Beam/Haskell/Syntax.hs

@@ -440,11 +440,13 @@ hsTableTypeName = hsMkTableName toUpper
 
 instance IsSql92DdlCommandSyntax HsAction where
   type Sql92DdlCommandCreateSchemaSyntax HsAction = HsAction
+  type Sql92DdlCommandDropSchemaSyntax HsAction = HsAction
   type Sql92DdlCommandCreateTableSyntax HsAction = HsAction
   type Sql92DdlCommandAlterTableSyntax HsAction = HsAction
   type Sql92DdlCommandDropTableSyntax HsAction = HsAction
 
   createSchemaCmd = id
+  dropSchemaCmd = id
   createTableCmd = id
   dropTableCmd = id
   alterTableCmd = id
@@ -480,7 +482,15 @@ instance IsSql92CreateSchemaSyntax HsAction where
   type Sql92CreateSchemaSchemaNameSyntax HsAction = SchemaName
   createSchemaSyntax (SchemaName nm) = HsAction [ (Nothing, createSchema) ] []
     where
-      createSchema = hsApp (hsVar "createSchema") [ hsVar nm ]
+      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

beam-migrate/Database/Beam/Migrate/Actions.hs

@@ -266,8 +266,9 @@ instance Semigroup (ActionProvider be) where
 instance Monoid (ActionProvider be) where
   mempty = ActionProvider (\_ _ -> [])
 
-createSchemaWeight, createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int
+createSchemaWeight, dropSchemaWeight, createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int
 createSchemaWeight = 1000
+dropSchemaWeight = 100
 createTableWeight = 500
 dropTableWeight = 100
 addColumnWeight = 1
@@ -309,6 +310,32 @@ createSchemaActionProvider =
                                (Seq.singleton (MigrationCommand cmd MigrationKeepsData))
                                ("Create the schema " <> postSchemaName) createSchemaWeight)
 
+-- | Action provider for SQL92 @DROP SCHEMA@ actions
+dropSchemaActionProvider :: forall be
+                         . BeamMigrateOnlySqlBackend 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 )
@@ -507,6 +534,7 @@ defaultActionProvider :: ( Typeable be
 defaultActionProvider =
   mconcat
   [ createSchemaActionProvider
+  , dropSchemaActionProvider
 
   , createTableActionProvider
   , dropTableActionProvider

beam-migrate/Database/Beam/Migrate/SQL/Builder.hs

@@ -30,10 +30,12 @@ data SqlSyntaxBuilderCreateTableOptions
 
 instance IsSql92DdlCommandSyntax SqlSyntaxBuilder where
   type Sql92DdlCommandCreateSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
+  type Sql92DdlCommandDropSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
   type Sql92DdlCommandCreateTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
   type Sql92DdlCommandDropTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
   type Sql92DdlCommandAlterTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder
   createSchemaCmd = id
+  dropSchemaCmd = id
   createTableCmd = id
   alterTableCmd = id
   dropTableCmd = id
@@ -85,6 +87,12 @@ instance IsSql92CreateSchemaSyntax SqlSyntaxBuilder where
       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

beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs

@@ -61,16 +61,19 @@ type Sql92DdlCommandAlterTableActionSyntax syntax =
   Sql92AlterTableAlterTableActionSyntax (Sql92DdlCommandAlterTableSyntax syntax)
 
 class ( IsSql92CreateSchemaSyntax (Sql92DdlCommandCreateSchemaSyntax syntax)
+      , IsSql92DropSchemaSyntax (Sql92DdlCommandDropSchemaSyntax syntax)
       , IsSql92CreateTableSyntax (Sql92DdlCommandCreateTableSyntax syntax)
       , IsSql92DropTableSyntax (Sql92DdlCommandDropTableSyntax syntax)
       , IsSql92AlterTableSyntax (Sql92DdlCommandAlterTableSyntax syntax)) =>
   IsSql92DdlCommandSyntax syntax where
   type Sql92DdlCommandCreateSchemaSyntax syntax :: Type
+  type Sql92DdlCommandDropSchemaSyntax syntax :: Type
   type Sql92DdlCommandCreateTableSyntax syntax :: Type
   type Sql92DdlCommandAlterTableSyntax syntax :: Type
   type Sql92DdlCommandDropTableSyntax syntax :: Type
 
   createSchemaCmd :: Sql92DdlCommandCreateSchemaSyntax syntax -> syntax
+  dropSchemaCmd   :: Sql92DdlCommandDropSchemaSyntax syntax -> syntax
   createTableCmd  :: Sql92DdlCommandCreateTableSyntax syntax -> syntax
   dropTableCmd    :: Sql92DdlCommandDropTableSyntax syntax -> syntax
   alterTableCmd   :: Sql92DdlCommandAlterTableSyntax syntax -> syntax
@@ -83,6 +86,14 @@ class IsSql92SchemaNameSyntax (Sql92CreateSchemaSchemaNameSyntax syntax) =>
   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) ) =>

beam-migrate/Database/Beam/Migrate/SQL/Tables.hs

@@ -9,7 +9,7 @@ module Database.Beam.Migrate.SQL.Tables
 
     -- ** Creation and deletion
     createTable, createTableWithSchema 
-  , createDatabaseSchema
+  , createDatabaseSchema, dropDatabaseSchema
   , dropTable
   , preserve
 
@@ -81,12 +81,24 @@ createTable = createTableWithSchema Nothing
 -- | Add a @CREATE SCHEMA@ statement to this migration
 --
 --   To create a table in a specific schema, see 'createTableWithSchema'.
+--   To drop a schema, see 'dropDatabaseSchema'.
 createDatabaseSchema :: BeamMigrateSqlBackend be
                      => Text
                      -> Migration be ()
 createDatabaseSchema nm 
   = upDown (createSchemaCmd (createSchemaSyntax (schemaName nm))) Nothing
 
+-- | 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'.
+dropDatabaseSchema :: BeamMigrateSqlBackend be
+                   => Text
+                   -> Migration be ()
+dropDatabaseSchema nm 
+  = upDown (dropSchemaCmd (dropSchemaSyntax (schemaName nm))) Nothing
+
 -- | 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.

beam-postgres/ChangeLog.md

@@ -3,7 +3,7 @@
 ## Added features
 
  * Better error messages on column type mismatches (#696).
- * Added support for creating database schemas and associated tables with `createDatabaseSchema` and `createTableWithSchema` (#716).
+ * Added support for creating and dropping database schemas and associated tables with `createDatabaseSchema`, `dropDatabaseSchema`, and `createTableWithSchema` (#716).
 
 ## Documentation
 

beam-postgres/Database/Beam/Postgres/Syntax.hs

@@ -337,6 +337,7 @@ instance Hashable PgDataTypeDescr where
     hashWithSalt salt (1 :: Int, t)
 
 newtype PgCreateSchemaSyntax = PgCreateSchemaSyntax { fromPgCreateSchema :: PgSyntax }
+newtype PgDropSchemaSyntax = PgDropSchemaSyntax { fromPgDropSchema :: PgSyntax }
 
 newtype PgCreateTableSyntax = PgCreateTableSyntax { fromPgCreateTable :: PgSyntax }
 data PgTableOptionsSyntax = PgTableOptionsSyntax PgSyntax PgSyntax
@@ -415,11 +416,13 @@ instance IsSql92Syntax PgCommandSyntax where
 
 instance IsSql92DdlCommandSyntax PgCommandSyntax where
   type Sql92DdlCommandCreateSchemaSyntax PgCommandSyntax = PgCreateSchemaSyntax
+  type Sql92DdlCommandDropSchemaSyntax PgCommandSyntax = PgDropSchemaSyntax
   type Sql92DdlCommandCreateTableSyntax PgCommandSyntax = PgCreateTableSyntax
   type Sql92DdlCommandDropTableSyntax PgCommandSyntax = PgDropTableSyntax
   type Sql92DdlCommandAlterTableSyntax PgCommandSyntax = PgAlterTableSyntax
 
   createSchemaCmd = PgCommandSyntax PgCommandTypeDdl . coerce
+  dropSchemaCmd = PgCommandSyntax PgCommandTypeDdl . coerce
   createTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce
   dropTableCmd   = PgCommandSyntax PgCommandTypeDdl . coerce
   alterTableCmd  = PgCommandSyntax PgCommandTypeDdl . coerce
@@ -1052,9 +1055,15 @@ instance IsSql92AlterColumnActionSyntax PgAlterColumnActionSyntax where
 instance IsSql92SchemaNameSyntax PgSchemaNameSyntax => IsSql92CreateSchemaSyntax PgCreateSchemaSyntax where
   type Sql92CreateSchemaSchemaNameSyntax PgCreateSchemaSyntax = PgSchemaNameSyntax
 
-  createSchemaSyntax schemaName =     PgCreateSchemaSyntax $
+  createSchemaSyntax schemaName = PgCreateSchemaSyntax $
     emit "CREATE SCHEMA " <> fromPgSchemaName schemaName
 
+instance IsSql92SchemaNameSyntax PgSchemaNameSyntax => IsSql92DropSchemaSyntax PgDropSchemaSyntax where
+  type Sql92DropSchemaSchemaNameSyntax PgDropSchemaSyntax = PgSchemaNameSyntax
+
+  dropSchemaSyntax schemaName = PgDropSchemaSyntax $
+    emit "DROP SCHEMA " <> fromPgSchemaName schemaName
+
 instance IsSql92CreateTableSyntax PgCreateTableSyntax where
   type Sql92CreateTableTableNameSyntax PgCreateTableSyntax = PgTableNameSyntax
   type Sql92CreateTableColumnSchemaSyntax PgCreateTableSyntax = PgColumnSchemaSyntax

beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module Database.Beam.Postgres.Test.Migrate where
 
 import Database.Beam
@@ -23,6 +24,7 @@ tests postgresConn =
       , charNoWidthVerification postgresConn "CHAR" char
       , extensionVerification postgresConn
       , createTableWithSchemaWorks postgresConn
+      , dropSchemaWorks postgresConn
       ]
 
 data CharT f
@@ -116,3 +118,22 @@ createTableWithSchemaWorks pgConn =
         case res of
           VerificationSucceeded -> return ()
           VerificationFailed failures -> fail ("Verification failed: " ++ show failures)
+
+
+-- | Verifies that creating a schema and dropping it works
+dropSchemaWorks :: IO ByteString -> TestTree
+dropSchemaWorks pgConn =
+    testCase ("dropDatabaseSchema works correctly") $ do
+      withTestPostgres "drop_schema" pgConn $ \conn -> do
+        runBeamPostgres conn $ do
+          db <- executeMigration runNoReturn $ do
+                  createDatabaseSchema "internal_schema"
+                  createDatabaseSchema "will_be_dropped"
+                  db <- (CharDb <$> createTableWithSchema (Just "internal_schema") "char_test"
+                                    (CharT (field "key" (varchar Nothing) notNull)))
+                  dropDatabaseSchema "will_be_dropped"
+                  pure db
+
+          verifySchema migrationBackend db >>= \case
+            VerificationFailed failures -> fail ("Verification failed: " ++ show failures)
+            VerificationSucceeded -> pure ()