{-# LANGUAGE BangPatterns          #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE UnboxedTuples         #-}
{-# LANGUAGE ViewPatterns          #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Retry
-- Copyright   :  Ozgun Ataman <ozgun.ataman@soostone.com>
-- License     :  BSD3
--
-- Maintainer  :  Ozgun Ataman
-- Stability   :  provisional
--
-- This module exposes combinators that can wrap arbitrary monadic
-- actions. They run the action and potentially retry running it with
-- some configurable delay for a configurable number of times.
--
-- The express purpose of this library is to make it easier to work
-- with IO and especially network IO actions that often experience
-- temporary failure that warrant retrying of the original action. For
-- example, a database query may time out for a while, in which case
-- we should delay a bit and retry the query.
----------------------------------------------------------------------------


module Control.Retry
    (
      -- * Types and Operations
      RetryPolicyM (..)
    , RetryPolicy
    , retryPolicy
    , retryPolicyDefault
    , natTransformRetryPolicy
    , RetryAction (..)
    , toRetryAction
    , RetryStatus (..)
    , defaultRetryStatus
    , applyPolicy
    , applyAndDelay


    -- ** Lenses for 'RetryStatus'
    , rsIterNumberL
    , rsCumulativeDelayL
    , rsPreviousDelayL

    -- * Applying Retry Policies
    , retrying
    , retryingDynamic
    , recovering
    , recoveringDynamic
    , stepping
    , recoverAll
    , skipAsyncExceptions
    , logRetries
    , defaultLogMsg
    , retryOnError
    -- ** Resumable variants
    , resumeRetrying
    , resumeRetryingDynamic
    , resumeRecovering
    , resumeRecoveringDynamic
    , resumeRecoverAll

    -- * Retry Policies
    , constantDelay
    , exponentialBackoff
    , fullJitterBackoff
    , fibonacciBackoff
    , limitRetries

    -- * Policy Transformers
    , limitRetriesByDelay
    , limitRetriesByCumulativeDelay
    , capDelay

    -- * Development Helpers
    , simulatePolicy
    , simulatePolicyPP
    ) where

-------------------------------------------------------------------------------
import           Control.Applicative
import           Control.Concurrent
#if MIN_VERSION_base(4, 7, 0)
import           Control.Exception (AsyncException, SomeAsyncException)
#else
import           Control.Exception (AsyncException)
#endif
import           Control.Monad
import           Control.Monad.Catch
import           Control.Monad.Except
import           Control.Monad.IO.Class as MIO
import           Control.Monad.Trans.Class as TC
import           Control.Monad.Trans.Maybe
import           Control.Monad.Trans.State
import           Data.List (foldl')
import           Data.Maybe
import           GHC.Generics
import           GHC.Prim
import           GHC.Types (Int(I#))
import           System.Random
# if MIN_VERSION_base(4, 9, 0)
import           Data.Semigroup
# else
import           Data.Monoid
# endif
import           Prelude
-------------------------------------------------------------------------------


-------------------------------------------------------------------------------
-- | A 'RetryPolicyM' is a function that takes an 'RetryStatus' and
-- possibly returns a delay in microseconds.  Iteration numbers start
-- at zero and increase by one on each retry.  A *Nothing* return value from
-- the function implies we have reached the retry limit.
--
-- Please note that 'RetryPolicyM' is a 'Monoid'. You can collapse
-- multiple strategies into one using 'mappend' or '<>'. The semantics
-- of this combination are as follows:
--
-- 1. If either policy returns 'Nothing', the combined policy returns
-- 'Nothing'. This can be used to @inhibit@ after a number of retries,
-- for example.
--
-- 2. If both policies return a delay, the larger delay will be used.
-- This is quite natural when combining multiple policies to achieve a
-- certain effect.
--
-- Example:
--
-- One can easily define an exponential backoff policy with a limited
-- number of retries:
--
-- >> limitedBackoff = exponentialBackoff 50000 <> limitRetries 5
--
-- Naturally, 'mempty' will retry immediately (delay 0) for an
-- unlimited number of retries, forming the identity for the 'Monoid'.
--
-- The default retry policy 'retryPolicyDefault' implements a constant 50ms delay, up to 5 times:
--
-- >> retryPolicyDefault = constantDelay 50000 <> limitRetries 5
--
-- For anything more complex, just define your own 'RetryPolicyM':
--
-- >> myPolicy = retryPolicy $ \ rs -> if rsIterNumber rs > 10 then Just 1000 else Just 10000
--
-- Since 0.7.
newtype RetryPolicyM m = RetryPolicyM { forall (m :: * -> *).
RetryPolicyM m -> RetryStatus -> m (Maybe Int)
getRetryPolicyM :: RetryStatus -> m (Maybe Int) }


-- | Simplified 'RetryPolicyM' without any use of the monadic context in
-- determining policy. Mostly maintains backwards compatitibility with
-- type signatures pre-0.7.
type RetryPolicy = forall m . Monad m => RetryPolicyM m

-- | Default retry policy
retryPolicyDefault :: (Monad m) => RetryPolicyM m
retryPolicyDefault :: forall (m :: * -> *). Monad m => RetryPolicyM m
retryPolicyDefault = forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
50000 forall a. Semigroup a => a -> a -> a
<> Int -> forall (m :: * -> *). Monad m => RetryPolicyM m
limitRetries Int
5


-- Base 4.9.0 adds a Data.Semigroup module. This has fewer
-- dependencies than the semigroups package, so we're using base's
-- only if its available.
# if MIN_VERSION_base(4, 9, 0)
instance Monad m => Semigroup (RetryPolicyM m) where
  (RetryPolicyM RetryStatus -> m (Maybe Int)
a) <> :: RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
<> (RetryPolicyM RetryStatus -> m (Maybe Int)
b) = forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM forall a b. (a -> b) -> a -> b
$ \ RetryStatus
n -> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall a b. (a -> b) -> a -> b
$ do
    Int
a' <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ RetryStatus -> m (Maybe Int)
a RetryStatus
n
    Int
b' <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ RetryStatus -> m (Maybe Int)
b RetryStatus
n
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. Ord a => a -> a -> a
max Int
a' Int
b'


instance Monad m => Monoid (RetryPolicyM m) where
    mempty :: RetryPolicyM m
mempty = forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Int
0)
    mappend :: RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
mappend = forall a. Semigroup a => a -> a -> a
(<>)
# else
instance Monad m => Monoid (RetryPolicyM m) where
    mempty = retryPolicy $ const (Just 0)
    (RetryPolicyM a) `mappend` (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do
      a' <- MaybeT $ a n
      b' <- MaybeT $ b n
      return $! max a' b'
#endif


-------------------------------------------------------------------------------
-- | Applies a natural transformation to a policy to run a RetryPolicy
-- meant for the monad @m@ in the monad @n@ provided a transformation
-- from @m@ to @n@ is available. A common case is if you have a pure
-- policy, @RetryPolicyM Identity@ and want to use it to govern an
-- @IO@ computation you could write:
--
-- @
--   purePolicyInIO :: RetryPolicyM Identity -> RetryPolicyM IO
--   purePolicyInIO = natTransformRetryPolicy (pure . runIdentity)
-- @
natTransformRetryPolicy :: (forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n
natTransformRetryPolicy :: forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n
natTransformRetryPolicy forall a. m a -> n a
f (RetryPolicyM RetryStatus -> m (Maybe Int)
p) = forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM forall a b. (a -> b) -> a -> b
$ \RetryStatus
stat -> forall a. m a -> n a
f (RetryStatus -> m (Maybe Int)
p RetryStatus
stat)


-- | Modify the delay of a RetryPolicy.
-- Does not change whether or not a retry is performed.
modifyRetryPolicyDelay :: Functor m => (Int -> Int) -> RetryPolicyM m -> RetryPolicyM m
modifyRetryPolicyDelay :: forall (m :: * -> *).
Functor m =>
(Int -> Int) -> RetryPolicyM m -> RetryPolicyM m
modifyRetryPolicyDelay Int -> Int
f (RetryPolicyM RetryStatus -> m (Maybe Int)
p) = forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM forall a b. (a -> b) -> a -> b
$ \RetryStatus
stat -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Int
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetryStatus -> m (Maybe Int)
p RetryStatus
stat


-------------------------------------------------------------------------------
-- | How to handle a failed action.
data RetryAction
    = DontRetry
    -- ^ Don't retry (regardless of what the 'RetryPolicy' says).
    | ConsultPolicy
    -- ^ Retry if the 'RetryPolicy' says so, with the delay specified by the policy.
    | ConsultPolicyOverrideDelay Int
    -- ^ Retry if the 'RetryPolicy' says so, but override the policy's delay (number of microseconds).
      deriving (ReadPrec [RetryAction]
ReadPrec RetryAction
Int -> ReadS RetryAction
ReadS [RetryAction]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RetryAction]
$creadListPrec :: ReadPrec [RetryAction]
readPrec :: ReadPrec RetryAction
$creadPrec :: ReadPrec RetryAction
readList :: ReadS [RetryAction]
$creadList :: ReadS [RetryAction]
readsPrec :: Int -> ReadS RetryAction
$creadsPrec :: Int -> ReadS RetryAction
Read, Int -> RetryAction -> ShowS
[RetryAction] -> ShowS
RetryAction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RetryAction] -> ShowS
$cshowList :: [RetryAction] -> ShowS
show :: RetryAction -> String
$cshow :: RetryAction -> String
showsPrec :: Int -> RetryAction -> ShowS
$cshowsPrec :: Int -> RetryAction -> ShowS
Show, RetryAction -> RetryAction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RetryAction -> RetryAction -> Bool
$c/= :: RetryAction -> RetryAction -> Bool
== :: RetryAction -> RetryAction -> Bool
$c== :: RetryAction -> RetryAction -> Bool
Eq, forall x. Rep RetryAction x -> RetryAction
forall x. RetryAction -> Rep RetryAction x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RetryAction x -> RetryAction
$cfrom :: forall x. RetryAction -> Rep RetryAction x
Generic)


-- | Convert a boolean answer to the question "Should we retry?" into
-- a 'RetryAction'.
toRetryAction :: Bool -> RetryAction
toRetryAction :: Bool -> RetryAction
toRetryAction Bool
False = RetryAction
DontRetry
toRetryAction Bool
True = RetryAction
ConsultPolicy

-------------------------------------------------------------------------------
-- | Datatype with stats about retries made thus far.
data RetryStatus = RetryStatus
    { RetryStatus -> Int
rsIterNumber      :: !Int -- ^ Iteration number, where 0 is the first try
    , RetryStatus -> Int
rsCumulativeDelay :: !Int -- ^ Delay incurred so far from retries in microseconds
    , RetryStatus -> Maybe Int
rsPreviousDelay   :: !(Maybe Int) -- ^ Latest attempt's delay. Will always be Nothing on first run.
    } deriving (ReadPrec [RetryStatus]
ReadPrec RetryStatus
Int -> ReadS RetryStatus
ReadS [RetryStatus]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RetryStatus]
$creadListPrec :: ReadPrec [RetryStatus]
readPrec :: ReadPrec RetryStatus
$creadPrec :: ReadPrec RetryStatus
readList :: ReadS [RetryStatus]
$creadList :: ReadS [RetryStatus]
readsPrec :: Int -> ReadS RetryStatus
$creadsPrec :: Int -> ReadS RetryStatus
Read, Int -> RetryStatus -> ShowS
[RetryStatus] -> ShowS
RetryStatus -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RetryStatus] -> ShowS
$cshowList :: [RetryStatus] -> ShowS
show :: RetryStatus -> String
$cshow :: RetryStatus -> String
showsPrec :: Int -> RetryStatus -> ShowS
$cshowsPrec :: Int -> RetryStatus -> ShowS
Show, RetryStatus -> RetryStatus -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RetryStatus -> RetryStatus -> Bool
$c/= :: RetryStatus -> RetryStatus -> Bool
== :: RetryStatus -> RetryStatus -> Bool
$c== :: RetryStatus -> RetryStatus -> Bool
Eq, forall x. Rep RetryStatus x -> RetryStatus
forall x. RetryStatus -> Rep RetryStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RetryStatus x -> RetryStatus
$cfrom :: forall x. RetryStatus -> Rep RetryStatus x
Generic)


-------------------------------------------------------------------------------
-- | Initial, default retry status. Use fields or lenses to update.
defaultRetryStatus :: RetryStatus
defaultRetryStatus :: RetryStatus
defaultRetryStatus = Int -> Int -> Maybe Int -> RetryStatus
RetryStatus Int
0 Int
0 forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
rsIterNumberL :: Lens' RetryStatus Int
rsIterNumberL :: Lens' RetryStatus Int
rsIterNumberL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens RetryStatus -> Int
rsIterNumber (\RetryStatus
rs Int
x -> RetryStatus
rs { rsIterNumber :: Int
rsIterNumber = Int
x })
{-# INLINE rsIterNumberL #-}


-------------------------------------------------------------------------------
rsCumulativeDelayL :: Lens' RetryStatus Int
rsCumulativeDelayL :: Lens' RetryStatus Int
rsCumulativeDelayL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens RetryStatus -> Int
rsCumulativeDelay (\RetryStatus
rs Int
x -> RetryStatus
rs { rsCumulativeDelay :: Int
rsCumulativeDelay = Int
x })
{-# INLINE rsCumulativeDelayL #-}


-------------------------------------------------------------------------------
rsPreviousDelayL :: Lens' RetryStatus (Maybe Int)
rsPreviousDelayL :: Lens' RetryStatus (Maybe Int)
rsPreviousDelayL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens RetryStatus -> Maybe Int
rsPreviousDelay (\RetryStatus
rs Maybe Int
x -> RetryStatus
rs { rsPreviousDelay :: Maybe Int
rsPreviousDelay = Maybe Int
x })
{-# INLINE rsPreviousDelayL #-}



-------------------------------------------------------------------------------
-- | Apply policy on status to see what the decision would be.
-- 'Nothing' implies no retry, 'Just' returns updated status.
applyPolicy
    :: Monad m
    => RetryPolicyM m
    -> RetryStatus
    -> m (Maybe RetryStatus)
applyPolicy :: forall (m :: * -> *).
Monad m =>
RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyPolicy (RetryPolicyM RetryStatus -> m (Maybe Int)
policy) RetryStatus
s = do
    Maybe Int
res <- RetryStatus -> m (Maybe Int)
policy RetryStatus
s
    case Maybe Int
res of
      Just Int
delay -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! RetryStatus
          { rsIterNumber :: Int
rsIterNumber = RetryStatus -> Int
rsIterNumber RetryStatus
s forall a. Num a => a -> a -> a
+ Int
1
          , rsCumulativeDelay :: Int
rsCumulativeDelay = RetryStatus -> Int
rsCumulativeDelay RetryStatus
s Int -> Int -> Int
`boundedPlus` Int
delay
          , rsPreviousDelay :: Maybe Int
rsPreviousDelay = forall a. a -> Maybe a
Just Int
delay }
      Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing


-------------------------------------------------------------------------------
-- | Apply policy and delay by its amount if it results in a retry.
-- Return updated status.
applyAndDelay
    :: MIO.MonadIO m
    => RetryPolicyM m
    -> RetryStatus
    -> m (Maybe RetryStatus)
applyAndDelay :: forall (m :: * -> *).
MonadIO m =>
RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyAndDelay RetryPolicyM m
policy RetryStatus
s = do
    Maybe RetryStatus
chk <- forall (m :: * -> *).
Monad m =>
RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyPolicy RetryPolicyM m
policy RetryStatus
s
    case Maybe RetryStatus
chk of
      Just RetryStatus
rs -> do
        case RetryStatus -> Maybe Int
rsPreviousDelay RetryStatus
rs of
          Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just Int
delay -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
delay
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just RetryStatus
rs)
      Maybe RetryStatus
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing



-------------------------------------------------------------------------------
-- | Helper for making simplified policies that don't use the monadic
-- context.
retryPolicy :: (Monad m) => (RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy :: forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy RetryStatus -> Maybe Int
f = forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM forall a b. (a -> b) -> a -> b
$ \ RetryStatus
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (RetryStatus -> Maybe Int
f RetryStatus
s)


-------------------------------------------------------------------------------
-- | Retry immediately, but only up to @n@ times.
limitRetries
    :: Int
    -- ^ Maximum number of retries.
    -> RetryPolicy
limitRetries :: Int -> forall (m :: * -> *). Monad m => RetryPolicyM m
limitRetries Int
i = forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy forall a b. (a -> b) -> a -> b
$ \ RetryStatus { rsIterNumber :: RetryStatus -> Int
rsIterNumber = Int
n} -> if Int
n forall a. Ord a => a -> a -> Bool
>= Int
i then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Int
0


-------------------------------------------------------------------------------
-- | Add an upperbound to a policy such that once the given time-delay
-- amount *per try* has been reached or exceeded, the policy will stop
-- retrying and fail. If you need to stop retrying once *cumulative*
-- delay reaches a time-delay amount, use
-- 'limitRetriesByCumulativeDelay'
limitRetriesByDelay
    :: Monad m
    => Int
    -- ^ Time-delay limit in microseconds.
    -> RetryPolicyM m
    -> RetryPolicyM m
limitRetriesByDelay :: forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByDelay Int
i RetryPolicyM m
p = forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM forall a b. (a -> b) -> a -> b
$ \ RetryStatus
n ->
    (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int
limit) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
RetryPolicyM m -> RetryStatus -> m (Maybe Int)
getRetryPolicyM RetryPolicyM m
p RetryStatus
n
  where
    limit :: Int -> Maybe Int
limit Int
delay = if Int
delay forall a. Ord a => a -> a -> Bool
>= Int
i then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Int
delay


-------------------------------------------------------------------------------
-- | Add an upperbound to a policy such that once the cumulative delay
-- over all retries has reached or exceeded the given limit, the
-- policy will stop retrying and fail.
limitRetriesByCumulativeDelay
    :: Monad m
    => Int
    -- ^ Time-delay limit in microseconds.
    -> RetryPolicyM m
    -> RetryPolicyM m
limitRetriesByCumulativeDelay :: forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay Int
cumulativeLimit RetryPolicyM m
p = forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM forall a b. (a -> b) -> a -> b
$ \ RetryStatus
stat ->
  (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RetryStatus -> Int -> Maybe Int
limit RetryStatus
stat) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
RetryPolicyM m -> RetryStatus -> m (Maybe Int)
getRetryPolicyM RetryPolicyM m
p RetryStatus
stat
  where
    limit :: RetryStatus -> Int -> Maybe Int
limit RetryStatus
status Int
curDelay
      | RetryStatus -> Int
rsCumulativeDelay RetryStatus
status Int -> Int -> Int
`boundedPlus` Int
curDelay forall a. Ord a => a -> a -> Bool
> Int
cumulativeLimit = forall a. Maybe a
Nothing
      | Bool
otherwise = forall a. a -> Maybe a
Just Int
curDelay


-------------------------------------------------------------------------------
-- | Implement a constant delay with unlimited retries.
constantDelay
    :: (Monad m)
    => Int
    -- ^ Base delay in microseconds
    -> RetryPolicyM m
constantDelay :: forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
delay = forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy (forall a b. a -> b -> a
const (forall a. a -> Maybe a
Just Int
delay))


-------------------------------------------------------------------------------
-- | Grow delay exponentially each iteration.  Each delay will
-- increase by a factor of two.
exponentialBackoff
    :: (Monad m)
    => Int
    -- ^ Base delay in microseconds
    -> RetryPolicyM m
exponentialBackoff :: forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
exponentialBackoff Int
base = forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy forall a b. (a -> b) -> a -> b
$ \ RetryStatus { rsIterNumber :: RetryStatus -> Int
rsIterNumber = Int
n } ->
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Int
base Int -> Int -> Int
`boundedMult` Int -> Int -> Int
boundedPow Int
2 Int
n

-------------------------------------------------------------------------------
-- | FullJitter exponential backoff as explained in AWS Architecture
-- Blog article.
--
-- @http:\/\/www.awsarchitectureblog.com\/2015\/03\/backoff.html@
--
-- temp = min(cap, base * 2 ** attempt)
--
-- sleep = temp \/ 2 + random_between(0, temp \/ 2)
fullJitterBackoff
    :: (MonadIO m)
    => Int
    -- ^ Base delay in microseconds
    -> RetryPolicyM m
fullJitterBackoff :: forall (m :: * -> *). MonadIO m => Int -> RetryPolicyM m
fullJitterBackoff Int
base = forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM forall a b. (a -> b) -> a -> b
$ \ RetryStatus { rsIterNumber :: RetryStatus -> Int
rsIterNumber = Int
n } -> do
  let d :: Int
d = (Int
base Int -> Int -> Int
`boundedMult` Int -> Int -> Int
boundedPow Int
2 Int
n) forall a. Integral a => a -> a -> a
`div` Int
2
  Int
rand <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, Int
d)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! Int
d Int -> Int -> Int
`boundedPlus` Int
rand


-------------------------------------------------------------------------------
-- | Implement Fibonacci backoff.
fibonacciBackoff
    :: (Monad m)
    => Int
    -- ^ Base delay in microseconds
    -> RetryPolicyM m
fibonacciBackoff :: forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
fibonacciBackoff Int
base = forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy forall a b. (a -> b) -> a -> b
$ \RetryStatus { rsIterNumber :: RetryStatus -> Int
rsIterNumber = Int
n } ->
  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {t}. (Eq t, Num t) => t -> (Int, Int) -> Int
fib (Int
n forall a. Num a => a -> a -> a
+ Int
1) (Int
0, Int
base)
    where
      fib :: t -> (Int, Int) -> Int
fib t
0 (Int
a, Int
_) = Int
a
      fib !t
m (!Int
a, !Int
b) = t -> (Int, Int) -> Int
fib (t
mforall a. Num a => a -> a -> a
-t
1) (Int
b, Int
a Int -> Int -> Int
`boundedPlus` Int
b)


-------------------------------------------------------------------------------
-- | Set a time-upperbound for any delays that may be directed by the
-- given policy.  This function does not terminate the retrying.  The policy
-- `capDelay maxDelay (exponentialBackoff n)` will never stop retrying.  It
-- will reach a state where it retries forever with a delay of `maxDelay`
-- between each one.  To get termination you need to use one of the
-- 'limitRetries' function variants.
capDelay
    :: Monad m
    => Int
    -- ^ A maximum delay in microseconds
    -> RetryPolicyM m
    -> RetryPolicyM m
capDelay :: forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> RetryPolicyM m
capDelay Int
limit RetryPolicyM m
p = forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM forall a b. (a -> b) -> a -> b
$ \ RetryStatus
n ->
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Ord a => a -> a -> a
min Int
limit) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
RetryPolicyM m -> RetryStatus -> m (Maybe Int)
getRetryPolicyM RetryPolicyM m
p RetryStatus
n


-------------------------------------------------------------------------------
-- | Retry combinator for actions that don't raise exceptions, but
-- signal in their type the outcome has failed. Examples are the
-- 'Maybe', 'Either' and 'EitherT' monads.
--
-- Let's write a function that always fails and watch this combinator
-- retry it 5 additional times following the initial run:
--
-- >>> import Data.Maybe
-- >>> let f _ = putStrLn "Running action" >> return Nothing
-- >>> retrying retryPolicyDefault (const $ return . isNothing) f
-- Running action
-- Running action
-- Running action
-- Running action
-- Running action
-- Running action
-- Nothing
--
-- Note how the latest failing result is returned after all retries
-- have been exhausted.
retrying  :: MonadIO m
          => RetryPolicyM m
          -> (RetryStatus -> b -> m Bool)
          -- ^ An action to check whether the result should be retried.
          -- If True, we delay and retry the operation.
          -> (RetryStatus -> m b)
          -- ^ Action to run
          -> m b
retrying :: forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying = forall (m :: * -> *) b.
MonadIO m =>
RetryStatus
-> RetryPolicyM m
-> (RetryStatus -> b -> m Bool)
-> (RetryStatus -> m b)
-> m b
resumeRetrying RetryStatus
defaultRetryStatus


-------------------------------------------------------------------------------
-- | A variant of 'retrying' that allows specifying the initial
-- 'RetryStatus' so that the retrying operation may pick up where it left
-- off in regards to its retry policy.
resumeRetrying
    :: MonadIO m
    => RetryStatus
    -> RetryPolicyM m
    -> (RetryStatus -> b -> m Bool)
    -- ^ An action to check whether the result should be retried.
    -- If True, we delay and retry the operation.
    -> (RetryStatus -> m b)
    -- ^ Action to run
    -> m b
resumeRetrying :: forall (m :: * -> *) b.
MonadIO m =>
RetryStatus
-> RetryPolicyM m
-> (RetryStatus -> b -> m Bool)
-> (RetryStatus -> m b)
-> m b
resumeRetrying RetryStatus
retryStatus RetryPolicyM m
policy RetryStatus -> b -> m Bool
chk RetryStatus -> m b
f =
    forall (m :: * -> *) b.
MonadIO m =>
RetryStatus
-> RetryPolicyM m
-> (RetryStatus -> b -> m RetryAction)
-> (RetryStatus -> m b)
-> m b
resumeRetryingDynamic
      RetryStatus
retryStatus
      RetryPolicyM m
policy
      (\RetryStatus
rs -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> RetryAction
toRetryAction forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryStatus -> b -> m Bool
chk RetryStatus
rs)
      RetryStatus -> m b
f


-------------------------------------------------------------------------------
-- | Same as 'retrying', but with the ability to override
-- the delay of the retry policy based on information
-- obtained after initiation.
--
-- For example, if the action to run is a HTTP request that
-- turns out to fail with a status code 429 ("too many requests"),
-- the response may contain a "Retry-After" HTTP header which
-- specifies the number of seconds
-- the client should wait until performing the next request.
-- This function allows overriding the delay calculated by the given
-- retry policy with the delay extracted from this header value.
--
-- In other words, given an arbitrary 'RetryPolicyM' @rp@, the
-- following invocation will always delay by 1000 microseconds:
--
-- > retryingDynamic rp (\_ _ -> return $ ConsultPolicyOverrideDelay 1000) f
--
-- Note that a 'RetryPolicy's decision to /not/ perform a retry
-- cannot be overridden. Ie. /when/ to /stop/ retrying is always decided
-- by the retry policy, regardless of the returned 'RetryAction' value.
retryingDynamic
    :: MonadIO m
    => RetryPolicyM m
    -> (RetryStatus -> b -> m RetryAction)
    -- ^ An action to check whether the result should be retried.
    -- The returned 'RetryAction' determines how/if a retry is performed.
    -- See documentation on 'RetryAction'.
    -> (RetryStatus -> m b)
    -- ^ Action to run
    -> m b
retryingDynamic :: forall (m :: * -> *) b.
MonadIO m =>
RetryPolicyM m
-> (RetryStatus -> b -> m RetryAction)
-> (RetryStatus -> m b)
-> m b
retryingDynamic = forall (m :: * -> *) b.
MonadIO m =>
RetryStatus
-> RetryPolicyM m
-> (RetryStatus -> b -> m RetryAction)
-> (RetryStatus -> m b)
-> m b
resumeRetryingDynamic RetryStatus
defaultRetryStatus


-------------------------------------------------------------------------------
-- | A variant of 'retryingDynamic' that allows specifying the initial
-- 'RetryStatus' so that a retrying operation may pick up where it left off
-- in regards to its retry policy.
resumeRetryingDynamic
    :: MonadIO m
    => RetryStatus
    -> RetryPolicyM m
    -> (RetryStatus -> b -> m RetryAction)
    -- ^ An action to check whether the result should be retried.
    -- The returned 'RetryAction' determines how/if a retry is performed.
    -- See documentation on 'RetryAction'.
    -> (RetryStatus -> m b)
    -- ^ Action to run
    -> m b
resumeRetryingDynamic :: forall (m :: * -> *) b.
MonadIO m =>
RetryStatus
-> RetryPolicyM m
-> (RetryStatus -> b -> m RetryAction)
-> (RetryStatus -> m b)
-> m b
resumeRetryingDynamic RetryStatus
retryStatus RetryPolicyM m
policy RetryStatus -> b -> m RetryAction
chk RetryStatus -> m b
f = RetryStatus -> m b
go RetryStatus
retryStatus
  where
    go :: RetryStatus -> m b
go RetryStatus
s = do
        b
res <- RetryStatus -> m b
f RetryStatus
s
        let consultPolicy :: RetryPolicyM m -> m b
consultPolicy RetryPolicyM m
policy' = do
              Maybe RetryStatus
rs <- forall (m :: * -> *).
MonadIO m =>
RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyAndDelay RetryPolicyM m
policy' RetryStatus
s
              case Maybe RetryStatus
rs of
                Maybe RetryStatus
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return b
res
                Just RetryStatus
rs' -> RetryStatus -> m b
go forall a b. (a -> b) -> a -> b
$! RetryStatus
rs'
        RetryAction
chk' <- RetryStatus -> b -> m RetryAction
chk RetryStatus
s b
res
        case RetryAction
chk' of
          RetryAction
DontRetry -> forall (m :: * -> *) a. Monad m => a -> m a
return b
res
          RetryAction
ConsultPolicy -> RetryPolicyM m -> m b
consultPolicy RetryPolicyM m
policy
          ConsultPolicyOverrideDelay Int
delay ->
            RetryPolicyM m -> m b
consultPolicy forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Functor m =>
(Int -> Int) -> RetryPolicyM m -> RetryPolicyM m
modifyRetryPolicyDelay (forall a b. a -> b -> a
const Int
delay) RetryPolicyM m
policy


-------------------------------------------------------------------------------
-- | Retry ALL exceptions that may be raised. To be used with caution;
-- this matches the exception on 'SomeException'. Note that this
-- handler explicitly does not handle 'AsyncException' nor
-- 'SomeAsyncException' (for versions of base >= 4.7). It is not a
-- good idea to catch async exceptions as it can result in hanging
-- threads and programs. Note that if you just throw an exception to
-- this thread that does not descend from SomeException, recoverAll
-- will not catch it.
--
-- See how the action below is run once and retried 5 more times
-- before finally failing for good:
--
-- >>> let f _ = putStrLn "Running action" >> error "this is an error"
-- >>> recoverAll retryPolicyDefault f
-- Running action
-- Running action
-- Running action
-- Running action
-- Running action
-- Running action
-- *** Exception: this is an error
recoverAll
#if MIN_VERSION_exceptions(0, 6, 0)
         :: (MonadIO m, MonadMask m)
#else
         :: (MonadIO m, MonadCatch m)
#endif
         => RetryPolicyM m
         -> (RetryStatus -> m a)
         -> m a
recoverAll :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus -> RetryPolicyM m -> (RetryStatus -> m a) -> m a
resumeRecoverAll RetryStatus
defaultRetryStatus


-------------------------------------------------------------------------------
-- | A variant of 'recoverAll' that allows specifying the initial
-- 'RetryStatus' so that a recovering operation may pick up where it left
-- off in regards to its retry policy.
resumeRecoverAll
#if MIN_VERSION_exceptions(0, 6, 0)
         :: (MonadIO m, MonadMask m)
#else
         :: (MonadIO m, MonadCatch m)
#endif
         => RetryStatus
         -> RetryPolicyM m
         -> (RetryStatus -> m a)
         -> m a
resumeRecoverAll :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus -> RetryPolicyM m -> (RetryStatus -> m a) -> m a
resumeRecoverAll RetryStatus
retryStatus RetryPolicyM m
set RetryStatus -> m a
f = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m Bool]
-> (RetryStatus -> m a)
-> m a
resumeRecovering RetryStatus
retryStatus RetryPolicyM m
set [RetryStatus -> Handler m Bool]
handlers RetryStatus -> m a
f
    where
      handlers :: [RetryStatus -> Handler m Bool]
handlers = forall (m :: * -> *). MonadIO m => [RetryStatus -> Handler m Bool]
skipAsyncExceptions forall a. [a] -> [a] -> [a]
++ [forall {m :: * -> *} {p}. Monad m => p -> Handler m Bool
h]
      h :: p -> Handler m Bool
h p
_ = forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \ (SomeException
_ :: SomeException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True


-------------------------------------------------------------------------------
-- | List of pre-made handlers that will skip retries on
-- 'AsyncException' and 'SomeAsyncException'. Append your handlers to
-- this list as a convenient way to make sure you're not catching
-- async exceptions like user interrupt.
skipAsyncExceptions
    :: ( MonadIO m
       )
    => [RetryStatus -> Handler m Bool]
skipAsyncExceptions :: forall (m :: * -> *). MonadIO m => [RetryStatus -> Handler m Bool]
skipAsyncExceptions = forall {p}. [p -> Handler m Bool]
handlers
  where
    asyncH :: p -> Handler m Bool
asyncH p
_ = forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \ (AsyncException
_ :: AsyncException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
#if MIN_VERSION_base(4, 7, 0)
    someAsyncH :: p -> Handler m Bool
someAsyncH p
_ = forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \(SomeAsyncException
_ :: SomeAsyncException) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    handlers :: [p -> Handler m Bool]
handlers = [forall {m :: * -> *} {p}. Monad m => p -> Handler m Bool
asyncH, forall {m :: * -> *} {p}. Monad m => p -> Handler m Bool
someAsyncH]
#else
    handlers = [asyncH]
#endif


-------------------------------------------------------------------------------
-- | Run an action and recover from a raised exception by potentially
-- retrying the action a number of times. Note that if you're going to
-- use a handler for 'SomeException', you should add explicit cases
-- *earlier* in the list of handlers to reject 'AsyncException' and
-- 'SomeAsyncException', as catching these can cause thread and
-- program hangs. 'recoverAll' already does this for you so if you
-- just plan on catching 'SomeException', you may as well use
-- 'recoverAll'
recovering
#if MIN_VERSION_exceptions(0, 6, 0)
    :: (MonadIO m, MonadMask m)
#else
    :: (MonadIO m, MonadCatch m)
#endif
    => RetryPolicyM m
    -- ^ Just use 'retryPolicyDefault' for default settings
    -> [RetryStatus -> Handler m Bool]
    -- ^ Should a given exception be retried? Action will be
    -- retried if this returns True *and* the policy allows it.
    -- This action will be consulted first even if the policy
    -- later blocks it.
    -> (RetryStatus -> m a)
    -- ^ Action to perform
    -> m a
recovering :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m Bool]
-> (RetryStatus -> m a)
-> m a
resumeRecovering RetryStatus
defaultRetryStatus


-------------------------------------------------------------------------------
-- | A variant of 'recovering' that allows specifying the initial
-- 'RetryStatus' so that a recovering operation may pick up where it left
-- off in regards to its retry policy.
resumeRecovering
#if MIN_VERSION_exceptions(0, 6, 0)
    :: (MonadIO m, MonadMask m)
#else
    :: (MonadIO m, MonadCatch m)
#endif
    => RetryStatus
    -> RetryPolicyM m
    -- ^ Just use 'retryPolicyDefault' for default settings
    -> [(RetryStatus -> Handler m Bool)]
    -- ^ Should a given exception be retried? Action will be
    -- retried if this returns True *and* the policy allows it.
    -- This action will be consulted first even if the policy
    -- later blocks it.
    -> (RetryStatus -> m a)
    -- ^ Action to perform
    -> m a
resumeRecovering :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m Bool]
-> (RetryStatus -> m a)
-> m a
resumeRecovering RetryStatus
retryStatus RetryPolicyM m
policy [RetryStatus -> Handler m Bool]
hs RetryStatus -> m a
f =
    forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m RetryAction]
-> (RetryStatus -> m a)
-> m a
resumeRecoveringDynamic RetryStatus
retryStatus RetryPolicyM m
policy [RetryStatus -> Handler m RetryAction]
hs' RetryStatus -> m a
f
  where
    hs' :: [RetryStatus -> Handler m RetryAction]
hs' = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> RetryAction
toRetryAction forall b c a. (b -> c) -> (a -> b) -> a -> c
.) [RetryStatus -> Handler m Bool]
hs


