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
|
{-# LANGUAGE ExplicitForAll #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.Persist.Sql.Orphan.PersistUnique
()
where
import Control.Exception (throwIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ask)
import qualified Data.Conduit.List as CL
import Data.Foldable (toList)
import Data.Function (on)
import Data.List (nubBy)
import qualified Data.Text as T
import Database.Persist
import Database.Persist.Class.PersistUnique
(defaultPutMany, defaultUpsertBy, persistUniqueKeyValues)
import Database.Persist.Sql.Orphan.PersistStore (withRawQuery)
import Database.Persist.Sql.Raw
import Database.Persist.Sql.Types.Internal
import Database.Persist.Sql.Util
( dbColumns
, mkUpdateText'
, parseEntityValues
, parseExistsResult
, updatePersistValue
)
instance PersistUniqueWrite SqlBackend where
upsertBy uniqueKey record updates = do
conn <- ask
let refCol n = T.concat [connEscapeTableName conn t, ".", n]
let mkUpdateText = mkUpdateText' (connEscapeFieldName conn) refCol
case connUpsertSql conn of
Just upsertSql -> case updates of
[] -> defaultUpsertBy uniqueKey record updates
_:_ -> do
let upds = T.intercalate "," $ map mkUpdateText updates
sql = upsertSql t (persistUniqueToFieldNames uniqueKey) upds
vals = map toPersistValue (toPersistFields record)
++ map updatePersistValue updates
++ unqs uniqueKey
x <- rawSql sql vals
return $ head x
Nothing -> defaultUpsertBy uniqueKey record updates
where
t = entityDef $ Just record
unqs uniqueKey' = concatMap persistUniqueToValues [uniqueKey']
deleteBy uniq = do
conn <- ask
let sql' = sql conn
vals = persistUniqueToValues uniq
rawExecute sql' vals
where
t = entityDef $ dummyFromUnique uniq
go = toList . fmap snd . persistUniqueToFieldNames
go' conn x = connEscapeFieldName conn x `mappend` "=?"
sql conn =
T.concat
[ "DELETE FROM "
, connEscapeTableName conn t
, " WHERE "
, T.intercalate " AND " $ map (go' conn) $ go uniq]
putMany [] = return ()
putMany rsD = do
let uKeys = persistUniqueKeys . head $ rsD
case uKeys of
[] -> insertMany_ rsD
_ -> go
where
go = do
let rs = nubBy ((==) `on` persistUniqueKeyValues) (reverse rsD)
let ent = entityDef rs
let nr = length rs
let toVals r = map toPersistValue $ toPersistFields r
conn <- ask
case connPutManySql conn of
(Just mkSql) -> rawExecute (mkSql ent nr) (concatMap toVals rs)
Nothing -> defaultPutMany rs
instance PersistUniqueWrite SqlWriteBackend where
deleteBy uniq = withBaseBackend $ deleteBy uniq
upsert rs us = withBaseBackend $ upsert rs us
putMany rs = withBaseBackend $ putMany rs
instance PersistUniqueRead SqlBackend where
getBy uniq = do
conn <- ask
let sql =
T.concat
[ "SELECT "
, T.intercalate "," $ toList $ dbColumns conn t
, " FROM "
, connEscapeTableName conn t
, " WHERE "
, sqlClause conn]
uvals = persistUniqueToValues uniq
withRawQuery sql uvals $
do row <- CL.head
case row of
Nothing -> return Nothing
Just [] -> error "getBy: empty row"
Just vals ->
case parseEntityValues t vals of
Left err ->
liftIO $ throwIO $ PersistMarshalError err
Right r -> return $ Just r
where
sqlClause conn =
T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq
go conn x = connEscapeFieldName conn x `mappend` "=?"
t = entityDef $ dummyFromUnique uniq
toFieldNames' = toList . fmap snd . persistUniqueToFieldNames
existsBy uniq = do
conn <- ask
let sql =
T.concat
[ "SELECT EXISTS(SELECT 1 FROM "
, connEscapeTableName conn t
, " WHERE "
, sqlClause conn
, ")"
]
uvals = persistUniqueToValues uniq
withRawQuery sql uvals $ do
mm <- CL.head
return $ parseExistsResult mm sql "PersistUnique.existsBy"
where
sqlClause conn =
T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq
go conn x = connEscapeFieldName conn x `mappend` "=?"
t = entityDef $ dummyFromUnique uniq
toFieldNames' = toList . fmap snd . persistUniqueToFieldNames
instance PersistUniqueRead SqlReadBackend where
getBy uniq = withBaseBackend $ getBy uniq
existsBy uniq = withBaseBackend $ existsBy uniq
instance PersistUniqueRead SqlWriteBackend where
getBy uniq = withBaseBackend $ getBy uniq
existsBy uniq = withBaseBackend $ existsBy uniq
dummyFromUnique :: Unique v -> Maybe v
dummyFromUnique _ = Nothing
|
