hasql-pool 0.10.1 → 1

raw patch · 12 files changed

+768/−554 lines, 12 filesdep +bytestringdep +textdep +uuidPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring, text, uuid

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• hasql-pool.cabal +51/−35
• library/Hasql/Pool.hs +0/−235
• library/Hasql/Pool/Prelude.hs +0/−72
• src/library/exposed/Hasql/Pool.hs +234/−0
• src/library/exposed/Hasql/Pool/Config.hs +24/−0
• src/library/exposed/Hasql/Pool/Observation.hs +46/−0
• src/library/other/Hasql/Pool/Config/Config.hs +27/−0
• src/library/other/Hasql/Pool/Config/Setting.hs +82/−0
• src/library/other/Hasql/Pool/Prelude.hs +75/−0
• src/test/Main.hs +224/−0
• test/Main.hs +0/−212

@@ -1,3 +1,8 @@+# 1++- 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  - Avoid releasing connections on exceptions thrown in session

@@ -1,25 +1,23 @@-cabal-version:      3.0-name:               hasql-pool-version:            0.10.1-category:           Hasql, Database, PostgreSQL-synopsis:           Pool of connections for Hasql-homepage:           https://github.com/nikita-volkov/hasql-pool-bug-reports:        https://github.com/nikita-volkov/hasql-pool/issues-author:             Nikita Volkov <nikita.y.volkov@mail.ru>-maintainer:         Nikita Volkov <nikita.y.volkov@mail.ru>-copyright:          (c) 2015, Nikita Volkov-license:            MIT-license-file:       LICENSE+cabal-version: 3.0+name: hasql-pool+version: 1+category: Hasql, Database, PostgreSQL+synopsis: Pool of connections for Hasql+homepage: https://github.com/nikita-volkov/hasql-pool+bug-reports: https://github.com/nikita-volkov/hasql-pool/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2015, Nikita Volkov+license: MIT+license-file: LICENSE extra-source-files: CHANGELOG.md  source-repository head-  type:     git+  type: git   location: git://github.com/nikita-volkov/hasql-pool.git  common base-settings   default-extensions:-    NoImplicitPrelude-    NoMonomorphismRestriction     BangPatterns     BlockArguments     ConstraintKinds@@ -59,30 +57,48 @@     TypeFamilies     TypeOperators     UnboxedTuples+    NoImplicitPrelude+    NoMonomorphismRestriction -  default-language:   Haskell2010+  default-language: Haskell2010  library-  import:          base-settings-  hs-source-dirs:  library-  exposed-modules: Hasql.Pool-  other-modules:   Hasql.Pool.Prelude+  import: base-settings+  hs-source-dirs:+    src/library/exposed+    src/library/other++  -- cabal-gild: discover src/library/exposed+  exposed-modules:+    Hasql.Pool+    Hasql.Pool.Config+    Hasql.Pool.Observation++  -- cabal-gild: discover src/library/other+  other-modules:+    Hasql.Pool.Config.Config+    Hasql.Pool.Config.Setting+    Hasql.Pool.Prelude+   build-depends:-    , base >=4.11 && <5-    , hasql >=1.6.0.1 && <1.7-    , stm >=2.5 && <3-    , time >=1.9 && <2+    base >=4.11 && <5,+    bytestring >=0.10 && <0.14,+    hasql >=1.6.0.1 && <1.7,+    stm >=2.5 && <3,+    text >=1.2 && <3,+    time >=1.9 && <2,+    uuid >=1.3 && <2,  test-suite test-  import:         base-settings-  type:           exitcode-stdio-1.0-  hs-source-dirs: test-  main-is:        Main.hs-  ghc-options:    -threaded+  import: base-settings+  type: exitcode-stdio-1.0+  hs-source-dirs: src/test+  main-is: Main.hs+  ghc-options: -threaded   build-depends:-    , async >=2.2 && <3-    , hasql-    , hasql-pool-    , hspec >=2.6 && <3-    , random >=1.2 && <2-    , rerebase >=1.15 && <2+    async >=2.2 && <3,+    hasql,+    hasql-pool,+    hspec >=2.6 && <3,+    random >=1.2 && <2,+    rerebase >=1.15 && <2,

