1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
|
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
--
-- DeriveAnyClass is not actually used by persistent-template
-- But a long standing bug was that if it was enabled, it was used to derive instead of GeneralizedNewtypeDeriving
-- This was fixed by using DerivingStrategies to specify newtype deriving should be used.
-- This pragma is left here as a "test" that deriving works when DeriveAnyClass is enabled.
-- See https://github.com/yesodweb/persistent/issues/578
{-# LANGUAGE DeriveAnyClass #-}
module Database.Persist.TH.ForeignRefSpec where
import Control.Applicative (Const(..))
import Data.Aeson
import Data.ByteString.Lazy.Char8 ()
import Data.Coerce
import Data.Functor.Identity (Identity(..))
import Data.Int
import qualified Data.List as List
import Data.Proxy
import Data.Text (Text, pack)
import GHC.Generics (Generic)
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.QuickCheck.Arbitrary
import Test.QuickCheck.Gen (Gen)
import Database.Persist
import Database.Persist.EntityDef.Internal
import Database.Persist.Sql
import Database.Persist.Sql.Util
import Database.Persist.TH
import TemplateTestImports
mkPersist sqlSettings [persistLowerCase|
HasCustomName sql=custom_name
name Text
ForeignTarget
name Text
deriving Eq Show
ForeignSource
name Text
foreignTargetId ForeignTargetId
Foreign ForeignTarget fk_s_t foreignTargetId
ForeignPrimary
name Text
Primary name
deriving Eq Show
ForeignPrimarySource
name Text
Foreign ForeignPrimary fk_name_target name
NullableRef
name Text Maybe
Foreign ForeignPrimary fk_nullable_ref name
ParentImplicit
name Text
ChildImplicit
name Text
parent ParentImplicitId OnDeleteCascade OnUpdateCascade
ParentExplicit
name Text
Primary name
ChildExplicit
name Text
Foreign ParentExplicit OnDeleteCascade OnUpdateCascade fkparent name
|]
spec :: Spec
spec = describe "ForeignRefSpec" $ do
describe "HasCustomName" $ do
let
edef =
entityDef $ Proxy @HasCustomName
it "should have a custom db name" $ do
entityDB edef
`shouldBe`
EntityNameDB "custom_name"
it "should compile" $ do
True `shouldBe` True
describe "ForeignPrimarySource" $ do
let
fpsDef =
entityDef $ Proxy @ForeignPrimarySource
[foreignDef] =
entityForeigns fpsDef
it "has the right type" $ do
foreignPrimarySourceFk_name_target (ForeignPrimarySource "asdf")
`shouldBe`
ForeignPrimaryKey "asdf"
describe "Cascade" $ do
describe "Explicit" $ do
let
parentDef =
entityDef $ Proxy @ParentExplicit
childDef =
entityDef $ Proxy @ChildExplicit
childForeigns =
entityForeigns childDef
it "should have a single foreign reference defined" $ do
case entityForeigns childDef of
[a] ->
pure ()
as ->
expectationFailure . mconcat $
[ "Expected one foreign reference on childDef, "
, "got: "
, show as
]
let
[ForeignDef {..}] =
childForeigns
describe "ChildExplicit" $ do
it "should have the right target table" $ do
foreignRefTableHaskell `shouldBe`
EntityNameHS "ParentExplicit"
foreignRefTableDBName `shouldBe`
EntityNameDB "parent_explicit"
it "should have the right cascade behavior" $ do
foreignFieldCascade
`shouldBe`
FieldCascade
{ fcOnUpdate =
Just Cascade
, fcOnDelete =
Just Cascade
}
it "is not nullable" $ do
foreignNullable `shouldBe` False
it "is to the Primary key" $ do
foreignToPrimary `shouldBe` True
describe "Implicit" $ do
let
parentDef =
entityDef $ Proxy @ParentImplicit
childDef =
entityDef $ Proxy @ChildImplicit
childFields =
entityFields childDef
describe "ChildImplicit" $ do
case childFields of
[nameField, parentIdField] -> do
it "parentId has reference" $ do
fieldReference parentIdField `shouldBe`
ForeignRef (EntityNameHS "ParentImplicit")
as ->
error . mconcat $
[ "Expected one foreign reference on childDef, "
, "got: "
, show as
]
|
