Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

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