@@ -1,235 +0,0 @@-module Hasql.Pool-  ( -- * Pool-    Pool,-    acquire,-    acquireDynamically,-    use,-    release,--    -- * Errors-    UsageError (..),-  )-where--import Hasql.Connection (Connection)-import qualified Hasql.Connection as Connection-import Hasql.Pool.Prelude-import qualified Hasql.Session as Session---- | A connection tagged with metadata.-data Entry = Entry-  { entryConnection :: Connection,-    entryCreationTimeNSec :: Word64,-    entryUseTimeNSec :: Word64-  }--entryIsAlive :: Word64 -> Word64 -> Word64 -> Entry -> Bool-entryIsAlive maxLifetime maxIdletime now Entry {..} =-  now-    <= entryCreationTimeNSec-    + maxLifetime-    && now-    <= entryUseTimeNSec-    + maxIdletime---- | Pool of connections to DB.-data Pool = Pool-  { -- | Pool size.-    poolSize :: Int,-    -- | Connection settings.-    poolFetchConnectionSettings :: IO Connection.Settings,-    -- | Acquisition timeout, in microseconds.-    poolAcquisitionTimeout :: Int,-    -- | Maximal connection lifetime, in nanoseconds.-    poolMaxLifetime :: Word64,-    -- | Maximal connection idle time, in nanoseconds.-    poolMaxIdletime :: Word64,-    -- | Avail connections.-    poolConnectionQueue :: TQueue Entry,-    -- | Remaining capacity.-    -- The pool size limits the sum of poolCapacity, the length-    -- of poolConnectionQueue and the number of in-flight-    -- connections.-    poolCapacity :: TVar Int,-    -- | Whether to return a connection to the pool.-    poolReuseVar :: TVar (TVar Bool),-    -- | To stop the manager thread via garbage collection.-    poolReaperRef :: IORef ()-  }---- | Create a connection-pool, with default settings.------ No connections actually get established by this function. It is delegated--- to 'use'.-acquire ::-  -- | Pool size.-  Int ->-  -- | Connection acquisition timeout.-  DiffTime ->-  -- | Maximal connection lifetime.-  DiffTime ->-  -- | Maximal connection idle time.-  DiffTime ->-  -- | Connection settings.-  Connection.Settings ->-  IO Pool-acquire poolSize acqTimeout maxLifetime maxIdletime connectionSettings =-  acquireDynamically poolSize acqTimeout maxLifetime maxIdletime (pure connectionSettings)---- | Create a connection-pool.------ In difference to 'acquire' new connection settings get fetched each--- time a connection is created. This may be useful for some security models.------ No connections actually get established by this function. It is delegated--- to 'use'.-acquireDynamically ::-  -- | Pool size.-  Int ->-  -- | Connection acquisition timeout.-  DiffTime ->-  -- | Maximal connection lifetime.-  DiffTime ->-  -- | Maximal connection idle time.-  DiffTime ->-  -- | Action fetching connection settings.-  IO Connection.Settings ->-  IO Pool-acquireDynamically poolSize acqTimeout maxLifetime maxIdletime fetchConnectionSettings = do-  connectionQueue <- newTQueueIO-  capVar <- newTVarIO poolSize-  reuseVar <- newTVarIO =<< newTVarIO True-  reaperRef <- newIORef ()--  managerTid <- forkIOWithUnmask $ \unmask -> unmask $ forever $ do-    threadDelay 1000000-    now <- getMonotonicTimeNSec-    join . atomically $ do-      entries <- flushTQueue connectionQueue-      let (keep, close) = partition (entryIsAlive maxLifetimeNanos maxIdletimeNanos now) entries-      traverse_ (writeTQueue connectionQueue) keep-      return $ forM_ close $ \entry -> do-        Connection.release (entryConnection entry)-        atomically $ modifyTVar' capVar succ--  void . mkWeakIORef reaperRef $ do-    -- When the pool goes out of scope, stop the manager.-    killThread managerTid--  return $ Pool poolSize fetchConnectionSettings acqTimeoutMicros maxLifetimeNanos maxIdletimeNanos connectionQueue capVar reuseVar reaperRef-  where-    acqTimeoutMicros =-      div (fromIntegral (diffTimeToPicoseconds acqTimeout)) 1_000_000-    maxLifetimeNanos =-      div (fromIntegral (diffTimeToPicoseconds maxLifetime)) 1_000-    maxIdletimeNanos =-      div (fromIntegral (diffTimeToPicoseconds maxIdletime)) 1_000---- | Release all the idle connections in the pool, and mark the in-use connections--- to be released after use. Any connections acquired after the call will be--- freshly established.------ The pool remains usable after this action.--- So you can use this function to reset the connections in the pool.--- Naturally, you can also use it to release the resources.-release :: Pool -> IO ()-release Pool {..} =-  join . atomically $ do-    prevReuse <- readTVar poolReuseVar-    writeTVar prevReuse False-    newReuse <- newTVar True-    writeTVar poolReuseVar newReuse-    entries <- flushTQueue poolConnectionQueue-    return $ forM_ entries $ \entry -> do-      Connection.release (entryConnection entry)-      atomically $ modifyTVar' poolCapacity succ---- | Use a connection from the pool to run a session and return the connection--- to the pool, when finished.------ Session failing with a 'Session.ClientError' gets interpreted as a loss of--- connection. In such case the connection does not get returned to the pool--- and a slot gets freed up for a new connection to be established the next--- time one is needed. The error still gets returned from this function.------ __Warning:__ Due to the mechanism mentioned above you should avoid consuming--- errors within sessions.-use :: Pool -> Session.Session a -> IO (Either UsageError a)-use Pool {..} sess = do-  timeout <- do-    delay <- registerDelay poolAcquisitionTimeout-    return $ readTVar delay-  join . atomically $ do-    reuseVar <- readTVar poolReuseVar-    asum-      [ readTQueue poolConnectionQueue <&> onConn reuseVar,-        do-          capVal <- readTVar poolCapacity-          if capVal > 0-            then do-              writeTVar poolCapacity $! pred capVal-              return $ onNewConn reuseVar-            else retry,-        do-          timedOut <- timeout-          if timedOut-            then return . return . Left $ AcquisitionTimeoutUsageError-            else retry-      ]-  where-    onNewConn reuseVar = do-      settings <- poolFetchConnectionSettings-      now <- getMonotonicTimeNSec-      connRes <- Connection.acquire settings-      case connRes of-        Left connErr -> do-          atomically $ modifyTVar' poolCapacity succ-          return $ Left $ ConnectionUsageError connErr-        Right entry -> onLiveConn reuseVar (Entry entry now now)--    onConn reuseVar entry = do-      now <- getMonotonicTimeNSec-      if entryIsAlive poolMaxLifetime poolMaxIdletime now entry-        then onLiveConn reuseVar entry {entryUseTimeNSec = now}-        else do-          Connection.release (entryConnection entry)-          onNewConn reuseVar--    onLiveConn reuseVar entry = do-      sessRes <- try @SomeException (Session.run sess (entryConnection entry))--      case sessRes of-        Left exc -> do-          returnConn-          throwIO exc-        Right (Left err) -> case err of-          Session.QueryError _ _ (Session.ClientError _) -> do-            atomically $ modifyTVar' poolCapacity succ-            return $ Left $ SessionUsageError err-          _ -> do-            returnConn-            return $ Left $ SessionUsageError err-        Right (Right res) -> do-          returnConn-          return $ Right res-      where-        returnConn =-          join . atomically $ do-            reuse <- readTVar reuseVar-            if reuse-              then writeTQueue poolConnectionQueue entry $> return ()-              else return $ do-                Connection.release (entryConnection entry)-                atomically $ modifyTVar' poolCapacity succ---- | Union over all errors that 'use' can result in.-data UsageError-  = -- | Attempt to establish a connection failed.-    ConnectionUsageError Connection.ConnectionError-  | -- | Session execution failed.-    SessionUsageError Session.QueryError-  | -- | Timeout acquiring a connection.-    AcquisitionTimeoutUsageError-  deriving (Show, Eq)--instance Exception UsageError

