packages feed

hasql-pool 1.3.0.3 → 1.3.0.4

raw patch · 16 files changed

+455/−231 lines, 16 filesdep +testcontainers-postgresqldep +text-builderdep +tuple

Dependencies added: testcontainers-postgresql, text-builder, tuple

Files

hasql-pool.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-pool-version: 1.3.0.3+version: 1.3.0.4 category: Hasql, Database, PostgreSQL synopsis: Pool of connections for Hasql homepage: https://github.com/nikita-volkov/hasql-pool@@ -19,7 +19,7 @@  source-repository head   type: git-  location: git://github.com/nikita-volkov/hasql-pool.git+  location: https://github.com/nikita-volkov/hasql-pool  common base-settings   default-language: Haskell2010@@ -97,9 +97,27 @@ test-suite test   import: base-settings   type: exitcode-stdio-1.0-  hs-source-dirs: src/test+  hs-source-dirs: src/integration-tests   main-is: Main.hs+  other-modules:+    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+   ghc-options: -threaded+  build-tool-depends:+    hspec-discover:hspec-discover ^>=2.11.12+   build-depends:     async >=2.2 && <3,     hasql,@@ -107,3 +125,6 @@     hspec >=2.6 && <3,     random >=1.2 && <2,     rerebase >=1.15 && <2,+    testcontainers-postgresql >=0.0.2 && <0.1,+    text-builder >=1 && <1.1,+    tuple ^>=0.3.0.2,
+ src/integration-tests/Helpers/Hooks.hs view
@@ -0,0 +1,19 @@+-- | Hooks for Hspec.+module Helpers.Hooks where++import Data.Bool+import TestcontainersPostgresql qualified+import Prelude hiding (Handler)++-- | Testing action in the scope of the host name and port of a running fresh isolated postgres server.+type Handler = (Text, Word16) -> IO ()++postgres17 :: Handler -> IO ()+postgres17 handler =+  TestcontainersPostgresql.run+    TestcontainersPostgresql.Config+      { forwardLogs = False,+        distro = TestcontainersPostgresql.Distro17,+        auth = TestcontainersPostgresql.TrustAuth+      }+    (\(host, portInt) -> handler (host, fromIntegral portInt))
+ src/integration-tests/Helpers/Scripts.hs view
@@ -0,0 +1,76 @@+module Helpers.Scripts where++import Hasql.Connection.Setting qualified as Connection.Setting+import Hasql.Connection.Setting.Connection qualified as Connection.Setting.Connection+import Hasql.Connection.Setting.Connection.Param qualified as Connection.Setting.Connection.Param+import Hasql.Pool qualified as Pool+import Hasql.Pool.Config qualified as Config+import System.Random.Stateful qualified as Random+import TextBuilder qualified+import Prelude++-- |+-- Parameters provided by the scope.+-- Host and port of a running isolated postgres server.+type ScopeParams = (Text, Word16)++onTaggedPool :: Int -> DiffTime -> DiffTime -> DiffTime -> Text -> ScopeParams -> (Pool.Pool -> IO ()) -> IO ()+onTaggedPool poolSize acqTimeout maxLifetime maxIdletime appName (host, port) =+  bracket+    ( Pool.acquire+        ( Config.settings+            [ Config.size poolSize,+              Config.acquisitionTimeout acqTimeout,+              Config.agingTimeout maxLifetime,+              Config.idlenessTimeout maxIdletime,+              Config.staticConnectionSettings+                [ Connection.Setting.connection+                    ( Connection.Setting.Connection.params+                        [ Connection.Setting.Connection.Param.host host,+                          Connection.Setting.Connection.Param.port (fromIntegral port),+                          Connection.Setting.Connection.Param.user "postgres",+                          Connection.Setting.Connection.Param.password "",+                          Connection.Setting.Connection.Param.dbname "postgres",+                          Connection.Setting.Connection.Param.other "application_name" appName+                        ]+                    )+                ]+            ]+        )+    )+    Pool.release++onAutotaggedPool :: Int -> DiffTime -> DiffTime -> DiffTime -> ScopeParams -> (Text -> Pool.Pool -> IO ()) -> IO ()+onAutotaggedPool poolSize acqTimeout maxLifetime maxIdletime (host, port) cont = do+  -- Generate app name+  appName <- generateName "hasql-pool-test-"+  onTaggedPool poolSize acqTimeout maxLifetime maxIdletime appName (host, port) (cont appName)++onDefaultTaggedPool :: ScopeParams -> (Text -> Pool.Pool -> IO ()) -> IO ()+onDefaultTaggedPool =+  onAutotaggedPool 3 10 1_800 1_800++generateName :: Text -> IO Text+generateName prefix = do+  uniqueNum1 <- Random.uniformWord64 Random.globalStdGen+  uniqueNum2 <- Random.uniformWord64 Random.globalStdGen+  pure+    $ TextBuilder.toText+    $ mconcat+    $ [ TextBuilder.text prefix,+        TextBuilder.decimal uniqueNum1,+        TextBuilder.decimal uniqueNum2+      ]++generateVarname :: IO Text+generateVarname = do+  uniqueNum1 <- Random.uniformWord64 Random.globalStdGen+  uniqueNum2 <- Random.uniformWord64 Random.globalStdGen+  pure+    $ TextBuilder.toText+    $ mconcat+    $ [ "testing.v",+        TextBuilder.decimal uniqueNum1,+        "v",+        TextBuilder.decimal uniqueNum2+      ]
+ src/integration-tests/Helpers/Sessions.hs view
@@ -0,0 +1,64 @@+module Helpers.Sessions+  ( selectOne,+    badQuery,+    closeConn,+    setSetting,+    getSetting,+    countConnections,+  )+where++import Data.Tuple.All+import Hasql.Connection qualified as Connection+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 Prelude++selectOne :: Session.Session Int64+selectOne =+  Session.statement () statement+  where+    statement = Statement.Statement "SELECT 1" Encoders.noParams decoder True+    decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))++badQuery :: Session.Session ()+badQuery =+  Session.statement () statement+  where+    statement =+      Statement.Statement "zzz" Encoders.noParams Decoders.noResult True++closeConn :: Session.Session ()+closeConn = do+  conn <- ask+  liftIO $ Connection.release conn++setSetting :: Text -> Text -> Session.Session ()+setSetting name value = do+  Session.statement (name, value) statement+  where+    statement =+      Statement.Statement "SELECT set_config($1, $2, false)" encoder Decoders.noResult True+    encoder =+      mconcat+        [ sel1 >$< Encoders.param (Encoders.nonNullable Encoders.text),+          sel2 >$< Encoders.param (Encoders.nonNullable Encoders.text)+        ]++getSetting :: Text -> Session.Session (Maybe Text)+getSetting name = do+  Session.statement name statement+  where+    statement = Statement.Statement "SELECT current_setting($1, true)" encoder decoder True+    encoder = Encoders.param (Encoders.nonNullable Encoders.text)+    decoder = Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.text))++countConnections :: Text -> Session.Session Int64+countConnections appName = do+  Session.statement appName statement+  where+    statement = Statement.Statement "SELECT count(*) FROM pg_stat_activity WHERE application_name = $1" encoder decoder True+    encoder = Encoders.param (Encoders.nonNullable Encoders.text)+    decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))
+ src/integration-tests/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ src/integration-tests/Specs/BySubject/Config/AgingTimeoutSpec.hs view
@@ -0,0 +1,32 @@+module Specs.BySubject.Config.AgingTimeoutSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Test.Hspec+import Prelude++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 view
@@ -0,0 +1,29 @@+module Specs.BySubject.Config.IdlenessTimeoutSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Test.Hspec+import Prelude++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
+ src/integration-tests/Specs/BySubject/Config/InitSessionSpec.hs view
@@ -0,0 +1,43 @@+module Specs.BySubject.Config.InitSessionSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Test.Hspec+import Prelude++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"))
+ src/integration-tests/Specs/BySubject/Helpers/Sessions/CountConnectionsSpec.hs view
@@ -0,0 +1,14 @@+module Specs.BySubject.Helpers.Sessions.CountConnectionsSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Test.Hspec+import Prelude++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 view
@@ -0,0 +1,36 @@+module Specs.BySubject.Helpers.Sessions.GetSettingSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Test.Hspec+import Prelude++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 view
@@ -0,0 +1,16 @@+module Specs.BySubject.ReleaseSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Test.Hspec+import Prelude++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 view
@@ -0,0 +1,11 @@+-- 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 Test.Hspec+import Prelude++hook :: SpecWith Scripts.ScopeParams -> Spec+hook =+  aroundAll Hooks.postgres17 . parallel
+ src/integration-tests/Specs/BySubject/UsageError/AcquisitionTimeoutSpec.hs view
@@ -0,0 +1,33 @@+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 Test.Hspec+import Prelude++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 view
@@ -0,0 +1,17 @@+module Specs.BySubject.UsageError.SessionSpec where++import Hasql.Pool+import Hasql.Session qualified as Session+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Test.Hspec+import Prelude++spec :: SpecWith Scripts.ScopeParams+spec = do+  it "Simulation of connection error works" \scopeParams ->+    Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do+      res <- use pool $ Sessions.closeConn >> Sessions.selectOne+      shouldSatisfy res $ \case+        Left (SessionUsageError (Session.QueryError _ _ (Session.ClientError _))) -> True+        _ -> False
+ src/integration-tests/Specs/BySubject/UseSpec.hs view
@@ -0,0 +1,40 @@+module Specs.BySubject.UseSpec where++import Hasql.Pool+import Helpers.Scripts qualified as Scripts+import Helpers.Sessions qualified as Sessions+import Test.Hspec+import Prelude++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 "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
− src/test/Main.hs 
@@ -1,228 +0,0 @@-module Main where--import Control.Concurrent.Async (race)-import Data.Text qualified as Text-import Hasql.Connection qualified as Connection-import Hasql.Connection.Setting qualified as Connection.Setting-import Hasql.Connection.Setting.Connection qualified as Connection.Setting.Connection-import Hasql.Decoders qualified as Decoders-import Hasql.Encoders qualified as Encoders-import Hasql.Pool-import Hasql.Pool.Config qualified as Config-import Hasql.Session qualified as Session-import Hasql.Statement qualified as Statement-import System.Environment qualified-import System.Random.Stateful qualified as Random-import Test.Hspec-import Prelude--main :: IO ()-main = do-  connectionString <- getConnectionString-  let withPool poolSize acqTimeout maxLifetime maxIdletime connectionString =-        bracket-          ( acquire-              ( Config.settings-                  [ Config.size poolSize,-                    Config.acquisitionTimeout acqTimeout,-                    Config.agingTimeout maxLifetime,-                    Config.idlenessTimeout maxIdletime,-                    Config.staticConnectionSettings-                      [ Connection.Setting.connection-                          (Connection.Setting.Connection.string connectionString)-                      ]-                  ]-              )-          )-          release-      withDefaultPool =-        withPool 3 10 1_800 1_800 connectionString--  hspec . describe "" $ do-    it "Releases a spot in the pool when there is a query error" $ withDefaultPool $ \pool -> do-      use pool badQuerySession `shouldNotReturn` (Right ())-      use pool selectOneSession `shouldReturn` (Right 1)-    it "Simulation of connection error works" $ withDefaultPool $ \pool -> do-      res <- use pool $ closeConnSession >> selectOneSession-      shouldSatisfy res $ \case-        Left (SessionUsageError (Session.QueryError _ _ (Session.ClientError _))) -> True-        _ -> False-    it "Connection errors cause eviction of connection" $ withDefaultPool $ \pool -> do-      _ <- use pool $ closeConnSession >> selectOneSession-      _ <- use pool $ closeConnSession >> selectOneSession-      _ <- use pool $ closeConnSession >> selectOneSession-      res <- use pool $ selectOneSession-      shouldSatisfy res $ isRight-    it "Connection gets returned to the pool after normal use" $ withDefaultPool $ \pool -> do-      _ <- use pool $ selectOneSession-      _ <- use pool $ selectOneSession-      _ <- use pool $ selectOneSession-      _ <- use pool $ selectOneSession-      res <- use pool $ selectOneSession-      shouldSatisfy res $ isRight-    it "Connection gets returned to the pool after non-connection error" $ withDefaultPool $ \pool -> do-      _ <- use pool $ badQuerySession-      _ <- use pool $ badQuerySession-      _ <- use pool $ badQuerySession-      _ <- use pool $ badQuerySession-      res <- use pool $ selectOneSession-      shouldSatisfy res $ isRight-    it "The pool remains usable after release" $ withDefaultPool $ \pool -> do-      _ <- use pool $ selectOneSession-      release pool-      res <- use pool $ selectOneSession-      shouldSatisfy res $ isRight-    it "Getting and setting session variables works" $ withDefaultPool $ \pool -> do-      res <- use pool $ getSettingSession "testing.foo"-      res `shouldBe` Right Nothing-      res <- use pool $ do-        setSettingSession "testing.foo" "hello world"-        getSettingSession "testing.foo"-      res `shouldBe` Right (Just "hello world")-    it "Session variables stay set when a connection gets reused" $ withPool 1 10 1_800 1_800 connectionString $ \pool -> do-      res <- use pool $ setSettingSession "testing.foo" "hello world"-      res `shouldBe` Right ()-      res2 <- use pool $ getSettingSession "testing.foo"-      res2 `shouldBe` Right (Just "hello world")-    it "Releasing the pool resets session variables" $ withPool 1 10 1_800 1_800 connectionString $ \pool -> do-      res <- use pool $ setSettingSession "testing.foo" "hello world"-      res `shouldBe` Right ()-      release pool-      res <- use pool $ getSettingSession "testing.foo"-      res `shouldBe` Right Nothing-    it "Times out connection acquisition"-      $-      -- 1ms timeout-      withPool 1 0.001 1_800 1_800 connectionString-      $ \pool -> do-        sleeping <- newEmptyMVar-        t0 <- getCurrentTime-        res <--          race-            ( use pool-                $ liftIO-                $ do-                  putMVar sleeping ()-                  threadDelay 1_000_000 -- 1s-            )-            ( do-                takeMVar sleeping-                use pool $ selectOneSession-            )-        t1 <- getCurrentTime-        res `shouldBe` Right (Left AcquisitionTimeoutUsageError)-        diffUTCTime t1 t0 `shouldSatisfy` (< 0.5) -- 0.5s-    it "Passively times out old connections (maxLifetime)"-      $-      -- 0.5s connection lifetime-      withPool 1 10 0.5 1_800 connectionString-      $ \pool -> do-        res <- use pool $ setSettingSession "testing.foo" "hello world"-        res `shouldBe` Right ()-        res2 <- use pool $ getSettingSession "testing.foo"-        res2 `shouldBe` Right (Just "hello world")-        threadDelay 1_000_000 -- 1s-        res3 <- use pool $ getSettingSession "testing.foo"-        res3 `shouldBe` Right Nothing-    it "Counts active connections" $ do-      (taggedConnectionSettings, appName) <- tagConnection connectionString-      withPool 3 10 1_800 1_800 taggedConnectionSettings $ \pool -> do-        res <- use pool $ countConnectionsSession appName-        res `shouldBe` Right 1--    it "Actively times out old connections (maxLifetime)" $ do-      withDefaultPool $ \countPool -> do-        (taggedConnectionSettings, appName) <- tagConnection connectionString-        withPool 3 10 0.5 1_800 taggedConnectionSettings $ \limitedPool -> do-          res <- use limitedPool $ selectOneSession-          res `shouldBe` Right 1-          res2 <- use countPool $ countConnectionsSession appName-          res2 `shouldBe` Right 1-          threadDelay 1_000_000 -- 1s-          res3 <- use countPool $ countConnectionsSession appName-          res3 `shouldBe` Right 0-    it "Times out old connections (maxIdletime)" $ do-      -- 0.5s connection idle time-      withPool 1 10 1_800 0.5 connectionString $ \pool -> do-        res <- use pool $ setSettingSession "testing.foo" "hello world"-        res `shouldBe` Right ()-        res2 <- use pool $ getSettingSession "testing.foo"-        res2 `shouldBe` Right (Just "hello world")-        -- busy sleep, to keep connection alive-        forM_ [1 :: Int .. 10] $ \_ -> do-          r <- use pool $ selectOneSession-          r `shouldBe` Right 1-          threadDelay 100_000 -- 0.1s-        res3 <- use pool $ getSettingSession "testing.foo"-        res3 `shouldBe` Right (Just "hello world")-        -- idle sleep, connection times out-        threadDelay 1_000_000 -- 1s-        res4 <- use pool $ getSettingSession "testing.foo"-        res4 `shouldBe` Right Nothing--getConnectionString :: IO Text-getConnectionString =-  Text.unwords-    . catMaybes-    <$> sequence-      [ setting "host" $ defaultEnv "POSTGRES_HOST" "localhost",-        setting "port" $ defaultEnv "POSTGRES_PORT" "5432",-        setting "user" $ defaultEnv "POSTGRES_USER" "postgres",-        setting "password" $ defaultEnv "POSTGRES_PASSWORD" "postgres",-        setting "dbname" $ defaultEnv "POSTGRES_DBNAME" "postgres"-      ]-  where-    maybeEnv env = fmap Text.pack <$> System.Environment.lookupEnv env-    defaultEnv env val = Just . fromMaybe val <$> maybeEnv env-    setting label getEnv = do-      val <- getEnv-      return $ (\v -> label <> "=" <> v) <$> val--tagConnection :: Text -> IO (Text, Text)-tagConnection connectionString = do-  tag <- Random.uniformWord32 Random.globalStdGen-  let appName = "hasql-pool-test-" <> show tag-  return (connectionString <> " application_name=" <> Text.pack appName, Text.pack appName)--selectOneSession :: Session.Session Int64-selectOneSession =-  Session.statement () statement-  where-    statement = Statement.Statement "SELECT 1" Encoders.noParams decoder True-    decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))--badQuerySession :: Session.Session ()-badQuerySession =-  Session.statement () statement-  where-    statement = Statement.Statement "zzz" Encoders.noParams Decoders.noResult True--closeConnSession :: Session.Session ()-closeConnSession = do-  conn <- ask-  liftIO $ Connection.release conn--setSettingSession :: Text -> Text -> Session.Session ()-setSettingSession name value = do-  Session.statement (name, value) statement-  where-    statement = Statement.Statement "SELECT set_config($1, $2, false)" encoder Decoders.noResult True-    encoder =-      contramap fst (Encoders.param (Encoders.nonNullable Encoders.text))-        <> contramap snd (Encoders.param (Encoders.nonNullable Encoders.text))--getSettingSession :: Text -> Session.Session (Maybe Text)-getSettingSession name = do-  Session.statement name statement-  where-    statement = Statement.Statement "SELECT current_setting($1, true)" encoder decoder True-    encoder = Encoders.param (Encoders.nonNullable Encoders.text)-    decoder = Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.text))--countConnectionsSession :: Text -> Session.Session Int64-countConnectionsSession appName = do-  Session.statement appName statement-  where-    statement = Statement.Statement "SELECT count(*) FROM pg_stat_activity WHERE application_name = $1" encoder decoder True-    encoder = Encoders.param (Encoders.nonNullable Encoders.text)-    decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8))