From 40a23f2391712829d0248a07e3fb012d260e8613 Mon Sep 17 00:00:00 2001
From: kderme <k.dermenz@gmail.com>
Date: Thu, 19 Mar 2020 23:01:31 +0200
Subject: [PATCH 01/12] Enable On Delete and On Update cascading actions

---
 persistent-sqlite/Database/Persist/Sqlite.hs | 14 ++++-
 persistent-template/Database/Persist/TH.hs   |  8 ++-
 persistent/Database/Persist/Quasi.hs         | 61 +++++++++++++-------
 persistent/Database/Persist/Types/Base.hs    |  5 ++
 4 files changed, 65 insertions(+), 23 deletions(-)

diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs
index da83c6fff..e9fd961ea 100644
--- a/persistent-sqlite/Database/Persist/Sqlite.hs
+++ b/persistent-sqlite/Database/Persist/Sqlite.hs
@@ -580,7 +580,7 @@ sqlColumn noRef (Column name isNull typ def _cn _maxLen ref) = T.concat
     ]
 
 sqlForeign :: ForeignDef -> Text
-sqlForeign fdef = T.concat
+sqlForeign fdef = T.concat $
     [ ", CONSTRAINT "
     , escape $ foreignConstraintNameDBName fdef
     , " FOREIGN KEY("
@@ -590,7 +590,17 @@ sqlForeign fdef = T.concat
     , "("
     , T.intercalate "," $ map (escape . snd . snd) $ foreignFields fdef
     , ")"
-    ]
+    ] ++ onDelete ++ onUpdate
+  where
+    onDelete = fmap (T.append " ON DELETE ") $ showAction $ foreignOnDelete fdef
+    onUpdate = fmap (T.append " ON UPDATE ") $ showAction $ foreignOnUpdate fdef
+
+    showAction action = case action of
+      Nothing         -> []
+      Just Cascade    -> ["CASCADE"]
+      Just Restrict   -> ["RESTRICT"]
+      Just SetNull    -> ["SET NULL"]
+      Just SetDefault -> ["SET DEFAULT"]
 
 sqlUnique :: UniqueDef -> Text
 sqlUnique (UniqueDef _ cname cols _) = T.concat
diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs
index 1cea0d99b..c8fd0eccb 100644
--- a/persistent-template/Database/Persist/TH.hs
+++ b/persistent-template/Database/Persist/TH.hs
@@ -1666,7 +1666,13 @@ instance Lift CompositeDef where
     lift (CompositeDef a b) = [|CompositeDef a b|]
 
 instance Lift ForeignDef where
-    lift (ForeignDef a b c d e f g) = [|ForeignDef a b c d e f g|]
+    lift (ForeignDef a b c d e f g h i) = [|ForeignDef a b c d e f g h i|]
+
+instance Lift CascadeAction where
+    lift Cascade = [|Cascade|]
+    lift Restrict = [|Restrict|]
+    lift SetNull = [|SetNull|]
+    lift SetDefault = [|SetDefault|]
 
 instance Lift HaskellName where
     lift (HaskellName t) = [|HaskellName t|]
diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs
index e9158c126..6226c8021 100644
--- a/persistent/Database/Persist/Quasi.hs
+++ b/persistent/Database/Persist/Quasi.hs
@@ -272,6 +272,7 @@ import Data.Monoid (mappend)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Database.Persist.Types
+import Text.Read (readEither)
 
 data ParseState a = PSDone | PSFail String | PSSuccess a Text deriving Show
 
@@ -908,28 +909,48 @@ takeForeign :: PersistSettings
           -> [FieldDef]
           -> [Text]
           -> UnboundForeignDef
-takeForeign ps tableName _defs (refTableName:n:rest)
-    | not (T.null n) && isLower (T.head n)
-        = UnboundForeignDef fields $ ForeignDef
-            { foreignRefTableHaskell =
-                HaskellName refTableName
-            , foreignRefTableDBName =
-                DBName $ psToDBName ps refTableName
-            , foreignConstraintNameHaskell =
-                HaskellName n
-            , foreignConstraintNameDBName =
-                DBName $ psToDBName ps (tableName `T.append` n)
-            , foreignFields =
-                []
-            , foreignAttrs =
-                attrs
-            , foreignNullable =
-                False
-            }
+takeForeign ps tableName _defs = takeRefTable
   where
-    (fields,attrs) = break ("!" `T.isPrefixOf`) rest
+    errorPrefix :: String
+    errorPrefix = "invalid foreign key constraint on table[" ++ show tableName ++ "] "
 