@@ -1,72 +0,0 @@-module Hasql.Pool.Prelude-  ( module Exports,-  )-where--import Control.Applicative as Exports hiding (WrappedArrow (..))-import Control.Arrow as Exports hiding (first, second)-import Control.Category as Exports-import Control.Concurrent as Exports-import Control.Concurrent.STM as Exports hiding (orElse)-import Control.Exception as Exports-import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)-import Control.Monad.Fail as Exports-import Control.Monad.Fix as Exports hiding (fix)-import Control.Monad.IO.Class as Exports-import Control.Monad.ST as Exports-import Data.Bifunctor as Exports-import Data.Bits as Exports-import Data.Bool as Exports-import Data.Char as Exports-import Data.Coerce as Exports-import Data.Complex as Exports-import Data.Data as Exports-import Data.Dynamic as Exports-import Data.Either as Exports-import Data.Fixed as Exports-import Data.Foldable as Exports hiding (toList)-import Data.Function as Exports hiding (id, (.))-import Data.Functor as Exports hiding (unzip)-import Data.Functor.Compose as Exports-import Data.IORef as Exports-import Data.Int as Exports-import Data.Ix as Exports-import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)-import Data.List.NonEmpty as Exports (NonEmpty (..))-import Data.Maybe as Exports-import Data.Monoid as Exports hiding (Alt)-import Data.Ord as Exports-import Data.Proxy as Exports-import Data.Ratio as Exports-import Data.STRef as Exports-import Data.String as Exports-import Data.Time as Exports-import Data.Traversable as Exports-import Data.Tuple as Exports-import Data.Unique as Exports-import Data.Version as Exports-import Data.Void as Exports-import Data.Word as Exports-import Debug.Trace as Exports-import Foreign.ForeignPtr as Exports-import Foreign.Ptr as Exports-import Foreign.StablePtr as Exports-import Foreign.Storable as Exports-import GHC.Clock as Exports (getMonotonicTimeNSec)-import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)-import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith)-import GHC.Generics as Exports (Generic)-import GHC.IO.Exception as Exports-import Numeric as Exports-import System.Environment as Exports-import System.Exit as Exports-import System.IO as Exports (Handle, hClose)-import System.IO.Error as Exports-import System.IO.Unsafe as Exports-import System.Mem as Exports-import System.Mem.StableName as Exports-import System.Timeout as Exports-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, (.))

