Remove System.IO.Pool (use resource-pool instead)
This commit is contained in:
parent
6e4decfa95
commit
b128bc7a09
2 changed files with 0 additions and 67 deletions
|
@ -1,66 +0,0 @@
|
||||||
{- | Cycle through a set of resources (randomly), recreating them when they expire -}
|
|
||||||
|
|
||||||
{-# LANGUAGE RecordWildCards, NamedFieldPuns, FlexibleContexts #-}
|
|
||||||
|
|
||||||
module System.IO.Pool where
|
|
||||||
|
|
||||||
import Control.Applicative ((<$>))
|
|
||||||
import Control.Exception (assert)
|
|
||||||
import Data.Array.IO (IOArray, readArray, writeArray, newArray, newListArray,
|
|
||||||
getElems, getBounds, rangeSize, range)
|
|
||||||
import Data.Maybe (catMaybes)
|
|
||||||
import System.Random (randomRIO)
|
|
||||||
|
|
||||||
import Control.Concurrent.MVar.Lifted (MVar, newMVar, withMVar, modifyMVar_)
|
|
||||||
import Control.Monad.Error (ErrorT, Error)
|
|
||||||
import Control.Monad.Trans (liftIO)
|
|
||||||
|
|
||||||
-- | Creator, destroyer, and checker of resources of type r. Creator may throw error or type e.
|
|
||||||
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)
|
|
||||||
-- ^ Create new pool of initial max size, which must be >= 1
|
|
||||||
newPool f n = assert (n > 0) $ do
|
|
||||||
arr <- newArray (0, n-1) Nothing
|
|
||||||
var <- newMVar arr
|
|
||||||
return (Pool f var)
|
|
||||||
|
|
||||||
data Pool e r = Pool {factory :: Factory e r, resources :: MVar (IOArray Int (Maybe r))}
|
|
||||||
-- ^ Pool of maximum N resources. Resources may expire on their own or be killed. Resources will initially be created on demand up N resources then recycled in random fashion. N may be changed by resizing the pool. Random is preferred to round-robin to distribute effect of pathological use cases that use every Xth resource the most and N is a multiple of X.
|
|
||||||
-- Resources *must* close/kill themselves when garbage collected ('resize' relies on this).
|
|
||||||
|
|
||||||
aResource :: (Error e) => Pool e r -> ErrorT e IO r
|
|
||||||
-- ^ Return a random live resource in pool or create new one if expired or not yet created
|
|
||||||
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
|
|
||||||
-- ^ current max size of pool
|
|
||||||
poolSize Pool{resources} = withMVar resources (fmap rangeSize . getBounds)
|
|
||||||
|
|
||||||
resize :: Pool e r -> Int -> IO ()
|
|
||||||
-- ^ resize max size of pool. When shrinking some resource will be dropped without closing since they may still be in use. They are expected to close themselves when garbage collected.
|
|
||||||
resize Pool{resources} n = modifyMVar_ resources $ \array -> do
|
|
||||||
rs <- take n <$> getElems array
|
|
||||||
array' <- newListArray (0, n-1) (rs ++ repeat Nothing)
|
|
||||||
return array'
|
|
||||||
|
|
||||||
killAll :: Pool e r -> IO ()
|
|
||||||
-- ^ Kill all resources in pool so subsequent access creates new ones
|
|
||||||
killAll (Pool Factory{killResource} resources) = withMVar resources $ \array -> do
|
|
||||||
mapM_ killResource . catMaybes =<< getElems array
|
|
||||||
mapM_ (\i -> writeArray array i Nothing) . range =<< getBounds array
|
|
|
@ -46,4 +46,3 @@ Library
|
||||||
Database.MongoDB.Internal.Util
|
Database.MongoDB.Internal.Util
|
||||||
Database.MongoDB.Query
|
Database.MongoDB.Query
|
||||||
System.IO.Pipeline
|
System.IO.Pipeline
|
||||||
System.IO.Pool
|
|
||||||
|
|
Loading…
Reference in a new issue