41 lines
1.1 KiB
Haskell
41 lines
1.1 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NumDecimals #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
module Utils.Sql
|
|
( setSerializable
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod
|
|
|
|
import Database.Persist.Sql
|
|
|
|
import Database.PostgreSQL.Simple (sqlErrorHint)
|
|
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 act = setSerializable' (0 :: Integer)
|
|
where
|
|
act' = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act
|
|
|
|
setSerializable' (min 10 -> logBackoff) =
|
|
handleIf
|
|
(\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e)
|
|
(\e -> do
|
|
let
|
|
delay :: NominalDiffTime
|
|
delay = 1e-3 * 2 ^ logBackoff
|
|
$logWarnS "Sql" $ tshow (delay, e)
|
|
transactionUndo
|
|
threadDelay . round $ delay * 1e6
|
|
setSerializable' (succ logBackoff)
|
|
)
|
|
act'
|
|
|