@@ -0,0 +1,234 @@+module Hasql.Pool+  ( -- * Pool+    Pool,+    acquire,+    use,+    release,++    -- * Errors+    UsageError (..),+  )+where++import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text+import qualified Data.UUID.V4 as Uuid+import Hasql.Connection (Connection)+import qualified Hasql.Connection as Connection+import qualified Hasql.Pool.Config.Config as Config+import Hasql.Pool.Observation+import Hasql.Pool.Prelude+import qualified Hasql.Session as Session++-- | A connection tagged with metadata.+data Entry = Entry+  { entryConnection :: Connection,+    entryCreationTimeNSec :: Word64,+    entryUseTimeNSec :: Word64,+    entryId :: UUID+  }++entryIsAged :: Word64 -> Word64 -> Entry -> Bool+entryIsAged maxLifetime now Entry {..} =+  now > entryCreationTimeNSec + maxLifetime++entryIsIdle :: Word64 -> Word64 -> Entry -> Bool+entryIsIdle maxIdletime now Entry {..} =+  now > entryUseTimeNSec + maxIdletime++-- | Pool of connections to DB.+data Pool = Pool+  { -- | Pool size.+    poolSize :: Int,+    -- | Connection settings.+    poolFetchConnectionSettings :: IO Connection.Settings,+    -- | Acquisition timeout, in microseconds.+    poolAcquisitionTimeout :: Int,+    -- | Maximal connection lifetime, in nanoseconds.+    poolMaxLifetime :: Word64,+    -- | Maximal connection idle time, in nanoseconds.+    poolMaxIdletime :: Word64,+    -- | Avail connections.+    poolConnectionQueue :: TQueue Entry,+    -- | Remaining capacity.+    -- The pool size limits the sum of poolCapacity, the length+    -- of poolConnectionQueue and the number of in-flight+    -- connections.+    poolCapacity :: TVar Int,+    -- | Whether to return a connection to the pool.+    poolReuseVar :: TVar (TVar Bool),+    -- | To stop the manager thread via garbage collection.+    poolReaperRef :: IORef (),+    -- | Action for reporting the observations.+    poolObserver :: Observation -> IO ()+  }++-- | Create a connection-pool.+--+-- No connections actually get established by this function. It is delegated+-- to 'use'.+acquire :: Config.Config -> IO Pool+acquire config = do+  connectionQueue <- newTQueueIO+  capVar <- newTVarIO (Config.size config)+  reuseVar <- newTVarIO =<< newTVarIO True+  reaperRef <- newIORef ()++  managerTid <- forkIOWithUnmask $ \unmask -> unmask $ forever $ do+    threadDelay 1000000+    now <- getMonotonicTimeNSec+    join . atomically $ do+      entries <- flushTQueue connectionQueue+      let (agedEntries, unagedEntries) = partition (entryIsAged agingTimeoutNanos now) entries+          (idleEntries, liveEntries) = partition (entryIsIdle agingTimeoutNanos now) unagedEntries+      traverse_ (writeTQueue connectionQueue) liveEntries+      return $ do+        forM_ agedEntries $ \entry -> do+          Connection.release (entryConnection entry)+          atomically $ modifyTVar' capVar succ+          (Config.observationHandler config) (ConnectionObservation (entryId entry) (TerminatedConnectionStatus AgingConnectionTerminationReason))+        forM_ idleEntries $ \entry -> do+          Connection.release (entryConnection entry)+          atomically $ modifyTVar' capVar succ+          (Config.observationHandler config) (ConnectionObservation (entryId entry) (TerminatedConnectionStatus IdlenessConnectionTerminationReason))++  void . mkWeakIORef reaperRef $ do+    -- 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)+  where+    acqTimeoutMicros =+      div (fromIntegral (diffTimeToPicoseconds (Config.acquisitionTimeout config))) 1_000_000+    agingTimeoutNanos =+      div (fromIntegral (diffTimeToPicoseconds (Config.agingTimeout config))) 1_000+    maxIdletimeNanos =+      div (fromIntegral (diffTimeToPicoseconds (Config.idlenessTimeout config))) 1_000++-- | Release all the idle connections in the pool, and mark the in-use connections+-- to be released after use. Any connections acquired after the call will be+-- freshly established.+--+-- The pool remains usable after this action.+-- So you can use this function to reset the connections in the pool.+-- Naturally, you can also use it to release the resources.+release :: Pool -> IO ()+release Pool {..} =+  join . atomically $ do+    prevReuse <- readTVar poolReuseVar+    writeTVar prevReuse False+    newReuse <- newTVar True+    writeTVar poolReuseVar newReuse+    entries <- flushTQueue poolConnectionQueue+    return $ forM_ entries $ \entry -> do+      Connection.release (entryConnection entry)+      atomically $ modifyTVar' poolCapacity succ+      poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus ReleaseConnectionTerminationReason))++-- | Use a connection from the pool to run a session and return the connection+-- to the pool, when finished.+--+-- Session failing with a 'Session.ClientError' gets interpreted as a loss of+-- connection. In such case the connection does not get returned to the pool+-- and a slot gets freed up for a new connection to be established the next+-- time one is needed. The error still gets returned from this function.+--+-- __Warning:__ Due to the mechanism mentioned above you should avoid intercepting this error type from within sessions.+use :: Pool -> Session.Session a -> IO (Either UsageError a)+use Pool {..} sess = do+  timeout <- do+    delay <- registerDelay poolAcquisitionTimeout+    return $ readTVar delay+  join . atomically $ do+    reuseVar <- readTVar poolReuseVar+    asum+      [ readTQueue poolConnectionQueue <&> onConn reuseVar,+        do+          capVal <- readTVar poolCapacity+          if capVal > 0+            then do+              writeTVar poolCapacity $! pred capVal+              return $ onNewConn reuseVar+            else retry,+        do+          timedOut <- timeout+          if timedOut+            then return . return . Left $ AcquisitionTimeoutUsageError+            else retry+      ]+  where+    onNewConn reuseVar = do+      settings <- poolFetchConnectionSettings+      now <- getMonotonicTimeNSec+      id <- Uuid.nextRandom+      poolObserver (ConnectionObservation id ConnectingConnectionStatus)+      connRes <- Connection.acquire settings+      case connRes of+        Left connErr -> do+          poolObserver (ConnectionObservation id (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (fmap (Text.decodeUtf8With Text.lenientDecode) connErr))))+          atomically $ modifyTVar' poolCapacity succ+          return $ Left $ ConnectionUsageError connErr+        Right entry -> do+          poolObserver (ConnectionObservation id ReadyForUseConnectionStatus)+          onLiveConn reuseVar (Entry entry now now id)++    onConn reuseVar entry = do+      now <- getMonotonicTimeNSec+      if entryIsAged poolMaxLifetime now entry+        then do+          Connection.release (entryConnection entry)+          poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus AgingConnectionTerminationReason))+          onNewConn reuseVar+        else+          if entryIsIdle poolMaxIdletime now entry+            then do+              Connection.release (entryConnection entry)+              poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus IdlenessConnectionTerminationReason))+              onNewConn reuseVar+            else do+              onLiveConn reuseVar entry {entryUseTimeNSec = now}++    onLiveConn reuseVar entry = do+      poolObserver (ConnectionObservation (entryId entry) InUseConnectionStatus)+      sessRes <- try @SomeException (Session.run sess (entryConnection entry))++      case sessRes of+        Left exc -> do+          returnConn+          throwIO exc+        Right (Left err) -> case err of+          Session.QueryError _ _ (Session.ClientError details) -> do+            Connection.release (entryConnection entry)+            atomically $ modifyTVar' poolCapacity succ+            poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (fmap (Text.decodeUtf8With Text.lenientDecode) details))))+            return $ Left $ SessionUsageError err+          _ -> do+            returnConn+            poolObserver (ConnectionObservation (entryId entry) ReadyForUseConnectionStatus)+            return $ Left $ SessionUsageError err+        Right (Right res) -> do+          returnConn+          poolObserver (ConnectionObservation (entryId entry) ReadyForUseConnectionStatus)+          return $ Right res+      where+        returnConn =+          join . atomically $ do+            reuse <- readTVar reuseVar+            if reuse+              then writeTQueue poolConnectionQueue entry $> return ()+              else return $ do+                Connection.release (entryConnection entry)+                atomically $ modifyTVar' poolCapacity succ+                poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus ReleaseConnectionTerminationReason))++-- | Union over all errors that 'use' can result in.+data UsageError+  = -- | Attempt to establish a connection failed.+    ConnectionUsageError Connection.ConnectionError+  | -- | Session execution failed.+    SessionUsageError Session.QueryError+  | -- | Timeout acquiring a connection.+    AcquisitionTimeoutUsageError+  deriving (Show, Eq)++instance Exception UsageError

