yesodweb · parsonsmatt · Mar 30, 2020 · Mar 19, 2020 · Mar 19, 2020 · Mar 30, 2020
diff --git 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/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
@@ -566,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'
@@ -592,12 +598,37 @@ 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
-        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)))
+        references =
+            mapMaybe
+                (\Column { cName, cReference } ->
+                    fmap (getAddReference allDefs Nothing name cName) cReference
+                )
+                newcols
+        foreignsAlt = map (mkForeignAlt name) fdefs
+
+mkForeignAlt
+    :: DBName
+    -> ForeignDef
+    -> AlterDB
+mkForeignAlt name fdef =
+    AlterColumn
+        name
+        ( foreignRefTableDBName fdef
+        , addReference
+        )
+  where
+    addReference =
+        AddReference
+            constraintName
+            childfields
+            escapedParentFields
+            (foreignFieldCascade fdef)
+    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
@@ -635,10 +666,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]
@@ -748,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
@@ -768,7 +805,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
@@ -895,8 +932,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 []
@@ -931,16 +977,26 @@ 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]
+    -> Maybe ForeignDef
+    -> DBName
+    -> DBName
+    -> (DBName, DBName)
+    -> AlterDB
+getAddReference allDefs mforeignDef table cname (s, constraintName) =
+    AlterColumn
+        table
+        ( s
+        , AddReference constraintName [cname] id_ (maybe noCascade foreignFieldCascade mforeignDef)
+        )
+  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
@@ -1066,7 +1122,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 "
@@ -1078,7 +1134,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
@@ -1200,12 +1256,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
-        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)))
+        references =
+            mapMaybe
+                (\Column { cName, cReference } ->
+                    fmap (getAddReference allDefs Nothing name cName) cReference
+                )
+                $ newcols
+        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-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-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

diff --git 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/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
@@ -580,7 +581,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 +591,20 @@ sqlForeign fdef = T.concat
     , "("
     , T.intercalate "," $ map (escape . snd . snd) $ foreignFields fdef
     , ")"
-    ]
+    ] ++ onDelete ++ onUpdate
+  where
+    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-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-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-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/Database/Persist/TH.hs b/persistent-template/Database/Persist/TH.hs
@@ -1666,7 +1666,22 @@ 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) = [|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|]
+    lift SetNull = [|SetNull|]
+    lift SetDefault = [|SetDefault|]
 
 instance Lift HaskellName where
     lift (HaskellName t) = [|HaskellName t|]