Параллельный пул соединений с БД в Haskell - PullRequest
Новая
       34

Параллельный пул соединений с БД в Haskell

10 голосов
/ 17 июля 2009

Я программист на Java, который изучает Haskell.
Я работаю над небольшим веб-приложением, которое использует Happstack и общается с базой данных через HDBC.

Я написал выберите и 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 и результат .
Создание соединения и фиксация / откат скрыты внутри select и 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)

Плохие баллы:

  • новое соединение всегда создается для каждого вызова - это снижает производительность при большой нагрузке
  • URL базы данных "users.db" жестко запрограммирован - я не могу использовать эти функции в других проектах без редактирования

ВОПРОС 1: как ввести пул соединений с некоторым определенным (мин., Макс.) Числом одновременных соединений, чтобы соединения были повторно использованы между вызовами select / exec?

ВОПРОС 2: Как сделать строку «users.db» настраиваемой? (Как перенести его в код клиента?)

Это должна быть прозрачная функция: пользовательский код не должен требовать явной обработки / освобождения соединения.

Ответы [ 3 ]

20 голосов
/ 01 мая 2012

Пакет resource-pool предоставляет высокопроизводительный пул ресурсов, который можно использовать для пула соединений с базой данных. Например: 

import Data.Pool (createPool, withResource)

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

Создает пул подключений к базе данных с 1 подпулем и до 5 подключений. Каждому соединению разрешено бездействовать в течение 10 секунд, прежде чем оно будет разорвано.

9 голосов
/ 17 июля 2009

ВОПРОС 2: Я никогда не использовал HDBC, но, вероятно, напишу что-то вроде этого. 

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 вокруг, если необходимо.

1 голос
/ 04 февраля 2011

Я изменил код выше, теперь он может компилироваться как минимум. 

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)
...