retry-0.9.3.1/src/0000755000000000000000000000000014264345463012017 5ustar0000000000000000retry-0.9.3.1/src/Control/0000755000000000000000000000000014242016577013434 5ustar0000000000000000retry-0.9.3.1/src/UnliftIO/0000755000000000000000000000000014264345463013510 5ustar0000000000000000retry-0.9.3.1/test/0000755000000000000000000000000014264345463012207 5ustar0000000000000000retry-0.9.3.1/test/Tests/0000755000000000000000000000000014264345463013311 5ustar0000000000000000retry-0.9.3.1/test/Tests/Control/0000755000000000000000000000000014417323572014726 5ustar0000000000000000retry-0.9.3.1/test/Tests/UnliftIO/0000755000000000000000000000000014264345463015002 5ustar0000000000000000retry-0.9.3.1/src/Control/Retry.hs0000644000000000000000000010273114242016577015101 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Control.Retry -- Copyright : Ozgun Ataman -- 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 { 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 = constantDelay 50000 <> limitRetries 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 a) <> (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do a' <- MaybeT $ a n b' <- MaybeT $ b n return $! max a' b' instance Monad m => Monoid (RetryPolicyM m) where mempty = retryPolicy $ const (Just 0) mappend = (<>) # 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 f (RetryPolicyM p) = RetryPolicyM $ \stat -> f (p 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 f (RetryPolicyM p) = RetryPolicyM $ \stat -> fmap f <$> p 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 (Read, Show, Eq, Generic) -- | Convert a boolean answer to the question "Should we retry?" into -- a 'RetryAction'. toRetryAction :: Bool -> RetryAction toRetryAction False = DontRetry toRetryAction True = ConsultPolicy ------------------------------------------------------------------------------- -- | Datatype with stats about retries made thus far. data RetryStatus = RetryStatus { rsIterNumber :: !Int -- ^ Iteration number, where 0 is the first try , rsCumulativeDelay :: !Int -- ^ Delay incurred so far from retries in microseconds , rsPreviousDelay :: !(Maybe Int) -- ^ Latest attempt's delay. Will always be Nothing on first run. } deriving (Read, Show, Eq, Generic) ------------------------------------------------------------------------------- -- | Initial, default retry status. Use fields or lenses to update. defaultRetryStatus :: RetryStatus defaultRetryStatus = RetryStatus 0 0 Nothing ------------------------------------------------------------------------------- rsIterNumberL :: Lens' RetryStatus Int rsIterNumberL = lens rsIterNumber (\rs x -> rs { rsIterNumber = x }) {-# INLINE rsIterNumberL #-} ------------------------------------------------------------------------------- rsCumulativeDelayL :: Lens' RetryStatus Int rsCumulativeDelayL = lens rsCumulativeDelay (\rs x -> rs { rsCumulativeDelay = x }) {-# INLINE rsCumulativeDelayL #-} ------------------------------------------------------------------------------- rsPreviousDelayL :: Lens' RetryStatus (Maybe Int) rsPreviousDelayL = lens rsPreviousDelay (\rs x -> rs { rsPreviousDelay = 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 policy) s = do res <- policy s case res of Just delay -> return $! Just $! RetryStatus { rsIterNumber = rsIterNumber s + 1 , rsCumulativeDelay = rsCumulativeDelay s `boundedPlus` delay , rsPreviousDelay = Just delay } Nothing -> return 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 policy s = do chk <- applyPolicy policy s case chk of Just rs -> do case rsPreviousDelay rs of Nothing -> return () Just delay -> liftIO $ threadDelay delay return (Just rs) Nothing -> return Nothing ------------------------------------------------------------------------------- -- | Helper for making simplified policies that don't use the monadic -- context. retryPolicy :: (Monad m) => (RetryStatus -> Maybe Int) -> RetryPolicyM m retryPolicy f = RetryPolicyM $ \ s -> return (f s) ------------------------------------------------------------------------------- -- | Retry immediately, but only up to @n@ times. limitRetries :: Int -- ^ Maximum number of retries. -> RetryPolicy limitRetries i = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> if n >= i then Nothing else Just 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 i p = RetryPolicyM $ \ n -> (>>= limit) `fmap` getRetryPolicyM p n where limit delay = if delay >= i then Nothing else Just 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 cumulativeLimit p = RetryPolicyM $ \ stat -> (>>= limit stat) `fmap` getRetryPolicyM p stat where limit status curDelay | rsCumulativeDelay status `boundedPlus` curDelay > cumulativeLimit = Nothing | otherwise = Just curDelay ------------------------------------------------------------------------------- -- | Implement a constant delay with unlimited retries. constantDelay :: (Monad m) => Int -- ^ Base delay in microseconds -> RetryPolicyM m constantDelay delay = retryPolicy (const (Just 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 base = retryPolicy $ \ RetryStatus { rsIterNumber = n } -> Just $! base `boundedMult` boundedPow 2 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 base = RetryPolicyM $ \ RetryStatus { rsIterNumber = n } -> do let d = (base `boundedMult` boundedPow 2 n) `div` 2 rand <- liftIO $ randomRIO (0, d) return $! Just $! d `boundedPlus` rand ------------------------------------------------------------------------------- -- | Implement Fibonacci backoff. fibonacciBackoff :: (Monad m) => Int -- ^ Base delay in microseconds -> RetryPolicyM m fibonacciBackoff base = retryPolicy $ \RetryStatus { rsIterNumber = n } -> Just $ fib (n + 1) (0, base) where fib 0 (a, _) = a fib !m (!a, !b) = fib (m-1) (b, a `boundedPlus` 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 limit p = RetryPolicyM $ \ n -> fmap (min limit) `fmap` getRetryPolicyM p 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 = resumeRetrying 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 policy chk f = resumeRetryingDynamic retryStatus policy (\rs -> fmap toRetryAction . chk rs) 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 = resumeRetryingDynamic 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 policy chk f = go retryStatus where go s = do res <- f s let consultPolicy policy' = do rs <- applyAndDelay policy' s case rs of Nothing -> return res Just rs' -> go $! rs' chk' <- chk s res case chk' of DontRetry -> return res ConsultPolicy -> consultPolicy policy ConsultPolicyOverrideDelay delay -> consultPolicy $ modifyRetryPolicyDelay (const delay) 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 = resumeRecoverAll 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 set f = resumeRecovering retryStatus set handlers f where handlers = skipAsyncExceptions ++ [h] h _ = Handler $ \ (_ :: SomeException) -> return 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 = handlers where asyncH _ = Handler $ \ (_ :: AsyncException) -> return False #if MIN_VERSION_base(4, 7, 0) someAsyncH _ = Handler $ \(_ :: SomeAsyncException) -> return False handlers = [asyncH, 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 = resumeRecovering 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 policy hs f = resumeRecoveringDynamic retryStatus policy hs' f where hs' = map (fmap toRetryAction .) 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 = resumeRecoveringDynamic 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 policy hs f = mask $ \restore -> go restore retryStatus where go restore = loop where loop s = do r <- try $ restore (f s) case r of Right x -> return x Left e -> recover (e :: SomeException) hs where recover e [] = throwM e recover e ((($ s) -> Handler h) : hs') | Just e' <- fromException e = do let consultPolicy policy' = do rs <- applyAndDelay policy' s case rs of Just rs' -> loop $! rs' Nothing -> throwM e' chk <- h e' case chk of DontRetry -> throwM e' ConsultPolicy -> consultPolicy policy ConsultPolicyOverrideDelay delay -> consultPolicy $ modifyRetryPolicyDelay (const delay) policy | otherwise = recover e 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 policy hs schedule f s = do r <- try $ f s case r of Right x -> return $ Just x Left e -> recover (e :: SomeException) hs where recover e [] = throwM e recover e ((($ s) -> Handler h) : hs') | Just e' <- fromException e = do chk <- h e' case chk of True -> do res <- applyPolicy policy s case res of Just rs -> do schedule $! rs return Nothing Nothing -> throwM e' False -> throwM e' | otherwise = recover e 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 test reporter status = Handler $ \ err -> do result <- test err reporter result err status return result -- | For use with 'logRetries'. defaultLogMsg :: (Exception e) => Bool -> e -> RetryStatus -> String defaultLogMsg shouldRetry err status = "[retry:" <> iter <> "] Encountered " <> show err <> ". " <> nextMsg where iter = show $ rsIterNumber status nextMsg = if shouldRetry then "Retrying." else "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 policy chk f = go defaultRetryStatus where go stat = do res <- (Right <$> f stat) `catchError` (\e -> Left . (e, ) <$> chk stat e) case res of Right x -> return x Left (e, True) -> do mstat' <- applyAndDelay policy stat case mstat' of Just stat' -> do go $! stat' Nothing -> throwError e Left (e, False) -> throwError 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 n (RetryPolicyM f) = flip evalStateT defaultRetryStatus $ forM [0..n] $ \i -> do stat <- get delay <- TC.lift (f stat) put $! stat { rsIterNumber = i + 1 , rsCumulativeDelay = rsCumulativeDelay stat `boundedPlus` fromMaybe 0 delay , rsPreviousDelay = delay } return (i, delay) ------------------------------------------------------------------------------- -- | Run given policy up to N iterations and pretty print results on -- the console. simulatePolicyPP :: Int -> RetryPolicyM IO -> IO () simulatePolicyPP n p = do ps <- simulatePolicy n p forM_ ps $ \ (iterNo, res) -> putStrLn $ show iterNo <> ": " <> maybe "Inhibit" ppTime res putStrLn $ "Total cumulative delay would be: " <> ppTime (boundedSum $ mapMaybe snd ps) ------------------------------------------------------------------------------- ppTime :: (Integral a, Show a) => a -> String ppTime n | n < 1000 = show n <> "us" | n < 1000000 = show ((fromIntegral n / 1000) :: Double) <> "ms" | otherwise = show ((fromIntegral n / 1000) :: Double) <> "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 i@(I# i#) j@(I# j#) = case addIntC# i# j# of (# k#, 0# #) -> I# k# (# _, _ #) | maxBy abs i j < 0 -> minBound | otherwise -> maxBound where maxBy f a b = if f a >= f b then a else b -- | Same as '*' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or -- @'minBound' :: 'Int'@ rather than rolling over boundedMult :: Int -> Int -> Int boundedMult i@(I# i#) j@(I# j#) = case mulIntMayOflo# i# j# of 0# -> I# (i# *# j#) _ | signum i * signum j < 0 -> minBound | otherwise -> maxBound -- | Same as 'sum' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or -- @'minBound' :: 'Int'@ rather than rolling over boundedSum :: [Int] -> Int boundedSum = foldl' boundedPlus 0 -- | Same as '^' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or -- @'MinBound' :: 'Int'@ rather than rolling over boundedPow :: Int -> Int -> Int boundedPow x0 y0 | y0 < 0 = error "Negative exponent" | y0 == 0 = 1 | otherwise = f x0 y0 where f x y | even y = f (x `boundedMult` x) (y `quot` 2) | y == 1 = x | otherwise = g (x `boundedMult` x) ((y - 1) `quot` 2) x g x y z | even y = g (x `boundedMult` x) (y `quot` 2) z | y == 1 = x `boundedMult` z | otherwise = g (x `boundedMult` x) ((y - 1) `quot` 2) (x `boundedMult` 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 sa sbt afb s = sbt s <$> afb (sa 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 retry-0.9.3.1/src/UnliftIO/Retry.hs0000644000000000000000000002167314264345463015162 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} ----------------------------------------------------------------------------- -- | -- Module : UnliftIO.Retry -- Copyright : Ozgun Ataman -- License : BSD3 -- -- Maintainer : Patrick Brisbin -- 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 = resumeRecovering 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 policy hs f = withRunInIO $ \runInIO -> Retry.resumeRecovering retryStatus (transRetryPolicy runInIO policy) (map ((.) $ transHandler runInIO) hs) (runInIO . 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 = resumeRecoveringDynamic 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 policy hs f = withRunInIO $ \runInIO -> Retry.resumeRecoveringDynamic retryStatus (transRetryPolicy runInIO policy) (map ((.) $ transHandler runInIO) hs) (runInIO . 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 = resumeRecoverAll 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 policy f = withRunInIO $ \runInIO -> Retry.resumeRecoverAll retryStatus (transRetryPolicy runInIO policy) (runInIO . 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 policy hs schedule f s = withRunInIO $ \runInIO -> Retry.stepping (transRetryPolicy runInIO policy) (map ((.) $ transHandler runInIO) hs) (runInIO . schedule) (runInIO . f) s ------------------------------------------------------------------------------- transRetryPolicy :: (forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n transRetryPolicy f (RetryPolicyM p) = RetryPolicyM $ f . p ------------------------------------------------------------------------------- transHandler :: (forall b. m b -> n b) -> Handler m a -> Handler n a transHandler f (Handler h) = Handler $ f . h retry-0.9.3.1/test/Main.hs0000644000000000000000000000114514264345463013430 0ustar0000000000000000module Main ( main ) where ------------------------------------------------------------------------------- import Test.Tasty ------------------------------------------------------------------------------- import qualified Tests.Control.Retry import qualified Tests.UnliftIO.Retry ------------------------------------------------------------------------------- main :: IO () main = defaultMain tests ------------------------------------------------------------------------------- tests :: TestTree tests = testGroup "retry" [ Tests.Control.Retry.tests , Tests.UnliftIO.Retry.tests ] retry-0.9.3.1/test/Tests/Control/Retry.hs0000644000000000000000000005667114417323641016403 0ustar0000000000000000{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} module Tests.Control.Retry ( tests -- * Used to test UnliftIO versions of the same functions , recoveringTestsWith , maskingStateTestsWith , quadraticDelayTestsWith , recoveringTest , testHandlers , testHandlersDynamic ) where ------------------------------------------------------------------------------- import Control.Applicative import Control.Concurrent import Control.Concurrent.STM as STM import qualified Control.Exception as EX import Control.Monad as M ( forM_ ) import Control.Monad.Catch import Control.Monad.Except import Control.Monad.Identity import Control.Monad.IO.Class as MIO import Control.Monad.Writer.Strict import Data.Either import Data.IORef import Data.List import Data.Maybe import Data.Time.Clock import Data.Time.LocalTime () import Data.Typeable import Hedgehog as HH import qualified Hedgehog.Gen as Gen import qualified Hedgehog.Range as Range import System.IO.Error import Test.Tasty import Test.Tasty.Hedgehog import Test.Tasty.HUnit ( assertBool, assertFailure , testCase, (@=?), (@?=) ) ------------------------------------------------------------------------------- import Control.Retry ------------------------------------------------------------------------------- tests :: TestTree tests = testGroup "Control.Retry" [ recoveringTests , monoidTests , retryStatusTests , quadraticDelayTests , policyTransformersTests , maskingStateTests , capDelayTests , limitRetriesByCumulativeDelayTests , overridingDelayTests , resumableTests , retryOnErrorTests ] ------------------------------------------------------------------------------- recoveringTests :: TestTree recoveringTests = recoveringTestsWith recovering recoveringTestsWith :: Monad m => (RetryPolicyM m -> [RetryStatus -> Handler IO Bool] -> (a -> IO ()) -> IO ()) -> TestTree recoveringTestsWith recovering' = testGroup "recovering" [ testProperty "recovering test without quadratic retry delay" $ property $ do startTime <- liftIO getCurrentTime timeout <- forAll (Gen.int (Range.linear 0 15)) retries <- forAll (Gen.int (Range.linear 0 50)) res <- liftIO $ try $ recovering' (constantDelay timeout <> limitRetries retries) testHandlers (const $ throwM (userError "booo")) endTime <- liftIO getCurrentTime HH.assert (isLeftAnd isUserError res) let ms' = (fromInteger . toInteger $ (timeout * retries)) / 1000000.0 HH.assert (diffUTCTime endTime startTime >= ms') , testGroup "exception hierarchy semantics" [ testCase "does not catch async exceptions" $ do counter <- newTVarIO (0 :: Int) done <- newEmptyMVar let work = atomically (modifyTVar' counter succ) >> threadDelay 1000000 tid <- forkIO $ recoverAll (limitRetries 2) (const work) `finally` putMVar done () atomically (STM.check . (== 1) =<< readTVar counter) EX.throwTo tid EX.UserInterrupt takeMVar done count <- atomically (readTVar counter) count @?= 1 , testCase "recovers from custom exceptions" $ do f <- mkFailN Custom1 2 res <- try $ recovering' (constantDelay 5000 <> limitRetries 3) [const $ Handler $ \ Custom1 -> return shouldRetry] f (res :: Either Custom1 ()) @?= Right () , testCase "fails beyond policy using custom exceptions" $ do f <- mkFailN Custom1 3 res <- try $ recovering' (constantDelay 5000 <> limitRetries 2) [const $ Handler $ \ Custom1 -> return shouldRetry] f (res :: Either Custom1 ()) @?= Left Custom1 , testCase "recoverAll won't catch exceptions which are not decendants of SomeException" $ do f <- mkFailN Custom1 4 res <- try $ recoverAll (constantDelay 5000 <> limitRetries 3) f (res :: Either Custom1 ()) @?= Left Custom1 , testCase "does not recover from unhandled exceptions" $ do f <- mkFailN Custom2 2 res <- try $ recovering' (constantDelay 5000 <> limitRetries 5) [const $ Handler $ \ Custom1 -> return shouldRetry] f (res :: Either Custom2 ()) @?= Left Custom2 , testCase "recovers in presence of multiple handlers" $ do f <- mkFailN Custom2 2 res <- try $ recovering' (constantDelay 5000 <> limitRetries 5) [ const $ Handler $ \ Custom1 -> return shouldRetry , const $ Handler $ \ Custom2 -> return shouldRetry ] f (res :: Either Custom2 ()) @?= Right () , testCase "general exceptions catch specific ones" $ do f <- mkFailN Custom2 2 res <- try $ recovering' (constantDelay 5000 <> limitRetries 5) [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] f (res :: Either Custom2 ()) @?= Right () , testCase "(redundant) even general catchers don't go beyond policy" $ do f <- mkFailN Custom2 3 res <- try $ recovering' (constantDelay 5000 <> limitRetries 2) [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] f (res :: Either Custom2 ()) @?= Left Custom2 , testCase "rethrows in presence of failed exception casts" $ do f <- mkFailN Custom2 3 final <- try $ do res <- try $ recovering' (constantDelay 5000 <> limitRetries 2) [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] f (res :: Either Custom1 ()) @?= Left Custom1 final @?= Left Custom2 ] ] ------------------------------------------------------------------------------- monoidTests :: TestTree monoidTests = testGroup "Policy is a monoid" [ testProperty "left identity" $ property $ propIdentity (\p -> mempty <> p) id , testProperty "right identity" $ property $ propIdentity (\p -> p <> mempty) id , testProperty "associativity" $ property $ propAssociativity (\x y z -> x <> (y <> z)) (\x y z -> (x <> y) <> z) ] where propIdentity left right = do retryStatus <- forAll genRetryStatus fixedDelay <- forAll (Gen.maybe (Gen.int (Range.linear 0 maxBound))) let calculateDelay _rs = fixedDelay let applyPolicy' f = getRetryPolicyM (f $ retryPolicy calculateDelay) retryStatus validRes = maybe True (>= 0) l <- liftIO $ applyPolicy' left r <- liftIO $ applyPolicy' right if validRes r && validRes l then l === r else return () propAssociativity left right = do retryStatus <- forAll genRetryStatus let genDelay = Gen.maybe (Gen.int (Range.linear 0 maxBound)) delayA <- forAll genDelay delayB <- forAll genDelay delayC <- forAll genDelay let applyPolicy' f = liftIO $ getRetryPolicyM (f (retryPolicy (const delayA)) (retryPolicy (const delayB)) (retryPolicy (const delayC))) retryStatus res <- liftIO (liftA2 (==) (applyPolicy' left) (applyPolicy' right)) assert res ------------------------------------------------------------------------------- retryStatusTests :: TestTree retryStatusTests = testGroup "retry status" [ testCase "passes the correct retry status each time" $ do let policy = limitRetries 2 <> constantDelay 100 rses <- gatherStatuses policy rsIterNumber <$> rses @?= [0, 1, 2] rsCumulativeDelay <$> rses @?= [0, 100, 200] rsPreviousDelay <$> rses @?= [Nothing, Just 100, Just 100] ] ------------------------------------------------------------------------------- policyTransformersTests :: TestTree policyTransformersTests = testGroup "policy transformers" [ testProperty "always produces positive delay with positive constants (no rollover)" $ property $ do delay <- forAll (Gen.int (Range.linear 0 maxBound)) let res = runIdentity (simulatePolicy 1000 (exponentialBackoff delay)) delays = catMaybes (snd <$> res) mnDelay = if null delays then Nothing else Just (minimum delays) case mnDelay of Nothing -> return () Just n -> do footnote (show n ++ " is not >= 0") HH.assert (n >= 0) , testProperty "positive, nonzero exponential backoff is always incrementing" $ property $ do delay <- forAll (Gen.int (Range.linear 1 maxBound)) let res = runIdentity (simulatePolicy 1000 (limitRetriesByDelay maxBound (exponentialBackoff delay))) delays = catMaybes (snd <$> res) sort delays === delays length (group delays) === length delays ] ------------------------------------------------------------------------------- maskingStateTests :: TestTree maskingStateTests = maskingStateTestsWith recovering maskingStateTestsWith :: Monad m => (RetryPolicyM m -> [RetryStatus -> Handler IO Bool] -> (a -> IO b) -> IO ()) -> TestTree maskingStateTestsWith recovering' = testGroup "masking state" [ testCase "shouldn't change masking state in a recovered action" $ do maskingState <- EX.getMaskingState final <- try $ recovering' retryPolicyDefault testHandlers $ const $ do maskingState' <- EX.getMaskingState maskingState' @?= maskingState fail "Retrying..." assertBool ("Expected EX.IOException but didn't get one") (isLeft (final :: Either EX.IOException ())) , testCase "should mask asynchronous exceptions in exception handlers" $ do let checkMaskingStateHandlers = [ const $ Handler $ \(_ :: SomeException) -> do maskingState <- EX.getMaskingState maskingState @?= EX.MaskedInterruptible return shouldRetry ] final <- try $ recovering' retryPolicyDefault checkMaskingStateHandlers $ const $ fail "Retrying..." assertBool ("Expected EX.IOException but didn't get one") (isLeft (final :: Either EX.IOException ())) ] ------------------------------------------------------------------------------- capDelayTests :: TestTree capDelayTests = testGroup "capDelay" [ testProperty "respects limitRetries" $ property $ do retries <- forAll (Gen.int (Range.linear 1 100)) cap <- forAll (Gen.int (Range.linear 1 maxBound)) let policy = capDelay cap (limitRetries retries) let delays = runIdentity (simulatePolicy (retries + 1) policy) let lastDelay = fromMaybe (error "impossible: empty delays") (lookup (retries - 1) delays) let gaveUp = fromMaybe (error "impossible: empty delays") (lookup retries delays) let noDelay = 0 lastDelay === Just noDelay gaveUp === Nothing , testProperty "does not allow any delays higher than the given delay" $ property $ do cap <- forAll (Gen.int (Range.linear 1 maxBound)) baseDelay <- forAll (Gen.int (Range.linear 1 100)) basePolicy <- forAllWith (const "RetryPolicy") (genScalingPolicy baseDelay) let policy = capDelay cap basePolicy let delays = catMaybes (snd <$> runIdentity (simulatePolicy 100 policy)) let baddies = filter (> cap) delays baddies === [] ] ------------------------------------------------------------------------------- -- | Generates policies that increase on each iteration genScalingPolicy :: (Alternative m) => Int -> m (RetryPolicyM Identity) genScalingPolicy baseDelay = (pure (exponentialBackoff baseDelay) <|> pure (fibonacciBackoff baseDelay)) ------------------------------------------------------------------------------- limitRetriesByCumulativeDelayTests :: TestTree limitRetriesByCumulativeDelayTests = testGroup "limitRetriesByCumulativeDelay" [ testProperty "never exceeds the given cumulative delay" $ property $ do baseDelay <- forAll (Gen.int (Range.linear 1 100)) basePolicy <- forAllWith (const "RetryPolicy") (genScalingPolicy baseDelay) cumulativeDelayMax <- forAll (Gen.int (Range.linear 1 10000)) let policy = limitRetriesByCumulativeDelay cumulativeDelayMax basePolicy let delays = catMaybes (snd <$> runIdentity (simulatePolicy 100 policy)) footnoteShow delays let actualCumulativeDelay = sum delays footnote (show actualCumulativeDelay <> " <= " <> show cumulativeDelayMax) HH.assert (actualCumulativeDelay <= cumulativeDelayMax) ] ------------------------------------------------------------------------------- quadraticDelayTests :: TestTree quadraticDelayTests = quadraticDelayTestsWith recovering quadraticDelayTestsWith :: Monad m => (RetryPolicyM m -> [RetryStatus -> Handler IO Bool] -> (a -> IO b) -> IO ()) -> TestTree quadraticDelayTestsWith recovering' = testGroup "quadratic delay" [ testProperty "recovering test with quadratic retry delay" $ property $ do startTime <- liftIO getCurrentTime timeout <- forAll (Gen.int (Range.linear 0 15)) retries <- forAll (Gen.int (Range.linear 0 8)) res <- liftIO $ try $ recovering' (exponentialBackoff timeout <> limitRetries retries) [const $ Handler (\(_::SomeException) -> return True)] (const $ throwM (userError "booo")) endTime <- liftIO getCurrentTime HH.assert (isLeftAnd isUserError res) let tmo = if retries > 0 then timeout * 2 ^ (retries - 1) else 0 let ms' = ((fromInteger . toInteger $ tmo) / 1000000.0) HH.assert (diffUTCTime endTime startTime >= ms') ] ------------------------------------------------------------------------------- overridingDelayTests :: TestTree overridingDelayTests = testGroup "overriding delay" [ testGroup "actual delays don't exceed specified delays" [ testProperty "retryingDynamic" $ testOverride retryingDynamic (\delays rs _ -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs)) (\_ _ -> liftIO getCurrentTime >>= \time -> tell [time]) , testProperty "recoveringDynamic" $ testOverride recoveringDynamic (\delays -> [\rs -> Handler (\(_::SomeException) -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs))]) (\delays rs -> do liftIO getCurrentTime >>= \time -> tell [time] if rsIterNumber rs < length delays then throwM (userError "booo") else return () ) ] ] where -- Transform a list of timestamps into a list of differences -- between adjacent timestamps. diffTimes = compareAdjacent (flip diffUTCTime) microsToNominalDiffTime = toNominal . picosecondsToDiffTime . (* 1000000) . fromIntegral toNominal :: DiffTime -> NominalDiffTime toNominal = realToFrac -- Generic test case used to test both "retryingDynamic" and "recoveringDynamic" testOverride retryer handler action = property $ do retryPolicy' <- forAll $ genPolicyNoLimit (Range.linear 1 1000000) delays <- forAll $ Gen.list (Range.linear 1 10) (Gen.int (Range.linear 10 1000)) (_, measuredTimestamps) <- liftIO $ runWriterT $ retryer -- Stop retrying when we run out of delays (retryPolicy' <> limitRetries (length delays)) (handler delays) (action delays) let expectedDelays = map microsToNominalDiffTime delays M.forM_ (zip (diffTimes measuredTimestamps) expectedDelays) $ \(actual, expected) -> diff actual (>=) expected ------------------------------------------------------------------------------- resumableTests :: TestTree resumableTests = testGroup "resumable" [ testGroup "resumeRetrying" [ testCase "can resume" $ do retryingTest resumeRetrying (\_ _ -> pure shouldRetry) ] , testGroup "resumeRetryingDynamic" [ testCase "can resume" $ do retryingTest resumeRetryingDynamic (\_ _ -> pure $ ConsultPolicy) ] , testGroup "resumeRecovering" [ testCase "can resume" $ do recoveringTest resumeRecovering testHandlers ] , testGroup "resumeRecoveringDynamic" [ testCase "can resume" $ do recoveringTest resumeRecoveringDynamic testHandlersDynamic ] , testGroup "resumeRecoverAll" [ testCase "can resume" $ do recoveringTest (\status policy () action -> resumeRecoverAll status policy action) () ] ] retryingTest :: (RetryStatus -> RetryPolicyM IO -> p -> (RetryStatus -> IO ()) -> IO ()) -> p -> IO () retryingTest resumableOp isRetryNeeded = do counterRef <- newIORef (0 :: Int) let go policy status = do atomicWriteIORef counterRef 0 resumableOp status policy isRetryNeeded (const $ atomicModifyIORef' counterRef $ \n -> (1 + n, ())) let policy = limitRetries 2 let nextStatus = nextStatusUsingPolicy policy go policy defaultRetryStatus (3 @=?) =<< readIORef counterRef go policy =<< nextStatus defaultRetryStatus (2 @=?) =<< readIORef counterRef go policy =<< nextStatus =<< nextStatus defaultRetryStatus (1 @=?) =<< readIORef counterRef recoveringTest :: (RetryStatus -> RetryPolicyM IO -> handlers -> (RetryStatus -> IO ()) -> IO ()) -> handlers -> IO () recoveringTest resumableOp handlers = do counterRef <- newIORef (0 :: Int) let go policy status = do action <- do mkFailUntilIO (\_ -> atomicModifyIORef' counterRef $ \n -> (1 + n, False)) Custom1 try $ resumableOp status policy handlers action let policy = limitRetries 2 let nextStatus = nextStatusUsingPolicy policy do atomicWriteIORef counterRef 0 res <- go policy defaultRetryStatus res @?= Left Custom1 (3 @=?) =<< readIORef counterRef do atomicWriteIORef counterRef 0 res <- go policy =<< nextStatus defaultRetryStatus res @?= Left Custom1 (2 @=?) =<< readIORef counterRef do atomicWriteIORef counterRef 0 res <- go policy =<< nextStatus =<< nextStatus defaultRetryStatus res @?= Left Custom1 (1 @=?) =<< readIORef counterRef ------------------------------------------------------------------------------- retryOnErrorTests :: TestTree retryOnErrorTests = testGroup "retryOnError" [ testCase "passes in the error type" $ do errCalls <- newTVarIO [] let policy = limitRetries 2 let shouldWeRetry _retryStat e = do liftIO (atomically (modifyTVar' errCalls (++ [e]))) return True let action rs = (throwError ("boom" ++ show (rsIterNumber rs))) res <- runExceptT (retryOnError policy shouldWeRetry action) res @?= (Left "boom2" :: Either String ()) calls <- atomically (readTVar errCalls) calls @?= ["boom0", "boom1", "boom2"] ] ------------------------------------------------------------------------------- nextStatusUsingPolicy :: RetryPolicyM IO -> RetryStatus -> IO RetryStatus nextStatusUsingPolicy policy status = do applyPolicy policy status >>= \case Nothing -> do assertFailure "applying policy produced no new status" Just status' -> do pure status' ------------------------------------------------------------------------------- isLeftAnd :: (a -> Bool) -> Either a b -> Bool isLeftAnd f ei = case ei of Left v -> f v _ -> False ------------------------------------------------------------------------------- testHandlers :: [a -> Handler IO Bool] testHandlers = [const $ Handler (\(_::SomeException) -> return shouldRetry)] ------------------------------------------------------------------------------- testHandlersDynamic :: [a -> Handler IO RetryAction] testHandlersDynamic = [const $ Handler (\(_::SomeException) -> return ConsultPolicy)] -- | Apply a function to adjacent list items. -- -- Ie.: -- > compareAdjacent f [a0, a1, a2, a3, ..., a(n-2), a(n-1), an] = -- > [f a0 a1, f a1 a2, f a2 a3, ..., f a(n-2) a(n-1), f a(n-1) an] -- -- Not defined for lists of length < 2. compareAdjacent :: (a -> a -> b) -> [a] -> [b] compareAdjacent f lst = reverse . snd $ foldl (\(a1, accum) a2 -> (a2, f a1 a2 : accum)) (head lst, []) (tail lst) data Custom1 = Custom1 deriving (Eq,Show,Read,Ord,Typeable) data Custom2 = Custom2 deriving (Eq,Show,Read,Ord,Typeable) instance Exception Custom1 instance Exception Custom2 ------------------------------------------------------------------------------- genRetryStatus :: MonadGen m => m RetryStatus genRetryStatus = do n <- Gen.int (Range.linear 0 maxBound) d <- Gen.int (Range.linear 0 maxBound) l <- Gen.maybe (Gen.int (Range.linear 0 d)) return $ defaultRetryStatus { rsIterNumber = n , rsCumulativeDelay = d , rsPreviousDelay = l} ------------------------------------------------------------------------------- -- | Generate an arbitrary 'RetryPolicy' without any limits applied. genPolicyNoLimit :: forall mg mr. (MonadGen mg, MIO.MonadIO mr) => Range Int -> mg (RetryPolicyM mr) genPolicyNoLimit durationRange = Gen.choice [ genConstantDelay , genExponentialBackoff , genFullJitterBackoff , genFibonacciBackoff ] where genDuration = Gen.int durationRange -- Retry policies genConstantDelay = fmap constantDelay genDuration genExponentialBackoff = fmap exponentialBackoff genDuration genFullJitterBackoff = fmap fullJitterBackoff genDuration genFibonacciBackoff = fmap fibonacciBackoff genDuration -- Needed to generate a 'RetryPolicyM' using 'forAll' instance Show (RetryPolicyM m) where show = const "RetryPolicyM" ------------------------------------------------------------------------------- -- | Create an action that will fail exactly N times with the given -- exception and will then return () in any subsequent calls. mkFailN :: (Exception e) => e -> Int -> IO (s -> IO ()) mkFailN e n = mkFailUntil (\iter -> iter >= n) e ------------------------------------------------------------------------------- -- | Create an action that will fail with the given exception until the given -- iteration predicate returns 'True', at which point the action will return -- '()' in any subsequent calls. mkFailUntil :: (Exception e) => (Int -> Bool) -> e -> IO (s -> IO ()) mkFailUntil p = mkFailUntilIO (pure . p) ------------------------------------------------------------------------------- -- | The same as 'mkFailUntil' but allows doing IO in the predicate. mkFailUntilIO :: (Exception e) => (Int -> IO Bool) -> e -> IO (s -> IO ()) mkFailUntilIO p e = do r <- newIORef 0 return $ const $ do old <- atomicModifyIORef' r $ \ old -> (old+1, old) p old >>= \case True -> return () False -> throwM e ------------------------------------------------------------------------------- gatherStatuses :: MonadIO m => RetryPolicyM (WriterT [RetryStatus] m) -> m [RetryStatus] gatherStatuses policy = execWriterT $ retrying policy (\_ _ -> return shouldRetry) (\rs -> tell [rs]) ------------------------------------------------------------------------------- -- | Just makes things a bit easier to follow instead of a magic value -- of @return True@ shouldRetry :: Bool shouldRetry = True retry-0.9.3.1/test/Tests/UnliftIO/Retry.hs0000644000000000000000000000330314264345463016442 0ustar0000000000000000module Tests.UnliftIO.Retry ( tests ) where ------------------------------------------------------------------------------- import Test.Tasty import Test.Tasty.HUnit (testCase) ------------------------------------------------------------------------------- import UnliftIO.Retry import Tests.Control.Retry hiding (tests) ------------------------------------------------------------------------------- tests :: TestTree tests = testGroup "UnliftIO.Retry" [ recoveringTests , maskingStateTests , quadraticDelayTests , resumableTests ] ------------------------------------------------------------------------------- recoveringTests :: TestTree recoveringTests = recoveringTestsWith recovering ------------------------------------------------------------------------------- maskingStateTests :: TestTree maskingStateTests = maskingStateTestsWith recovering ------------------------------------------------------------------------------- quadraticDelayTests :: TestTree quadraticDelayTests = quadraticDelayTestsWith recovering ------------------------------------------------------------------------------- resumableTests :: TestTree resumableTests = testGroup "resumable" [ testGroup "resumeRecovering" [ testCase "can resume" $ do recoveringTest resumeRecovering testHandlers ] , testGroup "resumeRecoveringDynamic" [ testCase "can resume" $ do recoveringTest resumeRecoveringDynamic testHandlersDynamic ] , testGroup "resumeRecoverAll" [ testCase "can resume" $ do recoveringTest (\status policy () action -> resumeRecoverAll status policy action) () ] ] retry-0.9.3.1/LICENSE0000644000000000000000000000276213334570257012242 0ustar0000000000000000Copyright (c) 2013, Ozgun Ataman All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Ozgun Ataman nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. retry-0.9.3.1/Setup.hs0000644000000000000000000000005613334570257012663 0ustar0000000000000000import Distribution.Simple main = defaultMain retry-0.9.3.1/retry.cabal0000644000000000000000000000457214417324124013360 0ustar0000000000000000name: retry description: This package 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 purpose is to make it easier to work with IO and especially network IO actions that often experience temporary failure and warrant retrying of the original action. For example, a database query may time out for a while, in which case we should hang back for a bit and retry the query instead of simply raising an exception. version: 0.9.3.1 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE author: Ozgun Ataman maintainer: ozgun.ataman@soostone.com copyright: Ozgun Ataman, Soostone Inc category: Control build-type: Simple cabal-version: >=1.10 homepage: http://github.com/Soostone/retry extra-source-files: README.md changelog.md flag lib-Werror default: False manual: True library exposed-modules: Control.Retry UnliftIO.Retry build-depends: base >= 4.8 && < 5 , exceptions >= 0.5 , ghc-prim , random >= 1 , transformers , mtl , mtl-compat , unliftio-core >= 0.1.0.0 hs-source-dirs: src default-language: Haskell2010 if flag(lib-Werror) ghc-options: -Werror ghc-options: -Wall test-suite test type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test,src ghc-options: -threaded other-modules: Control.Retry UnliftIO.Retry Tests.Control.Retry Tests.UnliftIO.Retry build-depends: base ==4.* , exceptions , transformers , random , time , HUnit >= 1.2.5.2 , tasty , tasty-hunit , tasty-hedgehog , hedgehog >= 1.0 , stm , ghc-prim , mtl , mtl-compat , unliftio-core default-language: Haskell2010 if flag(lib-Werror) ghc-options: -Werror ghc-options: -Wall source-repository head type: git location: git://github.com/Soostone/retry.git retry-0.9.3.1/README.md0000644000000000000000000000174314207751257012513 0ustar0000000000000000# README [![Build Status](https://travis-ci.org/Soostone/retry.svg?branch=master)](https://travis-ci.org/Soostone/retry) [![Coverage Status](https://coveralls.io/repos/Soostone/retry/badge.png?branch=master)](https://coveralls.io/r/Soostone/retry?branch=master) retry - combinators for monadic actions that may fail ## About Monadic action combinators that add delayed-retry functionality, potentially with exponential-backoff, to arbitrary actions. The main purpose of this package is to make it easy to work reliably with IO and similar actions that often fail. Common examples are database queries and large file uploads. ## Documentation Please see haddocks for documentation. ## Changes See [https://github.com/Soostone/retry/blob/master/changelog.md](changelog.md). ## Author Ozgun Ataman, Soostone Inc ## Contributors Contributors, please list yourself here. - Mitsutoshi Aoe (@maoe) - John Wiegley - Michael Snoyman - Michael Xavier - Toralf Wittner - Marco Zocca (@ocramz) retry-0.9.3.1/changelog.md0000644000000000000000000000732014417324177013502 0ustar00000000000000000.9.3.1 * Resolve warnings in test suite [PR 83](https://github.com/Soostone/retry/pull/83) 0.9.3.0 * Add `UnliftIO.Retry` [PR 81](https://github.com/Soostone/retry/pull/81) 0.9.2.1 * Use explicit import for `lift` which allows for mtl-2.3 compatibility [PR 80](https://github.com/Soostone/retry/pull/80) 0.9.2.0 * Add `retryOnError` [PR 44](https://github.com/Soostone/retry/pull/44) 0.9.1.0 * Add resumable retry/recover variants: * `resumeRetrying` * `resumeRetryingDynamic` * `resumeRecovering` * `resumeRecoveringDynamic` * `resumeRecoverAll` 0.9.0.0 * Replace several uses of RetryPolicy type alias with RetryPolicyM m for better GHC 9 compat. 0.8.1.2 * Set lower bound on base to >= 4.8 0.8.1.1 * Loosen upper bounds 0.8.1.0 * Add `retryingDynamic` and `recoveringDynamic`. [PR 65](https://github.com/Soostone/retry/pull/65) 0.8.0.2 * Update docs for default retry policy. [PR 64](https://github.com/Soostone/retry/pull/64) 0.8.0.1 * Loosen upper bounds 0.8.0.0 * Remove dependency on data-default-class 0.7.7.0 * Add `natTransformRetryPolicy` 0.7.6.3 * Documentation fix on `recoverAll` 0.7.6.2 * Loosen bounds on exceptions again. 0.7.6.1 * Loosen bounds on exceptions. 0.7.6.0 * Clarify the semantics of `limitRetriesByDelay`. * Add `limitRetriesByCumulativeDelay` 0.7.5.1 * Improve haddocks for fullJitterBackoff. 0.7.5.0 * Add Semigroup instance when the Semigroup class is available through base. 0.7.4.3 * Loosen dependency upper bounds. 0.7.5 * Add skipAsyncExceptions helper function 0.7.4.2 * Loosen HUnit dependency for tests. 0.7.4.1 * Loosen QuickCheck dependency for tests. 0.7.4 * Widen transformers dependency 0.7.3 * Widen ghc-prim dependency for GHC 8 0.7.2 * Fix premature integer overflow error thanks to Mitsutoshi Aoe 0.7.1 * Various documentation updates. * Add stepping combinator for manual retries. * Add applyPolicy and applyAndDelay * Add Read instance for RetryStatus * Fix logic bug in rsPreviousDelay in first retry 0.7.0.1 * Officially drop support for GHC < 7.6 due to usage of Generics. 0.7 * RetryPolicy has become RetryPolicyM, allowing for policy logic to consult the monad context. * RetryPolicyM now takes a RetryStatus value. Use the function rsIterNum to preserve existing behavior of RetryPolicy only receiving the number. * The monadic action now gets the RetryStatus on each try. Use const if you don't need it. * recoverAll explicitly does not handle the standard async exceptions. Users are encouraged to do the same when using recovering, as catching async exceptions can be hazardous. * We no longer re-export (<>) from Monoid. * Utility functions simulatePolicy and simulatePolicyPP have been added which help predict how a policy will behave on each iteration. 0.6 * Actions are now retried in the original masking state, while handlers continue to run in `MaskedInterruptible` (@maoe) * Added several tests confirming exception hierarchy semantics under `recovering` (@ozataman) 0.5 * Mitsutoshi's backoff work inspired a complete redo of the RetryPolicy interface, replacing it with a monoidal RetryPolicy. The result is a much thinner API that actually provides much more power to the end user. * Now using microseconds in all premade policies. PLEASE TAKE CARE WHEN UPGRADING. It was a bad idea to use miliseconds and deviate from norms in the first place. 0.4 * Transitioned to using Edward Kmett's exceptions package instead of monad-control. Use 0.3 series if you still need monad-control support. 0.3 Thanks to John Wiegley and Michael Snoyman for their contributions: * Now using monad-control instead of MonadCatchIO, which is widely agreed to be broken. * Now using transformers instead of mtl, which was a broader than needed dependency.