{-# LANGUAGE RankNTypes            #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  UnliftIO.Retry
-- Copyright   :  Ozgun Ataman <ozgun.ataman@soostone.com>
-- License     :  BSD3
--
-- Maintainer  :  Patrick Brisbin <pbrisbin@gmail.com>
-- Stability   :  provisional
--
-- Unlifted "Control.Retry".
--
-- @since 0.9.3.0
----------------------------------------------------------------------------


module UnliftIO.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.Retry hiding
    ( recoverAll
    , recovering
    , recoveringDynamic
    , resumeRecovering
    , resumeRecoveringDynamic
    , resumeRecoverAll
    , stepping
    )
import qualified Control.Retry as Retry
import           Control.Monad.Catch (Handler(..))
import           Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
import           Prelude
-------------------------------------------------------------------------------


-------------------------------------------------------------------------------
-- | 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
    :: MonadUnliftIO m
    => 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.
MonadUnliftIO 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
    :: MonadUnliftIO m
    => 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 = ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    RetryStatus
-> RetryPolicyM IO
-> [RetryStatus -> Handler IO Bool]
-> (RetryStatus -> IO a)
-> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m Bool]
-> (RetryStatus -> m a)
-> m a
Retry.resumeRecovering
        RetryStatus
retryStatus
        ((forall a. m a -> IO a) -> RetryPolicyM m -> RetryPolicyM IO
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n
transRetryPolicy forall a. m a -> IO a
runInIO RetryPolicyM m
policy)
        (((RetryStatus -> Handler m Bool) -> RetryStatus -> Handler IO Bool)
-> [RetryStatus -> Handler m Bool]
-> [RetryStatus -> Handler IO Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((Handler m Bool -> Handler IO Bool)
-> (RetryStatus -> Handler m Bool)
-> RetryStatus
-> Handler IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((Handler m Bool -> Handler IO Bool)
 -> (RetryStatus -> Handler m Bool)
 -> RetryStatus
 -> Handler IO Bool)
-> (Handler m Bool -> Handler IO Bool)
-> (RetryStatus -> Handler m Bool)
-> RetryStatus
-> Handler IO Bool
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> IO a) -> Handler m Bool -> Handler IO Bool
forall (m :: * -> *) (n :: * -> *) a.
(forall b. m b -> n b) -> Handler m a -> Handler n a
transHandler forall a. m a -> IO a
runInIO) [RetryStatus -> Handler m Bool]
hs)
        (m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a) -> (RetryStatus -> m a) -> RetryStatus -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryStatus -> m a
f)


-------------------------------------------------------------------------------
-- | The difference between this and 'recovering' is the same as
--  the difference between 'retryingDynamic' and 'retrying'.
recoveringDynamic
    :: MonadUnliftIO m
    => 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.
MonadUnliftIO 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
    :: MonadUnliftIO m
    => 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 -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    RetryStatus
-> RetryPolicyM IO
-> [RetryStatus -> Handler IO RetryAction]
-> (RetryStatus -> IO a)
-> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus
-> RetryPolicyM m
-> [RetryStatus -> Handler m RetryAction]
-> (RetryStatus -> m a)
-> m a
Retry.resumeRecoveringDynamic
        RetryStatus
retryStatus
        ((forall a. m a -> IO a) -> RetryPolicyM m -> RetryPolicyM IO
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n
transRetryPolicy forall a. m a -> IO a
runInIO RetryPolicyM m
policy)
        (((RetryStatus -> Handler m RetryAction)
 -> RetryStatus -> Handler IO RetryAction)
-> [RetryStatus -> Handler m RetryAction]
-> [RetryStatus -> Handler IO RetryAction]
forall a b. (a -> b) -> [a] -> [b]
map ((Handler m RetryAction -> Handler IO RetryAction)
-> (RetryStatus -> Handler m RetryAction)
-> RetryStatus
-> Handler IO RetryAction
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((Handler m RetryAction -> Handler IO RetryAction)
 -> (RetryStatus -> Handler m RetryAction)
 -> RetryStatus
 -> Handler IO RetryAction)
-> (Handler m RetryAction -> Handler IO RetryAction)
-> (RetryStatus -> Handler m RetryAction)
-> RetryStatus
-> Handler IO RetryAction
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> IO a)
-> Handler m RetryAction -> Handler IO RetryAction
forall (m :: * -> *) (n :: * -> *) a.
(forall b. m b -> n b) -> Handler m a -> Handler n a
transHandler forall a. m a -> IO a
runInIO) [RetryStatus -> Handler m RetryAction]
hs)
        (m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a) -> (RetryStatus -> m a) -> RetryStatus -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryStatus -> m a