-takeForeign _ tableName _ xs = error $ "invalid foreign key constraint on table[" ++ show tableName ++ "] expecting a lower case constraint name xs=" ++ show xs
+    takeRefTable :: [Text] -> UnboundForeignDef
+    takeRefTable [] = error $ errorPrefix ++ " expecting foreign table name"
+    takeRefTable (refTableName:restLine) = go restLine Nothing Nothing
+      where
+        go :: [Text] -> Maybe CascadeAction -> Maybe CascadeAction -> UnboundForeignDef
+        go (n:rest) onDelete onUpdate | not (T.null n) && isLower (T.head n)
+            = UnboundForeignDef fields $ ForeignDef
+                { foreignRefTableHaskell =
+                    HaskellName refTableName
+                , foreignRefTableDBName =
+                    DBName $ psToDBName ps refTableName
+                , foreignConstraintNameHaskell =
+                    HaskellName n
+                , foreignConstraintNameDBName =
+                    DBName $ psToDBName ps (tableName `T.append` n)
+                , foreignOnDelete = onDelete
+                , foreignOnUpdate = onUpdate
+                , foreignFields =
+                    []
+                , foreignAttrs =
+                    attrs
+                , foreignNullable =
+                    False
+                }
+          where
+            (fields,attrs) = break ("!" `T.isPrefixOf`) rest
+        go ((T.stripPrefix "OnDelete" -> Just onDelete) : rest) onDelete' onUpdate
+          = case (onDelete', readEither $ T.unpack onDelete) of
+            (Nothing, Right cascadingAction) -> go rest (Just cascadingAction) onUpdate
+            (Nothing, Left _) -> error $ errorPrefix ++ "could not parse OnDelete action"
+            (Just _, _)  -> error $ errorPrefix ++ "found more than one OnDelete actions"
+        go ((T.stripPrefix "OnUpdate" -> Just onUpdate) : rest) onDelete onUpdate'
+          = case (onUpdate', readEither $ T.unpack onUpdate) of
+            (Nothing, Right cascadingAction) -> go rest onDelete (Just cascadingAction)
+            (Nothing, Left _) -> error $ errorPrefix ++ "could not parse OnUpdate action"
+            (Just _, _)  -> error $ errorPrefix ++ "found more than one OnUpdate actions"
+        go xs _ _ = error $ errorPrefix ++ "expecting a lower case constraint name or a cascading action xs=" ++ show xs
 
 takeDerives :: [Text] -> Maybe [Text]
 takeDerives ("deriving":rest) = Just rest
diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs
index f8a08342e..62277148e 100644
--- a/persistent/Database/Persist/Types/Base.hs
+++ b/persistent/Database/Persist/Types/Base.hs
@@ -295,12 +295,17 @@ data ForeignDef = ForeignDef
     , foreignRefTableDBName        :: !DBName
     , foreignConstraintNameHaskell :: !HaskellName
     , foreignConstraintNameDBName  :: !DBName
+    , foreignOnDelete              :: !(Maybe CascadeAction)
+    , foreignOnUpdate              :: !(Maybe CascadeAction)
     , foreignFields                :: ![(ForeignFieldDef, ForeignFieldDef)] -- this entity plus the primary entity
     , foreignAttrs                 :: ![Attr]
     , foreignNullable              :: Bool
     }
     deriving (Show, Eq, Read, Ord)
 
+data CascadeAction = Cascade | Restrict | SetNull | SetDefault
+    deriving (Show, Eq, Read, Ord)
+
 data PersistException
   = PersistError Text -- ^ Generic Exception
   | PersistMarshalError Text

From 2f0a2ea703f2c48c3450d60977f18dacd1e88383 Mon Sep 17 00:00:00 2001
From: kderme <k.dermenz@gmail.com>
Date: Thu, 19 Mar 2020 23:04:10 +0200
Subject: [PATCH 02/12] Test foreign key options at SQLite

---
 persistent-sqlite/test/main.hs        |  3 ++
 persistent-test/persistent-test.cabal |  1 +
 persistent-test/src/ForeignKey.hs     | 66 +++++++++++++++++++++++++++
 3 files changed, 70 insertions(+)
 create mode 100644 persistent-test/src/ForeignKey.hs

diff --git a/persistent-sqlite/test/main.hs b/persistent-sqlite/test/main.hs
index 190a848e8..0ed27412d 100644
--- a/persistent-sqlite/test/main.hs
+++ b/persistent-sqlite/test/main.hs
@@ -22,6 +22,7 @@ import qualified EmptyEntityTest
 import qualified EmbedOrderTest
 import qualified EmbedTest
 import qualified EquivalentTypeTest
+import qualified ForeignKey
 import qualified HtmlTest
 import qualified LargeNumberTest
 import qualified MaxLenTest
@@ -141,6 +142,7 @@ main = do
       , MaxLenTest.maxlenMigrate
       , Recursive.recursiveMigrate
       , CompositeTest.compositeMigrate
+      , ForeignKey.compositeMigrate
       , MigrationTest.migrationMigrate
       , PersistUniqueTest.migration
       , RenameTest.migration
@@ -205,6 +207,7 @@ main = do
     CustomPrimaryKeyReferenceTest.specsWith db
     MigrationColumnLengthTest.specsWith db
     EquivalentTypeTest.specsWith db
+    ForeignKey.specsWith db
     TransactionLevelTest.specsWith db
     MigrationTest.specsWith db
 
diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal
index 363fa6bfa..d2f665aef 100644
--- a/persistent-test/persistent-test.cabal
+++ b/persistent-test/persistent-test.cabal
@@ -24,6 +24,7 @@ library
                      EmptyEntityTest
                      EntityEmbedTest
                      EquivalentTypeTest
+                     ForeignKey
                      HtmlTest
                      Init
                      LargeNumberTest
diff --git a/persistent-test/src/ForeignKey.hs b/persistent-test/src/ForeignKey.hs
new file mode 100644
index 000000000..756952358
--- /dev/null
+++ b/persistent-test/src/ForeignKey.hs
@@ -0,0 +1,66 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE UndecidableInstances #-}
+module ForeignKey where
+
+import Init
+
+-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs
+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "compositeMigrate"] [persistLowerCase|
+  Parent
+    name String
+    Primary name
+
+  Child
+    pname String
+    Foreign Parent OnDeleteCascade OnUpdateCascade fkparent pname
+    deriving Show Eq
+
+  ParentComposite
+    name String
+    lastName String
+    Primary name lastName
+
+  ChildComposite
+    pname String
+    plastName String
+    Foreign ParentComposite OnDeleteCascade fkparent pname plastName
+    deriving Show Eq
+
+  SelfReferenced
+    name String
+    pname String
+    Primary name
+    Foreign SelfReferenced OnDeleteCascade fkparent pname
+    deriving Show Eq
+|]
+
+specsWith :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec
+specsWith runDb = describe "foreign keys options" $ do
+  it "delete cascades" $ runDb $ do
+    kf <- insert $ Parent "A"
+    kc <- insert $ Child "A"
+    delete kf
+    cs <- selectList [] []
+    let expected = [] :: [Entity Child]
+    cs @== expected
+  it "update cascades" $ runDb $ do
+    kf <- insert $ Parent "A"
+    kc <- insert $ Child "A"
+    update kf [ParentName =. "B"]
+    cs <- selectList [] []
+    fmap (childPname . entityVal) cs @== ["B"]
+  it "delete Composite cascades" $ runDb $ do
+    kf <- insert $ ParentComposite "A" "B"
+    kc <- insert $ ChildComposite "A" "B"
+    delete kf
+    cs <- selectList [] []
+    let expected = [] :: [Entity ChildComposite]
+    cs @== expected
+  it "delete self referenced cascades" $ runDb $ do
+    kf <- insert $ SelfReferenced "A" "A" -- bootstrap self reference
+    kc <- insert $ SelfReferenced "B" "A"
+    delete kf
+    srs <- selectList [] []
+    let expected = [] :: [Entity SelfReferenced]
+    srs @== expected

