{-# 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.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
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