retry-0.7.7.0/src/0000755000000000000000000000000013334570257012016 5ustar0000000000000000retry-0.7.7.0/src/Control/0000755000000000000000000000000013334570257013436 5ustar0000000000000000retry-0.7.7.0/test/0000755000000000000000000000000013334570257012206 5ustar0000000000000000retry-0.7.7.0/test/Tests/0000755000000000000000000000000013334570257013310 5ustar0000000000000000retry-0.7.7.0/test/Tests/Control/0000755000000000000000000000000013334570257014730 5ustar0000000000000000retry-0.7.7.0/src/Control/Retry.hs0000644000000000000000000006240413335372663015107 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# 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 , natTransformRetryPolicy , RetryStatus (..) , defaultRetryStatus , applyPolicy , applyAndDelay -- ** Lenses for 'RetryStatus' , rsIterNumberL , rsCumulativeDelayL , rsPreviousDelayL -- * Applying Retry Policies , retrying , recovering , stepping , recoverAll , skipAsyncExceptions , logRetries , defaultLogMsg -- * 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.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe import Control.Monad.Trans.State import Data.Default.Class 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 50 <> 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: -- -- >> def = 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 -- -- 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 instance Monad m => Default (RetryPolicyM m) where def = 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) ------------------------------------------------------------------------------- -- | 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 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. Exported mostly to allow user code -- to test their handlers and retry policies. 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 :: 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 :: (RetryStatus -> Maybe Int) -> RetryPolicy 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) `liftM` 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) `liftM` getRetryPolicyM p stat where limit status curDelay | rsCumulativeDelay status `boundedPlus` curDelay > cumulativeLimit = Nothing | otherwise = Just curDelay ------------------------------------------------------------------------------- -- | Implement a constant delay with unlimited retries. constantDelay :: Int -- ^ Base delay in microseconds -> RetryPolicy constantDelay delay = retryPolicy (const (Just delay)) ------------------------------------------------------------------------------- -- | Grow delay exponentially each iteration. Each delay will -- increase by a factor of two. exponentialBackoff :: Int -- ^ Base delay in microseconds -> RetryPolicy exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n } -> Just $! base `boundedMult` boundedPow 2 n ------------------------------------------------------------------------------- -- | FullJitter exponential backoff as explained in AWS Architecture -- Blog article. -- -- @http:\/\/www.awsarchitectureblog.com\/2015\/03\/backoff.html@ -- -- temp = min(cap, base * 2 ** attempt) -- -- sleep = temp \/ 2 + random_between(0, temp \/ 2) fullJitterBackoff :: MonadIO m => Int -- ^ Base delay in microseconds -> RetryPolicyM m fullJitterBackoff base = RetryPolicyM $ \ RetryStatus { rsIterNumber = n } -> do let d = (base `boundedMult` boundedPow 2 n) `div` 2 rand <- liftIO $ randomRIO (0, d) return $! Just $! d `boundedPlus` rand ------------------------------------------------------------------------------- -- | Implement Fibonacci backoff. fibonacciBackoff :: Int -- ^ Base delay in microseconds -> RetryPolicy 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)) `liftM` (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 def (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 policy chk f = go defaultRetryStatus where go s = do res <- f s 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 ------------------------------------------------------------------------------- -- | 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 def 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 set f = recovering 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 ues -- 'recoverAll' recovering #if MIN_VERSION_exceptions(0, 6, 0) :: (MonadIO m, MonadMask m) #else :: (MonadIO m, MonadCatch m) #endif => RetryPolicyM m -- ^ Just use 'def' 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 policy hs f = mask $ \restore -> go restore defaultRetryStatus 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 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' | 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 'def' 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." ------------------------------------------------------------------------------- -- | 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) 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 def [h1,h2] f -- where -- f = putStrLn "Running action" >> throwM AnotherException -- h1 = Handler $ \ (e :: TestException) -> return False -- h2 = Handler $ \ (e :: AnotherException) -> return True retry-0.7.7.0/test/Main.hs0000644000000000000000000000104013334570257013421 0ustar0000000000000000module 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 ] retry-0.7.7.0/test/Tests/Control/Retry.hs0000644000000000000000000003521613334570257016400 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} module Tests.Control.Retry ( tests ) where ------------------------------------------------------------------------------- import Control.Applicative import Control.Concurrent import Control.Concurrent.STM as STM import Control.Exception (AsyncException (..), IOException, MaskingState (..), getMaskingState, throwTo) import Control.Monad.Catch import Control.Monad.Identity import Control.Monad.IO.Class import Control.Monad.Writer.Strict import Data.Default.Class (def) 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, testCase, (@?=)) ------------------------------------------------------------------------------- import Control.Retry ------------------------------------------------------------------------------- tests :: TestTree tests = testGroup "Control.Retry" [ recoveringTests , monoidTests , retryStatusTests , quadraticDelayTests , policyTransformersTests , maskingStateTests , capDelayTests , limitRetriesByCumulativeDelayTests ] ------------------------------------------------------------------------------- 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) throwTo tid 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 <- getMaskingState final <- try $ recovering def testHandlers $ const $ do maskingState' <- getMaskingState maskingState' @?= maskingState fail "Retrying..." assertBool ("Expected IOException but didn't get one") (isLeft (final :: Either IOException ())) , testCase "should mask asynchronous exceptions in exception handlers" $ do let checkMaskingStateHandlers = [ const $ Handler $ \(_ :: SomeException) -> do maskingState <- getMaskingState maskingState @?= MaskedInterruptible return shouldRetry ] final <- try $ recovering def checkMaskingStateHandlers $ const $ fail "Retrying..." assertBool ("Expected IOException but didn't get one") (isLeft (final :: Either 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') ] ------------------------------------------------------------------------------- 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)] 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} ------------------------------------------------------------------------------- ------------------------------------------------------------------------------- -- | 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 r <- newIORef 0 return $ const $ do old <- atomicModifyIORef' r $ \ old -> (old+1, old) case old >= n of True -> return () False -> throwM e ------------------------------------------------------------------------------- gatherStatuses :: MonadIO m => RetryPolicyM (WriterT [RetryStatus] m) -> m [RetryStatus] gatherStatuses policy = execWriterT $ retrying policy (\_ _ -> return shouldRetry) (\rs -> tell [rs]) ------------------------------------------------------------------------------- -- | Just makes things a bit easier to follow instead of a magic value -- of @return True@ shouldRetry :: Bool shouldRetry = True retry-0.7.7.0/LICENSE0000644000000000000000000000276213334570257012243 0ustar0000000000000000Copyright (c) 2013, Ozgun Ataman All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Ozgun Ataman nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. retry-0.7.7.0/Setup.hs0000644000000000000000000000005613334570257012664 0ustar0000000000000000import Distribution.Simple main = defaultMain retry-0.7.7.0/retry.cabal0000644000000000000000000000436413341105317013354 0ustar0000000000000000name: retry description: This package exposes combinators that can wrap arbitrary monadic actions. They run the action and potentially retry running it with some configurable delay for a configurable number of times. The purpose is to make it easier to work with IO and especially network IO actions that often experience temporary failure and warrant retrying of the original action. For example, a database query may time out for a while, in which case we should hang back for a bit and retry the query instead of simply raising an exception. version: 0.7.7.0 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.6 && < 5 , data-default-class , exceptions >= 0.5 && < 0.11 , ghc-prim < 0.6 , random >= 1 && < 1.2 , transformers < 0.7 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 , data-default-class , random , time , HUnit >= 1.2.5.2 , tasty , tasty-hunit , tasty-hedgehog , hedgehog , stm , ghc-prim , mtl default-language: Haskell2010 if flag(lib-Werror) ghc-options: -Werror ghc-options: -Wall source-repository head type: git location: git://github.com/Soostone/retry.git retry-0.7.7.0/README.md0000644000000000000000000000172513334570257012513 0ustar0000000000000000# README [![Build Status](https://travis-ci.org/Soostone/retry.svg?branch=master)](https://travis-ci.org/Soostone/retry) [![Coverage Status](https://coveralls.io/repos/Soostone/retry/badge.png?branch=master)](https://coveralls.io/r/Soostone/retry?branch=master) retry - combinators for monadic actions that may fail ## About Monadic action combinators that add delayed-retry functionality, potentially with exponential-backoff, to arbitrary actions. The main purpose of this package is to make it easy to work reliably with IO and similar actions that often fail. Common examples are database queries and large file uploads. ## Documentation Please see haddocks for documentation. ## Changes See [https://github.com/Soostone/retry/blob/master/changelog.md](changelog.md). ## Author Ozgun Ataman, Soostone Inc ## Contributors Contributors, please list yourself here. - Mitsutoshi Aoe (@maoe) - John Wiegley - Michael Snoyman - Michael Xavier - Marco Zocca (@ocramz) retry-0.7.7.0/changelog.md0000644000000000000000000000530513335372766013511 0ustar00000000000000000.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.