hasql-pool 1.4.1 → 1.4.2

raw patch · 5 files changed

+87/−15 lines, 5 files

Files

• hasql-pool.cabal +1/−1
• src/integration-tests/Specs/BySubject/UseSpec.hs +43/−0
• src/library/exposed/Hasql/Pool.hs +14/−13
• src/library/exposed/Hasql/Pool/Observation.hs +5/−1
• src/library/other/Hasql/Pool/SessionErrorDestructors.hs +24/−0

@@ -1,6 +1,6 @@ cabal-version: 3.0 name: hasql-pool-version: 1.4.1+version: 1.4.2 category: Hasql, Database, PostgreSQL synopsis: Pool of connections for Hasql homepage: https://github.com/nikita-volkov/hasql-pool

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

@@ -217,19 +217,20 @@           returnConn           throwIO exc         Right (Left err) ->-          ErrorsDestruction.reset-            ( \details -> do-                Connection.release (entryConnection entry)-                atomically $ modifyTVar' poolCapacity succ-                poolObserver (ConnectionObservation (entryId entry) (TerminatedConnectionStatus (NetworkErrorConnectionTerminationReason (Just 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))

@@ -51,7 +51,11 @@     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

@@ -7,3 +7,27 @@ reset onReset onNoReset = \case   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"