From 3f013b1f83f857d567bcffcac47f4e5e6cf88b7a Mon Sep 17 00:00:00 2001 From: Marcelo Zabani Date: Thu, 14 May 2026 14:53:51 -0300 Subject: [PATCH] Don't lose Irrecoverable errors in `withTransaction` This could happen with an asynchronous exception being throwed in just the right place. --- .hlint.yaml | 1 + hpgsql-tests/TransactionSpec.hs | 9 ++++++++ hpgsql/src/Hpgsql/Transaction.hs | 37 ++++++++++++++++---------------- 3 files changed, 29 insertions(+), 18 deletions(-) diff --git a/.hlint.yaml b/.hlint.yaml index ecf6633..cc33045 100644 --- a/.hlint.yaml +++ b/.hlint.yaml @@ -30,4 +30,5 @@ - {name: Data.List.NonEmpty.fromList, within: [], message: "fromList is partial. Use nonEmpty from Data.List.NonEmpty instead."} - {name: "Data.List.NonEmpty.!!", within: [], message: "(!!) is partial. Use safe indexing instead."} - {name: "waitReadSocketSTM", within: [], message: "waitReadSocketSTM is not available in older versions of the network library. Use functions from our own Networking module instead."} + - {name: "tryAny", within: [], message: "You typically want to ignore IrrecoverableHpgsqlError, so use tryJust instead"} diff --git a/hpgsql-tests/TransactionSpec.hs b/hpgsql-tests/TransactionSpec.hs index 3abbdef..04b94fd 100644 --- a/hpgsql-tests/TransactionSpec.hs +++ b/hpgsql-tests/TransactionSpec.hs @@ -28,6 +28,9 @@ spec = aroundConn $ describe "Hpgsql.Transaction" $ parallel $ do it "withTransaction issues ROLLBACK when the inner action throws a synchronous exception" withTransactionRollsBackOnSyncException + it + "withTransaction lets irrecoverable errors propagate" + withTransactionLetsIrrecoverableErrorsPropagate it "withTransaction issues ROLLBACK when the inner action is killed by an asynchronous exception" withTransactionRollsBackOnAsyncException @@ -57,6 +60,12 @@ withTransactionRollsBackOnSyncException conn = do query conn [sql|SELECT 1 FROM pg_class WHERE relname = 'tx_sync_test'|] `shouldReturn` ([] :: [Only Int]) +withTransactionLetsIrrecoverableErrorsPropagate :: HPgConnection -> IO () +withTransactionLetsIrrecoverableErrorsPropagate conn = do + let irrecEx = IrrecoverableHpgsqlError {hpgsqlDetails = "Example irrecoverable error", relatedStatement = Nothing, innerException = Nothing} + (withTransaction conn (throwIO irrecEx)) + `shouldThrow` (\(ex :: IrrecoverableHpgsqlError) -> ex.hpgsqlDetails == irrecEx.hpgsqlDetails) + withTransactionRollsBackOnAsyncException :: HPgConnection -> IO () withTransactionRollsBackOnAsyncException conn = do ( concurrently diff --git a/hpgsql/src/Hpgsql/Transaction.hs b/hpgsql/src/Hpgsql/Transaction.hs index e5b4080..89a8ab2 100644 --- a/hpgsql/src/Hpgsql/Transaction.hs +++ b/hpgsql/src/Hpgsql/Transaction.hs @@ -1,7 +1,7 @@ module Hpgsql.Transaction (withTransaction, withTransactionMode, begin, beginMode, commit, rollback, transactionStatus, IsolationLevel (..), ReadWriteMode (..), TransactionStatus (..)) where import qualified Control.Concurrent.STM as STM -import Control.Exception.Safe (Exception (..), bracketWithError, throw, tryAny) +import Control.Exception.Safe (Exception (..), bracketWithError, throw, tryAny, tryJust) import Control.Monad (unless) import Hpgsql.Internal (execute_, fullTransactionStatus, transactionStatus) import Hpgsql.InternalTypes (HPgConnection (..), InternalConnectionState (..), IrrecoverableHpgsqlError) @@ -73,24 +73,22 @@ withTransaction conn = withTransactionMode conn DefaultIsolationLevel DefaultRea -- will be issued before your next query on this connection. withTransactionMode :: HPgConnection -> IsolationLevel -> ReadWriteMode -> IO a -> IO a withTransactionMode conn il rw f = bracketWithError (beginMode conn il rw) cleanup $ \() -> do - res <- tryAny f + res <- tryJust notIrrecoverableError f case res of - Left ex -> case fromException ex of - Just (_ :: IrrecoverableHpgsqlError) -> throw ex -- Rethrow internal errors - Nothing -> do - -- In case of a synchronous exception, we rollback synchronously. - -- If this is interrupted: - -- - Before ROLLBACK is sent, `cleanup` will enqueue a "ROLLBACK". - -- - After ROLLBACK is sent but before it finishes, a ROLLBACK will still be enqueued - -- (check `cleanup`), which means: - -- - If ROLLBACK has already completed by the time the new ROLLBACK is meant to be sent, - -- the new ROLLBACK will produce a "WARNING: there is no transaction in progress". This - -- isn't great, but is mostly harmless. - -- - If ROLLBACK is cancelled by the future ROLLBACK, all is good as well. - -- - After ROLLBACK is sent and completed, `cleanup` won't enqueue a new ROLLBACK, and all is well. - -- - -- We rollback here, not in `cleanup`, because that runs with async exceptions masked - rollback conn >> throw ex -- Reminder that this can be interrupted before/after "rollback" is sent + Left ex -> do + -- In case of a synchronous exception, we rollback synchronously. + -- If this is interrupted: + -- - Before ROLLBACK is sent, `cleanup` will enqueue a "ROLLBACK". + -- - After ROLLBACK is sent but before it finishes, a ROLLBACK will still be enqueued + -- (check `cleanup`), which means: + -- - If ROLLBACK has already completed by the time the new ROLLBACK is meant to be sent, + -- the new ROLLBACK will produce a "WARNING: there is no transaction in progress". This + -- isn't great, but is mostly harmless. + -- - If ROLLBACK is cancelled by the future ROLLBACK, all is good as well. + -- - After ROLLBACK is sent and completed, `cleanup` won't enqueue a new ROLLBACK, and all is well. + -- + -- We rollback here, not in `cleanup`, because that runs with async exceptions masked + rollback conn >> throw ex -- Reminder that this can be interrupted before/after "rollback" is sent Right v -> do -- If this is interrupted: -- - Before COMMIT is sent, it's equivalent to failing in the middle of the user-supplied action @@ -105,6 +103,9 @@ withTransactionMode conn il rw f = bracketWithError (beginMode conn il rw) clean commit conn pure v where + notIrrecoverableError e = case fromException e of + Just (_ :: IrrecoverableHpgsqlError) -> Nothing + _ -> Just e cleanup mEx () = case mEx of Nothing -> pure () Just (fromException -> (Just (_ :: IrrecoverableHpgsqlError))) -> pure () -- Do nothing if an internal error was thrown, just let it propagate