-------------------------------------------------------------------------------
-- | The difference between this and 'recovering' is the same as
--  the difference between 'retryingDynamic' and 'retrying'.
recoveringDynamic
#if MIN_VERSION_exceptions(0, 6, 0)
    :: (MonadIO m, MonadMask m)
#else
    :: (MonadIO m, MonadCatch m)
#endif
    => RetryPolicyM m
    -- ^ Just use 'retryPolicyDefault' for default settings
    -> [RetryStatus -> Handler m RetryAction]
    -- ^ Should a given exception be retried? Action will be
    -- retried if this returns either 'ConsultPolicy' or
    -- 'ConsultPolicyOverrideDelay' *and* the policy allows it.
    -- This action will be consulted first even if the policy
    -- later blocks it.
    -> (RetryStatus -> m a)
    -- ^ Action to perform
    -> m a
recoveringDynamic :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m RetryAction]
-> (RetryStatus -> m a)
-> m a
recoveringDynamic = forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m RetryAction]
-> (RetryStatus -> m a)
-> m a
resumeRecoveringDynamic RetryStatus
defaultRetryStatus


-------------------------------------------------------------------------------
-- | A variant of 'recoveringDynamic' that allows specifying the initial
-- 'RetryStatus' so that a recovering operation may pick up where it left
-- off in regards to its retry policy.
resumeRecoveringDynamic
#if MIN_VERSION_exceptions(0, 6, 0)
    :: (MonadIO m, MonadMask m)
