在Haskell并发数据库连接池(Concurrent DB connection pool in

我是一个Java程序员谁学习哈斯克尔。
我对使用Happstack，并通过华夏邓白氏中国会谈到数据库的小web应用程序的工作。

我已经写了选择和exec功能，我使用它们像这样：

module Main where

import Control.Exception (throw)

import Database.HDBC
import Database.HDBC.Sqlite3 -- just for this example, I use MySQL in production

main = do
    exec "CREATE TABLE IF NOT EXISTS users (name VARCHAR(80) NOT NULL)" []

    exec "INSERT INTO users VALUES ('John')" []
    exec "INSERT INTO users VALUES ('Rick')" []

    rows <- select "SELECT name FROM users" []

    let toS x = (fromSql x)::String
    let names = map (toS . head) rows

    print names

正如你看到的很简单。 有查询 ，则params和结果 。
连接的创建和提交/回滚东西在里面选择和exec隐藏。
这是好事，我不想去关心它在我的“逻辑”的代码。

exec :: String -> [SqlValue] -> IO Integer
exec query params = withDb $ \c -> run c query params

select :: String -> [SqlValue] -> IO [[SqlValue]]
select query params = withDb $ \c -> quickQuery' c query params

withDb :: (Connection -> IO a) -> IO a
withDb f = do
    conn <- handleSqlError $ connectSqlite3 "users.db"
    catchSql
        (do r <- f conn
            commit conn
            disconnect conn
            return r)
        (\e@(SqlError _ _ m) -> do
            rollback conn
            disconnect conn
            throw e)

优缺点：

• 一个新的连接总是在每次调用创建 - 这可以杀死重载性能
• DB URL“users.db”硬编码 - 我不能重复使用在其他项目中，这些功能的W / O编辑

问题1：怎样引入一些定义（最小，最大）的并行连接的数目的连接池，因此连接将选择/ exec调用之间被重新使用？

问题2：如何使“users.db”串配置？ （如何将其移动到客户端代码？）

这应该是一个透明的功能：用户代码不应该需要明确的连接处理/释放。

Answer 1:

问题2：我从未使用过华夏邓白氏中国，但我可能会写这样的事情。

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

打开Connection某个功能之外，并没有在函数内断开。

问题1：嗯，一个连接池似乎并不难实现？

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)

你或许不应该逐字以此为我还没有编译测试它（和fail有相当不友好的），但这个想法是做类似的东西

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

并通过connPool需要各地。

Answer 2:

的资源池包提供了可用于数据库连接池高性能资源池。 例如：

import Data.Pool (createPool, withResource)

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

创建一个带有1分池和多达5个连接的数据库连接池。 每个连接被允许被破坏之前被闲置10秒。

Answer 3:

我修改上面的代码，现在它至少能够编译。

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)

文章来源: Concurrent DB connection pool in Haskell