Skip to content
Browse files

Added back pooling, for now (closes #3).

  • Loading branch information...
1 parent a4a1ed1 commit b900ce547b644916ee35996ba7a7a110b712dc58 @chrisdone committed Nov 12, 2011
Showing with 47 additions and 1 deletion.
  1. +47 −1 Database/PostgreSQL/Base.hs
View
48 Database/PostgreSQL/Base.hs
@@ -16,7 +16,10 @@ module Database.PostgreSQL.Base
,defaultConnectInfo
,close
,withDB
- ,withTransaction)
+ ,withTransaction
+ ,newPool
+ ,pconnect
+ ,withPoolConnection)
where
import Database.PostgreSQL.Base.Types
@@ -75,6 +78,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.

0 comments on commit b900ce5

Please sign in to comment.
Something went wrong with that request. Please try again.