#else
    :: (MonadIO m, MonadCatch m)
#endif
    => RetryStatus
    -> RetryPolicyM m
    -- ^ Just use 'retryPolicyDefault' for default settings
    -> [(RetryStatus -> Handler m RetryAction)]
    -- ^ Should a given exception be retried? Action will be
    -- retried if this returns either 'ConsultPolicy' or
    -- 'ConsultPolicyOverrideDelay' *and* the policy allows it.
    -- This action will be consulted first even if the policy
    -- later blocks it.
    -> (RetryStatus -> m a)
    -- ^ Action to perform
    -> m a
resumeRecoveringDynamic :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m RetryAction]
-> (RetryStatus -> m a)
-> m a
resumeRecoveringDynamic RetryStatus
retryStatus RetryPolicyM m
policy [RetryStatus -> Handler m RetryAction]
hs RetryStatus -> m a
f = forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> forall {b}. (m a -> m b) -> RetryStatus -> m b
go forall a. m a -> m a
restore RetryStatus
retryStatus
    where
      go :: (m a -> m b) -> RetryStatus -> m b
go m a -> m b
restore = RetryStatus -> m b
loop
        where
          loop :: RetryStatus -> m b
loop RetryStatus
s = do
            Either SomeException b
r <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ m a -> m b
restore (RetryStatus -> m a
f RetryStatus
s)
            case Either SomeException b
