Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 580 lines (510 sloc) 19.413 kb
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
1 {-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
2 {-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables #-}
3 {-# LANGUAGE FlexibleContexts, ViewPatterns, NamedFieldPuns, TupleSections #-}
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
4
5 -- | A front-end implementation for the PostgreSQL database protocol
6 -- version 3.0 (implemented in PostgreSQL 7.4 and later).
7
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
8 module Database.PostgreSQL.Base
9 (begin
10 ,rollback
11 ,commit
12 ,query
13 ,exec
14 ,escapeBS
15 ,connect
16 ,defaultConnectInfo
17 ,close
a4f16c51 »
2011-08-02 Use extensible exceptions.
18 ,withDB
b900ce54 »
2011-11-12 Added back pooling, for now (closes #3).
19 ,withTransaction
20 ,newPool
21 ,pconnect
22 ,withPoolConnection)
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
23 where
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
24
25 import Database.PostgreSQL.Base.Types
26
27 import Control.Concurrent
28 import Control.Monad
01ecfb99 »
2011-06-03 Sorted/aligned imports.
29 import Control.Monad.CatchIO (MonadCatchIO)
30 import qualified Control.Monad.CatchIO as E
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
31 import Control.Monad.Fix
01ecfb99 »
2011-06-03 Sorted/aligned imports.
32 import Control.Monad.State (MonadState,execStateT,modify)
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
33 import Control.Monad.Trans
34 import Data.Binary
35 import Data.Binary.Get
36 import Data.Binary.Put
01ecfb99 »
2011-06-03 Sorted/aligned imports.
37 import Data.ByteString (ByteString)
38 import qualified Data.ByteString as B
39 import qualified Data.ByteString.Lazy as L
7ebdb14c »
2011-10-05 Support password-based authentication.
40 import qualified Data.ByteString.Lazy.UTF8 as L (toString,fromString)
01ecfb99 »
2011-06-03 Sorted/aligned imports.
41 import Data.ByteString.UTF8 (toString,fromString)
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
42 import Data.Int
43 import Data.List
01ecfb99 »
2011-06-03 Sorted/aligned imports.
44 import Data.Map (Map)
45 import qualified Data.Map as M
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
46 import Data.Maybe
47 import Data.Monoid
48 import Network
49 import Prelude
01ecfb99 »
2011-06-03 Sorted/aligned imports.
50 import System.IO hiding (hPutStr)
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
51
52 --------------------------------------------------------------------------------
53 -- Exported values
54
55 -- | Default information for setting up a connection.
56 --
57 -- Defaults are as follows:
58 --
59 -- * Server on @localhost@
60 --
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
61 -- * User @postgres@
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
62 --
63 -- * No password
64 --
65 -- * Database @test@
66 --
67 -- * Character set @utf8@
68 --
69 -- Use as in the following example:
70 --
71 -- > connect defaultConnectInfo { connectHost = "db.example.com" }
72 defaultConnectInfo :: ConnectInfo
73 defaultConnectInfo = ConnectInfo {
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
74 connectHost = "127.0.0.1"
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
75 , connectPort = 5432
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
76 , connectUser = "postgres"
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
77 , connectPassword = ""
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
78 , connectDatabase = ""
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
79 }
80
b900ce54 »
2011-11-12 Added back pooling, for now (closes #3).
81 -- | Create a new connection pool.
82 newPool :: MonadIO m
83 => ConnectInfo -- ^ Connect info.
84 -> m Pool
85 newPool info = liftIO $ do
86 var <- newMVar $ PoolState {
87 poolConnections = []
88 , poolConnectInfo = info
89 }
90 return $ Pool var
91
92 -- | Connect using the connection pool.
93 pconnect :: MonadIO m => Pool -> m Connection
94 pconnect (Pool var) = liftIO $ do
95 modifyMVar var $ \state@PoolState{..} -> do
96 case poolConnections of
97 [] -> do conn <- connect poolConnectInfo
98 return (state,conn)
99 (conn:conns) -> return (state { poolConnections = conns },conn)
100
101 -- | Restore a connection to the pool.
102 restore :: MonadIO m => Pool -> Connection -> m ()
103 restore (Pool var) conn = liftIO $ do
104 handle <- readMVar $ connectionHandle conn
105 modifyMVar_ var $ \state -> do
106 case handle of
107 Nothing -> return state
108 Just h -> do
109 eof <- hIsOpen h
110 if eof
111 then return state { poolConnections = conn : poolConnections state }
112 else return state
113
114 -- | Use the connection pool.
115 withPoolConnection
116 :: (MonadCatchIO m,MonadIO m)
117 => Pool -- ^ The connection pool.
118 -> (Connection -> m a) -- ^ Use the connection.
119 -> m ()
120 withPoolConnection pool m = do
121 _ <- E.bracket (pconnect pool) (restore pool) m
122 return ()
123
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
124 -- | Connect with the given username to the given database. Will throw
125 -- an exception if it cannot connect.
126 connect :: MonadIO m => ConnectInfo -> m Connection -- ^ The datase connection.
127 connect connectInfo@ConnectInfo{..} = liftIO $ withSocketsDo $ do
128 var <- newEmptyMVar
129 h <- connectTo connectHost (PortNumber $ fromIntegral connectPort)
130 hSetBuffering h NoBuffering
131 putMVar var $ Just h
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
132 types <- newMVar M.empty
133 let conn = Connection var types
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
134 authenticate conn connectInfo
135 return conn
136
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
137 -- | Run a an action with a connection and close the connection
a4f16c51 »
2011-08-02 Use extensible exceptions.
138 -- afterwards (protects against exceptions).
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
139 withDB :: (MonadCatchIO m,MonadIO m) => ConnectInfo -> (Connection -> m a) -> m a
140 withDB connectInfo m = E.bracket (liftIO $ connect connectInfo) (liftIO . close) m
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
141
a4f16c51 »
2011-08-02 Use extensible exceptions.
142 -- | With a transaction, do some action (protects against exceptions).
143 withTransaction :: (MonadCatchIO m,MonadIO m) => Connection -> m a -> m a
144 withTransaction conn act = do
145 begin conn
146 r <- act `E.onException` rollback conn
147 commit conn
148 return r
149
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
150 -- | Rollback a transaction.
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
151 rollback :: (MonadCatchIO m,MonadIO m) => Connection -> m ()
152 rollback conn = do
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
153 _ <- exec conn (fromString ("ABORT;" :: String))
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
154 return ()
155
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
156 -- | Commit a transaction.
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
157 commit :: (MonadCatchIO m,MonadIO m) => Connection -> m ()
158 commit conn = do
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
159 _ <- exec conn (fromString ("COMMIT;" :: String))
160 return ()
161
162 -- | Begin a transaction.
163 begin :: (MonadCatchIO m,MonadIO m) => Connection -> m ()
164 begin conn = do
165 _ <- exec conn (fromString ("BEGIN;" :: String))
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
166 return ()
167
168 -- | Close a connection. Can safely be called any number of times.
169 close :: MonadIO m => Connection -- ^ The connection.
170 -> m ()
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
171 close Connection{connectionHandle} = liftIO$ do
172 modifyMVar_ connectionHandle $ \h -> do
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
173 case h of
174 Just h -> hClose h
175 Nothing -> return ()
176 return Nothing
177
178 -- | Run a simple query on a connection.
d1304add »
2012-03-14 Export base.
179 query :: (MonadIO m,MonadCatchIO m)
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
180 => Connection -- ^ The connection.
181 -> ByteString -- ^ The query.
182 -> m ([Field],[[Maybe ByteString]])
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
183 query conn sql = do
184 result <- execQuery conn sql
185 case result of
186 (_,Just ok) -> return ok
a4f16c51 »
2011-08-02 Use extensible exceptions.
187 _ -> return ([],[])
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
188
189 -- | Run a simple query on a connection.
d1304add »
2012-03-14 Export base.
190 execQuery :: (MonadIO m,MonadCatchIO m)
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
191 => Connection -- ^ The connection.
192 -> ByteString -- ^ The query.
193 -> m (Integer,Maybe ([Field],[[Maybe ByteString]]))
194 execQuery conn sql = liftIO $ do
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
195 withConnection conn $ \h -> do
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
196 types <- readMVar $ connectionObjects conn
197 Result{..} <- sendQuery types h sql
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
198 case resultType of
a4f16c51 »
2011-08-02 Use extensible exceptions.
199 ErrorResponse -> E.throw $ QueryError (fmap L.toString resultError)
200 EmptyQueryResponse -> E.throw QueryEmpty
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
201 _ ->
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
202 let tagCount = fromMaybe 0 resultTagRows
203 in case resultDesc of
204 Just fields -> return $ (tagCount,Just (fields,resultRows))
205 Nothing -> return $ (tagCount,Nothing)
206
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
207 -- | Exec a command.
d1304add »
2012-03-14 Export base.
208 exec :: (MonadIO m,MonadCatchIO m)
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
209 => Connection
210 -> ByteString
211 -> m Integer
212 exec conn sql = do
213 result <- execQuery conn sql
214 case result of
215 (ok,_) -> return ok
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
216
217 -- | PostgreSQL protocol version supported by this library.
218 protocolVersion :: Int32
219 protocolVersion = 196608
220
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
221 -- | Escape a string for PostgreSQL.
222 escape :: String -> String
a6edaf7c »
2011-06-05 Fix string escaping.
223 escape ('\\':cs) = '\\' : '\\' : escape cs
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
224 escape ('\'':cs) = '\'' : '\'' : escape cs
225 escape (c:cs) = c : escape cs
226 escape [] = []
227
228 -- | Escape a string for PostgreSQL.
229 escapeBS :: ByteString -> ByteString
230 escapeBS = fromString . escape . toString
231
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
232 --------------------------------------------------------------------------------
233 -- Authentication
234
235 -- | Run the connectInfoentication procedure.
236 authenticate :: Connection -> ConnectInfo -> IO ()
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
237 authenticate conn@Connection{..} connectInfo = do
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
238 withConnection conn $ \h -> do
239 sendStartUp h connectInfo
7ebdb14c »
2011-10-05 Support password-based authentication.
240 getConnectInfoResponse h connectInfo
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
241 objects <- objectIds h
242 modifyMVar_ connectionObjects (\_ -> return objects)
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
243
244 -- | Send the start-up message.
245 sendStartUp :: Handle -> ConnectInfo -> IO ()
246 sendStartUp h ConnectInfo{..} = do
247 sendBlock h Nothing $ do
248 int32 protocolVersion
249 string (fromString "user") ; string (fromString connectUser)
250 string (fromString "database") ; string (fromString connectDatabase)
251 zero
252
253 -- | Wait for and process the connectInfoentication response from the server.
7ebdb14c »
2011-10-05 Support password-based authentication.
254 getConnectInfoResponse :: Handle -> ConnectInfo -> IO ()
255 getConnectInfoResponse h conninfo = do
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
256 (typ,block) <- getMessage h
a4f16c51 »
2011-08-02 Use extensible exceptions.
257 -- TODO: Handle connectInfo failure. Handle information messages that are
258 -- sent, maybe store in the connection value for later
259 -- inspection.
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
260 case typ of
7ebdb14c »
2011-10-05 Support password-based authentication.
261 AuthenticationOk
262 | param == 0 -> waitForReady h
263 | param == 3 -> sendPassClearText h conninfo
264 -- | param == 5 -> sendPassMd5 h conninfo salt
265 | otherwise -> E.throw $ UnsupportedAuthenticationMethod param (show block)
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
266 where param = decode block :: Int32
7ebdb14c »
2011-10-05 Support password-based authentication.
267 _salt = flip runGet block $ do
268 _ <- getInt32
269 getWord8
270
271 els -> E.throw $ AuthenticationFailed (show (els,block))
272
273 -- | Send the pass as clear text and wait for connect response.
274 sendPassClearText :: Handle -> ConnectInfo -> IO ()
275 sendPassClearText h conninfo@ConnectInfo{..} = do
276 sendMessage h PasswordMessage $
277 string (fromString connectPassword)
278 getConnectInfoResponse h conninfo
279
280 -- -- | Send the pass as salted MD5 and wait for connect response.
281 -- sendPassMd5 :: Handle -> ConnectInfo -> Word8 -> IO ()
282 -- sendPassMd5 h conninfo@ConnectInfo{..} salt = do
283 -- -- TODO: Need md5 library with salt support.
284 -- sendMessage h PasswordMessage $
285 -- string (fromString connectPassword)
286 -- getConnectInfoResponse h conninfo
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
287
288 --------------------------------------------------------------------------------
289 -- Initialization
290
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
291 objectIds :: Handle -> IO (Map ObjectId String)
292 objectIds h = do
293 Result{..} <- sendQuery M.empty h q
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
294 case resultType of
a4f16c51 »
2011-08-02 Use extensible exceptions.
295 ErrorResponse -> E.throw $ InitializationError "Couldn't get types."
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
296 _ -> return $ M.fromList $ catMaybes $ flip map resultRows $ \row ->
297 case map toString $ catMaybes row of
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
298 [typ,readMay -> Just objId] -> Just $ (ObjectId objId,typ)
299 _ -> Nothing
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
300
301 where q = fromString ("SELECT typname, oid FROM pg_type" :: String)
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
302
303 --------------------------------------------------------------------------------
304 -- Queries and commands
305
306 -- | Send a simple query.
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
307 sendQuery :: Map ObjectId String -> Handle -> ByteString -> IO Result
308 sendQuery types h sql = do
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
309 sendMessage h Query $ string sql
310 listener $ \continue -> do
311 (typ,block) <- liftIO $ getMessage h
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
312 let setStatus = modify $ \r -> r { resultType = typ }
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
313 case typ of
a6edaf7c »
2011-06-05 Fix string escaping.
314 ReadyForQuery ->
315 modify $ \r -> r { resultRows = reverse (resultRows r) }
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
316
317 listenPassively -> do
318 case listenPassively of
319 EmptyQueryResponse -> setStatus
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
320 CommandComplete -> do setStatus
321 setCommandTag block
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
322 ErrorResponse -> do
323 modify $ \r -> r { resultError = Just block }
324 setStatus
325 RowDescription -> getRowDesc types block
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
326 DataRow -> getDataRow block
327 _ -> return ()
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
328
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
329 continue
330
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
331 where emptyResponse = Result [] Nothing Nothing [] UnknownMessageType Nothing
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
332 listener m = execStateT (fix m) emptyResponse
333
6b1d0fa9 »
2011-06-03 Transactions, execute statement, escaping.
334 -- | CommandComplete returns a ‘tag’ which indicates how many rows were
335 -- affected, or returned, as a result of the command.
336 -- See http://developer.postgresql.org/pgdocs/postgres/protocol-message-formats.html
337 setCommandTag :: MonadState Result m => L.ByteString -> m ()
338 setCommandTag block = do
339 modify $ \r -> r { resultTagRows = rows }
340 where rows =
341 case tag block of
342 ["INSERT",_oid,readMay -> Just rows] -> return rows
343 [cmd,readMay -> Just rows] | cmd `elem` cmds -> return rows
344 _ -> Nothing
345 tag = words . concat . map toString . L.toChunks . runGet getString
346 cmds = ["DELETE","UPDATE","SELECT","MOVE","FETCH"]
347
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
348 -- | Update the row description of the result.
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
349 getRowDesc :: MonadState Result m => Map ObjectId String -> L.ByteString -> m ()
350 getRowDesc types block =
351 modify $ \r -> r {
352 resultDesc = Just (parseFields types (runGet parseMsg block))
353 }
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
354 where parseMsg = do
355 fieldCount :: Int16 <- getInt16
356 forM [1..fieldCount] $ \_ -> do
357 name <- getString
358 objid <- getInt32
359 colid <- getInt16
360 dtype <- getInt32
361 size <- getInt16
362 modifier <- getInt32
363 code <- getInt16
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
364 return (name,objid,colid,dtype,size,modifier,code)
365
366 -- | Parse a row description.
367 --
368 -- Parts of the row description are:
369 --
370 -- String: The field name.
371 --
372 -- Int32: If the field can be identified as a column of a specific
373 -- table, the object ID of the table; otherwise zero.
374 --
375 -- Int16: If the field can be identified as a column of a specific
376 -- table, the attribute number of the column; otherwise zero.
377 ----
378 -- Int32: The object ID of the field's data type.
379 ----
380 -- Int16: The data type size (see pg_type.typlen). Note that negative
381 -- values denote variable-width types.
382 ----
383 -- Int32: The type modifier (see pg_attribute.atttypmod). The meaning
384 -- of the modifier is type-specific.
385 --
386 -- Int16: The format code being used for the field. Currently will be
387 -- zero (text) or one (binary). In a RowDescription returned from the
388 -- statement variant of Describe, the format code is not yet known and
389 -- will always be zero.
390 --
391 parseFields :: Map ObjectId String
392 -> [(L.ByteString,Int32,Int16,Int32,Int16,Int32,Int16)]
393 -> [Field]
394 parseFields types = map parse where
7a26af8c »
2011-06-03 Fixed things that should work, commented out things that don't.
395 parse (_fieldName
396 ,_ -- parseObjId -> _objectId
397 ,_ -- parseAttrId -> _attrId
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
398 ,parseType types -> typ
7a26af8c »
2011-06-03 Fixed things that should work, commented out things that don't.
399 ,_ -- parseSize -> _typeSize
400 ,_ -- parseModifier typ -> _typeModifier
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
401 ,parseFormatCode -> formatCode)
402 = Field {
403 fieldType = typ
7a26af8c »
2011-06-03 Fixed things that should work, commented out things that don't.
404 , fieldFormatCode = formatCode
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
405 }
406
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
407 -- These aren't used (yet).
408
409 -- -- | Parse an object ID. 0 means no object.
410 -- parseObjId :: Int32 -> Maybe ObjectId
411 -- parseObjId 0 = Nothing
412 -- parseObjId n = Just (ObjectId n)
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
413
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
414 -- -- | Parse an attribute ID. 0 means no object.
415 -- parseAttrId :: Int16 -> Maybe ObjectId
416 -- parseAttrId 0 = Nothing
417 -- parseAttrId n = Just (ObjectId $ fromIntegral n)
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
418
419 -- | Parse a number into a type.
420 parseType :: Map ObjectId String -> Int32 -> Type
421 parseType types objId =
422 case M.lookup (ObjectId objId) types of
423 Just name -> case typeFromName name of
424 Just typ -> typ
425 Nothing -> error $ "parseType: Unknown type: " ++ show name
7a26af8c »
2011-06-03 Fixed things that should work, commented out things that don't.
426 _ -> error $ "parseType: Unable to parse type: " ++ show objId
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
427
428 typeFromName :: String -> Maybe Type
429 typeFromName = flip lookup fieldTypes
430
7a26af8c »
2011-06-03 Fixed things that should work, commented out things that don't.
431 fieldTypes :: [(String, Type)]
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
432 fieldTypes =
433 [("bool",Boolean)
434 ,("int2",Short)
435 ,("integer",Long)
436 ,("int",Long)
437 ,("int4",Long)
438 ,("int8",LongLong)
beb05ae4 »
2011-06-02 Added more types, exports, removed some debug code.
439 ,("timestamptz",TimestampWithZone)
440 ,("varchar",CharVarying)
441 ,("text",Text)]
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
442
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
443 -- This isn't used yet.
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
444 -- | Parse a type's size.
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
445 -- parseSize :: Int16 -> Size
446 -- parseSize (-1) = Varying
447 -- parseSize n = Size n
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
448
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
449 -- This isn't used yet.
450 -- -- | Parse a type-specific modifier.
451 -- parseModifier :: Type -> Int32 -> Maybe Modifier
452 -- parseModifier _typ _modifier = Nothing
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
453
454 -- | Parse a format code (text or binary).
455 parseFormatCode :: Int16 -> FormatCode
456 parseFormatCode 1 = BinaryCode
457 parseFormatCode _ = TextCode
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
458
459 -- | Add a data row to the response.
460 getDataRow :: MonadState Result m => L.ByteString -> m ()
461 getDataRow block =
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
462 modify $ \r -> r { resultRows = runGet parseMsg block : resultRows r }
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
463 where parseMsg = do
464 values :: Int16 <- getInt16
465 forM [1..values] $ \_ -> do
466 size <- getInt32
467 if size == -1
468 then return Nothing
469 else do v <- getByteString (fromIntegral size)
470 return (Just v)
471
472 -- TODO:
7a26af8c »
2011-06-03 Fixed things that should work, commented out things that don't.
473 -- getNotice :: MonadState Result m => L.ByteString -> m ()
474 -- getNotice block =
475 -- return ()
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
476 -- modify $ \r -> r { responseNotices = runGet parseMsg block : responseNotices r }
477 -- where parseMsg = return ""
478
479 typeFromChar :: Char -> Maybe MessageType
480 typeFromChar c = lookup c types
481
482 charFromType :: MessageType -> Maybe Char
483 charFromType typ = fmap fst $ find ((==typ).snd) types
484
7a26af8c »
2011-06-03 Fixed things that should work, commented out things that don't.
485 types :: [(Char, MessageType)]
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
486 types = [('C',CommandComplete)
487 ,('T',RowDescription)
488 ,('D',DataRow)
489 ,('I',EmptyQueryResponse)
490 ,('E',ErrorResponse)
491 ,('Z',ReadyForQuery)
492 ,('N',NoticeResponse)
493 ,('R',AuthenticationOk)
7ebdb14c »
2011-10-05 Support password-based authentication.
494 ,('Q',Query)
495 ,('p',PasswordMessage)]
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
496
497 -- | Blocks until receives ReadyForQuery.
498 waitForReady :: Handle -> IO ()
499 waitForReady h = loop where
500 loop = do
501 (typ,block) <- getMessage h
502 case typ of
7ebdb14c »
2011-10-05 Support password-based authentication.
503 ErrorResponse -> E.throw $ GeneralError $ show block
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
504 ReadyForQuery | decode block == 'I' -> return ()
7a26af8c »
2011-06-03 Fixed things that should work, commented out things that don't.
505 _ -> loop
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
506
507 --------------------------------------------------------------------------------
508 -- Connections
509
510 -- | Atomically perform an action with the database handle, if there is one.
511 withConnection :: Connection -> (Handle -> IO a) -> IO a
512 withConnection Connection{..} m = do
513 withMVar connectionHandle $ \h -> do
514 case h of
515 Just h -> m h
516 -- TODO: Use extensible exceptions.
a4f16c51 »
2011-08-02 Use extensible exceptions.
517 Nothing -> E.throw ConnectionLost
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
518
519 -- | Send a block of bytes on a handle, prepending the message type
520 -- and complete length.
521 sendMessage :: Handle -> MessageType -> Put -> IO ()
522 sendMessage h typ output =
523 case charFromType typ of
524 Just char -> sendBlock h (Just char) output
a4f16c51 »
2011-08-02 Use extensible exceptions.
525 Nothing -> error $ "sendMessage: Bad message type " ++ show typ
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
526
527 -- | Send a block of bytes on a handle, prepending the complete length.
528 sendBlock :: Handle -> Maybe Char -> Put -> IO ()
529 sendBlock h typ output = do
530 L.hPutStr h bytes
531 where bytes = start `mappend` out
532 start = runPut $ do
533 maybe (return ()) (put . toByte) typ
534 int32 $ fromIntegral int32Size +
535 fromIntegral (L.length out)
536 out = runPut output
537 toByte c = fromIntegral (fromEnum c) :: Word8
538
539 -- | Get a message (block) from the stream.
540 getMessage :: Handle -> IO (MessageType,L.ByteString)
541 getMessage h = do
542 messageType <- L.hGet h 1
543 blockLength <- L.hGet h int32Size
544 let typ = decode messageType
545 rest = fromIntegral (decode blockLength :: Int32) - int32Size
546 block <- L.hGet h rest
547 return (maybe UnknownMessageType id $ typeFromChar typ,block)
548
549 --------------------------------------------------------------------------------
550 -- Binary input/output
551
552 -- | Put a Haskell string, encoding it to UTF-8, and null-terminating it.
3fb0b1f4 »
2011-06-02 Added PostgreSQL types, updated query function, Updated all parsers f…
553 string :: B.ByteString -> Put
554 string s = do putByteString s; zero
a77e39a4 »
2011-06-02 Sufficient types and dummy functions to build with mysql replaced by …
555
556 -- | Put a Haskell 32-bit integer.
557 int32 :: Int32 -> Put
558 int32 = put
559
560 -- | Put zero-byte terminator.
561 zero :: Put
562 zero = put (0 :: Word8)
563
564 -- | To avoid magic numbers, size of a 32-bit integer in bytes.
565 int32Size :: Int
566 int32Size = 4
567
568 getInt16 :: Get Int16
569 getInt16 = get
570
571 getInt32 :: Get Int32
572 getInt32 = get
573
574 getString :: Get L.ByteString
575 getString = getLazyByteStringNul
fb7a5b95 »
2011-08-02 Cleaned out some nonready functions and explicit export list.
576
577 readMay :: Read a => String -> Maybe a
578 readMay x = case reads x of
579 [(v,"")] -> return v
580 _ -> Nothing
Something went wrong with that request. Please try again.