diff --git a/hasql-pool.cabal b/hasql-pool.cabal --- a/hasql-pool.cabal +++ b/hasql-pool.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-pool -version: 0.9.0.1 +version: 0.10 category: Hasql, Database, PostgreSQL synopsis: Pool of connections for Hasql homepage: https://github.com/nikita-volkov/hasql-pool diff --git a/library/Hasql/Pool.hs b/library/Hasql/Pool.hs --- a/library/Hasql/Pool.hs +++ b/library/Hasql/Pool.hs @@ -19,12 +19,14 @@ -- | A connection tagged with metadata. data Conn = Conn { connConnection :: Connection, - connCreationTimeNSec :: Word64 + connCreationTimeNSec :: Word64, + connUseTimeNSec :: Word64 } -isAlive :: Word64 -> Word64 -> Conn -> Bool -isAlive maxLifetime now conn = - now <= connCreationTimeNSec conn + maxLifetime +isAlive :: Word64 -> Word64 -> Word64 -> Conn -> Bool +isAlive maxLifetime maxIdletime now Conn {..} = + now <= connCreationTimeNSec + maxLifetime + && now <= connUseTimeNSec + maxIdletime -- | Pool of connections to DB. data Pool = Pool @@ -36,6 +38,8 @@ poolAcquisitionTimeout :: Int, -- | Maximal connection lifetime, in nanoseconds. poolMaxLifetime :: Word64, + -- | Maximal connection idle time, in nanoseconds. + poolMaxIdletime :: Word64, -- | Avail connections. poolConnectionQueue :: TQueue Conn, -- | Remaining capacity. @@ -60,11 +64,13 @@ DiffTime -> -- | Maximal connection lifetime. DiffTime -> + -- | Maximal connection idle time. + DiffTime -> -- | Connection settings. Connection.Settings -> IO Pool -acquire poolSize acqTimeout maxLifetime connectionSettings = - acquireDynamically poolSize acqTimeout maxLifetime (pure connectionSettings) +acquire poolSize acqTimeout maxLifetime maxIdletime connectionSettings = + acquireDynamically poolSize acqTimeout maxLifetime maxIdletime (pure connectionSettings) -- | Create a connection-pool. -- @@ -80,10 +86,12 @@ DiffTime -> -- | Maximal connection lifetime. DiffTime -> + -- | Maximal connection idle time. + DiffTime -> -- | Action fetching connection settings. IO Connection.Settings -> IO Pool -acquireDynamically poolSize acqTimeout maxLifetime fetchConnectionSettings = do +acquireDynamically poolSize acqTimeout maxLifetime maxIdletime fetchConnectionSettings = do connectionQueue <- newTQueueIO capVar <- newTVarIO poolSize reuseVar <- newTVarIO =<< newTVarIO True @@ -94,7 +102,7 @@ now <- getMonotonicTimeNSec join . atomically $ do conns <- flushTQueue connectionQueue - let (keep, close) = partition (isAlive maxLifetimeNanos now) conns + let (keep, close) = partition (isAlive maxLifetimeNanos maxIdletimeNanos now) conns traverse_ (writeTQueue connectionQueue) keep return $ forM_ close $ \conn -> do Connection.release (connConnection conn) @@ -104,12 +112,14 @@ -- When the pool goes out of scope, stop the manager. killThread managerTid - return $ Pool poolSize fetchConnectionSettings acqTimeoutMicros maxLifetimeNanos connectionQueue capVar reuseVar reaperRef + 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 @@ -171,12 +181,12 @@ Left connErr -> do atomically $ modifyTVar' poolCapacity succ return $ Left $ ConnectionUsageError connErr - Right conn -> onLiveConn reuseVar (Conn conn now) + Right conn -> onLiveConn reuseVar (Conn conn now now) onConn reuseVar conn = do now <- getMonotonicTimeNSec - if isAlive poolMaxLifetime now conn - then onLiveConn reuseVar conn + if isAlive poolMaxLifetime poolMaxIdletime now conn + then onLiveConn reuseVar conn {connUseTimeNSec = now} else do Connection.release (connConnection conn) onNewConn reuseVar diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -17,10 +17,10 @@ main :: IO () main = do connectionSettings <- getConnectionSettings - let withPool poolSize acqTimeout maxLifetime connectionSettings = - bracket (acquire poolSize acqTimeout maxLifetime connectionSettings) release + let withPool poolSize acqTimeout maxLifetime maxIdletime connectionSettings = + bracket (acquire poolSize acqTimeout maxLifetime maxIdletime connectionSettings) release withDefaultPool = - withPool 3 10 1_800 connectionSettings + 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 @@ -63,12 +63,12 @@ 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 connectionSettings $ \pool -> do + 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 connectionSettings $ \pool -> do + 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 @@ -76,7 +76,7 @@ res `shouldBe` Right Nothing it "Times out connection acquisition" $ -- 1ms timeout - withPool 1 0.001 1_800 connectionSettings $ \pool -> do + withPool 1 0.001 1_800 1_800 connectionSettings $ \pool -> do sleeping <- newEmptyMVar t0 <- getCurrentTime res <- @@ -93,9 +93,9 @@ t1 <- getCurrentTime res `shouldBe` Right (Left AcquisitionTimeoutUsageError) diffUTCTime t1 t0 `shouldSatisfy` (< 0.5) -- 0.5s - it "Passively times out old connections" $ + it "Passively times out old connections (maxLifetime)" $ -- 0.5s connection lifetime - withPool 1 10 0.5 connectionSettings $ \pool -> do + 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" @@ -105,13 +105,14 @@ res3 `shouldBe` Right Nothing it "Counts active connections" $ do (taggedConnectionSettings, appName) <- tagConnection connectionSettings - withPool 3 10 1_800 taggedConnectionSettings $ \pool -> do + withPool 3 10 1_800 1_800 taggedConnectionSettings $ \pool -> do res <- use pool $ countConnectionsSession appName res `shouldBe` Right 1 - it "Times out old connections" $ do + + it "Actively times out old connections (maxLifetime)" $ do withDefaultPool $ \countPool -> do (taggedConnectionSettings, appName) <- tagConnection connectionSettings - withPool 3 10 0.5 taggedConnectionSettings $ \limitedPool -> do + withPool 3 10 0.5 1_800 taggedConnectionSettings $ \limitedPool -> do res <- use limitedPool $ selectOneSession res `shouldBe` Right 1 res2 <- use countPool $ countConnectionsSession appName @@ -119,6 +120,24 @@ 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 =