diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -11,7 +11,6 @@ with IO and similar actions that often fail. Common examples are database queries and large file uploads. - ## Documentation Please see haddocks for documentation. @@ -24,7 +23,6 @@ Ozgun Ataman, Soostone Inc - ## Contributors Contributors, please list yourself here. @@ -33,5 +31,5 @@ - John Wiegley - Michael Snoyman - Michael Xavier +- Toralf Wittner - Marco Zocca (@ocramz) - diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,45 @@ +0.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` diff --git a/retry.cabal b/retry.cabal --- a/retry.cabal +++ b/retry.cabal @@ -14,7 +14,7 @@ case we should hang back for a bit and retry the query instead of simply raising an exception. -version: 0.7.7.0 +version: 0.9.3.1 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE @@ -35,13 +35,16 @@ library exposed-modules: Control.Retry + UnliftIO.Retry build-depends: - base >= 4.6 && < 5 - , data-default-class - , exceptions >= 0.5 && < 0.11 - , ghc-prim < 0.6 - , random >= 1 && < 1.2 - , transformers < 0.7 + 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 @@ -57,22 +60,25 @@ 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 - , data-default-class , random , time , HUnit >= 1.2.5.2 , tasty , tasty-hunit , tasty-hedgehog - , hedgehog + , hedgehog >= 1.0 , stm , ghc-prim , mtl + , mtl-compat + , unliftio-core default-language: Haskell2010 if flag(lib-Werror) diff --git a/src/Control/Retry.hs b/src/Control/Retry.hs --- a/src/Control/Retry.hs +++ b/src/Control/Retry.hs @@ -3,8 +3,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ViewPatterns #-} @@ -35,7 +35,10 @@ RetryPolicyM (..) , RetryPolicy , retryPolicy + , retryPolicyDefault , natTransformRetryPolicy + , RetryAction (..) + , toRetryAction , RetryStatus (..) , defaultRetryStatus , applyPolicy @@ -49,12 +52,21 @@ -- * Applying Retry Policies , retrying + , retryingDynamic , recovering + , recoveringDynamic , stepping , recoverAll , skipAsyncExceptions , logRetries , defaultLogMsg + , retryOnError + -- ** Resumable variants + , resumeRetrying + , resumeRetryingDynamic + , resumeRecovering + , resumeRecoveringDynamic + , resumeRecoverAll -- * Retry Policies , constantDelay @@ -83,11 +95,11 @@ #endif import Control.Monad import Control.Monad.Catch -import Control.Monad.IO.Class -import Control.Monad.Trans.Class +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.Default.Class import Data.List (foldl') import Data.Maybe import GHC.Generics @@ -126,18 +138,18 @@ -- One can easily define an exponential backoff policy with a limited -- number of retries: -- --- >> limitedBackoff = exponentialBackoff 50 <> limitRetries 5 +-- >> 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 under 'def' implements a constant 50ms delay, up to 5 times: +-- The default retry policy 'retryPolicyDefault' implements a constant 50ms delay, up to 5 times: -- --- >> def = constantDelay 50000 <> limitRetries 5 +-- >> retryPolicyDefault = constantDelay 50000 <> limitRetries 5 -- -- For anything more complex, just define your own 'RetryPolicyM': -- --- >> myPolicy = retryPolicy $ \ rs -> if rsIterNumber n > 10 then Just 1000 else Just 10000 +-- >> 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) } @@ -148,9 +160,9 @@ -- type signatures pre-0.7. type RetryPolicy = forall m . Monad m => RetryPolicyM m - -instance Monad m => Default (RetryPolicyM m) where - def = constantDelay 50000 <> limitRetries 5 +-- | 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 @@ -192,16 +204,32 @@ 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 + + ------------------------------------------------------------------------------- --- | Datatype with stats about retries made thus far. The constructor --- is deliberately not exported to make additional fields easier to --- add in a backward-compatible manner. To read or modify fields in --- RetryStatus, use the accessors or lenses below. Note that if you --- don't want to use lenses, the exported field names can be used for --- updates: --- --- >> retryStatus { rsIterNumber = newIterNumber } --- >> retryStatus & rsIterNumberL .~ newIterNumber +-- | 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 @@ -210,8 +238,7 @@ ------------------------------------------------------------------------------- --- | Initial, default retry status. Exported mostly to allow user code --- to test their handlers and retry policies. Use fields or lenses to update. +-- | Initial, default retry status. Use fields or lenses to update. defaultRetryStatus :: RetryStatus defaultRetryStatus = RetryStatus 0 0 Nothing @@ -256,7 +283,7 @@ -- | Apply policy and delay by its amount if it results in a retry. -- Return updated status. applyAndDelay - :: MonadIO m + :: MIO.MonadIO m => RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus) @@ -264,7 +291,7 @@ chk <- applyPolicy policy s case chk of Just rs -> do - case (rsPreviousDelay rs) of + case rsPreviousDelay rs of Nothing -> return () Just delay -> liftIO $ threadDelay delay return (Just rs) @@ -275,7 +302,7 @@ ------------------------------------------------------------------------------- -- | Helper for making simplified policies that don't use the monadic -- context. -retryPolicy :: (RetryStatus -> Maybe Int) -> RetryPolicy +retryPolicy :: (Monad m) => (RetryStatus -> Maybe Int) -> RetryPolicyM m retryPolicy f = RetryPolicyM $ \ s -> return (f s) @@ -285,7 +312,7 @@ :: Int -- ^ Maximum number of retries. -> RetryPolicy -limitRetries i = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> if n >= i then Nothing else (Just 0) +limitRetries i = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> if n >= i then Nothing else Just 0 ------------------------------------------------------------------------------- @@ -301,7 +328,7 @@ -> RetryPolicyM m -> RetryPolicyM m limitRetriesByDelay i p = RetryPolicyM $ \ n -> - (>>= limit) `liftM` getRetryPolicyM p n + (>>= limit) `fmap` getRetryPolicyM p n where limit delay = if delay >= i then Nothing else Just delay @@ -317,7 +344,7 @@ -> RetryPolicyM m -> RetryPolicyM m limitRetriesByCumulativeDelay cumulativeLimit p = RetryPolicyM $ \ stat -> - (>>= limit stat) `liftM` getRetryPolicyM p stat + (>>= limit stat) `fmap` getRetryPolicyM p stat where limit status curDelay | rsCumulativeDelay status `boundedPlus` curDelay > cumulativeLimit = Nothing @@ -327,9 +354,10 @@ ------------------------------------------------------------------------------- -- | Implement a constant delay with unlimited retries. constantDelay - :: Int + :: (Monad m) + => Int -- ^ Base delay in microseconds - -> RetryPolicy + -> RetryPolicyM m constantDelay delay = retryPolicy (const (Just delay)) @@ -337,9 +365,10 @@ -- | Grow delay exponentially each iteration. Each delay will -- increase by a factor of two. exponentialBackoff - :: Int + :: (Monad m) + => Int -- ^ Base delay in microseconds - -> RetryPolicy + -> RetryPolicyM m exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n } -> Just $! base `boundedMult` boundedPow 2 n @@ -353,7 +382,7 @@ -- -- sleep = temp \/ 2 + random_between(0, temp \/ 2) fullJitterBackoff - :: MonadIO m + :: (MonadIO m) => Int -- ^ Base delay in microseconds -> RetryPolicyM m @@ -366,9 +395,10 @@ ------------------------------------------------------------------------------- -- | Implement Fibonacci backoff. fibonacciBackoff - :: Int + :: (Monad m) + => Int -- ^ Base delay in microseconds - -> RetryPolicy + -> RetryPolicyM m fibonacciBackoff base = retryPolicy $ \RetryStatus { rsIterNumber = n } -> Just $ fib (n + 1) (0, base) where @@ -390,7 +420,7 @@ -> RetryPolicyM m -> RetryPolicyM m capDelay limit p = RetryPolicyM $ \ n -> - (fmap (min limit)) `liftM` (getRetryPolicyM p) n + fmap (min limit) `fmap` getRetryPolicyM p n ------------------------------------------------------------------------------- @@ -403,7 +433,7 @@ -- -- >>> import Data.Maybe -- >>> let f _ = putStrLn "Running action" >> return Nothing --- >>> retrying def (const $ return . isNothing) f +-- >>> retrying retryPolicyDefault (const $ return . isNothing) f -- Running action -- Running action -- Running action @@ -422,18 +452,95 @@ -> (RetryStatus -> m b) -- ^ Action to run -> m b -retrying policy chk f = go defaultRetryStatus +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 - True -> do - rs <- applyAndDelay policy s - case rs of - Nothing -> return res - Just rs' -> go $! rs' - False -> return res + DontRetry -> return res + ConsultPolicy -> consultPolicy policy + ConsultPolicyOverrideDelay delay -> + consultPolicy $ modifyRetryPolicyDelay (const delay) policy ------------------------------------------------------------------------------- @@ -450,7 +557,7 @@ -- before finally failing for good: -- -- >>> let f _ = putStrLn "Running action" >> error "this is an error" --- >>> recoverAll def f +-- >>> recoverAll retryPolicyDefault f -- Running action -- Running action -- Running action @@ -467,7 +574,24 @@ => RetryPolicyM m -> (RetryStatus -> m a) -> m a -recoverAll set f = recovering set handlers f +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 @@ -500,7 +624,7 @@ -- *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 ues +-- just plan on catching 'SomeException', you may as well use -- 'recoverAll' recovering #if MIN_VERSION_exceptions(0, 6, 0) @@ -509,7 +633,31 @@ :: (MonadIO m, MonadCatch m) #endif => RetryPolicyM m - -- ^ Just use 'def' for default settings + -- ^ 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. @@ -518,7 +666,58 @@ -> (RetryStatus -> m a) -- ^ Action to perform -> m a -recovering policy hs f = mask $ \restore -> go restore defaultRetryStatus +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 @@ -531,18 +730,20 @@ 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 - True -> do - rs <- applyAndDelay policy s - case rs of - Just rs' -> loop $! rs' - Nothing -> throwM e' - False -> throwM e' + 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 @@ -555,8 +756,8 @@ :: (MonadIO m, MonadCatch m) #endif => RetryPolicyM m - -- ^ Just use 'def' for default settings - -> [(RetryStatus -> Handler m Bool)] + -- ^ 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 @@ -619,13 +820,38 @@ ------------------------------------------------------------------------------- +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 <- lift (f stat) + delay <- TC.lift (f stat) put $! stat { rsIterNumber = i + 1 , rsCumulativeDelay = rsCumulativeDelay stat `boundedPlus` fromMaybe 0 delay @@ -643,7 +869,7 @@ forM_ ps $ \ (iterNo, res) -> putStrLn $ show iterNo <> ": " <> maybe "Inhibit" ppTime res putStrLn $ "Total cumulative delay would be: " <> - (ppTime $ boundedSum $ (mapMaybe snd) ps) + ppTime (boundedSum $ mapMaybe snd ps) ------------------------------------------------------------------------------- @@ -725,7 +951,7 @@ -- instance Exception AnotherException --- test = retrying def [h1,h2] f +-- test = retrying retryPolicyDefault [h1,h2] f -- where -- f = putStrLn "Running action" >> throwM AnotherException -- h1 = Handler $ \ (e :: TestException) -> return False diff --git a/src/UnliftIO/Retry.hs b/src/UnliftIO/Retry.hs new file mode 100644 --- /dev/null +++ b/src/UnliftIO/Retry.hs @@ -0,0 +1,268 @@ +{-# 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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -7,6 +7,7 @@ import Test.Tasty ------------------------------------------------------------------------------- import qualified Tests.Control.Retry +import qualified Tests.UnliftIO.Retry ------------------------------------------------------------------------------- @@ -19,4 +20,5 @@ tests :: TestTree tests = testGroup "retry" [ Tests.Control.Retry.tests + , Tests.UnliftIO.Retry.tests ] diff --git a/test/Tests/Control/Retry.hs b/test/Tests/Control/Retry.hs --- a/test/Tests/Control/Retry.hs +++ b/test/Tests/Control/Retry.hs @@ -1,21 +1,31 @@ +{-# 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 Control.Exception (AsyncException (..), IOException, - MaskingState (..), - getMaskingState, throwTo) +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 +import Control.Monad.IO.Class as MIO import Control.Monad.Writer.Strict -import Data.Default.Class (def) import Data.Either import Data.IORef import Data.List @@ -29,7 +39,9 @@ import System.IO.Error import Test.Tasty import Test.Tasty.Hedgehog -import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import Test.Tasty.HUnit ( assertBool, assertFailure + , testCase, (@=?), (@?=) + ) ------------------------------------------------------------------------------- import Control.Retry ------------------------------------------------------------------------------- @@ -45,17 +57,27 @@ , maskingStateTests , capDelayTests , limitRetriesByCumulativeDelayTests + , overridingDelayTests + , resumableTests + , retryOnErrorTests ] ------------------------------------------------------------------------------- recoveringTests :: TestTree -recoveringTests = testGroup "recovering" +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 + res <- liftIO $ try $ recovering' (constantDelay timeout <> limitRetries retries) testHandlers (const $ throwM (userError "booo")) @@ -73,7 +95,7 @@ recoverAll (limitRetries 2) (const work) `finally` putMVar done () atomically (STM.check . (== 1) =<< readTVar counter) - throwTo tid UserInterrupt + EX.throwTo tid EX.UserInterrupt takeMVar done @@ -82,7 +104,7 @@ , testCase "recovers from custom exceptions" $ do f <- mkFailN Custom1 2 - res <- try $ recovering + res <- try $ recovering' (constantDelay 5000 <> limitRetries 3) [const $ Handler $ \ Custom1 -> return shouldRetry] f @@ -90,7 +112,7 @@ , testCase "fails beyond policy using custom exceptions" $ do f <- mkFailN Custom1 3 - res <- try $ recovering + res <- try $ recovering' (constantDelay 5000 <> limitRetries 2) [const $ Handler $ \ Custom1 -> return shouldRetry] f @@ -105,7 +127,7 @@ , testCase "does not recover from unhandled exceptions" $ do f <- mkFailN Custom2 2 - res <- try $ recovering + res <- try $ recovering' (constantDelay 5000 <> limitRetries 5) [const $ Handler $ \ Custom1 -> return shouldRetry] f @@ -114,7 +136,7 @@ , testCase "recovers in presence of multiple handlers" $ do f <- mkFailN Custom2 2 - res <- try $ recovering + res <- try $ recovering' (constantDelay 5000 <> limitRetries 5) [ const $ Handler $ \ Custom1 -> return shouldRetry , const $ Handler $ \ Custom2 -> return shouldRetry ] @@ -124,7 +146,7 @@ , testCase "general exceptions catch specific ones" $ do f <- mkFailN Custom2 2 - res <- try $ recovering + res <- try $ recovering' (constantDelay 5000 <> limitRetries 5) [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] f @@ -133,7 +155,7 @@ , testCase "(redundant) even general catchers don't go beyond policy" $ do f <- mkFailN Custom2 3 - res <- try $ recovering + res <- try $ recovering' (constantDelay 5000 <> limitRetries 2) [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] f @@ -143,7 +165,7 @@ , testCase "rethrows in presence of failed exception casts" $ do f <- mkFailN Custom2 3 final <- try $ do - res <- try $ recovering + res <- try $ recovering' (constantDelay 5000 <> limitRetries 2) [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] f @@ -224,28 +246,35 @@ ------------------------------------------------------------------------------- maskingStateTests :: TestTree -maskingStateTests = testGroup "masking state" +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 <- getMaskingState - final <- try $ recovering def testHandlers $ const $ do - maskingState' <- getMaskingState + maskingState <- EX.getMaskingState + final <- try $ recovering' retryPolicyDefault testHandlers $ const $ do + maskingState' <- EX.getMaskingState maskingState' @?= maskingState fail "Retrying..." assertBool - ("Expected IOException but didn't get one") - (isLeft (final :: Either IOException ())) + ("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 <- getMaskingState - maskingState @?= MaskedInterruptible + maskingState <- EX.getMaskingState + maskingState @?= EX.MaskedInterruptible return shouldRetry ] - final <- try $ recovering def checkMaskingStateHandlers $ const $ fail "Retrying..." + final <- try $ recovering' retryPolicyDefault checkMaskingStateHandlers $ const $ fail "Retrying..." assertBool - ("Expected IOException but didn't get one") - (isLeft (final :: Either IOException ())) + ("Expected EX.IOException but didn't get one") + (isLeft (final :: Either EX.IOException ())) ] @@ -257,8 +286,8 @@ cap <- forAll (Gen.int (Range.linear 1 maxBound)) let policy = capDelay cap (limitRetries retries) let delays = runIdentity (simulatePolicy (retries + 1) policy) - let Just lastDelay = lookup (retries - 1) delays - let Just gaveUp = lookup retries delays + 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 @@ -298,12 +327,19 @@ ------------------------------------------------------------------------------- quadraticDelayTests :: TestTree -quadraticDelayTests = testGroup "quadratic delay" +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 + res <- liftIO $ try $ recovering' (exponentialBackoff timeout <> limitRetries retries) [const $ Handler (\(_::SomeException) -> return True)] (const $ throwM (userError "booo")) @@ -314,16 +350,196 @@ 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) @@ -344,17 +560,62 @@ ------------------------------------------------------------------------------- +-- | 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 = do +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) - case old >= n of + p old >>= \case True -> return () False -> throwM e diff --git a/test/Tests/UnliftIO/Retry.hs b/test/Tests/UnliftIO/Retry.hs new file mode 100644 --- /dev/null +++ b/test/Tests/UnliftIO/Retry.hs @@ -0,0 +1,55 @@ +module 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) + () + ] + ]