Script 'mail_helper' called by obssrc
Hello community,
here is the log from the commit of package ghc-resource-pool for
openSUSE:Factory checked in at 2022-08-01 21:30:24
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-resource-pool (Old)
and /work/SRC/openSUSE:Factory/.ghc-resource-pool.new.1533 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-resource-pool"
Mon Aug 1 21:30:24 2022 rev:11 rq:987083 version:0.3.1.0
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-resource-pool/ghc-resource-pool.changes
2020-12-22 11:45:29.457815766 +0100
+++
/work/SRC/openSUSE:Factory/.ghc-resource-pool.new.1533/ghc-resource-pool.changes
2022-08-01 21:30:44.721716094 +0200
@@ -1,0 +2,8 @@
+Wed Jun 15 21:02:08 UTC 2022 - Peter Simons <psim...@suse.com>
+
+- Update resource-pool to version 0.3.1.0.
+ Upstream added a new change log file in this release. With no
+ previous version to compare against, the automatic updater cannot
+ reliable determine the relevante entries for this release.
+
+-------------------------------------------------------------------
Old:
----
resource-pool-0.2.3.2.tar.gz
New:
----
resource-pool-0.3.1.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-resource-pool.spec ++++++
--- /var/tmp/diff_new_pack.UqrVXE/_old 2022-08-01 21:30:45.229717551 +0200
+++ /var/tmp/diff_new_pack.UqrVXE/_new 2022-08-01 21:30:45.237717574 +0200
@@ -1,7 +1,7 @@
#
# spec file for package ghc-resource-pool
#
-# Copyright (c) 2020 SUSE LLC
+# Copyright (c) 2022 SUSE LLC
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -18,21 +18,16 @@
%global pkg_name resource-pool
Name: ghc-%{pkg_name}
-Version: 0.2.3.2
+Version: 0.3.1.0
Release: 0
Summary: A high-performance striped resource pooling implementation
License: BSD-3-Clause
URL: https://hackage.haskell.org/package/%{pkg_name}
Source0:
https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz
BuildRequires: ghc-Cabal-devel
-BuildRequires: ghc-hashable-devel
-BuildRequires: ghc-monad-control-devel
+BuildRequires: ghc-primitive-devel
BuildRequires: ghc-rpm-macros
-BuildRequires: ghc-stm-devel
BuildRequires: ghc-time-devel
-BuildRequires: ghc-transformers-base-devel
-BuildRequires: ghc-transformers-devel
-BuildRequires: ghc-vector-devel
ExcludeArch: %{ix86}
%description
@@ -68,6 +63,6 @@
%license LICENSE
%files devel -f %{name}-devel.files
-%doc README.markdown
+%doc CHANGELOG.md README.md
%changelog
++++++ resource-pool-0.2.3.2.tar.gz -> resource-pool-0.3.1.0.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.2.3.2/CHANGELOG.md
new/resource-pool-0.3.1.0/CHANGELOG.md
--- old/resource-pool-0.2.3.2/CHANGELOG.md 1970-01-01 01:00:00.000000000
+0100
+++ new/resource-pool-0.3.1.0/CHANGELOG.md 2001-09-09 03:46:40.000000000
+0200
@@ -0,0 +1,10 @@
+# resource-pool-0.3.1.0 (2022-06-15)
+* Add `tryWithResource` and `tryTakeResource`.
+
+# resource-pool-0.3.0.0 (2022-06-01)
+* Rewrite based on `Control.Concurrent.QSem` for better throughput and latency.
+* Make release of resources asynchronous exceptions safe.
+* Remove dependency on `monad-control`.
+* Expose the `.Internal` module.
+* Add support for introspection.
+* Add `PoolConfig`.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.2.3.2/Data/Pool.hs
new/resource-pool-0.3.1.0/Data/Pool.hs
--- old/resource-pool-0.2.3.2/Data/Pool.hs 2014-12-16 10:01:10.000000000
+0100
+++ new/resource-pool-0.3.1.0/Data/Pool.hs 1970-01-01 01:00:00.000000000
+0100
@@ -1,393 +0,0 @@
-{-# LANGUAGE CPP, NamedFieldPuns, RecordWildCards, ScopedTypeVariables,
RankNTypes, DeriveDataTypeable #-}
-
-#if MIN_VERSION_monad_control(0,3,0)
-{-# LANGUAGE FlexibleContexts #-}
-#endif
-
-#if !MIN_VERSION_base(4,3,0)
-{-# LANGUAGE RankNTypes #-}
-#endif
-
--- |
--- Module: Data.Pool
--- Copyright: (c) 2011 MailRank, Inc.
--- License: BSD3
--- Maintainer: Bryan O'Sullivan <b...@serpentine.com>,
--- Bas van Dijk <v.dijk....@gmail.com>
--- Stability: experimental
--- Portability: portable
---
--- A high-performance striped pooling abstraction for managing
--- flexibly-sized collections of resources such as database
--- connections.
---
--- \"Striped\" means that a single 'Pool' consists of several
--- sub-pools, each managed independently. A single stripe is fine for
--- many applications, and probably what you should choose by default.
--- More stripes will lead to reduced contention in high-performance
--- multicore applications, at a trade-off of causing the maximum
--- number of simultaneous resources in use to grow.
-module Data.Pool
- (
- Pool(idleTime, maxResources, numStripes)
- , LocalPool
- , createPool
- , withResource
- , takeResource
- , tryWithResource
- , tryTakeResource
- , destroyResource
- , putResource
- , destroyAllResources
- ) where
-
-import Control.Applicative ((<$>))
-import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread, myThreadId,
threadDelay)
-import Control.Concurrent.STM
-import Control.Exception (SomeException, onException, mask_)
-import Control.Monad (forM_, forever, join, liftM3, unless, when)
-import Data.Hashable (hash)
-import Data.IORef (IORef, newIORef, mkWeakIORef)
-import Data.List (partition)
-import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime)
-import Data.Typeable (Typeable)
-import GHC.Conc.Sync (labelThread)
-import qualified Control.Exception as E
-import qualified Data.Vector as V
-
-#if MIN_VERSION_monad_control(0,3,0)
-import Control.Monad.Trans.Control (MonadBaseControl, control)
-import Control.Monad.Base (liftBase)
-#else
-import Control.Monad.IO.Control (MonadControlIO, controlIO)
-import Control.Monad.IO.Class (liftIO)
-#define control controlIO
-#define liftBase liftIO
-#endif
-
-#if MIN_VERSION_base(4,3,0)
-import Control.Exception (mask)
-#else
--- Don't do any async exception protection for older GHCs.
-mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b
-mask f = f id
-#endif
-
--- | A single resource pool entry.
-data Entry a = Entry {
- entry :: a
- , lastUse :: UTCTime
- -- ^ Time of last return.
- }
-
--- | A single striped pool.
-data LocalPool a = LocalPool {
- inUse :: TVar Int
- -- ^ Count of open entries (both idle and in use).
- , entries :: TVar [Entry a]
- -- ^ Idle entries.
- , lfin :: IORef ()
- -- ^ empty value used to attach a finalizer to (internal)
- } deriving (Typeable)
-
-data Pool a = Pool {
- create :: IO a
- -- ^ Action for creating a new entry to add to the pool.
- , destroy :: a -> IO ()
- -- ^ Action for destroying an entry that is now done with.
- , numStripes :: Int
- -- ^ The number of stripes (distinct sub-pools) to maintain.
- -- The smallest acceptable value is 1.
- , idleTime :: NominalDiffTime
- -- ^ Amount of time for which an unused resource is kept alive.
- -- The smallest acceptable value is 0.5 seconds.
- --
- -- The elapsed time before closing may be a little longer than
- -- requested, as the reaper thread wakes at 1-second intervals.
- , maxResources :: Int
- -- ^ Maximum number of resources to maintain per stripe. The
- -- smallest acceptable value is 1.
- --
- -- Requests for resources will block if this limit is reached on a
- -- single stripe, even if other stripes have idle resources
- -- available.
- , localPools :: V.Vector (LocalPool a)
- -- ^ Per-capability resource pools.
- , fin :: IORef ()
- -- ^ empty value used to attach a finalizer to (internal)
- } deriving (Typeable)
-
-instance Show (Pool a) where
- show Pool{..} = "Pool {numStripes = " ++ show numStripes ++ ", " ++
- "idleTime = " ++ show idleTime ++ ", " ++
- "maxResources = " ++ show maxResources ++ "}"
-
--- | Create a striped resource pool.
---
--- Although the garbage collector will destroy all idle resources when
--- the pool is garbage collected it's recommended to manually
--- 'destroyAllResources' when you're done with the pool so that the
--- resources are freed up as soon as possible.
-createPool
- :: IO a
- -- ^ Action that creates a new resource.
- -> (a -> IO ())
- -- ^ Action that destroys an existing resource.
- -> Int
- -- ^ The number of stripes (distinct sub-pools) to maintain.
- -- The smallest acceptable value is 1.
- -> NominalDiffTime
- -- ^ Amount of time for which an unused resource is kept open.
- -- The smallest acceptable value is 0.5 seconds.
- --
- -- The elapsed time before destroying a resource may be a little
- -- longer than requested, as the reaper thread wakes at 1-second
- -- intervals.
- -> Int
- -- ^ Maximum number of resources to keep open per stripe. The
- -- smallest acceptable value is 1.
- --
- -- Requests for resources will block if this limit is reached on a
- -- single stripe, even if other stripes have idle resources
- -- available.
- -> IO (Pool a)
-createPool create destroy numStripes idleTime maxResources = do
- when (numStripes < 1) $
- modError "pool " $ "invalid stripe count " ++ show numStripes
- when (idleTime < 0.5) $
- modError "pool " $ "invalid idle time " ++ show idleTime
- when (maxResources < 1) $
- modError "pool " $ "invalid maximum resource count " ++ show maxResources
- localPools <- V.replicateM numStripes $
- liftM3 LocalPool (newTVarIO 0) (newTVarIO []) (newIORef ())
- reaperId <- forkIOLabeledWithUnmask "resource-pool: reaper" $ \unmask ->
- unmask $ reaper destroy idleTime localPools
- fin <- newIORef ()
- let p = Pool {
- create
- , destroy
- , numStripes
- , idleTime
- , maxResources
- , localPools
- , fin
- }
- mkWeakIORef fin (killThread reaperId) >>
- V.mapM_ (\lp -> mkWeakIORef (lfin lp) (purgeLocalPool destroy lp))
localPools
- return p
-
--- TODO: Propose 'forkIOLabeledWithUnmask' for the base library.
-
--- | Sparks off a new thread using 'forkIOWithUnmask' to run the given
--- IO computation, but first labels the thread with the given label
--- (using 'labelThread').
---
--- The implementation makes sure that asynchronous exceptions are
--- masked until the given computation is executed. This ensures the
--- thread will always be labeled which guarantees you can always
--- easily find it in the GHC event log.
---
--- Like 'forkIOWithUnmask', the given computation is given a function
--- to unmask asynchronous exceptions. See the documentation of that
--- function for the motivation of this.
---
--- Returns the 'ThreadId' of the newly created thread.
-forkIOLabeledWithUnmask :: String
- -> ((forall a. IO a -> IO a) -> IO ())
- -> IO ThreadId
-forkIOLabeledWithUnmask label m = mask_ $ forkIOWithUnmask $ \unmask -> do
- tid <- myThreadId
- labelThread tid label
- m unmask
-
--- | Periodically go through all pools, closing any resources that
--- have been left idle for too long.
-reaper :: (a -> IO ()) -> NominalDiffTime -> V.Vector (LocalPool a) -> IO ()
-reaper destroy idleTime pools = forever $ do
- threadDelay (1 * 1000000)
- now <- getCurrentTime
- let isStale Entry{..} = now `diffUTCTime` lastUse > idleTime
- V.forM_ pools $ \LocalPool{..} -> do
- resources <- atomically $ do
- (stale,fresh) <- partition isStale <$> readTVar entries
- unless (null stale) $ do
- writeTVar entries fresh
- modifyTVar_ inUse (subtract (length stale))
- return (map entry stale)
- forM_ resources $ \resource -> do
- destroy resource `E.catch` \(_::SomeException) -> return ()
-
--- | Destroy all idle resources of the given 'LocalPool' and remove them from
--- the pool.
-purgeLocalPool :: (a -> IO ()) -> LocalPool a -> IO ()
-purgeLocalPool destroy LocalPool{..} = do
- resources <- atomically $ do
- idle <- swapTVar entries []
- modifyTVar_ inUse (subtract (length idle))
- return (map entry idle)
- forM_ resources $ \resource ->
- destroy resource `E.catch` \(_::SomeException) -> return ()
-
--- | Temporarily take a resource from a 'Pool', perform an action with
--- it, and return it to the pool afterwards.
---
--- * If the pool has an idle resource available, it is used
--- immediately.
---
--- * Otherwise, if the maximum number of resources has not yet been
--- reached, a new resource is created and used.
---
--- * If the maximum number of resources has been reached, this
--- function blocks until a resource becomes available.
---
--- If the action throws an exception of any type, the resource is
--- destroyed, and not returned to the pool.
---
--- It probably goes without saying that you should never manually
--- destroy a pooled resource, as doing so will almost certainly cause
--- a subsequent user (who expects the resource to be valid) to throw
--- an exception.
-withResource ::
-#if MIN_VERSION_monad_control(0,3,0)
- (MonadBaseControl IO m)
-#else
- (MonadControlIO m)
-#endif
- => Pool a -> (a -> m b) -> m b
-{-# SPECIALIZE withResource :: Pool a -> (a -> IO b) -> IO b #-}
-withResource pool act = control $ \runInIO -> mask $ \restore -> do
- (resource, local) <- takeResource pool
- ret <- restore (runInIO (act resource)) `onException`
- destroyResource pool local resource
- putResource local resource
- return ret
-#if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE withResource #-}
-#endif
-
--- | Take a resource from the pool, following the same results as
--- 'withResource'. Note that this function should be used with caution, as
--- improper exception handling can lead to leaked resources.
---
--- This function returns both a resource and the @LocalPool@ it came from so
--- that it may either be destroyed (via 'destroyResource') or returned to the
--- pool (via 'putResource').
-takeResource :: Pool a -> IO (a, LocalPool a)
-takeResource pool@Pool{..} = do
- local@LocalPool{..} <- getLocalPool pool
- resource <- liftBase . join . atomically $ do
- ents <- readTVar entries
- case ents of
- (Entry{..}:es) -> writeTVar entries es >> return (return entry)
- [] -> do
- used <- readTVar inUse
- when (used == maxResources) retry
- writeTVar inUse $! used + 1
- return $
- create `onException` atomically (modifyTVar_ inUse (subtract 1))
- return (resource, local)
-#if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE takeResource #-}
-#endif
-
--- | Similar to 'withResource', but only performs the action if a resource
could
--- be taken from the pool /without blocking/. Otherwise, 'tryWithResource'
--- returns immediately with 'Nothing' (ie. the action function is /not/
called).
--- Conversely, if a resource can be borrowed from the pool without blocking,
the
--- action is performed and it's result is returned, wrapped in a 'Just'.
-tryWithResource :: forall m a b.
-#if MIN_VERSION_monad_control(0,3,0)
- (MonadBaseControl IO m)
-#else
- (MonadControlIO m)
-#endif
- => Pool a -> (a -> m b) -> m (Maybe b)
-tryWithResource pool act = control $ \runInIO -> mask $ \restore -> do
- res <- tryTakeResource pool
- case res of
- Just (resource, local) -> do
- ret <- restore (runInIO (Just <$> act resource)) `onException`
- destroyResource pool local resource
- putResource local resource
- return ret
- Nothing -> restore . runInIO $ return (Nothing :: Maybe b)
-#if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE tryWithResource #-}
-#endif
-
--- | A non-blocking version of 'takeResource'. The 'tryTakeResource' function
--- returns immediately, with 'Nothing' if the pool is exhausted, or @'Just' (a,
--- 'LocalPool' a)@ if a resource could be borrowed from the pool successfully.
-tryTakeResource :: Pool a -> IO (Maybe (a, LocalPool a))
-tryTakeResource pool@Pool{..} = do
- local@LocalPool{..} <- getLocalPool pool
- resource <- liftBase . join . atomically $ do
- ents <- readTVar entries
- case ents of
- (Entry{..}:es) -> writeTVar entries es >> return (return . Just $ entry)
- [] -> do
- used <- readTVar inUse
- if used == maxResources
- then return (return Nothing)
- else do
- writeTVar inUse $! used + 1
- return $ Just <$>
- create `onException` atomically (modifyTVar_ inUse (subtract 1))
- return $ (flip (,) local) <$> resource
-#if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE tryTakeResource #-}
-#endif
-
--- | Get a (Thread-)'LocalPool'
---
--- Internal, just to not repeat code for 'takeResource' and 'tryTakeResource'
-getLocalPool :: Pool a -> IO (LocalPool a)
-getLocalPool Pool{..} = do
- i <- liftBase $ ((`mod` numStripes) . hash) <$> myThreadId
- return $ localPools V.! i
-#if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE getLocalPool #-}
-#endif
-
--- | Destroy a resource. Note that this will ignore any exceptions in the
--- destroy function.
-destroyResource :: Pool a -> LocalPool a -> a -> IO ()
-destroyResource Pool{..} LocalPool{..} resource = do
- destroy resource `E.catch` \(_::SomeException) -> return ()
- atomically (modifyTVar_ inUse (subtract 1))
-#if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE destroyResource #-}
-#endif
-
--- | Return a resource to the given 'LocalPool'.
-putResource :: LocalPool a -> a -> IO ()
-putResource LocalPool{..} resource = do
- now <- getCurrentTime
- atomically $ modifyTVar_ entries (Entry resource now:)
-#if __GLASGOW_HASKELL__ >= 700
-{-# INLINABLE putResource #-}
-#endif
-
--- | Destroy all resources in all stripes in the pool. Note that this
--- will ignore any exceptions in the destroy function.
---
--- This function is useful when you detect that all resources in the
--- pool are broken. For example after a database has been restarted
--- all connections opened before the restart will be broken. In that
--- case it's better to close those connections so that 'takeResource'
--- won't take a broken connection from the pool but will open a new
--- connection instead.
---
--- Another use-case for this function is that when you know you are
--- done with the pool you can destroy all idle resources immediately
--- instead of waiting on the garbage collector to destroy them, thus
--- freeing up those resources sooner.
-destroyAllResources :: Pool a -> IO ()
-destroyAllResources Pool{..} = V.forM_ localPools $ purgeLocalPool destroy
-
-modifyTVar_ :: TVar a -> (a -> a) -> STM ()
-modifyTVar_ v f = readTVar v >>= \a -> writeTVar v $! f a
-
-modError :: String -> String -> a
-modError func msg =
- error $ "Data.Pool." ++ func ++ ": " ++ msg
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.2.3.2/README.markdown
new/resource-pool-0.3.1.0/README.markdown
--- old/resource-pool-0.2.3.2/README.markdown 2014-12-16 10:01:10.000000000
+0100
+++ new/resource-pool-0.3.1.0/README.markdown 1970-01-01 01:00:00.000000000
+0100
@@ -1,28 +0,0 @@
-# Welcome to pool
-
-pool is a fast Haskell library for managing medium-lifetime pooled
-resources, such as database connections.
-
-# Join in!
-
-We are happy to receive bug reports, fixes, documentation enhancements,
-and other improvements.
-
-Please report bugs via the
-[github issue tracker](http://github.com/bos/pool/issues).
-
-Master [git repository](http://github.com/bos/pool):
-
-* `git clone git://github.com/bos/pool.git`
-
-There's also a [Mercurial mirror](http://bitbucket.org/bos/pool):
-
-* `hg clone http://bitbucket.org/bos/pool`
-
-(You can create and contribute changes using either git or Mercurial.)
-
-Authors
--------
-
-This library is written and maintained by Bryan O'Sullivan,
-<b...@serpentine.com>.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.2.3.2/README.md
new/resource-pool-0.3.1.0/README.md
--- old/resource-pool-0.2.3.2/README.md 1970-01-01 01:00:00.000000000 +0100
+++ new/resource-pool-0.3.1.0/README.md 2001-09-09 03:46:40.000000000 +0200
@@ -0,0 +1,10 @@
+# resource-pool
+
+[](https://github.com/scrive/pool/actions?query=branch%3Amaster)
+[](https://hackage.haskell.org/package/resource-pool)
+[](https://packdeps.haskellers.com/feed?needle=andr...@rybczak.net)
+[](https://www.stackage.org/lts/package/resource-pool)
+[](https://www.stackage.org/nightly/package/resource-pool)
+
+A high-performance striped resource pooling implementation for Haskell based on
+[QSem](https://hackage.haskell.org/package/base/docs/Control-Concurrent-QSem.html).
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.2.3.2/Setup.lhs
new/resource-pool-0.3.1.0/Setup.lhs
--- old/resource-pool-0.2.3.2/Setup.lhs 2014-12-16 10:01:10.000000000 +0100
+++ new/resource-pool-0.3.1.0/Setup.lhs 1970-01-01 01:00:00.000000000 +0100
@@ -1,3 +0,0 @@
-#!/usr/bin/env runhaskell
-> import Distribution.Simple
-> main = defaultMain
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.2.3.2/resource-pool.cabal
new/resource-pool-0.3.1.0/resource-pool.cabal
--- old/resource-pool-0.2.3.2/resource-pool.cabal 2014-12-16
10:01:10.000000000 +0100
+++ new/resource-pool-0.3.1.0/resource-pool.cabal 2001-09-09
03:46:40.000000000 +0200
@@ -1,55 +1,46 @@
+cabal-version: 2.4
+build-type: Simple
name: resource-pool
-version: 0.2.3.2
-synopsis: A high-performance striped resource pooling implementation
-description:
- A high-performance striped pooling abstraction for managing
- flexibly-sized collections of resources such as database
- connections.
-
-homepage: http://github.com/bos/pool
-license: BSD3
+version: 0.3.1.0
+license: BSD-3-Clause
license-file: LICENSE
-author: Bryan O'Sullivan <b...@serpentine.com>
-maintainer: Bryan O'Sullivan <b...@serpentine.com>,
- Bas van Dijk <v.dijk....@gmail.com>
-copyright: Copyright 2011 MailRank, Inc.
category: Data, Database, Network
-build-type: Simple
-extra-source-files:
- README.markdown
+maintainer: andr...@rybczak.net
+author: Andrzej Rybczak, Bryan O'Sullivan
-cabal-version: >=1.8
-
-flag developer
- description: operate in developer mode
- default: False
- manual: True
+synopsis: A high-performance striped resource pooling implementation
-library
- exposed-modules:
- Data.Pool
+description: A high-performance striped pooling abstraction for managing
+ flexibly-sized collections of resources such as database
+ connections.
- build-depends:
- base >= 4.4 && < 5,
- hashable,
- monad-control >= 0.2.0.1,
- transformers,
- transformers-base >= 0.4,
- stm >= 2.3,
- time,
- vector >= 0.7
-
- if flag(developer)
- ghc-options: -Werror
- ghc-prof-options: -auto-all
- cpp-options: -DASSERTS -DDEBUG
+tested-with: GHC ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.0.2 ||
==9.2.3
- ghc-options: -Wall
+extra-doc-files:
+ CHANGELOG.md
+ README.md
+bug-reports: https://github.com/scrive/pool/issues
source-repository head
type: git
- location: http://github.com/bos/pool
+ location: https://github.com/scrive/pool.git
-source-repository head
- type: mercurial
- location: http://bitbucket.org/bos/pool
+library
+ hs-source-dirs: src
+
+ exposed-modules: Data.Pool
+ Data.Pool.Internal
+ Data.Pool.Introspection
+
+ build-depends: base >= 4.11 && < 5
+ , primitive >= 0.7
+ , time
+
+ ghc-options: -Wall -Wcompat
+
+ default-language: Haskell2010
+
+ default-extensions: DeriveGeneric
+ , LambdaCase
+ , RankNTypes
+ , TypeApplications
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.2.3.2/src/Data/Pool/Internal.hs
new/resource-pool-0.3.1.0/src/Data/Pool/Internal.hs
--- old/resource-pool-0.2.3.2/src/Data/Pool/Internal.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/resource-pool-0.3.1.0/src/Data/Pool/Internal.hs 2001-09-09
03:46:40.000000000 +0200
@@ -0,0 +1,275 @@
+-- | Internal implementation details for "Data.Pool".
+--
+-- This module is intended for internal use only, and may change without
warning
+-- in subsequent releases.
+{-# OPTIONS_HADDOCK not-home #-}
+module Data.Pool.Internal where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Data.IORef
+import Data.Primitive.SmallArray
+import GHC.Clock
+import qualified Data.List as L
+
+-- | Striped resource pool based on "Control.Concurrent.QSem".
+--
+-- The number of stripes is arranged to be equal to the number of capabilities
+-- so that they never compete over access to the same stripe. This results in a
+-- very good performance in a multi-threaded environment.
+data Pool a = Pool
+ { poolConfig :: !(PoolConfig a)
+ , localPools :: !(SmallArray (LocalPool a))
+ , reaperRef :: !(IORef ())
+ }
+
+-- | A single, capability-local pool.
+data LocalPool a = LocalPool
+ { stripeId :: !Int
+ , stripeVar :: !(MVar (Stripe a))
+ , cleanerRef :: !(IORef ())
+ }
+
+-- | Stripe of a resource pool. If @available@ is 0, the list of threads
waiting
+-- for a resource (each with an associated 'MVar') is @queue ++ reverse
queueR@.
+data Stripe a = Stripe
+ { available :: !Int
+ , cache :: ![Entry a]
+ , queue :: !(Queue a)
+ , queueR :: !(Queue a)
+ }
+
+-- | An existing resource currently sitting in a pool.
+data Entry a = Entry
+ { entry :: a
+ , lastUsed :: !Double
+ }
+
+-- | A queue of MVarS corresponding to threads waiting for resources.
+--
+-- Basically a monomorphic list to save two pointer indirections.
+data Queue a = Queue !(MVar (Maybe a)) (Queue a) | Empty
+
+-- | Configuration of a 'Pool'.
+data PoolConfig a = PoolConfig
+ { createResource :: !(IO a)
+ -- ^ The action that creates a new resource.
+ , freeResource :: !(a -> IO ())
+ -- ^ The action that destroys an existing resource.
+ , poolCacheTTL :: !Double
+ -- ^ The amount of seconds for which an unused resource is kept around. The
+ -- smallest acceptable value is @0.5@.
+ --
+ -- /Note:/ the elapsed time before destroying a resource may be a little
+ -- longer than requested, as the collector thread wakes at 1-second
intervals.
+ , poolMaxResources :: !Int
+ -- ^ The maximum number of resources to keep open across all stripes. The
+ -- smallest acceptable value is @1@.
+ --
+ -- /Note:/ for each stripe the number of resources is divided by the number
of
+ -- capabilities and rounded up. Therefore the pool might end up creating up
to
+ -- @N - 1@ resources more in total than specified, where @N@ is the number of
+ -- capabilities.
+ }
+
+-- | Create a new striped resource pool.
+--
+-- The number of stripes is equal to the number of capabilities.
+--
+-- /Note:/ although the runtime system will destroy all idle resources when the
+-- pool is garbage collected, it's recommended to manually call
+-- 'destroyAllResources' when you're done with the pool so that the resources
+-- are freed up as soon as possible.
+newPool :: PoolConfig a -> IO (Pool a)
+newPool pc = do
+ when (poolCacheTTL pc < 0.5) $ do
+ error "poolCacheTTL must be at least 0.5"
+ when (poolMaxResources pc < 1) $ do
+ error "poolMaxResources must be at least 1"
+ numStripes <- getNumCapabilities
+ when (numStripes < 1) $ do
+ error "numStripes must be at least 1"
+ pools <- fmap (smallArrayFromListN numStripes) . forM [1..numStripes] $ \n
-> do
+ ref <- newIORef ()
+ stripe <- newMVar Stripe
+ { available = poolMaxResources pc `quotCeil` numStripes
+ , cache = []
+ , queue = Empty
+ , queueR = Empty
+ }
+ -- When the local pool goes out of scope, free its resources.
+ void . mkWeakIORef ref $ cleanStripe (const True) (freeResource pc) stripe
+ pure LocalPool { stripeId = n
+ , stripeVar = stripe
+ , cleanerRef = ref
+ }
+ mask_ $ do
+ ref <- newIORef ()
+ collectorA <- forkIOWithUnmask $ \unmask -> unmask $ collector pools
+ void . mkWeakIORef ref $ do
+ -- When the pool goes out of scope, stop the collector. Resources
existing
+ -- in stripes will be taken care by their cleaners.
+ killThread collectorA
+ pure Pool { poolConfig = pc
+ , localPools = pools
+ , reaperRef = ref
+ }
+ where
+ quotCeil :: Int -> Int -> Int
+ quotCeil x y =
+ -- Basically ceiling (x / y) without going through Double.
+ let (z, r) = x `quotRem` y in if r == 0 then z else z + 1
+
+ -- Collect stale resources from the pool once per second.
+ collector pools = forever $ do
+ threadDelay 1000000
+ now <- getMonotonicTime
+ let isStale e = now - lastUsed e > poolCacheTTL pc
+ mapM_ (cleanStripe isStale (freeResource pc) . stripeVar) pools
+
+-- | Destroy a resource.
+--
+-- Note that this will ignore any exceptions in the destroy function.
+destroyResource :: Pool a -> LocalPool a -> a -> IO ()
+destroyResource pool lp a = do
+ uninterruptibleMask_ $ do -- Note [signal uninterruptible]
+ stripe <- takeMVar (stripeVar lp)
+ newStripe <- signal stripe Nothing
+ putMVar (stripeVar lp) newStripe
+ void . try @SomeException $ freeResource (poolConfig pool) a
+
+-- | Return a resource to the given 'LocalPool'.
+putResource :: LocalPool a -> a -> IO ()
+putResource lp a = do
+ uninterruptibleMask_ $ do -- Note [signal uninterruptible]
+ stripe <- takeMVar (stripeVar lp)
+ newStripe <- signal stripe (Just a)
+ putMVar (stripeVar lp) newStripe
+
+-- | Destroy all resources in all stripes in the pool.
+--
+-- Note that this will ignore any exceptions in the destroy function.
+--
+-- This function is useful when you detect that all resources in the pool are
+-- broken. For example after a database has been restarted all connections
+-- opened before the restart will be broken. In that case it's better to close
+-- those connections so that 'takeResource' won't take a broken connection from
+-- the pool but will open a new connection instead.
+--
+-- Another use-case for this function is that when you know you are done with
+-- the pool you can destroy all idle resources immediately instead of waiting
on
+-- the garbage collector to destroy them, thus freeing up those resources
+-- sooner.
+destroyAllResources :: Pool a -> IO ()
+destroyAllResources pool = forM_ (localPools pool) $ \lp -> do
+ cleanStripe (const True) (freeResource (poolConfig pool)) (stripeVar lp)
+
+----------------------------------------
+-- Helpers
+
+-- | Get a capability-local pool.
+getLocalPool :: SmallArray (LocalPool a) -> IO (LocalPool a)
+getLocalPool pools = do
+ (cid, _) <- threadCapability =<< myThreadId
+ pure $ pools `indexSmallArray` (cid `rem` sizeofSmallArray pools)
+
+-- | Wait for the resource to be put into a given 'MVar'.
+waitForResource :: MVar (Stripe a) -> MVar (Maybe a) -> IO (Maybe a)
+waitForResource mstripe q = takeMVar q `onException` cleanup
+ where
+ cleanup = uninterruptibleMask_ $ do -- Note [signal uninterruptible]
+ stripe <- takeMVar mstripe
+ newStripe <- tryTakeMVar q >>= \case
+ Just ma -> do
+ -- Between entering the exception handler and taking ownership of
+ -- the stripe we got the resource we wanted. We don't need it
+ -- anymore though, so pass it to someone else.
+ signal stripe ma
+ Nothing -> do
+ -- If we're still waiting, fill up the MVar with an undefined value
+ -- so that 'signal' can discard our MVar from the queue.
+ putMVar q $ error "unreachable"
+ pure stripe
+ putMVar mstripe newStripe
+
+-- | If an exception is received while a resource is being created, restore the
+-- original size of the stripe.
+restoreSize :: MVar (Stripe a) -> IO ()
+restoreSize mstripe = uninterruptibleMask_ $ do
+ -- 'uninterruptibleMask_' is used since 'takeMVar' might block.
+ stripe <- takeMVar mstripe
+ putMVar mstripe $! stripe { available = available stripe + 1 }
+
+-- | Free resource entries in the stripes that fulfil a given condition.
+cleanStripe
+ :: (Entry a -> Bool)
+ -> (a -> IO ())
+ -> MVar (Stripe a)
+ -> IO ()
+cleanStripe isStale free mstripe = mask $ \unmask -> do
+ -- Asynchronous exceptions need to be masked here to prevent leaking of
+ -- 'stale' resources before they're freed.
+ stale <- modifyMVar mstripe $ \stripe -> unmask $ do
+ let (stale, fresh) = L.partition isStale (cache stripe)
+ -- There's no need to update 'available' here because it only tracks
+ -- the number of resources taken from the pool.
+ newStripe = stripe { cache = fresh }
+ newStripe `seq` pure (newStripe, map entry stale)
+ -- We need to ignore exceptions in the 'free' function, otherwise if an
+ -- exception is thrown half-way, we leak the rest of the resources. Also,
+ -- asynchronous exceptions need to be hard masked here since freeing a
+ -- resource might in theory block.
+ uninterruptibleMask_ . forM_ stale $ try @SomeException . free
+
+-- Note [signal uninterruptible]
+--
+-- If we have
+--
+-- bracket takeResource putResource (...)
+--
+-- and an exception arrives at the putResource, then we must not lose the
+-- resource. The putResource is masked by bracket, but taking the MVar might
+-- block, and so it would be interruptible. Hence we need an uninterruptible
+-- variant of mask here.
+signal :: Stripe a -> Maybe a -> IO (Stripe a)
+signal stripe ma = if available stripe == 0
+ then loop (queue stripe) (queueR stripe)
+ else do
+ newCache <- case ma of
+ Just a -> do
+ now <- getMonotonicTime
+ pure $ Entry a now : cache stripe
+ Nothing -> pure $ cache stripe
+ pure $! stripe { available = available stripe + 1
+ , cache = newCache
+ }
+ where
+ loop Empty Empty = do
+ newCache <- case ma of
+ Just a -> do
+ now <- getMonotonicTime
+ pure [Entry a now]
+ Nothing -> pure []
+ pure $! Stripe { available = 1
+ , cache = newCache
+ , queue = Empty
+ , queueR = Empty
+ }
+ loop Empty qR = loop (reverseQueue qR) Empty
+ loop (Queue q qs) qR = tryPutMVar q ma >>= \case
+ -- This fails when 'waitForResource' went into the exception handler and
+ -- filled the MVar (with an undefined value) itself. In such case we
+ -- simply ignore it.
+ False -> loop qs qR
+ True -> pure $! stripe { available = 0
+ , queue = qs
+ , queueR = qR
+ }
+
+reverseQueue :: Queue a -> Queue a
+reverseQueue = go Empty
+ where
+ go acc = \case
+ Empty -> acc
+ Queue x xs -> go (Queue x acc) xs
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.2.3.2/src/Data/Pool/Introspection.hs
new/resource-pool-0.3.1.0/src/Data/Pool/Introspection.hs
--- old/resource-pool-0.2.3.2/src/Data/Pool/Introspection.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/resource-pool-0.3.1.0/src/Data/Pool/Introspection.hs 2001-09-09
03:46:40.000000000 +0200
@@ -0,0 +1,151 @@
+-- | A variant of "Data.Pool" with introspection capabilities.
+module Data.Pool.Introspection
+ ( -- * Pool
+ PoolConfig(..)
+ , Pool
+ , LocalPool
+ , newPool
+
+ -- * Resource management
+ , Resource(..)
+ , Acquisition(..)
+ , withResource
+ , takeResource
+ , tryWithResource
+ , tryTakeResource
+ , putResource
+ , destroyResource
+ , destroyAllResources
+ ) where
+
+import Control.Concurrent
+import Control.Exception
+import GHC.Clock
+import GHC.Generics (Generic)
+
+import Data.Pool.Internal
+
+-- | A resource taken from the pool along with additional information.
+data Resource a = Resource
+ { resource :: a
+ , stripeNumber :: !Int
+ , availableResources :: !Int
+ , acquisition :: !Acquisition
+ , acquisitionTime :: !Double
+ , creationTime :: !(Maybe Double)
+ } deriving (Eq, Show, Generic)
+
+-- | Describes how a resource was acquired from the pool.
+data Acquisition
+ = Immediate
+ -- ^ A resource was taken from the pool immediately.
+ | Delayed
+ -- ^ The thread had to wait until a resource was released.
+ deriving (Eq, Show, Generic)
+
+-- | 'Data.Pool.withResource' with introspection capabilities.
+withResource :: Pool a -> (Resource a -> IO r) -> IO r
+withResource pool act = mask $ \unmask -> do
+ (res, localPool) <- takeResource pool
+ r <- unmask (act res) `onException` destroyResource pool localPool (resource
res)
+ putResource localPool (resource res)
+ pure r
+
+-- | 'Data.Pool.takeResource' with introspection capabilities.
+takeResource :: Pool a -> IO (Resource a, LocalPool a)
+takeResource pool = mask_ $ do
+ t1 <- getMonotonicTime
+ lp <- getLocalPool (localPools pool)
+ stripe <- takeMVar (stripeVar lp)
+ if available stripe == 0
+ then do
+ q <- newEmptyMVar
+ putMVar (stripeVar lp) $! stripe { queueR = Queue q (queueR stripe) }
+ waitForResource (stripeVar lp) q >>= \case
+ Just a -> do
+ t2 <- getMonotonicTime
+ let res = Resource
+ { resource = a
+ , stripeNumber = stripeId lp
+ , availableResources = 0
+ , acquisition = Delayed
+ , acquisitionTime = t2 - t1
+ , creationTime = Nothing
+ }
+ pure (res, lp)
+ Nothing -> do
+ t2 <- getMonotonicTime
+ a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
+ t3 <- getMonotonicTime
+ let res = Resource
+ { resource = a
+ , stripeNumber = stripeId lp
+ , availableResources = 0
+ , acquisition = Delayed
+ , acquisitionTime = t2 - t1
+ , creationTime = Just $! t3 - t2
+ }
+ pure (res, lp)
+ else takeAvailableResource pool t1 lp stripe
+
+-- | A variant of 'withResource' that doesn't execute the action and returns
+-- 'Nothing' instead of blocking if the capability-local pool is exhausted.
+tryWithResource :: Pool a -> (Resource a -> IO r) -> IO (Maybe r)
+tryWithResource pool act = mask $ \unmask -> tryTakeResource pool >>= \case
+ Just (res, localPool) -> do
+ r <- unmask (act res) `onException` destroyResource pool localPool
(resource res)
+ putResource localPool (resource res)
+ pure (Just r)
+ Nothing -> pure Nothing
+
+-- | A variant of 'takeResource' that returns 'Nothing' instead of blocking if
+-- the capability-local pool is exhausted.
+tryTakeResource :: Pool a -> IO (Maybe (Resource a, LocalPool a))
+tryTakeResource pool = mask_ $ do
+ t1 <- getMonotonicTime
+ lp <- getLocalPool (localPools pool)
+ stripe <- takeMVar (stripeVar lp)
+ if available stripe == 0
+ then do
+ putMVar (stripeVar lp) stripe
+ pure Nothing
+ else Just <$> takeAvailableResource pool t1 lp stripe
+
+----------------------------------------
+-- Helpers
+
+takeAvailableResource
+ :: Pool a
+ -> Double
+ -> LocalPool a
+ -> Stripe a
+ -> IO (Resource a, LocalPool a)
+takeAvailableResource pool t1 lp stripe = case cache stripe of
+ [] -> do
+ let newAvailable = available stripe - 1
+ putMVar (stripeVar lp) $! stripe { available = newAvailable }
+ t2 <- getMonotonicTime
+ a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
+ t3 <- getMonotonicTime
+ let res = Resource
+ { resource = a
+ , stripeNumber = stripeId lp
+ , availableResources = newAvailable
+ , acquisition = Immediate
+ , acquisitionTime = t2 - t1
+ , creationTime = Just $! t3 - t2
+ }
+ pure (res, lp)
+ Entry a _ : as -> do
+ let newAvailable = available stripe - 1
+ putMVar (stripeVar lp) $! stripe { available = newAvailable, cache = as }
+ t2 <- getMonotonicTime
+ let res = Resource
+ { resource = a
+ , stripeNumber = stripeId lp
+ , availableResources = newAvailable
+ , acquisition = Immediate
+ , acquisitionTime = t2 - t1
+ , creationTime = Nothing
+ }
+ pure (res, lp)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/resource-pool-0.2.3.2/src/Data/Pool.hs
new/resource-pool-0.3.1.0/src/Data/Pool.hs
--- old/resource-pool-0.2.3.2/src/Data/Pool.hs 1970-01-01 01:00:00.000000000
+0100
+++ new/resource-pool-0.3.1.0/src/Data/Pool.hs 2001-09-09 03:46:40.000000000
+0200
@@ -0,0 +1,126 @@
+-- | A high-performance pooling abstraction for managing flexibly-sized
+-- collections of resources such as database connections.
+module Data.Pool
+ ( -- * Pool
+ PoolConfig(..)
+ , Pool
+ , LocalPool
+ , newPool
+
+ -- * Resource management
+ , withResource
+ , takeResource
+ , tryWithResource
+ , tryTakeResource
+ , putResource
+ , destroyResource
+ , destroyAllResources
+
+ -- * Compatibility with 0.2
+ , createPool
+ ) where
+
+import Control.Concurrent
+import Control.Exception
+import Data.Time (NominalDiffTime)
+
+import Data.Pool.Internal
+
+-- | Take a resource from the pool, perform an action with it and return it to
+-- the pool afterwards.
+--
+-- * If the pool has an idle resource available, it is used immediately.
+--
+-- * Otherwise, if the maximum number of resources has not yet been reached, a
+-- new resource is created and used.
+--
+-- * If the maximum number of resources has been reached, this function blocks
+-- until a resource becomes available.
+--
+-- If the action throws an exception of any type, the resource is destroyed and
+-- not returned to the pool.
+--
+-- It probably goes without saying that you should never manually destroy a
+-- pooled resource, as doing so will almost certainly cause a subsequent user
+-- (who expects the resource to be valid) to throw an exception.
+withResource :: Pool a -> (a -> IO r) -> IO r
+withResource pool act = mask $ \unmask -> do
+ (res, localPool) <- takeResource pool
+ r <- unmask (act res) `onException` destroyResource pool
localPool res
+ putResource localPool res
+ pure r
+
+-- | Take a resource from the pool, following the same results as
+-- 'withResource'.
+--
+-- /Note:/ this function returns both a resource and the 'LocalPool' it came
+-- from so that it may either be destroyed (via 'destroyResource') or returned
+-- to the pool (via 'putResource').
+takeResource :: Pool a -> IO (a, LocalPool a)
+takeResource pool = mask_ $ do
+ lp <- getLocalPool (localPools pool)
+ stripe <- takeMVar (stripeVar lp)
+ if available stripe == 0
+ then do
+ q <- newEmptyMVar
+ putMVar (stripeVar lp) $! stripe { queueR = Queue q (queueR stripe) }
+ waitForResource (stripeVar lp) q >>= \case
+ Just a -> pure (a, lp)
+ Nothing -> do
+ a <- createResource (poolConfig pool) `onException` restoreSize
(stripeVar lp)
+ pure (a, lp)
+ else takeAvailableResource pool lp stripe
+
+-- | A variant of 'withResource' that doesn't execute the action and returns
+-- 'Nothing' instead of blocking if the capability-local pool is exhausted.
+tryWithResource :: Pool a -> (a -> IO r) -> IO (Maybe r)
+tryWithResource pool act = mask $ \unmask -> tryTakeResource pool >>= \case
+ Just (res, localPool) -> do
+ r <- unmask (act res) `onException` destroyResource pool localPool res
+ putResource localPool res
+ pure (Just r)
+ Nothing -> pure Nothing
+
+-- | A variant of 'takeResource' that returns 'Nothing' instead of blocking if
+-- the capability-local pool is exhausted.
+tryTakeResource :: Pool a -> IO (Maybe (a, LocalPool a))
+tryTakeResource pool = mask_ $ do
+ lp <- getLocalPool (localPools pool)
+ stripe <- takeMVar (stripeVar lp)
+ if available stripe == 0
+ then do
+ putMVar (stripeVar lp) stripe
+ pure Nothing
+ else Just <$> takeAvailableResource pool lp stripe
+
+{-# DEPRECATED createPool "Use newPool instead" #-}
+-- | Provided for compatibility with @resource-pool < 0.3@.
+--
+-- Use 'newPool' instead.
+createPool :: IO a -> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO
(Pool a)
+createPool create free numStripes idleTime maxResources = newPool PoolConfig
+ { createResource = create
+ , freeResource = free
+ , poolCacheTTL = realToFrac idleTime
+ , poolMaxResources = numStripes * maxResources
+ }
+
+----------------------------------------
+-- Helpers
+
+takeAvailableResource
+ :: Pool a
+ -> LocalPool a
+ -> Stripe a
+ -> IO (a, LocalPool a)
+takeAvailableResource pool lp stripe = case cache stripe of
+ [] -> do
+ putMVar (stripeVar lp) $! stripe { available = available stripe - 1 }
+ a <- createResource (poolConfig pool) `onException` restoreSize (stripeVar
lp)
+ pure (a, lp)
+ Entry a _ : as -> do
+ putMVar (stripeVar lp) $! stripe
+ { available = available stripe - 1
+ , cache = as
+ }
+ pure (a, lp)
