Script 'mail_helper' called by obssrc
Hello community,
here is the log from the commit of package ghc-retry for openSUSE:Factory
checked in at 2022-02-11 23:09:33
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Comparing /work/SRC/openSUSE:Factory/ghc-retry (Old)
and /work/SRC/openSUSE:Factory/.ghc-retry.new.1956 (New)
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-retry"
Fri Feb 11 23:09:33 2022 rev:4 rq:953521 version:0.9.1.0
Changes:
--------
--- /work/SRC/openSUSE:Factory/ghc-retry/ghc-retry.changes 2021-08-25
20:58:50.097111823 +0200
+++ /work/SRC/openSUSE:Factory/.ghc-retry.new.1956/ghc-retry.changes
2022-02-11 23:11:30.471310110 +0100
@@ -1,0 +2,12 @@
+Tue Jan 25 23:27:44 UTC 2022 - Peter Simons <psim...@suse.com>
+
+- Update retry to version 0.9.1.0.
+ 0.9.1.0
+ * Add resumable retry/recover variants:
+ * `resumeRetrying`
+ * `resumeRetryingDynamic`
+ * `resumeRecovering`
+ * `resumeRecoveringDynamic`
+ * `resumeRecoverAll`
+
+-------------------------------------------------------------------
Old:
----
retry-0.9.0.0.tar.gz
New:
----
retry-0.9.1.0.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-retry.spec ++++++
--- /var/tmp/diff_new_pack.UsSwyg/_old 2022-02-11 23:11:30.903311361 +0100
+++ /var/tmp/diff_new_pack.UsSwyg/_new 2022-02-11 23:11:30.907311372 +0100
@@ -1,7 +1,7 @@
#
# spec file for package ghc-retry
#
-# Copyright (c) 2021 SUSE LLC
+# Copyright (c) 2022 SUSE LLC
#
# 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.9.0.0
+Version: 0.9.1.0
Release: 0
Summary: Retry combinators for monadic actions that may fail
License: BSD-3-Clause
++++++ retry-0.9.0.0.tar.gz -> retry-0.9.1.0.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.9.0.0/changelog.md
new/retry-0.9.1.0/changelog.md
--- old/retry-0.9.0.0/changelog.md 2021-07-06 17:35:52.000000000 +0200
+++ new/retry-0.9.1.0/changelog.md 2022-01-26 00:16:12.000000000 +0100
@@ -1,3 +1,11 @@
+0.9.1.0
+* Add resumable retry/recover variants:
+ * `resumeRetrying`
+ * `resumeRetryingDynamic`
+ * `resumeRecovering`
+ * `resumeRecoveringDynamic`
+ * `resumeRecoverAll`
+
0.9.0.0
* Replace several uses of RetryPolicy type alias with RetryPolicyM m for better
GHC 9 compat.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.9.0.0/retry.cabal
new/retry-0.9.1.0/retry.cabal
--- old/retry-0.9.0.0/retry.cabal 2021-07-06 17:35:52.000000000 +0200
+++ new/retry-0.9.1.0/retry.cabal 2022-01-26 00:21:01.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.9.0.0
+version: 0.9.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.9.0.0/src/Control/Retry.hs
new/retry-0.9.1.0/src/Control/Retry.hs
--- old/retry-0.9.0.0/src/Control/Retry.hs 2021-07-06 17:35:52.000000000
+0200
+++ new/retry-0.9.1.0/src/Control/Retry.hs 2022-01-26 00:16:12.000000000
+0100
@@ -3,7 +3,6 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ViewPatterns #-}
@@ -60,6 +59,12 @@
, skipAsyncExceptions
, logRetries
, defaultLogMsg
+ -- ** Resumable variants
+ , resumeRetrying
+ , resumeRetryingDynamic
+ , resumeRecovering
+ , resumeRecoveringDynamic
+ , resumeRecoverAll
-- * Retry Policies
, constantDelay
@@ -221,15 +226,7 @@
toRetryAction True = ConsultPolicy
-------------------------------------------------------------------------------
--- | Datatype with stats about retries made thus far. The constructor
--- is deliberately not exported to make additional fields easier to
--- add in a backward-compatible manner. To read or modify fields in
--- RetryStatus, use the accessors or lenses below. Note that if you
--- don't want to use lenses, the exported field names can be used for
--- updates:
---
--- >> retryStatus { rsIterNumber = newIterNumber }
--- >> retryStatus & rsIterNumberL .~ newIterNumber
+-- | Datatype with stats about retries made thus far.
data RetryStatus = RetryStatus
{ rsIterNumber :: !Int -- ^ Iteration number, where 0 is the first try
, rsCumulativeDelay :: !Int -- ^ Delay incurred so far from retries in
microseconds
@@ -238,8 +235,7 @@
-------------------------------------------------------------------------------
--- | Initial, default retry status. Exported mostly to allow user code
--- to test their handlers and retry policies. Use fields or lenses to update.
+-- | Initial, default retry status. Use fields or lenses to update.
defaultRetryStatus :: RetryStatus
defaultRetryStatus = RetryStatus 0 0 Nothing
@@ -292,7 +288,7 @@
chk <- applyPolicy policy s
case chk of
Just rs -> do
- case (rsPreviousDelay rs) of
+ case rsPreviousDelay rs of
Nothing -> return ()
Just delay -> liftIO $ threadDelay delay
return (Just rs)
@@ -313,7 +309,7 @@
:: Int
-- ^ Maximum number of retries.
-> RetryPolicy
-limitRetries i = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> if n >= i
then Nothing else (Just 0)
+limitRetries i = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> if n >= i
then Nothing else Just 0
-------------------------------------------------------------------------------
@@ -329,7 +325,7 @@
-> RetryPolicyM m
-> RetryPolicyM m
limitRetriesByDelay i p = RetryPolicyM $ \ n ->
- (>>= limit) `liftM` getRetryPolicyM p n
+ (>>= limit) `fmap` getRetryPolicyM p n
where
limit delay = if delay >= i then Nothing else Just delay
@@ -345,7 +341,7 @@
-> RetryPolicyM m
-> RetryPolicyM m
limitRetriesByCumulativeDelay cumulativeLimit p = RetryPolicyM $ \ stat ->
- (>>= limit stat) `liftM` getRetryPolicyM p stat
+ (>>= limit stat) `fmap` getRetryPolicyM p stat
where
limit status curDelay
| rsCumulativeDelay status `boundedPlus` curDelay > cumulativeLimit =
Nothing
@@ -421,7 +417,7 @@
-> RetryPolicyM m
-> RetryPolicyM m
capDelay limit p = RetryPolicyM $ \ n ->
- (fmap (min limit)) `liftM` (getRetryPolicyM p) n
+ fmap (min limit) `fmap` getRetryPolicyM p n
-------------------------------------------------------------------------------
@@ -453,8 +449,29 @@
-> (RetryStatus -> m b)
-- ^ Action to run
-> m b
-retrying policy chk f =
- retryingDynamic policy (\rs -> fmap toRetryAction . chk rs) f
+retrying = resumeRetrying defaultRetryStatus
+
+
+-------------------------------------------------------------------------------
+-- | A variant of 'retrying' that allows specifying the initial
+-- 'RetryStatus' so that the retrying operation may pick up where it left
+-- off in regards to its retry policy.
+resumeRetrying
+ :: MonadIO m
+ => RetryStatus
+ -> RetryPolicyM m
+ -> (RetryStatus -> b -> m Bool)
+ -- ^ An action to check whether the result should be retried.
+ -- If True, we delay and retry the operation.
+ -> (RetryStatus -> m b)
+ -- ^ Action to run
+ -> m b
+resumeRetrying retryStatus policy chk f =
+ resumeRetryingDynamic
+ retryStatus
+ policy
+ (\rs -> fmap toRetryAction . chk rs)
+ f
-------------------------------------------------------------------------------
@@ -488,7 +505,25 @@
-> (RetryStatus -> m b)
-- ^ Action to run
-> m b
-retryingDynamic policy chk f = go defaultRetryStatus
+retryingDynamic = resumeRetryingDynamic defaultRetryStatus
+
+
+-------------------------------------------------------------------------------
+-- | A variant of 'retryingDynamic' that allows specifying the initial
+-- 'RetryStatus' so that a retrying operation may pick up where it left off
+-- in regards to its retry policy.
+resumeRetryingDynamic
+ :: MonadIO m
+ => RetryStatus
+ -> 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
+resumeRetryingDynamic retryStatus policy chk f = go retryStatus
where
go s = do
res <- f s
@@ -536,7 +571,24 @@
=> RetryPolicyM m
-> (RetryStatus -> m a)
-> m a
-recoverAll set f = recovering set handlers f
+recoverAll = resumeRecoverAll defaultRetryStatus
+
+
+-------------------------------------------------------------------------------
+-- | A variant of 'recoverAll' that allows specifying the initial
+-- 'RetryStatus' so that a recovering operation may pick up where it left
+-- off in regards to its retry policy.
+resumeRecoverAll
+#if MIN_VERSION_exceptions(0, 6, 0)
+ :: (MonadIO m, MonadMask m)
+#else
+ :: (MonadIO m, MonadCatch m)
+#endif
+ => RetryStatus
+ -> RetryPolicyM m
+ -> (RetryStatus -> m a)
+ -> m a
+resumeRecoverAll retryStatus set f = resumeRecovering retryStatus set handlers
f
where
handlers = skipAsyncExceptions ++ [h]
h _ = Handler $ \ (_ :: SomeException) -> return True
@@ -569,7 +621,7 @@
-- *earlier* in the list of handlers to reject 'AsyncException' and
-- 'SomeAsyncException', as catching these can cause thread and
-- program hangs. 'recoverAll' already does this for you so if you
--- just plan on catching 'SomeException', you may as well ues
+-- just plan on catching 'SomeException', you may as well use
-- 'recoverAll'
recovering
#if MIN_VERSION_exceptions(0, 6, 0)
@@ -579,6 +631,30 @@
#endif
=> RetryPolicyM m
-- ^ 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.
+ -- This action will be consulted first even if the policy
+ -- later blocks it.
+ -> (RetryStatus -> m a)
+ -- ^ Action to perform
+ -> m a
+recovering = resumeRecovering defaultRetryStatus
+
+
+-------------------------------------------------------------------------------
+-- | A variant of 'recovering' that allows specifying the initial
+-- 'RetryStatus' so that a recovering operation may pick up where it left
+-- off in regards to its retry policy.
+resumeRecovering
+#if MIN_VERSION_exceptions(0, 6, 0)
+ :: (MonadIO m, MonadMask m)
+#else
+ :: (MonadIO m, MonadCatch m)
+#endif
+ => RetryStatus
+ -> RetryPolicyM m
+ -- ^ 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.
@@ -587,11 +663,13 @@
-> (RetryStatus -> m a)
-- ^ Action to perform
-> m a
-recovering policy hs f =
- recoveringDynamic policy hs' f
+resumeRecovering retryStatus policy hs f =
+ resumeRecoveringDynamic retryStatus 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
@@ -602,6 +680,31 @@
#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 = resumeRecoveringDynamic defaultRetryStatus
+
+
+-------------------------------------------------------------------------------
+-- | A variant of 'recoveringDynamic' that allows specifying the initial
+-- 'RetryStatus' so that a recovering operation may pick up where it left
+-- off in regards to its retry policy.
+resumeRecoveringDynamic
+#if MIN_VERSION_exceptions(0, 6, 0)
+ :: (MonadIO m, MonadMask m)
+#else
+ :: (MonadIO m, MonadCatch m)
+#endif
+ => RetryStatus
+ -> 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
@@ -611,7 +714,7 @@
-> (RetryStatus -> m a)
-- ^ Action to perform
-> m a
-recoveringDynamic policy hs f = mask $ \restore -> go restore
defaultRetryStatus
+resumeRecoveringDynamic retryStatus policy hs f = mask $ \restore -> go
restore retryStatus
where
go restore = loop
where
@@ -638,7 +741,6 @@
| otherwise = recover e hs'
-
-------------------------------------------------------------------------------
-- | A version of 'recovering' that tries to run the action only a
-- single time. The control will return immediately upon both success
@@ -652,7 +754,7 @@
#endif
=> RetryPolicyM m
-- ^ Just use 'retryPolicyDefault' for default settings
- -> [(RetryStatus -> Handler m Bool)]
+ -> [RetryStatus -> Handler m Bool]
-- ^ Should a given exception be retried? Action will be
-- retried if this returns True *and* the policy allows it.
-- This action will be consulted first even if the policy
@@ -739,7 +841,7 @@
forM_ ps $ \ (iterNo, res) -> putStrLn $
show iterNo <> ": " <> maybe "Inhibit" ppTime res
putStrLn $ "Total cumulative delay would be: " <>
- (ppTime $ boundedSum $ (mapMaybe snd) ps)
+ ppTime (boundedSum $ mapMaybe snd ps)
-------------------------------------------------------------------------------
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.9.0.0/test/Tests/Control/Retry.hs
new/retry-0.9.1.0/test/Tests/Control/Retry.hs
--- old/retry-0.9.0.0/test/Tests/Control/Retry.hs 2021-07-06
17:35:53.000000000 +0200
+++ new/retry-0.9.1.0/test/Tests/Control/Retry.hs 2022-01-26
00:16:12.000000000 +0100
@@ -1,5 +1,6 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Tests.Control.Retry
( tests
@@ -27,7 +28,9 @@
import System.IO.Error
import Test.Tasty
import Test.Tasty.Hedgehog
-import Test.Tasty.HUnit (assertBool, testCase, (@?=))
+import Test.Tasty.HUnit ( assertBool, assertFailure
+ , testCase, (@=?), (@?=)
+ )
-------------------------------------------------------------------------------
import Control.Retry
-------------------------------------------------------------------------------
@@ -44,6 +47,7 @@
, capDelayTests
, limitRetriesByCumulativeDelayTests
, overridingDelayTests
+ , resumableTests
]
@@ -355,15 +359,124 @@
forM_ (zip (diffTimes measuredTimestamps) expectedDelays) $
\(actual, expected) -> diff actual (>=) expected
+
+-------------------------------------------------------------------------------
+resumableTests :: TestTree
+resumableTests = testGroup "resumable"
+ [ testGroup "resumeRetrying"
+ [ testCase "can resume" $ do
+ retryingTest resumeRetrying (\_ _ -> pure shouldRetry)
+ ]
+ , testGroup "resumeRetryingDynamic"
+ [ testCase "can resume" $ do
+ retryingTest resumeRetryingDynamic (\_ _ -> pure $ ConsultPolicy)
+ ]
+ , testGroup "resumeRecovering"
+ [ testCase "can resume" $ do
+ recoveringTest resumeRecovering testHandlers
+ ]
+ , testGroup "resumeRecoveringDynamic"
+ [ testCase "can resume" $ do
+ recoveringTest resumeRecoveringDynamic testHandlersDynamic
+ ]
+ , testGroup "resumeRecoverAll"
+ [ testCase "can resume" $ do
+ recoveringTest
+ (\status policy () action -> resumeRecoverAll status policy action)
+ ()
+ ]
+ ]
+ where
+ retryingTest
+ :: (RetryStatus -> RetryPolicyM IO -> p -> (RetryStatus -> IO ()) -> IO
())
+ -> p
+ -> IO ()
+ retryingTest resumableOp isRetryNeeded = do
+ counterRef <- newIORef (0 :: Int)
+
+ let go policy status = do
+ atomicWriteIORef counterRef 0
+ resumableOp
+ status
+ policy
+ isRetryNeeded
+ (const $ atomicModifyIORef' counterRef $ \n -> (1 + n, ()))
+
+ let policy = limitRetries 2
+ let nextStatus = nextStatusUsingPolicy policy
+
+ go policy defaultRetryStatus
+ (3 @=?) =<< readIORef counterRef
+
+ go policy =<< nextStatus defaultRetryStatus
+ (2 @=?) =<< readIORef counterRef
+
+ go policy =<< nextStatus =<< nextStatus defaultRetryStatus
+ (1 @=?) =<< readIORef counterRef
+
+ recoveringTest
+ :: (RetryStatus -> RetryPolicyM IO -> handlers -> (RetryStatus -> IO ())
-> IO ())
+ -> handlers
+ -> IO ()
+ recoveringTest resumableOp handlers = do
+ counterRef <- newIORef (0 :: Int)
+
+ let go policy status = do
+ action <- do
+ mkFailUntilIO
+ (\_ -> atomicModifyIORef' counterRef $ \n -> (1 + n, False))
+ Custom1
+ try $ resumableOp status policy handlers action
+
+ let policy = limitRetries 2
+ let nextStatus = nextStatusUsingPolicy policy
+
+ do
+ atomicWriteIORef counterRef 0
+ res <- go policy defaultRetryStatus
+ res @?= Left Custom1
+ (3 @=?) =<< readIORef counterRef
+
+ do
+ atomicWriteIORef counterRef 0
+ res <- go policy =<< nextStatus defaultRetryStatus
+ res @?= Left Custom1
+ (2 @=?) =<< readIORef counterRef
+
+ do
+ atomicWriteIORef counterRef 0
+ res <- go policy =<< nextStatus =<< nextStatus defaultRetryStatus
+ res @?= Left Custom1
+ (1 @=?) =<< readIORef counterRef
+
+
+-------------------------------------------------------------------------------
+nextStatusUsingPolicy :: RetryPolicyM IO -> RetryStatus -> IO RetryStatus
+nextStatusUsingPolicy policy status = do
+ applyPolicy policy status >>= \case
+ Nothing -> do
+ assertFailure "applying policy produced no new status"
+ Just status' -> do
+ pure status'
+
+
-------------------------------------------------------------------------------
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)]
+
+-------------------------------------------------------------------------------
+testHandlersDynamic :: [a -> Handler IO RetryAction]
+testHandlersDynamic =
+ [const $ Handler (\(_::SomeException) -> return ConsultPolicy)]
+
-- | Apply a function to adjacent list items.
--
-- Ie.:
@@ -427,11 +540,33 @@
-- | 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
+mkFailN e n = mkFailUntil (\iter -> iter >= n) e
+
+
+-------------------------------------------------------------------------------
+-- | Create an action that will fail with the given exception until the given
+-- iteration predicate returns 'True', at which point the action will return
+-- '()' in any subsequent calls.
+mkFailUntil
+ :: (Exception e)
+ => (Int -> Bool)
+ -> e
+ -> IO (s -> IO ())
+mkFailUntil p = mkFailUntilIO (pure . p)
+
+
+-------------------------------------------------------------------------------
+-- | The same as 'mkFailUntil' but allows doing IO in the predicate.
+mkFailUntilIO
+ :: (Exception e)
+ => (Int -> IO Bool)
+ -> e
+ -> IO (s -> IO ())
+mkFailUntilIO p e = do
r <- newIORef 0
return $ const $ do
old <- atomicModifyIORef' r $ \ old -> (old+1, old)
- case old >= n of
+ p old >>= \case
True -> return ()
False -> throwM e
