simpoole 0.0.0 → 0.0.1
raw patch · 5 files changed
+153/−12 lines, 5 filesdep ~concurrencydep ~containers
Dependency ranges changed: concurrency, containers
Files
- ChangeLog.md +5/−1
- lib/Simpoole.hs +30/−6
- simpoole.cabal +11/−3
- test/Main.hs +4/−2
- test/SimpooleSpec.hs +103/−0
ChangeLog.md view
@@ -1,5 +1,9 @@ # simpoole -### 0.0.0+## 0.0.1++* Fix max live metric++## 0.0.0 This is the root version.
lib/Simpoole.hs view
@@ -29,6 +29,8 @@ import Numeric.Natural (Natural) -- | Pool of resources+--+-- @since 0.0.0 data Pool m a = Pool { pool_acquire :: m a , pool_return :: a -> m ()@@ -37,6 +39,8 @@ } -- | Lift a natural transformation @m ~> n@ to @Pool m ~> Pool n@.+--+-- @since 0.0.0 mapPool :: (forall x. m x -> n x) -> Pool m a@@ -59,6 +63,8 @@ -- ^ The resource itesemf -- | Create a new pool that has no limit on how many resources it may create and hold.+--+-- @since 0.0.0 newUnlimitedPool :: (Concurrent.MonadConc m, MonadIO m) => m a@@ -83,12 +89,16 @@ destroy resource `Catch.finally` succIORef (metrics_destroyedResources metricRefs) acquireResource = do- (mbResource, tailSize) <- Concurrent.atomicModifyIORef' leftOversRef $ \leftOvers ->+ mbResource <- Concurrent.atomicModifyIORef' leftOversRef $ \leftOvers -> case leftOvers of- Resource _ head Seq.:<| tail -> (tail, (Just head, Seq.length tail))- _empty -> (leftOvers, (Nothing, 0))+ Resource _ head Seq.:<| tail -> (tail, Just head)+ _empty -> (leftOvers, Nothing) resource <- maybe wrappedCreate pure mbResource- maxIORef (metrics_maxLiveResources metricRefs) (fromIntegral tailSize + 1)++ numDestroyed <- Concurrent.readIORef (metrics_destroyedResources metricRefs)+ numCreated <- Concurrent.readIORef (metrics_createdResources metricRefs)+ maxIORef (metrics_maxLiveResources metricRefs) (numCreated - numDestroyed)+ pure resource returnResource value = do@@ -119,6 +129,8 @@ -- | Similar to 'newUnlimitedPool' but allows you to limit the number of resources that will exist -- at the same time. When all resources are currently in use, further resource acquisition will -- block until one is no longer in use.+--+-- @since 0.0.0 newPool :: (Concurrent.MonadConc m, MonadIO m, MonadFail m) => m a@@ -128,7 +140,7 @@ -> Int -- ^ Maximum number of resources to exist at the same time -> Time.NominalDiffTime- -- ^ Maximum idle time (+-1s) after which a resource is destroyed+ -- ^ Maximum idle time after which a resource is destroyed -> m (Pool m a) newPool create destroy maxElems maxIdleTime = do basePool <- newUnlimitedPool create destroy maxIdleTime@@ -152,6 +164,8 @@ } -- | Use a resource from the pool.+--+-- @since 0.0.0 withResource :: Catch.MonadMask m => Pool m a -> (a -> m r) -> m r withResource pool f = Catch.mask $ \restore -> do@@ -163,6 +177,8 @@ {-# INLINE withResource #-} -- | Fetch pool metrics.+--+-- @since 0.0.0 poolMetrics :: Pool m a -> m (Metrics Natural) poolMetrics = pool_metrics @@ -171,15 +187,23 @@ --- -- | Pool metrics+--+-- @since 0.0.0 data Metrics a = Metrics { metrics_createdResources :: a -- ^ Total number of resources created+ --+ -- @since 0.0.0 , metrics_destroyedResources :: a -- ^ Total number of resources destroyed+ --+ -- @since 0.0.0 , metrics_maxLiveResources :: a -- ^ Maximum number of resources that were alive simultaneously+ --+ -- @since 0.0.0 }- deriving stock (Show, Functor, Foldable, Traversable)+ deriving stock (Show, Read, Eq, Ord, Functor, Foldable, Traversable) -- | Create the IORefs which capture the metric values. mkMetricRefs :: Concurrent.MonadConc m => m (Metrics (Concurrent.IORef m Natural))
simpoole.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.2 name: simpoole-version: 0.0.0+version: 0.0.1 category: Data, Resources synopsis: Simple pool description: Provides a simple pool implementation.@@ -23,7 +23,11 @@ import: warnings default-language: Haskell2010 ghc-options: -Wall -Wextra -Wno-name-shadowing -Wredundant-constraints- build-depends: base >= 4.13 && < 5, time, exceptions, concurrency, containers+ build-depends: base >= 4.13 && < 5,+ concurrency >= 1.6.0.0,+ containers >= 0.5.8,+ exceptions,+ time hs-source-dirs: lib exposed-modules: Simpoole @@ -32,6 +36,10 @@ type: exitcode-stdio-1.0 default-language: Haskell2010 ghc-options: -Wall -Wextra -Wno-name-shadowing -threaded -with-rtsopts=-N- build-depends: base, simpoole, hspec >= 2.7.1+ build-depends: base,+ simpoole,+ concurrency,+ hspec >= 2.7.1 hs-source-dirs: test main-is: Main.hs+ other-modules: SimpooleSpec
test/Main.hs view
@@ -1,6 +1,8 @@ module Main (main) where -import Test.Hspec+import qualified SimpooleSpec+import Test.Hspec (describe, hspec) main :: IO ()-main = hspec $ pure ()+main = hspec $+ describe "Simpoole" SimpooleSpec.spec
+ test/SimpooleSpec.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE NumericUnderscores #-}++module SimpooleSpec (spec) where++import qualified Control.Concurrent.Classy as Concurrent+import qualified Control.Concurrent.Classy.Async as Async+import Control.Monad (join)+import Control.Monad.IO.Class (liftIO)+import Numeric.Natural (Natural)+import qualified Simpoole as Pool+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)++spec :: Spec+spec = do+ describe "newUnlimitedPool" $ do+ it "eventually frees all resources" $ do+ counterRef <- Concurrent.newIORefN "counterRef" (0 :: Integer)++ let+ create =+ Concurrent.atomicModifyIORef' counterRef $ \count -> (succ count, ())++ destroy _ =+ Concurrent.atomicModifyIORef' counterRef $ \count -> (pred count, ())++ pool <- Pool.newUnlimitedPool create destroy 1++ Async.replicateConcurrently_ 200 $+ Pool.withResource pool $ const $ Concurrent.threadDelay 1_000++ currentCount <- Concurrent.readIORef counterRef+ currentCount `shouldSatisfy` (> 0)++ let+ wait = do+ currentCount <- Concurrent.readIORef counterRef+ if currentCount > 0 then do+ Concurrent.threadDelay 100_000+ wait+ else+ pure ()++ wait++ currentCount <- Concurrent.readIORef counterRef+ currentCount `shouldBe` 0++ it "tracks metrics accurately" $ do+ counterRef <- Concurrent.newIORefN "counterRef" (0 :: Integer)+ createdRef <- Concurrent.newIORefN "createdRef" (0 :: Natural)+ destroyedRef <- Concurrent.newIORefN "destroyedRef" (0 :: Natural)+ maxRef <- Concurrent.newIORefN "maxRef" 0++ let+ create = do+ Concurrent.atomicModifyIORef' createdRef $ \count -> (count + 1, ())+ counter <- Concurrent.atomicModifyIORef' counterRef $ join (,) . succ+ Concurrent.atomicModifyIORef' maxRef $ join (,) . max counter++ destroy _ = do+ Concurrent.atomicModifyIORef' destroyedRef $ \count -> (count + 1, ())+ Concurrent.atomicModifyIORef' counterRef $ \count -> (count - 1, ())++ pool <- Pool.newUnlimitedPool create destroy 60++ Async.replicateConcurrently_ 200 $ do+ Pool.withResource pool $ const $ Concurrent.threadDelay 1_000++ metrics <- Pool.poolMetrics pool+ liftIO $ print metrics++ created <- Concurrent.readIORef createdRef+ Pool.metrics_createdResources metrics `shouldBe` created++ destroyed <- Concurrent.readIORef destroyedRef+ Pool.metrics_destroyedResources metrics `shouldBe` destroyed++ maxLive <- Concurrent.readIORef maxRef+ fromIntegral (Pool.metrics_maxLiveResources metrics) `shouldBe` maxLive++ describe "newPool" $ do+ it "never allocates more than allowed" $ do+ counterRef <- Concurrent.newIORefN "counterRef" (0 :: Integer)+ maxRef <- Concurrent.newIORefN "maxRef" 0++ let+ create = do+ counter <- Concurrent.atomicModifyIORef' counterRef $ join (,) . succ+ Concurrent.atomicModifyIORef' maxRef $ join (,) . max counter++ destroy _ =+ Concurrent.atomicModifyIORef' counterRef $ \count -> (pred count, ())++ pool <- Pool.newPool create destroy 10 60++ Async.replicateConcurrently_ 200 $ do+ Pool.withResource pool $ const $ Concurrent.threadDelay 1_000++ max <- Concurrent.readIORef maxRef+ max `shouldSatisfy` (<= 10)+++ pure ()