f)


-------------------------------------------------------------------------------
-- | 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
     :: MonadUnliftIO m
     => 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.
MonadUnliftIO 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
     :: MonadUnliftIO m
     => RetryStatus
     -> RetryPolicyM m
     -> (RetryStatus -> m a)
     -> m a
resumeRecoverAll :: RetryStatus -> RetryPolicyM m -> (RetryStatus -> m a) -> m a
resumeRecoverAll RetryStatus
retryStatus RetryPolicyM m
policy RetryStatus -> m a
f = ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    RetryStatus -> RetryPolicyM IO -> (RetryStatus -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryStatus -> RetryPolicyM m -> (RetryStatus -> m a) -> m a
Retry.resumeRecoverAll
        RetryStatus
retryStatus
        ((forall a. m a -> IO a) -> RetryPolicyM m -> RetryPolicyM IO
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n
transRetryPolicy forall a. m a -> IO a
runInIO RetryPolicyM m
policy)
        (m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a) -> (RetryStatus -> m a) -> RetryStatus -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryStatus -> m a
f)

-------------------------------------------------------------------------------
-- | 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
    :: MonadUnliftIO m
    => 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 = ((forall a. m a -> IO a) -> IO (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (Maybe a)) -> m (Maybe a))
-> ((forall a. m a -> IO a) -> IO (Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
runInIO ->
    RetryPolicyM IO
-> [RetryStatus -> Handler IO Bool]
-> (RetryStatus -> IO ())
-> (RetryStatus -> IO a)
-> RetryStatus
-> IO (Maybe a)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RetryPolicyM m
-> [RetryStatus -> Handler m Bool]
-> (RetryStatus -> m ())
-> (RetryStatus -> m a)
-> RetryStatus
-> m (Maybe a)
Retry.stepping
        ((forall a. m a -> IO a) -> RetryPolicyM m -> RetryPolicyM IO
forall (m :: * -> *) (n :: * -> *).
(forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n
transRetryPolicy forall a. m a -> IO a
runInIO RetryPolicyM m
policy)
        (((RetryStatus -> Handler m Bool) -> RetryStatus -> Handler IO Bool)
-> [RetryStatus -> Handler m Bool]
-> [RetryStatus -> Handler IO Bool]
forall a b. (a -> b) -> [a] -> [b]
map ((Handler m Bool -> Handler IO Bool)
-> (RetryStatus -> Handler m Bool)
-> RetryStatus
-> Handler IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) ((Handler m Bool -> Handler IO Bool)
 -> (RetryStatus -> Handler m Bool)
 -> RetryStatus
 -> Handler IO Bool)
-> (Handler m Bool -> Handler IO Bool)
-> (RetryStatus -> Handler m Bool)
-> RetryStatus
-> Handler IO Bool
forall a b. (a -> b) -> a -> b
$ (forall a. m a -> IO a) -> Handler m Bool -> Handler IO Bool
forall (m :: * -> *) (n :: * -> *) a.
(forall b. m b -> n b) -> Handler m a -> Handler n a
transHandler forall a. m a -> IO a
runInIO) [RetryStatus -> Handler m Bool]
hs)
        (m () -> IO ()
forall a. m a -> IO a
runInIO (m () -> IO ()) -> (RetryStatus -> m ()) -> RetryStatus -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryStatus -> m ()
schedule)
        (m a -> IO a
forall a. m a -> IO a
runInIO (m a -> IO a) -> (RetryStatus -> m a) -> RetryStatus -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryStatus -> m a
f)
        RetryStatus
s


-------------------------------------------------------------------------------
transRetryPolicy :: (forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n
transRetryPolicy :: (forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n
transRetryPolicy 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
$ m (Maybe Int) -> n (Maybe Int)
forall a. m a -> n a
f (m (Maybe Int) -> n (Maybe Int))
-> (RetryStatus -> m (Maybe Int)) -> RetryStatus -> n (Maybe Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RetryStatus -> m (Maybe Int)
p


-------------------------------------------------------------------------------
transHandler :: (forall b. m b -> n b) -> Handler m a -> Handler n a
transHandler :: (forall b. m b -> n b) -> Handler m a -> Handler n a
transHandler forall b. m b -> n b
f (Handler e -> m a
h) = (e -> n a) -> Handler n a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler ((e -> n a) -> Handler n a) -> (e -> n a) -> Handler n a
forall a b. (a -> b) -> a -> b
$ m a -> n a
forall b. m b -> n b
f (m a -> n a) -> (e -> m a) -> e -> n a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
h