Permalink
Browse files

Connection pooling.

  • Loading branch information...
chrisdone committed Jun 5, 2011
1 parent a6edaf7 commit 57330b348f1014219a8df101234c9d3caa81ff85
Showing with 63 additions and 31 deletions.
  1. +45 −2 Database/PostgreSQL/Base.hs
  2. +11 −25 Database/PostgreSQL/Base/Types.hs
  3. +4 −1 Database/PostgreSQL/Simple.hs
  4. +3 −3 pgsql-simple.cabal
@@ -62,6 +62,49 @@ defaultConnectInfo = ConnectInfo {
, connectDatabase = ""
}
+-- | Create a new connection pool.
+newPool :: MonadIO m
+ => ConnectInfo -- ^ Connect info.
+ -> m Pool
+newPool info = liftIO $ do
+ var <- newMVar $ PoolState {
+ poolConnections = []
+ , poolConnectInfo = info
+ }
+ return $ Pool var
+
+-- | Connect using the connection pool.
+pconnect :: MonadIO m => Pool -> m Connection
+pconnect (Pool var) = liftIO $ do
+ modifyMVar var $ \state@PoolState{..} -> do
+ case poolConnections of
+ [] -> do conn <- connect poolConnectInfo
+ return (state,conn)
+ (conn:conns) -> return (state { poolConnections = conns },conn)
+
+-- | Restore a connection to the pool.
+restore :: MonadIO m => Pool -> Connection -> m ()
+restore (Pool var) conn = liftIO $ do
+ handle <- readMVar $ connectionHandle conn
+ modifyMVar_ var $ \state -> do
+ case handle of
+ Nothing -> return state
+ Just h -> do
+ eof <- hIsOpen h
+ if eof
+ then return state { poolConnections = conn : poolConnections state }
+ else return state
+
+-- | Use the connection pool.
+withPoolConnection
+ :: (MonadCatchIO m,MonadIO m)
+ => Pool -- ^ The connection pool.
+ -> (Connection -> m a) -- ^ Use the connection.
+ -> m ()
+withPoolConnection pool m = do
+ _ <- E.bracket (pconnect pool) (restore pool) m
+ return ()
+
-- | Connect with the given username to the given database. Will throw
-- an exception if it cannot connect.
connect :: MonadIO m => ConnectInfo -> m Connection -- ^ The datase connection.
@@ -75,8 +118,8 @@ connect connectInfo@ConnectInfo{..} = liftIO $ withSocketsDo $ do
authenticate conn connectInfo
return conn
-withDB :: (MonadCatchIO m,MonadIO m) => ConnectInfo -> (Connection -> m a) -> m a
-withDB connectInfo m = E.bracket (liftIO $ connect connectInfo) (liftIO . close) m
+-- withDB :: (MonadCatchIO m,MonadIO m) => ConnectInfo -> (Connection -> m a) -> m a
+-- withDB connectInfo m = E.bracket (liftIO $ connect connectInfo) (liftIO . close) m
-- | Rollback a transaction.
rollback :: (MonadCatchIO m,MonadIO m) => Connection -> m ()
@@ -10,7 +10,9 @@ module Database.PostgreSQL.Base.Types
,Size(..)
,FormatCode(..)
,Modifier(..)
- ,ObjectId(..))
+ ,ObjectId(..)
+ ,Pool(..)
+ ,PoolState(..))
where
import Control.Concurrent.MVar (MVar)
@@ -69,41 +71,19 @@ data Field = Field {
} deriving Show
data Type =
- -- These types ought to properly match their corresponding
- -- size in the database.
Short -- ^ 2 bytes, small-range integer
| Long -- ^ 4 bytes, usual choice for integer
| LongLong -- ^ 8 bytes large-range integer
-
- -- -- TODO: This choice for Decimal seems, pardon me,
- -- -- rational, as the precision ought to be
- -- -- infinite. However, I'm not confident in the choice.
| Decimal -- ^ variable, user-specified precision, exact, no limit
| Numeric -- ^ variable, user-specified precision, exact, no limit
-
- -- -- TODO: For the IEEE floating points, use isNaN and
- -- -- isInfinite.
- -- -- <http://www.postgresql.org/docs/current/static/datatype-numeric.html>
| Real -- ^ 4 bytes, variable-precision, inexact
| DoublePrecision -- ^ 8 bytes, variable-precision, inexact
- -- --
- -- | Serial Int32 -- ^ 4 bytes, autoincrementing integer
- -- | BigSerial Int64 -- ^ 8 bytes, large autoincrementing integer
-
- -- -- TODO: Is Money a double?
- -- | Money Double -- ^ 8 bytes, currency amount.
- -- -- See <http://www.postgresql.org/docs/current/static/datatype-money.html> for
- -- -- more information.
| CharVarying -- ^ character varying(n), varchar(n), variable-length
| Characters -- ^ character(n), char(n), fixed-length
| Text -- ^ text, variable unlimited length
--
-- Lazy. Decoded from UTF-8 into Haskell native encoding.
- -- | Bytes ByteString -- ^ 1 or 4 bytes plus the actual binary string
- --
- -- See <http://www.postgresql.org/docs/current/static/datatype-binary.html>
- -- for more information on this type. Strict.
| Boolean -- ^ boolean, 1 byte, state of true or false
@@ -114,8 +94,6 @@ data Type =
| TimestampWithZone -- ^ timestamp /with/ time zone
| Date -- ^ date, 4 bytes julian day
| Time -- ^ 8 bytes, time of day (no date)
- -- | ZonedTime ZonedTime -- ^ 12 bytes, times of day only, with time zone
- -- | Interval DiffTime -- ^ 12 bytes time interval
deriving (Eq,Enum,Show)
@@ -133,3 +111,11 @@ data Modifier = Modifier
-- | A PostgreSQL object ID.
newtype ObjectId = ObjectId Int32
deriving (Eq,Ord,Show)
+
+-- | A connection pool.
+data PoolState = PoolState {
+ poolConnections :: [Connection]
+ , poolConnectInfo :: ConnectInfo
+ }
+
+newtype Pool = Pool { unPool :: MVar PoolState }
@@ -50,11 +50,14 @@ module Database.PostgreSQL.Simple
, In(..)
, Binary(..)
, Only(..)
+ , Pool
-- ** Exceptions
, FormatError(fmtMessage, fmtQuery, fmtParams)
, QueryError(qeMessage, qeQuery)
, ResultError(errSQLType, errHaskellType, errMessage)
-- * Connection management
+ , Base.newPool
+ , Base.withPoolConnection
, Base.connect
, Base.defaultConnectInfo
, Base.close
@@ -88,7 +91,7 @@ import Data.ByteString (ByteString)
import Data.List (intersperse)
import Data.Monoid (mappend, mconcat)
import Data.Typeable (Typeable)
-import Database.PostgreSQL.Base.Types (ConnectInfo(..),Connection(..))
+import Database.PostgreSQL.Base.Types (ConnectInfo(..),Connection(..),Pool)
import Database.PostgreSQL.Simple.Param (Action(..), inQuotes)
import Database.PostgreSQL.Simple.QueryParams (QueryParams(..))
import Database.PostgreSQL.Simple.QueryResults (QueryResults(..))
View
@@ -1,5 +1,5 @@
name: pgsql-simple
-version: 0.0.3
+version: 0.1.1
homepage: https://github.com/chrisdone/pgsql-simple
bug-reports: https://github.com/chrisdone/pgsql-simple/issues
synopsis: A mid-level PostgreSQL client library.
@@ -43,11 +43,11 @@ library
network >= 2.2,
binary >= 0.5,
mtl >= 2.0,
- MonadCatchIO-mtl >= 0.3,
+ MonadCatchIO-transformers >= 0.2,
utf8-string >= 0.3 && < 0.4,
containers >= 0.3
- ghc-options: -Wall
+ ghc-options: -Wall -O2
if impl(ghc >= 6.8)
ghc-options: -fwarn-tabs

0 comments on commit 57330b3

Please sign in to comment.