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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
|
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
-- | Intended for creating new backends.
module Database.Persist.Sql.Internal
( mkColumns
, defaultAttribute
, BackendSpecificOverrides(..)
, getBackendSpecificForeignKeyName
, setBackendSpecificForeignKeyName
, emptyBackendSpecificOverrides
) where
import Control.Applicative ((<|>))
import Data.Monoid (mappend, mconcat)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Database.Persist.EntityDef
import Database.Persist.Sql.Types
import Database.Persist.Types
-- | Record of functions to override the default behavior in 'mkColumns'. It is
-- recommended you initialize this with 'emptyBackendSpecificOverrides' and
-- override the default values, so that as new fields are added, your code still
-- compiles.
--
-- For added safety, use the @getBackendSpecific*@ and @setBackendSpecific*@
-- functions, as a breaking change to the record field labels won't be reflected
-- in a major version bump of the library.
--
-- @since 2.11
data BackendSpecificOverrides = BackendSpecificOverrides
{ backendSpecificForeignKeyName :: Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
}
-- | If the override is defined, then this returns a function that accepts an
-- entity name and field name and provides the 'ConstraintNameDB' for the
-- foreign key constraint.
--
-- An abstract accessor for the 'BackendSpecificOverrides'
--
-- @since 2.13.0.0
getBackendSpecificForeignKeyName
:: BackendSpecificOverrides
-> Maybe (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
getBackendSpecificForeignKeyName =
backendSpecificForeignKeyName
-- | Set the backend's foreign key generation function to this value.
--
-- @since 2.13.0.0
setBackendSpecificForeignKeyName
:: (EntityNameDB -> FieldNameDB -> ConstraintNameDB)
-> BackendSpecificOverrides
-> BackendSpecificOverrides
setBackendSpecificForeignKeyName func bso =
bso { backendSpecificForeignKeyName = Just func }
findMaybe :: (a -> Maybe b) -> [a] -> Maybe b
findMaybe p = listToMaybe . mapMaybe p
-- | Creates an empty 'BackendSpecificOverrides' (i.e. use the default behavior; no overrides)
--
-- @since 2.11
emptyBackendSpecificOverrides :: BackendSpecificOverrides
emptyBackendSpecificOverrides = BackendSpecificOverrides Nothing
defaultAttribute :: [FieldAttr] -> Maybe Text
defaultAttribute = findMaybe $ \case
FieldAttrDefault x -> Just x
_ -> Nothing
-- | Create the list of columns for the given entity.
mkColumns
:: [EntityDef]
-> EntityDef
-> BackendSpecificOverrides
-> ([Column], [UniqueDef], [ForeignDef])
mkColumns allDefs t overrides =
(cols, getEntityUniquesNoPrimaryKey t, getEntityForeignDefs t)
where
cols :: [Column]
cols = map goId idCol `mappend` map go (getEntityFieldsDatabase t)
idCol :: [FieldDef]
idCol =
case getEntityId t of
EntityIdNaturalKey _ ->
[]
EntityIdField fd ->
[fd]
goId :: FieldDef -> Column
goId fd =
Column
{ cName = fieldDB fd
, cNull = False
, cSqlType = fieldSqlType fd
, cDefault =
case defaultAttribute $ fieldAttrs fd of
Nothing ->
-- So this is not necessarily a problem...
-- because you can use eg `inserKey` to insert
-- a value into the database without ever asking
-- for a default attribute.
Nothing
-- But we need to be able to say "Hey, if this is
-- an *auto generated ID column*, then I need to
-- specify that it has the default serial picking
-- behavior for whatever SQL backend this is using.
-- Because naturally MySQL, Postgres, MSSQL, etc
-- all do ths differently, sigh.
-- Really, this should be something like,
--
-- > data ColumnDefault
-- > = Custom Text
-- > | AutogenerateId
-- > | NoDefault
--
-- where Autogenerated is determined by the
-- MkPersistSettings.
Just def ->
Just def
, cGenerated = fieldGenerated fd
, cDefaultConstraintName = Nothing
, cMaxLen = maxLen $ fieldAttrs fd
, cReference = mkColumnReference fd
}
tableName :: EntityNameDB
tableName = getEntityDBName t
go :: FieldDef -> Column
go fd =
Column
{ cName = fieldDB fd
, cNull =
case isFieldNullable fd of
Nullable _ -> True
NotNullable -> isFieldMaybe fd || isEntitySum t
, cSqlType = fieldSqlType fd
, cDefault = defaultAttribute $ fieldAttrs fd
, cGenerated = fieldGenerated fd
, cDefaultConstraintName = Nothing
, cMaxLen = maxLen $ fieldAttrs fd
, cReference = mkColumnReference fd
}
maxLen :: [FieldAttr] -> Maybe Integer
maxLen = findMaybe $ \case
FieldAttrMaxlen n -> Just n
_ -> Nothing
refNameFn = fromMaybe refName (backendSpecificForeignKeyName overrides)
mkColumnReference :: FieldDef -> Maybe ColumnReference
mkColumnReference fd =
fmap
(\(tName, cName) ->
ColumnReference tName cName $ overrideNothings $ fieldCascade fd
)
$ ref (fieldDB fd) (fieldReference fd) (fieldAttrs fd)
-- a 'Nothing' in the definition means that the QQ migration doesn't
-- specify behavior. the default is RESTRICT. setting this here
-- explicitly makes migrations run smoother.
overrideNothings (FieldCascade { fcOnUpdate = upd, fcOnDelete = del }) =
FieldCascade
{ fcOnUpdate = upd <|> Just Restrict
, fcOnDelete = del <|> Just Restrict
}
ref :: FieldNameDB
-> ReferenceDef
-> [FieldAttr]
-> Maybe (EntityNameDB, ConstraintNameDB) -- table name, constraint name
ref c fe []
| ForeignRef f <- fe =
Just (resolveTableName allDefs f, refNameFn tableName c)
| otherwise = Nothing
ref _ _ (FieldAttrNoreference:_) = Nothing
ref c fe (a:as) = case a of
FieldAttrReference x -> do
(_, constraintName) <- ref c fe as
pure (EntityNameDB x, constraintName)
FieldAttrConstraint x -> do
(tableName_, _) <- ref c fe as
pure (tableName_, ConstraintNameDB x)
_ -> ref c fe as
refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB
refName (EntityNameDB table) (FieldNameDB column) =
ConstraintNameDB $ Data.Monoid.mconcat [table, "_", column, "_fkey"]
resolveTableName :: [EntityDef] -> EntityNameHS -> EntityNameDB
resolveTableName [] (EntityNameHS t) = error $ "Table not found: " `Data.Monoid.mappend` T.unpack t
resolveTableName (e:es) hn
| getEntityHaskellName e == hn = getEntityDBName e
| otherwise = resolveTableName es hn
|
