hasql-pool 1.4.2.1 → 1.4.2.2

raw patch · 17 files changed

+143/−32 lines, 17 files

Files

• CHANGELOG.md +24/−17
• hasql-pool.cabal +1/−1
• src/integration-tests/Helpers/Hooks.hs +1/−1
• src/integration-tests/Helpers/Scripts.hs +31/−1
• src/integration-tests/Helpers/Sessions.hs +8/−0
• src/integration-tests/Specs/BySubject/Config/AgingTimeoutSpec.hs +1/−1
• src/integration-tests/Specs/BySubject/Config/IdlenessTimeoutSpec.hs +16/−1
• src/integration-tests/Specs/BySubject/Config/InitSessionSpec.hs +17/−1
• src/integration-tests/Specs/BySubject/Helpers/Sessions/CountConnectionsSpec.hs +1/−1
• src/integration-tests/Specs/BySubject/Helpers/Sessions/GetSettingSpec.hs +1/−1
• src/integration-tests/Specs/BySubject/ReleaseSpec.hs +1/−1
• src/integration-tests/Specs/BySubject/SpecHook.hs +1/−1
• src/integration-tests/Specs/BySubject/UsageError/AcquisitionTimeoutSpec.hs +1/−1
• src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs +1/−1
• src/integration-tests/Specs/BySubject/UseSpec.hs +35/−1
• src/library/Hasql/Pool.hs +2/−1
• src/library/Hasql/Pool/Prelude.hs +1/−1

@@ -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. 

@@ -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

@@ -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 ()

@@ -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 =

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 =

@@ -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

@@ -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

@@ -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_"

@@ -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))))

@@ -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, (.))