retry 0.8.0.2 → 0.8.1.0
raw patch · 4 files changed
+192/−16 lines, 4 files
Files
- changelog.md +3/−0
- retry.cabal +1/−1
- src/Control/Retry.hs +108/−15
- test/Tests/Control/Retry.hs +80/−0
changelog.md view
@@ -1,3 +1,6 @@+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)
retry.cabal view
@@ -14,7 +14,7 @@ case we should hang back for a bit and retry the query instead of simply raising an exception. -version: 0.8.0.2+version: 0.8.1.0 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE
src/Control/Retry.hs view
@@ -37,6 +37,8 @@ , retryPolicy , retryPolicyDefault , natTransformRetryPolicy+ , RetryAction (..)+ , toRetryAction , RetryStatus (..) , defaultRetryStatus , applyPolicy@@ -50,7 +52,9 @@ -- * Applying Retry Policies , retrying+ , retryingDynamic , recovering+ , recoveringDynamic , stepping , recoverAll , skipAsyncExceptions@@ -192,7 +196,31 @@ 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. The constructor -- is deliberately not exported to make additional fields easier to -- add in a backward-compatible manner. To read or modify fields in@@ -422,18 +450,56 @@ -> (RetryStatus -> m b) -- ^ Action to run -> m b-retrying policy chk f = go defaultRetryStatus+retrying policy chk f =+ retryingDynamic 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 policy chk f = go defaultRetryStatus 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- if chk'- then do- rs <- applyAndDelay policy s- case rs of- Nothing -> return res- Just rs' -> go $! rs'- else return res+ case chk' of+ DontRetry -> return res+ ConsultPolicy -> consultPolicy policy+ ConsultPolicyOverrideDelay delay ->+ consultPolicy $ modifyRetryPolicyDelay (const delay) policy -------------------------------------------------------------------------------@@ -518,7 +584,31 @@ -> (RetryStatus -> m a) -- ^ Action to perform -> m a-recovering policy hs f = mask $ \restore -> go restore defaultRetryStatus+recovering policy hs f =+ recoveringDynamic 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 policy hs f = mask $ \restore -> go restore defaultRetryStatus where go restore = loop where@@ -531,14 +621,17 @@ recover e [] = throwM e recover e ((($ s) -> Handler h) : hs') | Just e' <- fromException e = do+ let consultPolicy policy' = do+ rs <- applyAndDelay policy' s+ case rs of+ Just rs' -> loop $! rs'+ Nothing -> throwM e' chk <- h e' case chk of- True -> do- rs <- applyAndDelay policy s- case rs of- Just rs' -> loop $! rs'- Nothing -> throwM e'- False -> throwM e'+ DontRetry -> throwM e'+ ConsultPolicy -> consultPolicy policy+ ConsultPolicyOverrideDelay delay ->+ consultPolicy $ modifyRetryPolicyDelay (const delay) policy | otherwise = recover e hs'
test/Tests/Control/Retry.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} module Tests.Control.Retry@@ -42,6 +43,7 @@ , maskingStateTests , capDelayTests , limitRetriesByCumulativeDelayTests+ , overridingDelayTests ] @@ -311,7 +313,49 @@ 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++------------------------------------------------------------------------------- isLeftAnd :: (a -> Bool) -> Either a b -> Bool isLeftAnd f ei = case ei of Left v -> f v@@ -320,6 +364,19 @@ testHandlers :: [a -> Handler IO Bool] testHandlers = [const $ Handler (\(_::SomeException) -> return shouldRetry)] +-- | 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)@@ -341,6 +398,29 @@ -------------------------------------------------------------------------------+-- | Generate an arbitrary 'RetryPolicy' without any limits applied.+genPolicyNoLimit+ :: (MonadGen mg, 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" -------------------------------------------------------------------------------