From 5e167ff06266236472cb1ef8854f94bfbfa6552d Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 12:53:41 -0600
Subject: [PATCH 03/12] add postgres test

---
 persistent-postgresql/test/main.hs | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/persistent-postgresql/test/main.hs b/persistent-postgresql/test/main.hs
index 88d93a853..4917813f6 100644
--- a/persistent-postgresql/test/main.hs
+++ b/persistent-postgresql/test/main.hs
@@ -23,6 +23,7 @@ import Test.QuickCheck
 -- FIXME: should probably be used?
 -- import qualified ArrayAggTest
 import qualified CompositeTest
+import qualified ForeignKey
 import qualified CustomPersistFieldTest
 import qualified CustomPrimaryKeyReferenceTest
 import qualified DataTypeTest
@@ -118,6 +119,7 @@ main = do
       , CustomPrimaryKeyReferenceTest.migration
       , MigrationColumnLengthTest.migration
       , TransactionLevelTest.migration
+      , ForeignKey.compositeMigrate
       ]
     PersistentTest.cleanDB
 
@@ -147,6 +149,7 @@ main = do
     EmbedTest.specsWith db
     EmbedOrderTest.specsWith db
     LargeNumberTest.specsWith db
+    ForeignKey.specsWith db
     UniqueTest.specsWith db
     MaxLenTest.specsWith db
     Recursive.specsWith db

From 67c5659ee7e03b572e111c58c3bcdba9b39c67b1 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 13:05:48 -0600
Subject: [PATCH 04/12] refactor

---
 .../Database/Persist/Postgresql.hs            | 23 +++++++++++++------
 1 file changed, 16 insertions(+), 7 deletions(-)

diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs
index a898df2ca..1a10c6d8c 100644
--- a/persistent-postgresql/Database/Persist/Postgresql.hs
+++ b/persistent-postgresql/Database/Persist/Postgresql.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 -- | A postgresql backend for persistent.
 module Database.Persist.Postgresql
@@ -592,9 +593,13 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do
       where
         uniques = flip concatMap udspair $ \(uname, ucols) ->
                 [AlterTable name $ AddUniqueConstraint uname ucols]
-        references = mapMaybe (\c@Column { cName=cname, cReference=Just (refTblName, _) } ->
-            getAddReference allDefs name refTblName cname (cReference c))
-                   $ filter (isJust . cReference) newcols
+        references =
+            mapMaybe
+                (\Column { cName, cReference } ->
+                    cReference >>= \(refTblName, _) ->
+                        getAddReference allDefs name refTblName cName cReference
+                )
+                newcols
         foreignsAlt = flip map fdefs (\fdef ->
             let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))
             in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields (map escape parentfields)))
@@ -768,7 +773,7 @@ getAlters defs def (c1, u1) (c2, u2) =
 
 getColumn :: (Text -> IO Statement)
           -> DBName -> [PersistValue]
-          -> Maybe (DBName, DBName) 
+          -> Maybe (DBName, DBName)
           -> IO (Either Text Column)
 getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName =
     case d' of
@@ -1200,9 +1205,13 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do
       where
         uniques = flip concatMap udspair $ \(uname, ucols) ->
                 [AlterTable name $ AddUniqueConstraint uname ucols]
-        references = mapMaybe (\c@Column { cName=cname, cReference=Just (refTblName, _) } ->
-            getAddReference allDefs name refTblName cname (cReference c))
-                   $ filter (isJust . cReference) newcols
+        references =
+            mapMaybe
+                (\Column { cName, cReference } ->
+                    cReference >>= \(refTblName, _) ->
+                        getAddReference allDefs name refTblName cName cReference
+                )
+                $ newcols
         foreignsAlt = flip map fdefs (\fdef ->
             let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))
             in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields (map escape parentfields)))

From 25b0f6a4aa1747e828e87debbe978654d83e62cf Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 13:12:29 -0600
Subject: [PATCH 05/12] refactor getAddReference

