Foreign key cascade

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

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
 

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|]

persistent-test/persistent-test.cabal

@@ -24,6 +24,7 @@ library
                      EmptyEntityTest
                      EntityEmbedTest
                      EquivalentTypeTest
+                     ForeignKey
                      HtmlTest
                      Init
                      LargeNumberTest

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

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

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