retry 0.5.1 → 0.9.3.1
raw patch · 9 files changed
Files
- README.md +35/−0
- changelog.md +141/−0
- retry.cabal +50/−18
- src/Control/Retry.hs +780/−102
- src/UnliftIO/Retry.hs +268/−0
- test/Main.hs +24/−0
- test/Tests/Control/Retry.hs +637/−0
- test/Tests/UnliftIO/Retry.hs +55/−0
- test/main.hs +0/−2
+ README.md view
@@ -0,0 +1,35 @@+# README [](https://travis-ci.org/Soostone/retry) [](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)
+ changelog.md view
@@ -0,0 +1,141 @@+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`++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.
retry.cabal view
@@ -1,6 +1,6 @@ name: retry -description: +description: This package exposes combinators that can wrap arbitrary monadic actions. They run the action and potentially retry@@ -14,7 +14,7 @@ case we should hang back for a bit and retry the query instead of simply raising an exception. -version: 0.5.1+version: 0.9.3.1 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE@@ -24,36 +24,68 @@ category: Control build-type: Simple cabal-version: >=1.10-Homepage: http://github.com/Soostone/retry+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- build-depends: - base ==4.*- , data-default-class- , exceptions >= 0.5 && < 0.7- , transformers < 0.5+ 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+ main-is: Main.hs hs-source-dirs: test,src ghc-options: -threaded- build-depends: - base ==4.* - , exceptions >= 0.5 && < 0.6+ other-modules: Control.Retry+ UnliftIO.Retry+ Tests.Control.Retry+ Tests.UnliftIO.Retry+ build-depends:+ base ==4.*+ , exceptions , transformers- , data-default-class+ , random , time- , QuickCheck >= 2.7 && < 2.8- , HUnit >= 1.2.5.2 && < 1.3- , hspec >= 1.9 && < 1.10+ , 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
src/Control/Retry.hs view
@@ -1,9 +1,12 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- -- |@@ -28,42 +31,97 @@ module Control.Retry (- -- * High Level Operation- RetryPolicy (..)+ -- * 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- , capDelay - -- * Re-export from Data.Monoid-- , (<>)+ -- * 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.IO.Class-import Data.Default.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.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-import Prelude hiding (catch)+# endif+import Prelude ------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- | A 'RetryPolicy' is a function that takes an iteration number and--- possibly returns a delay in miliseconds. *Nothing* implies we have--- reached the retry limit.+-- | 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 'RetryPolicy' is a 'Monoid'. You can collapse+-- 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: --@@ -80,80 +138,289 @@ -- One can easily define an exponential backoff policy with a limited -- number of retries: ----- >> limitedBackoff = exponentialBackoff 50 <> limitedRetries 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 'RetryPolicy':+-- For anything more complex, just define your own 'RetryPolicyM': ----- >> myPolicy = RetryPolicy $ \ n -> if n > 10 then Just 1000 else Just 10000-newtype RetryPolicy = RetryPolicy { getRetryPolicy :: Int -> Maybe Int }+-- >> 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) } -instance Default RetryPolicy where- def = constantDelay 50000 <> limitRetries 5+-- | 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 -instance Monoid RetryPolicy where- mempty = RetryPolicy $ (const (Just 0))- (RetryPolicy a) `mappend` (RetryPolicy b) = RetryPolicy $ \ n -> do- a' <- a n- b' <- b n+-- | 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 $ \ n -> if n >= i then Nothing else (Just 0)+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- :: Int+ :: (Monad m)+ => Int -- ^ Base delay in microseconds- -> RetryPolicy-constantDelay delay = RetryPolicy (const (Just delay))+ -> RetryPolicyM m+constantDelay delay = retryPolicy (const (Just delay)) ---------------------------------------------------------------------------------- | Grow delay exponentially each iteration.+-- | Grow delay exponentially each iteration. Each delay will+-- increase by a factor of two. exponentialBackoff- :: Int+ :: (Monad m)+ => Int -- ^ Base delay in microseconds- -> RetryPolicy-exponentialBackoff base = RetryPolicy $ \ n -> Just (2^n * base)+ -> 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- :: Int+ :: (Monad m)+ => Int -- ^ Base delay in microseconds- -> RetryPolicy-fibonacciBackoff base = RetryPolicy $ \ n -> Just $ fib (n + 1) (0, base)+ -> 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 + b)+ fib !m (!a, !b) = fib (m-1) (b, a `boundedPlus` b) ---------------------------------------------------------------------------------- | Set an upperbound for any delays that may be directed by the--- given policy.+-- | 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- :: Int+ :: Monad m+ => Int -- ^ A maximum delay in microseconds- -> RetryPolicy- -> RetryPolicy-capDelay limit p = RetryPolicy $ \ n -> min limit `fmap` (getRetryPolicy p) n+ -> RetryPolicyM m+ -> RetryPolicyM m+capDelay limit p = RetryPolicyM $ \ n ->+ fmap (min limit) `fmap` getRetryPolicyM p n -------------------------------------------------------------------------------@@ -165,8 +432,8 @@ -- retry it 5 additional times following the initial run: -- -- >>> import Data.Maybe--- >>> let f = putStrLn "Running action" >> return Nothing--- >>> retrying def isNothing f+-- >>> let f _ = putStrLn "Running action" >> return Nothing+-- >>> retrying retryPolicyDefault (const $ return . isNothing) f -- Running action -- Running action -- Running action@@ -177,39 +444,120 @@ -- -- Note how the latest failing result is returned after all retries -- have been exhausted.-retrying :: MonadIO m- => RetryPolicy- -> (Int -> b -> m Bool)- -- ^ An action to check whether the result should be retried.- -- If True, we delay and retry the operation.- -> m b- -- ^ Action to run- -> m b-retrying (RetryPolicy policy) chk f = go 0- where- go n = do- res <- f- chk' <- chk n res- case chk' of- True ->- case (policy n) of- Just delay -> do- liftIO (threadDelay delay)- go $! n+1- Nothing -> return res- False -> return res+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'.+-- 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 def f+-- >>> let f _ = putStrLn "Running action" >> error "this is an error"+-- >>> recoverAll retryPolicyDefault f -- Running action -- Running action -- Running action@@ -217,49 +565,379 @@ -- Running action -- Running action -- *** Exception: this is an error-recoverAll :: (MonadIO m, MonadCatch m)- => RetryPolicy+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-recoverAll set f = recovering set [h] f+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.-recovering :: forall m a. (MonadIO m, MonadCatch m)- => RetryPolicy- -- ^ Just use 'def' faor default settings- -> [(Int -> Handler m Bool)]- -- ^ Should a given exception be retried? Action will be- -- retried if this returns True.- -> m a- -- ^ Action to perform- -> m a-recovering (RetryPolicy policy) hs f = go 0+-- 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' - -- | Convert a (e -> m Bool) handler into (e -> m a) so it can- -- be wired into the 'catches' combinator.- transHandler :: Int -> Handler m Bool -> Handler m a- transHandler n (Handler h) = Handler $ \ e -> do- chk <- h e- case chk of- True ->- case policy n of- Just delay -> do- liftIO (threadDelay delay)- go $! n+1- Nothing -> throwM e- False -> throwM e - go n = f `catches` map (transHandler n . ($ n)) 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 -- ------------------@@ -273,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
+ src/UnliftIO/Retry.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------+-- |+-- Module : UnliftIO.Retry+-- Copyright : Ozgun Ataman <ozgun.ataman@soostone.com>+-- License : BSD3+--+-- Maintainer : Patrick Brisbin <pbrisbin@gmail.com>+-- Stability : provisional+--+-- Unlifted "Control.Retry".+--+-- @since 0.9.3.0+----------------------------------------------------------------------------+++module UnliftIO.Retry+ (+ -- * Types and Operations+ RetryPolicyM (..)+ , RetryPolicy+ , retryPolicy+ , retryPolicyDefault+ , natTransformRetryPolicy+ , RetryAction (..)+ , toRetryAction+ , RetryStatus (..)+ , defaultRetryStatus+ , applyPolicy+ , applyAndDelay+++ -- ** Lenses for 'RetryStatus'+ , rsIterNumberL+ , rsCumulativeDelayL+ , rsPreviousDelayL++ -- * Applying Retry Policies+ , retrying+ , retryingDynamic+ , recovering+ , recoveringDynamic+ , stepping+ , recoverAll+ , skipAsyncExceptions+ , logRetries+ , defaultLogMsg+ , retryOnError+ -- ** Resumable variants+ , resumeRetrying+ , resumeRetryingDynamic+ , resumeRecovering+ , resumeRecoveringDynamic+ , resumeRecoverAll++ -- * Retry Policies+ , constantDelay+ , exponentialBackoff+ , fullJitterBackoff+ , fibonacciBackoff+ , limitRetries++ -- * Policy Transformers+ , limitRetriesByDelay+ , limitRetriesByCumulativeDelay+ , capDelay++ -- * Development Helpers+ , simulatePolicy+ , simulatePolicyPP+ ) where++-------------------------------------------------------------------------------+import Control.Retry hiding+ ( recoverAll+ , recovering+ , recoveringDynamic+ , resumeRecovering+ , resumeRecoveringDynamic+ , resumeRecoverAll+ , stepping+ )+import qualified Control.Retry as Retry+import Control.Monad.Catch (Handler(..))+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Prelude+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+-- | Run an action and recover from a raised exception by potentially+-- retrying the action a number of times. Note that if you're going to+-- use a handler for 'SomeException', you should add explicit cases+-- *earlier* in the list of handlers to reject 'AsyncException' and+-- 'SomeAsyncException', as catching these can cause thread and+-- program hangs. 'recoverAll' already does this for you so if you+-- just plan on catching 'SomeException', you may as well use+-- 'recoverAll'+recovering+ :: MonadUnliftIO m+ => RetryPolicyM m+ -- ^ Just use 'retryPolicyDefault' for default settings+ -> [RetryStatus -> Handler m Bool]+ -- ^ Should a given exception be retried? Action will be+ -- retried if this returns True *and* the policy allows it.+ -- This action will be consulted first even if the policy+ -- later blocks it.+ -> (RetryStatus -> m a)+ -- ^ Action to perform+ -> m a+recovering = 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
+ test/Main.hs view
@@ -0,0 +1,24 @@+module 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+ ]
+ test/Tests/Control/Retry.hs view
@@ -0,0 +1,637 @@+{-# 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
+ test/Tests/UnliftIO/Retry.hs view
@@ -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)+ ()+ ]+ ]
− test/main.hs
@@ -1,2 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}-