simpoole 0.1.0 → 0.2.0

raw patch · 5 files changed

+106/−36 lines, 5 files

Files

• ChangeLog.md +6/−1
• lib/Simpoole.hs +61/−28
• lib/Simpoole/Internal.hs +31/−0
• simpoole.cabal +2/−1
• test/SimpooleSpec.hs +6/−6

@@ -1,6 +1,11 @@ # simpoole -## 0.1.0 (Unreleased)+## 0.2.0++* Make idle timeout optional+* Overhaul newPool function to be able to produce limited and unlimited pools alike++## 0.1.0  * Expose helper functions: acquireResource, returnResource, destroyResource * Track number of idle resources as part of metrics

@@ -9,7 +9,6 @@ module Simpoole   ( Pool   , mapPool-  , newUnlimitedPool   , newPool   , withResource   , acquireResource@@ -30,10 +29,12 @@ import           Control.Monad (forever, unless, void) import qualified Control.Monad.Catch as Catch import           Control.Monad.IO.Class (MonadIO (liftIO))+import           Data.Coerce (coerce) import           Data.Foldable (for_) import qualified Data.Sequence as Seq import qualified Data.Time as Time import           Numeric.Natural (Natural)+import           Simpoole.Internal (FailToIO (..), failToIO)  -- | Strategy to use when returning resources to the pool --@@ -41,17 +42,22 @@ data ReturnPolicy   = ReturnToFront   -- ^ Return resources to the front. Resources that have been used recently are more likely to be-  -- reused again quicker. This strategy is good if you want to scale down the pool more quickly in-  -- case resources are not needed.+  -- reused again quicker.   --+  -- This strategy is good if you want to scale down the pool more quickly in case resources are not+  -- needed.+  --   -- @since 0.1.0   | ReturnToBack   -- ^ Return resources to the back. Resources that have been used recently are less likely to be-  -- used again quicker. Use this strategy if you want to keep more resources in the pool fresh, or-  -- when maintaining the pool in order to be ready for burst workloads.-  -- This strategy can lead to no resources ever been freed when all resources are used within the-  -- idle timeout.+  -- used again quicker.   --+  -- Use this strategy if you want to keep more resources in the pool fresh, or when maintaining the+  -- pool in order to be ready for burst workloads.+  --+  -- Note: This strategy can lead to no resources ever being destroyed when all resources are+  -- continuously used within the idle timeout.+  --   -- @since 0.1.0   | ReturnToMiddle   -- ^ Return resources to the middle. This offers a middleground between 'ReturnToFront' and@@ -76,21 +82,33 @@ -- | Lets you configure certain behaviours of the pool -- -- @since 0.1.0-data Settings = PoolSettings-  { settings_idleTimeout :: Time.NominalDiffTime+data Settings = Settings -- ^ @since 0.2.0+  { settings_idleTimeout :: Maybe Time.NominalDiffTime   -- ^ Maximum idle time after which a resource is destroyed   --+  -- Setting it to @Nothing@ means that nothing will ever be destroyed based on idle time.+  --   -- @since 0.1.0   , settings_returnPolicy :: ReturnPolicy+  -- ^ Read documentation on 'ReturnPolicy' for details.+  --+  -- @since 0.1.0+  , settings_maxLiveLimit :: Maybe Int+  -- ^ Maximum number of resources that may live at the same time.+  --+  -- @Nothing@ means unlimited.+  --+  -- @since 0.2.0   }  -- | Default pool settings -- -- @since 0.1.0 defaultSettings :: Settings-defaultSettings = PoolSettings-  { settings_idleTimeout = 60 -- 60 seconds+defaultSettings = Settings+  { settings_idleTimeout = Just 60 -- 60 seconds   , settings_returnPolicy = ReturnToMiddle+  , settings_maxLiveLimit = Nothing   }  -- | Pool of resources@@ -128,8 +146,6 @@     -- ^ The resource item  -- | Create a new pool that has no limit on how many resources it may create and hold.------ @since 0.1.0 newUnlimitedPool   :: (Concurrent.MonadConc m, MonadIO m)   => m a@@ -189,21 +205,20 @@         , ()         ) -  _reaperThread <- Async.asyncWithUnmaskN "reaperThread" $ \unmask -> unmask $ forever $ do-    now <- liftIO Time.getCurrentTime+  for_ (settings_idleTimeout settings) $ \idleTimeout -> void $+    Async.asyncWithUnmaskN "reaperThread" $ \unmask -> unmask $ forever $ do+      now <- liftIO Time.getCurrentTime -    let-      isStillGood (Resource lastUse _) =-        Time.diffUTCTime now lastUse <= settings_idleTimeout settings+      let isStillGood (Resource lastUse _) = Time.diffUTCTime now lastUse <= idleTimeout -    oldResource <- Concurrent.atomicModifyIORef' leftOversRef (Seq.partition isStillGood)+      oldResource <- Concurrent.atomicModifyIORef' leftOversRef (Seq.partition isStillGood) -    unless (null oldResource) $ void $-      Async.asyncN "destructionThread" $-        for_ oldResource $ \(Resource _ value) ->-          Catch.try @_ @Catch.SomeException $ wrappedDestroy value+      unless (null oldResource) $ void $+        Async.asyncN "destructionThread" $+          for_ oldResource $ \(Resource _ value) ->+            Catch.try @_ @Catch.SomeException $ wrappedDestroy value -    Concurrent.threadDelay 1_000_000+      Concurrent.threadDelay 1_000_000    pure Pool     { pool_acquire = acquireResource@@ -215,9 +230,7 @@ -- | 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.1.0-newPool+newLimitedPool   :: (Concurrent.MonadConc m, MonadIO m, MonadFail m)   => m a   -- ^ Resource creation@@ -228,7 +241,7 @@   -> Settings   -- ^ Pool settings   -> m (Pool m a)-newPool create destroy maxElems settings = do+newLimitedPool create destroy maxElems settings = do   basePool <- newUnlimitedPool create destroy settings   maxElemBarrier <- Concurrent.newQSem maxElems @@ -248,6 +261,26 @@     , pool_destroy = giveBackResource pool_destroy     , pool_metrics = pool_metrics basePool     }++-- | Create a new pool.+--+-- @since 0.2.0+newPool+  :: (Concurrent.MonadConc m, MonadIO m)+  => m a+  -- ^ Resource creation+  -> (a -> m ())+  -- ^ Resource destruction+  -> Settings+  -- ^ Pool settings+  -> m (Pool m a)+newPool create destroy settings =+  case settings_maxLiveLimit settings of+    Just maxLive -> failToIO $ do -- Translate the MonadFail constraint to MonadIO.+      pool <- newLimitedPool (coerce create) (coerce destroy) maxLive settings+      pure (mapPool coerce pool)++    Nothing -> newUnlimitedPool create destroy settings  -- | Use a resource from the pool. Once the continuation returns, the resource will be returned to -- the pool. If the given continuation throws an error then the acquired resource will be destroyed

@@ -0,0 +1,31 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Simpoole.Internal (FailToIO (..), failToIO) where++import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)+import Control.Monad.Conc.Class (MonadConc)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Coerce (coerce)++newtype FailToIO m a = FailToIO (m a)+  deriving newtype+    ( Functor+    , Applicative+    , Monad+    , MonadIO+    , MonadThrow+    , MonadCatch+    , MonadMask+    , MonadConc+    )++instance MonadIO m => MonadFail (FailToIO m) where+  fail = liftIO . fail++  {-# INLINE fail #-}++failToIO :: FailToIO m a -> m a+failToIO = coerce++{-# INLINE failToIO #-}

@@ -1,6 +1,6 @@ cabal-version:      2.2 name:               simpoole-version:            0.1.0+version:            0.2.0 category:           Data, Resources synopsis:           Simple pool description:        Provides a simple pool implementation.@@ -30,6 +30,7 @@                     time   hs-source-dirs:   lib   exposed-modules:  Simpoole+  other-modules:    Simpoole.Internal  test-suite simpoole-tests   import:           warnings

@@ -11,7 +11,7 @@  spec :: Spec spec = do-  describe "newUnlimitedPool" $ do+  describe "newPool" $ do     it "eventually frees all resources" $ do       counterRef <- Concurrent.newIORefN "counterRef" (0 :: Integer) @@ -22,8 +22,8 @@         destroy _ =           Concurrent.atomicModifyIORef' counterRef $ \count -> (pred count, ()) -      pool <- Pool.newUnlimitedPool create destroy-        Pool.defaultSettings { Pool.settings_idleTimeout = 1 }+      pool <- Pool.newPool create destroy+        Pool.defaultSettings { Pool.settings_idleTimeout = Just 1 }        Async.replicateConcurrently_ 200 $         Pool.withResource pool $ const $ Concurrent.threadDelay 1_000@@ -61,7 +61,7 @@           Concurrent.atomicModifyIORef' destroyedRef $ \count -> (count + 1, ())           Concurrent.atomicModifyIORef' counterRef $ \count -> (count - 1, ()) -      pool <- Pool.newUnlimitedPool create destroy Pool.defaultSettings+      pool <- Pool.newPool create destroy Pool.defaultSettings        Async.replicateConcurrently_ 200 $ do         Pool.withResource pool $ const $ Concurrent.threadDelay 1_000@@ -81,7 +81,6 @@       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@@ -94,7 +93,8 @@         destroy _ =           Concurrent.atomicModifyIORef' counterRef $ \count -> (pred count, ()) -      pool <- Pool.newPool create destroy 10 Pool.defaultSettings+      pool <- Pool.newPool create destroy Pool.defaultSettings+        { Pool.settings_maxLiveLimit = Just 10 }        Async.replicateConcurrently_ 200 $ do         Pool.withResource pool $ const $ Concurrent.threadDelay 1_000