{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE AllowAmbiguousTypes, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables, TypeApplications, UndecidableInstances #-}
module ForeignKey where
import Data.Proxy
import qualified Data.List as List
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|
SimpleCascadeChild
ref SimpleCascadeId OnDeleteCascade
deriving Show Eq
SimpleCascade
name Int
deriving Show Eq
Parent
name Int
Primary name
Child
pname Int
Foreign Parent OnDeleteCascade OnUpdateCascade fkparent pname
deriving Show Eq
ParentImplicit
name Int
ChildImplicit
pname Int
parentId ParentImplicitId noreference
Foreign ParentImplicit OnDeleteCascade OnUpdateCascade fkparent parentId
deriving Show Eq
ParentComposite
name Int
lastName Int
Primary name lastName
ChildComposite
pname Int
plastName Int
Foreign ParentComposite OnDeleteCascade fkparent pname plastName
deriving Show Eq
SelfReferenced
name Int
pname Int
Primary name
Foreign SelfReferenced OnDeleteCascade fkparent pname
deriving Show Eq
A
aa Int
ab Int
U1 aa
B
ba Int
bb Int
Foreign A OnDeleteCascade fkA ba References aa
deriving Show Eq
AComposite
aa Int
ab Int
U2 aa ab
BComposite
ba Int
bb Int
Foreign AComposite OnDeleteCascade fkAComposite ba bb References aa ab
deriving Show Eq
BExplicit
ba AId noreference
Foreign A OnDeleteCascade fkAI ba References Id
deriving Show Eq
Chain
name Int
previous ChainId Maybe noreference
Foreign Chain OnDeleteSetNull fkChain previous References Id
deriving Show Eq Ord
Chain2
name Int
previous Chain2Id Maybe noreference
Foreign Chain2 OnDeleteCascade fkChain previous References Id
deriving Show Eq
Chain3
name Int
previous Chain3Id Maybe OnDeleteCascade
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 1
insert_ $ Child 1
delete kf
cs <- selectList [] []
let expected = [] :: [Entity Child]
cs @== expected
it "update cascades" $ runDb $ do
kf <- insert $ Parent 1
insert_ $ Child 1
update kf [ParentName =. 2]
cs <- selectList [] []
fmap (childPname . entityVal) cs @== [2]
it "delete Composite cascades" $ runDb $ do
kf <- insert $ ParentComposite 1 2
insert_ $ ChildComposite 1 2
delete kf
cs <- selectList [] []
let expected = [] :: [Entity ChildComposite]
cs @== expected
it "delete self referenced cascades" $ runDb $ do
kf <- insert $ SelfReferenced 1 1
insert_ $ SelfReferenced 2 1
delete kf
srs <- selectList [] []
let expected = [] :: [Entity SelfReferenced]
srs @== expected
it "delete cascade works on simple references" $ runDb $ do
scId <- insert $ SimpleCascade 1
sccId <- insert $ SimpleCascadeChild scId
Just _ <- get sccId
delete scId
mres <- get sccId
mxs <- selectList @SimpleCascadeChild [] []
liftIO $ do
mres `shouldBe` Nothing
mxs `shouldBe` []
it "delete cascades with explicit Reference" $ runDb $ do
kf <- insert $ A 1 40
insert_ $ B 1 15
delete kf
return ()
cs <- selectList [] []
let expected = [] :: [Entity B]
cs @== expected
it "delete cascades with explicit Composite Reference" $ runDb $ do
kf <- insert $ AComposite 1 20
insert_ $ BComposite 1 20
delete kf
return ()
cs <- selectList [] []
let expected = [] :: [Entity B]
cs @== expected
it "delete cascades with explicit Composite Reference" $ runDb $ do
kf <- insert $ AComposite 1 20
insert_ $ BComposite 1 20
delete kf
return ()
cs <- selectList [] []
let expected = [] :: [Entity B]
cs @== expected
it "delete cascades with explicit Id field" $ runDb $ do
kf <- insert $ A 1 20
insert_ $ BExplicit kf
delete kf
return ()
cs <- selectList [] []
let expected = [] :: [Entity B]
cs @== expected
it "deletes sets null with self reference" $ runDb $ do
kf <- insert $ Chain 1 Nothing
kf' <- insert $ Chain 2 (Just kf)
delete kf
cs <- selectList [] []
let expected = [Entity {entityKey = kf', entityVal = Chain 2 Nothing}]
List.sort cs @== List.sort expected
it "deletes cascades with self reference to the whole chain" $ runDb $ do
k1 <- insert $ Chain2 1 Nothing
k2 <- insert $ Chain2 2 (Just k1)
insert_ $ Chain2 3 (Just k2)
delete k1
cs <- selectList [] []
let expected = [] :: [Entity Chain2]
cs @== expected
it "deletes cascades with field self reference to the whole chain" $ runDb $ do
k1 <- insert $ Chain3 1 Nothing
k2 <- insert $ Chain3 2 (Just k1)
insert_ $ Chain3 3 (Just k2)
delete k1
cs <- selectList [] []
let expected = [] :: [Entity Chain3]
cs @== expected
describe "EntityDef" $ do
let ed =
entityDef (Proxy @SimpleCascadeChild)
isRefCol =
(FieldNameHS "ref" ==) . fieldHaskell
expected = FieldCascade
{ fcOnUpdate = Nothing
, fcOnDelete = Just Cascade
}
Just refField =
List.find isRefCol (entityFields ed)
it "parses into fieldCascade" $ do
fieldCascade refField `shouldBe` expected
it "shouldn't have cascade in extras" $ do
entityExtra ed
`shouldBe`
mempty
cleanDB :: (MonadIO m) => SqlPersistT m ()
cleanDB = do
del @SimpleCascadeChild
del @SimpleCascade
del @Parent
del @ParentComposite
del @ParentImplicit
del @Child
del @ChildComposite
del @ChildImplicit
del @SelfReferenced
del @A
del @AComposite
del @B
del @BExplicit
del @BComposite
del @Chain
del @Chain2
del
:: forall a m.
( PersistEntity a
, PersistEntityBackend a ~ SqlBackend
, MonadIO m
)
=> SqlPersistT m ()
del = deleteWhere @_ @_ @a []