@@ -0,0 +1,24 @@+-- | DSL for construction of configs.+module Hasql.Pool.Config+  ( Config.Config,+    settings,+    Setting.Setting,+    Setting.size,+    Setting.acquisitionTimeout,+    Setting.agingTimeout,+    Setting.idlenessTimeout,+    Setting.staticConnectionSettings,+    Setting.dynamicConnectionSettings,+    Setting.observationHandler,+  )+where++import qualified Hasql.Pool.Config.Config as Config+import qualified Hasql.Pool.Config.Setting as Setting+import Hasql.Pool.Prelude++-- | Compile config from a list of settings.+-- Latter settings override the preceding in cases of conflicts.+settings :: [Setting.Setting] -> Config.Config+settings =+  foldr ($) Config.defaults . fmap Setting.apply

@@ -0,0 +1,46 @@+-- | Interface for processing observations of the status of the pool.+--+-- Provides a flexible mechanism for monitoring the healthiness of the pool via logs and metrics without any opinionated choices on the actual monitoring technologies.+-- Specific interpreters are encouraged to be created as extension libraries.+module Hasql.Pool.Observation where++import Hasql.Pool.Prelude++-- | An observation of a change of the state of a pool.+data Observation+  = -- | Status of one of the pool's connections has changed.+    ConnectionObservation+      -- | Generated connection ID.+      -- For grouping the observations by one connection.+      UUID+      -- | Status that the connection has entered.+      ConnectionStatus+  deriving (Show, Eq)++-- | Status of a connection.+data ConnectionStatus+  = -- | Connection is being established.+    --+    -- This is the initial status of every connection.+    ConnectingConnectionStatus+  | -- | Connection is established and not occupied.+    ReadyForUseConnectionStatus+  | -- | Is being used by some session.+    --+    -- After it's done the status will transition to 'ReadyForUseConnectionStatus' or 'TerminatedConnectionStatus'.+    InUseConnectionStatus+  | -- | Connection terminated.+    TerminatedConnectionStatus ConnectionTerminationReason+  deriving (Show, Eq)++-- | Explanation of why a connection was terminated.+data ConnectionTerminationReason+  = -- | The age timeout of the connection has passed.+    AgingConnectionTerminationReason+  | -- | The timeout of how long a connection may remain idle in the pool has passed.+    IdlenessConnectionTerminationReason+  | -- | Connectivity issues with the server.+    NetworkErrorConnectionTerminationReason (Maybe Text)+  | -- | User has invoked the 'Hasql.Pool.release' procedure.+    ReleaseConnectionTerminationReason+  deriving (Show, Eq)

