retry 0.9.0.0 → 0.9.1.0
raw patch · 4 files changed
+277/−32 lines, 4 files
Files
- changelog.md +8/−0
- retry.cabal +1/−1
- src/Control/Retry.hs +130/−28
- test/Tests/Control/Retry.hs +138/−3
changelog.md view
@@ -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.
retry.cabal view
@@ -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
src/Control/Retry.hs view
@@ -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,11 +449,32 @@ -> (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+++------------------------------------------------------------------------------- -- | Same as 'retrying', but with the ability to override -- the delay of the retry policy based on information -- obtained after initiation.@@ -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) -------------------------------------------------------------------------------
test/Tests/Control/Retry.hs view
@@ -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