module Data.Conduit.Pool
( ManagedResource (..)
, takeResource
, takeResourceCheck
, P.Pool
, P.createPool
, P.withResource
, withResourceTimeout
, withResourceT
) where
import qualified Data.Pool as P
import Control.Monad (liftM)
import Control.Monad.Trans.Resource
import Control.Monad.IO.Class (liftIO)
import qualified Data.IORef as I
import Control.Exception (onException, mask)
import System.Timeout (timeout)
import Control.Monad.Trans.Control (control)
data ManagedResource m a = ManagedResource
{ mrValue :: a
, mrReuse :: Bool -> m ()
, mrRelease :: m ()
}
withResourceT :: MonadResource m => P.Pool a -> (a -> m b) -> m b
withResourceT pool f = do
mr <- takeResource pool
b <- f $ mrValue mr
mrReuse mr True
mrRelease mr
return b
withResourceTimeout ::
#if MIN_VERSION_monad_control(0,3,0)
(MonadBaseControl IO m)
#else
(MonadControlIO m)
#endif
=> Int
-> P.Pool a
-> (a -> m b)
-> m (Maybe b)
withResourceTimeout ms pool act = control $ \runInIO -> mask $ \restore -> do
mres <- timeout ms $ P.takeResource pool
case mres of
Nothing -> runInIO $ return Nothing
Just (resource, local) -> do
ret <- restore (runInIO (liftM Just $ act resource)) `onException`
P.destroyResource pool local resource
P.putResource local resource
return ret
#if __GLASGOW_HASKELL__ >= 700
#endif
takeResource :: MonadResource m => P.Pool a -> m (ManagedResource m a)
takeResource pool = do
onRelRef <- liftIO $ I.newIORef False
(relKey, (a, _)) <- allocate
(P.takeResource pool)
(\(a, local) -> do
onRel <- I.readIORef onRelRef
if onRel
then P.putResource local a
else P.destroyResource pool local a)
return ManagedResource
{ mrValue = a
, mrReuse = liftIO . I.writeIORef onRelRef
, mrRelease = release relKey
}
takeResourceCheck :: MonadResource m
=> P.Pool a
-> (a -> m Bool)
-> m (ManagedResource m a)
takeResourceCheck pool check = do
mr <- takeResource pool
isValid <- check $ mrValue mr
if isValid
then return mr
else do
mrRelease mr
takeResourceCheck pool check