---
 .../Database/Persist/Postgresql.hs            | 30 ++++++++++---------
 1 file changed, 16 insertions(+), 14 deletions(-)

diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs
index 1a10c6d8c..1e8e97aeb 100644
--- a/persistent-postgresql/Database/Persist/Postgresql.hs
+++ b/persistent-postgresql/Database/Persist/Postgresql.hs
@@ -596,8 +596,8 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do
         references =
             mapMaybe
                 (\Column { cName, cReference } ->
-                    cReference >>= \(refTblName, _) ->
-                        getAddReference allDefs name refTblName cName cReference
+                    flip fmap cReference $ \cref ->
+                        getAddReference allDefs name cName cref
                 )
                 newcols
         foreignsAlt = flip map fdefs (\fdef ->
@@ -936,16 +936,18 @@ findAlters defs _tablename col@(Column name isNull sqltype def _defConstraintNam
                  filter (\c -> cName c /= name) cols)
 
 -- | Get the references to be added to a table for the given column.
-getAddReference :: [EntityDef] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB
-getAddReference allDefs table reftable cname ref =
-    case ref of
-        Nothing -> Nothing
-        Just (s, constraintName) -> Just $ AlterColumn table (s, AddReference constraintName [cname] id_)
-                          where
-                            id_ = fromMaybe (error $ "Could not find ID of entity " ++ show reftable)
-                                        $ do
-                                          entDef <- find ((== reftable) . entityDB) allDefs
-                                          return $ Util.dbIdColumnsEsc escape entDef
+getAddReference :: [EntityDef] -> DBName -> DBName -> (DBName, DBName) -> AlterDB
+getAddReference allDefs table cname (s, constraintName) =
+    AlterColumn
+        table
+        (s, AddReference constraintName [cname] id_)
+  where
+    id_ =
+        fromMaybe
+            (error $ "Could not find ID of entity " ++ show s)
+            $ do
+                entDef <- find ((== s) . entityDB) allDefs
+                return $ Util.dbIdColumnsEsc escape entDef
 
 
 showColumn :: Column -> Text
@@ -1208,8 +1210,8 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do
         references =
             mapMaybe
                 (\Column { cName, cReference } ->
-                    cReference >>= \(refTblName, _) ->
-                        getAddReference allDefs name refTblName cName cReference
+                    flip fmap cReference $ \cref ->
+                        getAddReference allDefs name cName cref
                 )
                 $ newcols
         foreignsAlt = flip map fdefs (\fdef ->

From daf8437c377f1f3cda78dd520f577b3149992bc0 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 13:55:12 -0600
Subject: [PATCH 06/12] refactor to field cascade

---
 .../Database/Persist/Postgresql.hs            | 26 ++++++++++++++-----
 persistent-sqlite/Database/Persist/Sqlite.hs  | 22 +++++++++-------
 persistent-template/Database/Persist/TH.hs    |  5 +++-
 persistent/Database/Persist/Quasi.hs          |  6 +++--
 persistent/Database/Persist/Types/Base.hs     | 16 ++++++++++--
 5 files changed, 55 insertions(+), 20 deletions(-)

diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs
index 1e8e97aeb..022f50eec 100644
--- a/persistent-postgresql/Database/Persist/Postgresql.hs
+++ b/persistent-postgresql/Database/Persist/Postgresql.hs
@@ -600,9 +600,25 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do
                         getAddReference allDefs name cName cref
                 )
                 newcols
-        foreignsAlt = flip map fdefs (\fdef ->
-            let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))
-            in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields (map escape parentfields)))
+        foreignsAlt = map (mkForeignAlt name) fdefs
+
+mkForeignAlt
+    :: DBName
+    -> ForeignDef
+    -> AlterDB
+mkForeignAlt name fdef =
+    AlterColumn
+        name
+        ( foreignRefTableDBName fdef
+        , AddReference constraintName childfields escapedParentFields
+        )
+  where
+    constraintName =
+        foreignConstraintNameDBName fdef
+    (childfields, parentfields) =
+        unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))
+    escapedParentFields =
+        map escape parentfields
 
 addTable :: [Column] -> EntityDef -> AlterDB
 addTable cols entity = AddTable $ T.concat
@@ -1214,9 +1230,7 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do
                         getAddReference allDefs name cName cref
                 )
                 $ newcols
-        foreignsAlt = flip map fdefs (\fdef ->
-            let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef))
-            in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields (map escape parentfields)))
+        foreignsAlt = map (mkForeignAlt name) fdefs
 
 -- | Mock a migration even when the database is not present.
 -- This function performs the same functionality of 'printMigration'
diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs
index e9fd961ea..631e50ca5 100644
--- a/persistent-sqlite/Database/Persist/Sqlite.hs
+++ b/persistent-sqlite/Database/Persist/Sqlite.hs
@@ -53,6 +53,7 @@ import Control.Monad.Logger (NoLoggingT, runNoLoggingT, MonadLogger, logWarn, ru
 import Control.Monad.Trans.Reader (ReaderT, runReaderT, withReaderT)
 import Control.Monad.Trans.Writer (runWriterT)
 import Data.Acquire (Acquire, mkAcquire, with)
+import Data.Maybe
 import Data.Aeson
 import Data.Aeson.Types (modifyFailure)
 import Data.Conduit
@@ -592,15 +593,18 @@ sqlForeign fdef = T.concat $
     , ")"
     ] ++ onDelete ++ onUpdate
   where
