From 322e1baecb8667cace6b14436ef2f3d8cc86cd05 Mon Sep 17 00:00:00 2001 From: Clint Adams Date: Thu, 21 Jul 2022 21:32:12 +0100 Subject: [PATCH] Import haskell-retry_0.9.2.1.orig.tar.gz [dgit import orig haskell-retry_0.9.2.1.orig.tar.gz] --- LICENSE | 30 ++ README.md | 35 ++ Setup.hs | 2 + changelog.md | 135 +++++ retry.cabal | 86 ++++ src/Control/Retry.hs | 958 ++++++++++++++++++++++++++++++++++++ test/Main.hs | 22 + test/Tests/Control/Retry.hs | 607 +++++++++++++++++++++++ 8 files changed, 1875 insertions(+) create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 changelog.md create mode 100644 retry.cabal create mode 100644 src/Control/Retry.hs create mode 100644 test/Main.hs create mode 100644 test/Tests/Control/Retry.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f42500f --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Ozgun Ataman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ozgun Ataman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..b717f85 --- /dev/null +++ b/README.md @@ -0,0 +1,35 @@ +# README [![Build Status](https://travis-ci.org/Soostone/retry.svg?branch=master)](https://travis-ci.org/Soostone/retry) [![Coverage Status](https://coveralls.io/repos/Soostone/retry/badge.png?branch=master)](https://coveralls.io/r/Soostone/retry?branch=master) + +retry - combinators for monadic actions that may fail + +## About + +Monadic action combinators that add delayed-retry functionality, +potentially with exponential-backoff, to arbitrary actions. + +The main purpose of this package is to make it easy to work reliably +with IO and similar actions that often fail. Common examples are +database queries and large file uploads. + +## Documentation + +Please see haddocks for documentation. + +## Changes + +See [https://github.com/Soostone/retry/blob/master/changelog.md](changelog.md). + +## Author + +Ozgun Ataman, Soostone Inc + +## Contributors + +Contributors, please list yourself here. + +- Mitsutoshi Aoe (@maoe) +- John Wiegley +- Michael Snoyman +- Michael Xavier +- Toralf Wittner +- Marco Zocca (@ocramz) diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 index 0000000..8d49368 --- /dev/null +++ b/changelog.md @@ -0,0 +1,135 @@ +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. diff --git a/retry.cabal b/retry.cabal new file mode 100644 index 0000000..ca7a5e7 --- /dev/null +++ b/retry.cabal @@ -0,0 +1,86 @@ +name: retry + +description: + + This package exposes combinators that can wrap arbitrary + monadic actions. They run the action and potentially retry + running it with some configurable delay for a configurable + number of times. + + The purpose is to make it easier to work with IO and + especially network IO actions that often experience temporary + failure and warrant retrying of the original action. For + example, a database query may time out for a while, in which + case we should hang back for a bit and retry the query instead + of simply raising an exception. + +version: 0.9.2.1 +synopsis: Retry combinators for monadic actions that may fail +license: BSD3 +license-file: LICENSE +author: Ozgun Ataman +maintainer: ozgun.ataman@soostone.com +copyright: Ozgun Ataman, Soostone Inc +category: Control +build-type: Simple +cabal-version: >=1.10 +homepage: http://github.com/Soostone/retry +extra-source-files: + README.md + changelog.md + +flag lib-Werror + default: False + manual: True + +library + exposed-modules: Control.Retry + build-depends: + base >= 4.8 && < 5 + , exceptions >= 0.5 + , ghc-prim + , random >= 1 + , transformers + , mtl + , mtl-compat + hs-source-dirs: src + default-language: Haskell2010 + + if flag(lib-Werror) + ghc-options: -Werror + + ghc-options: -Wall + + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test,src + ghc-options: -threaded + other-modules: Control.Retry + Tests.Control.Retry + build-depends: + base ==4.* + , exceptions + , transformers + , random + , time + , HUnit >= 1.2.5.2 + , tasty + , tasty-hunit + , tasty-hedgehog + , hedgehog >= 1.0 + , stm + , ghc-prim + , mtl + , mtl-compat + 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 diff --git a/src/Control/Retry.hs b/src/Control/Retry.hs new file mode 100644 index 0000000..e198a2f --- /dev/null +++ b/src/Control/Retry.hs @@ -0,0 +1,958 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Retry +-- Copyright : Ozgun Ataman +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- Stability : provisional +-- +-- This module exposes combinators that can wrap arbitrary monadic +-- actions. They run the action and potentially retry running it with +-- some configurable delay for a configurable number of times. +-- +-- The express purpose of this library is to make it easier to work +-- with IO and especially network IO actions that often experience +-- temporary failure that warrant retrying of the original action. For +-- example, a database query may time out for a while, in which case +-- we should delay a bit and retry the query. +---------------------------------------------------------------------------- + + +module Control.Retry + ( + -- * Types and Operations + RetryPolicyM (..) + , RetryPolicy + , retryPolicy + , retryPolicyDefault + , natTransformRetryPolicy + , RetryAction (..) + , toRetryAction + , RetryStatus (..) + , defaultRetryStatus + , applyPolicy + , applyAndDelay + + + -- ** Lenses for 'RetryStatus' + , rsIterNumberL + , rsCumulativeDelayL + , rsPreviousDelayL + + -- * Applying Retry Policies + , retrying + , retryingDynamic + , recovering + , recoveringDynamic + , stepping + , recoverAll + , skipAsyncExceptions + , logRetries + , defaultLogMsg + , retryOnError + -- ** Resumable variants + , resumeRetrying + , resumeRetryingDynamic + , resumeRecovering + , resumeRecoveringDynamic + , resumeRecoverAll + + -- * Retry Policies + , constantDelay + , exponentialBackoff + , fullJitterBackoff + , fibonacciBackoff + , limitRetries + + -- * Policy Transformers + , limitRetriesByDelay + , limitRetriesByCumulativeDelay + , capDelay + + -- * Development Helpers + , simulatePolicy + , simulatePolicyPP + ) where + +------------------------------------------------------------------------------- +import Control.Applicative +import Control.Concurrent +#if MIN_VERSION_base(4, 7, 0) +import Control.Exception (AsyncException, SomeAsyncException) +#else +import Control.Exception (AsyncException) +#endif +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Except +import Control.Monad.IO.Class as MIO +import Control.Monad.Trans.Class as TC +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State +import Data.List (foldl') +import Data.Maybe +import GHC.Generics +import GHC.Prim +import GHC.Types (Int(I#)) +import System.Random +# if MIN_VERSION_base(4, 9, 0) +import Data.Semigroup +# else +import Data.Monoid +# endif +import Prelude +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +-- | A 'RetryPolicyM' is a function that takes an 'RetryStatus' and +-- possibly returns a delay in microseconds. Iteration numbers start +-- at zero and increase by one on each retry. A *Nothing* return value from +-- the function implies we have reached the retry limit. +-- +-- Please note that 'RetryPolicyM' is a 'Monoid'. You can collapse +-- multiple strategies into one using 'mappend' or '<>'. The semantics +-- of this combination are as follows: +-- +-- 1. If either policy returns 'Nothing', the combined policy returns +-- 'Nothing'. This can be used to @inhibit@ after a number of retries, +-- for example. +-- +-- 2. If both policies return a delay, the larger delay will be used. +-- This is quite natural when combining multiple policies to achieve a +-- certain effect. +-- +-- Example: +-- +-- One can easily define an exponential backoff policy with a limited +-- number of retries: +-- +-- >> limitedBackoff = exponentialBackoff 50000 <> limitRetries 5 +-- +-- Naturally, 'mempty' will retry immediately (delay 0) for an +-- unlimited number of retries, forming the identity for the 'Monoid'. +-- +-- The default retry policy 'retryPolicyDefault' implements a constant 50ms delay, up to 5 times: +-- +-- >> retryPolicyDefault = constantDelay 50000 <> limitRetries 5 +-- +-- For anything more complex, just define your own 'RetryPolicyM': +-- +-- >> myPolicy = retryPolicy $ \ rs -> if rsIterNumber rs > 10 then Just 1000 else Just 10000 +-- +-- Since 0.7. +newtype RetryPolicyM m = RetryPolicyM { getRetryPolicyM :: RetryStatus -> m (Maybe Int) } + + +-- | Simplified 'RetryPolicyM' without any use of the monadic context in +-- determining policy. Mostly maintains backwards compatitibility with +-- type signatures pre-0.7. +type RetryPolicy = forall m . Monad m => RetryPolicyM m + +-- | Default retry policy +retryPolicyDefault :: (Monad m) => RetryPolicyM m +retryPolicyDefault = constantDelay 50000 <> limitRetries 5 + + +-- Base 4.9.0 adds a Data.Semigroup module. This has fewer +-- dependencies than the semigroups package, so we're using base's +-- only if its available. +# if MIN_VERSION_base(4, 9, 0) +instance Monad m => Semigroup (RetryPolicyM m) where + (RetryPolicyM a) <> (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do + a' <- MaybeT $ a n + b' <- MaybeT $ b n + return $! max a' b' + + +instance Monad m => Monoid (RetryPolicyM m) where + mempty = retryPolicy $ const (Just 0) + mappend = (<>) +# else +instance Monad m => Monoid (RetryPolicyM m) where + mempty = retryPolicy $ const (Just 0) + (RetryPolicyM a) `mappend` (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do + a' <- MaybeT $ a n + b' <- MaybeT $ b n + return $! max a' b' +#endif + + +------------------------------------------------------------------------------- +-- | Applies a natural transformation to a policy to run a RetryPolicy +-- meant for the monad @m@ in the monad @n@ provided a transformation +-- from @m@ to @n@ is available. A common case is if you have a pure +-- policy, @RetryPolicyM Identity@ and want to use it to govern an +-- @IO@ computation you could write: +-- +-- @ +-- purePolicyInIO :: RetryPolicyM Identity -> RetryPolicyM IO +-- purePolicyInIO = natTransformRetryPolicy (pure . runIdentity) +-- @ +natTransformRetryPolicy :: (forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n +natTransformRetryPolicy f (RetryPolicyM p) = RetryPolicyM $ \stat -> f (p stat) + + +-- | Modify the delay of a RetryPolicy. +-- Does not change whether or not a retry is performed. +modifyRetryPolicyDelay :: Functor m => (Int -> Int) -> RetryPolicyM m -> RetryPolicyM m +modifyRetryPolicyDelay f (RetryPolicyM p) = RetryPolicyM $ \stat -> fmap f <$> p stat + + +------------------------------------------------------------------------------- +-- | How to handle a failed action. +data RetryAction + = DontRetry + -- ^ Don't retry (regardless of what the 'RetryPolicy' says). + | ConsultPolicy + -- ^ Retry if the 'RetryPolicy' says so, with the delay specified by the policy. + | ConsultPolicyOverrideDelay Int + -- ^ Retry if the 'RetryPolicy' says so, but override the policy's delay (number of microseconds). + deriving (Read, Show, Eq, Generic) + + +-- | Convert a boolean answer to the question "Should we retry?" into +-- a 'RetryAction'. +toRetryAction :: Bool -> RetryAction +toRetryAction False = DontRetry +toRetryAction True = ConsultPolicy + +------------------------------------------------------------------------------- +-- | Datatype with stats about retries made thus far. +data RetryStatus = RetryStatus + { rsIterNumber :: !Int -- ^ Iteration number, where 0 is the first try + , rsCumulativeDelay :: !Int -- ^ Delay incurred so far from retries in microseconds + , rsPreviousDelay :: !(Maybe Int) -- ^ Latest attempt's delay. Will always be Nothing on first run. + } deriving (Read, Show, Eq, Generic) + + +------------------------------------------------------------------------------- +-- | Initial, default retry status. Use fields or lenses to update. +defaultRetryStatus :: RetryStatus +defaultRetryStatus = RetryStatus 0 0 Nothing + +------------------------------------------------------------------------------- +rsIterNumberL :: Lens' RetryStatus Int +rsIterNumberL = lens rsIterNumber (\rs x -> rs { rsIterNumber = x }) +{-# INLINE rsIterNumberL #-} + + +------------------------------------------------------------------------------- +rsCumulativeDelayL :: Lens' RetryStatus Int +rsCumulativeDelayL = lens rsCumulativeDelay (\rs x -> rs { rsCumulativeDelay = x }) +{-# INLINE rsCumulativeDelayL #-} + + +------------------------------------------------------------------------------- +rsPreviousDelayL :: Lens' RetryStatus (Maybe Int) +rsPreviousDelayL = lens rsPreviousDelay (\rs x -> rs { rsPreviousDelay = x }) +{-# INLINE rsPreviousDelayL #-} + + + +------------------------------------------------------------------------------- +-- | Apply policy on status to see what the decision would be. +-- 'Nothing' implies no retry, 'Just' returns updated status. +applyPolicy + :: Monad m + => RetryPolicyM m + -> RetryStatus + -> m (Maybe RetryStatus) +applyPolicy (RetryPolicyM policy) s = do + res <- policy s + case res of + Just delay -> return $! Just $! RetryStatus + { rsIterNumber = rsIterNumber s + 1 + , rsCumulativeDelay = rsCumulativeDelay s `boundedPlus` delay + , rsPreviousDelay = Just delay } + Nothing -> return Nothing + + +------------------------------------------------------------------------------- +-- | Apply policy and delay by its amount if it results in a retry. +-- Return updated status. +applyAndDelay + :: MIO.MonadIO m + => RetryPolicyM m + -> RetryStatus + -> m (Maybe RetryStatus) +applyAndDelay policy s = do + chk <- applyPolicy policy s + case chk of + Just rs -> do + case rsPreviousDelay rs of + Nothing -> return () + Just delay -> liftIO $ threadDelay delay + return (Just rs) + Nothing -> return Nothing + + + +------------------------------------------------------------------------------- +-- | Helper for making simplified policies that don't use the monadic +-- context. +retryPolicy :: (Monad m) => (RetryStatus -> Maybe Int) -> RetryPolicyM m +retryPolicy f = RetryPolicyM $ \ s -> return (f s) + + +------------------------------------------------------------------------------- +-- | Retry immediately, but only up to @n@ times. +limitRetries + :: Int + -- ^ Maximum number of retries. + -> RetryPolicy +limitRetries i = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> if n >= i then Nothing else Just 0 + + +------------------------------------------------------------------------------- +-- | Add an upperbound to a policy such that once the given time-delay +-- amount *per try* has been reached or exceeded, the policy will stop +-- retrying and fail. If you need to stop retrying once *cumulative* +-- delay reaches a time-delay amount, use +-- 'limitRetriesByCumulativeDelay' +limitRetriesByDelay + :: Monad m + => Int + -- ^ Time-delay limit in microseconds. + -> RetryPolicyM m + -> RetryPolicyM m +limitRetriesByDelay i p = RetryPolicyM $ \ n -> + (>>= limit) `fmap` getRetryPolicyM p n + where + limit delay = if delay >= i then Nothing else Just delay + + +------------------------------------------------------------------------------- +-- | Add an upperbound to a policy such that once the cumulative delay +-- over all retries has reached or exceeded the given limit, the +-- policy will stop retrying and fail. +limitRetriesByCumulativeDelay + :: Monad m + => Int + -- ^ Time-delay limit in microseconds. + -> RetryPolicyM m + -> RetryPolicyM m +limitRetriesByCumulativeDelay cumulativeLimit p = RetryPolicyM $ \ stat -> + (>>= limit stat) `fmap` getRetryPolicyM p stat + where + limit status curDelay + | rsCumulativeDelay status `boundedPlus` curDelay > cumulativeLimit = Nothing + | otherwise = Just curDelay + + +------------------------------------------------------------------------------- +-- | Implement a constant delay with unlimited retries. +constantDelay + :: (Monad m) + => Int + -- ^ Base delay in microseconds + -> RetryPolicyM m +constantDelay delay = retryPolicy (const (Just delay)) + + +------------------------------------------------------------------------------- +-- | Grow delay exponentially each iteration. Each delay will +-- increase by a factor of two. +exponentialBackoff + :: (Monad m) + => Int + -- ^ Base delay in microseconds + -> RetryPolicyM m +exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n } -> + Just $! base `boundedMult` boundedPow 2 n + +------------------------------------------------------------------------------- +-- | FullJitter exponential backoff as explained in AWS Architecture +-- Blog article. +-- +-- @http:\/\/www.awsarchitectureblog.com\/2015\/03\/backoff.html@ +-- +-- temp = min(cap, base * 2 ** attempt) +-- +-- sleep = temp \/ 2 + random_between(0, temp \/ 2) +fullJitterBackoff + :: (MonadIO m) + => Int + -- ^ Base delay in microseconds + -> RetryPolicyM m +fullJitterBackoff base = RetryPolicyM $ \ RetryStatus { rsIterNumber = n } -> do + let d = (base `boundedMult` boundedPow 2 n) `div` 2 + rand <- liftIO $ randomRIO (0, d) + return $! Just $! d `boundedPlus` rand + + +------------------------------------------------------------------------------- +-- | Implement Fibonacci backoff. +fibonacciBackoff + :: (Monad m) + => Int + -- ^ Base delay in microseconds + -> RetryPolicyM m +fibonacciBackoff base = retryPolicy $ \RetryStatus { rsIterNumber = n } -> + Just $ fib (n + 1) (0, base) + where + fib 0 (a, _) = a + fib !m (!a, !b) = fib (m-1) (b, a `boundedPlus` b) + + +------------------------------------------------------------------------------- +-- | Set a time-upperbound for any delays that may be directed by the +-- given policy. This function does not terminate the retrying. The policy +-- `capDelay maxDelay (exponentialBackoff n)` will never stop retrying. It +-- will reach a state where it retries forever with a delay of `maxDelay` +-- between each one. To get termination you need to use one of the +-- 'limitRetries' function variants. +capDelay + :: Monad m + => Int + -- ^ A maximum delay in microseconds + -> RetryPolicyM m + -> RetryPolicyM m +capDelay limit p = RetryPolicyM $ \ n -> + fmap (min limit) `fmap` getRetryPolicyM p n + + +------------------------------------------------------------------------------- +-- | Retry combinator for actions that don't raise exceptions, but +-- signal in their type the outcome has failed. Examples are the +-- 'Maybe', 'Either' and 'EitherT' monads. +-- +-- Let's write a function that always fails and watch this combinator +-- retry it 5 additional times following the initial run: +-- +-- >>> import Data.Maybe +-- >>> let f _ = putStrLn "Running action" >> return Nothing +-- >>> retrying retryPolicyDefault (const $ return . isNothing) f +-- Running action +-- Running action +-- Running action +-- Running action +-- Running action +-- Running action +-- Nothing +-- +-- Note how the latest failing result is returned after all retries +-- have been exhausted. +retrying :: MonadIO m + => RetryPolicyM m + -> (RetryStatus -> b -> m Bool) + -- ^ An action to check whether the result should be retried. + -- If True, we delay and retry the operation. + -> (RetryStatus -> m b) + -- ^ Action to run + -> m b +retrying = resumeRetrying defaultRetryStatus + + +------------------------------------------------------------------------------- +-- | A variant of 'retrying' that allows specifying the initial +-- 'RetryStatus' so that the retrying operation may pick up where it left +-- off in regards to its retry policy. +resumeRetrying + :: MonadIO m + => RetryStatus + -> RetryPolicyM m + -> (RetryStatus -> b -> m Bool) + -- ^ An action to check whether the result should be retried. + -- If True, we delay and retry the operation. + -> (RetryStatus -> m b) + -- ^ Action to run + -> m b +resumeRetrying retryStatus policy chk f = + resumeRetryingDynamic + retryStatus + policy + (\rs -> fmap toRetryAction . chk rs) + f + + +------------------------------------------------------------------------------- +-- | Same as 'retrying', but with the ability to override +-- the delay of the retry policy based on information +-- obtained after initiation. +-- +-- For example, if the action to run is a HTTP request that +-- turns out to fail with a status code 429 ("too many requests"), +-- the response may contain a "Retry-After" HTTP header which +-- specifies the number of seconds +-- the client should wait until performing the next request. +-- This function allows overriding the delay calculated by the given +-- retry policy with the delay extracted from this header value. +-- +-- In other words, given an arbitrary 'RetryPolicyM' @rp@, the +-- following invocation will always delay by 1000 microseconds: +-- +-- > retryingDynamic rp (\_ _ -> return $ ConsultPolicyOverrideDelay 1000) f +-- +-- Note that a 'RetryPolicy's decision to /not/ perform a retry +-- cannot be overridden. Ie. /when/ to /stop/ retrying is always decided +-- by the retry policy, regardless of the returned 'RetryAction' value. +retryingDynamic + :: MonadIO m + => RetryPolicyM m + -> (RetryStatus -> b -> m RetryAction) + -- ^ An action to check whether the result should be retried. + -- The returned 'RetryAction' determines how/if a retry is performed. + -- See documentation on 'RetryAction'. + -> (RetryStatus -> m b) + -- ^ Action to run + -> m b +retryingDynamic = resumeRetryingDynamic defaultRetryStatus + + +------------------------------------------------------------------------------- +-- | A variant of 'retryingDynamic' that allows specifying the initial +-- 'RetryStatus' so that a retrying operation may pick up where it left off +-- in regards to its retry policy. +resumeRetryingDynamic + :: MonadIO m + => RetryStatus + -> RetryPolicyM m + -> (RetryStatus -> b -> m RetryAction) + -- ^ An action to check whether the result should be retried. + -- The returned 'RetryAction' determines how/if a retry is performed. + -- See documentation on 'RetryAction'. + -> (RetryStatus -> m b) + -- ^ Action to run + -> m b +resumeRetryingDynamic retryStatus policy chk f = go retryStatus + where + go s = do + res <- f s + let consultPolicy policy' = do + rs <- applyAndDelay policy' s + case rs of + Nothing -> return res + Just rs' -> go $! rs' + chk' <- chk s res + case chk' of + DontRetry -> return res + ConsultPolicy -> consultPolicy policy + ConsultPolicyOverrideDelay delay -> + consultPolicy $ modifyRetryPolicyDelay (const delay) policy + + +------------------------------------------------------------------------------- +-- | Retry ALL exceptions that may be raised. To be used with caution; +-- this matches the exception on 'SomeException'. Note that this +-- handler explicitly does not handle 'AsyncException' nor +-- 'SomeAsyncException' (for versions of base >= 4.7). It is not a +-- good idea to catch async exceptions as it can result in hanging +-- threads and programs. Note that if you just throw an exception to +-- this thread that does not descend from SomeException, recoverAll +-- will not catch it. +-- +-- See how the action below is run once and retried 5 more times +-- before finally failing for good: +-- +-- >>> let f _ = putStrLn "Running action" >> error "this is an error" +-- >>> recoverAll retryPolicyDefault f +-- Running action +-- Running action +-- Running action +-- Running action +-- Running action +-- Running action +-- *** Exception: this is an error +recoverAll +#if MIN_VERSION_exceptions(0, 6, 0) + :: (MonadIO m, MonadMask m) +#else + :: (MonadIO m, MonadCatch m) +#endif + => RetryPolicyM m + -> (RetryStatus -> m a) + -> m a +recoverAll = resumeRecoverAll defaultRetryStatus + + +------------------------------------------------------------------------------- +-- | A variant of 'recoverAll' that allows specifying the initial +-- 'RetryStatus' so that a recovering operation may pick up where it left +-- off in regards to its retry policy. +resumeRecoverAll +#if MIN_VERSION_exceptions(0, 6, 0) + :: (MonadIO m, MonadMask m) +#else + :: (MonadIO m, MonadCatch m) +#endif + => RetryStatus + -> RetryPolicyM m + -> (RetryStatus -> m a) + -> m a +resumeRecoverAll retryStatus set f = resumeRecovering retryStatus set handlers f + where + handlers = skipAsyncExceptions ++ [h] + h _ = Handler $ \ (_ :: SomeException) -> return True + + +------------------------------------------------------------------------------- +-- | List of pre-made handlers that will skip retries on +-- 'AsyncException' and 'SomeAsyncException'. Append your handlers to +-- this list as a convenient way to make sure you're not catching +-- async exceptions like user interrupt. +skipAsyncExceptions + :: ( MonadIO m + ) + => [RetryStatus -> Handler m Bool] +skipAsyncExceptions = handlers + where + asyncH _ = Handler $ \ (_ :: AsyncException) -> return False +#if MIN_VERSION_base(4, 7, 0) + someAsyncH _ = Handler $ \(_ :: SomeAsyncException) -> return False + handlers = [asyncH, someAsyncH] +#else + handlers = [asyncH] +#endif + + +------------------------------------------------------------------------------- +-- | Run an action and recover from a raised exception by potentially +-- retrying the action a number of times. Note that if you're going to +-- use a handler for 'SomeException', you should add explicit cases +-- *earlier* in the list of handlers to reject 'AsyncException' and +-- 'SomeAsyncException', as catching these can cause thread and +-- program hangs. 'recoverAll' already does this for you so if you +-- just plan on catching 'SomeException', you may as well use +-- 'recoverAll' +recovering +#if MIN_VERSION_exceptions(0, 6, 0) + :: (MonadIO m, MonadMask m) +#else + :: (MonadIO m, MonadCatch m) +#endif + => RetryPolicyM m + -- ^ Just use 'retryPolicyDefault' for default settings + -> [RetryStatus -> Handler m Bool] + -- ^ Should a given exception be retried? Action will be + -- retried if this returns True *and* the policy allows it. + -- This action will be consulted first even if the policy + -- later blocks it. + -> (RetryStatus -> m a) + -- ^ Action to perform + -> m a +recovering = resumeRecovering defaultRetryStatus + + +------------------------------------------------------------------------------- +-- | A variant of 'recovering' that allows specifying the initial +-- 'RetryStatus' so that a recovering operation may pick up where it left +-- off in regards to its retry policy. +resumeRecovering +#if MIN_VERSION_exceptions(0, 6, 0) + :: (MonadIO m, MonadMask m) +#else + :: (MonadIO m, MonadCatch m) +#endif + => RetryStatus + -> RetryPolicyM m + -- ^ Just use 'retryPolicyDefault' for default settings + -> [(RetryStatus -> Handler m Bool)] + -- ^ Should a given exception be retried? Action will be + -- retried if this returns True *and* the policy allows it. + -- This action will be consulted first even if the policy + -- later blocks it. + -> (RetryStatus -> m a) + -- ^ Action to perform + -> m a +resumeRecovering retryStatus policy hs f = + resumeRecoveringDynamic retryStatus policy hs' f + where + hs' = map (fmap toRetryAction .) hs + + +------------------------------------------------------------------------------- +-- | The difference between this and 'recovering' is the same as +-- the difference between 'retryingDynamic' and 'retrying'. +recoveringDynamic +#if MIN_VERSION_exceptions(0, 6, 0) + :: (MonadIO m, MonadMask m) +#else + :: (MonadIO m, MonadCatch m) +#endif + => RetryPolicyM m + -- ^ Just use 'retryPolicyDefault' for default settings + -> [RetryStatus -> Handler m RetryAction] + -- ^ Should a given exception be retried? Action will be + -- retried if this returns either 'ConsultPolicy' or + -- 'ConsultPolicyOverrideDelay' *and* the policy allows it. + -- This action will be consulted first even if the policy + -- later blocks it. + -> (RetryStatus -> m a) + -- ^ Action to perform + -> m a +recoveringDynamic = resumeRecoveringDynamic defaultRetryStatus + + +------------------------------------------------------------------------------- +-- | A variant of 'recoveringDynamic' that allows specifying the initial +-- 'RetryStatus' so that a recovering operation may pick up where it left +-- off in regards to its retry policy. +resumeRecoveringDynamic +#if MIN_VERSION_exceptions(0, 6, 0) + :: (MonadIO m, MonadMask m) +#else + :: (MonadIO m, MonadCatch m) +#endif + => RetryStatus + -> RetryPolicyM m + -- ^ Just use 'retryPolicyDefault' for default settings + -> [(RetryStatus -> Handler m RetryAction)] + -- ^ Should a given exception be retried? Action will be + -- retried if this returns either 'ConsultPolicy' or + -- 'ConsultPolicyOverrideDelay' *and* the policy allows it. + -- This action will be consulted first even if the policy + -- later blocks it. + -> (RetryStatus -> m a) + -- ^ Action to perform + -> m a +resumeRecoveringDynamic retryStatus policy hs f = mask $ \restore -> go restore retryStatus + where + go restore = loop + where + loop s = do + r <- try $ restore (f s) + case r of + Right x -> return x + Left e -> recover (e :: SomeException) hs + where + recover e [] = throwM e + recover e ((($ s) -> Handler h) : hs') + | Just e' <- fromException e = do + let consultPolicy policy' = do + rs <- applyAndDelay policy' s + case rs of + Just rs' -> loop $! rs' + Nothing -> throwM e' + chk <- h e' + case chk of + DontRetry -> throwM e' + ConsultPolicy -> consultPolicy policy + ConsultPolicyOverrideDelay delay -> + consultPolicy $ modifyRetryPolicyDelay (const delay) policy + | otherwise = recover e hs' + + +------------------------------------------------------------------------------- +-- | A version of 'recovering' that tries to run the action only a +-- single time. The control will return immediately upon both success +-- and failure. Useful for implementing retry logic in distributed +-- queues and similar external-interfacing systems. +stepping +#if MIN_VERSION_exceptions(0, 6, 0) + :: (MonadIO m, MonadMask m) +#else + :: (MonadIO m, MonadCatch m) +#endif + => RetryPolicyM m + -- ^ Just use 'retryPolicyDefault' for default settings + -> [RetryStatus -> Handler m Bool] + -- ^ Should a given exception be retried? Action will be + -- retried if this returns True *and* the policy allows it. + -- This action will be consulted first even if the policy + -- later blocks it. + -> (RetryStatus -> m ()) + -- ^ Action to run with updated status upon failure. + -> (RetryStatus -> m a) + -- ^ Main action to perform with current status. + -> RetryStatus + -- ^ Current status of this step + -> m (Maybe a) +stepping policy hs schedule f s = do + r <- try $ f s + case r of + Right x -> return $ Just x + Left e -> recover (e :: SomeException) hs + where + recover e [] = throwM e + recover e ((($ s) -> Handler h) : hs') + | Just e' <- fromException e = do + chk <- h e' + case chk of + True -> do + res <- applyPolicy policy s + case res of + Just rs -> do + schedule $! rs + return Nothing + Nothing -> throwM e' + False -> throwM e' + | otherwise = recover e hs' + + +------------------------------------------------------------------------------- +-- | Helper function for constructing handler functions of the form required +-- by 'recovering'. +logRetries + :: ( Monad m + , Exception e) + => (e -> m Bool) + -- ^ Test for whether action is to be retried + -> (Bool -> e -> RetryStatus -> m ()) + -- ^ How to report the generated warning message. Boolean is + -- whether it's being retried or crashed. + -> RetryStatus + -- ^ Retry number + -> Handler m Bool +logRetries test reporter status = Handler $ \ err -> do + result <- test err + reporter result err status + return result + +-- | For use with 'logRetries'. +defaultLogMsg :: (Exception e) => Bool -> e -> RetryStatus -> String +defaultLogMsg shouldRetry err status = + "[retry:" <> iter <> "] Encountered " <> show err <> ". " <> nextMsg + where + iter = show $ rsIterNumber status + nextMsg = if shouldRetry then "Retrying." else "Crashing." + + +------------------------------------------------------------------------------- +retryOnError + :: (Functor m, MonadIO m, MonadError e m) + => RetryPolicyM m + -- ^ Policy + -> (RetryStatus -> e -> m Bool) + -- ^ Should an error be retried? + -> (RetryStatus -> m a) + -- ^ Action to perform + -> m a +retryOnError policy chk f = go defaultRetryStatus + where + go stat = do + res <- (Right <$> f stat) `catchError` (\e -> Left . (e, ) <$> chk stat e) + case res of + Right x -> return x + Left (e, True) -> do + mstat' <- applyAndDelay policy stat + case mstat' of + Just stat' -> do + go $! stat' + Nothing -> throwError e + Left (e, False) -> throwError e + + +------------------------------------------------------------------------------- +-- | Run given policy up to N iterations and gather results. In the +-- pair, the @Int@ is the iteration number and the @Maybe Int@ is the +-- delay in microseconds. +simulatePolicy :: Monad m => Int -> RetryPolicyM m -> m [(Int, Maybe Int)] +simulatePolicy n (RetryPolicyM f) = flip evalStateT defaultRetryStatus $ forM [0..n] $ \i -> do + stat <- get + delay <- TC.lift (f stat) + put $! stat + { rsIterNumber = i + 1 + , rsCumulativeDelay = rsCumulativeDelay stat `boundedPlus` fromMaybe 0 delay + , rsPreviousDelay = delay + } + return (i, delay) + + +------------------------------------------------------------------------------- +-- | Run given policy up to N iterations and pretty print results on +-- the console. +simulatePolicyPP :: Int -> RetryPolicyM IO -> IO () +simulatePolicyPP n p = do + ps <- simulatePolicy n p + forM_ ps $ \ (iterNo, res) -> putStrLn $ + show iterNo <> ": " <> maybe "Inhibit" ppTime res + putStrLn $ "Total cumulative delay would be: " <> + ppTime (boundedSum $ mapMaybe snd ps) + + +------------------------------------------------------------------------------- +ppTime :: (Integral a, Show a) => a -> String +ppTime n | n < 1000 = show n <> "us" + | n < 1000000 = show ((fromIntegral n / 1000) :: Double) <> "ms" + | otherwise = show ((fromIntegral n / 1000) :: Double) <> "ms" + +------------------------------------------------------------------------------- +-- Bounded arithmetic +------------------------------------------------------------------------------- + +-- | Same as '+' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or +-- @'minBound' :: 'Int'@ rather than rolling over +boundedPlus :: Int -> Int -> Int +boundedPlus i@(I# i#) j@(I# j#) = case addIntC# i# j# of + (# k#, 0# #) -> I# k# + (# _, _ #) + | maxBy abs i j < 0 -> minBound + | otherwise -> maxBound + where + maxBy f a b = if f a >= f b then a else b + +-- | Same as '*' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or +-- @'minBound' :: 'Int'@ rather than rolling over +boundedMult :: Int -> Int -> Int +boundedMult i@(I# i#) j@(I# j#) = case mulIntMayOflo# i# j# of + 0# -> I# (i# *# j#) + _ | signum i * signum j < 0 -> minBound + | otherwise -> maxBound + +-- | Same as 'sum' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or +-- @'minBound' :: 'Int'@ rather than rolling over +boundedSum :: [Int] -> Int +boundedSum = foldl' boundedPlus 0 + +-- | Same as '^' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or +-- @'MinBound' :: 'Int'@ rather than rolling over +boundedPow :: Int -> Int -> Int +boundedPow x0 y0 + | y0 < 0 = error "Negative exponent" + | y0 == 0 = 1 + | otherwise = f x0 y0 + where + f x y + | even y = f (x `boundedMult` x) (y `quot` 2) + | y == 1 = x + | otherwise = g (x `boundedMult` x) ((y - 1) `quot` 2) x + g x y z + | even y = g (x `boundedMult` x) (y `quot` 2) z + | y == 1 = x `boundedMult` z + | otherwise = g (x `boundedMult` x) ((y - 1) `quot` 2) (x `boundedMult` z) + +------------------------------------------------------------------------------- +-- Lens machinery +------------------------------------------------------------------------------- +-- Unexported type aliases to clean up the documentation +type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t + +type Lens' s a = Lens s s a a + + +------------------------------------------------------------------------------- +lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b +lens sa sbt afb s = sbt s <$> afb (sa s) +{-# INLINE lens #-} + + + ------------------ + -- Simple Tests -- + ------------------ + + + +-- data TestException = TestException deriving (Show, Typeable) +-- data AnotherException = AnotherException deriving (Show, Typeable) + +-- instance Exception TestException +-- instance Exception AnotherException + + +-- test = retrying retryPolicyDefault [h1,h2] f +-- where +-- f = putStrLn "Running action" >> throwM AnotherException +-- h1 = Handler $ \ (e :: TestException) -> return False +-- h2 = Handler $ \ (e :: AnotherException) -> return True diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 index 0000000..e489715 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,22 @@ +module Main + ( main + ) where + + +------------------------------------------------------------------------------- +import Test.Tasty +------------------------------------------------------------------------------- +import qualified Tests.Control.Retry +------------------------------------------------------------------------------- + + + +main :: IO () +main = defaultMain tests + + +------------------------------------------------------------------------------- +tests :: TestTree +tests = testGroup "retry" + [ Tests.Control.Retry.tests + ] diff --git a/test/Tests/Control/Retry.hs b/test/Tests/Control/Retry.hs new file mode 100644 index 0000000..96543c6 --- /dev/null +++ b/test/Tests/Control/Retry.hs @@ -0,0 +1,607 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +module Tests.Control.Retry + ( tests + ) where + +------------------------------------------------------------------------------- +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM as STM +import qualified Control.Exception as EX +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 = 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 = 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 Just lastDelay = lookup (retries - 1) delays + let Just gaveUp = 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 = 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 + 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) + () + ] + ] + where + 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 -- 2.30.2