Created
February 4, 2011 11:01
-
-
Save voidlizard/810988 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module ConnPool ( newConnPool, withConn, delConnPool ) where | |
import Control.Concurrent | |
import Control.Exception | |
import Control.Monad (replicateM) | |
import Database.HDBC | |
data Pool a = | |
Pool { poolMin :: Int, poolMax :: Int, poolUsed :: Int, poolFree :: [a] } | |
newConnPool :: Int -> Int -> IO a -> (a -> IO ()) -> IO (MVar (Pool a), IO a, (a -> IO ())) | |
newConnPool low high newConn delConn = do | |
-- cs <- handleSqlError . sequence . replicate low newConn | |
cs <- replicateM low newConn | |
mPool <- newMVar $ Pool low high 0 cs | |
return (mPool, newConn, delConn) | |
delConnPool (mPool, newConn, delConn) = do | |
pool <- takeMVar mPool | |
if length (poolFree pool) /= poolUsed pool | |
then putMVar mPool pool >> fail "pool in use" | |
else mapM_ delConn $ poolFree pool | |
takeConn (mPool, newConn, delConn) = modifyMVar mPool $ \pool -> | |
case poolFree pool of | |
conn:cs -> | |
return (pool { poolUsed = poolUsed pool + 1, poolFree = cs }, conn) | |
_ | poolUsed pool < poolMax pool -> do | |
conn <- handleSqlError newConn | |
return (pool { poolUsed = poolUsed pool + 1 }, conn) | |
_ -> fail "pool is exhausted" | |
putConn :: (MVar (Pool a), IO a, (a -> IO b)) -> a -> IO () | |
putConn (mPool, newConn, delConn) conn = modifyMVar_ mPool $ \pool -> | |
let used = poolUsed pool in | |
if used > poolMin pool | |
then handleSqlError (delConn conn) >> return (pool { poolUsed = used - 1 }) | |
else return $ pool { poolUsed = used - 1, poolFree = conn : (poolFree pool) } | |
withConn connPool = bracket (takeConn connPool) (putConn connPool) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment