module System.IO.Pool where
import Control.Applicative ((<$>))
import Control.Monad.MVar
import Data.Array.IO
import Data.Maybe (catMaybes)
import Control.Monad.Error
import System.Random (randomRIO)
import Control.Exception (assert)
data Factory e r = Factory {
newResource :: ErrorT e IO r,
killResource :: r -> IO (),
isExpired :: r -> IO Bool }
newPool :: Factory e r -> Int -> IO (Pool e r)
newPool f n = assert (n > 0) $ do
arr <- newArray (0, n1) Nothing
var <- newMVar arr
return (Pool f var)
data Pool e r = Pool {factory :: Factory e r, resources :: MVar (IOArray Int (Maybe r))}
aResource :: (Error e) => Pool e r -> ErrorT e IO r
aResource Pool{..} = withMVar resources $ \array -> do
i <- liftIO $ randomRIO =<< getBounds array
mr <- liftIO $ readArray array i
r <- maybe (new array i) (check array i) mr
return r
where
new array i = do
r <- newResource factory
liftIO $ writeArray array i (Just r)
return r
check array i r = do
bad <- liftIO $ isExpired factory r
if bad then new array i else return r
poolSize :: Pool e r -> IO Int
poolSize Pool{resources} = withMVar resources (fmap rangeSize . getBounds)
resize :: Pool e r -> Int -> IO ()
resize Pool{resources} n = modifyMVar_ resources $ \array -> do
rs <- take n <$> getElems array
array' <- newListArray (0, n1) (rs ++ repeat Nothing)
return array'
killAll :: Pool e r -> IO ()
killAll (Pool Factory{killResource} resources) = withMVar resources $ \array -> do
mapM_ killResource . catMaybes =<< getElems array
mapM_ (\i -> writeArray array i Nothing) . range =<< getBounds array