-    onDelete = fmap (T.append " ON DELETE ") $ showAction $ foreignOnDelete fdef
-    onUpdate = fmap (T.append " ON UPDATE ") $ showAction $ foreignOnUpdate fdef
-
-    showAction action = case action of
-      Nothing         -> []
-      Just Cascade    -> ["CASCADE"]
-      Just Restrict   -> ["RESTRICT"]
-      Just SetNull    -> ["SET NULL"]
-      Just SetDefault -> ["SET DEFAULT"]
+    onDelete =
+        fmap (T.append " ON DELETE ")
+        $ showAction
+        $ fcOnDelete
+        $ foreignFieldCascade fdef
+    onUpdate =
+        fmap (T.append " ON UPDATE ")
+        $ showAction
+        $ fcOnUpdate
+        $ foreignFieldCascade fdef
+
+    showAction = maybeToList . fmap renderCascadeAction
 
 sqlUnique :: UniqueDef -> Text
 sqlUnique (UniqueDef _ cname cols _) = T.concat
diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs
index c8fd0eccb..360224c48 100644
--- a/persistent-template/Database/Persist/TH.hs
+++ b/persistent-template/Database/Persist/TH.hs
@@ -1666,7 +1666,10 @@ instance Lift CompositeDef where
     lift (CompositeDef a b) = [|CompositeDef a b|]
 
 instance Lift ForeignDef where
-    lift (ForeignDef a b c d e f g h i) = [|ForeignDef a b c d e f g h i|]
+    lift (ForeignDef a b c d e f g h) = [|ForeignDef a b c d e f g h|]
+
+instance Lift FieldCascade where
+    lift (FieldCascade a b) = [|FieldCascade a b|]
 
 instance Lift CascadeAction where
     lift Cascade = [|Cascade|]
diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs
index 6226c8021..1a60a3b24 100644
--- a/persistent/Database/Persist/Quasi.hs
+++ b/persistent/Database/Persist/Quasi.hs
@@ -929,8 +929,10 @@ takeForeign ps tableName _defs = takeRefTable
                     HaskellName n
                 , foreignConstraintNameDBName =
                     DBName $ psToDBName ps (tableName `T.append` n)
-                , foreignOnDelete = onDelete
-                , foreignOnUpdate = onUpdate
+                , foreignFieldCascade = FieldCascade
+                    { fcOnDelete = onDelete
+                    , fcOnUpdate = onUpdate
+                    }
                 , foreignFields =
                     []
                 , foreignAttrs =
diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs
index 62277148e..d792ffa6a 100644
--- a/persistent/Database/Persist/Types/Base.hs
+++ b/persistent/Database/Persist/Types/Base.hs
@@ -295,17 +295,29 @@ data ForeignDef = ForeignDef
     , foreignRefTableDBName        :: !DBName
     , foreignConstraintNameHaskell :: !HaskellName
     , foreignConstraintNameDBName  :: !DBName
-    , foreignOnDelete              :: !(Maybe CascadeAction)
-    , foreignOnUpdate              :: !(Maybe CascadeAction)
+    , foreignFieldCascade          :: !FieldCascade
     , foreignFields                :: ![(ForeignFieldDef, ForeignFieldDef)] -- this entity plus the primary entity
     , foreignAttrs                 :: ![Attr]
     , foreignNullable              :: Bool
     }
     deriving (Show, Eq, Read, Ord)
 
+data FieldCascade = FieldCascade
+    { fcOnUpdate :: !(Maybe CascadeAction)
+    , fcOnDelete :: !(Maybe CascadeAction)
+    }
+    deriving (Show, Eq, Read, Ord)
+
 data CascadeAction = Cascade | Restrict | SetNull | SetDefault
     deriving (Show, Eq, Read, Ord)
 
+renderCascadeAction :: CascadeAction -> Text
+renderCascadeAction action = case action of
+  Cascade    -> "CASCADE"
+  Restrict   -> "RESTRICT"
+  SetNull    -> "SET NULL"
+  SetDefault -> "SET DEFAULT"
+
 data PersistException
   = PersistError Text -- ^ Generic Exception
   | PersistMarshalError Text

From 08f5ace039d16cfd0a5eb8103d16329e94ff858d Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 14:19:39 -0600
Subject: [PATCH 07/12] a bit more plumbing

---
 .../Database/Persist/Postgresql.hs            | 56 +++++++++++++------
 persistent/Database/Persist/Types/Base.hs     | 10 ++++
 2 files changed, 50 insertions(+), 16 deletions(-)

diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs
index 022f50eec..9f4ed2cea 100644
--- a/persistent-postgresql/Database/Persist/Postgresql.hs
+++ b/persistent-postgresql/Database/Persist/Postgresql.hs
@@ -596,8 +596,7 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do
         references =
             mapMaybe
                 (\Column { cName, cReference } ->
-                    flip fmap cReference $ \cref ->
-                        getAddReference allDefs name cName cref
+                    fmap (getAddReference allDefs Nothing name cName) cReference
                 )
                 newcols
         foreignsAlt = map (mkForeignAlt name) fdefs
@@ -610,9 +609,15 @@ mkForeignAlt name fdef =
     AlterColumn
         name
         ( foreignRefTableDBName fdef
-        , AddReference constraintName childfields escapedParentFields
+        , addReference
         )
   where
+    addReference =
+        AddReference
+            constraintName
+            childfields
+            escapedParentFields
+            (foreignFieldCascade fdef)
     constraintName =
         foreignConstraintNameDBName fdef
     (childfields, parentfields) =