@@ -0,0 +1,27 @@+module Hasql.Pool.Config.Config where++import qualified Hasql.Connection as Connection+import Hasql.Pool.Observation (Observation)+import Hasql.Pool.Prelude++-- | Configufation for Hasql connection pool.+data Config = Config+  { size :: Int,+    acquisitionTimeout :: DiffTime,+    agingTimeout :: DiffTime,+    idlenessTimeout :: DiffTime,+    connectionSettingsProvider :: IO Connection.Settings,+    observationHandler :: Observation -> IO ()+  }++-- | Reasonable defaults, which can be built upon.+defaults :: Config+defaults =+  Config+    { size = 3,+      acquisitionTimeout = 10,+      agingTimeout = 60 * 60 * 24,+      idlenessTimeout = 60 * 10,+      connectionSettingsProvider = pure "postgresql://postgres:postgres@localhost:5432/postgres",+      observationHandler = const (pure ())+    }

@@ -0,0 +1,82 @@+module Hasql.Pool.Config.Setting where++import qualified Hasql.Connection as Connection+import Hasql.Pool.Config.Config (Config)+import qualified Hasql.Pool.Config.Config as Config+import Hasql.Pool.Observation (Observation)+import Hasql.Pool.Prelude++apply :: Setting -> Config -> Config+apply (Setting run) = run++-- | A single setting of a config.+newtype Setting+  = Setting (Config -> Config)++-- | Pool size.+--+-- 3 by default.+size :: Int -> Setting+size x =+  Setting (\config -> config {Config.size = x})++-- | Connection acquisition timeout.+--+-- 10 seconds by default.+acquisitionTimeout :: DiffTime -> Setting+acquisitionTimeout x =+  Setting (\config -> config {Config.acquisitionTimeout = x})++-- | Maximal connection lifetime.+--+-- Determines how long is available for reuse.+-- After the timeout passes and an active session is finished the connection will be closed releasing a slot in the pool for a fresh connection to be established.+--+-- This is useful as a healthy measure for resetting the server-side caches.+--+-- 1 day by default.+agingTimeout :: DiffTime -> Setting+agingTimeout x =+  Setting (\config -> config {Config.agingTimeout = x})++-- | Maximal connection idle time.+--+-- How long to keep a connection open when it's not being used.+--+-- 10 minutes by default.+idlenessTimeout :: DiffTime -> Setting+idlenessTimeout x =+  Setting (\config -> config {Config.idlenessTimeout = x})++-- | Connection string.+--+-- You can use 'Hasql.Connection.settings' to construct it.+--+-- @\"postgresql://postgres:postgres@localhost:5432/postgres\"@ by default.+staticConnectionSettings :: Connection.Settings -> Setting+staticConnectionSettings x =+  Setting (\config -> config {Config.connectionSettingsProvider = pure x})++-- | Action providing connection settings.+--+-- Gets used each time a connection gets established by the pool.+-- This may be useful for some authorization models.+--+-- You can use 'Hasql.Connection.settings' to construct it.+--+-- @pure \"postgresql://postgres:postgres@localhost:5432/postgres\"@ by default.+dynamicConnectionSettings :: IO Connection.Settings -> Setting+dynamicConnectionSettings x =+  Setting (\config -> config {Config.connectionSettingsProvider = x})++-- | Observation handler.+--+-- Typically it's used for monitoring the state of the pool via metrics and logging.+--+-- If the provided action is not lightweight, it's recommended to use intermediate bufferring via channels like TBQueue to avoid occupying the pool management thread for too long.+-- E.g., if the action is @'atomically' . 'writeTBQueue' yourQueue@, then reading from it and processing can be done on a separate thread.+--+-- @const (pure ())@ by default.+observationHandler :: (Observation -> IO ()) -> Setting+observationHandler x =+  Setting (\config -> config {Config.observationHandler = x})

