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