pool (empty) → 0.0.0

raw patch · 4 files changed

+145/−0 lines, 4 filesdep +basedep +monad-peeldep +stmsetup-changed

Dependencies added: base, monad-peel, stm, transformers

Files

• Data/Pool.hs +93/−0
• LICENSE +25/−0
• Setup.hs +2/−0
• pool.cabal +25/−0

@@ -0,0 +1,93 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE PackageImports #-}+module Data.Pool+    ( -- * Using pools+      createPool+    , withPool+    , withPool'+    , Pool+      -- * Diagnostics+    , PoolStats (..)+    , poolStats+    ) where++import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar+    (TVar, newTVarIO, readTVar, writeTVar)+import Control.Exception (throwIO, Exception)+import Data.Typeable+import qualified Control.Monad.IO.Peel as I+import qualified Control.Exception.Peel as I+import Control.Monad.IO.Class+import Control.Monad++data PoolData a = PoolData+    { poolAvail :: [a]+    , poolCreated :: Int+    }++data Pool a = Pool+    { poolMax :: Int+    , poolData :: TVar (PoolData a)+    , poolMake :: IO a+    }++data PoolStats = PoolStats+    { poolStatsMax :: Int+    , poolStatsAvailable :: Int+    , poolStatsCreated :: Int+    }++poolStats :: Pool a -> IO PoolStats+poolStats (Pool m td _) = do+    d <- atomically $ readTVar td+    return $ PoolStats m (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+        mapM_ fr ress++data PoolExhaustedException = PoolExhaustedException+    deriving (Show, Typeable)+instance Exception PoolExhaustedException++withPool' :: (MonadIO m, I.MonadPeelIO m) => Pool a -> (a -> m b) -> m b+withPool' p f = do+    x <- withPool p f+    case x of+        Nothing -> liftIO $ throwIO PoolExhaustedException+        Just x' -> return x'++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+    case eres of+        Left pc ->+            if pc >= poolMax p+                then return Nothing+                else I.bracket+                    (liftIO $ poolMake p)+                    (insertResource 1)+                    (liftM Just . I.unblock . f)+        Right res -> I.finally+                        (liftM Just $ I.unblock $ f res)+                        (insertResource 0 res)+  where+    insertResource i x = liftIO $ atomically $ do+        pd <- readTVar $ poolData p+        writeTVar (poolData p)+            pd { poolAvail = x : poolAvail pd+               , poolCreated = i + poolCreated pd+               }

@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+  list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+  this list of conditions and the following disclaimer in the documentation+  and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,25 @@+name:            pool+version:         0.0.0+license:         BSD3+license-file:    LICENSE+author:          Michael Snoyman <michael@snoyman.com>+maintainer:      Michael Snoyman <michael@snoyman.com>+synopsis:        Thread-safe resource pools.+description:     Useful for stuff like database connection pools.+category:        Data, Database, Yesod+stability:       Stable+cabal-version:   >= 1.6+build-type:      Simple+homepage:        http://github.com/snoyberg/pool++library+    build-depends:   base                     >= 4         && < 5+                   , transformers             >= 0.2.1     && < 0.3+                   , stm                      >= 2.1       && < 2.3+                   , monad-peel               >= 0.1       && < 0.2+    exposed-modules: Data.Pool+    ghc-options:     -Wall++source-repository head+  type:     git+  location: git://github.com/snoyberg/pool.git