Hello community, here is the log from the commit of package ghc-retry for openSUSE:Leap:15.2 checked in at 2020-02-19 18:40:55 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Leap:15.2/ghc-retry (Old) and /work/SRC/openSUSE:Leap:15.2/.ghc-retry.new.26092 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-retry" Wed Feb 19 18:40:55 2020 rev:14 rq:771433 version:0.8.1.0 Changes: -------- --- /work/SRC/openSUSE:Leap:15.2/ghc-retry/ghc-retry.changes 2020-01-15 15:02:35.209815162 +0100 +++ /work/SRC/openSUSE:Leap:15.2/.ghc-retry.new.26092/ghc-retry.changes 2020-02-19 18:40:56.186170085 +0100 @@ -1,0 +2,26 @@ +Fri Nov 8 16:14:36 UTC 2019 - Peter Simons <[email protected]> + +- Drop obsolete group attributes. + +------------------------------------------------------------------- +Sat Oct 12 02:02:04 UTC 2019 - [email protected] + +- Update retry to version 0.8.1.0. + 0.8.1.0 + * Add `retryingDynamic` and `recoveringDynamic`. [PR 65](https://github.com/Soostone/retry/pull/65) + +------------------------------------------------------------------- +Sat Sep 28 02:01:09 UTC 2019 - [email protected] + +- Update retry to version 0.8.0.2. + 0.8.0.2 + * Update docs for default retry policy. [PR 64](https://github.com/Soostone/retry/pull/64) + +------------------------------------------------------------------- +Thu May 2 02:00:58 UTC 2019 - [email protected] + +- Update retry to version 0.8.0.1. + 0.8.0.1 + * Loosen upper bounds + +------------------------------------------------------------------- Old: ---- retry-0.8.0.0.tar.gz New: ---- retry-0.8.1.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-retry.spec ++++++ --- /var/tmp/diff_new_pack.7l3MpE/_old 2020-02-19 18:40:56.462170424 +0100 +++ /var/tmp/diff_new_pack.7l3MpE/_new 2020-02-19 18:40:56.462170424 +0100 @@ -19,11 +19,10 @@ %global pkg_name retry %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.8.0.0 +Version: 0.8.1.0 Release: 0 Summary: Retry combinators for monadic actions that may fail License: BSD-3-Clause -Group: Development/Libraries/Haskell URL: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz BuildRequires: ghc-Cabal-devel @@ -53,7 +52,6 @@ %package devel Summary: Haskell %{pkg_name} library development files -Group: Development/Libraries/Haskell Requires: %{name} = %{version}-%{release} Requires: ghc-compiler = %{ghc_version} Requires(post): ghc-compiler = %{ghc_version} ++++++ retry-0.8.0.0.tar.gz -> retry-0.8.1.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.8.0.0/changelog.md new/retry-0.8.1.0/changelog.md --- old/retry-0.8.0.0/changelog.md 2019-01-08 22:41:56.000000000 +0100 +++ new/retry-0.8.1.0/changelog.md 2019-10-11 17:33:21.000000000 +0200 @@ -1,3 +1,12 @@ +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) + +0.8.0.1 +* Loosen upper bounds + 0.8.0.0 * Remove dependency on data-default-class diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.8.0.0/retry.cabal new/retry-0.8.1.0/retry.cabal --- old/retry-0.8.0.0/retry.cabal 2019-01-08 22:41:56.000000000 +0100 +++ new/retry-0.8.1.0/retry.cabal 2019-10-11 17:32:32.000000000 +0200 @@ -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.0 +version: 0.8.1.0 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE @@ -37,10 +37,10 @@ exposed-modules: Control.Retry build-depends: base >= 4.6 && < 5 - , exceptions >= 0.5 && < 0.11 + , exceptions >= 0.5 , ghc-prim < 0.6 - , random >= 1 && < 1.2 - , transformers < 0.7 + , random >= 1 + , transformers hs-source-dirs: src default-language: Haskell2010 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.8.0.0/src/Control/Retry.hs new/retry-0.8.1.0/src/Control/Retry.hs --- old/retry-0.8.0.0/src/Control/Retry.hs 2019-01-08 22:41:56.000000000 +0100 +++ new/retry-0.8.1.0/src/Control/Retry.hs 2019-10-11 17:31:38.000000000 +0200 @@ -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 @@ -131,9 +135,9 @@ -- Naturally, 'mempty' will retry immediately (delay 0) for an -- unlimited number of retries, forming the identity for the 'Monoid'. -- --- The default under 'def' implements a constant 50ms delay, up to 5 times: +-- The default retry policy 'retryPolicyDefault' implements a constant 50ms delay, up to 5 times: -- --- >> def = constantDelay 50000 <> limitRetries 5 +-- >> retryPolicyDefault = constantDelay 50000 <> limitRetries 5 -- -- For anything more complex, just define your own 'RetryPolicyM': -- @@ -192,6 +196,30 @@ 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 @@ -403,7 +431,7 @@ -- -- >>> import Data.Maybe -- >>> let f _ = putStrLn "Running action" >> return Nothing --- >>> retrying def (const $ return . isNothing) f +-- >>> retrying retryPolicyDefault (const $ return . isNothing) f -- Running action -- Running action -- Running action @@ -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 ------------------------------------------------------------------------------- @@ -450,7 +516,7 @@ -- before finally failing for good: -- -- >>> let f _ = putStrLn "Running action" >> error "this is an error" --- >>> recoverAll def f +-- >>> recoverAll retryPolicyDefault f -- Running action -- Running action -- Running action @@ -509,7 +575,7 @@ :: (MonadIO m, MonadCatch m) #endif => RetryPolicyM m - -- ^ Just use 'def' for default settings + -- ^ Just use 'retryPolicyDefault' for default settings -> [(RetryStatus -> Handler m Bool)] -- ^ Should a given exception be retried? Action will be -- retried if this returns True *and* the policy allows it. @@ -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' @@ -555,7 +648,7 @@ :: (MonadIO m, MonadCatch m) #endif => RetryPolicyM m - -- ^ Just use 'def' for default settings + -- ^ Just use 'retryPolicyDefault' for default settings -> [(RetryStatus -> Handler m Bool)] -- ^ Should a given exception be retried? Action will be -- retried if this returns True *and* the policy allows it. @@ -725,7 +818,7 @@ -- instance Exception AnotherException --- test = retrying def [h1,h2] f +-- test = retrying retryPolicyDefault [h1,h2] f -- where -- f = putStrLn "Running action" >> throwM AnotherException -- h1 = Handler $ \ (e :: TestException) -> return False diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.8.0.0/test/Tests/Control/Retry.hs new/retry-0.8.1.0/test/Tests/Control/Retry.hs --- old/retry-0.8.0.0/test/Tests/Control/Retry.hs 2019-01-08 22:41:56.000000000 +0100 +++ new/retry-0.8.1.0/test/Tests/Control/Retry.hs 2019-10-11 17:31:38.000000000 +0200 @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ScopedTypeVariables #-} module Tests.Control.Retry @@ -8,9 +9,7 @@ import Control.Applicative import Control.Concurrent import Control.Concurrent.STM as STM -import Control.Exception (AsyncException (..), IOException, - MaskingState (..), - getMaskingState, throwTo) +import qualified Control.Exception as EX import Control.Monad.Catch import Control.Monad.Identity import Control.Monad.IO.Class @@ -44,6 +43,7 @@ , maskingStateTests , capDelayTests , limitRetriesByCumulativeDelayTests + , overridingDelayTests ] @@ -72,7 +72,7 @@ recoverAll (limitRetries 2) (const work) `finally` putMVar done () atomically (STM.check . (== 1) =<< readTVar counter) - throwTo tid UserInterrupt + EX.throwTo tid EX.UserInterrupt takeMVar done @@ -225,26 +225,26 @@ maskingStateTests :: TestTree maskingStateTests = testGroup "masking state" [ testCase "shouldn't change masking state in a recovered action" $ do - maskingState <- getMaskingState + maskingState <- EX.getMaskingState final <- try $ recovering retryPolicyDefault testHandlers $ const $ do - maskingState' <- getMaskingState + maskingState' <- EX.getMaskingState maskingState' @?= maskingState fail "Retrying..." assertBool - ("Expected IOException but didn't get one") - (isLeft (final :: Either IOException ())) + ("Expected EX.IOException but didn't get one") + (isLeft (final :: Either EX.IOException ())) , testCase "should mask asynchronous exceptions in exception handlers" $ do let checkMaskingStateHandlers = [ const $ Handler $ \(_ :: SomeException) -> do - maskingState <- getMaskingState - maskingState @?= MaskedInterruptible + maskingState <- EX.getMaskingState + maskingState @?= EX.MaskedInterruptible return shouldRetry ] final <- try $ recovering retryPolicyDefault checkMaskingStateHandlers $ const $ fail "Retrying..." assertBool - ("Expected IOException but didn't get one") - (isLeft (final :: Either IOException ())) + ("Expected EX.IOException but didn't get one") + (isLeft (final :: Either EX.IOException ())) ] @@ -313,6 +313,48 @@ 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 @@ -322,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) @@ -343,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" -------------------------------------------------------------------------------