@@ -0,0 +1,75 @@+module Hasql.Pool.Prelude+  ( module Exports,+  )+where++import Control.Applicative as Exports hiding (WrappedArrow (..))+import Control.Arrow as Exports hiding (first, second)+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Concurrent.STM as Exports hiding (orElse)+import Control.Exception as Exports+import Control.Monad as Exports hiding (fail, forM, forM_, mapM, mapM_, msum, sequence, sequence_)+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.IO.Class as Exports+import Control.Monad.ST as Exports+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.ByteString as Exports (ByteString)+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports hiding (unzip)+import Data.Functor.Compose as Exports+import Data.IORef as Exports+import Data.Int as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (all, and, any, concat, concatMap, elem, find, foldl, foldl', foldl1, foldr, foldr1, isSubsequenceOf, mapAccumL, mapAccumR, maximum, maximumBy, minimum, minimumBy, notElem, or, product, sortOn, sum, uncons)+import Data.List.NonEmpty as Exports (NonEmpty (..))+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Alt)+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.STRef as Exports+import Data.String as Exports+import Data.Text as Exports (Text)+import Data.Time as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.UUID as Exports (UUID)+import Data.Unique as Exports+import Data.Version as Exports+import Data.Void as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports+import GHC.Clock as Exports (getMonotonicTimeNSec)+import GHC.Conc as Exports hiding (orElse, threadWaitRead, threadWaitReadSTM, threadWaitWrite, threadWaitWriteSTM, withMVar)+import GHC.Exts as Exports (IsList (..), groupWith, inline, lazy, sortWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Numeric as Exports+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+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, (.))

@@ -0,0 +1,224 @@+module Main where++import Control.Concurrent.Async (race)+import qualified Data.ByteString.Char8 as B8+import qualified Data.Text as Text+import qualified Hasql.Connection as Connection+import qualified Hasql.Decoders as Decoders+import qualified Hasql.Encoders as Encoders+import Hasql.Pool+import qualified Hasql.Pool.Config as Config+import qualified Hasql.Session as Session+import qualified Hasql.Statement as Statement+import qualified System.Environment+import qualified System.Random.Stateful as Random+import Test.Hspec+import Prelude++main :: IO ()+main = do+  connectionSettings <- getConnectionSettings+  let withPool poolSize acqTimeout maxLifetime maxIdletime connectionSettings =+        bracket+          ( acquire+              ( Config.settings+                  [ Config.size poolSize,+                    Config.acquisitionTimeout acqTimeout,+                    Config.agingTimeout maxLifetime,+                    Config.idlenessTimeout maxIdletime,+                    Config.staticConnectionSettings connectionSettings+                  ]+              )+          )+          release+      withDefaultPool =+        withPool 3 10 1_800 1_800 connectionSettings++  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+      res <- use pool $ closeConnSession >> selectOneSession+      res <- use pool $ closeConnSession >> selectOneSession+      res <- use pool $ closeConnSession >> selectOneSession+      res <- use pool $ selectOneSession+      shouldSatisfy res $ isRight+    it "Connection gets returned to the pool after normal use" $ withDefaultPool $ \pool -> do+      res <- use pool $ selectOneSession+      res <- use pool $ selectOneSession+      res <- use pool $ selectOneSession+      res <- use pool $ selectOneSession+      res <- use pool $ selectOneSession+      shouldSatisfy res $ isRight+    it "Connection gets returned to the pool after non-connection error" $ withDefaultPool $ \pool -> do+      res <- use pool $ badQuerySession+      res <- use pool $ badQuerySession+      res <- use pool $ badQuerySession+      res <- use pool $ badQuerySession+      res <- use pool $ selectOneSession+      shouldSatisfy res $ isRight+    it "The pool remains usable after release" $ withDefaultPool $ \pool -> do+      res <- 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 connectionSettings $ \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 connectionSettings $ \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 connectionSettings+      $ \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 connectionSettings+      $ \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 connectionSettings+      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 connectionSettings+        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 connectionSettings $ \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 .. 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++getConnectionSettings :: IO Connection.Settings+getConnectionSettings =+  B8.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 B8.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 :: Connection.Settings -> IO (Connection.Settings, Text)+tagConnection connectionSettings = do+  tag <- Random.uniformWord32 Random.globalStdGen+  let appName = "hasql-pool-test-" <> show tag+  return (connectionSettings <> " application_name=" <> B8.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))