r of
              Right b
x -> forall (m :: * -> *) a. Monad m => a -> m a
return b
x
              Left SomeException
e -> SomeException -> [RetryStatus -> Handler m RetryAction] -> m b
recover (SomeException
e :: SomeException) [RetryStatus -> Handler m RetryAction]
hs
            where
              recover :: SomeException -> [RetryStatus -> Handler m RetryAction] -> m b
recover SomeException
e [] = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
              recover SomeException
e (((forall a b. (a -> b) -> a -> b
$ RetryStatus
s) -> Handler e -> m RetryAction
h) : [RetryStatus -> Handler m RetryAction]
hs')
                | Just e
e' <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = do
                    let consultPolicy :: RetryPolicyM m -> m b
consultPolicy RetryPolicyM m
policy' = do
                          Maybe RetryStatus
rs <- forall (m :: * -> *).
MonadIO m =>
RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyAndDelay RetryPolicyM m
policy' RetryStatus
s
                          case Maybe RetryStatus
rs of
                            Just RetryStatus
rs' -> RetryStatus -> m b
loop forall a b. (a -> b) -> a -> b
$! RetryStatus
rs'
                            Maybe RetryStatus
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e'
                    RetryAction
chk <- e -> m RetryAction
h e
e'
                    case RetryAction
chk of
                      RetryAction
DontRetry -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e'
                      RetryAction
ConsultPolicy -> RetryPolicyM m -> m b
consultPolicy RetryPolicyM m
policy
                      ConsultPolicyOverrideDelay Int
delay ->
                        RetryPolicyM m -> m b
consultPolicy forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Functor m =>
(Int -> Int) -> RetryPolicyM m -> RetryPolicyM m
modifyRetryPolicyDelay (forall a b. a -> b -> a
const Int
delay) RetryPolicyM m
policy
                | Bool
otherwise = SomeException -> [RetryStatus -> Handler m RetryAction] -> m b
recover SomeException
e [RetryStatus -> Handler m RetryAction]
hs'


-------------------------------------------------------------------------------
-- | A version of 'recovering' that tries to run the action only a
-- single time. The control will return immediately upon both success
-- and failure. Useful for implementing retry logic in distributed
-- queues and similar external-interfacing systems.
stepping
#if MIN_VERSION_exceptions(0, 6, 0)
    :: (MonadIO m, MonadMask m)
#else
    :: (MonadIO m, MonadCatch m)
#endif
    => RetryPolicyM m
    -- ^ Just use 'retryPolicyDefault' for default settings
    -> [RetryStatus -> Handler m Bool]
    -- ^ Should a given exception be retried? Action will be
    -- retried if this returns True *and* the policy allows it.
    -- This action will be consulted first even if the policy
    -- later blocks it.
    -> (RetryStatus -> m ())
    -- ^ Action to run with updated status upon failure.
    -> (RetryStatus -> m a)
    -- ^ Main action to perform with current status.
    -> RetryStatus
    -- ^ Current status of this step
    -> m (Maybe a)
stepping :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool]
-> (RetryStatus -> m ())
-> (RetryStatus -> m a)
-> RetryStatus
-> m (Maybe a)
stepping RetryPolicyM m
policy [RetryStatus -> Handler m Bool]
hs RetryStatus -> m ()
schedule RetryStatus -> m a
f RetryStatus
s = do
    Either SomeException a
