retry 0.9.2.1 → 0.9.3.0
raw patch · 6 files changed
+428/−66 lines, 6 filesdep +unliftio-core
Dependencies added: unliftio-core
Files
- changelog.md +3/−0
- retry.cabal +6/−1
- src/UnliftIO/Retry.hs +268/−0
- test/Main.hs +2/−0
- test/Tests/Control/Retry.hs +94/−65
- test/Tests/UnliftIO/Retry.hs +55/−0
changelog.md view
@@ -1,3 +1,6 @@+0.9.3.0+* Add `UnliftIO.Retry` [PR 81](https://github.com/Soostone/retry/pull/81)+ 0.9.2.1 * Use explicit import for `lift` which allows for mtl-2.3 compatibility [PR 80](https://github.com/Soostone/retry/pull/80)
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.2.1+version: 0.9.3.0 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE@@ -35,6 +35,7 @@ library exposed-modules: Control.Retry+ UnliftIO.Retry build-depends: base >= 4.8 && < 5 , exceptions >= 0.5@@ -43,6 +44,7 @@ , transformers , mtl , mtl-compat+ , unliftio-core >= 0.1.0.0 hs-source-dirs: src default-language: Haskell2010 @@ -58,7 +60,9 @@ hs-source-dirs: test,src ghc-options: -threaded other-modules: Control.Retry+ UnliftIO.Retry Tests.Control.Retry+ Tests.UnliftIO.Retry build-depends: base ==4.* , exceptions@@ -74,6 +78,7 @@ , ghc-prim , mtl , mtl-compat+ , unliftio-core default-language: Haskell2010 if flag(lib-Werror)
+ src/UnliftIO/Retry.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE RankNTypes #-}++-----------------------------------------------------------------------------+-- |+-- Module : UnliftIO.Retry+-- Copyright : Ozgun Ataman <ozgun.ataman@soostone.com>+-- License : BSD3+--+-- Maintainer : Patrick Brisbin <pbrisbin@gmail.com>+-- Stability : provisional+--+-- Unlifted "Control.Retry".+--+-- @since 0.9.3.0+----------------------------------------------------------------------------+++module UnliftIO.Retry+ (+ -- * Types and Operations+ RetryPolicyM (..)+ , RetryPolicy+ , retryPolicy+ , retryPolicyDefault+ , natTransformRetryPolicy+ , RetryAction (..)+ , toRetryAction+ , RetryStatus (..)+ , defaultRetryStatus+ , applyPolicy+ , applyAndDelay+++ -- ** Lenses for 'RetryStatus'+ , rsIterNumberL+ , rsCumulativeDelayL+ , rsPreviousDelayL++ -- * Applying Retry Policies+ , retrying+ , retryingDynamic+ , recovering+ , recoveringDynamic+ , stepping+ , recoverAll+ , skipAsyncExceptions+ , logRetries+ , defaultLogMsg+ , retryOnError+ -- ** Resumable variants+ , resumeRetrying+ , resumeRetryingDynamic+ , resumeRecovering+ , resumeRecoveringDynamic+ , resumeRecoverAll++ -- * Retry Policies+ , constantDelay+ , exponentialBackoff+ , fullJitterBackoff+ , fibonacciBackoff+ , limitRetries++ -- * Policy Transformers+ , limitRetriesByDelay+ , limitRetriesByCumulativeDelay+ , capDelay++ -- * Development Helpers+ , simulatePolicy+ , simulatePolicyPP+ ) where++-------------------------------------------------------------------------------+import Control.Retry hiding+ ( recoverAll+ , recovering+ , recoveringDynamic+ , resumeRecovering+ , resumeRecoveringDynamic+ , resumeRecoverAll+ , stepping+ )+import qualified Control.Retry as Retry+import Control.Monad.Catch (Handler(..))+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Prelude+-------------------------------------------------------------------------------+++-------------------------------------------------------------------------------+-- | Run an action and recover from a raised exception by potentially+-- retrying the action a number of times. Note that if you're going to+-- use a handler for 'SomeException', you should add explicit cases+-- *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 use+-- 'recoverAll'+recovering+ :: MonadUnliftIO m+ => 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+ :: MonadUnliftIO m+ => 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.+ -- This action will be consulted first even if the policy+ -- later blocks it.+ -> (RetryStatus -> m a)+ -- ^ Action to perform+ -> m a+resumeRecovering retryStatus policy hs f = withRunInIO $ \runInIO ->+ Retry.resumeRecovering+ retryStatus+ (transRetryPolicy runInIO policy)+ (map ((.) $ transHandler runInIO) hs)+ (runInIO . f)+++-------------------------------------------------------------------------------+-- | The difference between this and 'recovering' is the same as+-- the difference between 'retryingDynamic' and 'retrying'.+recoveringDynamic+ :: MonadUnliftIO m+ => 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+ :: MonadUnliftIO m+ => 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+ -- '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+resumeRecoveringDynamic retryStatus policy hs f = withRunInIO $ \runInIO ->+ Retry.resumeRecoveringDynamic+ retryStatus+ (transRetryPolicy runInIO policy)+ (map ((.) $ transHandler runInIO) hs)+ (runInIO . f)+++-------------------------------------------------------------------------------+-- | Retry ALL exceptions that may be raised. To be used with caution;+-- this matches the exception on 'SomeException'. Note that this+-- handler explicitly does not handle 'AsyncException' nor+-- 'SomeAsyncException' (for versions of base >= 4.7). It is not a+-- good idea to catch async exceptions as it can result in hanging+-- threads and programs. Note that if you just throw an exception to+-- this thread that does not descend from SomeException, recoverAll+-- will not catch it.+--+-- See how the action below is run once and retried 5 more times+-- before finally failing for good:+--+-- >>> let f _ = putStrLn "Running action" >> error "this is an error"+-- >>> recoverAll retryPolicyDefault f+-- Running action+-- Running action+-- Running action+-- Running action+-- Running action+-- Running action+-- *** Exception: this is an error+recoverAll+ :: MonadUnliftIO m+ => RetryPolicyM m+ -> (RetryStatus -> m a)+ -> m a+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+ :: MonadUnliftIO m+ => RetryStatus+ -> RetryPolicyM m+ -> (RetryStatus -> m a)+ -> m a+resumeRecoverAll retryStatus policy f = withRunInIO $ \runInIO ->+ Retry.resumeRecoverAll+ retryStatus+ (transRetryPolicy runInIO policy)+ (runInIO . f)++-------------------------------------------------------------------------------+-- | A version of 'recovering' that tries to run the action only a+-- single time. The control will return immediately upon both success+-- and failure. Useful for implementing retry logic in distributed+-- queues and similar external-interfacing systems.+stepping+ :: MonadUnliftIO m+ => 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 ())+ -- ^ Action to run with updated status upon failure.+ -> (RetryStatus -> m a)+ -- ^ Main action to perform with current status.+ -> RetryStatus+ -- ^ Current status of this step+ -> m (Maybe a)+stepping policy hs schedule f s = withRunInIO $ \runInIO ->+ Retry.stepping+ (transRetryPolicy runInIO policy)+ (map ((.) $ transHandler runInIO) hs)+ (runInIO . schedule)+ (runInIO . f)+ s+++-------------------------------------------------------------------------------+transRetryPolicy :: (forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n+transRetryPolicy f (RetryPolicyM p) = RetryPolicyM $ f . p+++-------------------------------------------------------------------------------+transHandler :: (forall b. m b -> n b) -> Handler m a -> Handler n a+transHandler f (Handler h) = Handler $ f . h
test/Main.hs view
@@ -7,6 +7,7 @@ import Test.Tasty ------------------------------------------------------------------------------- import qualified Tests.Control.Retry+import qualified Tests.UnliftIO.Retry ------------------------------------------------------------------------------- @@ -19,4 +20,5 @@ tests :: TestTree tests = testGroup "retry" [ Tests.Control.Retry.tests+ , Tests.UnliftIO.Retry.tests ]
test/Tests/Control/Retry.hs view
@@ -5,6 +5,14 @@ {-# LANGUAGE FlexibleContexts #-} module Tests.Control.Retry ( tests++ -- * Used to test UnliftIO versions of the same functions+ , recoveringTestsWith+ , maskingStateTestsWith+ , quadraticDelayTestsWith+ , recoveringTest+ , testHandlers+ , testHandlersDynamic ) where -------------------------------------------------------------------------------@@ -56,12 +64,19 @@ ------------------------------------------------------------------------------- recoveringTests :: TestTree-recoveringTests = testGroup "recovering"+recoveringTests = recoveringTestsWith recovering+++recoveringTestsWith+ :: Monad m+ => (RetryPolicyM m -> [RetryStatus -> Handler IO Bool] -> (a -> IO ()) -> IO ())+ -> TestTree+recoveringTestsWith recovering' = 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+ res <- liftIO $ try $ recovering' (constantDelay timeout <> limitRetries retries) testHandlers (const $ throwM (userError "booo"))@@ -88,7 +103,7 @@ , testCase "recovers from custom exceptions" $ do f <- mkFailN Custom1 2- res <- try $ recovering+ res <- try $ recovering' (constantDelay 5000 <> limitRetries 3) [const $ Handler $ \ Custom1 -> return shouldRetry] f@@ -96,7 +111,7 @@ , testCase "fails beyond policy using custom exceptions" $ do f <- mkFailN Custom1 3- res <- try $ recovering+ res <- try $ recovering' (constantDelay 5000 <> limitRetries 2) [const $ Handler $ \ Custom1 -> return shouldRetry] f@@ -111,7 +126,7 @@ , testCase "does not recover from unhandled exceptions" $ do f <- mkFailN Custom2 2- res <- try $ recovering+ res <- try $ recovering' (constantDelay 5000 <> limitRetries 5) [const $ Handler $ \ Custom1 -> return shouldRetry] f@@ -120,7 +135,7 @@ , testCase "recovers in presence of multiple handlers" $ do f <- mkFailN Custom2 2- res <- try $ recovering+ res <- try $ recovering' (constantDelay 5000 <> limitRetries 5) [ const $ Handler $ \ Custom1 -> return shouldRetry , const $ Handler $ \ Custom2 -> return shouldRetry ]@@ -130,7 +145,7 @@ , testCase "general exceptions catch specific ones" $ do f <- mkFailN Custom2 2- res <- try $ recovering+ res <- try $ recovering' (constantDelay 5000 <> limitRetries 5) [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] f@@ -139,7 +154,7 @@ , testCase "(redundant) even general catchers don't go beyond policy" $ do f <- mkFailN Custom2 3- res <- try $ recovering+ res <- try $ recovering' (constantDelay 5000 <> limitRetries 2) [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] f@@ -149,7 +164,7 @@ , testCase "rethrows in presence of failed exception casts" $ do f <- mkFailN Custom2 3 final <- try $ do- res <- try $ recovering+ res <- try $ recovering' (constantDelay 5000 <> limitRetries 2) [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] f@@ -230,10 +245,17 @@ ------------------------------------------------------------------------------- maskingStateTests :: TestTree-maskingStateTests = testGroup "masking state"+maskingStateTests = maskingStateTestsWith recovering+++maskingStateTestsWith+ :: Monad m+ => (RetryPolicyM m -> [RetryStatus -> Handler IO Bool] -> (a -> IO b) -> IO ())+ -> TestTree+maskingStateTestsWith recovering' = testGroup "masking state" [ testCase "shouldn't change masking state in a recovered action" $ do maskingState <- EX.getMaskingState- final <- try $ recovering retryPolicyDefault testHandlers $ const $ do+ final <- try $ recovering' retryPolicyDefault testHandlers $ const $ do maskingState' <- EX.getMaskingState maskingState' @?= maskingState fail "Retrying..."@@ -248,7 +270,7 @@ maskingState @?= EX.MaskedInterruptible return shouldRetry ]- final <- try $ recovering retryPolicyDefault checkMaskingStateHandlers $ const $ fail "Retrying..."+ final <- try $ recovering' retryPolicyDefault checkMaskingStateHandlers $ const $ fail "Retrying..." assertBool ("Expected EX.IOException but didn't get one") (isLeft (final :: Either EX.IOException ()))@@ -304,12 +326,19 @@ ------------------------------------------------------------------------------- quadraticDelayTests :: TestTree-quadraticDelayTests = testGroup "quadratic delay"+quadraticDelayTests = quadraticDelayTestsWith recovering+++quadraticDelayTestsWith+ :: Monad m+ => (RetryPolicyM m -> [RetryStatus -> Handler IO Bool] -> (a -> IO b) -> IO ())+ -> TestTree+quadraticDelayTestsWith recovering' = 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+ res <- liftIO $ try $ recovering' (exponentialBackoff timeout <> limitRetries retries) [const $ Handler (\(_::SomeException) -> return True)] (const $ throwM (userError "booo"))@@ -389,68 +418,68 @@ () ] ]- 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, ()))+retryingTest+ :: (RetryStatus -> RetryPolicyM IO -> p -> (RetryStatus -> IO ()) -> IO ())+ -> p+ -> IO ()+retryingTest resumableOp isRetryNeeded = do+ counterRef <- newIORef (0 :: Int) - let policy = limitRetries 2- let nextStatus = nextStatusUsingPolicy policy+ let go policy status = do+ atomicWriteIORef counterRef 0+ resumableOp+ status+ policy+ isRetryNeeded+ (const $ atomicModifyIORef' counterRef $ \n -> (1 + n, ())) - go policy defaultRetryStatus- (3 @=?) =<< readIORef counterRef+ let policy = limitRetries 2+ let nextStatus = nextStatusUsingPolicy policy - go policy =<< nextStatus defaultRetryStatus- (2 @=?) =<< readIORef counterRef+ go policy defaultRetryStatus+ (3 @=?) =<< readIORef counterRef - go policy =<< nextStatus =<< nextStatus defaultRetryStatus- (1 @=?) =<< readIORef counterRef+ go policy =<< nextStatus defaultRetryStatus+ (2 @=?) =<< readIORef counterRef - recoveringTest- :: (RetryStatus -> RetryPolicyM IO -> handlers -> (RetryStatus -> IO ()) -> IO ())- -> handlers- -> IO ()- recoveringTest resumableOp handlers = do- counterRef <- newIORef (0 :: Int)+ go policy =<< nextStatus =<< nextStatus defaultRetryStatus+ (1 @=?) =<< readIORef counterRef - let go policy status = do- action <- do- mkFailUntilIO- (\_ -> atomicModifyIORef' counterRef $ \n -> (1 + n, False))- Custom1- try $ resumableOp status policy handlers action+recoveringTest+ :: (RetryStatus -> RetryPolicyM IO -> handlers -> (RetryStatus -> IO ()) -> IO ())+ -> handlers+ -> IO ()+recoveringTest resumableOp handlers = do+ counterRef <- newIORef (0 :: Int) - let policy = limitRetries 2- let nextStatus = nextStatusUsingPolicy policy+ let go policy status = do+ action <- do+ mkFailUntilIO+ (\_ -> atomicModifyIORef' counterRef $ \n -> (1 + n, False))+ Custom1+ try $ resumableOp status policy handlers action - do- atomicWriteIORef counterRef 0- res <- go policy defaultRetryStatus- res @?= Left Custom1- (3 @=?) =<< readIORef counterRef+ let policy = limitRetries 2+ let nextStatus = nextStatusUsingPolicy policy - do- atomicWriteIORef counterRef 0- res <- go policy =<< nextStatus defaultRetryStatus- res @?= Left Custom1- (2 @=?) =<< readIORef counterRef+ do+ atomicWriteIORef counterRef 0+ res <- go policy defaultRetryStatus+ res @?= Left Custom1+ (3 @=?) =<< readIORef counterRef - do- atomicWriteIORef counterRef 0- res <- go policy =<< nextStatus =<< nextStatus defaultRetryStatus- res @?= Left Custom1- (1 @=?) =<< 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 -------------------------------------------------------------------------------
+ test/Tests/UnliftIO/Retry.hs view
@@ -0,0 +1,55 @@+module Tests.UnliftIO.Retry+ ( tests+ ) where++-------------------------------------------------------------------------------+import Test.Tasty+import Test.Tasty.HUnit (testCase)+-------------------------------------------------------------------------------+import UnliftIO.Retry+import Tests.Control.Retry hiding (tests)+-------------------------------------------------------------------------------+++tests :: TestTree+tests = testGroup "UnliftIO.Retry"+ [ recoveringTests+ , maskingStateTests+ , quadraticDelayTests+ , resumableTests+ ]+++-------------------------------------------------------------------------------+recoveringTests :: TestTree+recoveringTests = recoveringTestsWith recovering+++-------------------------------------------------------------------------------+maskingStateTests :: TestTree+maskingStateTests = maskingStateTestsWith recovering+++-------------------------------------------------------------------------------+quadraticDelayTests :: TestTree+quadraticDelayTests = quadraticDelayTestsWith recovering+++-------------------------------------------------------------------------------+resumableTests :: TestTree+resumableTests = testGroup "resumable"+ [ 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)+ ()+ ]+ ]