packages feed

hasql-pool 1.3.0.4 → 1.4.2

raw patch · 13 files changed

Files

CHANGELOG.md view
@@ -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`
hasql-pool.cabal view
@@ -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,
src/integration-tests/Helpers/Hooks.hs view
@@ -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))
src/integration-tests/Helpers/Scripts.hs view
@@ -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       ]
src/integration-tests/Helpers/Sessions.hs view
@@ -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))
src/integration-tests/Specs/BySubject/UsageError/SessionSpec.hs view
@@ -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
src/integration-tests/Specs/BySubject/UseSpec.hs view
@@ -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))))
src/library/exposed/Hasql/Pool.hs view
@@ -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)
src/library/exposed/Hasql/Pool/Config/Defaults.hs view
@@ -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  -- |
src/library/exposed/Hasql/Pool/Observation.hs view
@@ -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)
src/library/other/Hasql/Pool/Config/Config.hs view
@@ -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 ()   }
src/library/other/Hasql/Pool/Config/Setting.hs view
@@ -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})
src/library/other/Hasql/Pool/SessionErrorDestructors.hs view
@@ -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"