r <- forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try forall a b. (a -> b) -> a -> b
$ RetryStatus -> m a
f RetryStatus
s
    case Either SomeException a
r of
      Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just a
x
      Left SomeException
e -> forall {a}.
SomeException -> [RetryStatus -> Handler m Bool] -> m (Maybe a)
recover (SomeException
e :: SomeException) [RetryStatus -> Handler m Bool]
hs
    where
      recover :: SomeException -> [RetryStatus -> Handler m Bool] -> m (Maybe a)
recover SomeException
e [] = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
      recover SomeException
e (((forall a b. (a -> b) -> a -> b
$ RetryStatus
s) -> Handler e -> m Bool
h) : [RetryStatus -> Handler m Bool]
hs')
        | Just e
e' <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = do
            Bool
chk <- e -> m Bool
h e
e'
            case Bool
chk of
              Bool
True -> do
                Maybe RetryStatus
res <- forall (m :: * -> *).
Monad m =>
RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyPolicy RetryPolicyM m
policy RetryStatus
s
                case Maybe RetryStatus
res of
                  Just RetryStatus
rs -> do
                    RetryStatus -> m ()
schedule forall a b. (a -> b) -> a -> b
$! RetryStatus
rs
                    forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                  Maybe RetryStatus
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e'
              Bool
False -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e'
        | Bool
otherwise = SomeException -> [RetryStatus -> Handler m Bool] -> m (Maybe a)
recover SomeException
e [RetryStatus -> Handler m Bool]
hs'


-------------------------------------------------------------------------------
-- | Helper function for constructing handler functions of the form required
-- by 'recovering'.
logRetries
    :: ( Monad m
       , Exception e)
    => (e -> m Bool)
    -- ^ Test for whether action is to be retried
    -> (Bool -> e -> RetryStatus -> m ())
    -- ^ How to report the generated warning message. Boolean is
    -- whether it's being retried or crashed.
    -> RetryStatus
    -- ^ Retry number
    -> Handler m Bool
logRetries :: forall (m :: * -> *) e.
(Monad m, Exception e) =>
(e -> m Bool)
-> (Bool -> e -> RetryStatus -> m ())
-> RetryStatus
-> Handler m Bool
logRetries e -> m Bool
test Bool -> e -> RetryStatus -> m ()
reporter RetryStatus
status = forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall a b. (a -> b) -> a -> b
$ \ e
err -> do
    Bool
result <- e -> m Bool
test e
err
    Bool -> e -> RetryStatus -> m ()
reporter Bool
result e
err RetryStatus
status
    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
result

-- | For use with 'logRetries'.
defaultLogMsg :: (Exception e) => Bool -> e -> RetryStatus -> String
defaultLogMsg :: forall e. Exception e => Bool -> e -> RetryStatus -> String
defaultLogMsg Bool
shouldRetry e
err RetryStatus
status =
    String
"[retry:" forall a. Semigroup a => a -> a -> a
<> String
iter forall a. Semigroup a => a -> a -> a
<> String
"] Encountered " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show e
err forall a. Semigroup a => a -> a -> a
<> String
". " forall a. Semigroup a => a -> a -> a
<> String
nextMsg
  where
    iter :: String
iter = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ RetryStatus -> Int
rsIterNumber RetryStatus
status
    nextMsg :: String
nextMsg = if Bool
shouldRetry then String
"Retrying." else String
"Crashing."


-------------------------------------------------------------------------------
retryOnError
    :: (Functor m, MonadIO m, MonadError e m)
    => RetryPolicyM m
    -- ^ Policy
    -> (RetryStatus -> e -> m Bool)
    -- ^ Should an error be retried?
    -> (RetryStatus -> m a)
    -- ^ Action to perform
    -> m a
retryOnError :: forall (m :: * -> *) e a.
(Functor m, MonadIO m, MonadError e m) =>
RetryPolicyM m
-> (RetryStatus -> e -> m Bool) -> (RetryStatus -> m a) -> m a
retryOnError RetryPolicyM m
policy RetryStatus -> e -> m Bool
chk RetryStatus -> m a
f = RetryStatus -> m a
go RetryStatus
defaultRetryStatus
  where
    go :: RetryStatus -> m a
go RetryStatus
stat = do
      Either (e, Bool) a
res <- (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetryStatus -> m a
f RetryStatus
stat) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\e
e -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e
e, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetryStatus -> e -> m Bool
chk RetryStatus
stat e
e)
      case Either (e, Bool) a
