@@ -17,6 +17,7 @@ module Database.PostgreSQL.Simple.Transaction
17 , withTransactionLevel
17 , withTransactionLevel
18 , withTransactionMode
18 , withTransactionMode
19 , withTransactionModeRetry
19 , withTransactionModeRetry
20+ , withTransactionModeRetry'
20 , withTransactionSerializable
21 , withTransactionSerializable
21 , TransactionMode(..)
22 , TransactionMode(..)
22 , IsolationLevel(..)
23 , IsolationLevel(..)
@@ -146,31 +147,34 @@ withTransactionMode mode conn act =
146 commit conn
147 commit conn
150+-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.
151+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
152+withTransactionModeRetry = withTransactionModeRetry'
149-- | Like 'withTransactionMode', but also takes a custom callback to
154-- | Like 'withTransactionMode', but also takes a custom callback to
150−-- determine if a transaction should be retried if an 'SqlError' occurs.
155+-- determine if a transaction should be retried if an exception occurs.
151−-- If the callback returns True, then the transaction will be retried.
156+-- If the callback returns 'True', then the transaction will be retried.
152−-- If the callback returns False, or an exception other than an 'SqlError'
157+-- If the callback returns 'False', or an exception other than an @e@
153-- occurs then the transaction will be rolled back and the exception rethrown.
158-- occurs then the transaction will be rolled back and the exception rethrown.
155-- This is used to implement 'withTransactionSerializable'.
160-- This is used to implement 'withTransactionSerializable'.
156−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
161+withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a
157−withTransactionModeRetry mode shouldRetry conn act =
162+withTransactionModeRetry' mode shouldRetry conn act =
158 mask $ \restore ->
163 mask $ \restore ->
159 retryLoop $ E.try $ do
164 retryLoop $ E.try $ do
160− a <- restore act
165+ a <- restore act `E.onException` rollback_ conn
161 commit conn
166 commit conn
164− retryLoop :: IO (Either E.SomeException a) -> IO a
169+ retryLoop :: IO (Either e a) -> IO a
165 retryLoop act' = do
170 retryLoop act' = do
166 beginMode mode conn
171 beginMode mode conn
167 r <- act'
172 r <- act'
168 case r of
173 case r of
169− Left e -> do
174+ Left e ->
171− case fmap shouldRetry (E.fromException e) of
175+ case shouldRetry e of
172− Just True -> retryLoop act'
176+ True -> retryLoop act'
173− _ -> E.throwIO e
177+ False -> E.throwIO e
174 Right a ->
178 Right a ->