From 5f4e8e5ba42dcd007621e91a75f2a611b28c9433 Mon Sep 17 00:00:00 2001 From: Laurent Rene de Cotret Date: Mon, 7 Oct 2024 13:01:08 -0400 Subject: [PATCH] Make use of strong typing in schema manipulation --- .../Database/Beam/Migrate/SQL/Tables.hs | 36 +++++++++++++------ .../Database/Beam/Postgres/Test/Migrate.hs | 12 +++---- 2 files changed, 32 insertions(+), 16 deletions(-) diff --git a/beam-migrate/Database/Beam/Migrate/SQL/Tables.hs b/beam-migrate/Database/Beam/Migrate/SQL/Tables.hs index 849c27f5..94fd427f 100644 --- a/beam-migrate/Database/Beam/Migrate/SQL/Tables.hs +++ b/beam-migrate/Database/Beam/Migrate/SQL/Tables.hs @@ -9,7 +9,6 @@ module Database.Beam.Migrate.SQL.Tables -- ** Creation and deletion createTable, createTableWithSchema - , createDatabaseSchema, dropDatabaseSchema , dropTable , preserve @@ -21,6 +20,9 @@ module Database.Beam.Migrate.SQL.Tables , renameTableTo, renameColumnTo , addColumn, dropColumn + -- * Schema manipulation + , createDatabaseSchema, dropDatabaseSchema, existingDatabaseSchema + -- * Field specification , DefaultValue, Constraint(..), NotNullConstraint @@ -51,7 +53,9 @@ import Control.Monad.Identity 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) @@ -78,27 +82,39 @@ 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 () -createDatabaseSchema nm - = upDown (createSchemaCmd (createSchemaSyntax (schemaName nm))) Nothing + -> 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 - => Text + => DatabaseSchema -> Migration be () -dropDatabaseSchema nm +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. @@ -110,7 +126,7 @@ dropDatabaseSchema nm -- a database schema. createTableWithSchema :: ( Beamable table, Table table , BeamMigrateSqlBackend be ) - => Maybe Text -- ^ Schema name, if any + => Maybe DatabaseSchema -- ^ Schema name, if any -> Text -- ^ Table name -> TableSchema be table -> Migration be (CheckedDatabaseEntity be db (TableEntity table)) @@ -118,7 +134,7 @@ 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 maybeSchemaName newTblName) + createTableSyntax Nothing (tableName (coerce <$> maybeSchemaName) newTblName) (allBeamValues (\(Columnar' (TableFieldSchema name (FieldSchema schema) _)) -> (name, schema)) tblSettings) tblConstraints command = createTableCmd createTableCommand @@ -139,12 +155,12 @@ createTableWithSchema maybeSchemaName newTblName tblSettings = schemaCheck = case maybeSchemaName of Nothing -> [] - Just sn -> [ SomeDatabasePredicate (SchemaExistsPredicate sn) ] + Just (MkDatabaseSchema sn) -> [ SomeDatabasePredicate (SchemaExistsPredicate sn) ] upDown command Nothing pure (CheckedDatabaseEntity (CheckedDatabaseTable - (DatabaseTable maybeSchemaName newTblName newTblName tbl') + (DatabaseTable (coerce <$> maybeSchemaName) newTblName newTblName tbl') tblChecks fieldChecks ) diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs b/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs index defbf775..07a4180d 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs @@ -109,8 +109,8 @@ createTableWithSchemaWorks pgConn = withTestPostgres "create_table_with_schema" pgConn $ \conn -> do res <- runBeamPostgres conn $ do db <- executeMigration runNoReturn $ do - createDatabaseSchema "internal_schema" - (CharDb <$> createTableWithSchema (Just "internal_schema") "char_test" + internalSchema <- createDatabaseSchema "internal_schema" + (CharDb <$> createTableWithSchema (Just internalSchema) "char_test" (CharT (field "key" (varchar Nothing) notNull))) verifySchema migrationBackend db @@ -127,11 +127,11 @@ dropSchemaWorks pgConn = 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" + internalSchema <- createDatabaseSchema "internal_schema" + willBeDroppedSchema <- createDatabaseSchema "will_be_dropped" + db <- (CharDb <$> createTableWithSchema (Just internalSchema) "char_test" (CharT (field "key" (varchar Nothing) notNull))) - dropDatabaseSchema "will_be_dropped" + dropDatabaseSchema willBeDroppedSchema pure db verifySchema migrationBackend db >>= \case