hasql-pool 0.9.0.1 → 0.10

raw patch · 3 files changed

+53/−24 lines, 3 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• hasql-pool.cabal +1/−1
• library/Hasql/Pool.hs +22/−12
• test/Main.hs +30/−11

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

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

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