@@ -17,6 +17,7 @@ module Database.PostgreSQL.Simple.Transaction
1717 , withTransactionLevel
1818 , withTransactionMode
1919 , withTransactionModeRetry
20+ , withTransactionModeRetry'
2021 , withTransactionSerializable
2122 , TransactionMode(..)
2223 , IsolationLevel(..)
@@ -146,31 +147,34 @@ withTransactionMode mode conn act =
146147 commit conn
147148 return r
148149
150+-- | 'withTransactionModeRetry'' but with the exception type pinned to 'SqlError'.
151+withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
152+withTransactionModeRetry = withTransactionModeRetry'
153+
149154-- | Like 'withTransactionMode', but also takes a custom callback to
150−-- determine if a transaction should be retried if an 'SqlError' occurs.
151−-- If the callback returns True, then the transaction will be retried.
152−-- If the callback returns False, or an exception other than an 'SqlError'
155+-- determine if a transaction should be retried if an exception occurs.
156+-- If the callback returns 'True', then the transaction will be retried.
157+-- If the callback returns 'False', or an exception other than an @e@
153158-- occurs then the transaction will be rolled back and the exception rethrown.
154159--
155160-- This is used to implement 'withTransactionSerializable'.
156−withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a
157−withTransactionModeRetry mode shouldRetry conn act =
161+withTransactionModeRetry' :: forall a e. E.Exception e => TransactionMode -> (e -> Bool) -> Connection -> IO a -> IO a
162+withTransactionModeRetry' mode shouldRetry conn act =
158163 mask $ \restore ->
159164 retryLoop $ E.try $ do
160− a <- restore act
165+ a <- restore act `E.onException` rollback_ conn
161166 commit conn
162167 return a
163168 where
164− retryLoop :: IO (Either E.SomeException a) -> IO a
169+ retryLoop :: IO (Either e a) -> IO a
165170 retryLoop act' = do
166171 beginMode mode conn
167172 r <- act'
168173 case r of
169− Left e -> do
170− rollback_ conn
171− case fmap shouldRetry (E.fromException e) of
172− Just True -> retryLoop act'
173− _ -> E.throwIO e
174+ Left e ->
175+ case shouldRetry e of
176+ True -> retryLoop act'
177+ False -> E.throwIO e
174178 Right a ->
175179 return a
176180