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
|
-----------------------------------------------------------
-- |
-- Module : Database.HaskellDB.HDBC
-- Copyright : HWT Group 2003,
-- Bjorn Bringert 2005-2006
-- License : BSD-style
--
-- Maintainer : haskelldb-users@lists.sourceforge.net
-- Stability : experimental
-- Portability : portable
--
-- HDBC interface for HaskellDB
--
-----------------------------------------------------------
module Database.HaskellDB.HDBC (hdbcConnect) where
import Database.HaskellDB
import Database.HaskellDB.Database
import Database.HaskellDB.Sql.Generate (SqlGenerator(..))
import Database.HaskellDB.Sql.Print
import Database.HaskellDB.PrimQuery
import Database.HaskellDB.Query
import Database.HaskellDB.FieldType
import Database.HDBC as HDBC hiding (toSql)
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Char (toLower)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe)
-- | Run an action on a HDBC IConnection and close the connection.
hdbcConnect :: (MonadIO m, IConnection conn) =>
SqlGenerator
-> IO conn -- ^ connection function
-> (Database -> m a) -> m a
hdbcConnect gen connect action =
do
conn <- liftIO $ handleSqlError connect
x <- action (mkDatabase gen conn)
-- FIXME: should we really commit here?
liftIO $ HDBC.commit conn
liftIO $ handleSqlError (HDBC.disconnect conn)
return x
mkDatabase :: (IConnection conn) => SqlGenerator -> conn -> Database
mkDatabase gen connection
= Database { dbQuery = hdbcQuery gen connection,
dbInsert = hdbcInsert gen connection,
dbInsertQuery = hdbcInsertQuery gen connection,
dbDelete = hdbcDelete gen connection,
dbUpdate = hdbcUpdate gen connection,
dbTables = hdbcTables connection,
dbDescribe = hdbcDescribe connection,
dbTransaction = hdbcTransaction connection,
dbCreateDB = hdbcCreateDB gen connection,
dbCreateTable = hdbcCreateTable gen connection,
dbDropDB = hdbcDropDB gen connection,
dbDropTable = hdbcDropTable gen connection
}
hdbcQuery :: (GetRec er vr, IConnection conn) =>
SqlGenerator
-> conn
-> PrimQuery
-> Rel er
-> IO [Record vr]
hdbcQuery gen connection q rel = hdbcPrimQuery connection sql scheme rel
where sql = show $ ppSql $ sqlQuery gen q
scheme = attributes q
hdbcInsert :: (IConnection conn) => SqlGenerator -> conn -> TableName -> Assoc -> IO ()
hdbcInsert gen conn table assoc =
hdbcPrimExecute conn $ show $ ppInsert $ sqlInsert gen table assoc
hdbcInsertQuery :: (IConnection conn) => SqlGenerator -> conn -> TableName -> PrimQuery -> IO ()
hdbcInsertQuery gen conn table assoc =
hdbcPrimExecute conn $ show $ ppInsert $ sqlInsertQuery gen table assoc
hdbcDelete :: (IConnection conn) => SqlGenerator -> conn -> TableName -> [PrimExpr] -> IO ()
hdbcDelete gen conn table exprs =
hdbcPrimExecute conn $ show $ ppDelete $ sqlDelete gen table exprs
hdbcUpdate :: (IConnection conn) => SqlGenerator -> conn -> TableName -> [PrimExpr] -> Assoc -> IO ()
hdbcUpdate gen conn table criteria assigns =
hdbcPrimExecute conn $ show $ ppUpdate $ sqlUpdate gen table criteria assigns
hdbcTables :: (IConnection conn) => conn -> IO [TableName]
hdbcTables conn = handleSqlError $ HDBC.getTables conn
hdbcDescribe :: (IConnection conn) => conn -> TableName -> IO [(Attribute,FieldDesc)]
hdbcDescribe conn table =
handleSqlError $ do
cs <- HDBC.describeTable conn table
return [(n,colDescToFieldDesc c) | (n,c) <- cs]
colDescToFieldDesc :: SqlColDesc -> FieldDesc
colDescToFieldDesc c = (t, nullable)
where
nullable = fromMaybe True (colNullable c)
string = maybe StringT BStrT (colSize c)
t = case colType c of
SqlCharT -> string
SqlVarCharT -> string
SqlLongVarCharT -> string
SqlWCharT -> string
SqlWVarCharT -> string
SqlWLongVarCharT -> string
SqlDecimalT -> IntegerT
SqlNumericT -> IntegerT
SqlSmallIntT -> IntT
SqlIntegerT -> IntT
SqlRealT -> DoubleT
SqlFloatT -> DoubleT
SqlDoubleT -> DoubleT
SqlBitT -> BoolT
SqlTinyIntT -> IntT
SqlBigIntT -> IntT
SqlBinaryT -> string
SqlVarBinaryT -> string
SqlLongVarBinaryT -> string
SqlDateT -> CalendarTimeT
SqlTimeT -> CalendarTimeT
SqlTimestampT -> CalendarTimeT
SqlUTCDateTimeT -> CalendarTimeT
SqlUTCTimeT -> CalendarTimeT
SqlIntervalT _ -> string
SqlGUIDT -> string
SqlUnknownT _ -> string
hdbcCreateDB :: (IConnection conn) => SqlGenerator -> conn -> String -> IO ()
hdbcCreateDB gen conn name
= hdbcPrimExecute conn $ show $ ppCreate $ sqlCreateDB gen name
hdbcCreateTable :: (IConnection conn) => SqlGenerator -> conn -> TableName -> [(Attribute,FieldDesc)] -> IO ()
hdbcCreateTable gen conn name attrs
= hdbcPrimExecute conn $ show $ ppCreate $ sqlCreateTable gen name attrs
hdbcDropDB :: (IConnection conn) => SqlGenerator -> conn -> String -> IO ()
hdbcDropDB gen conn name
= hdbcPrimExecute conn $ show $ ppDrop $ sqlDropDB gen name
hdbcDropTable :: (IConnection conn) => SqlGenerator -> conn -> TableName -> IO ()
hdbcDropTable gen conn name
= hdbcPrimExecute conn $ show $ ppDrop $ sqlDropTable gen name
-- | HDBC implementation of 'Database.dbTransaction'.
hdbcTransaction :: (IConnection conn) => conn -> IO a -> IO a
hdbcTransaction conn action =
handleSqlError $ HDBC.withTransaction conn (\_ -> action)
-----------------------------------------------------------
-- Primitive operations
-----------------------------------------------------------
type HDBCRow = Map String HDBC.SqlValue
-- | Primitive query
hdbcPrimQuery :: (GetRec er vr, IConnection conn) =>
conn -- ^ Database connection.
-> String -- ^ SQL query
-> Scheme -- ^ List of field names to retrieve
-> Rel er -- ^ Phantom argument to get the return type right.
-> IO [Record vr] -- ^ Query results
hdbcPrimQuery conn sql scheme rel =
do
stmt <- handleSqlError $ HDBC.prepare conn sql
handleSqlError $ HDBC.execute stmt []
rows <- HDBC.fetchAllRowsMap stmt
mapM (getRec hdbcGetInstances rel scheme) rows
-- | Primitive execute
hdbcPrimExecute :: (IConnection conn) => conn -- ^ Database connection.
-> String -- ^ SQL query.
-> IO ()
hdbcPrimExecute conn sql =
do
handleSqlError $ HDBC.run conn sql []
return ()
-----------------------------------------------------------
-- Getting data from a statement
-----------------------------------------------------------
hdbcGetInstances :: GetInstances HDBCRow
hdbcGetInstances =
GetInstances {
getString = hdbcGetValue
, getInt = hdbcGetValue
, getInteger = hdbcGetValue
, getDouble = hdbcGetValue
, getBool = hdbcGetValue
, getCalendarTime = hdbcGetValue
}
-- hdbcGetValue :: Data.Convertible.Base.Convertible SqlValue a
-- => HDBCRow -> String -> IO (Maybe a)
hdbcGetValue m f = case Map.lookup (map toLower f) m of
Nothing -> fail $ "No such field " ++ f
Just x -> return $ HDBC.fromSql x
|
