retry 0.7.7.0 → 0.9.3.1
raw patch · 8 files changed
Files
- README.md +1/−3
- changelog.md +42/−0
- retry.cabal +15/−9
- src/Control/Retry.hs +287/−61
- src/UnliftIO/Retry.hs +268/−0
- test/Main.hs +2/−0
- test/Tests/Control/Retry.hs +294/−33
- test/Tests/UnliftIO/Retry.hs +55/−0
README.md view
@@ -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)-
changelog.md view
@@ -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`
retry.cabal view
@@ -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)
src/Control/Retry.hs view
@@ -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
+ 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
@@ -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 ]
test/Tests/Control/Retry.hs view
@@ -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
+ 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)+ ()+ ]+ ]