diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,30 @@ +# 0.5.5.0 + +## Added features + +* Added support for foreign key constraints: + + * New `ForeignKeyAction` datatype representing possible actions when updating + or deleting a row with referencing foreign keys. + * The `IsSql92TableConstraintSyntax` typeclass now has an additional method, + `foreignKeyConstraintSyntax`, for constructing foreign key constraint syntax. + * Introduce `addTableForeignKey` for declaring new foreign key constraints. + +* Added support for temporary tables: + + * The `BeamHasTempTables` typeclass is used for backends to emit + `CREATE TEMPORARY TABLE` syntax. + * The `runCreateTempTable` command allows creating a temporary table. + The returned table entity can be used in queries like any other table. + +## Bug fixes + +* Fix an issue in which `beam-migrate` would fail to migrate a unique index + to a non-unique index or vice-versa. + +* Fixed an issue in which the migration solver could end up taking an + exponentially long time to conclude that migration isn't possible. + # 0.5.4.0 ## Added features 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 @@ -25,6 +25,7 @@ import Data.Hashable import Data.Int import Data.List (find, nub) +import qualified Data.List.NonEmpty as NE import qualified Data.Map as M import Data.Maybe import qualified Data.Set as S @@ -584,6 +585,7 @@ map hsConstraintDefinitionConstraint cs) instance IsSql92TableConstraintSyntax HsTableConstraint where + foreignKeyConstraintSyntax _ _ _ _ _ = HsTableConstraint $ \_ _ -> mempty primaryKeyConstraintSyntax fields = HsTableConstraint $ \tblNm tblFields -> let primaryKeyDataDecl = insDataDecl primaryKeyType [ primaryKeyConDecl ] (Just primaryKeyDeriving) @@ -591,7 +593,7 @@ tableTypeNm = tblNm <> "T" tableTypeKeyNm = tblNm <> "Key" - (fieldRecordNames, fieldTys) = unzip (fromMaybe (error "fieldTys") (mapM (hsFieldLookup tblFields) fields)) + (fieldRecordNames, fieldTys) = unzip (fromMaybe (error "fieldTys") (mapM (hsFieldLookup tblFields) $ NE.toList fields)) primaryKeyType = tyApp (tyConNamed "PrimaryKey") [ tyConNamed (T.unpack tableTypeNm), tyVarNamed "f" ] primaryKeyConDecl = Hs.QualConDecl () Nothing Nothing (Hs.ConDecl () (Hs.Ident () (T.unpack tableTypeKeyNm)) fieldTys) 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 @@ -107,6 +107,7 @@ import Control.Parallel.Strategies import Data.Foldable +import qualified Data.List.NonEmpty as NE import qualified Data.HashMap.Strict as HM import qualified Data.HashSet as HS @@ -377,9 +378,41 @@ guard (tblNm == postTblNm) pure (primaryKeyP, primaryKey) - let postConditions = [ p tblP, p primaryKeyP ] ++ concat columnsP + -- For each foreign key constraint, ensure the referenced table + -- already exists in the current state. + -- This enforces a topological ordering, so that the solver schedules + -- CREATE TABLE for all referenced tables first. + -- + -- Note: this does not support cycles in the foreign key reference graph, + -- for which we would need ALTER TABLE ADD CONSTRAINT, which we don't + -- currently support. + (fkPs, fkConstraints) <- do + let fkData = + unzip + [ ( p fkP + , foreignKeyConstraintSyntax localCols (qnameAsText refTbl) refCols onUpd onDel ) + | fkP@(TableHasForeignKey tblNm localCols refTbl refCols onUpd onDel) + <- findPostConditions + , tblNm == postTblNm + ] + refTbls = + [ refTbl + | TableHasForeignKey tblNm _ refTbl _ _ _ <- findPostConditions + , tblNm == postTblNm + , refTbl /= postTblNm + ] + for_ refTbls $ \refTbl -> do + TableExistsPredicate nm <- findPreConditions + guard (nm == refTbl) + pure fkData + + + let postConditions = [ p tblP, p primaryKeyP ] ++ concat columnsP ++ fkPs cmd = createTableCmd (createTableSyntax Nothing (qnameAsTableName postTblNm) colsSyntax tblConstraints) - tblConstraints = if null primaryKey then [] else [ primaryKeyConstraintSyntax primaryKey ] + tblConstraints = (case NE.nonEmpty primaryKey of + Nothing -> [] + Just pkey -> [primaryKeyConstraintSyntax pkey]) + ++ fkConstraints colsSyntax = map (\(colNm, type_, cs) -> (colNm, columnSchemaSyntax type_ Nothing cs Nothing)) columns pure (PotentialAction mempty (HS.fromList postConditions) (Seq.singleton (MigrationCommand cmd MigrationKeepsData)) @@ -453,16 +486,14 @@ dropColumnProvider = ActionProvider provider where provider :: ActionProviderFn be - provider findPreConditions _ = + provider findPreConditions findPostConditions = do colP@(TableHasColumn tblNm colNm _ :: TableHasColumn be) <- findPreConditions --- TableExistsPredicate tblNm' <- trace ("COnsider drop " <> show tblNm <> " " <> show colNm) findPreConditions --- guard (any (\(TableExistsPredicate tblNm') -> tblNm' == tblNm) findPreConditions) --tblNm' == tblNm) --- ensuringNot_ $ do --- TableHasColumn tblNm' colNm' colType' :: TableHasColumn (Sql92DdlCommandColumnSchemaSyntax cmd) <- --- findPostConditions --- guard (tblNm' == tblNm && colNm == colNm' && colType == colType') -- This column exists as a different type + -- Don't drop a column that the goal still requires with the same type. + ensuringNot_ $ do + (colPost :: TableHasColumn be) <- findPostConditions + guard (p colPost == p colP) relatedPreds <- --pure [] pure $ do p'@(SomeDatabasePredicate pred') <- findPreConditions @@ -506,11 +537,16 @@ dropColumnNullProvider = ActionProvider provider where provider :: ActionProviderFn be - provider findPreConditions _ = + provider findPreConditions findPostConditions = do colP@(TableColumnHasConstraint tblNm colNm _ :: TableColumnHasConstraint be) <- findPreConditions -- TODO guard (c == notNullConstraintSyntax) + -- Don't drop a constraint that is still required in the goal. + ensuringNot_ $ + do (sdp :: SomeDatabasePredicate) <- findPostConditions + guard (sdp == p colP) + TableExistsPredicate tblNm' <- findPreConditions guard (tblNm == tblNm') @@ -564,10 +600,15 @@ provider findPreConditions findPostConditions = do (idxP@(TableHasIndex { hasIndex_table = preTblNm, hasIndex_name = idxNm }) :: TableHasIndex be) <- findPreConditions + + -- Supress DROP INDEX if the exact same index is still required + -- in the goal (including options such as uniqueness). + -- + -- Comparing only by name would wrongly prevent dropping a non-unique + -- index that must be replaced by a unique one (or vice-versa). ensuringNot_ $ - do (TableHasIndex { hasIndex_table = postTblNm, hasIndex_name = idxNm' } - :: TableHasIndex be) <- findPostConditions - guard (preTblNm == postTblNm && idxNm' == idxNm) + do (postIdx :: TableHasIndex be) <- findPostConditions + guard (p postIdx == p idxP) let cmd = dropIndexCmd idxNm pure (PotentialAction (HS.singleton (p idxP)) mempty 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 @@ -11,7 +11,8 @@ import Database.Beam.Migrate.Serialization import Database.Beam.Migrate.Types.Predicates -import Data.Aeson ((.:), (.=), withObject, object) +import Data.Aeson ((.:), (.:?), (.=), withObject, object) +import Data.Maybe (fromMaybe) import Data.Aeson.Types (Parser, Value) import Data.Hashable (Hashable(..)) import qualified Data.List.NonEmpty as NE (NonEmpty) @@ -168,6 +169,67 @@ | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm | otherwise = False +-- | Asserts that the given table has a foreign key referencing another table. +-- Create these predicates with +-- 'Database.Beam.Migrate.Types.CheckedEntities.addTableForeignKey'. +data TableHasForeignKey + = TableHasForeignKey + { hasForeignKey_table :: QualifiedName -- ^ source table + , hasForeignKey_columns :: NE.NonEmpty Text -- ^ local columns (in order) + , hasForeignKey_refTable :: QualifiedName -- ^ referenced table + , hasForeignKey_refColumns :: NE.NonEmpty Text -- ^ referenced columns (in order) + , hasForeignKey_onUpdate :: ForeignKeyAction + , hasForeignKey_onDelete :: ForeignKeyAction + } deriving (Show, Eq, Generic) +instance Hashable TableHasForeignKey +instance DatabasePredicate TableHasForeignKey where + englishDescription (TableHasForeignKey { hasForeignKey_table = tbl + , hasForeignKey_columns = cols + , hasForeignKey_refTable = refTbl + , hasForeignKey_refColumns = refCols + , hasForeignKey_onUpdate = onUpd + , hasForeignKey_onDelete = onDel }) = + "Table " <> show tbl <> " has foreign key on " <> show cols <> + " referencing " <> show refTbl <> " " <> show refCols <> + " ON UPDATE " <> show onUpd <> + " ON DELETE " <> show onDel + + predicateSpecificity _ = PredicateSpecificityAllBackends + + serializePredicate (TableHasForeignKey { hasForeignKey_table = tbl + , hasForeignKey_columns = cols + , hasForeignKey_refTable = refTbl + , hasForeignKey_refColumns = refCols + , hasForeignKey_onUpdate = onUpd + , hasForeignKey_onDelete = onDel }) = + object [ "has-foreign-key" .= object + [ "table" .= tbl + , "columns" .= cols + , "ref-table" .= refTbl + , "ref-columns" .= refCols + , "on-update" .= serializeForeignKeyAction onUpd + , "on-delete" .= serializeForeignKeyAction onDel + ] ] + + predicateCascadesDropOn (TableHasForeignKey { hasForeignKey_table = tblNm }) p' + | Just (TableExistsPredicate tblNm') <- cast p' = tblNm' == tblNm + | otherwise = False + +serializeForeignKeyAction :: ForeignKeyAction -> Text +serializeForeignKeyAction ForeignKeyActionCascade = "cascade" +serializeForeignKeyAction ForeignKeyActionSetNull = "set-null" +serializeForeignKeyAction ForeignKeyActionSetDefault = "set-default" +serializeForeignKeyAction ForeignKeyActionRestrict = "restrict" +serializeForeignKeyAction ForeignKeyNoAction = "no-action" + +deserializeForeignKeyAction :: Text -> Maybe ForeignKeyAction +deserializeForeignKeyAction "cascade" = Just ForeignKeyActionCascade +deserializeForeignKeyAction "set-null" = Just ForeignKeyActionSetNull +deserializeForeignKeyAction "set-default" = Just ForeignKeyActionSetDefault +deserializeForeignKeyAction "restrict" = Just ForeignKeyActionRestrict +deserializeForeignKeyAction "no-action" = Just ForeignKeyNoAction +deserializeForeignKeyAction _ = Nothing + -- * Deserialization -- | 'BeamDeserializers' for all the predicates defined in this module @@ -182,6 +244,7 @@ , beamDeserializer (const deserializeTableExistsPredicate) , beamDeserializer (const deserializeTableHasPrimaryKeyPredicate) , beamDeserializer (const deserializeTableHasIndexPredicate) + , beamDeserializer (const deserializeTableHasForeignKeyPredicate) , beamDeserializer deserializeTableHasColumnPredicate , beamDeserializer deserializeTableColumnHasConstraintPredicate ] @@ -213,6 +276,20 @@ (TableHasIndex <$> v' .: "table" <*> v' .: "name" <*> v' .: "columns" <*> (deserializeIndexOptions @(BeamSqlBackendSyntax be) =<< v' .: "options"))) + + deserializeTableHasForeignKeyPredicate :: Value -> Parser SomeDatabasePredicate + deserializeTableHasForeignKeyPredicate = + withObject "TableHasForeignKey" $ \v -> + v .: "has-foreign-key" >>= + (withObject "TableHasForeignKey" $ \v' -> + SomeDatabasePredicate <$> + (TableHasForeignKey + <$> v' .: "table" + <*> v' .: "columns" + <*> v' .: "ref-table" + <*> v' .: "ref-columns" + <*> (fromMaybe ForeignKeyNoAction . (>>= deserializeForeignKeyAction) <$> v' .:? "on-update") + <*> (fromMaybe ForeignKeyNoAction . (>>= deserializeForeignKeyAction) <$> v' .:? "on-delete"))) deserializeTableHasColumnPredicate :: BeamDeserializers be' -> Value -> Parser SomeDatabasePredicate 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 @@ -14,6 +14,7 @@ import Data.ByteString.Builder (Builder, byteString, toLazyByteString) import qualified Data.ByteString.Lazy.Char8 as BCL +import qualified Data.List.NonEmpty as NE -- | Options for @CREATE TABLE@. Given as a separate ADT because the options may -- go in different places syntactically. @@ -124,7 +125,20 @@ instance IsSql92TableConstraintSyntax SqlSyntaxBuilder where primaryKeyConstraintSyntax fs = SqlSyntaxBuilder $ - byteString "PRIMARY KEY(" <> buildSepBy (byteString ", ") (map quoteSql fs) <> byteString ")" + byteString "PRIMARY KEY(" <> buildSepBy (byteString ", ") (map quoteSql $ NE.toList fs) <> byteString ")" + foreignKeyConstraintSyntax localCols refTbl refCols onUpdate onDelete = + SqlSyntaxBuilder $ + byteString "FOREIGN KEY(" <> buildSepBy (byteString ", ") (map quoteSql $ NE.toList localCols) <> byteString ")" <> + byteString " REFERENCES " <> quoteSql refTbl <> + byteString "(" <> buildSepBy (byteString ", ") (map quoteSql $ NE.toList refCols) <> byteString ")" <> + byteString " ON UPDATE " <> buildSql (sqlForeignKeyAction onUpdate) <> + byteString " ON DELETE " <> buildSql (sqlForeignKeyAction onDelete) + where + sqlForeignKeyAction ForeignKeyActionCascade = SqlSyntaxBuilder (byteString "CASCADE") + sqlForeignKeyAction ForeignKeyActionSetNull = SqlSyntaxBuilder (byteString "SET NULL") + sqlForeignKeyAction ForeignKeyActionSetDefault = SqlSyntaxBuilder (byteString "SET DEFAULT") + sqlForeignKeyAction ForeignKeyActionRestrict = SqlSyntaxBuilder (byteString "RESTRICT") + sqlForeignKeyAction ForeignKeyNoAction = SqlSyntaxBuilder (byteString "NO ACTION") -- | Some backends use this to represent their constraint attributes. Does not -- need to be used in practice. 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 @@ -17,7 +17,8 @@ import Data.Kind (Type) import qualified Data.List.NonEmpty as NE (NonEmpty) import Data.Text (Text) -import Data.Typeable +import Data.Typeable (Typeable) +import GHC.Generics (Generic) -- * Convenience type synonyms @@ -184,8 +185,35 @@ -> Maybe Text {-^ Default collation -} -> columnSchema +-- | Action to perform on referencing foreign keys when a row is modified. +data ForeignKeyAction + = ForeignKeyActionCascade + -- ^ @CASCADE@: propagate the action to referencing foreign key columns. + | ForeignKeyActionSetNull + -- ^ @SET NULL@: set the referencing foreign key colums to @NULL@. + | ForeignKeyActionSetDefault + -- ^ @SET DEFAULT@: set the referencing foreign key columns to their default + -- values. + | ForeignKeyActionRestrict + -- ^ @RESTRICT@: prohibit modification of a row when foreign key references + -- to that row exist. + | ForeignKeyNoAction + -- ^ @NO ACTION@ + deriving (Show, Eq, Ord, Generic) +instance Hashable ForeignKeyAction + class Typeable constraint => IsSql92TableConstraintSyntax constraint where - primaryKeyConstraintSyntax :: [ Text ] -> constraint + primaryKeyConstraintSyntax :: NE.NonEmpty Text -> constraint + -- | Emit a @FOREIGN KEY (cols) REFERENCES tbl (refCols)@ table constraint. + -- + -- Use 'addTableForeignKey' to attach a foreign key to a schema definition. + foreignKeyConstraintSyntax + :: NE.NonEmpty Text -- ^ local columns + -> Text -- ^ referenced table name + -> NE.NonEmpty Text -- ^ referenced columns + -> ForeignKeyAction -- ^ ON UPDATE action + -> ForeignKeyAction -- ^ ON DELETE action + -> constraint class Typeable match => IsSql92MatchTypeSyntax match where fullMatchSyntax :: match 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 @@ -55,6 +55,7 @@ import Data.Coerce (coerce) import Data.Kind (Type) +import qualified Data.List.NonEmpty as NE import Data.Text (Text) import Data.Typeable import qualified Data.Kind as Kind (Constraint) @@ -143,7 +144,10 @@ -> 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 ] + tblConstraints = + case NE.nonEmpty pkFields of + Nothing -> [] + Just pks -> [ primaryKeyConstraintSyntax pks ] createTableCommand = createTableSyntax Nothing (tableName (coerce <$> maybeSchemaName) newTblName) (allBeamValues (\(Columnar' (TableFieldSchema name (FieldSchema schema) _)) -> (name, schema)) tblSettings) 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 @@ -19,6 +19,7 @@ , BeamSqlBackendReferentialActionSyntax , BeamSqlBackendConstraintAttributesSyntax , BeamSqlBackendIndexSyntax + , BeamSqlBackendTableConstraintSyntax ) where import Database.Beam.Migrate.Types.Predicates @@ -94,3 +95,5 @@ = Sql92DdlCommandConstraintAttributesSyntax (BeamSqlBackendSyntax be) type BeamSqlBackendIndexSyntax be = Sql92CreateIndexOptionsSyntax (BeamSqlBackendSyntax be) +type BeamSqlBackendTableConstraintSyntax be + = Sql92CreateTableTableConstraintSyntax (Sql92DdlCommandCreateTableSyntax (BeamSqlBackendSyntax be)) diff --git a/Database/Beam/Migrate/TempTable.hs b/Database/Beam/Migrate/TempTable.hs new file mode 100644 --- /dev/null +++ b/Database/Beam/Migrate/TempTable.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Database.Beam.Migrate.TempTable + ( -- * Temporary tables + + -- ** @CREATE TEMPORARY TABLE@ + runCreateTempTable + + -- ** Options + , TempTableCreateMode(..) + , TempTableOptions(..) + , defaultTempTableOptions + + -- ** Backend support for temporary tables + , BeamHasTempTables(..) + + -- ** Schema constraint + , HasDefaultTempTableSchema + + -- ** Internals + , GNullableConstraintsForSchema(..) + , GDefaultBackendFieldSchemas(..) + ) where + +import Control.Monad.Writer (execWriter, tell) + +import Data.Functor.Const (Const(..)) +import Data.Functor.Identity (Identity(..)) +import Data.Kind (Type) +import Data.Proxy (Proxy(..)) +import qualified Data.Text as T +import GHC.Generics + +import Database.Beam.Backend.SQL + ( MonadBeam(..), BeamSqlBackendSyntax ) +import Database.Beam.Backend.Types (Nullable) +import Database.Beam.Migrate.Generics (HasDefaultSqlDataType(..), NullableStatus) +import Database.Beam.Migrate.SQL.SQL92 + ( IsSql92ColumnSchemaSyntax(..) + , IsSql92ColumnConstraintDefinitionSyntax(..) + , IsSql92ColumnConstraintSyntax(..) + ) +import Database.Beam.Migrate.SQL.Types + ( BeamMigrateSqlBackend + , BeamSqlBackendColumnSchemaSyntax + , BeamSqlBackendColumnConstraintDefinitionSyntax + ) +import Database.Beam.Query (HasQBuilder) +import Database.Beam.Schema.Tables + ( DatabaseEntity(..), DatabaseEntityDescriptor(..) + , TableEntity + , TableSettings, TableField(..) + , defTblFieldSettings, allBeamValues, zipBeamFieldsM + , Columnar'(..), Table(..) + , GDefaultTableFieldSettings + ) + +-------------------------------------------------------------------------------- + +-- | How to handle an existing temporary table when calling 'runCreateTempTable'. +data TempTableCreateMode + = CreateIfNotExists + -- ^ Emit @CREATE TEMPORARY TABLE IF NOT EXISTS@. + -- If the table already exists, do nothing. + | DropAndCreate + -- ^ Emit @DROP TABLE IF EXISTS@ followed by @CREATE TEMPORARY TABLE@. + -- The table is always (re)created fresh. + deriving (Eq, Ord, Show) + +-- | Options for 'runCreateTempTable'. +data TempTableOptions = TempTableOptions + { tempTableCreateMode :: TempTableCreateMode + -- ^ Whether to preserve an existing table or recreate it from scratch. + } + +-- | Default options: use @CREATE TEMPORARY TABLE IF NOT EXISTS@. +defaultTempTableOptions :: TempTableOptions +defaultTempTableOptions = + TempTableOptions { tempTableCreateMode = CreateIfNotExists } + +-- | Support for temporary tables in a Beam backend. +class (BeamMigrateSqlBackend be, HasQBuilder be) => BeamHasTempTables be where + -- | Render a @CREATE TEMPORARY TABLE@ command. + createTempTableCmd + :: T.Text + -- ^ table name + -> [(T.Text, BeamSqlBackendColumnSchemaSyntax be)] + -- ^ ordered (column name, column schema) pairs + -> [T.Text] + -- ^ primary key column names (empty for no primary key constraint) + -> Bool + -- ^ include @IF NOT EXISTS@? + -> BeamSqlBackendSyntax be + + -- | Render a @DROP TABLE IF EXISTS@ command. + dropTempTableIfExistsCmd + :: T.Text + -- ^ table name + -> BeamSqlBackendSyntax be + + +-- | Constraint used for deriving the schema of a temporary table. +type HasDefaultTempTableSchema be tbl = + ( BeamHasTempTables be + , Generic (tbl (Const (BeamSqlBackendColumnSchemaSyntax be))) + , GDefaultBackendFieldSchemas be + (Rep (tbl Identity)) + (Rep (tbl (Const (BeamSqlBackendColumnSchemaSyntax be)))) + , Table tbl + , Generic (TableSettings tbl) + , GDefaultTableFieldSettings (Rep (TableSettings tbl) ()) + ) + +-- --------------------------------------------------------------------------- +-- CREATE TEMPORARY TABLE + +-- | Execute @CREATE TEMPORARY TABLE@, returning the created temporary table +-- entity. +-- +-- Note that the @db@ parameter is phantom; if you need to change it you can +-- use 'Data.Coerce.coerce'. +runCreateTempTable + :: forall be db tbl m + . ( HasDefaultTempTableSchema be tbl + , MonadBeam be m ) + => TempTableOptions + -> T.Text -- ^ temporary table name + -> m (DatabaseEntity be db (TableEntity tbl)) +runCreateTempTable opts nm = do + let tblSettings = defTblFieldSettings :: TableSettings tbl + colSchemas = deriveTblColSchemas (Proxy @be) (Proxy @tbl) + + -- Collect (columnName, columnSchema) pairs in field declaration order. + fieldDefs :: [(T.Text, BeamSqlBackendColumnSchemaSyntax be)] + fieldDefs = execWriter $ + zipBeamFieldsM + (\(Columnar' tf) c@(Columnar' (Const schema)) -> + do tell [(_fieldName tf, schema)] + return c + ) + tblSettings colSchemas + + pkFields = + allBeamValues (\(Columnar' tf) -> _fieldName tf) (primaryKey tblSettings) + + case tempTableCreateMode opts of + CreateIfNotExists -> + runNoReturn (createTempTableCmd @be nm fieldDefs pkFields True) + DropAndCreate -> do + runNoReturn (dropTempTableIfExistsCmd @be nm) + runNoReturn (createTempTableCmd @be nm fieldDefs pkFields False) + + let entity = DatabaseEntity $ DatabaseTable + { dbTableSchema = Nothing + , dbTableOrigName = nm + , dbTableCurrentName = nm + , dbTableSettings = tblSettings + } + pure entity + +deriveTblColSchemas + :: forall be tbl + . HasDefaultTempTableSchema be tbl + => Proxy be -> Proxy tbl -> tbl (Const (BeamSqlBackendColumnSchemaSyntax be)) +deriveTblColSchemas pBe _ = + to $ gDefaultBackendFieldSchemas pBe (Proxy @(Rep (tbl Identity))) False + +------------------------------------------------------------------------------ +-- Generics machinery (internal) + +class BeamMigrateSqlBackend be + => GNullableConstraintsForSchema (nullable :: Bool) be where + nullableConstraintsForSchema + :: Proxy nullable + -> Proxy be + -> [BeamSqlBackendColumnConstraintDefinitionSyntax be] + +instance BeamMigrateSqlBackend be + => GNullableConstraintsForSchema 'False be where + nullableConstraintsForSchema _ _ = + [ constraintDefinitionSyntax Nothing notNullConstraintSyntax Nothing ] + +instance BeamMigrateSqlBackend be + => GNullableConstraintsForSchema 'True be where + nullableConstraintsForSchema _ _ = [] + +class BeamMigrateSqlBackend be + => GDefaultBackendFieldSchemas be (i :: Type -> Type) (o :: Type -> Type) where + gDefaultBackendFieldSchemas :: Proxy be -> Proxy i -> Bool -> o () + +instance ( BeamMigrateSqlBackend be + , GDefaultBackendFieldSchemas be xId schemaId ) + => GDefaultBackendFieldSchemas be (M1 t s xId) (M1 t s schemaId) where + gDefaultBackendFieldSchemas pBe _ embedded = + M1 (gDefaultBackendFieldSchemas pBe (Proxy @xId) embedded) + +instance ( BeamMigrateSqlBackend be + , GDefaultBackendFieldSchemas be aId aSchema + , GDefaultBackendFieldSchemas be bId bSchema ) + => GDefaultBackendFieldSchemas be (aId :*: bId) (aSchema :*: bSchema) where + gDefaultBackendFieldSchemas pBe _ embedded = + gDefaultBackendFieldSchemas pBe (Proxy @aId) embedded :*: + gDefaultBackendFieldSchemas pBe (Proxy @bId) embedded + + +instance ( HasDefaultSqlDataType be haskTy + , GNullableConstraintsForSchema (NullableStatus haskTy) be + , cs ~ BeamSqlBackendColumnSchemaSyntax be ) + => GDefaultBackendFieldSchemas be + (Rec0 haskTy) + (Rec0 (Const cs haskTy)) where + gDefaultBackendFieldSchemas pBe _ embedded = + K1 $ Const $ columnSchemaSyntax + (defaultSqlDataType (Proxy @haskTy) pBe embedded) + Nothing + (nullableConstraintsForSchema (Proxy @(NullableStatus haskTy)) pBe) + Nothing + +instance ( BeamMigrateSqlBackend be + , cs ~ BeamSqlBackendColumnSchemaSyntax be + , Generic (embeddedTbl (Const cs)) + , GDefaultBackendFieldSchemas be + (Rep (embeddedTbl Identity)) + (Rep (embeddedTbl (Const cs))) ) + => GDefaultBackendFieldSchemas be + (Rec0 (embeddedTbl Identity)) + (Rec0 (embeddedTbl (Const cs))) where + gDefaultBackendFieldSchemas pBe _ _ = + K1 $ to $ gDefaultBackendFieldSchemas pBe + (Proxy @(Rep (embeddedTbl Identity))) True + +instance ( BeamMigrateSqlBackend be + , cs ~ BeamSqlBackendColumnSchemaSyntax be + , Generic (embeddedTbl (Nullable (Const cs))) + , GDefaultBackendFieldSchemas be + (Rep (embeddedTbl (Nullable Identity))) + (Rep (embeddedTbl (Nullable (Const cs)))) ) + => GDefaultBackendFieldSchemas be + (Rec0 (embeddedTbl (Nullable Identity))) + (Rec0 (embeddedTbl (Nullable (Const cs)))) where + gDefaultBackendFieldSchemas pBe _ _ = + K1 $ to $ gDefaultBackendFieldSchemas pBe + (Proxy @(Rep (embeddedTbl (Nullable Identity)))) True + 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 @@ -30,6 +30,9 @@ , IsSql92CreateDropIndexSyntax(..) + , addTableForeignKey + , primaryKeyColumns + -- * Predicates , DatabasePredicate(..) , SomeDatabasePredicate(..) 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 @@ -298,6 +298,43 @@ in CheckedDatabaseEntity (CheckedDatabaseTable dt (tblChecks ++ [idxCheck]) fieldChecks) extraChecks +-- | Declare a foreign key constraint on a checked table entity. +-- +-- Example referencing the primary key of a @UserT@ table: +-- +-- @ +-- addTableForeignKey (db ^. usersTable) +-- (\\ t -> selectorColumnName _postAuthorId t NE.:| []) +-- primaryKeyColumns +-- ForeignKeyNoAction -- ON UPDATE action +-- ForeignKeyActionCascade -- ON DELETE action +-- @ +addTableForeignKey + :: forall be db localTbl refTbl. + (Table localTbl, Table refTbl) + => CheckedDatabaseEntity be db (TableEntity refTbl) -- ^ referenced table + -> (localTbl (TableField localTbl) -> NE.NonEmpty Text) -- ^ local columns + -> (refTbl (TableField refTbl) -> NE.NonEmpty Text) -- ^ referenced columns + -> ForeignKeyAction -- ^ ON UPDATE action + -> ForeignKeyAction -- ^ ON DELETE action + -> EntityModification (CheckedDatabaseEntity be db) be (TableEntity localTbl) +addTableForeignKey refTableEntity getLocalFk getRefFk onUpdate onDelete = + EntityModification $ Endo $ + \(CheckedDatabaseEntity (CheckedDatabaseTable dt tblChecks fieldChecks) extraChecks) -> + let + CheckedDatabaseEntity (CheckedDatabaseTable refDt _ _) _ = refTableEntity + refTableName = QualifiedName (dbTableSchema refDt) (dbTableCurrentName refDt) + + localCols = getLocalFk (dbTableSettings dt) + refCols = getRefFk (dbTableSettings refDt) + + fkCheck = TableCheck $ \tblNm _flds -> + Just (SomeDatabasePredicate + (TableHasForeignKey tblNm localCols refTableName refCols onUpdate onDelete)) + + in CheckedDatabaseEntity (CheckedDatabaseTable dt (tblChecks ++ [fkCheck]) fieldChecks) + extraChecks + -- | Produce a table field modification that does nothing -- -- Most commonly supplied as the second argument to 'modifyCheckedTable' when 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.4.0 +version: 0.5.5.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 @@ -45,6 +45,8 @@ Database.Beam.Migrate.Simple + Database.Beam.Migrate.TempTable + Database.Beam.Haskell.Syntax other-modules: Database.Beam.Migrate.Generics.Types @@ -73,7 +75,7 @@ pretty >=1.1 && <1.2, dependent-map >=0.2 && <0.5, dependent-sum >=0.4 && <0.8, - pqueue >=1.3 && <1.7, + pqueue >=1.3 && <1.8, uuid-types >=1.0 && <1.1 default-language: Haskell2010 default-extensions: KindSignatures, OverloadedStrings, TypeFamilies, FlexibleContexts,