Concurrent DB connection pool in Haskell

后端 未结 3 1617
無奈伤痛
無奈伤痛 2021-02-06 00:15

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

3条回答
  •  终归单人心
    2021-02-06 01:16

    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)
    

提交回复
热议问题