{-# 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 { 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 :: RetryPolicyM m
retryPolicyDefault = Int -> RetryPolicyM m
forall (m :: * -> *). Monad m => Int -> RetryPolicyM m
constantDelay Int
50000 RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
forall a. Semigroup a => a -> a -> a
<> Int -> RetryPolicy
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) = (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM ((RetryStatus -> m (Maybe Int)) -> RetryPolicyM m)
-> (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \ RetryStatus
n -> MaybeT m Int -> m (Maybe Int)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT m Int -> m (Maybe Int)) -> MaybeT m Int -> m (Maybe Int)
forall a b. (a -> b) -> a -> b
$ do
    Int
a' <- m (Maybe Int) -> MaybeT m Int
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Int) -> MaybeT m Int) -> m (Maybe Int) -> MaybeT m Int
forall a b. (a -> b) -> a -> b
$ RetryStatus -> m (Maybe Int)
a RetryStatus
n
    Int
b' <- m (Maybe Int) -> MaybeT m Int
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (m (Maybe Int) -> MaybeT m Int) -> m (Maybe Int) -> MaybeT m Int
forall a b. (a -> b) -> a -> b
$ RetryStatus -> m (Maybe Int)
b RetryStatus
n
    Int -> MaybeT m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> MaybeT m Int) -> Int -> MaybeT m Int
forall a b. (a -> b) -> a -> b
$! Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
a' Int
b'


instance Monad m => Monoid (RetryPolicyM m) where
    mempty :: RetryPolicyM m
