yesodweb · parsonsmatt · Jan 14, 2026 · Jul 1, 2025 · Jul 1, 2025 · Jul 1, 2025
diff --git 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
@@ -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
@@ -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,19 +535,20 @@ 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
             let
                 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
@@ -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 <michael@snoyman.com>
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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,14 +64,34 @@ 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
 
 -- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides)
 --
 -- @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
@@ -1,5 +1,5 @@
 name:               persistent
-version:            2.18.0.0
+version:            2.18.1.0
 license:            MIT
 license-file:       LICENSE
 author:             Michael Snoyman <michael@snoyman.com>