diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 181def641..8d6ec1613 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent-postgresql +# 2.14.3.0 + +* [#1616](https://github.com/yesodweb/persistent/pull/1616) + * Allow overriding the default cascade option for foreign keys. + # 2.14.2.0 * [#1614](https://github.com/yesodweb/persistent/pull/1614) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index c253b870b..226f55e73 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -506,7 +506,7 @@ createBackend logFunc serverVersion smap conn = , connStmtMap = smap , connInsertSql = insertSql' , connClose = PG.close conn - , connMigrateSql = migrate' + , connMigrateSql = migrate' emptyBackendSpecificOverrides , connBegin = \_ mIsolation -> case mIsolation of Nothing -> PG.begin conn Just iso -> @@ -683,11 +683,14 @@ withStmt' conn query vals = Ok v -> return v migrate' - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] CautiousMigration) -migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ migrateStructured allDefs getter entity +migrate' overrides allDefs getter entity = + fmap (fmap $ map showAlterDb) $ + migrateStructured overrides allDefs getter entity -- | Get the SQL string for the table that a PersistEntity represents. -- Useful for raw SQL queries. @@ -821,15 +824,16 @@ defaultPostgresConfHooks = } mockMigrate - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) -mockMigrate allDefs _ entity = +mockMigrate overrides allDefs _ entity = fmap (fmap $ map showAlterDb) $ return $ Right $ - mockMigrateStructured allDefs entity + mockMigrateStructured overrides allDefs entity -- | Mock a migration even when the database is not present. -- This function performs the same functionality of 'printMigration' @@ -852,7 +856,7 @@ mockMigration mig = do , connInsertSql = undefined , connStmtMap = smap , connClose = undefined - , connMigrateSql = mockMigrate + , connMigrateSql = mockMigrate emptyBackendSpecificOverrides , connBegin = undefined , connCommit = undefined , connRollback = undefined diff --git a/persistent-postgresql/Database/Persist/Postgresql/Internal/Migration.hs b/persistent-postgresql/Database/Persist/Postgresql/Internal/Migration.hs index 321a41445..051244e16 100644 --- a/persistent-postgresql/Database/Persist/Postgresql/Internal/Migration.hs +++ b/persistent-postgresql/Database/Persist/Postgresql/Internal/Migration.hs @@ -39,12 +39,13 @@ import qualified Database.Persist.Sql.Util as Util -- -- @since 2.17.1.0 migrateStructured - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [AlterDB]) -migrateStructured allDefs getter entity = - migrateEntitiesStructured getter allDefs [entity] +migrateStructured overrides allDefs getter entity = + migrateEntitiesStructured overrides getter allDefs [entity] -- | Returns a structured representation of all of the DB changes required to -- migrate the listed entities from their current state in the database to the @@ -54,15 +55,16 @@ migrateStructured allDefs getter entity = -- -- @since 2.14.1.0 migrateEntitiesStructured - :: (Text -> IO Statement) + :: BackendSpecificOverrides + -> (Text -> IO Statement) -> [EntityDef] -> [EntityDef] -> IO (Either [Text] [AlterDB]) -migrateEntitiesStructured getStmt allDefs defsToMigrate = do +migrateEntitiesStructured overrides getStmt allDefs defsToMigrate = do r <- collectSchemaState getStmt (map getEntityDBName defsToMigrate) pure $ case r of Right schemaState -> - migrateEntitiesFromSchemaState schemaState allDefs defsToMigrate + migrateEntitiesFromSchemaState overrides schemaState allDefs defsToMigrate Left err -> Left [err] @@ -73,11 +75,12 @@ migrateEntitiesStructured getStmt allDefs defsToMigrate = do -- -- @since 2.17.1.0 mockMigrateStructured - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> EntityDef -> [AlterDB] -mockMigrateStructured allDefs entity = - migrateEntityFromSchemaState EntityDoesNotExist allDefs entity +mockMigrateStructured overrides allDefs entity = + migrateEntityFromSchemaState overrides EntityDoesNotExist allDefs entity -- | In order to ensure that generating migrations is fast and avoids N+1 -- queries, we split it into two phases. The first phase involves querying the @@ -532,11 +535,12 @@ mapLeft _ (Right x) = Right x mapLeft f (Left x) = Left (f x) migrateEntitiesFromSchemaState - :: SchemaState + :: BackendSpecificOverrides + -> SchemaState -> [EntityDef] -> [EntityDef] -> Either [Text] [AlterDB] -migrateEntitiesFromSchemaState (SchemaState schemaStateMap) allDefs defsToMigrate = +migrateEntitiesFromSchemaState overrides (SchemaState schemaStateMap) allDefs defsToMigrate = let go :: EntityDef -> Either Text [AlterDB] go entity = do @@ -544,7 +548,7 @@ migrateEntitiesFromSchemaState (SchemaState schemaStateMap) allDefs defsToMigrat name = getEntityDBName entity case Map.lookup name schemaStateMap of Just entityState -> - Right $ migrateEntityFromSchemaState entityState allDefs entity + Right $ migrateEntityFromSchemaState overrides entityState allDefs entity Nothing -> Left $ T.pack $ "No entry for entity in schemaState: " <> show name in @@ -553,11 +557,12 @@ migrateEntitiesFromSchemaState (SchemaState schemaStateMap) allDefs defsToMigrat (errs, _) -> Left errs migrateEntityFromSchemaState - :: EntitySchemaState + :: BackendSpecificOverrides + -> EntitySchemaState -> [EntityDef] -> EntityDef -> [AlterDB] -migrateEntityFromSchemaState schemaState allDefs entity = +migrateEntityFromSchemaState overrides schemaState allDefs entity = case schemaState of EntityDoesNotExist -> (addTable newcols entity) : uniques ++ references ++ foreignsAlt @@ -577,7 +582,7 @@ migrateEntityFromSchemaState schemaState allDefs entity = acs' ++ ats' where name = getEntityDBName entity - (newcols', udefs, fdefs) = postgresMkColumns allDefs entity + (newcols', udefs, fdefs) = postgresMkColumns overrides allDefs entity newcols = filter (not . safeToRemove entity . cName) newcols' udspair = map udToPair udefs @@ -822,10 +827,13 @@ refName (EntityNameDB table) (FieldNameDB column) = | otherwise = shortenNames overhead (x, y - 1) postgresMkColumns - :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -postgresMkColumns allDefs t = + :: BackendSpecificOverrides + -> [EntityDef] + -> EntityDef + -> ([Column], [UniqueDef], [ForeignDef]) +postgresMkColumns overrides allDefs t = mkColumns allDefs t $ - setBackendSpecificForeignKeyName refName emptyBackendSpecificOverrides + setBackendSpecificForeignKeyName refName overrides -- | Check if a column name is listed as the "safe to remove" in the entity -- list. diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 9b2c9ee85..8314c528d 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.14.2.0 +version: 2.14.3.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -28,7 +28,7 @@ library , file-embed >=0.0.16 , monad-logger >=0.3.25 , mtl - , persistent >=2.18 && <3 + , persistent >=2.18.1 && <3 , postgresql-libpq >=0.9.4.2 && <0.12 , postgresql-simple >=0.6.1 && <0.8 , postgresql-simple-interval >=1 && <1.1 diff --git a/persistent-postgresql/test/MigrationSpec.hs b/persistent-postgresql/test/MigrationSpec.hs index 7600d06cc..e4fa141dc 100644 --- a/persistent-postgresql/test/MigrationSpec.hs +++ b/persistent-postgresql/test/MigrationSpec.hs @@ -585,7 +585,12 @@ spec = describe "MigrationSpec" $ do getter <- getStmtGetter result <- - liftIO $ migrateEntitiesStructured getter allEntityDefs allEntityDefs + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + allEntityDefs + allEntityDefs cleanDB @@ -602,7 +607,12 @@ spec = describe "MigrationSpec" $ do getter <- getStmtGetter result <- - liftIO $ migrateEntitiesStructured getter allEntityDefs allEntityDefs + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + allEntityDefs + allEntityDefs cleanDB @@ -614,7 +624,12 @@ spec = describe "MigrationSpec" $ do Right alters -> do traverse_ (flip rawExecute [] . snd . showAlterDb) alters result2 <- - liftIO $ migrateEntitiesStructured getter allEntityDefs allEntityDefs + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + allEntityDefs + allEntityDefs result2 `shouldBe` Right [] it "suggests FK constraints for new fields first time" $ runConnAssert $ do @@ -624,6 +639,7 @@ spec = describe "MigrationSpec" $ do result <- liftIO $ migrateEntitiesStructured + emptyBackendSpecificOverrides getter (fkChildV2EntityDef : allEntityDefs) [fkChildV2EntityDef] @@ -640,3 +656,32 @@ spec = describe "MigrationSpec" $ do `shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL" , "ALTER TABLE \"migration_fk_child\" ADD CONSTRAINT \"migration_fk_child_parent_id_fkey\" FOREIGN KEY(\"parent_id\") REFERENCES \"migration_fk_parent\"(\"id\") ON DELETE RESTRICT ON UPDATE RESTRICT" ] + + it "Uses overrides for empty cascade action" $ runConnAssert $ do + migrateManually + + getter <- getStmtGetter + + let + overrideWithDefault = + setBackendSpecificForeignKeyCascadeDefault Cascade emptyBackendSpecificOverrides + result <- + liftIO $ + migrateEntitiesStructured + overrideWithDefault + getter + (fkChildV2EntityDef : allEntityDefs) + [fkChildV2EntityDef] + + cleanDB + + case result of + Right [] -> + pure () + Left err -> + expectationFailure $ show err + Right alters -> + map (snd . showAlterDb) alters + `shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL" + , "ALTER TABLE \"migration_fk_child\" ADD CONSTRAINT \"migration_fk_child_parent_id_fkey\" FOREIGN KEY(\"parent_id\") REFERENCES \"migration_fk_parent\"(\"id\") ON DELETE CASCADE ON UPDATE CASCADE" + ] diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index e0c208d03..a7703759e 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,6 +1,8 @@ # Changelog for persistent -# Unreleased +# 2.18.1.0 +* [#1616](https://github.com/yesodweb/persistent/pull/1616) + * Allow overriding the default cascade option for foreign keys. * [#1608](https://github.com/yesodweb/persistent/pull/1608) * Improves documentation on getBy with nullable fields * Updates the warning text present when you try to make a Unique field that is nullable diff --git a/persistent/Database/Persist/Sql.hs b/persistent/Database/Persist/Sql.hs index e450cf9e5..76de6661b 100644 --- a/persistent/Database/Persist/Sql.hs +++ b/persistent/Database/Persist/Sql.hs @@ -61,6 +61,8 @@ module Database.Persist.Sql , emptyBackendSpecificOverrides , getBackendSpecificForeignKeyName , setBackendSpecificForeignKeyName + , getBackendSpecificForeignKeyCascadeDefault + , setBackendSpecificForeignKeyCascadeDefault , defaultAttribute -- * Internal diff --git a/persistent/Database/Persist/Sql/Internal.hs b/persistent/Database/Persist/Sql/Internal.hs index 8aa6adfa0..3b3f7beae 100644 --- a/persistent/Database/Persist/Sql/Internal.hs +++ b/persistent/Database/Persist/Sql/Internal.hs @@ -10,6 +10,8 @@ module Database.Persist.Sql.Internal , BackendSpecificOverrides (..) , getBackendSpecificForeignKeyName , setBackendSpecificForeignKeyName + , getBackendSpecificForeignKeyCascadeDefault + , setBackendSpecificForeignKeyCascadeDefault , emptyBackendSpecificOverrides ) where @@ -36,6 +38,7 @@ import Database.Persist.Types data BackendSpecificOverrides = BackendSpecificOverrides { backendSpecificForeignKeyName :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB) + , backendSpecificForeignKeyCascadeDefault :: CascadeAction } -- | If the override is defined, then this returns a function that accepts an @@ -61,6 +64,26 @@ setBackendSpecificForeignKeyName setBackendSpecificForeignKeyName func bso = bso{backendSpecificForeignKeyName = Just func} +-- | If the override is defined, then this specifies what cascade action +-- should be used if there is none defined for the column. +-- +-- @since 2.18.1.0 +getBackendSpecificForeignKeyCascadeDefault + :: BackendSpecificOverrides + -> CascadeAction +getBackendSpecificForeignKeyCascadeDefault = + backendSpecificForeignKeyCascadeDefault + +-- | Set the backend's default cascade action. +-- +-- @since 2.18.1.0 +setBackendSpecificForeignKeyCascadeDefault + :: CascadeAction + -> BackendSpecificOverrides + -> BackendSpecificOverrides +setBackendSpecificForeignKeyCascadeDefault action bso = + bso{backendSpecificForeignKeyCascadeDefault = action} + findMaybe :: (a -> Maybe b) -> [a] -> Maybe b findMaybe p = listToMaybe . mapMaybe p @@ -68,7 +91,7 @@ findMaybe p = listToMaybe . mapMaybe p -- -- @since 2.11 emptyBackendSpecificOverrides :: BackendSpecificOverrides -emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing +emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing Restrict defaultAttribute :: [FieldAttr] -> Maybe Text defaultAttribute = findMaybe $ \case @@ -171,9 +194,11 @@ mkColumns allDefs t overrides = -- explicitly makes migrations run smoother. overrideNothings (FieldCascade{fcOnUpdate = upd, fcOnDelete = del}) = FieldCascade - { fcOnUpdate = upd <|> Just Restrict - , fcOnDelete = del <|> Just Restrict + { fcOnUpdate = upd <|> Just defaultAction + , fcOnDelete = del <|> Just defaultAction } + where + defaultAction = (backendSpecificForeignKeyCascadeDefault overrides) ref :: FieldNameDB diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 8db185165..d30976467 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.18.0.0 +version: 2.18.1.0 license: MIT license-file: LICENSE author: Michael Snoyman