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

minor cleanup

Browse Source
This commit is contained in:
Gregor Kleen 2018-10-17 10:30:28 +02:00
parent 36b512d90b
commit 52d6c2d347
1 changed files with 11 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Utils/Sql.hs
View File

@ -17,6 +17,8 @@ import Database.Persist.Sql
import Database.PostgreSQL.Simple (sqlErrorHint) import Database.PostgreSQL.Simple (sqlErrorHint)
import Control.Monad.Catch (handleIf) import Control.Monad.Catch (handleIf)
import Data.Time.Clock
setSerializable :: (MonadLogger m, MonadCatch m, MonadBase IO m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a setSerializable :: (MonadLogger m, MonadCatch m, MonadBase IO m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
setSerializable act = setSerializable' (0 :: Integer) setSerializable act = setSerializable' (0 :: Integer)
where where
@ -24,7 +26,14 @@ setSerializable act = setSerializable' (0 :: Integer)
setSerializable' (min 10 -> logBackoff) = setSerializable' (min 10 -> logBackoff) =
handleIf handleIf
(\e -> sqlErrorHint e == "The transaction might succeed if retried.") (\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e)
(\e -> $logWarnS "Sql" (tshow e) *> threadDelay (1e3 * 2 ^ logBackoff) *> setSerializable' (succ logBackoff)) (\e -> do
let
delay :: NominalDiffTime
delay = 1e-3 * 2 ^ logBackoff
$logWarnS "Sql" $ tshow (delay, e)
threadDelay . round $ delay * 1e6
setSerializable' (succ logBackoff)
)
act' act'