diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,7 @@ +0.7.6.0 +* Clarify the semantics of `limitRetriesByDelay`. +* Add `limitRetriesByCumulativeDelay` + 0.7.5.1 * Improve haddocks for fullJitterBackoff. diff --git a/retry.cabal b/retry.cabal --- a/retry.cabal +++ b/retry.cabal @@ -14,7 +14,7 @@ case we should hang back for a bit and retry the query instead of simply raising an exception. -version: 0.7.5.1 +version: 0.7.6.0 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE @@ -29,6 +29,10 @@ README.md changelog.md +flag lib-Werror + default: False + manual: True + library exposed-modules: Control.Retry build-depends: @@ -41,12 +45,19 @@ 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 + main-is: Main.hs hs-source-dirs: test,src ghc-options: -threaded + other-modules: Control.Retry + Tests.Control.Retry build-depends: base ==4.* , exceptions @@ -54,13 +65,20 @@ , data-default-class , random , time - , QuickCheck >= 2.7 && < 2.11 - , HUnit >= 1.2.5.2 && < 1.7 - , hspec >= 1.9 + , 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 diff --git a/src/Control/Retry.hs b/src/Control/Retry.hs --- a/src/Control/Retry.hs +++ b/src/Control/Retry.hs @@ -64,6 +64,7 @@ -- * Policy Transformers , limitRetriesByDelay + , limitRetriesByCumulativeDelay , capDelay -- * Development Helpers @@ -73,7 +74,6 @@ ------------------------------------------------------------------------------- import Control.Applicative -import Control.Arrow import Control.Concurrent #if MIN_VERSION_base(4, 7, 0) import Control.Exception (AsyncException, SomeAsyncException) @@ -88,7 +88,6 @@ import Control.Monad.Trans.State import Data.Default.Class import Data.List (foldl') -import Data.Functor.Identity import Data.Maybe import GHC.Generics import GHC.Prim @@ -99,7 +98,7 @@ # else import Data.Monoid # endif -import Prelude hiding (catch) +import Prelude ------------------------------------------------------------------------------- @@ -275,13 +274,16 @@ ------------------------------------------------------------------------------- -- | Add an upperbound to a policy such that once the given time-delay --- amount has been reached or exceeded, the policy will stop retrying --- and fail. +-- 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 - :: Int + :: Monad m + => Int -- ^ Time-delay limit in microseconds. - -> RetryPolicy - -> RetryPolicy + -> RetryPolicyM m + -> RetryPolicyM m limitRetriesByDelay i p = RetryPolicyM $ \ n -> (>>= limit) `liftM` getRetryPolicyM p n where @@ -289,6 +291,24 @@ ------------------------------------------------------------------------------- +-- | 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 @@ -442,8 +462,9 @@ -- '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, MonadMask m) +skipAsyncExceptions + :: ( MonadIO m + ) => [RetryStatus -> Handler m Bool] skipAsyncExceptions = handlers where @@ -557,7 +578,8 @@ -- | Helper function for constructing handler functions of the form required -- by 'recovering'. logRetries - :: (Monad m, Show e, Exception e) + :: ( Monad m + , Exception e) => (e -> m Bool) -- ^ Test for whether action is to be retried -> (Bool -> e -> RetryStatus -> m ()) @@ -572,12 +594,12 @@ return result -- | For use with 'logRetries'. -defaultLogMsg :: (Show e, Exception e) => Bool -> e -> RetryStatus -> String +defaultLogMsg :: (Exception e) => Bool -> e -> RetryStatus -> String defaultLogMsg shouldRetry err status = - "[retry:" <> iter <> "] Encountered " <> show err <> ". " <> next + "[retry:" <> iter <> "] Encountered " <> show err <> ". " <> nextMsg where iter = show $ rsIterNumber status - next = if shouldRetry then "Retrying." else "Crashing." + nextMsg = if shouldRetry then "Retrying." else "Crashing." ------------------------------------------------------------------------------- @@ -602,8 +624,8 @@ simulatePolicyPP :: Int -> RetryPolicyM IO -> IO () simulatePolicyPP n p = do ps <- simulatePolicy n p - forM_ ps $ \ (n, res) -> putStrLn $ - show n <> ": " <> maybe "Inhibit" ppTime res + forM_ ps $ \ (iterNo, res) -> putStrLn $ + show iterNo <> ": " <> maybe "Inhibit" ppTime res putStrLn $ "Total cumulative delay would be: " <> (ppTime $ boundedSum $ (mapMaybe snd) ps) @@ -611,8 +633,8 @@ ------------------------------------------------------------------------------- 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" + | n < 1000000 = show ((fromIntegral n / 1000) :: Double) <> "ms" + | otherwise = show ((fromIntegral n / 1000) :: Double) <> "ms" ------------------------------------------------------------------------------- -- Bounded arithmetic diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /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 --- /dev/null +++ b/test/Tests/Control/Retry.hs @@ -0,0 +1,371 @@ +{-# 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 "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 diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,2 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} -