packages feed

hasql-pool 1.4.2.3 → 1.5.0.0

raw patch · 26 files changed

+473/−421 lines, 26 filesdep +pqidep +pqi-ffidep +pqi-nativedep −postgresql-libpqdep ~hasqlPVP ok

version bump matches the API change (PVP)

Dependencies added: pqi, pqi-ffi, pqi-native

Dependencies removed: postgresql-libpq

Dependency ranges changed: hasql

API changes (from Hackage documentation)

- Hasql.Pool: acquire :: Config -> IO Pool
+ Hasql.Pool: acquire :: Adapter -> Config -> IO Pool

Files

CHANGELOG.md view
@@ -1,3 +1,9 @@+# v1.5.0.0++## Breaking++- Migrate to `hasql-2`, replacing `postgresql-libpq` with the `pqi` connection-adapter interface. `acquire` now takes a `Pqi.Adapter` as its first argument; pick one from an adapter package such as `pqi-ffi` or `pqi-native`.+ # v1.4.2.3  ## Fixes
hasql-pool.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-pool-version: 1.4.2.3+version: 1.5.0.0 category: Hasql, Database, PostgreSQL synopsis: Pool of connections for Hasql homepage: https://github.com/nikita-volkov/hasql-pool@@ -85,7 +85,8 @@   build-depends:     base >=4.11 && <5,     bytestring >=0.10 && <0.14,-    hasql >=1.10 && <1.11,+    hasql ^>=2.0,+    pqi ^>=1.0,     stm >=2.5 && <3,     text >=1.2 && <3,     time >=1.9 && <2,@@ -97,19 +98,20 @@   hs-source-dirs: src/integration-tests   main-is: Main.hs   other-modules:+    Helpers.Adapters     Helpers.Hooks     Helpers.Scripts     Helpers.Sessions-    Specs.BySubject.Config.AgingTimeoutSpec-    Specs.BySubject.Config.IdlenessTimeoutSpec-    Specs.BySubject.Config.InitSessionSpec-    Specs.BySubject.Helpers.Sessions.CountConnectionsSpec-    Specs.BySubject.Helpers.Sessions.GetSettingSpec-    Specs.BySubject.ReleaseSpec-    Specs.BySubject.SpecHook-    Specs.BySubject.UsageError.AcquisitionTimeoutSpec-    Specs.BySubject.UsageError.SessionSpec-    Specs.BySubject.UseSpec+    Specs.Config.AgingTimeoutSpec+    Specs.Config.IdlenessTimeoutSpec+    Specs.Config.InitSessionSpec+    Specs.Helpers.Sessions.CountConnectionsSpec+    Specs.Helpers.Sessions.GetSettingSpec+    Specs.ReleaseSpec+    Specs.SpecHook+    Specs.UsageError.AcquisitionTimeoutSpec+    Specs.UsageError.SessionSpec+    Specs.UseSpec    ghc-options: -threaded   build-tool-depends:@@ -120,7 +122,9 @@     hasql,     hasql-pool,     hspec >=2.6 && <3,-    postgresql-libpq >=0.10 && <0.12,+    pqi ^>=1.0,+    pqi-ffi ^>=1.0,+    pqi-native ^>=1.0,     random >=1.2 && <2,     rerebase >=1.15 && <2,     testcontainers-postgresql >=0.2 && <0.3,
+ src/integration-tests/Helpers/Adapters.hs view
@@ -0,0 +1,30 @@+module Helpers.Adapters+  ( adapters,+    byAdapter,+    hook,+  )+where++import Pqi qualified+import Pqi.Ffi qualified+import Pqi.Native qualified+import Prelude+import Test.Hspec++adapters :: [Pqi.Adapter]+adapters =+  [ Pqi.Ffi.adapter,+    Pqi.Native.adapter+  ]++-- | Run the given spec-building function once per available Pqi adapter,+-- nesting each run under a @describe@ named after the adapter.+byAdapter :: (Pqi.Adapter -> Spec) -> Spec+byAdapter f =+  for_ adapters \adapter ->+    describe (toList (Pqi.name adapter)) (f adapter)++hook :: SpecWith Pqi.Adapter -> Spec+hook hookedSpec =+  byAdapter \adapter ->+    mapSubject (const adapter) hookedSpec
src/integration-tests/Helpers/Scripts.hs view
@@ -4,19 +4,21 @@ import Hasql.Pool qualified as Pool import Hasql.Pool.Config qualified as Config import Hasql.Session qualified as Session+import Pqi qualified import Prelude import System.Random.Stateful qualified as Random import TextBuilder qualified  -- | -- Parameters provided by the scope.--- Host and port of a running isolated postgres server.-type ScopeParams = (Text, Word16)+-- Adapter, host and port of a running isolated postgres server.+type ScopeParams = (Pqi.Adapter, Text, Word16)  onTaggedPool :: Int -> DiffTime -> DiffTime -> DiffTime -> Text -> ScopeParams -> (Pool.Pool -> IO ()) -> IO ()-onTaggedPool poolSize acqTimeout maxLifetime maxIdletime appName (host, port) =+onTaggedPool poolSize acqTimeout maxLifetime maxIdletime appName (adapter, host, port) =   bracket     ( Pool.acquire+        adapter         ( Config.settings             [ Config.size poolSize,               Config.acquisitionTimeout acqTimeout,@@ -37,15 +39,16 @@     Pool.release  onAutotaggedPool :: Int -> DiffTime -> DiffTime -> DiffTime -> ScopeParams -> (Text -> Pool.Pool -> IO ()) -> IO ()-onAutotaggedPool poolSize acqTimeout maxLifetime maxIdletime (host, port) cont = do+onAutotaggedPool poolSize acqTimeout maxLifetime maxIdletime scopeParams cont = do   -- Generate app name   appName <- generateName "hasql-pool-test-"-  onTaggedPool poolSize acqTimeout maxLifetime maxIdletime appName (host, port) (cont appName)+  onTaggedPool poolSize acqTimeout maxLifetime maxIdletime appName scopeParams (cont appName)  onTaggedPoolWithInitSession :: Int -> DiffTime -> DiffTime -> DiffTime -> Session.Session () -> Text -> ScopeParams -> (Pool.Pool -> IO ()) -> IO ()-onTaggedPoolWithInitSession poolSize acqTimeout maxLifetime maxIdletime initSession appName (host, port) =+onTaggedPoolWithInitSession poolSize acqTimeout maxLifetime maxIdletime initSession appName (adapter, host, port) =   bracket     ( Pool.acquire+        adapter         ( Config.settings             [ Config.size poolSize,               Config.acquisitionTimeout acqTimeout,@@ -67,9 +70,9 @@     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+onAutotaggedPoolWithInitSession poolSize acqTimeout maxLifetime maxIdletime initSession (adapter, host, port) cont = do   appName <- generateName "hasql-pool-test-"-  onTaggedPoolWithInitSession poolSize acqTimeout maxLifetime maxIdletime initSession appName (host, port) (cont appName)+  onTaggedPoolWithInitSession poolSize acqTimeout maxLifetime maxIdletime initSession appName (adapter, host, port) (cont appName)  onDefaultTaggedPool :: ScopeParams -> (Text -> Pool.Pool -> IO ()) -> IO () onDefaultTaggedPool =
src/integration-tests/Helpers/Sessions.hs view
@@ -10,11 +10,11 @@ where  import Data.Tuple.All-import Database.PostgreSQL.LibPQ qualified as Pq import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders import Hasql.Session qualified as Session import Hasql.Statement qualified as Statement+import Pqi qualified import Prelude  selectOne :: Session.Session Int64@@ -34,7 +34,7 @@ closeConn :: Session.Session () closeConn =   Session.onLibpqConnection \conn -> do-    Pq.finish conn+    Pqi.finish conn     pure (Right (), conn)  setSetting :: Text -> Text -> Session.Session ()
− src/integration-tests/Specs/BySubject/Config/AgingTimeoutSpec.hs 
@@ -1,32 +0,0 @@-module Specs.BySubject.Config.AgingTimeoutSpec where--import Hasql.Pool-import Helpers.Scripts qualified as Scripts-import Helpers.Sessions qualified as Sessions-import Prelude-import Test.Hspec--spec :: SpecWith Scripts.ScopeParams-spec = do-  it "Actively times out old connections" \scopeParams -> do-    Scripts.onAutotaggedPool 3 10 1_800 1_800 scopeParams \_appName1 pool1 -> do-      Scripts.onAutotaggedPool 3 10 0.5 1_800 scopeParams \appName2 pool2 -> do-        res <- use pool2 $ Sessions.selectOne-        res `shouldBe` Right 1-        res2 <- use pool1 $ Sessions.countConnections appName2-        res2 `shouldBe` Right 1-        threadDelay 1_000_000 -- 1s-        res3 <- use pool1 $ Sessions.countConnections appName2-        res3 `shouldBe` Right 0--  it "Passively times out old connections" \scopeParams -> do-    -- 0.5s connection lifetime-    Scripts.onAutotaggedPool 1 10 0.5 1_800 scopeParams \_ pool -> do-      varName <- Scripts.generateVarname-      res <- use pool $ Sessions.setSetting varName "hello world"-      res `shouldBe` Right ()-      res2 <- use pool $ Sessions.getSetting varName-      res2 `shouldBe` Right (Just "hello world")-      threadDelay 1_000_000 -- 1s-      res3 <- use pool $ Sessions.getSetting varName-      res3 `shouldBe` Right Nothing
− src/integration-tests/Specs/BySubject/Config/IdlenessTimeoutSpec.hs 
@@ -1,44 +0,0 @@-module Specs.BySubject.Config.IdlenessTimeoutSpec where--import Hasql.Pool-import Helpers.Scripts qualified as Scripts-import Helpers.Sessions qualified as Sessions-import Prelude-import Test.Hspec--spec :: SpecWith Scripts.ScopeParams-spec = do-  it "Times out old connections (maxIdletime)" \scopeParams -> do-    -- 0.5s connection idle time-    Scripts.onAutotaggedPool 1 10 1_800 0.5 scopeParams \_ pool -> do-      varName <- Scripts.generateVarname-      res <- use pool $ Sessions.setSetting varName "hello world"-      res `shouldBe` Right ()-      res2 <- use pool $ Sessions.getSetting varName-      res2 `shouldBe` Right (Just "hello world")-      -- busy sleep, to keep connection alive-      forM_ [1 :: Int .. 10] $ \_ -> do-        r <- use pool $ Sessions.selectOne-        r `shouldBe` Right 1-        threadDelay 100_000 -- 0.1s-      res3 <- use pool $ Sessions.getSetting varName-      res3 `shouldBe` Right (Just "hello world")-      -- idle sleep, connection times out-      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
− src/integration-tests/Specs/BySubject/Config/InitSessionSpec.hs 
@@ -1,59 +0,0 @@-module Specs.BySubject.Config.InitSessionSpec where--import Hasql.Pool-import Helpers.Scripts qualified as Scripts-import Helpers.Sessions qualified as Sessions-import Prelude-import Test.Hspec--spec :: SpecWith Scripts.ScopeParams-spec = do-  it "Persists after exceptions thrown in session" \scopeParams -> do-    Scripts.onAutotaggedPool 1 10 60 60 scopeParams \_ pool -> do-      varName <- Scripts.generateVarname--      res <- use pool do-        Sessions.setSetting varName "1"-        Sessions.getSetting varName-      shouldBe res (Right (Just "1"))--      try @SomeException do-        use pool do-          liftIO do-            throwIO (userError "Intentional error for testing")--      res <- use pool do-        Sessions.getSetting varName-      shouldBe res (Right (Just "1"))--  it "Persists after bad query" \scopeParams -> do-    Scripts.onAutotaggedPool 1 10 60 60 scopeParams \_ pool -> do-      varName <- Scripts.generateVarname--      res <- use pool do-        Sessions.setSetting varName "1"-        Sessions.getSetting varName-      shouldBe res (Right (Just "1"))--      use pool do-        Sessions.badQuery--      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
− src/integration-tests/Specs/BySubject/Helpers/Sessions/CountConnectionsSpec.hs 
@@ -1,14 +0,0 @@-module Specs.BySubject.Helpers.Sessions.CountConnectionsSpec where--import Hasql.Pool-import Helpers.Scripts qualified as Scripts-import Helpers.Sessions qualified as Sessions-import Prelude-import Test.Hspec--spec :: SpecWith Scripts.ScopeParams-spec = do-  it "Counts active connections" \scopeParams -> do-    Scripts.onAutotaggedPool 3 10 1_800 1_800 scopeParams \appName pool -> do-      res <- use pool $ Sessions.countConnections appName-      res `shouldBe` Right 1
− src/integration-tests/Specs/BySubject/Helpers/Sessions/GetSettingSpec.hs 
@@ -1,36 +0,0 @@-module Specs.BySubject.Helpers.Sessions.GetSettingSpec where--import Hasql.Pool-import Helpers.Scripts qualified as Scripts-import Helpers.Sessions qualified as Sessions-import Prelude-import Test.Hspec--spec :: SpecWith Scripts.ScopeParams-spec = do-  it "Getting and setting session variables works" \scopeParams ->-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      varName <- Scripts.generateVarname-      res <- use pool $ Sessions.getSetting varName-      res `shouldBe` Right Nothing-      res <- use pool $ do-        Sessions.setSetting varName "hello world"-        Sessions.getSetting varName-      res `shouldBe` Right (Just "hello world")--  it "Session variables stay set when a connection gets reused" \scopeParams ->-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      varName <- Scripts.generateVarname-      res <- use pool $ Sessions.setSetting varName "hello world"-      res `shouldBe` Right ()-      res2 <- use pool $ Sessions.getSetting varName-      res2 `shouldBe` Right (Just "hello world")--  it "Releasing the pool resets session variables" \scopeParams -> do-    varName <- Scripts.generateVarname-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      res <- use pool $ Sessions.setSetting varName "hello world"-      res `shouldBe` Right ()-      release pool-      res <- use pool $ Sessions.getSetting varName-      res `shouldBe` Right Nothing
− src/integration-tests/Specs/BySubject/ReleaseSpec.hs 
@@ -1,16 +0,0 @@-module Specs.BySubject.ReleaseSpec where--import Hasql.Pool-import Helpers.Scripts qualified as Scripts-import Helpers.Sessions qualified as Sessions-import Prelude-import Test.Hspec--spec :: SpecWith Scripts.ScopeParams-spec = do-  it "The pool remains usable after release" \scopeParams ->-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      _ <- use pool $ Sessions.selectOne-      release pool-      res <- use pool $ Sessions.selectOne-      shouldSatisfy res $ isRight
− src/integration-tests/Specs/BySubject/SpecHook.hs 
@@ -1,11 +0,0 @@--- Docs: https://hspec.github.io/hspec-discover.html-module Specs.BySubject.SpecHook where--import Helpers.Hooks qualified as Hooks-import Helpers.Scripts qualified as Scripts-import Prelude-import Test.Hspec--hook :: SpecWith Scripts.ScopeParams -> Spec-hook =-  aroundAll Hooks.postgres17 . parallel
− src/integration-tests/Specs/BySubject/UsageError/AcquisitionTimeoutSpec.hs 
@@ -1,33 +0,0 @@-module Specs.BySubject.UsageError.AcquisitionTimeoutSpec where--import Control.Concurrent.Async (race)-import Hasql.Pool-import Helpers.Scripts qualified as Scripts-import Helpers.Sessions qualified as Sessions-import Prelude-import Test.Hspec--spec :: SpecWith Scripts.ScopeParams-spec = do-  it "Gets produced on timeout" \scopeParams ->-    -- 1ms timeout-    Scripts.onAutotaggedPool 1 0.001 1_800 1_800 scopeParams \_ pool -> do-      sleeping <- newEmptyMVar-      t0 <- getCurrentTime-      res <--        race-          ( use pool-              $ liftIO-              $ do-                putMVar sleeping ()-                -- 1s-                threadDelay 1_000_000-          )-          ( do-              takeMVar sleeping-              use pool $ Sessions.selectOne-          )-      t1 <- getCurrentTime-      res `shouldBe` Right (Left AcquisitionTimeoutUsageError)-      -- 0.5s-      diffUTCTime t1 t0 `shouldSatisfy` (< 0.5)
− src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs 
@@ -1,16 +0,0 @@-module Specs.BySubject.UsageError.SessionSpec where--import Hasql.Pool-import Helpers.Scripts qualified as Scripts-import Helpers.Sessions qualified as Sessions-import Prelude-import Test.Hspec--spec :: SpecWith Scripts.ScopeParams-spec = do-  it "Bad SQL query triggers error" \scopeParams ->-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      res <- use pool Sessions.badQuery-      shouldSatisfy res $ \case-        Left (SessionUsageError _) -> True-        _ -> False
− src/integration-tests/Specs/BySubject/UseSpec.hs 
@@ -1,133 +0,0 @@-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-import Hasql.Errors qualified as Errors-import Hasql.Pool-import Hasql.Session qualified as Session-import Hasql.Statement qualified as Statement-import Helpers.Scripts qualified as Scripts-import Helpers.Sessions qualified as Sessions-import Prelude-import Test.Hspec--spec :: SpecWith Scripts.ScopeParams-spec = do-  it "Releases a spot in the pool when there is a query error" \scopeParams ->-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      use pool Sessions.badQuery `shouldNotReturn` (Right ())-      use pool Sessions.selectOne `shouldReturn` (Right 1)--  it "Connection errors cause eviction of connection" \scopeParams ->-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      _ <- use pool $ Sessions.closeConn >> Sessions.selectOne-      _ <- use pool $ Sessions.closeConn >> Sessions.selectOne-      _ <- use pool $ Sessions.closeConn >> Sessions.selectOne-      res <- use pool $ Sessions.selectOne-      shouldSatisfy res $ isRight--  it "Driver errors cause eviction of connection" \scopeParams -> do-    settingName <- Scripts.generateVarname-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      use pool (Sessions.setSetting settingName "present") `shouldReturn` Right ()-      result <- use pool driverError-      result `shouldSatisfy` \case-        Left (SessionUsageError (Errors.DriverSessionError _)) -> True-        _ -> False-      use pool (Sessions.getSetting settingName) `shouldReturn` Right Nothing--  it "Connection gets returned to the pool after normal use" \scopeParams ->-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      _ <- use pool $ Sessions.selectOne-      _ <- use pool $ Sessions.selectOne-      _ <- use pool $ Sessions.selectOne-      _ <- use pool $ Sessions.selectOne-      res <- use pool $ Sessions.selectOne-      shouldSatisfy res $ isRight--  it "Connection gets returned to the pool after non-connection error" \scopeParams ->-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      _ <- use pool $ Sessions.badQuery-      _ <- use pool $ Sessions.badQuery-      _ <- use pool $ Sessions.badQuery-      _ <- 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_"-    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do-      use pool (Session.script (createTypeSql typeName)) `shouldReturn` Right ()-      use pool (roundtripEnum typeName "ok") `shouldReturn` Right "ok"-      use pool (Session.script (recreateTypeSql typeName)) `shouldReturn` Right ()-      res <- use pool (roundtripEnum typeName "ok")-      shouldSatisfy res \case-        Left (SessionUsageError _) -> True-        _ -> False-      use pool (roundtripEnum typeName "ok") `shouldReturn` Right "ok"--quoteIdentifier :: Text -> Text-quoteIdentifier identifier =-  "\"" <> Text.replace "\"" "\"\"" identifier <> "\""--createTypeSql :: Text -> Text-createTypeSql typeName =-  "create type " <> quotedTypeName <> " as enum ('sad', 'ok', 'happy')"-  where-    quotedTypeName = quoteIdentifier typeName--recreateTypeSql :: Text -> Text-recreateTypeSql typeName =-  "drop type " <> quotedTypeName <> "; create type " <> quotedTypeName <> " as enum ('sad', 'ok', 'happy')"-  where-    quotedTypeName = quoteIdentifier typeName--roundtripEnum :: Text -> Text -> Session.Session Text-roundtripEnum typeName value =-  Session.statement value statement-  where-    statement =-      Statement.preparable-        ("select $1 :: " <> quoteIdentifier typeName)-        (Encoders.param (Encoders.nonNullable (Encoders.enum Nothing typeName id)))-        (Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.enum Nothing typeName Just))))--driverError :: Session.Session ()-driverError =-  Session.onLibpqConnection \connection ->-    pure (Left (Errors.DriverSessionError "synthetic driver error"), connection)
+ src/integration-tests/Specs/Config/AgingTimeoutSpec.hs view
@@ -0,0 +1,32 @@+module Specs.Config.AgingTimeoutSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Prelude+import Test.Hspec++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "Actively times out old connections" \scopeParams -> do+    Scripts.onAutotaggedPool 3 10 1_800 1_800 scopeParams \_appName1 pool1 -> do+      Scripts.onAutotaggedPool 3 10 0.5 1_800 scopeParams \appName2 pool2 -> do+        res <- use pool2 $ Sessions.selectOne+        res `shouldBe` Right 1+        res2 <- use pool1 $ Sessions.countConnections appName2+        res2 `shouldBe` Right 1+        threadDelay 1_000_000 -- 1s+        res3 <- use pool1 $ Sessions.countConnections appName2+        res3 `shouldBe` Right 0++  it "Passively times out old connections" \scopeParams -> do+    -- 0.5s connection lifetime+    Scripts.onAutotaggedPool 1 10 0.5 1_800 scopeParams \_ pool -> do+      varName <- Scripts.generateVarname+      res <- use pool $ Sessions.setSetting varName "hello world"+      res `shouldBe` Right ()+      res2 <- use pool $ Sessions.getSetting varName+      res2 `shouldBe` Right (Just "hello world")+      threadDelay 1_000_000 -- 1s+      res3 <- use pool $ Sessions.getSetting varName+      res3 `shouldBe` Right Nothing
+ src/integration-tests/Specs/Config/IdlenessTimeoutSpec.hs view
@@ -0,0 +1,44 @@+module Specs.Config.IdlenessTimeoutSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Prelude+import Test.Hspec++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "Times out old connections (maxIdletime)" \scopeParams -> do+    -- 0.5s connection idle time+    Scripts.onAutotaggedPool 1 10 1_800 0.5 scopeParams \_ pool -> do+      varName <- Scripts.generateVarname+      res <- use pool $ Sessions.setSetting varName "hello world"+      res `shouldBe` Right ()+      res2 <- use pool $ Sessions.getSetting varName+      res2 `shouldBe` Right (Just "hello world")+      -- busy sleep, to keep connection alive+      forM_ [1 :: Int .. 10] $ \_ -> do+        r <- use pool $ Sessions.selectOne+        r `shouldBe` Right 1+        threadDelay 100_000 -- 0.1s+      res3 <- use pool $ Sessions.getSetting varName+      res3 `shouldBe` Right (Just "hello world")+      -- idle sleep, connection times out+      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
+ src/integration-tests/Specs/Config/InitSessionSpec.hs view
@@ -0,0 +1,59 @@+module Specs.Config.InitSessionSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Prelude+import Test.Hspec++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "Persists after exceptions thrown in session" \scopeParams -> do+    Scripts.onAutotaggedPool 1 10 60 60 scopeParams \_ pool -> do+      varName <- Scripts.generateVarname++      res <- use pool do+        Sessions.setSetting varName "1"+        Sessions.getSetting varName+      shouldBe res (Right (Just "1"))++      try @SomeException do+        use pool do+          liftIO do+            throwIO (userError "Intentional error for testing")++      res <- use pool do+        Sessions.getSetting varName+      shouldBe res (Right (Just "1"))++  it "Persists after bad query" \scopeParams -> do+    Scripts.onAutotaggedPool 1 10 60 60 scopeParams \_ pool -> do+      varName <- Scripts.generateVarname++      res <- use pool do+        Sessions.setSetting varName "1"+        Sessions.getSetting varName+      shouldBe res (Right (Just "1"))++      use pool do+        Sessions.badQuery++      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
+ src/integration-tests/Specs/Helpers/Sessions/CountConnectionsSpec.hs view
@@ -0,0 +1,14 @@+module Specs.Helpers.Sessions.CountConnectionsSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Prelude+import Test.Hspec++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "Counts active connections" \scopeParams -> do+    Scripts.onAutotaggedPool 3 10 1_800 1_800 scopeParams \appName pool -> do+      res <- use pool $ Sessions.countConnections appName+      res `shouldBe` Right 1
+ src/integration-tests/Specs/Helpers/Sessions/GetSettingSpec.hs view
@@ -0,0 +1,36 @@+module Specs.Helpers.Sessions.GetSettingSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Prelude+import Test.Hspec++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "Getting and setting session variables works" \scopeParams ->+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      varName <- Scripts.generateVarname+      res <- use pool $ Sessions.getSetting varName+      res `shouldBe` Right Nothing+      res <- use pool $ do+        Sessions.setSetting varName "hello world"+        Sessions.getSetting varName+      res `shouldBe` Right (Just "hello world")++  it "Session variables stay set when a connection gets reused" \scopeParams ->+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      varName <- Scripts.generateVarname+      res <- use pool $ Sessions.setSetting varName "hello world"+      res `shouldBe` Right ()+      res2 <- use pool $ Sessions.getSetting varName+      res2 `shouldBe` Right (Just "hello world")++  it "Releasing the pool resets session variables" \scopeParams -> do+    varName <- Scripts.generateVarname+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      res <- use pool $ Sessions.setSetting varName "hello world"+      res `shouldBe` Right ()+      release pool+      res <- use pool $ Sessions.getSetting varName+      res `shouldBe` Right Nothing
+ src/integration-tests/Specs/ReleaseSpec.hs view
@@ -0,0 +1,16 @@+module Specs.ReleaseSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Prelude+import Test.Hspec++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "The pool remains usable after release" \scopeParams ->+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      _ <- use pool $ Sessions.selectOne+      release pool+      res <- use pool $ Sessions.selectOne+      shouldSatisfy res $ isRight
+ src/integration-tests/Specs/SpecHook.hs view
@@ -0,0 +1,15 @@+-- Docs: https://hspec.github.io/hspec-discover.html+module Specs.SpecHook where++import Helpers.Adapters qualified as Adapters+import Helpers.Hooks qualified as Hooks+import Helpers.Scripts qualified as Scripts+import Test.Hspec++hook :: SpecWith Scripts.ScopeParams -> Spec+hook hookedSpec =+  Adapters.hook+    ( aroundAllWith+        (\action adapter -> Hooks.postgres17 \(host, port) -> action (adapter, host, port))+        (parallel hookedSpec)+    )
+ src/integration-tests/Specs/UsageError/AcquisitionTimeoutSpec.hs view
@@ -0,0 +1,33 @@+module Specs.UsageError.AcquisitionTimeoutSpec where++import Control.Concurrent.Async (race)+import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Prelude+import Test.Hspec++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "Gets produced on timeout" \scopeParams ->+    -- 1ms timeout+    Scripts.onAutotaggedPool 1 0.001 1_800 1_800 scopeParams \_ pool -> do+      sleeping <- newEmptyMVar+      t0 <- getCurrentTime+      res <-+        race+          ( use pool+              $ liftIO+              $ do+                putMVar sleeping ()+                -- 1s+                threadDelay 1_000_000+          )+          ( do+              takeMVar sleeping+              use pool $ Sessions.selectOne+          )+      t1 <- getCurrentTime+      res `shouldBe` Right (Left AcquisitionTimeoutUsageError)+      -- 0.5s+      diffUTCTime t1 t0 `shouldSatisfy` (< 0.5)
+ src/integration-tests/Specs/UsageError/SessionSpec.hs view
@@ -0,0 +1,16 @@+module Specs.UsageError.SessionSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Prelude+import Test.Hspec++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "Bad SQL query triggers error" \scopeParams ->+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      res <- use pool Sessions.badQuery+      shouldSatisfy res $ \case+        Left (SessionUsageError _) -> True+        _ -> False
+ src/integration-tests/Specs/UseSpec.hs view
@@ -0,0 +1,133 @@+module Specs.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+import Hasql.Errors qualified as Errors+import Hasql.Pool+import Hasql.Session qualified as Session+import Hasql.Statement qualified as Statement+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Prelude+import Test.Hspec++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "Releases a spot in the pool when there is a query error" \scopeParams ->+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      use pool Sessions.badQuery `shouldNotReturn` (Right ())+      use pool Sessions.selectOne `shouldReturn` (Right 1)++  it "Connection errors cause eviction of connection" \scopeParams ->+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      _ <- use pool $ Sessions.closeConn >> Sessions.selectOne+      _ <- use pool $ Sessions.closeConn >> Sessions.selectOne+      _ <- use pool $ Sessions.closeConn >> Sessions.selectOne+      res <- use pool $ Sessions.selectOne+      shouldSatisfy res $ isRight++  it "Driver errors cause eviction of connection" \scopeParams -> do+    settingName <- Scripts.generateVarname+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      use pool (Sessions.setSetting settingName "present") `shouldReturn` Right ()+      result <- use pool driverError+      result `shouldSatisfy` \case+        Left (SessionUsageError (Errors.DriverSessionError _)) -> True+        _ -> False+      use pool (Sessions.getSetting settingName) `shouldReturn` Right Nothing++  it "Connection gets returned to the pool after normal use" \scopeParams ->+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      _ <- use pool $ Sessions.selectOne+      _ <- use pool $ Sessions.selectOne+      _ <- use pool $ Sessions.selectOne+      _ <- use pool $ Sessions.selectOne+      res <- use pool $ Sessions.selectOne+      shouldSatisfy res $ isRight++  it "Connection gets returned to the pool after non-connection error" \scopeParams ->+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      _ <- use pool $ Sessions.badQuery+      _ <- use pool $ Sessions.badQuery+      _ <- use pool $ Sessions.badQuery+      _ <- 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_"+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      use pool (Session.script (createTypeSql typeName)) `shouldReturn` Right ()+      use pool (roundtripEnum typeName "ok") `shouldReturn` Right "ok"+      use pool (Session.script (recreateTypeSql typeName)) `shouldReturn` Right ()+      res <- use pool (roundtripEnum typeName "ok")+      shouldSatisfy res \case+        Left (SessionUsageError _) -> True+        _ -> False+      use pool (roundtripEnum typeName "ok") `shouldReturn` Right "ok"++quoteIdentifier :: Text -> Text+quoteIdentifier identifier =+  "\"" <> Text.replace "\"" "\"\"" identifier <> "\""++createTypeSql :: Text -> Text+createTypeSql typeName =+  "create type " <> quotedTypeName <> " as enum ('sad', 'ok', 'happy')"+  where+    quotedTypeName = quoteIdentifier typeName++recreateTypeSql :: Text -> Text+recreateTypeSql typeName =+  "drop type " <> quotedTypeName <> "; create type " <> quotedTypeName <> " as enum ('sad', 'ok', 'happy')"+  where+    quotedTypeName = quoteIdentifier typeName++roundtripEnum :: Text -> Text -> Session.Session Text+roundtripEnum typeName value =+  Session.statement value statement+  where+    statement =+      Statement.preparable+        ("select $1 :: " <> quoteIdentifier typeName)+        (Encoders.param (Encoders.nonNullable (Encoders.enum Nothing typeName id)))+        (Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.enum Nothing typeName Just))))++driverError :: Session.Session ()+driverError =+  Session.onLibpqConnection \connection ->+    pure (Left (Errors.DriverSessionError "synthetic driver error"), connection)
src/library/Hasql/Pool.hs view
@@ -20,6 +20,7 @@ import Hasql.Pool.Prelude import Hasql.Pool.SessionErrorDestructors qualified as ErrorsDestruction import Hasql.Session qualified as Session+import Pqi qualified  -- | A connection tagged with metadata. data Entry = Entry@@ -41,6 +42,8 @@ data Pool = Pool   { -- | Pool size.     poolSize :: Int,+    -- | Adapter used to establish connections.+    poolAdapter :: Pqi.Adapter,     -- | Connection settings.     poolFetchConnectionSettings :: IO Connection.Settings.Settings,     -- | Acquisition timeout, in microseconds.@@ -72,8 +75,10 @@ -- to 'use'. -- -- If you want to ensure that the pool connects fine at the initialization phase, just run 'use' with an empty session (@pure ()@) and check for errors.-acquire :: Config.Config -> IO Pool-acquire config = do+--+-- The 'Pqi.Adapter' determines which connection implementation the pool uses, e.g. an FFI adapter backed by @postgresql-libpq@, or a pure Haskell one. Pick one from an adapter package such as @pqi-ffi@ or @pqi-native@.+acquire :: Pqi.Adapter -> Config.Config -> IO Pool+acquire adapter config = do   connectionQueue <- newTQueueIO   capVar <- newTVarIO (Config.size config)   reuseVar <- newTVarIO =<< newTVarIO True@@ -101,7 +106,7 @@     -- When the pool goes out of scope, stop the manager.     killThread managerTid -  return $ Pool (Config.size config) (Config.connectionSettingsProvider config) acqTimeoutMicros agingTimeoutNanos maxIdletimeNanos connectionQueue capVar reuseVar reaperRef (Config.observationHandler config) (Config.initSession config)+  return $ Pool (Config.size config) adapter (Config.connectionSettingsProvider config) acqTimeoutMicros agingTimeoutNanos maxIdletimeNanos connectionQueue capVar reuseVar reaperRef (Config.observationHandler config) (Config.initSession config)   where     acqTimeoutMicros =       div (fromIntegral (diffTimeToPicoseconds (Config.acquisitionTimeout config))) 1_000_000@@ -167,7 +172,7 @@       now <- getMonotonicTimeNSec       id <- Uuid.nextRandom       poolObserver (ConnectionObservation id ConnectingConnectionStatus)-      Connection.acquire settings >>= \case+      Connection.acquire poolAdapter settings >>= \case         Left connErr -> do           let connErrText = case connErr of                 Errors.NetworkingConnectionError details -> Just details