Hello community, here is the log from the commit of package ghc-retry for openSUSE:Factory checked in at 2019-12-27 13:56:56 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-retry (Old) and /work/SRC/openSUSE:Factory/.ghc-retry.new.6675 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-retry" Fri Dec 27 13:56:56 2019 rev:18 rq:759494 version:0.8.1.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-retry/ghc-retry.changes 2019-10-18 14:34:55.424006520 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-retry.new.6675/ghc-retry.changes 2019-12-27 13:57:02.292764696 +0100 @@ -1,0 +2,12 @@ +Fri Nov 8 16:14:36 UTC 2019 - Peter Simons <psim...@suse.com> + +- Drop obsolete group attributes. + +------------------------------------------------------------------- +Sat Oct 12 02:02:04 UTC 2019 - psim...@suse.com + +- 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) + +------------------------------------------------------------------- Old: ---- retry-0.8.0.2.tar.gz New: ---- retry-0.8.1.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-retry.spec ++++++ --- /var/tmp/diff_new_pack.Q4VWAN/_old 2019-12-27 13:57:02.828764955 +0100 +++ /var/tmp/diff_new_pack.Q4VWAN/_new 2019-12-27 13:57:02.828764955 +0100 @@ -19,11 +19,10 @@ %global pkg_name retry %bcond_with tests Name: ghc-%{pkg_name} -Version: 0.8.0.2 +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.2.tar.gz -> retry-0.8.1.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.8.0.2/changelog.md new/retry-0.8.1.0/changelog.md --- old/retry-0.8.0.2/changelog.md 2019-09-27 22:24:28.000000000 +0200 +++ new/retry-0.8.1.0/changelog.md 2019-10-11 17:33:21.000000000 +0200 @@ -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) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.8.0.2/retry.cabal new/retry-0.8.1.0/retry.cabal --- old/retry-0.8.0.2/retry.cabal 2019-09-27 22:23:31.000000000 +0200 +++ 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.2 +version: 0.8.1.0 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.8.0.2/src/Control/Retry.hs new/retry-0.8.1.0/src/Control/Retry.hs --- old/retry-0.8.0.2/src/Control/Retry.hs 2019-09-27 17:56:03.000000000 +0200 +++ 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 @@ -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 @@ -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' diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.8.0.2/test/Tests/Control/Retry.hs new/retry-0.8.1.0/test/Tests/Control/Retry.hs --- old/retry-0.8.0.2/test/Tests/Control/Retry.hs 2019-09-27 21:47:34.000000000 +0200 +++ 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 @@ -42,6 +43,7 @@ , maskingStateTests , capDelayTests , limitRetriesByCumulativeDelayTests + , overridingDelayTests ] @@ -311,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 @@ -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" -------------------------------------------------------------------------------
