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
|
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.Persist.Sql.Orphan.PersistStore () where
import Database.Persist
import Database.Persist.Sql.Types
import Database.Persist.Sql.Class
import Database.Persist.Sql.Raw
import Database.Persist.Sql.Internal (convertKey)
import qualified Data.Conduit as C
import qualified Data.Conduit.List as CL
import Control.Monad.Logger
import qualified Data.Text as T
import Data.Text (Text, unpack)
import Data.Monoid (mappend, (<>))
import Control.Monad.IO.Class
import Data.ByteString.Char8 (readInteger)
import Data.Maybe (isJust)
import Data.List (find)
import Control.Monad.Trans.Resource (MonadResource)
instance (MonadResource m, MonadLogger m) => PersistStore (SqlPersistT m) where
type PersistMonadBackend (SqlPersistT m) = SqlBackend
insert val = do
conn <- askSqlConn
let esql = connInsertSql conn t vals
key <-
case esql of
ISRSingle sql -> rawQuery sql vals C.$$ do
x <- CL.head
case x of
Just [PersistInt64 i] -> return $ Key $ PersistInt64 i
Nothing -> error $ "SQL insert did not return a result giving the generated ID"
Just vals' -> error $ "Invalid result from a SQL insert, got: " ++ show vals'
ISRInsertGet sql1 sql2 -> do
rawExecute sql1 vals
rawQuery sql2 [] C.$$ do
mm <- CL.head
case mm of
Just [PersistInt64 i] -> return $ Key $ PersistInt64 i
Just [PersistDouble i] ->return $ Key $ PersistInt64 $ truncate i -- oracle need this!
Just [PersistByteString i] -> case readInteger i of -- mssql
Just (ret,"") -> return $ Key $ PersistInt64 $ fromIntegral ret
xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]"
Just xs -> error $ "invalid sql2 return xs["++show xs++"] sql2["++show sql2++"] sql1["++show sql1++"]"
Nothing -> error $ "invalid sql2 returned nothing sql2["++show sql2++"] sql1["++show sql1++"]"
ISRManyKeys sql fs -> do
rawExecute sql vals
case entityPrimary t of
Nothing -> error $ "ISRManyKeys is used when Primary is defined " ++ show sql
Just pdef ->
let pks = map fst $ primaryFields pdef
keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) fs
in return $ Key $ PersistList keyvals
return key
where
t = entityDef $ Just val
vals = map toPersistValue $ toPersistFields val
replace k val = do
conn <- askSqlConn
let t = entityDef $ Just val
let sql = T.concat
[ "UPDATE "
, connEscapeName conn (entityDB t)
, " SET "
, T.intercalate "," (map (go conn . fieldDB) $ entityFields t)
, " WHERE "
, connEscapeName conn $ entityID t
, "=?"
]
vals = map toPersistValue (toPersistFields val) `mappend` [unKey k]
rawExecute sql vals
where
go conn x = connEscapeName conn x `T.append` "=?"
insertKey = insrepHelper "INSERT"
repsert key value = do
mExisting <- get key
case mExisting of
Nothing -> insertKey key value
Just _ -> replace key value
get k = do
conn <- askSqlConn
let t = entityDef $ dummyFromKey k
let composite = isJust $ entityPrimary t
let cols = T.intercalate ","
$ map (connEscapeName conn . fieldDB) $ entityFields t
noColumns :: Bool
noColumns = null $ entityFields t
let wher = case entityPrimary t of
Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef
Nothing -> connEscapeName conn (entityID t) <> "=?"
let sql = T.concat
[ "SELECT "
, if noColumns then "*" else cols
, " FROM "
, connEscapeName conn $ entityDB t
, " WHERE "
, wher
]
rawQuery sql (convertKey composite k) C.$$ do
res <- CL.head
case res of
Nothing -> return Nothing
Just vals ->
case fromPersistValues $ if noColumns then [] else vals of
Left e -> error $ "get " ++ show (unKey k) ++ ": " ++ unpack e
Right v -> return $ Just v
delete k = do
conn <- askSqlConn
rawExecute (sql conn) (convertKey composite k)
where
t = entityDef $ dummyFromKey k
composite = isJust $ entityPrimary t
wher conn =
case entityPrimary t of
Just pdef -> T.intercalate " AND " $ map (\fld -> connEscapeName conn (snd fld) <> "=? ") $ primaryFields pdef
Nothing -> connEscapeName conn (entityID t) <> "=?"
sql conn = T.concat
[ "DELETE FROM "
, connEscapeName conn $ entityDB t
, " WHERE "
, wher conn
]
dummyFromKey :: KeyBackend SqlBackend v -> Maybe v
dummyFromKey _ = Nothing
insrepHelper :: (MonadIO m, PersistEntity val, MonadLogger m, MonadSqlPersist m)
=> Text
-> Key val
-> val
-> m ()
insrepHelper command (Key k) val = do
conn <- askSqlConn
rawExecute (sql conn) vals
where
t = entityDef $ Just val
sql conn = T.concat
[ command
, " INTO "
, connEscapeName conn (entityDB t)
, "("
, T.intercalate ","
$ map (connEscapeName conn)
$ entityID t : map fieldDB (entityFields t)
, ") VALUES("
, T.intercalate "," ("?" : map (const "?") (entityFields t))
, ")"
]
vals = k : map toPersistValue (toPersistFields val)
|