@@ -1,212 +0,0 @@-module Main where--import Control.Concurrent.Async (race)-import qualified Data.ByteString.Char8 as B8-import qualified Data.Text as Text-import qualified Hasql.Connection as Connection-import qualified Hasql.Decoders as Decoders-import qualified Hasql.Encoders as Encoders-import Hasql.Pool-import qualified Hasql.Session as Session-import qualified Hasql.Statement as Statement-import qualified System.Environment-import qualified System.Random.Stateful as Random-import Test.Hspec-import Prelude--main :: IO ()-main = do-  connectionSettings <- getConnectionSettings-  let withPool poolSize acqTimeout maxLifetime maxIdletime connectionSettings =-        bracket (acquire poolSize acqTimeout maxLifetime maxIdletime connectionSettings) release-      withDefaultPool =-        withPool 3 10 1_800 1_800 connectionSettings--  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-      res <- use pool $ closeConnSession >> selectOneSession-      res <- use pool $ closeConnSession >> selectOneSession-      res <- use pool $ closeConnSession >> selectOneSession-      res <- use pool $ selectOneSession-      shouldSatisfy res $ isRight-    it "Connection gets returned to the pool after normal use" $ withDefaultPool $ \pool -> do-      res <- use pool $ selectOneSession-      res <- use pool $ selectOneSession-      res <- use pool $ selectOneSession-      res <- use pool $ selectOneSession-      res <- use pool $ selectOneSession-      shouldSatisfy res $ isRight-    it "Connection gets returned to the pool after non-connection error" $ withDefaultPool $ \pool -> do-      res <- use pool $ badQuerySession-      res <- use pool $ badQuerySession-      res <- use pool $ badQuerySession-      res <- use pool $ badQuerySession-      res <- use pool $ selectOneSession-      shouldSatisfy res $ isRight-    it "The pool remains usable after release" $ withDefaultPool $ \pool -> do-      res <- 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 connectionSettings $ \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 connectionSettings $ \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 connectionSettings-      $ \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 connectionSettings-      $ \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 connectionSettings-      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 connectionSettings-        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 connectionSettings $ \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 .. 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--getConnectionSettings :: IO Connection.Settings-getConnectionSettings =-  B8.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 B8.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 :: Connection.Settings -> IO (Connection.Settings, Text)-tagConnection connectionSettings = do-  tag <- Random.uniformWord32 Random.globalStdGen-  let appName = "hasql-pool-test-" <> show tag-  return (connectionSettings <> " application_name=" <> B8.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))