retry 0.6 → 0.7
raw patch · 4 files changed
+360/−95 lines, 4 filesdep +randomdep +stmdep ~QuickCheckdep ~basenew-uploader
Dependencies added: random, stm
Dependency ranges changed: QuickCheck, base
Files
- README.md +36/−0
- changelog.md +46/−0
- retry.cabal +13/−12
- src/Control/Retry.hs +265/−83
+ README.md view
@@ -0,0 +1,36 @@+# README [](https://travis-ci.org/Soostone/retry) [](https://coveralls.io/r/Soostone/retry?branch=master)++retry - combinators for monadic actions that may fail++## About++Monadic action combinators that add delayed-retry functionality,+potentially with exponential-backoff, to arbitrary actions.++The main purpose of this package is to make it easy to work reliably+with IO and similar actions that often fail. Common examples are+database queries and large file uploads.+++## Documentation++Please see haddocks for documentation.++## Changes++See [changelog.md](changelog.md).++## Author++Ozgun Ataman, Soostone Inc+++## Contributors++Contributors, please list yourself here.++- Mitsutoshi Aoe (@maoe)+- John Wiegley+- Michael Snoyman+- Michael Xavier+
+ changelog.md view
@@ -0,0 +1,46 @@+0.7+* RetryPolicy has become RetryPolicyM, allowing for policy logic to+ consult the monad context.+* RetryPolicyM now takes a RetryStatus value. Use the function+ rsIterNum to preserve existing behavior of RetryPolicy only+ receiving the number.+* The monadic action now gets the RetryStatus on each try. Use const+ if you don't need it.+* recoverAll explicitly does not handle the standard async+ exceptions. Users are encouraged to do the same when using+ recovering, as catching async exceptions can be hazardous.+* We no longer re-export (<>) from Monoid.+* Utility functions simulatePolicy and simulatePolicyPP have been+ added which help predict how a policy will behave on each iteration.++0.6++* Actions are now retried in the original masking state, while+ handlers continue to run in `MaskedInterruptible` (@maoe)+* Added several tests confirming exception hierarchy semantics under+ `recovering` (@ozataman)++0.5++* Mitsutoshi's backoff work inspired a complete redo of the+ RetryPolicy interface, replacing it with a monoidal RetryPolicy. The+ result is a much thinner API that actually provides much more power+ to the end user.+* Now using microseconds in all premade policies. PLEASE TAKE CARE+ WHEN UPGRADING. It was a bad idea to use miliseconds and deviate+ from norms in the first place.++0.4++* Transitioned to using Edward Kmett's exceptions package instead of+ monad-control. Use 0.3 series if you still need monad-control+ support.++0.3++Thanks to John Wiegley and Michael Snoyman for their contributions:++* Now using monad-control instead of MonadCatchIO, which is widely+ agreed to be broken.+* Now using transformers instead of mtl, which was a broader than+ needed dependency.
retry.cabal view
@@ -1,6 +1,6 @@ name: retry -description: +description: This package exposes combinators that can wrap arbitrary monadic actions. They run the action and potentially retry@@ -14,7 +14,7 @@ case we should hang back for a bit and retry the query instead of simply raising an exception. -version: 0.6+version: 0.7 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE@@ -24,14 +24,18 @@ category: Control build-type: Simple cabal-version: >=1.10-Homepage: http://github.com/Soostone/retry+homepage: http://github.com/Soostone/retry+extra-source-files:+ README.md+ changelog.md library exposed-modules: Control.Retry- build-depends: + build-depends: base ==4.* , data-default-class , exceptions >= 0.5 && < 0.9+ , random >= 1 && < 1.2 , transformers < 0.5 hs-source-dirs: src default-language: Haskell2010@@ -42,18 +46,15 @@ main-is: main.hs hs-source-dirs: test,src ghc-options: -threaded- build-depends: - base ==4.* + build-depends:+ base ==4.* , exceptions , transformers , data-default-class+ , random , time- , QuickCheck >= 2.7 && < 2.8+ , QuickCheck >= 2.7 && < 2.9 , HUnit >= 1.2.5.2 && < 1.3 , hspec >= 1.9+ , stm default-language: Haskell2010-----
src/Control/Retry.hs view
@@ -1,9 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} @@ -30,9 +28,23 @@ module Control.Retry (- -- * High Level Operation- RetryPolicy (..)+ -- * Types and Operations+ RetryPolicyM (..)+ , RetryPolicy+ , retryPolicy+ , RetryStatus+ -- ** Fields for 'RetryStatus'+ , rsIterNumber+ , rsCumulativeDelay+ , rsPreviousDelay+ , defaultRetryStatus + -- ** Lenses for 'RetryStatus'+ , rsIterNumberL+ , rsCumulativeDelayL+ , rsPreviousDelayL++ -- * Applying Retry Policies , retrying , recovering , recoverAll@@ -41,33 +53,51 @@ -- * Retry Policies , constantDelay , exponentialBackoff+ , fullJitterBackoff , fibonacciBackoff , limitRetries++ -- * Policy Transformers , limitRetriesByDelay , capDelay - -- * Re-export from Data.Monoid-- , (<>)-+ -- * Development Helpers+ , simulatePolicy+ , simulatePolicyPP ) where -------------------------------------------------------------------------------+import Control.Applicative+import Control.Arrow 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.Functor.Identity+import Data.Maybe+import GHC.Generics+import System.Random import Data.Monoid import Prelude hiding (catch) ------------------------------------------------------------------------------- ---------------------------------------------------------------------------------- | A 'RetryPolicy' is a function that takes an iteration number and--- possibly returns a delay in microseconds. *Nothing* implies we have--- reached the retry limit.+-- | A 'RetryPolicyM' is a function that takes an 'RetryStatus' and+-- possibly returns a delay in microseconds. Iteration numbers start+-- at zero and increase by one on each retry. A *Nothing* return value from+-- the function implies we have reached the retry limit. ----- Please note that 'RetryPolicy' is a 'Monoid'. You can collapse+-- Please note that 'RetryPolicyM' is a 'Monoid'. You can collapse -- multiple strategies into one using 'mappend' or '<>'. The semantics -- of this combination are as follows: --@@ -93,30 +123,87 @@ -- -- >> def = constantDelay 50000 <> limitRetries 5 ----- For anything more complex, just define your own 'RetryPolicy':+-- For anything more complex, just define your own 'RetryPolicyM': ----- >> myPolicy = RetryPolicy $ \ n -> if n > 10 then Just 1000 else Just 10000-newtype RetryPolicy = RetryPolicy { getRetryPolicy :: Int -> Maybe Int }+-- >> myPolicy = retryPolicy $ \ rs -> if rsIterNumber n > 10 then Just 1000 else Just 10000+--+-- Since 0.7.+newtype RetryPolicyM m = RetryPolicyM { getRetryPolicyM :: RetryStatus -> m (Maybe Int) } -instance Default RetryPolicy where+-- | 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 -instance Monoid RetryPolicy where- mempty = RetryPolicy $ (const (Just 0))- (RetryPolicy a) `mappend` (RetryPolicy b) = RetryPolicy $ \ n -> do- a' <- a n- b' <- b n++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' -------------------------------------------------------------------------------+-- | 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) -- ^ Previous attempt's delay. Will always be Nothing on first run.+ } deriving (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 #-}+++-------------------------------------------------------------------------------+-- | 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 $ \ n -> if n >= i then Nothing else (Just 0)+limitRetries i = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> if n >= i then Nothing else (Just 0) -------------------------------------------------------------------------------@@ -125,10 +212,11 @@ -- and fail. limitRetriesByDelay :: Int- -- ^ Time-delay limit in microseconds. + -- ^ Time-delay limit in microseconds. -> RetryPolicy -> RetryPolicy-limitRetriesByDelay i p = RetryPolicy $ \ n -> getRetryPolicy p n >>= limit+limitRetriesByDelay i p = RetryPolicyM $ \ n ->+ (>>= limit) `liftM` getRetryPolicyM p n where limit delay = if delay >= i then Nothing else Just delay @@ -139,25 +227,42 @@ :: Int -- ^ Base delay in microseconds -> RetryPolicy-constantDelay delay = RetryPolicy (const (Just delay))+constantDelay delay = retryPolicy (const (Just delay)) ---------------------------------------------------------------------------------- | Grow delay exponentially each iteration.+-- | Grow delay exponentially each iteration. Each delay will+-- increase by a factor of two. exponentialBackoff :: Int- -- ^ Base delay in microseconds+ -- ^ First delay in microseconds -> RetryPolicy-exponentialBackoff base = RetryPolicy $ \ n -> Just (2^n * base)+exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> Just (2^n * base) -------------------------------------------------------------------------------+-- | 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 -> RetryPolicyM m+fullJitterBackoff base = RetryPolicyM $ \RetryStatus { rsIterNumber = n } -> do+ let d = (2^n * base) `div` 2+ rand <- liftIO $ randomRIO (0, d)+ return $ Just $! d + rand+++------------------------------------------------------------------------------- -- | Implement Fibonacci backoff. fibonacciBackoff :: Int -- ^ Base delay in microseconds -> RetryPolicy-fibonacciBackoff base = RetryPolicy $ \ n -> Just $ fib (n + 1) (0, base)+fibonacciBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n } -> Just $ fib (n + 1) (0, base) where fib 0 (a, _) = a fib !m (!a, !b) = fib (m-1) (b, a + b)@@ -171,11 +276,13 @@ -- between each one. To get termination you need to use one of the -- 'limitRetries' function variants. capDelay- :: Int+ :: Monad m+ => Int -- ^ A maximum delay in microseconds- -> RetryPolicy- -> RetryPolicy-capDelay limit p = RetryPolicy $ \ n -> min limit `fmap` (getRetryPolicy p) n+ -> RetryPolicyM m+ -> RetryPolicyM m+capDelay limit p = RetryPolicyM $ \ n ->+ (fmap (min limit)) `liftM` (getRetryPolicyM p) n -------------------------------------------------------------------------------@@ -187,7 +294,7 @@ -- retry it 5 additional times following the initial run: -- -- >>> import Data.Maybe--- >>> let f = putStrLn "Running action" >> return Nothing+-- >>> let f _ = putStrLn "Running action" >> return Nothing -- >>> retrying def (const $ return . isNothing) f -- Running action -- Running action@@ -199,38 +306,46 @@ -- -- Note how the latest failing result is returned after all retries -- have been exhausted.-retrying :: MonadIO m- => RetryPolicy- -> (Int -> b -> m Bool)- -- ^ An action to check whether the result should be retried.- -- If True, we delay and retry the operation.- -> m b- -- ^ Action to run- -> m b-retrying (RetryPolicy policy) chk f = go 0- where- go n = do- res <- f- chk' <- chk n res- case chk' of- True ->- case (policy n) of- Just delay -> do- liftIO (threadDelay delay)- go $! n+1- Nothing -> return res- False -> return res-+retrying :: MonadIO m+ => RetryPolicyM m+ -> (RetryStatus -> b -> m Bool)+ -- ^ An action to check whether the result should be retried.+ -- If True, we delay and retry the operation.+ -> (RetryStatus -> m b)+ -- ^ Action to run+ -> m b+retrying (RetryPolicyM policy) chk f = go defaultRetryStatus+ where+ go s = do+ res <- f s+ chk' <- chk s res+ case chk' of+ True -> do+ chk <- policy s+ case chk of+ Just delay -> do+ liftIO (threadDelay delay)+ go $! RetryStatus { rsIterNumber = rsIterNumber s + 1+ , rsCumulativeDelay = rsCumulativeDelay s + delay+ , rsPreviousDelay = Just (maybe 0 (const delay) (rsPreviousDelay s))}+ Nothing -> return res+ False -> return res ------------------------------------------------------------------------------- -- | Retry ALL exceptions that may be raised. To be used with caution;--- this matches the exception on 'SomeException'.+-- this matches the exception on 'SomeException'. Note that this+-- handler explicitly does not handle 'AsyncException' nor+-- 'SomeAsyncException' (for versions of base >= 4.7). It is not a+-- good idea to catch async exceptions as it can result in hanging+-- threads and programs. Note that if you just throw an exception to+-- this thread that does not descend from SomeException, recoverAll+-- will 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"+-- >>> let f _ = putStrLn "Running action" >> error "this is an error" -- >>> recoverAll def f -- Running action -- Running action@@ -245,52 +360,71 @@ #else :: (MonadIO m, MonadCatch m) #endif- => RetryPolicy- -> m a+ => RetryPolicyM m+ -> (RetryStatus -> m a) -> m a-recoverAll set f = recovering set [h] f+recoverAll set f = recovering set handlers f where+#if MIN_VERSION_base(4, 7, 0)+ someAsyncH _ = Handler $ \(_ :: SomeAsyncException) -> return False+ handlers = [asyncH, someAsyncH, h]+#else+ handlers = [asyncH, h]+#endif+ asyncH _ = Handler $ \ (_ :: AsyncException) -> return False h _ = Handler $ \ (_ :: SomeException) -> return True ------------------------------------------------------------------------------- -- | Run an action and recover from a raised exception by potentially--- retrying the action a number of times.+-- 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- => RetryPolicy+ => RetryPolicyM m -- ^ Just use 'def' for default settings- -> [(Int -> Handler m Bool)]+ -> [(RetryStatus -> Handler m Bool)] -- ^ Should a given exception be retried? Action will be- -- retried if this returns True.- -> m a+ -- 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 (RetryPolicy policy) hs f = mask $ \restore -> go restore 0+recovering p@(RetryPolicyM policy) hs f = mask $ \restore -> go restore defaultRetryStatus where go restore = loop where- loop n = do- r <- try $ restore f+ 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 ((($ n) -> Handler h) : hs')+ recover e ((($ s) -> Handler h) : hs') | Just e' <- fromException e = do chk <- h e'- if chk- then case policy n of- Just delay -> do- liftIO $ threadDelay delay- loop $! n+1- Nothing -> throwM e'- else throwM e'+ case chk of+ True -> do+ res <- policy s+ case res of+ Just delay -> do+ liftIO $ threadDelay delay+ loop $! RetryStatus { rsIterNumber = rsIterNumber s + 1+ , rsCumulativeDelay = rsCumulativeDelay s + delay+ , rsPreviousDelay = Just (maybe 0 (const delay) (rsPreviousDelay s))}+ Nothing -> throwM e'+ False -> throwM e' | otherwise = recover e hs' @@ -301,17 +435,65 @@ :: (Monad m, Show e, Exception e) => (e -> m Bool) -- ^ Test for whether action is to be retried- -> (String -> m ())- -- ^ How to report the generated warning message.- -> Int+ -> (Bool -> String -> m ())+ -- ^ How to report the generated warning message. Boolean is+ -- whether it's being retried or crashed.+ -> RetryStatus -- ^ Retry number -> Handler m Bool-logRetries f report n = Handler $ \ e -> do+logRetries f report s = Handler $ \ e -> do res <- f e let msg = "[retry:" <> show n <> "] Encountered " <> show e <> ". " <> if res then "Retrying." else "Crashing."- report msg+ report res msg return res+ where n = rsIterNumber s+++-------------------------------------------------------------------------------+-- | 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 + fromMaybe 0 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 $ \ (n, res) -> putStrLn $+ show n <> ": " <> maybe "Inhibit" ppTime res+ putStrLn $ "Total cumulative delay would be: " <>+ (ppTime $ sum $ (mapMaybe snd) ps)+++-------------------------------------------------------------------------------+ppTime :: (Integral a, Show a) => a -> String+ppTime n | n < 1000 = show n <> "us"+ | n < 1000000 = show (fromIntegral n / 1000) <> "ms"+ | otherwise = show (fromIntegral n / 1000) <> "ms"+++-------------------------------------------------------------------------------+-- 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 #-} ------------------