fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(sql): quiet warnings in setSerializable

Browse Source
This commit is contained in:
Gregor Kleen 2020-05-12 11:46:02 +02:00
parent e5acdad134
commit 859ae5eea1
1 changed files with 19 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
src/Utils/Sql.hs
View File

@ -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 :: 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 where
policy :: RetryPolicyM (ReaderT SqlBackend m) policy :: RetryPolicyM (ReaderT SqlBackend m)
policy = fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6 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@False err status = $logErrorS "SQL.setSerializable" . pack $ defaultLogMsg shouldRetry err status
logRetry shouldRetry@True err status = $logDebugS "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' :: TVar Bool -> RetryStatus -> ReaderT SqlBackend m a
act' RetryStatus{..} act' didCommit RetryStatus{..} = do
| rsIterNumber == 0 = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act'' prevCommited <- atomically $ swapTVar didCommit False
| otherwise = [executeQQ|ROLLBACK; BEGIN TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act'' $logDebugS "SQL.setSerializable" $ "prevCommited = " <> tshow prevCommited <> "; rsIterNumber = " <> tshow rsIterNumber
where act'' = act <* transactionSaveWithIsolation ReadCommitted 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