resource-pool 0.3.0.0 → 0.3.1.0
raw patch · 4 files changed
+114/−41 lines, 4 files
Files
- CHANGELOG.md +3/−0
- resource-pool.cabal +1/−1
- src/Data/Pool.hs +45/−11
- src/Data/Pool/Introspection.hs +65/−29
CHANGELOG.md view
@@ -1,3 +1,6 @@+# 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.
resource-pool.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.4 build-type: Simple name: resource-pool-version: 0.3.0.0+version: 0.3.1.0 license: BSD-3-Clause license-file: LICENSE category: Data, Database, Network
src/Data/Pool.hs view
@@ -10,6 +10,8 @@ -- * Resource management , withResource , takeResource+ , tryWithResource+ , tryTakeResource , putResource , destroyResource , destroyAllResources@@ -67,18 +69,30 @@ Nothing -> do a <- createResource (poolConfig pool) `onException` restoreSize (stripeVar lp) pure (a, lp)- else 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)+ 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@. --@@ -90,3 +104,23 @@ , 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)
src/Data/Pool/Introspection.hs view
@@ -11,6 +11,8 @@ , Acquisition(..) , withResource , takeResource+ , tryWithResource+ , tryTakeResource , putResource , destroyResource , destroyAllResources@@ -84,32 +86,66 @@ , creationTime = Just $! t3 - t2 } pure (res, lp)- else 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)+ 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)