@@ -656,10 +661,13 @@ mayDefault def = case def of
 
 type SafeToRemove = Bool
 
-data AlterColumn = ChangeType SqlType Text
-                 | IsNull | NotNull | Add' Column | Drop SafeToRemove
-                 | Default Text | NoDefault | Update' Text
-                 | AddReference DBName [DBName] [Text] | DropReference DBName
+data AlterColumn
+    = ChangeType SqlType Text
+    | IsNull | NotNull | Add' Column | Drop SafeToRemove
+    | Default Text | NoDefault | Update' Text
+    | AddReference DBName [DBName] [Text] FieldCascade
+    | DropReference DBName
+
 type AlterColumn' = (DBName, AlterColumn)
 
 data AlterTable = AddUniqueConstraint DBName [DBName]
@@ -916,8 +924,17 @@ findAlters defs _tablename col@(Column name isNull sqltype def _defConstraintNam
                 refAdd Nothing = []
                 refAdd (Just (tname, a)) =
                     case find ((==tname) . entityDB) defs of
-                        Just refdef -> [(tname, AddReference a [name] (Util.dbIdColumnsEsc escape refdef))]
-                        Nothing -> error $ "could not find the entityDef for reftable[" ++ show tname ++ "]"
+                        Just refdef ->
+                            [ ( tname
+                              , AddReference
+                                    a
+                                    [name]
+                                    (Util.dbIdColumnsEsc escape refdef)
+                                    noCascade
+                              )
+                            ]
+                        Nothing ->
+                            error $ "could not find the entityDef for reftable[" ++ show tname ++ "]"
                 modRef =
                     if fmap snd ref == fmap snd ref'
                         then []
@@ -952,11 +969,19 @@ findAlters defs _tablename col@(Column name isNull sqltype def _defConstraintNam
                  filter (\c -> cName c /= name) cols)
 
 -- | Get the references to be added to a table for the given column.
-getAddReference :: [EntityDef] -> DBName -> DBName -> (DBName, DBName) -> AlterDB
-getAddReference allDefs table cname (s, constraintName) =
+getAddReference
+    :: [EntityDef]
+    -> Maybe ForeignDef
+    -> DBName
+    -> DBName
+    -> (DBName, DBName)
+    -> AlterDB
+getAddReference allDefs mforeignDef table cname (s, constraintName) =
     AlterColumn
         table
-        (s, AddReference constraintName [cname] id_)
+        ( s
+        , AddReference constraintName [cname] id_ (maybe noCascade foreignFieldCascade mforeignDef)
+        )
   where
     id_ =
         fromMaybe
@@ -1089,7 +1114,7 @@ showAlter table (n, Update' s) = T.concat
     , escape n
     , " IS NULL"
     ]
-showAlter table (reftable, AddReference fkeyname t2 id2) = T.concat
+showAlter table (reftable, AddReference fkeyname t2 id2 cascade) = T.concat
     [ "ALTER TABLE "
     , escape table
     , " ADD CONSTRAINT "
@@ -1101,7 +1126,7 @@ showAlter table (reftable, AddReference fkeyname t2 id2) = T.concat
     , "("
     , T.intercalate "," id2
     , ")"
-    ]
+    ] <> renderFieldCascade cascade
 showAlter table (_, DropReference cname) = T.concat
     [ "ALTER TABLE "
     , escape table
@@ -1226,8 +1251,7 @@ mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do
         references =
             mapMaybe
                 (\Column { cName, cReference } ->
-                    flip fmap cReference $ \cref ->
-                        getAddReference allDefs name cName cref
+                    fmap (getAddReference allDefs Nothing name cName) cReference
                 )
                 $ newcols
         foreignsAlt = map (mkForeignAlt name) fdefs
diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs
index d792ffa6a..33b3de453 100644
--- a/persistent/Database/Persist/Types/Base.hs
+++ b/persistent/Database/Persist/Types/Base.hs
@@ -308,6 +308,16 @@ data FieldCascade = FieldCascade
     }
     deriving (Show, Eq, Read, Ord)
 
+noCascade :: FieldCascade
+noCascade = FieldCascade Nothing Nothing
+
+renderFieldCascade :: FieldCascade -> Text
+renderFieldCascade (FieldCascade onUpdate onDelete) =
+    T.unwords
+        [ foldMap (mappend "ON DELETE " . renderCascadeAction) onDelete
+        , foldMap (mappend "ON UPDATE " . renderCascadeAction) onUpdate
+        ]
+
 data CascadeAction = Cascade | Restrict | SetNull | SetDefault
     deriving (Show, Eq, Read, Ord)
 

From a24a802f3ab9e99d93ca4a04af3762f566225b8e Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 14:56:40 -0600
Subject: [PATCH 08/12] ok it works for postgres, sorta

---
 .../Database/Persist/Postgresql.hs            | 32 ++++++++++++-------
 1 file changed, 20 insertions(+), 12 deletions(-)

diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs
index 9f4ed2cea..8f83863b7 100644
--- a/persistent-postgresql/Database/Persist/Postgresql.hs
+++ b/persistent-postgresql/Database/Persist/Postgresql.hs
@@ -567,13 +567,18 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do
   where
     name = entityDB entity
     (newcols', udefs, fdefs) = mkColumns allDefs entity
-    migrationText exists old'' =
-        if not exists
-            then createText newcols fdefs udspair
-            else let (acs, ats) = getAlters allDefs entity (newcols, udspair) $ excludeForeignKeys $ old'
-                     acs' = map (AlterColumn name) acs
-                     ats' = map (AlterTable name) ats
-                 in  acs' ++ ats'
+    migrationText exists old''
+        | not exists =
+            createText newcols fdefs udspair
+        | otherwise =
+            let (acs, ats) =
+                    getAlters allDefs entity (newcols, udspair)
+                    -- $ excludeForeignKeys
+                    $ old'
+                acs' = map (AlterColumn name) acs
+                ats' = map (AlterTable name) ats
+            in
+                acs' ++ ats'
        where
          old' = partitionEithers old''
          newcols = filter (not . safeToRemove entity . cName) newcols'
@@ -777,13 +782,16 @@ getAlters defs def (c1, u1) (c2, u2) =
         let (alters, old') = findAlters defs (entityDB def) new old
          in alters ++ getAltersC news old'
 
-    getAltersU :: [(DBName, [DBName])]
-               -> [(DBName, [DBName])]
-               -> [AlterTable]
-    getAltersU [] old = map DropConstraint $ filter (not . isManual) $ map fst old
+    getAltersU
+        :: [(DBName, [DBName])]
+        -> [(DBName, [DBName])]
+        -> [AlterTable]
+    getAltersU [] old =
+        map DropConstraint $ filter (not . isManual) $ map fst old
     getAltersU ((name, cols):news) old =
         case lookup name old of
-            Nothing -> AddUniqueConstraint name cols : getAltersU news old
+            Nothing ->
+                AddUniqueConstraint name cols : getAltersU news old
             Just ocols ->
                 let old' = filter (\(x, _) -> x /= name) old
                  in if sort cols == sort ocols

From d86e811e3d97a96ea024679707cd42cd4415ca24 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 15:58:05 -0600
Subject: [PATCH 09/12] Add notes and changes

---
 persistent-postgresql/ChangeLog.md            |  5 +++++
 .../persistent-postgresql.cabal               |  4 ++--
 persistent-sqlite/ChangeLog.md                |  5 +++++
 persistent-sqlite/persistent-sqlite.cabal     |  4 ++--
 persistent/ChangeLog.md                       |  5 +++++
 persistent/Database/Persist/Types/Base.hs     | 22 +++++++++++++++++++
 6 files changed, 41 insertions(+), 4 deletions(-)

diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md
index 53a904e55..60822ab6c 100644
--- a/persistent-postgresql/ChangeLog.md
+++ b/persistent-postgresql/ChangeLog.md
@@ -1,5 +1,10 @@
 # Changelog for persistent-postgresql
 
+## 2.11.0.0
+
+* [#1060](https://github.com/yesodweb/persistent/pull/1060)
+  * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options.
+
 ## 2.10.1.2
 
 * Fix issue with multiple foreign keys on single column. [#1010](https://github.com/yesodweb/persistent/pull/1010)
diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal
index 87ea7e1c0..d07851b9f 100644
--- a/persistent-postgresql/persistent-postgresql.cabal
+++ b/persistent-postgresql/persistent-postgresql.cabal
@@ -1,5 +1,5 @@
 name:            persistent-postgresql
-version:         2.10.1.2
+version:         2.11.0.0
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa, Michael Snoyman <michael@snoyman.com>
@@ -16,7 +16,7 @@ extra-source-files: ChangeLog.md
 
 library
     build-depends:   base                  >= 4.9      && < 5
-                   , persistent            >= 2.10     && < 3
+                   , persistent            >= 2.11     && < 3
                    , aeson                 >= 1.0
                    , blaze-builder
                    , bytestring            >= 0.10
diff --git a/persistent-sqlite/ChangeLog.md b/persistent-sqlite/ChangeLog.md
index 2f8422a27..fd70c3504 100644
--- a/persistent-sqlite/ChangeLog.md
+++ b/persistent-sqlite/ChangeLog.md
@@ -1,5 +1,10 @@
 # Changelog for persistent-sqlite
 
+## 2.11.0.0
+
+* [#1060](https://github.com/yesodweb/persistent/pull/1060)
+  * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options.
+
 ## 2.10.6.2
 
 * Move template haskell splices to be correct (and GHC 8.10 compatible) [#1034](https://github.com/yesodweb/persistent/pull/1034)
diff --git a/persistent-sqlite/persistent-sqlite.cabal b/persistent-sqlite/persistent-sqlite.cabal
index 4e7904a04..2c0cc3392 100644
--- a/persistent-sqlite/persistent-sqlite.cabal
+++ b/persistent-sqlite/persistent-sqlite.cabal
@@ -1,5 +1,5 @@
 name:            persistent-sqlite
-version:         2.10.6.2
+version:         2.11.0.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -44,7 +44,7 @@ flag use-stat4
 
 library
     build-depends:   base                    >= 4.9         && < 5
-                   , persistent              >= 2.10        && < 3
+                   , persistent              >= 2.11        && < 3
                    , aeson                   >= 1.0
                    , bytestring              >= 0.10
                    , conduit                 >= 1.2.12
diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md
index 15c563e48..02e197f9e 100644
--- a/persistent/ChangeLog.md
+++ b/persistent/ChangeLog.md
@@ -1,5 +1,10 @@
 # Changelog for persistent
 
+## 2.11.0.0
+
+* [#1060](https://github.com/yesodweb/persistent/pull/1060)
+  * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options.
+
 ## 2.10.5.2
 
 * [#1041](https://github.com/yesodweb/persistent/pull/1041)
diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs
index 33b3de453..f8686151e 100644
--- a/persistent/Database/Persist/Types/Base.hs
+++ b/persistent/Database/Persist/Types/Base.hs
@@ -296,21 +296,35 @@ data ForeignDef = ForeignDef
     , foreignConstraintNameHaskell :: !HaskellName
     , foreignConstraintNameDBName  :: !DBName
     , foreignFieldCascade          :: !FieldCascade
+    -- ^ Determine how the field will cascade on updates and deletions.
+    --
+    -- @since 2.11.0
     , foreignFields                :: ![(ForeignFieldDef, ForeignFieldDef)] -- this entity plus the primary entity
     , foreignAttrs                 :: ![Attr]
     , foreignNullable              :: Bool
     }
     deriving (Show, Eq, Read, Ord)
 
+-- | This datatype describes how a foreign reference field cascades deletes
+-- or updates.
+--
+-- @since 2.11.0
 data FieldCascade = FieldCascade
     { fcOnUpdate :: !(Maybe CascadeAction)
     , fcOnDelete :: !(Maybe CascadeAction)
     }
     deriving (Show, Eq, Read, Ord)
 
+-- | A 'FieldCascade' that does nothing.
+--
+-- @since 2.11.0
 noCascade :: FieldCascade
 noCascade = FieldCascade Nothing Nothing
 
+-- | Renders a 'FieldCascade' value such that it can be used in SQL
+-- migrations.
+--
+-- @since 2.11.0
 renderFieldCascade :: FieldCascade -> Text
 renderFieldCascade (FieldCascade onUpdate onDelete) =
     T.unwords
@@ -318,9 +332,17 @@ renderFieldCascade (FieldCascade onUpdate onDelete) =
         , foldMap (mappend "ON UPDATE " . renderCascadeAction) onUpdate
         ]
 
+-- | An action that might happen on a deletion or update on a foreign key
+-- change.
+--
+-- @since 2.11.0
 data CascadeAction = Cascade | Restrict | SetNull | SetDefault
     deriving (Show, Eq, Read, Ord)
 
+-- | Render a 'CascadeAction' to 'Text' such that it can be used in a SQL
+-- command.
+--
+-- @since 2.11.0
 renderCascadeAction :: CascadeAction -> Text
 renderCascadeAction action = case action of
   Cascade    -> "CASCADE"

From f99c0c496abd78bcb5386d3d37a6cda4524491d6 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 16:00:13 -0600
Subject: [PATCH 10/12] Add persistent-template changelog and version bump

---
 persistent-template/ChangeLog.md              | 4 ++++
 persistent-template/persistent-template.cabal | 4 ++--
 2 files changed, 6 insertions(+), 2 deletions(-)

diff --git a/persistent-template/ChangeLog.md b/persistent-template/ChangeLog.md
index c4fbc5b88..fa088e415 100644
--- a/persistent-template/ChangeLog.md
+++ b/persistent-template/ChangeLog.md
@@ -1,5 +1,9 @@
 ## Unreleased changes
 
+## 2.8.3.0
+
+* Add `Lift` instances for the cascade types. [#1060](https://github.com/yesodweb/persistent/pull/1060)
+
 ## 2.8.2.3
 
 * Require extensions in a more friendly manner. [#1030](https://github.com/yesodweb/persistent/pull/1030)
diff --git a/persistent-template/persistent-template.cabal b/persistent-template/persistent-template.cabal
index 74b37cfcf..1187d8fc4 100644
--- a/persistent-template/persistent-template.cabal
+++ b/persistent-template/persistent-template.cabal
@@ -1,5 +1,5 @@
 name:            persistent-template
-version:         2.8.2.3
+version:         2.8.3.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -16,7 +16,7 @@ extra-source-files: test/main.hs ChangeLog.md README.md
 
 library
     build-depends:   base                     >= 4.10      && < 5
-                   , persistent               >= 2.10      && < 3
+                   , persistent               >= 2.11      && < 3
                    , aeson                    >= 1.0       && < 1.5
                    , bytestring               >= 0.10
                    , containers

From b2a1e32ed339f5a5964d393bfdb32ccfef702988 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 16:00:40 -0600
Subject: [PATCH 11/12] since

---
 persistent-template/Database/Persist/TH.hs | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/persistent-template/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs
index 360224c48..76b865539 100644
--- a/persistent-template/Database/Persist/TH.hs
+++ b/persistent-template/Database/Persist/TH.hs
@@ -1668,9 +1668,15 @@ instance Lift CompositeDef where
 instance Lift ForeignDef where
     lift (ForeignDef a b c d e f g h) = [|ForeignDef a b c d e f g h|]
 
+-- |
+--
+-- @since 2.8.3.0
 instance Lift FieldCascade where
     lift (FieldCascade a b) = [|FieldCascade a b|]
 
+-- |
+--
+-- @since 2.8.3.0
 instance Lift CascadeAction where
     lift Cascade = [|Cascade|]
     lift Restrict = [|Restrict|]

From c3f96e477239d21d617044fcf40c45da7bef0d64 Mon Sep 17 00:00:00 2001
From: parsonsmatt <parsonsmatt@gmail.com>
Date: Mon, 30 Mar 2020 16:21:14 -0600
Subject: [PATCH 12/12] version is right now oops

---
 persistent/persistent.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal
index 9449d5c99..7b819b174 100644
--- a/persistent/persistent.cabal
+++ b/persistent/persistent.cabal
@@ -1,5 +1,5 @@
 name:            persistent
-version:         2.10.5.2
+version:         2.11.0.0
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>