37 lines
1.3 KiB
Haskell
37 lines
1.3 KiB
Haskell
module Utils.Sql
|
|
( setSerializable
|
|
) where
|
|
|
|
import ClassyPrelude.Yesod
|
|
|
|
import Database.PostgreSQL.Simple (SqlError(SqlError), sqlErrorHint)
|
|
import Control.Monad.Catch (MonadMask)
|
|
|
|
import Database.Persist.Sql
|
|
import Database.Persist.Sql.Raw.QQ
|
|
|
|
import Control.Retry
|
|
|
|
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 [logRetries suggestRetry logRetry] act'
|
|
where
|
|
policy :: RetryPolicyM (ReaderT SqlBackend m)
|
|
policy = fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6
|
|
|
|
suggestRetry :: SqlError -> ReaderT SqlBackend m Bool
|
|
suggestRetry SqlError{sqlErrorHint} = return $ "The transaction might succeed if retried." `isInfixOf` sqlErrorHint
|
|
|
|
logRetry :: Bool -- ^ Will retry
|
|
-> SqlError
|
|
-> RetryStatus
|
|
-> ReaderT SqlBackend m ()
|
|
logRetry shouldRetry err status = $logDebugS "SQL" . pack $ defaultLogMsg shouldRetry err status
|
|
|
|
act' :: RetryStatus -> ReaderT SqlBackend m a
|
|
act' RetryStatus{..}
|
|
| rsIterNumber == 0 = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act
|
|
| otherwise = transactionUndoWithIsolation Serializable *> act
|