retry 0.7.5.1 → 0.7.6.0

raw patch · 6 files changed

+460/−25 lines, 6 filesdep +hedgehogdep +tastydep +tasty-hedgehogdep −QuickCheckdep −hspecdep ~HUnitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: hedgehog, tasty, tasty-hedgehog, tasty-hunit

Dependencies removed: QuickCheck, hspec

Dependency ranges changed: HUnit

API changes (from Hackage documentation)

Files

• changelog.md +4/−0
• retry.cabal +23/−5
• src/Control/Retry.hs +40/−18
• test/Main.hs +22/−0
• test/Tests/Control/Retry.hs +371/−0
• test/main.hs +0/−2

@@ -1,3 +1,7 @@+0.7.6.0+* Clarify the semantics of `limitRetriesByDelay`.+* Add `limitRetriesByCumulativeDelay`+ 0.7.5.1 * Improve haddocks for fullJitterBackoff. 

@@ -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

@@ -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

@@ -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+  ]

@@ -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

@@ -1,2 +0,0 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}-