From 2537809bebdd12bc250fb897a2b41b4b0c2921b4 Mon Sep 17 00:00:00 2001 From: Andrzej Rybczak Date: Wed, 8 Jul 2026 17:21:49 +0200 Subject: [PATCH] Add a test suite Cover the public API of Data.Pool and Data.Pool.Introspection with a tasty based test suite: * Config validation: newPool rejects invalid TTL, maximum number of resources and stripe counts. * Basic operation: reuse of idle resources, tryTakeResource and tryWithResource on an exhausted pool, destruction of the resource when the action throws, destroyResource, destroyAllResources, distribution of resources across stripes and collection of idle resources after the TTL. * Concurrency: the number of created resources never exceeds the maximum, a blocked thread is woken up by putResource, and a regression test for the fix in 0.5.0.1 where a thread waiting for a resource has to be woken up when resource creation fails in another thread. * Introspection: resource metadata (label, stripe number, creation time) and Immediate/Delayed acquisition. * Stress: concurrent clients with periodic failures on 1 and 4 stripe pools, checking via Data.Pool.Internal that all permits are available, all live resources sit in stripe caches and no thread is queued once the pool is idle again. Synchronization-sensitive tests poll the stripe state through Data.Pool.Internal instead of relying on fixed delays. --- .github/workflows/haskell-ci.yml | 3 + CHANGELOG.md | 1 + resource-pool.cabal | 30 +++ test/Main.hs | 320 +++++++++++++++++++++++++++++++ 4 files changed, 354 insertions(+) create mode 100644 test/Main.hs diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 7db7a8c..61c32ff 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -230,6 +230,9 @@ jobs: - name: build run: | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: tests + run: | + $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct - name: cabal check run: | cd ${PKGDIR_resource_pool} || false diff --git a/CHANGELOG.md b/CHANGELOG.md index e98c470..34b7cab 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,7 @@ of a thread id is negative. * Fix a bug where some of the stripes would never be used if the number of stripes was larger than the number of capabilities. +* Add a test suite. # resource-pool-0.5.0.0 (2025-06-13) * Drop support for GHC < 8.10. diff --git a/resource-pool.cabal b/resource-pool.cabal index 3fbfd59..2036ad3 100644 --- a/resource-pool.cabal +++ b/resource-pool.cabal @@ -53,3 +53,33 @@ library , RankNTypes , ScopedTypeVariables , TypeApplications + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + + main-is: Main.hs + + build-depends: base + , async + , resource-pool + , stm + , tasty + , tasty-hunit + , text + + ghc-options: -Wall + -Wcompat + -Wmissing-deriving-strategies + -Werror=prepositive-qualified-module + -threaded + -rtsopts + "-with-rtsopts=-N4" + + default-language: Haskell2010 + + default-extensions: DerivingStrategies + , ImportQualifiedPost + , LambdaCase + , ScopedTypeVariables + , TypeApplications diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..94ce73e --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,320 @@ +module Main (main) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Data.Foldable qualified as F +import Data.IORef +import Data.List qualified as L +import Data.Maybe +import Data.Text qualified as T +import System.Timeout (timeout) +import Test.Tasty hiding (withResource) +import Test.Tasty.HUnit + +import Data.Pool +import Data.Pool.Internal (LocalPool (..), Pool (..), Queue (..), Stripe (..)) +import Data.Pool.Introspection qualified as I + +main :: IO () +main = + defaultMain . localOption (mkTimeout 60000000) + $ testGroup + "resource-pool" + [ configValidationTests + , basicTests + , concurrencyTests + , introspectionTests + , stressTests + ] + +---------------------------------------- +-- Configuration validation + +configValidationTests :: TestTree +configValidationTests = + testGroup + "config validation" + [ testCase "rejects too small poolCacheTTL" $ do + expectError . newPool $ poolConfig_ 0.4 1 + , testCase "rejects non-positive poolMaxResources" $ do + expectError . newPool $ poolConfig_ 100 0 + , testCase "rejects non-positive number of stripes" $ do + expectError . newPool . setNumStripes (Just 0) $ poolConfig_ 100 1 + , testCase "rejects poolMaxResources smaller than the number of stripes" $ do + expectError . newPool . setNumStripes (Just 4) $ poolConfig_ 100 2 + ] + where + poolConfig_ = defaultPoolConfig (pure ()) (\_ -> pure ()) + + expectError :: IO a -> Assertion + expectError io = + try @ErrorCall (void io) >>= \case + Left _ -> pure () + Right _ -> assertFailure "expected newPool to error out" + +---------------------------------------- +-- Basic tests + +basicTests :: TestTree +basicTests = + testGroup + "basic" + [ testCase "an idle resource is reused" $ do + tp <- mkPool 5 + r1 <- withResource (testPool tp) pure + r2 <- withResource (testPool tp) pure + assertEqual "the same resource is taken" r1 r2 + readIORef (createdCount tp) >>= assertEqual "created resources" 1 + , testCase "concurrently taken resources are distinct" $ do + tp <- mkPool 5 + (r1, lp1) <- takeResource (testPool tp) + (r2, lp2) <- takeResource (testPool tp) + assertBool "resources are distinct" $ r1 /= r2 + putResource lp1 r1 + putResource lp2 r2 + , testCase "tryTakeResource returns Nothing iff the pool is exhausted" $ do + tp <- mkPool 1 + Just (r, lp) <- tryTakeResource (testPool tp) + mr <- tryTakeResource (testPool tp) + assertBool "Nothing when exhausted" $ isNothing mr + putResource lp r + mr2 <- tryTakeResource (testPool tp) + assertBool "Just when a resource is available" $ isJust mr2 + , testCase "tryWithResource returns Nothing iff the pool is exhausted" $ do + tp <- mkPool 1 + (r, lp) <- takeResource (testPool tp) + mr <- tryWithResource (testPool tp) pure + assertEqual "Nothing when exhausted" Nothing mr + putResource lp r + mr2 <- tryWithResource (testPool tp) pure + assertEqual "Just when a resource is available" (Just r) mr2 + , testCase "withResource destroys the resource on exception" $ do + tp <- mkPool 5 + r <- try @Boom $ withResource (testPool tp) $ \_ -> throwIO Boom :: IO () + assertEqual "the exception is propagated" (Left Boom) r + readIORef (freedCount tp) >>= assertEqual "freed resources" 1 + -- The pool is still usable and creates a fresh resource. + _ <- withResource (testPool tp) pure + readIORef (createdCount tp) >>= assertEqual "created resources" 2 + , testCase "destroyResource frees the resource and its slot" $ do + tp <- mkPool 1 + (r1, lp) <- takeResource (testPool tp) + destroyResource (testPool tp) lp r1 + readIORef (freedCount tp) >>= assertEqual "freed resources" 1 + r2 <- withResource (testPool tp) pure + assertBool "resource is fresh" $ r2 /= r1 + , testCase "destroyAllResources frees all idle resources" $ do + tp <- mkPool 5 + rs <- replicateM 3 $ takeResource (testPool tp) + forM_ rs $ \(r, lp) -> putResource lp r + destroyAllResources (testPool tp) + readIORef (freedCount tp) >>= assertEqual "freed resources" 3 + -- The pool is still usable and creates a fresh resource. + _ <- withResource (testPool tp) pure + readIORef (createdCount tp) >>= assertEqual "created resources" 4 + , testCase "resources are distributed evenly across stripes" $ do + tp <- mkPoolWith (setNumStripes $ Just 2) 5 + ss <- stripeStates (testPool tp) + assertEqual "available resources per stripe" [2, 3] + $ L.sort (map available ss) + , testCase "idle resources exceeding the TTL are collected" $ do + createdC <- newIORef (0 :: Int) + freedC <- newIORef (0 :: Int) + pool <- + newPool + $ defaultPoolConfig + (atomicModifyIORef' createdC $ \n -> (n + 1, n + 1)) + (\_ -> atomicModifyIORef' freedC $ \n -> (n + 1, ())) + 0.5 + 5 + _ <- withResource pool pure + -- The collector thread wakes up every second. + waitUntil "the resource is collected" $ (== 1) <$> readIORef freedC + readIORef createdC >>= assertEqual "created resources" 1 + ] + +---------------------------------------- +-- Concurrency tests + +concurrencyTests :: TestTree +concurrencyTests = + testGroup + "concurrency" + [ testCase "the number of created resources never exceeds the maximum" $ do + tp <- mkPool 3 + mapConcurrently_ + (\_ -> replicateM_ 10 . withResource (testPool tp) $ \_ -> threadDelay 1000) + [1 .. 20 :: Int] + created <- readIORef (createdCount tp) + assertBool ("created " ++ show created ++ " resources") $ created <= 3 + ss <- stripeStates (testPool tp) + assertEqual "all permits are available" 3 $ sum (map available ss) + , testCase "a blocked thread is woken up by putResource" $ do + tp <- mkPool 1 + (r, lp) <- takeResource (testPool tp) + done <- newEmptyMVar + _ <- forkIO $ withResource (testPool tp) pure >>= putMVar done + waitUntil "the thread is queued" + $ any ((> 0) . queueLength) <$> stripeStates (testPool tp) + putResource lp r + mr <- timeout 5000000 $ takeMVar done + assertEqual "the returned resource is received" (Just r) mr + , testCase "a blocked thread is woken up when resource creation fails" $ do + entered <- newEmptyMVar + gate <- newEmptyMVar + let create = do + putMVar entered () + takeMVar gate + throwIO Boom :: IO Int + pool <- newPool $ defaultPoolConfig create (\_ -> pure ()) 100 1 + t1 <- newEmptyMVar + _ <- forkIO $ try @Boom (withResource pool $ \_ -> pure ()) >>= putMVar t1 + takeMVar entered + t2 <- newEmptyMVar + _ <- forkIO $ try @Boom (withResource pool $ \_ -> pure ()) >>= putMVar t2 + waitUntil "the second thread is queued" + $ any ((> 0) . queueLength) <$> stripeStates pool + -- Fail creation in the first thread. The second one needs to be woken + -- up and attempt creation itself. + putMVar gate () + takeMVar t1 >>= assertEqual "the first thread failed" (Left Boom) + mr <- timeout 5000000 $ do + takeMVar entered + putMVar gate () + takeMVar t2 + assertEqual "the second thread attempted creation" (Just (Left Boom)) mr + ] + +---------------------------------------- +-- Introspection tests + +introspectionTests :: TestTree +introspectionTests = + testGroup + "introspection" + [ testCase "resource metadata is filled in correctly" $ do + pool <- + newPool . setPoolLabel (T.pack "label") + $ defaultPoolConfig (pure (0 :: Int)) (\_ -> pure ()) 100 1 + (res, lp) <- I.takeResource pool + assertEqual "poolLabel" (T.pack "label") (I.poolLabel res) + assertEqual "stripeNumber" 1 (I.stripeNumber res) + assertEqual "acquisition" I.Immediate (I.acquisition res) + assertBool "creationTime is set for a fresh resource" + $ isJust (I.creationTime res) + putResource lp $ I.resource res + (res2, lp2) <- I.takeResource pool + assertEqual "acquisition" I.Immediate (I.acquisition res2) + assertEqual "creationTime is not set for a cached resource" Nothing + $ I.creationTime res2 + putResource lp2 $ I.resource res2 + , testCase "acquisition of a blocked thread is Delayed" $ do + tp <- mkPool 1 + (res, lp) <- I.takeResource (testPool tp) + done <- newEmptyMVar + _ <- forkIO $ I.takeResource (testPool tp) >>= putMVar done + waitUntil "the thread is queued" + $ any ((> 0) . queueLength) <$> stripeStates (testPool tp) + putResource lp $ I.resource res + mr <- timeout 5000000 $ takeMVar done + case mr of + Nothing -> assertFailure "the blocked thread wasn't woken up" + Just (res2, lp2) -> do + assertEqual "acquisition" I.Delayed (I.acquisition res2) + putResource lp2 $ I.resource res2 + ] + +---------------------------------------- +-- Stress tests + +stressTests :: TestTree +stressTests = + testGroup + "stress" + [ testCase "pool invariants hold under load (1 stripe)" $ stressTest 1 + , testCase "pool invariants hold under load (4 stripes)" $ stressTest 4 + ] + where + stressTest numStripes = do + let maxResources = 8 + tp <- mkPoolWith (setNumStripes $ Just numStripes) maxResources + mapConcurrently_ + ( \i -> replicateM_ 50 $ do + r <- try @Boom . withResource (testPool tp) $ \_ -> do + threadDelay 100 + -- Some of the threads always fail, destroying the resource. + when (i `rem` 5 == 0) $ throwIO Boom + case r of + Left Boom -> when (i `rem` 5 /= 0) $ throwIO Boom + Right () -> pure () + ) + [1 .. 30 :: Int] + -- Once the pool is idle again, all permits are available, all live + -- resources sit in stripe caches and no thread is queued. + ss <- stripeStates (testPool tp) + assertEqual "all permits are available" maxResources + $ sum (map available ss) + created <- readIORef (createdCount tp) + freed <- readIORef (freedCount tp) + assertEqual "all live resources are cached" (created - freed) + $ sum (map (length . cache) ss) + assertEqual "no thread is queued" 0 $ sum (map queueLength ss) + +---------------------------------------- +-- Helpers + +data Boom = Boom + deriving stock (Eq, Show) + +instance Exception Boom + +data TestPool = TestPool + { testPool :: Pool Int + , createdCount :: IORef Int + , freedCount :: IORef Int + } + +mkPool :: Int -> IO TestPool +mkPool = mkPoolWith id + +mkPoolWith :: (PoolConfig Int -> PoolConfig Int) -> Int -> IO TestPool +mkPoolWith adjust maxResources = do + createdC <- newIORef 0 + freedC <- newIORef 0 + pool <- + newPool . adjust + $ defaultPoolConfig + (atomicModifyIORef' createdC $ \n -> (n + 1, n + 1)) + (\_ -> atomicModifyIORef' freedC $ \n -> (n + 1, ())) + 100 + maxResources + pure + TestPool + { testPool = pool + , createdCount = createdC + , freedCount = freedC + } + +stripeStates :: Pool a -> IO [Stripe a] +stripeStates pool = mapM (readTVarIO . stripeVar) . F.toList $ localPools pool + +queueLength :: Stripe a -> Int +queueLength stripe = go (queue stripe) + go (queueR stripe) + where + go = \case + Empty -> 0 + Queue _ q -> 1 + go q + +-- | Wait (up to 10 seconds) until a condition is met. +waitUntil :: String -> IO Bool -> Assertion +waitUntil label cond = go (100 :: Int) + where + go n = do + ok <- cond + unless ok + $ if n == 0 + then assertFailure $ "timed out waiting until " ++ label + else threadDelay 100000 >> go (n - 1)