mempty = (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy ((RetryStatus -> Maybe Int) -> RetryPolicyM m)
-> (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ Maybe Int -> RetryStatus -> Maybe Int
forall a b. a -> b -> a
const (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)
    mappend :: RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
mappend = RetryPolicyM m -> RetryPolicyM m -> RetryPolicyM m
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 a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n
natTransformRetryPolicy forall a. m a -> n a
f (RetryPolicyM RetryStatus -> m (Maybe Int)
p) = (RetryStatus -> n (Maybe Int)) -> RetryPolicyM n
forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM ((RetryStatus -> n (Maybe Int)) -> RetryPolicyM n)
-> (RetryStatus -> n (Maybe Int)) -> RetryPolicyM n
forall a b. (a -> b) -> a -> b
$ \RetryStatus
stat -> m (Maybe Int) -> n (Maybe Int)
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 :: (Int -> Int) -> RetryPolicyM m -> RetryPolicyM m
modifyRetryPolicyDelay Int -> Int
f (RetryPolicyM RetryStatus -> m (Maybe Int)
p) = (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM ((RetryStatus -> m (Maybe Int)) -> RetryPolicyM m)
-> (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \RetryStatus
stat -> (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Int
f (Maybe Int -> Maybe Int) -> m (Maybe Int) -> m (Maybe Int)
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]
(Int -> ReadS RetryAction)
-> ReadS [RetryAction]
-> ReadPrec RetryAction
-> ReadPrec [RetryAction]
-> Read 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
(Int -> RetryAction -> ShowS)
-> (RetryAction -> String)
-> ([RetryAction] -> ShowS)
-> Show RetryAction
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
(RetryAction -> RetryAction -> Bool)
-> (RetryAction -> RetryAction -> Bool) -> Eq RetryAction
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. RetryAction -> Rep RetryAction x)
-> (forall x. Rep RetryAction x -> RetryAction)
-> Generic RetryAction
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]
(Int -> ReadS RetryStatus)
-> ReadS [RetryStatus]
-> ReadPrec RetryStatus
-> ReadPrec [RetryStatus]
-> Read 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
(Int -> RetryStatus -> ShowS)
-> (RetryStatus -> String)
-> ([RetryStatus] -> ShowS)
-> Show RetryStatus
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
(RetryStatus -> RetryStatus -> Bool)
-> (RetryStatus -> RetryStatus -> Bool) -> Eq RetryStatus
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. RetryStatus -> Rep RetryStatus x)
-> (forall x. Rep RetryStatus x -> RetryStatus)
-> Generic RetryStatus
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 Maybe Int
forall a. Maybe a
Nothing

-------------------------------------------------------------------------------
rsIterNumberL :: Lens' RetryStatus Int
rsIterNumberL :: (Int -> f Int) -> RetryStatus -> f RetryStatus
rsIterNumberL = (RetryStatus -> Int)
-> (RetryStatus -> Int -> RetryStatus)
-> Lens RetryStatus RetryStatus Int Int
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 :: (Int -> f Int) -> RetryStatus -> f RetryStatus
rsCumulativeDelayL = (RetryStatus -> Int)
-> (RetryStatus -> Int -> RetryStatus)
-> Lens RetryStatus RetryStatus Int Int
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 :: (Maybe Int -> f (Maybe Int)) -> RetryStatus -> f RetryStatus
rsPreviousDelayL = (RetryStatus -> Maybe Int)
-> (RetryStatus -> Maybe Int -> RetryStatus)
-> Lens RetryStatus RetryStatus (Maybe Int) (Maybe Int)
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 :: 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 -> Maybe RetryStatus -> m (Maybe RetryStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe RetryStatus -> m (Maybe RetryStatus))
-> Maybe RetryStatus -> m (Maybe RetryStatus)
forall a b. (a -> b) -> a -> b
$! RetryStatus -> Maybe RetryStatus
forall a. a -> Maybe a
Just (RetryStatus -> Maybe RetryStatus)
-> RetryStatus -> Maybe RetryStatus
forall a b. (a -> b) -> a -> b
$! RetryStatus :: Int -> Int -> Maybe Int -> RetryStatus
RetryStatus
          { rsIterNumber :: Int
rsIterNumber = RetryStatus -> Int
rsIterNumber RetryStatus
s Int -> Int -> Int
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 = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
delay }
      Maybe Int
Nothing -> Maybe RetryStatus -> m (Maybe RetryStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RetryStatus
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 :: RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyAndDelay RetryPolicyM m
policy RetryStatus
s = do
    Maybe RetryStatus
chk <- RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
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 -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just Int
delay -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
delay
        Maybe RetryStatus -> m (Maybe RetryStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return (RetryStatus -> Maybe RetryStatus
forall a. a -> Maybe a
Just RetryStatus
rs)
      Maybe RetryStatus
Nothing -> Maybe RetryStatus -> m (Maybe RetryStatus)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe RetryStatus
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 :: (RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy RetryStatus -> Maybe Int
f = (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM ((RetryStatus -> m (Maybe Int)) -> RetryPolicyM m)
-> (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \ RetryStatus
s -> Maybe Int -> m (Maybe Int)
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 -> RetryPolicy
limitRetries Int
i = (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy ((RetryStatus -> Maybe Int) -> RetryPolicyM m)
-> (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \ RetryStatus { rsIterNumber :: RetryStatus -> Int
rsIterNumber = Int
n} -> if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i then Maybe Int
forall a. Maybe a
Nothing else Int -> Maybe Int
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 :: Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByDelay Int
i RetryPolicyM m
p = (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM ((RetryStatus -> m (Maybe Int)) -> RetryPolicyM m)
-> (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \ RetryStatus
n ->
    (Maybe Int -> (Int -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Maybe Int
limit) (Maybe Int -> Maybe Int) -> m (Maybe Int) -> m (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RetryPolicyM m -> RetryStatus -> m (Maybe Int)
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
i then Maybe Int
forall a. Maybe a
Nothing else Int -> Maybe Int
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 :: Int -> RetryPolicyM m -> RetryPolicyM m
limitRetriesByCumulativeDelay Int
cumulativeLimit RetryPolicyM m
p = (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM ((RetryStatus -> m (Maybe Int)) -> RetryPolicyM m)
-> (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \ RetryStatus
stat ->
  (Maybe Int -> (Int -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RetryStatus -> Int -> Maybe Int
limit RetryStatus
stat) (Maybe Int -> Maybe Int) -> m (Maybe Int) -> m (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RetryPolicyM m -> RetryStatus -> m (Maybe Int)
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
cumulativeLimit = Maybe Int
forall a. Maybe a
Nothing
      | Bool
otherwise = Int -> Maybe Int
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 :: Int -> RetryPolicyM m
constantDelay Int
delay = (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy (Maybe Int -> RetryStatus -> Maybe Int
forall a b. a -> b -> a
const (Int -> Maybe Int
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 :: Int -> RetryPolicyM m
exponentialBackoff Int
base = (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy ((RetryStatus -> Maybe Int) -> RetryPolicyM m)
-> (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \ RetryStatus { rsIterNumber :: RetryStatus -> Int
rsIterNumber = Int
n } ->
  Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
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 :: Int -> RetryPolicyM m
fullJitterBackoff Int
base = (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM ((RetryStatus -> m (Maybe Int)) -> RetryPolicyM m)
-> (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
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) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2
  Int
rand <- IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> IO Int
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Int
0, Int
d)
  Maybe Int -> m (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Int -> m (Maybe Int)) -> Maybe Int -> m (Maybe Int)
forall a b. (a -> b) -> a -> b
$! Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
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 :: Int -> RetryPolicyM m
fibonacciBackoff Int
base = (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall (m :: * -> *).
Monad m =>
(RetryStatus -> Maybe Int) -> RetryPolicyM m
retryPolicy ((RetryStatus -> Maybe Int) -> RetryPolicyM m)
-> (RetryStatus -> Maybe Int) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \RetryStatus { rsIterNumber :: RetryStatus -> Int
rsIterNumber = Int
n } ->
  Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Int -> (Int, Int) -> Int
forall t. (Eq t, Num t) => t -> (Int, Int) -> Int
fib (Int
n Int -> Int -> Int
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
mt -> t -> t
forall 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 :: Int -> RetryPolicyM m -> RetryPolicyM m
capDelay Int
limit RetryPolicyM m
p = (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall (m :: * -> *).
(RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
RetryPolicyM ((RetryStatus -> m (Maybe Int)) -> RetryPolicyM m)
-> (RetryStatus -> m (Maybe Int)) -> RetryPolicyM m
forall a b. (a -> b) -> a -> b
$ \ RetryStatus
n ->
  (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
limit) (Maybe Int -> Maybe Int) -> m (Maybe Int) -> m (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` RetryPolicyM m -> RetryStatus -> m (Maybe Int)
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 :: RetryPolicyM m
-> (RetryStatus -> b -> m Bool) -> (RetryStatus -> m b) -> m b
retrying = RetryStatus
-> RetryPolicyM m
-> (RetryStatus -> b -> m Bool)
-> (RetryStatus -> m b)
-> m b
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 :: 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 =
    RetryStatus
-> RetryPolicyM m
-> (RetryStatus -> b -> m RetryAction)
-> (RetryStatus -> m b)
-> m b
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 -> (Bool -> RetryAction) -> m Bool -> m RetryAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> RetryAction
toRetryAction (m Bool -> m RetryAction) -> (b -> m Bool) -> b -> m RetryAction
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 :: RetryPolicyM m
-> (RetryStatus -> b -> m RetryAction)
-> (RetryStatus -> m b)
-> m b
retryingDynamic = RetryStatus
-> RetryPolicyM m
-> (RetryStatus -> b -> m RetryAction)
-> (RetryStatus -> m b)
-> m b
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 :: 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 <- RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
forall (m :: * -> *).
MonadIO m =>
RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
applyAndDelay RetryPolicyM m
policy' RetryStatus
s
              case Maybe RetryStatus
rs of
                Maybe RetryStatus
Nothing -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
res
                Just RetryStatus
rs' -> RetryStatus -> m b
go (RetryStatus -> m b) -> RetryStatus -> m b
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 -> b -> m b
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 (RetryPolicyM m -> m b) -> RetryPolicyM m -> m b
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Functor m =>
(Int -> Int) -> RetryPolicyM m -> RetryPolicyM m
modifyRetryPolicyDelay (Int -> Int -> Int
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 :: RetryPolicyM m -> (RetryStatus -> m a) -> m a
recoverAll = RetryStatus -> RetryPolicyM m -> (RetryStatus -> m a) -> m a
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 :: RetryStatus -> RetryPolicyM m -> (RetryStatus -> m a) -> m a
resumeRecoverAll RetryStatus
retryStatus RetryPolicyM m
set RetryStatus -> m a
f = RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m Bool]
-> (RetryStatus -> m a)
-> m a
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 = [RetryStatus -> Handler m Bool]
forall (m :: * -> *). MonadIO m => [RetryStatus -> Handler m Bool]
skipAsyncExceptions [RetryStatus -> Handler m Bool]
-> [RetryStatus -> Handler m Bool]
-> [RetryStatus -> Handler m Bool]
forall a. [a] -> [a] -> [a]
++ [RetryStatus -> Handler m Bool
forall (m :: * -> *) p. Monad m => p -> Handler m Bool
h]
      h :: p -> Handler m Bool
h p
_ = (SomeException -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((SomeException -> m Bool) -> Handler m Bool)
-> (SomeException -> m Bool) -> Handler m Bool
forall a b. (a -> b) -> a -> b
$ \ (SomeException
_ :: SomeException) -> Bool -> m Bool
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 :: [RetryStatus -> Handler m Bool]
skipAsyncExceptions = [RetryStatus -> Handler m Bool]
forall p. [p -> Handler m Bool]
handlers
  where
    asyncH :: p -> Handler m Bool
asyncH p
_ = (AsyncException -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((AsyncException -> m Bool) -> Handler m Bool)
-> (AsyncException -> m Bool) -> Handler m Bool
forall a b. (a -> b) -> a -> b
$ \ (AsyncException
_ :: AsyncException) -> Bool -> m Bool
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
_ = (SomeAsyncException -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((SomeAsyncException -> m Bool) -> Handler m Bool)
-> (SomeAsyncException -> m Bool) -> Handler m Bool
forall a b. (a -> b) -> a -> b
$ \(SomeAsyncException
_ :: SomeAsyncException) -> Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    handlers :: [p -> Handler m Bool]
handlers = [p -> Handler m Bool
forall (m :: * -> *) p. Monad m => p -> Handler m Bool
asyncH, p -> Handler m Bool
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 :: RetryPolicyM m
-> [RetryStatus -> Handler m Bool] -> (RetryStatus -> m a) -> m a
recovering = RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m Bool]
-> (RetryStatus -> m a)
-> m a
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 :: 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 =
    RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m RetryAction]
-> (RetryStatus -> m a)
-> m a
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' = ((RetryStatus -> Handler m Bool)
 -> RetryStatus -> Handler m RetryAction)
-> [RetryStatus -> Handler m Bool]
-> [RetryStatus -> Handler m RetryAction]
forall a b. (a -> b) -> [a] -> [b]
map ((Bool -> RetryAction) -> Handler m Bool -> Handler m RetryAction
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> RetryAction
toRetryAction (Handler m Bool -> Handler m RetryAction)
-> (RetryStatus -> Handler m Bool)
-> RetryStatus
-> Handler m RetryAction
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 :: RetryPolicyM m
-> [RetryStatus -> Handler m RetryAction]
-> (RetryStatus -> m a)
-> m a
recoveringDynamic = RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m RetryAction]
-> (RetryStatus -> m a)
-> m a
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 :: 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 a. m a -> m a) -> m a) -> m a
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m a) -> m a)
-> ((forall a. m a -> m a) -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> (m a -> m a) -> RetryStatus -> m a
forall b. (m a -> m b) -> RetryStatus -> m b
go m a -> m a
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 <- m b -> m (Either SomeException b)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m b -> m (Either SomeException b))
-> m b -> m (Either SomeException b)
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 -> b -> m b
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 [] = SomeException -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
              recover SomeException
e ((((RetryStatus -> Handler m RetryAction)
-> RetryStatus -> Handler m RetryAction
forall a b. (a -> b) -> a -> b
$ RetryStatus
s) -> Handler e -> m RetryAction
h) : [RetryStatus -> Handler m RetryAction]
hs')
                | Just e
e' <- SomeException -> Maybe 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 <- RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
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 (RetryStatus -> m b) -> RetryStatus -> m b
forall a b. (a -> b) -> a -> b
$! RetryStatus
rs'
                            Maybe RetryStatus
Nothing -> e -> m b
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 -> e -> m b
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 delay ->
                        RetryPolicyM m -> m b
consultPolicy (RetryPolicyM m -> m b) -> RetryPolicyM m -> m b
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> RetryPolicyM m -> RetryPolicyM m
forall (m :: * -> *).
Functor m =>
(Int -> Int) -> RetryPolicyM m -> RetryPolicyM m
modifyRetryPolicyDelay (Int -> Int -> Int
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 :: 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 <- m a -> m (Either SomeException a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m a -> m (Either SomeException a))
-> m a -> m (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ RetryStatus -> m a
f RetryStatus
s
    case Either SomeException a
r of
      Right a
x -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> m (Maybe a)) -> Maybe a -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ a -> Maybe a
forall a. a -> Maybe a
Just a
x
      Left SomeException
e -> SomeException -> [RetryStatus -> Handler m Bool] -> m (Maybe a)
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 [] = SomeException -> m (Maybe a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM SomeException
e
      recover SomeException
e ((((RetryStatus -> Handler m Bool) -> RetryStatus -> Handler m Bool
forall a b. (a -> b) -> a -> b
$ RetryStatus
s) -> Handler e -> m Bool
h) : [RetryStatus -> Handler m Bool]
hs')
        | Just e
e' <- SomeException -> Maybe 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 <- RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
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 (RetryStatus -> m ()) -> RetryStatus -> m ()
forall a b. (a -> b) -> a -> b
$! RetryStatus
rs
                    Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
                  Maybe RetryStatus
Nothing -> e -> m (Maybe a)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e'
              Bool
False -> e -> m (Maybe a)
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 :: (e -> m Bool)
-> (Bool -> e -> RetryStatus -> m ())
-> RetryStatus
-> Handler m Bool
logRetries e -> m Bool
test Bool -> e -> RetryStatus -> m ()
reporter RetryStatus
status = (e -> m Bool) -> Handler m Bool
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((e -> m Bool) -> Handler m Bool)
-> (e -> m Bool) -> Handler m Bool
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
    Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
result

-- | For use with 'logRetries'.
defaultLogMsg :: (Exception e) => Bool -> e -> RetryStatus -> String
defaultLogMsg :: Bool -> e -> RetryStatus -> String
defaultLogMsg Bool
shouldRetry e
err RetryStatus
status =
    String
"[retry:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
iter String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"] Encountered " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> e -> String
forall a. Show a => a -> String
show e
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
". " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
nextMsg
  where
    iter :: String
iter = Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
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 :: 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 <- (a -> Either (e, Bool) a
forall a b. b -> Either a b
Right (a -> Either (e, Bool) a) -> m a -> m (Either (e, Bool) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RetryStatus -> m a
f RetryStatus
stat) m (Either (e, Bool) a)
-> (e -> m (Either (e, Bool) a)) -> m (Either (e, Bool) a)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (\e
e -> (e, Bool) -> Either (e, Bool) a
forall a b. a -> Either a b
Left ((e, Bool) -> Either (e, Bool) a)
-> (Bool -> (e, Bool)) -> Bool -> Either (e, Bool) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (e
e, ) (Bool -> Either (e, Bool) a) -> m Bool -> m (Either (e, Bool) a)
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 -> a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
        Left (e
e, Bool
True) -> do
          Maybe RetryStatus
mstat' <- RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)
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 (RetryStatus -> m a) -> RetryStatus -> m a
forall a b. (a -> b) -> a -> b
$! RetryStatus
stat'
            Maybe RetryStatus
Nothing -> e -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
e
        Left (e
e, Bool
False) -> e -> m a
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 :: Int -> RetryPolicyM m -> m [(Int, Maybe Int)]
simulatePolicy Int
n (RetryPolicyM RetryStatus -> m (Maybe Int)
f) = (StateT RetryStatus m [(Int, Maybe Int)]
 -> RetryStatus -> m [(Int, Maybe Int)])
-> RetryStatus
-> StateT RetryStatus m [(Int, Maybe Int)]
-> m [(Int, Maybe Int)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT RetryStatus m [(Int, Maybe Int)]
-> RetryStatus -> m [(Int, Maybe Int)]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT RetryStatus
defaultRetryStatus (StateT RetryStatus m [(Int, Maybe Int)] -> m [(Int, Maybe Int)])
-> StateT RetryStatus m [(Int, Maybe Int)] -> m [(Int, Maybe Int)]
forall a b. (a -> b) -> a -> b
$ [Int]
-> (Int -> StateT RetryStatus m (Int, Maybe Int))
-> StateT RetryStatus m [(Int, Maybe Int)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
0..Int
n] ((Int -> StateT RetryStatus m (Int, Maybe Int))
 -> StateT RetryStatus m [(Int, Maybe Int)])
-> (Int -> StateT RetryStatus m (Int, Maybe Int))
-> StateT RetryStatus m [(Int, Maybe Int)]
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
  RetryStatus
stat <- StateT RetryStatus m RetryStatus
forall (m :: * -> *) s. Monad m => StateT s m s
get
  Maybe Int
delay <- m (Maybe Int) -> StateT RetryStatus m (Maybe Int)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
TC.lift (RetryStatus -> m (Maybe Int)
f RetryStatus
stat)
  RetryStatus -> StateT RetryStatus m ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
put (RetryStatus -> StateT RetryStatus m ())
-> RetryStatus -> StateT RetryStatus m ()
forall a b. (a -> b) -> a -> b
$! RetryStatus
stat
    { rsIterNumber :: Int
rsIterNumber = Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    , rsCumulativeDelay :: Int
rsCumulativeDelay = RetryStatus -> Int
rsCumulativeDelay RetryStatus
stat Int -> Int -> Int
`boundedPlus` Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 Maybe Int
delay
    , rsPreviousDelay :: Maybe Int
rsPreviousDelay = Maybe Int
delay
    }
  (Int, Maybe Int) -> StateT RetryStatus m (Int, Maybe Int)
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 <- Int -> RetryPolicyM IO -> IO [(Int, Maybe Int)]
forall (m :: * -> *).
Monad m =>
Int -> RetryPolicyM m -> m [(Int, Maybe Int)]
simulatePolicy Int
n RetryPolicyM IO
p
    [(Int, Maybe Int)] -> ((Int, Maybe Int) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Int, Maybe Int)]
ps (((Int, Maybe Int) -> IO ()) -> IO ())
-> ((Int, Maybe Int) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ (Int
iterNo, Maybe Int
res) -> String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      Int -> String
forall a. Show a => a -> String
show Int
iterNo String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> (Int -> String) -> Maybe Int -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"Inhibit" Int -> String
forall a. (Integral a, Show a) => a -> String
ppTime Maybe Int
res
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Total cumulative delay would be: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
      Int -> String
forall a. (Integral a, Show a) => a -> String
ppTime ([Int] -> Int
boundedSum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ ((Int, Maybe Int) -> Maybe Int) -> [(Int, Maybe Int)] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd [(Int, Maybe Int)]
ps)


-------------------------------------------------------------------------------
ppTime :: (Integral a, Show a) => a -> String
ppTime :: a -> String
ppTime a
n | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
1000 = a -> String
forall a. Show a => a -> String
show a
n String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"us"
         | a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
1000000 = Double -> String
forall a. Show a => a -> String
show ((a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000) :: Double) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"ms"
         | Bool
otherwise = Double -> String
forall a. Show a => a -> String
show ((a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
n Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000) :: Double) String -> ShowS
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#
_ #)
    | (Int -> Int) -> Int -> Int -> Int
forall a p. Ord a => (p -> a) -> p -> p -> p
maxBy Int -> Int
forall a. Num a => a -> a
abs Int
i Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> Int
forall a. Bounded a => a
minBound
    | Bool
otherwise -> Int
forall a. Bounded a => a
maxBound
  where
    maxBy :: (p -> a) -> p -> p -> p
maxBy p -> a
f p
a p
b = if p -> a
f p
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= p -> a
f p
b then p
a else p
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#
_ | Int -> Int
forall a. Num a => a -> a
signum Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int -> Int
forall a. Num a => a -> a
signum Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 -> Int
forall a. Bounded a => a
minBound
    | Bool
otherwise -> Int
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 = (Int -> Int -> Int) -> Int -> [Int] -> Int
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = String -> Int
forall a. HasCallStack => String -> a
error String
"Negative exponent"
  | Int
y0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int
1
  | Bool
otherwise = Int -> Int -> Int
forall a. Integral a => Int -> a -> Int
f Int
x0 Int
y0
  where
    f :: Int -> a -> Int
f Int
x a
y
      | a -> Bool
forall a. Integral a => a -> Bool
even a
y = Int -> a -> Int
f (Int
x Int -> Int -> Int
`boundedMult` Int
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2)
      | a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1 = Int
x
      | Bool
otherwise = Int -> a -> Int -> Int
forall a. Integral a => Int -> a -> Int -> Int
g (Int
x Int -> Int -> Int
`boundedMult` Int
x) ((a
y a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2) Int
x
    g :: Int -> a -> Int -> Int
g Int
x a
y Int
z
      | a -> Bool
forall a. Integral a => a -> Bool
even a
y = Int -> a -> Int -> Int
g (Int
x Int -> Int -> Int
`boundedMult` Int
x) (a
y a -> a -> a
forall a. Integral a => a -> a -> a
`quot` a
2) Int
z
      | a
y a -> a -> Bool
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 a -> a -> a
forall a. Num a => a -> a -> a
- a
1) a -> a -> a
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 :: (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 (b -> t) -> f b -> f t
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