res of
        Right a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Left (e
e, Bool
True) -> do
          Maybe RetryStatus
mstat' <- forall (m :: * -> *).
MonadIO m =>
RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyAndDelay RetryPolicyM m
policy RetryStatus
stat
          case Maybe RetryStatus
mstat' of
            Just RetryStatus
stat' -> do
              RetryStatus -> m a
go forall a b. (a -> b) -> a -> b
$! RetryStatus
stat'
            Maybe RetryStatus
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
        Left (e
e, Bool
False) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e


-------------------------------------------------------------------------------
-- | Run given policy up to N iterations and gather results. In the
-- pair, the @Int@ is the iteration number and the @Maybe Int@ is the
-- delay in microseconds.
simulatePolicy :: Monad m => Int -> RetryPolicyM m -> m [(Int, Maybe Int)]
simulatePolicy :: forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> m [(Int, Maybe Int)]
simulatePolicy Int
n (RetryPolicyM RetryStatus -> m (Maybe Int)
f) = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT RetryStatus
defaultRetryStatus forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Int
n] forall a b. (a -> b) -> a -> b
$ \Int
i -> do
  RetryStatus
stat <- forall (m :: * -> *) s. Monad m => StateT s m s
get
  Maybe Int
delay <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
TC.lift (RetryStatus -> m (Maybe Int)
f RetryStatus
stat)
  forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put forall a b. (a -> b) -> a -> b
