From deca8e026548772b008b33b88dbf160b441adbc7 Mon Sep 17 00:00:00 2001 From: kderme Date: Thu, 19 Mar 2020 23:01:31 +0200 Subject: [PATCH 1/2] 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 e5f64ebd33cce55110523a71826c4b45bc22edf2 Mon Sep 17 00:00:00 2001 From: kderme Date: Thu, 19 Mar 2020 23:04:10 +0200 Subject: [PATCH 2/2] 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