{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Glue.Retry(
RetryOptions
, defaultRetryOptions
, retryingService
, retryAllowed
, retryInitialWaitTimeMs
, maximumRetries
, retryWaitTimeMultiplier
) where
import Control.Concurrent.Lifted
import Control.Exception.Lifted
import Control.Monad.Trans.Control
import Glue.Types
data RetryOptions a = RetryOptions {
retryAllowed :: a -> Bool,
retryInitialWaitTimeMs :: Int,
maximumRetries :: Int,
retryWaitTimeMultiplier :: Double
}
defaultRetryOptions :: RetryOptions a
defaultRetryOptions = RetryOptions {
retryAllowed = (\_ -> True)
, retryInitialWaitTimeMs = 0
, maximumRetries = 3
, retryWaitTimeMultiplier = 0
}
possibleAsyncException :: SomeException -> Maybe SomeAsyncException
possibleAsyncException = fromException
retryingService :: (MonadBaseControl IO m)
=> RetryOptions a
-> BasicService m a b
-> BasicService m a b
retryingService options service =
let catchHandler rc r e = case possibleAsyncException e of
Just ae -> throw ae
Nothing -> wait (rc + 1) >> attempt (rc + 1) r
attempt retryCount request = if (retryAllowed options) request && maxRetries > retryCount
then catch (service request) (catchHandler retryCount request)
else service request
maxRetries = maximumRetries options
wait retryCount = threadDelay $ round $ fromIntegral (retryInitialWaitTimeMs options) * ((retryWaitTimeMultiplier options) ^ retryCount)
in attempt 0