$! RetryStatus
stat
    { rsIterNumber :: Int
rsIterNumber = Int
i forall a. Num a => a -> a -> a
+ Int
1
    , rsCumulativeDelay :: Int
rsCumulativeDelay = RetryStatus -> Int
rsCumulativeDelay RetryStatus
stat Int -> Int -> Int
`boundedPlus` forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
delay
    , rsPreviousDelay :: Maybe Int
rsPreviousDelay = Maybe Int
delay
    }
  forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, Maybe Int
delay)


-------------------------------------------------------------------------------
-- | Run given policy up to N iterations and pretty print results on
-- the console.
simulatePolicyPP :: Int -> RetryPolicyM IO -> IO ()
simulatePolicyPP :: Int -> RetryPolicyM IO -> IO ()
simulatePolicyPP Int
n RetryPolicyM IO
p = do
    [(Int, Maybe Int)]
ps <- forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> m [(Int, Maybe Int)]
simulatePolicy Int
n RetryPolicyM IO
p
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, Maybe Int)]
ps forall a b. (a -> b) -> a -> b
$ \ (Int
iterNo, Maybe Int
res) -> String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
      forall a. Show a => a -> String
show Int
iterNo forall a. Semigroup a => a -> a -> a
<> String
": " forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Inhibit" forall a. (Integral a, Show a) => a -> String
ppTime Maybe Int
res
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Total cumulative delay would be: " forall a. Semigroup a => a -> a -> a
<>
      forall a. (Integral a, Show a) => a -> String
ppTime ([Int] -> Int
boundedSum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> b
snd [(Int, Maybe Int)]
ps)


-------------------------------------------------------------------------------
ppTime :: (Integral a, Show a) => a -> String
ppTime :: forall a. (Integral a, Show a) => a -> String
ppTime a
n | a
n forall a. Ord a => a -> a -> Bool
< a
1000 = forall a. Show a => a -> String
show a
n forall a. Semigroup a => a -> a -> a
<> String
"us"
         | a
n forall a. Ord a => a -> a -> Bool
< a
1000000 = forall a. Show a => a -> String
show ((forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n forall a. Fractional a => a -> a -> a
/ Double
1000) :: Double) forall a. Semigroup a => a -> a -> a
<> String
"ms"
         | Bool
otherwise = forall a. Show a => a -> String
show ((forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n forall a. Fractional a => a -> a -> a
/ Double
1000) :: Double) forall a. Semigroup a => a -> a -> a
<> String
"ms"

-------------------------------------------------------------------------------
-- Bounded arithmetic
-------------------------------------------------------------------------------

-- | Same as '+' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or
-- @'minBound' :: 'Int'@ rather than rolling over
boundedPlus :: Int -> Int -> Int
boundedPlus :: Int -> Int -> Int
boundedPlus i :: Int
i@(I# Int#
i#) j :: Int
j@(I# Int#
j#) = case Int# -> Int# -> (# Int#, Int# #)
addIntC# Int#
i# Int#
j# of
  (# Int#
k#, Int#
0# #) -> Int# -> Int
I# Int#
k#
  (# Int#
_, Int#
_ #)
    | forall {a} {t}. Ord a => (t -> a) -> t -> t -> t
maxBy forall a. Num a => a -> a
abs Int
i Int
j forall a. Ord a => a -> a -> Bool
< Int
0 -> forall a. Bounded a => a
minBound
    | Bool
otherwise -> forall a. Bounded a => a
maxBound
  where
    maxBy :: (t -> a) -> t -> t -> t
maxBy t -> a
f t
a t
b = if t -> a
f t
a forall a. Ord a => a -> a -> Bool
>= t -> a
f t
b then t
a else t
b

-- | Same as '*' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or
-- @'minBound' :: 'Int'@ rather than rolling over
boundedMult :: Int -> Int -> Int
boundedMult :: Int -> Int -> Int
boundedMult i :: Int
i@(I# Int#
i#) j :: Int
j@(I# Int#
j#) = case Int# -> Int# -> Int#
mulIntMayOflo# Int#
i# Int#
j# of
  Int#
0# -> Int# -> Int
I# (Int#
i# Int# -> Int# -> Int#
*# Int#
j#)
  Int#
_ | forall a. Num a => a -> a
signum Int
i forall a. Num a => a -> a -> a
* forall a. Num a => a -> a
signum Int
j forall a. Ord a => a -> a -> Bool
< Int
0 -> forall a. Bounded a => a
minBound
    | Bool
otherwise -> forall a. Bounded a => a
maxBound

-- | Same as 'sum' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or
-- @'minBound' :: 'Int'@ rather than rolling over
boundedSum :: [Int] -> Int
boundedSum :: [Int] -> Int
boundedSum = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int -> Int -> Int
boundedPlus Int
0

-- | Same as '^' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or
-- @'MinBound' :: 'Int'@ rather than rolling over
boundedPow :: Int -> Int -> Int
boundedPow :: Int -> Int -> Int
boundedPow Int
x0 Int
y0
  | Int
y0 forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. HasCallStack => String -> a
error String
"Negative exponent"
  | Int
y0 forall a. Eq a => a -> a -> Bool
== Int
0 = Int
1
  | Bool
otherwise = forall {a}. Integral a => Int -> a -> Int
f Int
x0 Int
y0
  where
    f :: Int -> a -> Int
f Int
x a
y
      | forall a. Integral a => a -> Bool
even a
y = Int -> a -> Int
f (Int
x Int -> Int -> Int
`boundedMult` Int
x) (a
y forall a. Integral a => a -> a -> a
`quot` a
2)
      | a
y forall a. Eq a => a -> a -> Bool
== a
1 = Int
x
      | Bool
otherwise = forall {a}. Integral a => Int -> a -> Int -> Int
g (Int
x Int -> Int -> Int
`boundedMult` Int
x) ((a
y forall a. Num a => a -> a -> a
- a
1) forall a. Integral a => a -> a -> a
`quot` a
2) Int
x
    g :: Int -> a -> Int -> Int
g Int
x a
y Int
z
      | forall a. Integral a => a -> Bool
even a
y = Int -> a -> Int -> Int
g (Int
x Int -> Int -> Int
`boundedMult` Int
x) (a
y forall a. Integral a => a -> a -> a
`quot` a
2) Int
z
      | a
y forall a. Eq a => a -> a -> Bool
== a
1 = Int
x Int -> Int -> Int
`boundedMult` Int
z
      | Bool
otherwise = Int -> a -> Int -> Int
g (Int
x Int -> Int -> Int
`boundedMult` Int
x) ((a
y forall a. Num a => a -> a -> a
- a
1) forall a. Integral a => a -> a -> a
`quot` a
2) (Int
x Int -> Int -> Int
`boundedMult` Int
z)

-------------------------------------------------------------------------------
-- Lens machinery
-------------------------------------------------------------------------------
-- Unexported type aliases to clean up the documentation
type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t

type Lens' s a = Lens s s a a


-------------------------------------------------------------------------------
lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
lens :: forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens s -> a
sa s -> b -> t
sbt a -> f b
afb s
s = s -> b -> t
sbt s
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
afb (s -> a
sa s
s)
{-# INLINE lens #-}


                              ------------------
                              -- Simple Tests --
                              ------------------



-- data TestException = TestException deriving (Show, Typeable)
-- data AnotherException = AnotherException deriving (Show, Typeable)

-- instance Exception TestException
-- instance Exception AnotherException


-- test = retrying retryPolicyDefault [h1,h2] f
--     where
--       f = putStrLn "Running action" >> throwM AnotherException
--       h1 = Handler $ \ (e :: TestException) -> return False
--       h2 = Handler $ \ (e :: AnotherException) -> return True