diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# 1.4 + +- Migrated to `hasql-1.10` +- Updated connection settings API to use monoid-based `Settings` instead of list-based `[Setting]` +- Updated error types to use `Hasql.Errors` module instead of `Hasql.Session` and `Hasql.Connection` +- Changed session execution API from `Session.run session connection` to `Connection.use connection session` +- Error handling now uses `ConnectionSessionError` for connection-level issues instead of `ClientError` +- Updated statement construction to use `Statement.preparable` and `Statement.unpreparable` instead of direct constructor +- Hid the `Defaults` module from the public API + # 1.3 - Adapt to the new settings model of `hasql-1.9` 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.3.0.4 +version: 1.4.2 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.9 && <1.10, + hasql >=1.10 && <1.11, stm >=2.5 && <3, text >=1.2 && <3, time >=1.9 && <2, @@ -123,8 +123,9 @@ hasql, hasql-pool, hspec >=2.6 && <3, + postgresql-libpq >=0.10 && <0.12, random >=1.2 && <2, rerebase >=1.15 && <2, - testcontainers-postgresql >=0.0.2 && <0.1, + testcontainers-postgresql >=0.2 && <0.3, text-builder >=1 && <1.1, tuple ^>=0.3.0.2, diff --git a/src/integration-tests/Helpers/Hooks.hs b/src/integration-tests/Helpers/Hooks.hs --- a/src/integration-tests/Helpers/Hooks.hs +++ b/src/integration-tests/Helpers/Hooks.hs @@ -13,7 +13,7 @@ TestcontainersPostgresql.run TestcontainersPostgresql.Config { forwardLogs = False, - distro = TestcontainersPostgresql.Distro17, + tagName = "postgres:17", auth = TestcontainersPostgresql.TrustAuth } (\(host, portInt) -> handler (host, fromIntegral portInt)) diff --git a/src/integration-tests/Helpers/Scripts.hs b/src/integration-tests/Helpers/Scripts.hs --- a/src/integration-tests/Helpers/Scripts.hs +++ b/src/integration-tests/Helpers/Scripts.hs @@ -1,8 +1,6 @@ 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.Connection.Settings qualified as Connection.Settings import Hasql.Pool qualified as Pool import Hasql.Pool.Config qualified as Config import System.Random.Stateful qualified as Random @@ -24,17 +22,14 @@ 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 - ] - ) - ] + ( mconcat + [ Connection.Settings.hostAndPort host (fromIntegral port), + Connection.Settings.user "postgres", + Connection.Settings.password "", + Connection.Settings.dbname "postgres", + Connection.Settings.applicationName appName + ] + ) ] ) ) @@ -59,6 +54,7 @@ $ mconcat $ [ TextBuilder.text prefix, TextBuilder.decimal uniqueNum1, + "-", TextBuilder.decimal uniqueNum2 ] diff --git a/src/integration-tests/Helpers/Sessions.hs b/src/integration-tests/Helpers/Sessions.hs --- a/src/integration-tests/Helpers/Sessions.hs +++ b/src/integration-tests/Helpers/Sessions.hs @@ -9,7 +9,7 @@ where import Data.Tuple.All -import Hasql.Connection qualified as Connection +import Database.PostgreSQL.LibPQ qualified as Pq import Hasql.Decoders qualified as Decoders import Hasql.Encoders qualified as Encoders import Hasql.Session qualified as Session @@ -20,7 +20,7 @@ selectOne = Session.statement () statement where - statement = Statement.Statement "SELECT 1" Encoders.noParams decoder True + statement = Statement.preparable "SELECT 1::int8" Encoders.noParams decoder decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)) badQuery :: Session.Session () @@ -28,19 +28,20 @@ Session.statement () statement where statement = - Statement.Statement "zzz" Encoders.noParams Decoders.noResult True + Statement.preparable "zzz" Encoders.noParams Decoders.noResult closeConn :: Session.Session () -closeConn = do - conn <- ask - liftIO $ Connection.release conn +closeConn = + Session.onLibpqConnection \conn -> do + Pq.finish conn + pure (Right (), 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 + Statement.preparable "SELECT set_config($1, $2, false)" encoder Decoders.noResult encoder = mconcat [ sel1 >$< Encoders.param (Encoders.nonNullable Encoders.text), @@ -51,7 +52,7 @@ getSetting name = do Session.statement name statement where - statement = Statement.Statement "SELECT current_setting($1, true)" encoder decoder True + statement = Statement.preparable "SELECT current_setting($1, true)" encoder decoder encoder = Encoders.param (Encoders.nonNullable Encoders.text) decoder = Decoders.singleRow (Decoders.column (Decoders.nullable Decoders.text)) @@ -59,6 +60,6 @@ countConnections appName = do Session.statement appName statement where - statement = Statement.Statement "SELECT count(*) FROM pg_stat_activity WHERE application_name = $1" encoder decoder True + statement = Statement.preparable "SELECT count(*) FROM pg_stat_activity WHERE application_name = $1" encoder decoder encoder = Encoders.param (Encoders.nonNullable Encoders.text) decoder = Decoders.singleRow (Decoders.column (Decoders.nonNullable Decoders.int8)) diff --git a/src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs b/src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs --- a/src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs +++ b/src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs @@ -1,7 +1,6 @@ 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 @@ -9,9 +8,9 @@ spec :: SpecWith Scripts.ScopeParams spec = do - it "Simulation of connection error works" \scopeParams -> + it "Bad SQL query triggers error" \scopeParams -> Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do - res <- use pool $ Sessions.closeConn >> Sessions.selectOne + res <- use pool Sessions.badQuery shouldSatisfy res $ \case - Left (SessionUsageError (Session.QueryError _ _ (Session.ClientError _))) -> True + Left (SessionUsageError _) -> True _ -> False diff --git a/src/integration-tests/Specs/BySubject/UseSpec.hs b/src/integration-tests/Specs/BySubject/UseSpec.hs --- a/src/integration-tests/Specs/BySubject/UseSpec.hs +++ b/src/integration-tests/Specs/BySubject/UseSpec.hs @@ -1,6 +1,11 @@ module Specs.BySubject.UseSpec where +import Data.Text qualified as Text +import Hasql.Decoders qualified as Decoders +import Hasql.Encoders qualified as Encoders import Hasql.Pool +import Hasql.Session qualified as Session +import Hasql.Statement qualified as Statement import Helpers.Scripts qualified as Scripts import Helpers.Sessions qualified as Sessions import Test.Hspec @@ -38,3 +43,41 @@ _ <- use pool $ Sessions.badQuery res <- use pool $ Sessions.selectOne shouldSatisfy res $ isRight + + it "Cached type errors cause eviction of connection" \scopeParams -> do + typeName <- Text.replace "-" "_" <$> Scripts.generateName "cached_type_" + Scripts.onAutotaggedPool 1 10 1_800 1_800 scopeParams \_ pool -> do + use pool (Session.script (createTypeSql typeName)) `shouldReturn` Right () + use pool (roundtripEnum typeName "ok") `shouldReturn` Right "ok" + use pool (Session.script (recreateTypeSql typeName)) `shouldReturn` Right () + res <- use pool (roundtripEnum typeName "ok") + shouldSatisfy res \case + Left (SessionUsageError _) -> True + _ -> False + use pool (roundtripEnum typeName "ok") `shouldReturn` Right "ok" + +quoteIdentifier :: Text -> Text +quoteIdentifier identifier = + "\"" <> Text.replace "\"" "\"\"" identifier <> "\"" + +createTypeSql :: Text -> Text +createTypeSql typeName = + "create type " <> quotedTypeName <> " as enum ('sad', 'ok', 'happy')" + where + quotedTypeName = quoteIdentifier typeName + +recreateTypeSql :: Text -> Text +recreateTypeSql typeName = + "drop type " <> quotedTypeName <> "; create type " <> quotedTypeName <> " as enum ('sad', 'ok', 'happy')" + where + quotedTypeName = quoteIdentifier typeName + +roundtripEnum :: Text -> Text -> Session.Session Text +roundtripEnum typeName value = + Session.statement value statement + where + statement = + Statement.preparable + ("select $1 :: " <> quoteIdentifier typeName) + (Encoders.param (Encoders.nonNullable (Encoders.enum Nothing typeName id))) + (Decoders.singleRow (Decoders.column (Decoders.nonNullable (Decoders.enum Nothing typeName Just)))) 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 @@ -10,12 +10,11 @@ ) where -import Data.Text.Encoding qualified as Text -import Data.Text.Encoding.Error qualified as Text 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.Connection.Settings qualified as Connection.Settings +import Hasql.Errors qualified as Errors import Hasql.Pool.Config.Config qualified as Config import Hasql.Pool.Observation import Hasql.Pool.Prelude @@ -43,7 +42,7 @@ { -- | Pool size. poolSize :: Int, -- | Connection settings. - poolFetchConnectionSettings :: IO [Connection.Setting.Setting], + poolFetchConnectionSettings :: IO Connection.Settings.Settings, -- | Acquisition timeout, in microseconds. poolAcquisitionTimeout :: Int, -- | Maximal connection lifetime, in nanoseconds. @@ -170,16 +169,21 @@ poolObserver (ConnectionObservation id ConnectingConnectionStatus) Connection.acquire settings >>= \case Left connErr -> do - poolObserver (ConnectionObservation id (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (fmap (Text.decodeUtf8With Text.lenientDecode) connErr)))) + let connErrText = case connErr of + Errors.NetworkingConnectionError details -> Just details + Errors.AuthenticationConnectionError details -> Just details + Errors.CompatibilityConnectionError details -> Just details + Errors.OtherConnectionError details -> if details == "" then Nothing else Just details + poolObserver (ConnectionObservation id (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason connErrText))) atomically $ modifyTVar' poolCapacity succ return $ Left $ ConnectionUsageError connErr Right connection -> do - Session.run poolInitSession connection >>= \case + Connection.use connection poolInitSession >>= \case Left err -> do Connection.release connection ErrorsDestruction.reset ( \details -> do - poolObserver (ConnectionObservation id (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (fmap (Text.decodeUtf8With Text.lenientDecode) details)))) + poolObserver (ConnectionObservation id (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (Just details)))) ) (poolObserver (ConnectionObservation id (TerminatedConnectionStatus (InitializationErrorTerminationReason err)))) err @@ -206,26 +210,27 @@ onLiveConn reuseVar entry = do poolObserver (ConnectionObservation (entryId entry) InUseConnectionStatus) - sessRes <- try @SomeException (Session.run sess (entryConnection entry)) + sessRes <- try @SomeException (Connection.use (entryConnection entry) sess) case sessRes of Left exc -> do returnConn throwIO exc Right (Left err) -> - ErrorsDestruction.reset - ( \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 (SessionFailedConnectionReadyForUseReason err))) - return $ Left $ SessionUsageError err - ) - err + if ErrorsDestruction.requiresConnectionDiscard err + then do + Connection.release (entryConnection entry) + atomically $ modifyTVar' poolCapacity succ + poolObserver + ( ConnectionObservation + (entryId entry) + (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (ErrorsDestruction.discardDetails err))) + ) + return $ Left $ SessionUsageError err + else do + returnConn + poolObserver (ConnectionObservation (entryId entry) (ReadyForUseConnectionStatus (SessionFailedConnectionReadyForUseReason err))) + return $ Left $ SessionUsageError err Right (Right res) -> do returnConn poolObserver (ConnectionObservation (entryId entry) (ReadyForUseConnectionStatus SessionSucceededConnectionReadyForUseReason)) @@ -244,9 +249,9 @@ -- | Union over all errors that 'use' can result in. data UsageError = -- | Attempt to establish a connection failed. - ConnectionUsageError Connection.ConnectionError + ConnectionUsageError Errors.ConnectionError | -- | Session execution failed. - SessionUsageError Session.SessionError + SessionUsageError Errors.SessionError | -- | Timeout acquiring a connection. AcquisitionTimeoutUsageError deriving (Show, Eq) 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,7 +1,6 @@ module Hasql.Pool.Config.Defaults where -import Hasql.Connection.Setting qualified as Connection.Setting -import Hasql.Connection.Setting.Connection qualified as Connection.Setting.Connection +import Hasql.Connection.Settings qualified as Connection.Settings import Hasql.Pool.Observation (Observation) import Hasql.Pool.Prelude import Hasql.Session qualified as Session @@ -28,14 +27,13 @@ -- | -- > "postgresql://postgres:postgres@localhost:5432/postgres" -staticConnectionSettings :: [Connection.Setting.Setting] +staticConnectionSettings :: Connection.Settings.Settings staticConnectionSettings = - [ Connection.Setting.connection (Connection.Setting.Connection.string "postgresql://postgres:postgres@localhost:5432/postgres") - ] + "postgresql://postgres:postgres@localhost:5432/postgres" -- | -- > pure "postgresql://postgres:postgres@localhost:5432/postgres" -dynamicConnectionSettings :: IO [Connection.Setting.Setting] +dynamicConnectionSettings :: IO Connection.Settings.Settings dynamicConnectionSettings = pure staticConnectionSettings -- | diff --git a/src/library/exposed/Hasql/Pool/Observation.hs b/src/library/exposed/Hasql/Pool/Observation.hs --- a/src/library/exposed/Hasql/Pool/Observation.hs +++ b/src/library/exposed/Hasql/Pool/Observation.hs @@ -4,8 +4,8 @@ -- Specific interpreters are encouraged to be created as extension libraries. module Hasql.Pool.Observation where +import Hasql.Errors qualified as Errors import Hasql.Pool.Prelude -import Hasql.Session qualified as Session -- | An observation of a change of the state of a pool. data Observation @@ -40,7 +40,7 @@ = -- | Connection just got established. EstablishedConnectionReadyForUseReason | -- | Session execution ended with a failure that does not require a connection reset. - SessionFailedConnectionReadyForUseReason Session.SessionError + SessionFailedConnectionReadyForUseReason Errors.SessionError | -- | Session execution ended with success. SessionSucceededConnectionReadyForUseReason deriving (Show, Eq) @@ -51,10 +51,14 @@ AgingConnectionTerminationReason | -- | The timeout of how long a connection may remain idle in the pool has passed. IdlenessConnectionTerminationReason - | -- | Connectivity issues with the server. + | -- | The connection became unusable and had to be discarded. + -- + -- This includes connectivity issues with the server as well as fatal + -- session errors that invalidate the connection's prepared statement or + -- type caches. NetworkErrorConnectionTerminationReason (Maybe Text) | -- | User has invoked the 'Hasql.Pool.release' procedure. ReleaseConnectionTerminationReason | -- | Initialization session failure. - InitializationErrorTerminationReason Session.SessionError + InitializationErrorTerminationReason Errors.SessionError deriving (Show, Eq) 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.Setting qualified as Connection.Setting +import Hasql.Connection.Settings qualified as Connection.Settings 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.Setting.Setting], + connectionSettingsProvider :: IO Connection.Settings.Settings, 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.Setting qualified as Connection.Setting +import Hasql.Connection.Settings qualified as Connection.Settings import Hasql.Pool.Config.Config (Config) import Hasql.Pool.Config.Config qualified as Config import Hasql.Pool.Observation (Observation) @@ -54,7 +54,7 @@ -- By default it is: -- -- > "postgresql://postgres:postgres@localhost:5432/postgres" -staticConnectionSettings :: [Connection.Setting.Setting] -> Setting +staticConnectionSettings :: Connection.Settings.Settings -> Setting staticConnectionSettings x = Setting (\config -> config {Config.connectionSettingsProvider = pure x}) @@ -66,7 +66,7 @@ -- By default it is: -- -- > pure "postgresql://postgres:postgres@localhost:5432/postgres" -dynamicConnectionSettings :: IO [Connection.Setting.Setting] -> Setting +dynamicConnectionSettings :: IO Connection.Settings.Settings -> Setting dynamicConnectionSettings x = Setting (\config -> config {Config.connectionSettingsProvider = x}) @@ -88,6 +88,10 @@ -- -- Gets executed on every connection upon acquisition. -- Lets you specify the connection-wide settings. +-- +-- E.g., you can set the search path for all the sessions executed by the pool by executing the following: +-- +-- > initSession (Session.sql "SET search_path TO schema1, schema2, public;") initSession :: Session.Session () -> Setting initSession x = Setting (\config -> config {Config.initSession = x}) diff --git a/src/library/other/Hasql/Pool/SessionErrorDestructors.hs b/src/library/other/Hasql/Pool/SessionErrorDestructors.hs --- a/src/library/other/Hasql/Pool/SessionErrorDestructors.hs +++ b/src/library/other/Hasql/Pool/SessionErrorDestructors.hs @@ -1,10 +1,33 @@ module Hasql.Pool.SessionErrorDestructors where +import Hasql.Errors qualified as Errors import Hasql.Pool.Prelude -import Hasql.Session qualified as Session -reset :: (Maybe ByteString -> x) -> x -> Session.SessionError -> x +reset :: (Text -> x) -> x -> Errors.SessionError -> x reset onReset onNoReset = \case - Session.QueryError _ _ (Session.ClientError details) -> onReset details - Session.PipelineError (Session.ClientError details) -> onReset details + Errors.ConnectionSessionError details -> onReset details _ -> onNoReset + +requiresConnectionDiscard :: Errors.SessionError -> Bool +requiresConnectionDiscard = \case + Errors.ConnectionSessionError {} -> True + Errors.MissingTypesSessionError {} -> True + Errors.ScriptSessionError _ serverError -> isStaleServerError serverError + Errors.StatementSessionError _ _ _ _ _ statementError -> statementRequiresConnectionDiscard statementError + Errors.DriverSessionError {} -> False + +discardDetails :: Errors.SessionError -> Maybe Text +discardDetails err = + if requiresConnectionDiscard err + then Just $ Errors.toMessage err + else Nothing + +statementRequiresConnectionDiscard :: Errors.StatementError -> Bool +statementRequiresConnectionDiscard = \case + Errors.ServerStatementError serverError -> isStaleServerError serverError + Errors.UnexpectedColumnTypeStatementError {} -> True + _ -> False + +isStaleServerError :: Errors.ServerError -> Bool +isStaleServerError (Errors.ServerError code _ _ _ _) = + code == "0A000" || code == "XX000"