Concurrent DB connection pool in Haskell

Question

I am a Java programmer who learns Haskell.
I work on a small web-app that uses Happstack and talks to a database via HDBC.

I\'ve written select and

Answer 1

The resource-pool package provides a high-performance resource pool which can be used for database connection pooling. For example:

import Data.Pool (createPool, withResource)

main = do
    pool <- createPool newConn delConn 1 10 5
    withResource pool $ \conn -> doSomething conn

Creates a database connection pool with 1 sub-pool and up to 5 connections. Each connection is allowed to be idle for 10 seconds before being destroyed.

Answer 2

QUESTION 2: I've never used HDBC, but I'd probably write something like this.

trySql :: Connection -> (Connection -> IO a) -> IO a
trySql conn f = handleSql catcher $ do
    r <- f conn
    commit conn
    return r
  where catcher e = rollback conn >> throw e

Open the Connection somewhere outside of the function, and don't disconnect it within the function.

QUESTION 1: Hmm, a connection pool doesn't seem that hard to implement...

import Control.Concurrent
import Control.Exception

data Pool a =
    Pool { poolMin :: Int, poolMax :: Int, poolUsed :: Int, poolFree :: [a] }

newConnPool low high newConn delConn = do
    cs <- handleSqlError . sequence . replicate 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 (mPool, newConn, delConn) conn = modifyMVar_ mPool $ \pool ->
    let used = poolUsed pool in
    if used > poolMin conn
      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 conPool)

You probably shouldn't take this verbatim as I haven't even compile-tested it (and fail there is pretty unfriendly), but the idea is to do something like

connPool <- newConnPool 0 50 (connectSqlite3 "user.db") disconnect

and pass connPool around as needed.

Answer 3

I modified the code above, now it's able to compile at least.

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)