pool 0.0.0 → 0.0.1

raw patch · 2 files changed

+56/−27 lines, 2 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Pool.hs +55/−26
• pool.cabal +1/−1

@@ -3,18 +3,19 @@ module Data.Pool     ( -- * Using pools       createPool+    , createPoolCheckAlive     , withPool     , withPool'+    , withPoolAllocate     , Pool       -- * Diagnostics     , PoolStats (..)     , poolStats     ) where -import Control.Concurrent.STM (atomically)-import Control.Concurrent.STM.TVar-    (TVar, newTVarIO, readTVar, writeTVar)+import Data.IORef (IORef, newIORef, atomicModifyIORef, readIORef) import Control.Exception (throwIO, Exception)+import qualified Control.Exception as E import Data.Typeable import qualified Control.Monad.IO.Peel as I import qualified Control.Exception.Peel as I@@ -28,8 +29,10 @@  data Pool a = Pool     { poolMax :: Int-    , poolData :: TVar (PoolData a)+    , poolData :: IORef (PoolData a)     , poolMake :: IO a+    , poolFree :: a -> IO ()+    , poolCheckAlive :: a -> IO Bool     }  data PoolStats = PoolStats@@ -39,22 +42,31 @@     }  poolStats :: Pool a -> IO PoolStats-poolStats (Pool m td _) = do-    d <- atomically $ readTVar td-    return $ PoolStats m (length $ poolAvail d) (poolCreated d)+poolStats p = do+    d <- readIORef $ poolData p+    return $ PoolStats (poolMax p) (length $ poolAvail d) (poolCreated d)  createPool :: (MonadIO m, I.MonadPeelIO m)            => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b) -> m b-createPool mk fr mx f = do-    pd <- liftIO $ newTVarIO $ PoolData [] 0-    I.finally (f $ Pool mx pd mk) $ liftIO $ do-        PoolData ress _ <- atomically $ readTVar pd+createPool mk fr mx f = createPoolCheckAlive mk fr mx f $ const $ return True++createPoolCheckAlive+    :: (MonadIO m, I.MonadPeelIO m)+    => IO a -> (a -> IO ()) -> Int -> (Pool a -> m b)+    -> (a -> IO Bool) -- ^ is the resource alive?+    -> m b+createPoolCheckAlive mk fr mx f ca = do+    pd <- liftIO $ newIORef $ PoolData [] 0+    I.finally (f $ Pool mx pd mk fr ca) $ liftIO $ do+        PoolData ress _ <- readIORef pd         mapM_ fr ress  data PoolExhaustedException = PoolExhaustedException     deriving (Show, Typeable) instance Exception PoolExhaustedException +-- | This function throws a 'PoolExhaustedException' when no resources are+-- available. See 'withPoolAllocate' to avoid this. withPool' :: (MonadIO m, I.MonadPeelIO m) => Pool a -> (a -> m b) -> m b withPool' p f = do     x <- withPool p f@@ -62,17 +74,27 @@         Nothing -> liftIO $ throwIO PoolExhaustedException         Just x' -> return x' +-- | Same as @withPool'@, but instead of throwing a 'PoolExhaustedException'+-- when there the maximum number of resources are created and allocated, it+-- allocates a new resource, passes it to the subprocess and then frees it.+withPoolAllocate :: I.MonadPeelIO m => Pool a -> (a -> m b) -> m b+withPoolAllocate p f = do+    x <- withPool p f+    case x of+        Just x' -> return x'+        Nothing ->+            I.bracket+                (liftIO $ poolMake p)+                (liftIO . poolFree p)+                f+ withPool :: (MonadIO m, I.MonadPeelIO m)          => Pool a -> (a -> m b) -> m (Maybe b) withPool p f = I.block $ do-    eres <- liftIO $ atomically $ do-        pd <- readTVar $ poolData p-        let (pd', eres) =-                case poolAvail pd of-                    (x:xs) -> (pd { poolAvail = xs }, Right x)-                    [] -> (pd, Left $ poolCreated pd)-        writeTVar (poolData p) pd'-        return eres+    eres <- liftIO $ atomicModifyIORef (poolData p) $ \pd ->+        case poolAvail pd of+            x:xs -> (pd { poolAvail = xs }, Right x)+            [] -> (pd, Left $ poolCreated pd)     case eres of         Left pc ->             if pc >= poolMax p@@ -81,13 +103,20 @@                     (liftIO $ poolMake p)                     (insertResource 1)                     (liftM Just . I.unblock . f)-        Right res -> I.finally+        Right res -> do+            isAlive <- liftIO $ E.try $ E.unblock $ poolCheckAlive p res+            case isAlive :: Either E.SomeException Bool of+                Right True ->+                    I.finally                         (liftM Just $ I.unblock $ f res)                         (insertResource 0 res)+                _ -> do+                    -- decrement the poolCreated count and then start over+                    liftIO $ atomicModifyIORef (poolData p) $ \pd ->+                        (pd { poolCreated = poolCreated pd - 1}, ())+                    I.unblock $ withPool p f   where-    insertResource i x = liftIO $ atomically $ do-        pd <- readTVar $ poolData p-        writeTVar (poolData p)-            pd { poolAvail = x : poolAvail pd-               , poolCreated = i + poolCreated pd-               }+    insertResource i x = liftIO $ atomicModifyIORef (poolData p) $ \pd ->+        (pd { poolAvail = x : poolAvail pd+                , poolCreated = i + poolCreated pd+                }, ())

@@ -1,5 +1,5 @@ name:            pool-version:         0.0.0+version:         0.0.1 license:         BSD3 license-file:    LICENSE author:          Michael Snoyman <michael@snoyman.com>