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: 1.2.0.3 +version: 1.3 category: Hasql, Database, PostgreSQL synopsis: Pool of connections for Hasql homepage: https://github.com/nikita-volkov/hasql-pool @@ -88,7 +88,7 @@ build-depends: base >=4.11 && <5, bytestring >=0.10 && <0.14, - hasql >=1.7 && <1.9, + hasql >=1.9 && <1.10, stm >=2.5 && <3, text >=1.2 && <3, time >=1.9 && <2, diff --git a/src/library/exposed/Hasql/Pool.hs b/src/library/exposed/Hasql/Pool.hs --- a/src/library/exposed/Hasql/Pool.hs +++ b/src/library/exposed/Hasql/Pool.hs @@ -15,6 +15,7 @@ import Data.UUID.V4 qualified as Uuid import Hasql.Connection (Connection) import Hasql.Connection qualified as Connection +import Hasql.Connection.Setting qualified as Connection.Setting import Hasql.Pool.Config.Config qualified as Config import Hasql.Pool.Observation import Hasql.Pool.Prelude @@ -42,7 +43,7 @@ { -- | Pool size. poolSize :: Int, -- | Connection settings. - poolFetchConnectionSettings :: IO Connection.Settings, + poolFetchConnectionSettings :: IO [Connection.Setting.Setting], -- | Acquisition timeout, in microseconds. poolAcquisitionTimeout :: Int, -- | Maximal connection lifetime, in nanoseconds. diff --git a/src/library/exposed/Hasql/Pool/Config/Defaults.hs b/src/library/exposed/Hasql/Pool/Config/Defaults.hs --- a/src/library/exposed/Hasql/Pool/Config/Defaults.hs +++ b/src/library/exposed/Hasql/Pool/Config/Defaults.hs @@ -1,6 +1,7 @@ module Hasql.Pool.Config.Defaults where -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.Pool.Observation (Observation) import Hasql.Pool.Prelude import Hasql.Session qualified as Session @@ -27,13 +28,15 @@ -- | -- > "postgresql://postgres:postgres@localhost:5432/postgres" -staticConnectionSettings :: Connection.Settings -staticConnectionSettings = "postgresql://postgres:postgres@localhost:5432/postgres" +staticConnectionSettings :: [Connection.Setting.Setting] +staticConnectionSettings = + [ Connection.Setting.connection (Connection.Setting.Connection.string "postgresql://postgres:postgres@localhost:5432/postgres") + ] -- | -- > pure "postgresql://postgres:postgres@localhost:5432/postgres" -dynamicConnectionSettings :: IO Connection.Settings -dynamicConnectionSettings = pure "postgresql://postgres:postgres@localhost:5432/postgres" +dynamicConnectionSettings :: IO [Connection.Setting.Setting] +dynamicConnectionSettings = pure staticConnectionSettings -- | -- > const (pure ()) diff --git a/src/library/other/Hasql/Pool/Config/Config.hs b/src/library/other/Hasql/Pool/Config/Config.hs --- a/src/library/other/Hasql/Pool/Config/Config.hs +++ b/src/library/other/Hasql/Pool/Config/Config.hs @@ -1,6 +1,6 @@ module Hasql.Pool.Config.Config where -import Hasql.Connection qualified as Connection +import Hasql.Connection.Setting qualified as Connection.Setting import Hasql.Pool.Config.Defaults qualified as Defaults import Hasql.Pool.Observation (Observation) import Hasql.Pool.Prelude @@ -12,7 +12,7 @@ acquisitionTimeout :: DiffTime, agingTimeout :: DiffTime, idlenessTimeout :: DiffTime, - connectionSettingsProvider :: IO Connection.Settings, + connectionSettingsProvider :: IO [Connection.Setting.Setting], observationHandler :: Observation -> IO (), initSession :: Session.Session () } diff --git a/src/library/other/Hasql/Pool/Config/Setting.hs b/src/library/other/Hasql/Pool/Config/Setting.hs --- a/src/library/other/Hasql/Pool/Config/Setting.hs +++ b/src/library/other/Hasql/Pool/Config/Setting.hs @@ -1,6 +1,6 @@ module Hasql.Pool.Config.Setting where -import Hasql.Connection qualified as Connection +import Hasql.Connection.Setting qualified as Connection.Setting import Hasql.Pool.Config.Config (Config) import Hasql.Pool.Config.Config qualified as Config import Hasql.Pool.Observation (Observation) @@ -56,7 +56,7 @@ -- By default it is: -- -- > "postgresql://postgres:postgres@localhost:5432/postgres" -staticConnectionSettings :: Connection.Settings -> Setting +staticConnectionSettings :: [Connection.Setting.Setting] -> Setting staticConnectionSettings x = Setting (\config -> config {Config.connectionSettingsProvider = pure x}) @@ -70,7 +70,7 @@ -- By default it is: -- -- > pure "postgresql://postgres:postgres@localhost:5432/postgres" -dynamicConnectionSettings :: IO Connection.Settings -> Setting +dynamicConnectionSettings :: IO [Connection.Setting.Setting] -> Setting dynamicConnectionSettings x = Setting (\config -> config {Config.connectionSettingsProvider = x}) diff --git a/src/test/Main.hs b/src/test/Main.hs --- a/src/test/Main.hs +++ b/src/test/Main.hs @@ -1,9 +1,10 @@ module Main where import Control.Concurrent.Async (race) -import Data.ByteString.Char8 qualified as B8 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 @@ -17,8 +18,8 @@ main :: IO () main = do - connectionSettings <- getConnectionSettings - let withPool poolSize acqTimeout maxLifetime maxIdletime connectionSettings = + connectionString <- getConnectionString + let withPool poolSize acqTimeout maxLifetime maxIdletime connectionString = bracket ( acquire ( Config.settings @@ -26,13 +27,16 @@ Config.acquisitionTimeout acqTimeout, Config.agingTimeout maxLifetime, Config.idlenessTimeout maxIdletime, - Config.staticConnectionSettings connectionSettings + Config.staticConnectionSettings + [ Connection.Setting.connection + (Connection.Setting.Connection.string connectionString) + ] ] ) ) release withDefaultPool = - withPool 3 10 1_800 1_800 connectionSettings + 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 @@ -44,27 +48,27 @@ 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 + _ <- 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 - res <- use pool $ selectOneSession - res <- use pool $ selectOneSession - res <- use pool $ selectOneSession - res <- use pool $ selectOneSession + _ <- 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 - res <- use pool $ badQuerySession - res <- use pool $ badQuerySession - res <- use pool $ badQuerySession - res <- use pool $ badQuerySession + _ <- 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 - res <- use pool $ selectOneSession + _ <- use pool $ selectOneSession release pool res <- use pool $ selectOneSession shouldSatisfy res $ isRight @@ -75,12 +79,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 1_800 connectionSettings $ \pool -> do + 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 connectionSettings $ \pool -> do + 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 @@ -89,7 +93,7 @@ it "Times out connection acquisition" $ -- 1ms timeout - withPool 1 0.001 1_800 1_800 connectionSettings + withPool 1 0.001 1_800 1_800 connectionString $ \pool -> do sleeping <- newEmptyMVar t0 <- getCurrentTime @@ -111,7 +115,7 @@ it "Passively times out old connections (maxLifetime)" $ -- 0.5s connection lifetime - withPool 1 10 0.5 1_800 connectionSettings + withPool 1 10 0.5 1_800 connectionString $ \pool -> do res <- use pool $ setSettingSession "testing.foo" "hello world" res `shouldBe` Right () @@ -121,14 +125,14 @@ res3 <- use pool $ getSettingSession "testing.foo" res3 `shouldBe` Right Nothing it "Counts active connections" $ do - (taggedConnectionSettings, appName) <- tagConnection connectionSettings + (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 connectionSettings + (taggedConnectionSettings, appName) <- tagConnection connectionString withPool 3 10 0.5 1_800 taggedConnectionSettings $ \limitedPool -> do res <- use limitedPool $ selectOneSession res `shouldBe` Right 1 @@ -139,13 +143,13 @@ 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 + 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 .. 10] $ \_ -> do + forM_ [1 :: Int .. 10] $ \_ -> do r <- use pool $ selectOneSession r `shouldBe` Right 1 threadDelay 100_000 -- 0.1s @@ -156,9 +160,9 @@ res4 <- use pool $ getSettingSession "testing.foo" res4 `shouldBe` Right Nothing -getConnectionSettings :: IO Connection.Settings -getConnectionSettings = - B8.unwords +getConnectionString :: IO Text +getConnectionString = + Text.unwords . catMaybes <$> sequence [ setting "host" $ defaultEnv "POSTGRES_HOST" "localhost", @@ -168,17 +172,17 @@ setting "dbname" $ defaultEnv "POSTGRES_DBNAME" "postgres" ] where - maybeEnv env = fmap B8.pack <$> System.Environment.lookupEnv env + 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 :: Connection.Settings -> IO (Connection.Settings, Text) -tagConnection connectionSettings = do +tagConnection :: Text -> IO (Text, Text) +tagConnection connectionString = do tag <- Random.uniformWord32 Random.globalStdGen let appName = "hasql-pool-test-" <> show tag - return (connectionSettings <> " application_name=" <> B8.pack appName, Text.pack appName) + return (connectionString <> " application_name=" <> Text.pack appName, Text.pack appName) selectOneSession :: Session.Session Int64 selectOneSession =