From 859ae5eea103cce3dee84d6ba9d104f21d120f43 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Tue, 12 May 2020 11:46:02 +0200
Subject: [PATCH] fix(sql): quiet warnings in setSerializable

---
 src/Utils/Sql.hs | 25 +++++++++++++++++++------
 1 file changed, 19 insertions(+), 6 deletions(-)

diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs
index fabac30ec..7ced39ddf 100644
--- a/src/Utils/Sql.hs
+++ b/src/Utils/Sql.hs
@@ -17,7 +17,9 @@ import Control.Lens ((&))
 
 
 setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
-setSerializable act = recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry logRetry) act'
+setSerializable act = do
+  didCommit <- newTVarIO False
+  recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry logRetry) $ act' didCommit
   where
     policy :: RetryPolicyM (ReaderT SqlBackend m)
     policy = fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6
@@ -32,8 +34,19 @@ setSerializable act = recovering policy (skipAsyncExceptions `snoc` logRetries s
     logRetry shouldRetry@False err status = $logErrorS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
     logRetry shouldRetry@True  err status = $logDebugS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
 
-    act' :: RetryStatus -> ReaderT SqlBackend m a
-    act' RetryStatus{..}
-      | rsIterNumber == 0 = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act''
-      | otherwise         = [executeQQ|ROLLBACK; BEGIN TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act''
-      where act'' = act <* transactionSaveWithIsolation ReadCommitted
+    act' :: TVar Bool -> RetryStatus -> ReaderT SqlBackend m a
+    act' didCommit RetryStatus{..} = do
+      prevCommited <- atomically $ swapTVar didCommit False
+      $logDebugS "SQL.setSerializable" $ "prevCommited = " <> tshow prevCommited <> "; rsIterNumber = " <> tshow rsIterNumber
+      if
+        | rsIterNumber == 0 -> [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act''
+        | prevCommited      -> [executeQQ|BEGIN TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act''
+        | otherwise         -> transactionUndoWithIsolation Serializable *> act''
+      where act'' = do
+              res <- act
+              atomically $ writeTVar didCommit True
+              transactionSaveWithIsolation ReadCommitted
+              return res
+
+
+