From 184c74f2b4997a40c71acfb3ca364cc20cec1fc9 Mon Sep 17 00:00:00 2001
From: Elliot Cameron <eacameron@gmail.com>
Date: Fri, 11 Oct 2019 17:40:24 -0400
Subject: [PATCH 1/2] Fix spurious aborts when retrying transactions

Transactions that enter an error state must be aborted manually by
issuing a "ROLLBACK". However, if the transaction error happened during
a "COMMIT" then the rollback happens automatically. Issuing a "ROLLBACK"
at this point causes PostgreSQL to issue a "WARNING: There is no
transaction in progress". This warning can have much worse causes (e.g.
you "COMMIT" but never began a transaction). This change makes the
transaction retrying logic never cause PostgreSQL to issue this warning
making it a more useful warning for detecting real bugs.
---
 src/Database/PostgreSQL/Simple/Transaction.hs | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs
index c8f3434..6ae9e2b 100644
--- a/src/Database/PostgreSQL/Simple/Transaction.hs
+++ b/src/Database/PostgreSQL/Simple/Transaction.hs
@@ -157,7 +157,7 @@ withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection
 withTransactionModeRetry mode shouldRetry conn act =
     mask $ \restore ->
         retryLoop $ E.try $ do
-            a <- restore act
+            a <- restore act `E.onException` rollback_ conn
             commit conn
             return a
   where
@@ -166,8 +166,7 @@ withTransactionModeRetry mode shouldRetry conn act =
         beginMode mode conn
         r <- act'
         case r of
-            Left e -> do
-                rollback_ conn
+            Left e ->
                 case fmap shouldRetry (E.fromException e) of
                   Just True -> retryLoop act'
                   _ -> E.throwIO e

From e02684f9c38acf736ac590b36b919000a2b45bc4 Mon Sep 17 00:00:00 2001
From: Elliot Cameron <eacameron@gmail.com>
Date: Tue, 15 Oct 2019 10:46:26 -0400
Subject: [PATCH 2/2] Only catch SqlError in retryLoop

---
 src/Database/PostgreSQL/Simple/Transaction.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs
index 6ae9e2b..7e201df 100644
--- a/src/Database/PostgreSQL/Simple/Transaction.hs
+++ b/src/Database/PostgreSQL/Simple/Transaction.hs
@@ -161,15 +161,15 @@ withTransactionModeRetry mode shouldRetry conn act =
             commit conn
             return a
   where
-    retryLoop :: IO (Either E.SomeException a) -> IO a
+    retryLoop :: IO (Either SqlError a) -> IO a
     retryLoop act' = do
         beginMode mode conn
         r <- act'
         case r of
             Left e ->
-                case fmap shouldRetry (E.fromException e) of
-                  Just True -> retryLoop act'
-                  _ -> E.throwIO e
+                case shouldRetry e of
+                  True -> retryLoop act'
+                  False -> E.throwIO e
             Right a ->
                 return a