diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,10 +1,17 @@ -# 1.4.2.1 +# v1.4.2.2 ## Fixes +- Fix pool capacity leak when `initSession` fails (#56) +- Fix background reaper never passively evicting idle connections: it used the connection-lifetime timeout instead of the idleness timeout when checking for idle connections + +# v1.4.2.1 + +## Fixes + - Discard pooled connections after driver errors (#55) -# 1.4 +# v1.4 - Migrated to `hasql-1.10` - Updated connection settings API to use monoid-based `Settings` instead of list-based `[Setting]` @@ -14,30 +21,30 @@ - Updated statement construction to use `Statement.preparable` and `Statement.unpreparable` instead of direct constructor - Hid the `Defaults` module from the public API -# 1.3 +# v1.3 - Adapt to the new settings model of `hasql-1.9` -# 1.2 +# v1.2 - Migrated to `hasql-1.7` - Changed references to `QueryError` in observations to `SessionError` -# 1.1 +# v1.1 - `ReadyForUseConnectionStatus` got extended with the `ConnectionReadyForUseReason` details. - `initSession` setting added. -# 1 +# v1 - Optional observability event stream added. Provides a flexible mechanism for monitoring the healthiness of the pool via logs and metrics. - Configuration got isolated into a DSL, which will allow to provide new configurations without breaking backward compatibility. -# 0.10.1 +# v0.10.1 - Avoid releasing connections on exceptions thrown in session -# 0.9 +# v0.9 - Maximal lifetime added for connections. Allows to refresh the connections in time cleaning up the resources. @@ -46,19 +53,19 @@ - The acquisition timeout is now non-optional. - Moved to `DiffTime` for timeouts. -# 0.8.0.7 +# v0.8.0.7 Fix excessive connections during releases due to race conditions. -# 0.8.0.5 +# v0.8.0.5 Fix connections not returning to the pool on exceptions. -# 0.8.0.2 +# v0.8.0.2 Fixed Windows build. -# 0.8 +# v0.8 `release` became reusable. You can use it to destroy the whole pool (same as before), but now also you can use it to reset the connections. @@ -70,19 +77,19 @@ - `acquire` extended with the acquisition timeout parameter - `acquireDynamically` extended with the acquisition timeout parameter -# 0.7.2 +# v0.7.2 Added support for dynamic connection configuration ([issue #11](https://github.com/nikita-volkov/hasql-pool/issues/11)). -# 0.7.1.2 +# v0.7.1.2 Fixed connections not being released if they were in use during the call to `release`. -# 0.7.1 +# v0.7.1 Added `Exception` for `UsageError`. -# 0.7 +# v0.7 Simplified the implementation a lot by removing the notion of timeout. @@ -90,7 +97,7 @@ - Removed the `Settings` type - Changed the signature of `acquire` -# 0.6 +# v0.6 Moved away from "resource-pool" and fixed the handling of lost connections. diff --git a/hasql-pool.cabal b/hasql-pool.cabal --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-pool -version: 1.4.2.1 +version: 1.4.2.2 category: Hasql, Database, PostgreSQL synopsis: Pool of connections for Hasql homepage: https://github.com/nikita-volkov/hasql-pool diff --git a/src/integration-tests/Helpers/Hooks.hs b/src/integration-tests/Helpers/Hooks.hs --- a/src/integration-tests/Helpers/Hooks.hs +++ b/src/integration-tests/Helpers/Hooks.hs @@ -2,8 +2,8 @@ module Helpers.Hooks where import Data.Bool -import TestcontainersPostgresql qualified import Prelude hiding (Handler) +import TestcontainersPostgresql qualified -- | Testing action in the scope of the host name and port of a running fresh isolated postgres server. type Handler = (Text, Word16) -> IO () diff --git a/src/integration-tests/Helpers/Scripts.hs b/src/integration-tests/Helpers/Scripts.hs --- a/src/integration-tests/Helpers/Scripts.hs +++ b/src/integration-tests/Helpers/Scripts.hs @@ -3,9 +3,10 @@ import Hasql.Connection.Settings qualified as Connection.Settings import Hasql.Pool qualified as Pool import Hasql.Pool.Config qualified as Config +import Hasql.Session qualified as Session +import Prelude import System.Random.Stateful qualified as Random import TextBuilder qualified -import Prelude -- | -- Parameters provided by the scope. @@ -40,6 +41,35 @@ -- Generate app name appName <- generateName "hasql-pool-test-" onTaggedPool poolSize acqTimeout maxLifetime maxIdletime appName (host, port) (cont appName) + +onTaggedPoolWithInitSession :: Int -> DiffTime -> DiffTime -> DiffTime -> Session.Session () -> Text -> ScopeParams -> (Pool.Pool -> IO ()) -> IO () +onTaggedPoolWithInitSession poolSize acqTimeout maxLifetime maxIdletime initSession appName (host, port) = + bracket + ( Pool.acquire + ( Config.settings + [ Config.size poolSize, + Config.acquisitionTimeout acqTimeout, + Config.agingTimeout maxLifetime, + Config.idlenessTimeout maxIdletime, + Config.initSession initSession, + Config.staticConnectionSettings + ( mconcat + [ Connection.Settings.hostAndPort host (fromIntegral port), + Connection.Settings.user "postgres", + Connection.Settings.password "", + Connection.Settings.dbname "postgres", + Connection.Settings.applicationName appName + ] + ) + ] + ) + ) + Pool.release + +onAutotaggedPoolWithInitSession :: Int -> DiffTime -> DiffTime -> DiffTime -> Session.Session () -> ScopeParams -> (Text -> Pool.Pool -> IO ()) -> IO () +onAutotaggedPoolWithInitSession poolSize acqTimeout maxLifetime maxIdletime initSession (host, port) cont = do + appName <- generateName "hasql-pool-test-" + onTaggedPoolWithInitSession poolSize acqTimeout maxLifetime maxIdletime initSession appName (host, port) (cont appName) onDefaultTaggedPool :: ScopeParams -> (Text -> Pool.Pool -> IO ()) -> IO () onDefaultTaggedPool = diff --git a/src/integration-tests/Helpers/Sessions.hs b/src/integration-tests/Helpers/Sessions.hs --- a/src/integration-tests/Helpers/Sessions.hs +++ b/src/integration-tests/Helpers/Sessions.hs @@ -5,6 +5,7 @@ setSetting, getSetting, countConnections, + sleep, ) where @@ -63,3 +64,10 @@ statement = Statement.preparable "SELECT count(*) FROM pg_stat_activity WHERE application_name = $1" encoder decoder encoder = Encoders.param (Encoders.nonNullable Encoders.text) decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)) + +sleep :: Double -> Session.Session () +sleep seconds = + Session.statement seconds statement + where + statement = Statement.preparable "SELECT pg_sleep($1)" encoder Decoders.noResult + encoder = Encoders.param (Encoders.nonNullable Encoders.float8) diff --git a/src/integration-tests/Specs/BySubject/Config/AgingTimeoutSpec.hs b/src/integration-tests/Specs/BySubject/Config/AgingTimeoutSpec.hs --- a/src/integration-tests/Specs/BySubject/Config/AgingTimeoutSpec.hs +++ b/src/integration-tests/Specs/BySubject/Config/AgingTimeoutSpec.hs @@ -3,8 +3,8 @@ import Hasql.Pool import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions -import Test.Hspec import Prelude +import Test.Hspec spec :: SpecWith Scripts.ScopeParams spec = do diff --git a/src/integration-tests/Specs/BySubject/Config/IdlenessTimeoutSpec.hs b/src/integration-tests/Specs/BySubject/Config/IdlenessTimeoutSpec.hs --- a/src/integration-tests/Specs/BySubject/Config/IdlenessTimeoutSpec.hs +++ b/src/integration-tests/Specs/BySubject/Config/IdlenessTimeoutSpec.hs @@ -3,8 +3,8 @@ import Hasql.Pool import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions -import Test.Hspec import Prelude +import Test.Hspec spec :: SpecWith Scripts.ScopeParams spec = do @@ -27,3 +27,18 @@ threadDelay 1_000_000 -- 1s res4 <- use pool $ Sessions.getSetting varName res4 `shouldBe` Right Nothing + + it "Passively times out idle connections" \scopeParams -> do + -- 0.5s connection idle time, large lifetime, so only idleness can explain a passive close. + Scripts.onAutotaggedPool 3 10 1_800 1_800 scopeParams \_appName1 pool1 -> do + Scripts.onAutotaggedPool 3 10 1_800 0.5 scopeParams \appName2 pool2 -> do + res <- use pool2 $ Sessions.selectOne + res `shouldBe` Right 1 + res2 <- use pool1 $ Sessions.countConnections appName2 + res2 `shouldBe` Right 1 + -- Give the background reaper (1s tick) a chance to passively evict + -- the now-idle connection, without ever calling `use pool2` again + -- (which would trigger the separate active idleness check). + threadDelay 1_500_000 -- 1.5s + res3 <- use pool1 $ Sessions.countConnections appName2 + res3 `shouldBe` Right 0 diff --git a/src/integration-tests/Specs/BySubject/Config/InitSessionSpec.hs b/src/integration-tests/Specs/BySubject/Config/InitSessionSpec.hs --- a/src/integration-tests/Specs/BySubject/Config/InitSessionSpec.hs +++ b/src/integration-tests/Specs/BySubject/Config/InitSessionSpec.hs @@ -3,8 +3,8 @@ import Hasql.Pool import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions -import Test.Hspec import Prelude +import Test.Hspec spec :: SpecWith Scripts.ScopeParams spec = do @@ -41,3 +41,19 @@ res <- use pool do Sessions.getSetting varName shouldBe res (Right (Just "1")) + + -- https://github.com/nikita-volkov/hasql-pool/issues/56 + it "Does not exhaust the pool capacity when it fails" \scopeParams -> do + -- Pool of size 1 whose init session always fails, with a short + -- acquisition timeout so that a leaked capacity slot shows up as + -- an AcquisitionTimeoutUsageError instead of hanging the test. + Scripts.onAutotaggedPoolWithInitSession 1 1 60 60 Sessions.badQuery scopeParams \_ pool -> do + res1 <- use pool Sessions.selectOne + res1 `shouldSatisfy` \case + Left (SessionUsageError _) -> True + _ -> False + + res2 <- use pool Sessions.selectOne + res2 `shouldSatisfy` \case + Left (SessionUsageError _) -> True + _ -> False diff --git a/src/integration-tests/Specs/BySubject/Helpers/Sessions/CountConnectionsSpec.hs b/src/integration-tests/Specs/BySubject/Helpers/Sessions/CountConnectionsSpec.hs --- a/src/integration-tests/Specs/BySubject/Helpers/Sessions/CountConnectionsSpec.hs +++ b/src/integration-tests/Specs/BySubject/Helpers/Sessions/CountConnectionsSpec.hs @@ -3,8 +3,8 @@ import Hasql.Pool import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions -import Test.Hspec import Prelude +import Test.Hspec spec :: SpecWith Scripts.ScopeParams spec = do diff --git a/src/integration-tests/Specs/BySubject/Helpers/Sessions/GetSettingSpec.hs b/src/integration-tests/Specs/BySubject/Helpers/Sessions/GetSettingSpec.hs --- a/src/integration-tests/Specs/BySubject/Helpers/Sessions/GetSettingSpec.hs +++ b/src/integration-tests/Specs/BySubject/Helpers/Sessions/GetSettingSpec.hs @@ -3,8 +3,8 @@ import Hasql.Pool import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions -import Test.Hspec import Prelude +import Test.Hspec spec :: SpecWith Scripts.ScopeParams spec = do diff --git a/src/integration-tests/Specs/BySubject/ReleaseSpec.hs b/src/integration-tests/Specs/BySubject/ReleaseSpec.hs --- a/src/integration-tests/Specs/BySubject/ReleaseSpec.hs +++ b/src/integration-tests/Specs/BySubject/ReleaseSpec.hs @@ -3,8 +3,8 @@ import Hasql.Pool import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions -import Test.Hspec import Prelude +import Test.Hspec spec :: SpecWith Scripts.ScopeParams spec = do diff --git a/src/integration-tests/Specs/BySubject/SpecHook.hs b/src/integration-tests/Specs/BySubject/SpecHook.hs --- a/src/integration-tests/Specs/BySubject/SpecHook.hs +++ b/src/integration-tests/Specs/BySubject/SpecHook.hs @@ -3,8 +3,8 @@ import Helpers.Hooks qualified as Hooks import Helpers.Scripts qualified as Scripts -import Test.Hspec import Prelude +import Test.Hspec hook :: SpecWith Scripts.ScopeParams -> Spec hook = diff --git a/src/integration-tests/Specs/BySubject/UsageError/AcquisitionTimeoutSpec.hs b/src/integration-tests/Specs/BySubject/UsageError/AcquisitionTimeoutSpec.hs --- a/src/integration-tests/Specs/BySubject/UsageError/AcquisitionTimeoutSpec.hs +++ b/src/integration-tests/Specs/BySubject/UsageError/AcquisitionTimeoutSpec.hs @@ -4,8 +4,8 @@ import Hasql.Pool import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions -import Test.Hspec import Prelude +import Test.Hspec spec :: SpecWith Scripts.ScopeParams spec = do diff --git a/src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs b/src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs --- a/src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs +++ b/src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs @@ -3,8 +3,8 @@ import Hasql.Pool import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions -import Test.Hspec import Prelude +import Test.Hspec spec :: SpecWith Scripts.ScopeParams spec = do diff --git a/src/integration-tests/Specs/BySubject/UseSpec.hs b/src/integration-tests/Specs/BySubject/UseSpec.hs --- a/src/integration-tests/Specs/BySubject/UseSpec.hs +++ b/src/integration-tests/Specs/BySubject/UseSpec.hs @@ -1,5 +1,6 @@ module Specs.BySubject.UseSpec where +import Control.Concurrent.Async (race) import Data.Text qualified as Text import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders @@ -9,8 +10,8 @@ import Hasql.Statement qualified as Statement import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions -import Test.Hspec import Prelude +import Test.Hspec spec :: SpecWith Scripts.ScopeParams spec = do @@ -54,6 +55,39 @@ _ <- use pool $ Sessions.badQuery res <- use pool $ Sessions.selectOne shouldSatisfy res $ isRight + + -- https://github.com/nikita-volkov/hasql-pool/issues/38 + -- + -- When a session is interrupted by an asynchronous exception (e.g., a + -- caller-side timeout racing the query, as simulated here via `race`) + -- while it is genuinely blocked waiting on the server's response, the + -- underlying libpq connection is left mid-command: the query was sent, + -- but its result was never read. `onLiveConn` in Hasql.Pool.use still + -- unconditionally returns such a connection to the pool (the `Left exc` + -- branch calls `returnConn` for all exceptions, not just synchronous + -- ones), so the next `use` call hands out a connection whose protocol + -- state is desynced from libpq's expectations. This is a plausible root + -- cause of the "connection pointer is NULL" reports: two independent + -- consumers of hasql-pool end up driving the same libpq connection state + -- machine without coordination. + it "Does not return a connection to the pool when the session is interrupted by an asynchronous exception" \scopeParams -> + Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do + started <- newEmptyMVar + _ <- + race + ( use pool do + liftIO $ putMVar started () + Sessions.sleep 2 + ) + ( do + takeMVar started + -- Give the query time to actually reach the server and for + -- the client to start blocking on the socket read, as + -- opposed to being cancelled while still sending. + threadDelay 200_000 + ) + res <- use pool Sessions.selectOne + res `shouldSatisfy` isRight it "Cached type errors cause eviction of connection" \scopeParams -> do typeName <- Text.replace "-" "_" <$> Scripts.generateName "cached_type_" diff --git a/src/library/Hasql/Pool.hs b/src/library/Hasql/Pool.hs --- a/src/library/Hasql/Pool.hs +++ b/src/library/Hasql/Pool.hs @@ -85,7 +85,7 @@ join . atomically $ do entries <- flushTQueue connectionQueue let (agedEntries, unagedEntries) = partition (entryIsAged agingTimeoutNanos now) entries - (idleEntries, liveEntries) = partition (entryIsIdle agingTimeoutNanos now) unagedEntries + (idleEntries, liveEntries) = partition (entryIsIdle maxIdletimeNanos now) unagedEntries traverse_ (writeTQueue connectionQueue) liveEntries return $ do forM_ agedEntries $ \entry -> do @@ -181,6 +181,7 @@ Connection.use connection poolInitSession >>= \case Left err -> do Connection.release connection + atomically $ modifyTVar' poolCapacity succ ErrorsDestruction.reset ( \details -> do poolObserver (ConnectionObservation id (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (Just details)))) diff --git a/src/library/Hasql/Pool/Prelude.hs b/src/library/Hasql/Pool/Prelude.hs --- a/src/library/Hasql/Pool/Prelude.hs +++ b/src/library/Hasql/Pool/Prelude.hs @@ -61,6 +61,7 @@ import GHC.Generics as Exports (Generic) import GHC.IO.Exception as Exports import Numeric as Exports +import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.)) import System.Environment as Exports import System.Exit as Exports import System.IO as Exports (Handle, hClose) @@ -72,4 +73,3 @@ import Text.Printf as Exports (hPrintf, printf) import Text.Read as Exports (Read (..), readEither, readMaybe) import Unsafe.Coerce as Exports -import Prelude as Exports hiding (all, and, any, concat, concatMap, elem, fail, foldl, foldl1, foldr, foldr1, id, mapM, mapM_, maximum, minimum, notElem, or, product, sequence, sequence_, sum, (.))