Hello community,
here is the log from the commit of package ghc-retry for openSUSE:Factory
checked in at 2018-05-30 12:12:29
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-retry (Old)
and /work/SRC/openSUSE:Factory/.ghc-retry.new (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-retry"
Wed May 30 12:12:29 2018 rev:10 rq:607874 version:0.7.6.2
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-retry/ghc-retry.changes 2017-09-15
22:10:19.764810325 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-retry.new/ghc-retry.changes 2018-05-30
12:27:03.502793209 +0200
@@ -1,0 +2,11 @@
+Mon May 14 17:02:11 UTC 2018 - psim...@suse.com
+
+- Update retry to version 0.7.6.2.
+ * Clarify the semantics of `limitRetriesByDelay`.
+ * Add `limitRetriesByCumulativeDelay`
+ * Improve haddocks for fullJitterBackoff.
+ * Add Semigroup instance when the Semigroup class is available through base.
+ * Loosen dependency upper bounds.
+ * Add skipAsyncExceptions helper function
+
+-------------------------------------------------------------------
Old:
----
retry-0.7.4.2.tar.gz
New:
----
retry-0.7.6.2.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-retry.spec ++++++
--- /var/tmp/diff_new_pack.hEUulV/_old 2018-05-30 12:27:04.278766451 +0200
+++ /var/tmp/diff_new_pack.hEUulV/_new 2018-05-30 12:27:04.282766313 +0200
@@ -1,7 +1,7 @@
#
# spec file for package ghc-retry
#
-# Copyright (c) 2017 SUSE LINUX GmbH, Nuernberg, Germany.
+# Copyright (c) 2018 SUSE LINUX GmbH, Nuernberg, Germany.
#
# All modifications and additions to the file contributed by third parties
# remain the property of their copyright owners, unless otherwise agreed
@@ -19,7 +19,7 @@
%global pkg_name retry
%bcond_with tests
Name: ghc-%{pkg_name}
-Version: 0.7.4.2
+Version: 0.7.6.2
Release: 0
Summary: Retry combinators for monadic actions that may fail
License: BSD-3-Clause
@@ -34,10 +34,12 @@
BuildRequires: ghc-transformers-devel
%if %{with tests}
BuildRequires: ghc-HUnit-devel
-BuildRequires: ghc-QuickCheck-devel
-BuildRequires: ghc-hspec-devel
+BuildRequires: ghc-hedgehog-devel
BuildRequires: ghc-mtl-devel
BuildRequires: ghc-stm-devel
+BuildRequires: ghc-tasty-devel
+BuildRequires: ghc-tasty-hedgehog-devel
+BuildRequires: ghc-tasty-hunit-devel
BuildRequires: ghc-time-devel
%endif
@@ -80,7 +82,7 @@
%ghc_pkg_recache
%files -f %{name}.files
-%doc LICENSE
+%license LICENSE
%files devel -f %{name}-devel.files
%doc README.md changelog.md
++++++ retry-0.7.4.2.tar.gz -> retry-0.7.6.2.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.7.4.2/README.md new/retry-0.7.6.2/README.md
--- old/retry-0.7.4.2/README.md 2016-11-23 19:32:49.000000000 +0100
+++ new/retry-0.7.6.2/README.md 2017-10-24 17:33:08.000000000 +0200
@@ -33,4 +33,5 @@
- John Wiegley
- Michael Snoyman
- Michael Xavier
+- Marco Zocca (@ocramz)
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.7.4.2/changelog.md
new/retry-0.7.6.2/changelog.md
--- old/retry-0.7.4.2/changelog.md 2016-11-23 19:32:49.000000000 +0100
+++ new/retry-0.7.6.2/changelog.md 2018-03-22 18:45:26.000000000 +0100
@@ -1,3 +1,25 @@
+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.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.7.4.2/retry.cabal
new/retry-0.7.6.2/retry.cabal
--- old/retry-0.7.4.2/retry.cabal 2016-11-23 19:32:49.000000000 +0100
+++ new/retry-0.7.6.2/retry.cabal 2018-03-22 18:45:18.000000000 +0100
@@ -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.4.2
+version: 0.7.6.2
synopsis: Retry combinators for monadic actions that may fail
license: BSD3
license-file: LICENSE
@@ -29,24 +29,35 @@
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.9
+ , 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
+ 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,14 +65,21 @@
, data-default-class
, random
, time
- , QuickCheck >= 2.7 && < 2.10
- , HUnit >= 1.2.5.2 && < 1.6
- , 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
location: git://github.com/Soostone/retry.git
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.7.4.2/src/Control/Retry.hs
new/retry-0.7.6.2/src/Control/Retry.hs
--- old/retry-0.7.4.2/src/Control/Retry.hs 2016-11-23 19:32:49.000000000
+0100
+++ new/retry-0.7.6.2/src/Control/Retry.hs 2018-02-05 21:10:48.000000000
+0100
@@ -51,6 +51,7 @@
, recovering
, stepping
, recoverAll
+ , skipAsyncExceptions
, logRetries
, defaultLogMsg
@@ -63,6 +64,7 @@
-- * Policy Transformers
, limitRetriesByDelay
+ , limitRetriesByCumulativeDelay
, capDelay
-- * Development Helpers
@@ -72,7 +74,6 @@
-------------------------------------------------------------------------------
import Control.Applicative
-import Control.Arrow
import Control.Concurrent
#if MIN_VERSION_base(4, 7, 0)
import Control.Exception (AsyncException, SomeAsyncException)
@@ -87,14 +88,17 @@
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
import GHC.Types (Int(I#))
import System.Random
+# if MIN_VERSION_base(4, 9, 0)
+import Data.Semigroup
+# else
import Data.Monoid
-import Prelude hiding (catch)
+# endif
+import Prelude
-------------------------------------------------------------------------------
@@ -148,12 +152,28 @@
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
-------------------------------------------------------------------------------
@@ -254,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
@@ -268,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
@@ -281,7 +322,7 @@
-- increase by a factor of two.
exponentialBackoff
:: Int
- -- ^ First delay in microseconds
+ -- ^ Base delay in microseconds
-> RetryPolicy
exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n } ->
Just $! base `boundedMult` boundedPow 2 n
@@ -294,8 +335,12 @@
--
-- temp = min(cap, base * 2 ** attempt)
--
--- sleep = temp / 2 + random_between(0, temp / 2)
-fullJitterBackoff :: MonadIO m => Int -> RetryPolicyM m
+-- 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)
@@ -408,14 +453,28 @@
-> 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, h]
+ someAsyncH _ = Handler $ \(_ :: SomeAsyncException) -> return False
+ handlers = [asyncH, someAsyncH]
#else
- handlers = [asyncH, h]
+ handlers = [asyncH]
#endif
- asyncH _ = Handler $ \ (_ :: AsyncException) -> return False
- h _ = Handler $ \ (_ :: SomeException) -> return True
-------------------------------------------------------------------------------
@@ -519,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 ())
@@ -534,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."
-------------------------------------------------------------------------------
@@ -564,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)
@@ -573,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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.7.4.2/test/Main.hs
new/retry-0.7.6.2/test/Main.hs
--- old/retry-0.7.4.2/test/Main.hs 1970-01-01 01:00:00.000000000 +0100
+++ new/retry-0.7.6.2/test/Main.hs 2018-02-05 21:10:48.000000000 +0100
@@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.7.4.2/test/Tests/Control/Retry.hs
new/retry-0.7.6.2/test/Tests/Control/Retry.hs
--- old/retry-0.7.4.2/test/Tests/Control/Retry.hs 1970-01-01
01:00:00.000000000 +0100
+++ new/retry-0.7.6.2/test/Tests/Control/Retry.hs 2018-02-05
21:10:48.000000000 +0100
@@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.7.4.2/test/main.hs
new/retry-0.7.6.2/test/main.hs
--- old/retry-0.7.4.2/test/main.hs 2016-11-23 19:32:49.000000000 +0100
+++ new/retry-0.7.6.2/test/main.hs 1970-01-01 01:00:00.000000000 +0100
@@ -1,2 +0,0 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
-
