diff --git a/beam-core/Database/Beam/Backend/SQL/AST.hs b/beam-core/Database/Beam/Backend/SQL/AST.hs index cae70630..4a52e7d0 100644 --- a/beam-core/Database/Beam/Backend/SQL/AST.hs +++ b/beam-core/Database/Beam/Backend/SQL/AST.hs @@ -464,6 +464,12 @@ instance IsSql92GroupingSyntax Grouping where groupByExpressions = Grouping +data SchemaName = SchemaName Text + deriving (Show, Eq, Ord) + +instance IsSql92SchemaNameSyntax SchemaName where + schemaName = SchemaName + data TableName = TableName (Maybe Text) Text deriving (Show, Eq, Ord) diff --git a/beam-core/Database/Beam/Backend/SQL/Builder.hs b/beam-core/Database/Beam/Backend/SQL/Builder.hs index bcc340cc..86b123b9 100644 --- a/beam-core/Database/Beam/Backend/SQL/Builder.hs +++ b/beam-core/Database/Beam/Backend/SQL/Builder.hs @@ -405,6 +405,9 @@ instance IsSql92TableSourceSyntax SqlSyntaxBuilder where buildSepBy (byteString ", ") (map buildSql vs) <> byteString ")") vss) +instance IsSql92SchemaNameSyntax SqlSyntaxBuilder where + schemaName = SqlSyntaxBuilder . quoteSql + instance IsSql92TableNameSyntax SqlSyntaxBuilder where tableName Nothing t = SqlSyntaxBuilder $ quoteSql t tableName (Just s) t = SqlSyntaxBuilder $ quoteSql s <> byteString "." <> quoteSql t diff --git a/beam-core/Database/Beam/Backend/SQL/SQL92.hs b/beam-core/Database/Beam/Backend/SQL/SQL92.hs index 464b0c40..fb122334 100644 --- a/beam-core/Database/Beam/Backend/SQL/SQL92.hs +++ b/beam-core/Database/Beam/Backend/SQL/SQL92.hs @@ -343,6 +343,10 @@ class IsSql92OrderingSyntax ord where ascOrdering, descOrdering :: Sql92OrderingExpressionSyntax ord -> ord +class IsSql92SchemaNameSyntax schemaName where + schemaName :: Text {-^ Schema name -} + -> schemaName + class IsSql92TableNameSyntax tblName where tableName :: Maybe Text {-^ Schema -} -> Text {-^ Table name -} diff --git a/beam-migrate/Database/Beam/Haskell/Syntax.hs b/beam-migrate/Database/Beam/Haskell/Syntax.hs index d83f8f45..cc49846c 100644 --- a/beam-migrate/Database/Beam/Haskell/Syntax.hs +++ b/beam-migrate/Database/Beam/Haskell/Syntax.hs @@ -431,15 +431,20 @@ hsMkTableName toNameCase (TableName sch nm) = [] -> 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 IsSql92DdlCommandSyntax HsAction where + type Sql92DdlCommandCreateSchemaSyntax HsAction = HsAction type Sql92DdlCommandCreateTableSyntax HsAction = HsAction type Sql92DdlCommandAlterTableSyntax HsAction = HsAction type Sql92DdlCommandDropTableSyntax HsAction = HsAction + createSchemaCmd = id createTableCmd = id dropTableCmd = id alterTableCmd = id @@ -471,6 +476,12 @@ instance IsSql92DropTableSyntax HsAction where 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 "createSchema") [ hsVar nm ] + instance IsSql92CreateTableSyntax HsAction where type Sql92CreateTableTableNameSyntax HsAction = TableName type Sql92CreateTableOptionsSyntax HsAction = HsNone diff --git a/beam-migrate/Database/Beam/Migrate/Actions.hs b/beam-migrate/Database/Beam/Migrate/Actions.hs index c5d31f3d..163ae9aa 100644 --- a/beam-migrate/Database/Beam/Migrate/Actions.hs +++ b/beam-migrate/Database/Beam/Migrate/Actions.hs @@ -77,6 +77,7 @@ module Database.Beam.Migrate.Actions , ensuringNot_ , justOne_ + , createSchemaActionProvider , createTableActionProvider , dropTableActionProvider , addColumnProvider @@ -265,7 +266,8 @@ instance Semigroup (ActionProvider be) where instance Monoid (ActionProvider be) where mempty = ActionProvider (\_ _ -> []) -createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int +createSchemaWeight, createTableWeight, dropTableWeight, addColumnWeight, dropColumnWeight :: Int +createSchemaWeight = 1000 createTableWeight = 500 dropTableWeight = 100 addColumnWeight = 1 @@ -283,6 +285,30 @@ justOne_ :: [ a ] -> [ a ] justOne_ [x] = [x] justOne_ _ = [] + +-- IsSql92CreateTableSyntax + +-- | Action provider for SQL92 @CREATE SCHEMA@ actions. +createSchemaActionProvider :: forall be + . ( Typeable be, BeamMigrateOnlySqlBackend 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 @CREATE TABLE@ actions. createTableActionProvider :: forall be . ( Typeable be, BeamMigrateOnlySqlBackend be ) @@ -469,6 +495,7 @@ dropColumnNullProvider = ActionProvider provider -- -- In particular, this provides edges consisting of the following statements: -- +-- * CREATE SCHEMA -- * CREATE TABLE -- * DROP TABLE -- * ALTER TABLE ... ADD COLUMN ... @@ -479,14 +506,17 @@ defaultActionProvider :: ( Typeable be => ActionProvider be defaultActionProvider = mconcat - [ createTableActionProvider + [ createSchemaActionProvider + + , createTableActionProvider , dropTableActionProvider , addColumnProvider , dropColumnProvider , addColumnNullProvider - , dropColumnNullProvider ] + , dropColumnNullProvider + ] -- | Represents current state of a database graph search. -- diff --git a/beam-migrate/Database/Beam/Migrate/Backend.hs b/beam-migrate/Database/Beam/Migrate/Backend.hs index 0cb8086b..993fae42 100644 --- a/beam-migrate/Database/Beam/Migrate/Backend.hs +++ b/beam-migrate/Database/Beam/Migrate/Backend.hs @@ -120,7 +120,7 @@ instance Semigroup HaskellPredicateConverter where instance Monoid HaskellPredicateConverter where mempty = HaskellPredicateConverter $ \_ -> Nothing --- | 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 @@ -128,6 +128,7 @@ sql92HsPredicateConverters :: forall fromBe => (BeamMigrateSqlBackendDataTypeSyntax fromBe -> Maybe HsDataType) -> HaskellPredicateConverter sql92HsPredicateConverters convType = + trivialHsConverter @SchemaExistsPredicate <> trivialHsConverter @TableExistsPredicate <> trivialHsConverter @TableHasPrimaryKey <> hasColumnConverter @fromBe convType diff --git a/beam-migrate/Database/Beam/Migrate/Checks.hs b/beam-migrate/Database/Beam/Migrate/Checks.hs index a84fd6d1..0d010b6f 100644 --- a/beam-migrate/Database/Beam/Migrate/Checks.hs +++ b/beam-migrate/Database/Beam/Migrate/Checks.hs @@ -22,6 +22,21 @@ import Data.Semigroup 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 @@ beamCheckDeserializers , 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/beam-migrate/Database/Beam/Migrate/SQL/Builder.hs b/beam-migrate/Database/Beam/Migrate/SQL/Builder.hs index 12bcf2c6..9f3afa93 100644 --- a/beam-migrate/Database/Beam/Migrate/SQL/Builder.hs +++ b/beam-migrate/Database/Beam/Migrate/SQL/Builder.hs @@ -29,9 +29,11 @@ data SqlSyntaxBuilderCreateTableOptions deriving Eq instance IsSql92DdlCommandSyntax SqlSyntaxBuilder where + type Sql92DdlCommandCreateSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92DdlCommandCreateTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92DdlCommandDropTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92DdlCommandAlterTableSyntax SqlSyntaxBuilder = SqlSyntaxBuilder + createSchemaCmd = id createTableCmd = id alterTableCmd = id dropTableCmd = id @@ -77,6 +79,12 @@ instance IsSql92AlterColumnActionSyntax SqlSyntaxBuilder where 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 IsSql92CreateTableSyntax SqlSyntaxBuilder where type Sql92CreateTableTableNameSyntax SqlSyntaxBuilder = SqlSyntaxBuilder type Sql92CreateTableColumnSchemaSyntax SqlSyntaxBuilder = SqlSyntaxBuilder diff --git a/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs b/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs index 923738ff..ab6f8d9f 100644 --- a/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs +++ b/beam-migrate/Database/Beam/Migrate/SQL/SQL92.hs @@ -60,17 +60,28 @@ type Sql92DdlCommandConstraintAttributesSyntax syntax = type Sql92DdlCommandAlterTableActionSyntax syntax = Sql92AlterTableAlterTableActionSyntax (Sql92DdlCommandAlterTableSyntax syntax) -class ( IsSql92CreateTableSyntax (Sql92DdlCommandCreateTableSyntax syntax) +class ( IsSql92CreateSchemaSyntax (Sql92DdlCommandCreateSchemaSyntax syntax) + , IsSql92CreateTableSyntax (Sql92DdlCommandCreateTableSyntax syntax) , IsSql92DropTableSyntax (Sql92DdlCommandDropTableSyntax syntax) , IsSql92AlterTableSyntax (Sql92DdlCommandAlterTableSyntax syntax)) => IsSql92DdlCommandSyntax syntax where + type Sql92DdlCommandCreateSchemaSyntax syntax :: Type type Sql92DdlCommandCreateTableSyntax syntax :: Type type Sql92DdlCommandAlterTableSyntax syntax :: Type type Sql92DdlCommandDropTableSyntax syntax :: Type - createTableCmd :: Sql92DdlCommandCreateTableSyntax syntax -> syntax - dropTableCmd :: Sql92DdlCommandDropTableSyntax syntax -> syntax - alterTableCmd :: Sql92DdlCommandAlterTableSyntax syntax -> syntax + createSchemaCmd :: Sql92DdlCommandCreateSchemaSyntax 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 ( IsSql92TableConstraintSyntax (Sql92CreateTableTableConstraintSyntax syntax) , IsSql92ColumnSchemaSyntax (Sql92CreateTableColumnSchemaSyntax syntax) diff --git a/beam-migrate/Database/Beam/Migrate/SQL/Tables.hs b/beam-migrate/Database/Beam/Migrate/SQL/Tables.hs index 284f4728..475a54e9 100644 --- a/beam-migrate/Database/Beam/Migrate/SQL/Tables.hs +++ b/beam-migrate/Database/Beam/Migrate/SQL/Tables.hs @@ -8,7 +8,9 @@ module Database.Beam.Migrate.SQL.Tables ( -- * Table manipulation -- ** Creation and deletion - createTable, createTableWithSchema, dropTable + createTable, createTableWithSchema + , createDatabaseSchema + , dropTable , preserve -- ** @ALTER TABLE@ @@ -67,19 +69,33 @@ import Lens.Micro ((^.)) -- The second argument is a table containing a 'FieldSchema' for each field. -- See documentation on the 'Field' command for more information. -- --- To create a table in a specific schema, see `createTableWithSchema` +-- 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 = createTableWithSchema Nothing +-- * Schema manipulation + +-- | Add a @CREATE SCHEMA@ statement to this migration +-- +-- To create a table in a specific schema, see 'createTableWithSchema'. +createDatabaseSchema :: BeamMigrateSqlBackend be + => Text + -> Migration be () +createDatabaseSchema nm + = upDown (createSchemaCmd (createSchemaSyntax (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. -- -- 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. +-- +-- Note that the database schema is expected to exist; see 'createDatabaseSchema' to create +-- a database schema. createTableWithSchema :: ( Beamable table, Table table , BeamMigrateSqlBackend be ) => Maybe Text -- ^ Schema name, if any @@ -98,7 +114,7 @@ createTableWithSchema maybeSchemaName newTblName tblSettings = 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 @@ -106,9 +122,22 @@ createTableWithSchema maybeSchemaName newTblName tblSettings = 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 sn -> [ SomeDatabasePredicate (SchemaExistsPredicate sn) ] upDown command Nothing - pure (CheckedDatabaseEntity (CheckedDatabaseTable (DatabaseTable Nothing newTblName newTblName tbl') tblChecks fieldChecks) []) + pure (CheckedDatabaseEntity + (CheckedDatabaseTable + (DatabaseTable maybeSchemaName newTblName newTblName tbl') + tblChecks + fieldChecks + ) + schemaCheck + ) -- | Add a @DROP TABLE@ statement to this migration. dropTable :: BeamMigrateSqlBackend be diff --git a/beam-postgres/Database/Beam/Postgres/Migrate.hs b/beam-postgres/Database/Beam/Postgres/Migrate.hs index b8e5ca56..303ae725 100644 --- a/beam-postgres/Database/Beam/Postgres/Migrate.hs +++ b/beam-postgres/Database/Beam/Postgres/Migrate.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -77,6 +79,8 @@ import Data.Monoid (Endo(..)) #endif import Data.Word (Word64) +import GHC.Generics ( Generic ) + -- | Top-level migration backend for use by @beam-migrate@ tools migrationBackend :: Tool.BeamMigrationBackend Postgres Pg migrationBackend = Tool.BeamMigrationBackend @@ -321,27 +325,37 @@ pgUnknownDataType oid@(Pg.Oid oid') pgMod = PgDataTypeSyntax (PgDataTypeDescrOid oid pgMod) (emit "{- UNKNOWN -}") (pgDataTypeJSON (object [ "oid" .= (fromIntegral oid' :: Word), "mod" .= pgMod ])) --- * Create constraints from a connection +newtype SchemaName = MkSchemaName T.Text + deriving (Generic, Pg.FromRow) + +-- * Create constraints from a connection getDbConstraints :: Pg.Connection -> IO [ Db.SomeDatabasePredicate ] -getDbConstraints = getDbConstraintsForSchemas Nothing +getDbConstraints conn = do + schemata <- Pg.query_ conn "SELECT schema_name FROM information_schema.schemata WHERE schema_name NOT LIKE '%pg_%' AND schema_name <> 'information_schema' AND schema_name <> 'public';" + case schemata of + [] -> getDbConstraintsForSchemas Nothing conn + schemata' -> + (++) <$> getDbConstraintsForSchemas (Just ((\(MkSchemaName nm) -> T.unpack nm) <$> schemata')) conn + <*> getDbConstraintsForSchemas Nothing conn getDbConstraintsForSchemas :: Maybe [String] -> Pg.Connection -> IO [ Db.SomeDatabasePredicate ] getDbConstraintsForSchemas subschemas conn = - do tbls <- case subschemas of - Nothing -> Pg.query_ conn "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r'" - Just ss -> Pg.query conn "SELECT cl.oid, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname IN ? and relkind='r'" (Pg.Only (Pg.In ss)) - let tblsExist = map (\(_, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate (Db.QualifiedName Nothing tbl))) tbls - + do (tbls :: [(Pg.Oid, Maybe T.Text, T.Text)]) <- case subschemas of + Nothing -> Pg.query_ conn "SELECT cl.oid, NULL, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname = any (current_schemas(false)) and relkind='r'" + Just ss -> Pg.query conn "SELECT cl.oid, nspname, relname FROM pg_catalog.pg_class \"cl\" join pg_catalog.pg_namespace \"ns\" on (ns.oid = relnamespace) where nspname IN ? and relkind='r'" (Pg.Only (Pg.In ss)) + let tblsExist = map (\(_, mschema, tbl) -> Db.SomeDatabasePredicate (Db.TableExistsPredicate (Db.QualifiedName mschema tbl))) tbls + schemaChecks = fromMaybe [] $ (fmap (Db.SomeDatabasePredicate . Db.SchemaExistsPredicate . T.pack)) <$> subschemas enumerationData <- Pg.query_ conn (fromString (unlines [ "SELECT t.typname, t.oid, array_agg(e.enumlabel ORDER BY e.enumsortorder)" , "FROM pg_enum e JOIN pg_type t ON t.oid = e.enumtypid" - , "GROUP BY t.typname, t.oid" ])) + , "GROUP BY t.typname, t.oid" + ])) columnChecks <- - fmap mconcat . forM tbls $ \(oid, tbl) -> + fmap mconcat . forM tbls $ \(oid, mschema, tbl) -> do columns <- Pg.query conn "SELECT attname, atttypid, atttypmod, attnotnull, pg_catalog.format_type(atttypid, atttypmod) FROM pg_catalog.pg_attribute att WHERE att.attrelid=? AND att.attnum>0 AND att.attisdropped='f'" (Pg.Only (oid :: Pg.Oid)) let columnChecks = map (\(nm, typId :: Pg.Oid, typmod, _, typ :: ByteString) -> @@ -351,24 +365,26 @@ getDbConstraintsForSchemas subschemas conn = pgDataTypeFromAtt typ typId typmod' <|> pgEnumerationTypeFromAtt enumerationData typ typId typmod' - in Db.SomeDatabasePredicate (Db.TableHasColumn (Db.QualifiedName Nothing tbl) nm pgDataType :: Db.TableHasColumn Postgres)) columns + in Db.SomeDatabasePredicate (Db.TableHasColumn (Db.QualifiedName mschema tbl) nm pgDataType :: Db.TableHasColumn Postgres)) columns notNullChecks = concatMap (\(nm, _, _, isNotNull, _) -> if isNotNull then - [Db.SomeDatabasePredicate (Db.TableColumnHasConstraint (Db.QualifiedName Nothing tbl) nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) + [Db.SomeDatabasePredicate (Db.TableColumnHasConstraint (Db.QualifiedName mschema tbl) nm (Db.constraintDefinitionSyntax Nothing Db.notNullConstraintSyntax Nothing) :: Db.TableColumnHasConstraint Postgres)] else [] ) columns - pure (columnChecks ++ notNullChecks) + pure (columnChecks ++ notNullChecks ++ schemaChecks) primaryKeys <- - map (\(relnm, cols) -> Db.SomeDatabasePredicate (Db.TableHasPrimaryKey (Db.QualifiedName Nothing relnm) (V.toList cols))) <$> - Pg.query_ conn (fromString (unlines [ "SELECT c.relname, array_agg(a.attname ORDER BY k.n ASC)" + map (\(schema, relnm, cols) -> Db.SomeDatabasePredicate (Db.TableHasPrimaryKey (Db.QualifiedName schema relnm) (V.toList cols))) <$> + -- We nullify the 'public' schema, which is the implicit default in Postgres + Pg.query_ conn (fromString (unlines [ "SELECT NULLIF(ns.nspname, 'public'), c.relname, array_agg(a.attname ORDER BY k.n ASC)" , "FROM pg_index i" , "CROSS JOIN unnest(i.indkey) WITH ORDINALITY k(attid, n)" , "JOIN pg_attribute a ON a.attnum=k.attid AND a.attrelid=i.indrelid" , "JOIN pg_class c ON c.oid=i.indrelid" , "JOIN pg_namespace ns ON ns.oid=c.relnamespace" - , "WHERE ns.nspname = any (current_schemas(false)) AND c.relkind='r' AND i.indisprimary GROUP BY relname, i.indrelid" ])) + -- Recall that schema of the form 'pg_' are Postgres internal tables that should not be taken into account + , "WHERE nspname NOT LIKE '%pg_%' AND c.relkind='r' AND i.indisprimary GROUP BY nspname, relname, i.indrelid" ])) let enumerations = map (\(enumNm, _, options) -> Db.SomeDatabasePredicate (PgHasEnum enumNm (V.toList options))) enumerationData diff --git a/beam-postgres/Database/Beam/Postgres/Syntax.hs b/beam-postgres/Database/Beam/Postgres/Syntax.hs index bc42da55..db678daf 100644 --- a/beam-postgres/Database/Beam/Postgres/Syntax.hs +++ b/beam-postgres/Database/Beam/Postgres/Syntax.hs @@ -251,6 +251,7 @@ newtype PgExpressionSyntax = PgExpressionSyntax { fromPgExpression :: PgSyntax } newtype PgAggregationSetQuantifierSyntax = PgAggregationSetQuantifierSyntax { fromPgAggregationSetQuantifier :: PgSyntax } newtype PgSelectSetQuantifierSyntax = PgSelectSetQuantifierSyntax { fromPgSelectSetQuantifier :: PgSyntax } newtype PgFromSyntax = PgFromSyntax { fromPgFrom :: PgSyntax } +newtype PgSchemaNameSyntax = PgSchemaNameSyntax { fromPgSchemaName :: PgSyntax } newtype PgTableNameSyntax = PgTableNameSyntax { fromPgTableName :: PgSyntax } newtype PgComparisonQuantifierSyntax = PgComparisonQuantifierSyntax { fromPgComparisonQuantifier :: PgSyntax } newtype PgExtractFieldSyntax = PgExtractFieldSyntax { fromPgExtractField :: PgSyntax } @@ -335,6 +336,8 @@ instance Hashable PgDataTypeDescr where hashWithSalt salt (PgDataTypeDescrDomain t) = hashWithSalt salt (1 :: Int, t) +newtype PgCreateSchemaSyntax = PgCreateSchemaSyntax { fromPgCreateSchema :: PgSyntax } + newtype PgCreateTableSyntax = PgCreateTableSyntax { fromPgCreateTable :: PgSyntax } data PgTableOptionsSyntax = PgTableOptionsSyntax PgSyntax PgSyntax newtype PgColumnSchemaSyntax = PgColumnSchemaSyntax { fromPgColumnSchema :: PgSyntax } deriving (Show, Eq) @@ -411,14 +414,19 @@ instance IsSql92Syntax PgCommandSyntax where updateCmd = PgCommandSyntax PgCommandTypeDataUpdate . coerce instance IsSql92DdlCommandSyntax PgCommandSyntax where + type Sql92DdlCommandCreateSchemaSyntax PgCommandSyntax = PgCreateSchemaSyntax type Sql92DdlCommandCreateTableSyntax PgCommandSyntax = PgCreateTableSyntax type Sql92DdlCommandDropTableSyntax PgCommandSyntax = PgDropTableSyntax type Sql92DdlCommandAlterTableSyntax PgCommandSyntax = PgAlterTableSyntax + createSchemaCmd = PgCommandSyntax PgCommandTypeDdl . coerce createTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce dropTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce alterTableCmd = PgCommandSyntax PgCommandTypeDdl . coerce +instance IsSql92SchemaNameSyntax PgSchemaNameSyntax where + schemaName s = PgSchemaNameSyntax (pgQuotedIdentifier s) + instance IsSql92TableNameSyntax PgTableNameSyntax where tableName Nothing t = PgTableNameSyntax (pgQuotedIdentifier t) tableName (Just s) t = PgTableNameSyntax (pgQuotedIdentifier s <> emit "." <> pgQuotedIdentifier t) @@ -1041,6 +1049,12 @@ instance IsSql92AlterColumnActionSyntax PgAlterColumnActionSyntax where setNullSyntax = PgAlterColumnActionSyntax (emit "DROP NOT NULL") setNotNullSyntax = PgAlterColumnActionSyntax (emit "SET NOT NULL") +instance IsSql92SchemaNameSyntax PgSchemaNameSyntax => IsSql92CreateSchemaSyntax PgCreateSchemaSyntax where + type Sql92CreateSchemaSchemaNameSyntax PgCreateSchemaSyntax = PgSchemaNameSyntax + + createSchemaSyntax schemaName = PgCreateSchemaSyntax $ + emit "CREATE SCHEMA " <> fromPgSchemaName schemaName + instance IsSql92CreateTableSyntax PgCreateTableSyntax where type Sql92CreateTableTableNameSyntax PgCreateTableSyntax = PgTableNameSyntax type Sql92CreateTableColumnSchemaSyntax PgCreateTableSyntax = PgColumnSchemaSyntax diff --git a/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs b/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs index 882a7e36..da5349fb 100644 --- a/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs +++ b/beam-postgres/test/Database/Beam/Postgres/Test/Migrate.hs @@ -22,6 +22,7 @@ tests postgresConn = , charWidthVerification postgresConn "CHAR" char , charNoWidthVerification postgresConn "CHAR" char , extensionVerification postgresConn + , createTableWithSchemaWorks postgresConn ] data CharT f @@ -96,3 +97,22 @@ extensionVerification pgConn = case resAfter of VerificationSucceeded -> return () VerificationFailed failures -> fail ("Verification failed: " ++ show failures) + + +-- | Verifies that 'createTableWithSchema' correctly creates a table +-- with a schema. +createTableWithSchemaWorks :: IO ByteString -> TestTree +createTableWithSchemaWorks pgConn = + testCase ("createTableWithSchema works correctly") $ do + 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" + (CharT (field "key" (varchar Nothing) notNull))) + + verifySchema migrationBackend db + + case res of + VerificationSucceeded -> return () + VerificationFailed failures -> fail ("Verification failed: " ++ show failures)