├── .gitignore ├── .travis.yml ├── LICENSE ├── README.md ├── Setup.hs ├── changelog.md ├── retry.cabal ├── src ├── Control │ └── Retry.hs └── UnliftIO │ └── Retry.hs ├── stack.yaml └── test ├── Main.hs └── Tests ├── Control └── Retry.hs └── UnliftIO └── Retry.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *.csv 2 | *.o 3 | *.hi 4 | dist 5 | cabal-dev 6 | *DS* 7 | *.swp 8 | TAGS 9 | .stack-work 10 | stack.yaml.lock -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # GHC depends on GMP. You can add other dependencies here as well. 8 | addons: 9 | apt: 10 | packages: 11 | - libgmp-dev 12 | 13 | # The different configurations we want to test. You could also do things like 14 | # change flags or use --stack-yaml to point to a different file. 15 | matrix: 16 | include: 17 | env: 18 | - ARGS="--resolver=lts-15" 19 | - ARGS="--resolver=lts-16" 20 | - ARGS="--resolver=lts-17" 21 | # latest LTS at the time 22 | - ARGS="--resolver=lts" 23 | - ARGS="--resolver=nightly" 24 | allowed_failures: 25 | - ARGS="--resolver=nightly" 26 | 27 | before_install: 28 | # Download and unpack the stack executable 29 | - mkdir -p ~/.local/bin 30 | - export PATH=$HOME/.local/bin:$PATH 31 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 32 | 33 | # This line does all of the work: installs GHC if necessary, build the library, 34 | # executables, and test suites, and runs the test suites. --no-terminal works 35 | # around some quirks in Travis's terminal implementation. 36 | script: 37 | - travis_retry stack $ARGS setup 38 | - stack $ARGS test --no-terminal --haddock --no-haddock-deps 39 | - stack $ARGS bench 40 | - stack $ARGS build 41 | - stack $ARGS sdist 42 | 43 | # Caching so the next build will be fast too. 44 | cache: 45 | directories: 46 | - $HOME/.stack 47 | - .stack-work 48 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013, Ozgun Ataman 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ozgun Ataman nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # README [![Build Status](https://travis-ci.org/Soostone/retry.svg?branch=master)](https://travis-ci.org/Soostone/retry) [![Coverage Status](https://coveralls.io/repos/Soostone/retry/badge.png?branch=master)](https://coveralls.io/r/Soostone/retry?branch=master) 2 | 3 | retry - combinators for monadic actions that may fail 4 | 5 | ## About 6 | 7 | Monadic action combinators that add delayed-retry functionality, 8 | potentially with exponential-backoff, to arbitrary actions. 9 | 10 | The main purpose of this package is to make it easy to work reliably 11 | with IO and similar actions that often fail. Common examples are 12 | database queries and large file uploads. 13 | 14 | ## Documentation 15 | 16 | Please see haddocks for documentation. 17 | 18 | ## Changes 19 | 20 | See [https://github.com/Soostone/retry/blob/master/changelog.md](changelog.md). 21 | 22 | ## Author 23 | 24 | Ozgun Ataman, Soostone Inc 25 | 26 | ## Contributors 27 | 28 | Contributors, please list yourself here. 29 | 30 | - Mitsutoshi Aoe (@maoe) 31 | - John Wiegley 32 | - Michael Snoyman 33 | - Michael Xavier 34 | - Toralf Wittner 35 | - Marco Zocca (@ocramz) 36 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | 0.9.3.1 2 | * Resolve test warnings [PR 83](https://github.com/Soostone/retry/pull/83) 3 | 4 | 5 | 0.9.3.0 6 | * Add `UnliftIO.Retry` [PR 81](https://github.com/Soostone/retry/pull/81) 7 | 8 | 0.9.2.1 9 | * Use explicit import for `lift` which allows for mtl-2.3 compatibility [PR 80](https://github.com/Soostone/retry/pull/80) 10 | 11 | 0.9.2.0 12 | * Add `retryOnError` [PR 44](https://github.com/Soostone/retry/pull/44) 13 | 14 | 0.9.1.0 15 | * Add resumable retry/recover variants: 16 | * `resumeRetrying` 17 | * `resumeRetryingDynamic` 18 | * `resumeRecovering` 19 | * `resumeRecoveringDynamic` 20 | * `resumeRecoverAll` 21 | 22 | 0.9.0.0 23 | * Replace several uses of RetryPolicy type alias with RetryPolicyM m for better 24 | GHC 9 compat. 25 | 26 | 0.8.1.2 27 | * Set lower bound on base to >= 4.8 28 | 29 | 0.8.1.1 30 | * Loosen upper bounds 31 | 32 | 0.8.1.0 33 | * Add `retryingDynamic` and `recoveringDynamic`. [PR 65](https://github.com/Soostone/retry/pull/65) 34 | 35 | 0.8.0.2 36 | * Update docs for default retry policy. [PR 64](https://github.com/Soostone/retry/pull/64) 37 | 38 | 0.8.0.1 39 | * Loosen upper bounds 40 | 41 | 0.8.0.0 42 | * Remove dependency on data-default-class 43 | 44 | 0.7.7.0 45 | * Add `natTransformRetryPolicy` 46 | 47 | 0.7.6.3 48 | * Documentation fix on `recoverAll` 49 | 50 | 0.7.6.2 51 | * Loosen bounds on exceptions again. 52 | 53 | 0.7.6.1 54 | * Loosen bounds on exceptions. 55 | 56 | 0.7.6.0 57 | * Clarify the semantics of `limitRetriesByDelay`. 58 | * Add `limitRetriesByCumulativeDelay` 59 | 60 | 0.7.5.1 61 | * Improve haddocks for fullJitterBackoff. 62 | 63 | 0.7.5.0 64 | * Add Semigroup instance when the Semigroup class is available through base. 65 | 66 | 0.7.4.3 67 | * Loosen dependency upper bounds. 68 | 69 | 0.7.5 70 | * Add skipAsyncExceptions helper function 71 | 72 | 0.7.4.2 73 | * Loosen HUnit dependency for tests. 74 | 75 | 0.7.4.1 76 | * Loosen QuickCheck dependency for tests. 77 | 78 | 0.7.4 79 | * Widen transformers dependency 80 | 81 | 0.7.3 82 | * Widen ghc-prim dependency for GHC 8 83 | 84 | 0.7.2 85 | * Fix premature integer overflow error thanks to Mitsutoshi Aoe 86 | 87 | 0.7.1 88 | * Various documentation updates. 89 | * Add stepping combinator for manual retries. 90 | * Add applyPolicy and applyAndDelay 91 | * Add Read instance for RetryStatus 92 | * Fix logic bug in rsPreviousDelay in first retry 93 | 94 | 0.7.0.1 95 | * Officially drop support for GHC < 7.6 due to usage of Generics. 96 | 97 | 0.7 98 | * RetryPolicy has become RetryPolicyM, allowing for policy logic to 99 | consult the monad context. 100 | * RetryPolicyM now takes a RetryStatus value. Use the function 101 | rsIterNum to preserve existing behavior of RetryPolicy only 102 | receiving the number. 103 | * The monadic action now gets the RetryStatus on each try. Use const 104 | if you don't need it. 105 | * recoverAll explicitly does not handle the standard async 106 | exceptions. Users are encouraged to do the same when using 107 | recovering, as catching async exceptions can be hazardous. 108 | * We no longer re-export (<>) from Monoid. 109 | * Utility functions simulatePolicy and simulatePolicyPP have been 110 | added which help predict how a policy will behave on each iteration. 111 | 112 | 0.6 113 | 114 | * Actions are now retried in the original masking state, while 115 | handlers continue to run in `MaskedInterruptible` (@maoe) 116 | * Added several tests confirming exception hierarchy semantics under 117 | `recovering` (@ozataman) 118 | 119 | 0.5 120 | 121 | * Mitsutoshi's backoff work inspired a complete redo of the 122 | RetryPolicy interface, replacing it with a monoidal RetryPolicy. The 123 | result is a much thinner API that actually provides much more power 124 | to the end user. 125 | * Now using microseconds in all premade policies. PLEASE TAKE CARE 126 | WHEN UPGRADING. It was a bad idea to use miliseconds and deviate 127 | from norms in the first place. 128 | 129 | 0.4 130 | 131 | * Transitioned to using Edward Kmett's exceptions package instead of 132 | monad-control. Use 0.3 series if you still need monad-control 133 | support. 134 | 135 | 0.3 136 | 137 | Thanks to John Wiegley and Michael Snoyman for their contributions: 138 | 139 | * Now using monad-control instead of MonadCatchIO, which is widely 140 | agreed to be broken. 141 | * Now using transformers instead of mtl, which was a broader than 142 | needed dependency. 143 | -------------------------------------------------------------------------------- /retry.cabal: -------------------------------------------------------------------------------- 1 | name: retry 2 | 3 | description: 4 | 5 | This package exposes combinators that can wrap arbitrary 6 | monadic actions. They run the action and potentially retry 7 | running it with some configurable delay for a configurable 8 | number of times. 9 | 10 | The purpose is to make it easier to work with IO and 11 | especially network IO actions that often experience temporary 12 | failure and warrant retrying of the original action. For 13 | example, a database query may time out for a while, in which 14 | case we should hang back for a bit and retry the query instead 15 | of simply raising an exception. 16 | 17 | version: 0.9.3.1 18 | synopsis: Retry combinators for monadic actions that may fail 19 | license: BSD3 20 | license-file: LICENSE 21 | author: Ozgun Ataman 22 | maintainer: ozgun.ataman@soostone.com 23 | copyright: Ozgun Ataman, Soostone Inc 24 | category: Control 25 | build-type: Simple 26 | cabal-version: >=1.10 27 | homepage: http://github.com/Soostone/retry 28 | extra-source-files: 29 | README.md 30 | changelog.md 31 | 32 | flag lib-Werror 33 | default: False 34 | manual: True 35 | 36 | library 37 | exposed-modules: Control.Retry 38 | UnliftIO.Retry 39 | build-depends: 40 | base >= 4.8 && < 5 41 | , exceptions >= 0.5 42 | , ghc-prim 43 | , random >= 1 44 | , transformers 45 | , mtl 46 | , mtl-compat 47 | , unliftio-core >= 0.1.0.0 48 | hs-source-dirs: src 49 | default-language: Haskell2010 50 | 51 | if flag(lib-Werror) 52 | ghc-options: -Werror 53 | 54 | ghc-options: -Wall 55 | 56 | 57 | test-suite test 58 | type: exitcode-stdio-1.0 59 | main-is: Main.hs 60 | hs-source-dirs: test,src 61 | ghc-options: -threaded 62 | other-modules: Control.Retry 63 | UnliftIO.Retry 64 | Tests.Control.Retry 65 | Tests.UnliftIO.Retry 66 | build-depends: 67 | base ==4.* 68 | , exceptions 69 | , transformers 70 | , random 71 | , time 72 | , HUnit >= 1.2.5.2 73 | , tasty 74 | , tasty-hunit 75 | , tasty-hedgehog 76 | , hedgehog >= 1.0 77 | , stm 78 | , ghc-prim 79 | , mtl 80 | , mtl-compat 81 | , unliftio-core 82 | default-language: Haskell2010 83 | 84 | if flag(lib-Werror) 85 | ghc-options: -Werror 86 | 87 | ghc-options: -Wall 88 | 89 | source-repository head 90 | type: git 91 | location: git://github.com/Soostone/retry.git 92 | -------------------------------------------------------------------------------- /src/Control/Retry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE MagicHash #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TupleSections #-} 8 | {-# LANGUAGE UnboxedTuples #-} 9 | {-# LANGUAGE ViewPatterns #-} 10 | 11 | ----------------------------------------------------------------------------- 12 | -- | 13 | -- Module : Control.Retry 14 | -- Copyright : Ozgun Ataman 15 | -- License : BSD3 16 | -- 17 | -- Maintainer : Ozgun Ataman 18 | -- Stability : provisional 19 | -- 20 | -- This module exposes combinators that can wrap arbitrary monadic 21 | -- actions. They run the action and potentially retry running it with 22 | -- some configurable delay for a configurable number of times. 23 | -- 24 | -- The express purpose of this library is to make it easier to work 25 | -- with IO and especially network IO actions that often experience 26 | -- temporary failure that warrant retrying of the original action. For 27 | -- example, a database query may time out for a while, in which case 28 | -- we should delay a bit and retry the query. 29 | ---------------------------------------------------------------------------- 30 | 31 | 32 | module Control.Retry 33 | ( 34 | -- * Types and Operations 35 | RetryPolicyM (..) 36 | , RetryPolicy 37 | , retryPolicy 38 | , retryPolicyDefault 39 | , natTransformRetryPolicy 40 | , RetryAction (..) 41 | , toRetryAction 42 | , RetryStatus (..) 43 | , defaultRetryStatus 44 | , applyPolicy 45 | , applyAndDelay 46 | 47 | 48 | -- ** Lenses for 'RetryStatus' 49 | , rsIterNumberL 50 | , rsCumulativeDelayL 51 | , rsPreviousDelayL 52 | 53 | -- * Applying Retry Policies 54 | , retrying 55 | , retryingDynamic 56 | , recovering 57 | , recoveringDynamic 58 | , stepping 59 | , recoverAll 60 | , skipAsyncExceptions 61 | , logRetries 62 | , defaultLogMsg 63 | , retryOnError 64 | -- ** Resumable variants 65 | , resumeRetrying 66 | , resumeRetryingDynamic 67 | , resumeRecovering 68 | , resumeRecoveringDynamic 69 | , resumeRecoverAll 70 | 71 | -- * Retry Policies 72 | , constantDelay 73 | , exponentialBackoff 74 | , fullJitterBackoff 75 | , fibonacciBackoff 76 | , limitRetries 77 | 78 | -- * Policy Transformers 79 | , limitRetriesByDelay 80 | , limitRetriesByCumulativeDelay 81 | , capDelay 82 | 83 | -- * Development Helpers 84 | , simulatePolicy 85 | , simulatePolicyPP 86 | ) where 87 | 88 | ------------------------------------------------------------------------------- 89 | import Control.Applicative 90 | import Control.Concurrent 91 | #if MIN_VERSION_base(4, 7, 0) 92 | import Control.Exception (AsyncException, SomeAsyncException) 93 | #else 94 | import Control.Exception (AsyncException) 95 | #endif 96 | import Control.Monad 97 | import Control.Monad.Catch 98 | import Control.Monad.Except 99 | import Control.Monad.IO.Class as MIO 100 | import Control.Monad.Trans.Class as TC 101 | import Control.Monad.Trans.Maybe 102 | import Control.Monad.Trans.State 103 | import Data.List (foldl') 104 | import Data.Maybe 105 | import GHC.Generics 106 | import GHC.Prim 107 | import GHC.Types (Int(I#)) 108 | import System.Random 109 | # if MIN_VERSION_base(4, 9, 0) 110 | import Data.Semigroup 111 | # else 112 | import Data.Monoid 113 | # endif 114 | import Prelude 115 | ------------------------------------------------------------------------------- 116 | 117 | 118 | ------------------------------------------------------------------------------- 119 | -- | A 'RetryPolicyM' is a function that takes an 'RetryStatus' and 120 | -- possibly returns a delay in microseconds. Iteration numbers start 121 | -- at zero and increase by one on each retry. A *Nothing* return value from 122 | -- the function implies we have reached the retry limit. 123 | -- 124 | -- Please note that 'RetryPolicyM' is a 'Monoid'. You can collapse 125 | -- multiple strategies into one using 'mappend' or '<>'. The semantics 126 | -- of this combination are as follows: 127 | -- 128 | -- 1. If either policy returns 'Nothing', the combined policy returns 129 | -- 'Nothing'. This can be used to @inhibit@ after a number of retries, 130 | -- for example. 131 | -- 132 | -- 2. If both policies return a delay, the larger delay will be used. 133 | -- This is quite natural when combining multiple policies to achieve a 134 | -- certain effect. 135 | -- 136 | -- Example: 137 | -- 138 | -- One can easily define an exponential backoff policy with a limited 139 | -- number of retries: 140 | -- 141 | -- >> limitedBackoff = exponentialBackoff 50000 <> limitRetries 5 142 | -- 143 | -- Naturally, 'mempty' will retry immediately (delay 0) for an 144 | -- unlimited number of retries, forming the identity for the 'Monoid'. 145 | -- 146 | -- The default retry policy 'retryPolicyDefault' implements a constant 50ms delay, up to 5 times: 147 | -- 148 | -- >> retryPolicyDefault = constantDelay 50000 <> limitRetries 5 149 | -- 150 | -- For anything more complex, just define your own 'RetryPolicyM': 151 | -- 152 | -- >> myPolicy = retryPolicy $ \ rs -> if rsIterNumber rs > 10 then Just 1000 else Just 10000 153 | -- 154 | -- Since 0.7. 155 | newtype RetryPolicyM m = RetryPolicyM { getRetryPolicyM :: RetryStatus -> m (Maybe Int) } 156 | 157 | 158 | -- | Simplified 'RetryPolicyM' without any use of the monadic context in 159 | -- determining policy. Mostly maintains backwards compatitibility with 160 | -- type signatures pre-0.7. 161 | type RetryPolicy = forall m . Monad m => RetryPolicyM m 162 | 163 | -- | Default retry policy 164 | retryPolicyDefault :: (Monad m) => RetryPolicyM m 165 | retryPolicyDefault = constantDelay 50000 <> limitRetries 5 166 | 167 | 168 | -- Base 4.9.0 adds a Data.Semigroup module. This has fewer 169 | -- dependencies than the semigroups package, so we're using base's 170 | -- only if its available. 171 | # if MIN_VERSION_base(4, 9, 0) 172 | instance Monad m => Semigroup (RetryPolicyM m) where 173 | (RetryPolicyM a) <> (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do 174 | a' <- MaybeT $ a n 175 | b' <- MaybeT $ b n 176 | return $! max a' b' 177 | 178 | 179 | instance Monad m => Monoid (RetryPolicyM m) where 180 | mempty = retryPolicy $ const (Just 0) 181 | mappend = (<>) 182 | # else 183 | instance Monad m => Monoid (RetryPolicyM m) where 184 | mempty = retryPolicy $ const (Just 0) 185 | (RetryPolicyM a) `mappend` (RetryPolicyM b) = RetryPolicyM $ \ n -> runMaybeT $ do 186 | a' <- MaybeT $ a n 187 | b' <- MaybeT $ b n 188 | return $! max a' b' 189 | #endif 190 | 191 | 192 | ------------------------------------------------------------------------------- 193 | -- | Applies a natural transformation to a policy to run a RetryPolicy 194 | -- meant for the monad @m@ in the monad @n@ provided a transformation 195 | -- from @m@ to @n@ is available. A common case is if you have a pure 196 | -- policy, @RetryPolicyM Identity@ and want to use it to govern an 197 | -- @IO@ computation you could write: 198 | -- 199 | -- @ 200 | -- purePolicyInIO :: RetryPolicyM Identity -> RetryPolicyM IO 201 | -- purePolicyInIO = natTransformRetryPolicy (pure . runIdentity) 202 | -- @ 203 | natTransformRetryPolicy :: (forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n 204 | natTransformRetryPolicy f (RetryPolicyM p) = RetryPolicyM $ \stat -> f (p stat) 205 | 206 | 207 | -- | Modify the delay of a RetryPolicy. 208 | -- Does not change whether or not a retry is performed. 209 | modifyRetryPolicyDelay :: Functor m => (Int -> Int) -> RetryPolicyM m -> RetryPolicyM m 210 | modifyRetryPolicyDelay f (RetryPolicyM p) = RetryPolicyM $ \stat -> fmap f <$> p stat 211 | 212 | 213 | ------------------------------------------------------------------------------- 214 | -- | How to handle a failed action. 215 | data RetryAction 216 | = DontRetry 217 | -- ^ Don't retry (regardless of what the 'RetryPolicy' says). 218 | | ConsultPolicy 219 | -- ^ Retry if the 'RetryPolicy' says so, with the delay specified by the policy. 220 | | ConsultPolicyOverrideDelay Int 221 | -- ^ Retry if the 'RetryPolicy' says so, but override the policy's delay (number of microseconds). 222 | deriving (Read, Show, Eq, Generic) 223 | 224 | 225 | -- | Convert a boolean answer to the question "Should we retry?" into 226 | -- a 'RetryAction'. 227 | toRetryAction :: Bool -> RetryAction 228 | toRetryAction False = DontRetry 229 | toRetryAction True = ConsultPolicy 230 | 231 | ------------------------------------------------------------------------------- 232 | -- | Datatype with stats about retries made thus far. 233 | data RetryStatus = RetryStatus 234 | { rsIterNumber :: !Int -- ^ Iteration number, where 0 is the first try 235 | , rsCumulativeDelay :: !Int -- ^ Delay incurred so far from retries in microseconds 236 | , rsPreviousDelay :: !(Maybe Int) -- ^ Latest attempt's delay. Will always be Nothing on first run. 237 | } deriving (Read, Show, Eq, Generic) 238 | 239 | 240 | ------------------------------------------------------------------------------- 241 | -- | Initial, default retry status. Use fields or lenses to update. 242 | defaultRetryStatus :: RetryStatus 243 | defaultRetryStatus = RetryStatus 0 0 Nothing 244 | 245 | ------------------------------------------------------------------------------- 246 | rsIterNumberL :: Lens' RetryStatus Int 247 | rsIterNumberL = lens rsIterNumber (\rs x -> rs { rsIterNumber = x }) 248 | {-# INLINE rsIterNumberL #-} 249 | 250 | 251 | ------------------------------------------------------------------------------- 252 | rsCumulativeDelayL :: Lens' RetryStatus Int 253 | rsCumulativeDelayL = lens rsCumulativeDelay (\rs x -> rs { rsCumulativeDelay = x }) 254 | {-# INLINE rsCumulativeDelayL #-} 255 | 256 | 257 | ------------------------------------------------------------------------------- 258 | rsPreviousDelayL :: Lens' RetryStatus (Maybe Int) 259 | rsPreviousDelayL = lens rsPreviousDelay (\rs x -> rs { rsPreviousDelay = x }) 260 | {-# INLINE rsPreviousDelayL #-} 261 | 262 | 263 | 264 | ------------------------------------------------------------------------------- 265 | -- | Apply policy on status to see what the decision would be. 266 | -- 'Nothing' implies no retry, 'Just' returns updated status. 267 | applyPolicy 268 | :: Monad m 269 | => RetryPolicyM m 270 | -> RetryStatus 271 | -> m (Maybe RetryStatus) 272 | applyPolicy (RetryPolicyM policy) s = do 273 | res <- policy s 274 | case res of 275 | Just delay -> return $! Just $! RetryStatus 276 | { rsIterNumber = rsIterNumber s + 1 277 | , rsCumulativeDelay = rsCumulativeDelay s `boundedPlus` delay 278 | , rsPreviousDelay = Just delay } 279 | Nothing -> return Nothing 280 | 281 | 282 | ------------------------------------------------------------------------------- 283 | -- | Apply policy and delay by its amount if it results in a retry. 284 | -- Return updated status. 285 | applyAndDelay 286 | :: MIO.MonadIO m 287 | => RetryPolicyM m 288 | -> RetryStatus 289 | -> m (Maybe RetryStatus) 290 | applyAndDelay policy s = do 291 | chk <- applyPolicy policy s 292 | case chk of 293 | Just rs -> do 294 | case rsPreviousDelay rs of 295 | Nothing -> return () 296 | Just delay -> liftIO $ threadDelay delay 297 | return (Just rs) 298 | Nothing -> return Nothing 299 | 300 | 301 | 302 | ------------------------------------------------------------------------------- 303 | -- | Helper for making simplified policies that don't use the monadic 304 | -- context. 305 | retryPolicy :: (Monad m) => (RetryStatus -> Maybe Int) -> RetryPolicyM m 306 | retryPolicy f = RetryPolicyM $ \ s -> return (f s) 307 | 308 | 309 | ------------------------------------------------------------------------------- 310 | -- | Retry immediately, but only up to @n@ times. 311 | limitRetries 312 | :: Int 313 | -- ^ Maximum number of retries. 314 | -> RetryPolicy 315 | limitRetries i = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> if n >= i then Nothing else Just 0 316 | 317 | 318 | ------------------------------------------------------------------------------- 319 | -- | Add an upperbound to a policy such that once the given time-delay 320 | -- amount *per try* has been reached or exceeded, the policy will stop 321 | -- retrying and fail. If you need to stop retrying once *cumulative* 322 | -- delay reaches a time-delay amount, use 323 | -- 'limitRetriesByCumulativeDelay' 324 | limitRetriesByDelay 325 | :: Monad m 326 | => Int 327 | -- ^ Time-delay limit in microseconds. 328 | -> RetryPolicyM m 329 | -> RetryPolicyM m 330 | limitRetriesByDelay i p = RetryPolicyM $ \ n -> 331 | (>>= limit) `fmap` getRetryPolicyM p n 332 | where 333 | limit delay = if delay >= i then Nothing else Just delay 334 | 335 | 336 | ------------------------------------------------------------------------------- 337 | -- | Add an upperbound to a policy such that once the cumulative delay 338 | -- over all retries has reached or exceeded the given limit, the 339 | -- policy will stop retrying and fail. 340 | limitRetriesByCumulativeDelay 341 | :: Monad m 342 | => Int 343 | -- ^ Time-delay limit in microseconds. 344 | -> RetryPolicyM m 345 | -> RetryPolicyM m 346 | limitRetriesByCumulativeDelay cumulativeLimit p = RetryPolicyM $ \ stat -> 347 | (>>= limit stat) `fmap` getRetryPolicyM p stat 348 | where 349 | limit status curDelay 350 | | rsCumulativeDelay status `boundedPlus` curDelay > cumulativeLimit = Nothing 351 | | otherwise = Just curDelay 352 | 353 | 354 | ------------------------------------------------------------------------------- 355 | -- | Implement a constant delay with unlimited retries. 356 | constantDelay 357 | :: (Monad m) 358 | => Int 359 | -- ^ Base delay in microseconds 360 | -> RetryPolicyM m 361 | constantDelay delay = retryPolicy (const (Just delay)) 362 | 363 | 364 | ------------------------------------------------------------------------------- 365 | -- | Grow delay exponentially each iteration. Each delay will 366 | -- increase by a factor of two. 367 | exponentialBackoff 368 | :: (Monad m) 369 | => Int 370 | -- ^ Base delay in microseconds 371 | -> RetryPolicyM m 372 | exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n } -> 373 | Just $! base `boundedMult` boundedPow 2 n 374 | 375 | ------------------------------------------------------------------------------- 376 | -- | FullJitter exponential backoff as explained in AWS Architecture 377 | -- Blog article. 378 | -- 379 | -- @http:\/\/www.awsarchitectureblog.com\/2015\/03\/backoff.html@ 380 | -- 381 | -- temp = min(cap, base * 2 ** attempt) 382 | -- 383 | -- sleep = temp \/ 2 + random_between(0, temp \/ 2) 384 | fullJitterBackoff 385 | :: (MonadIO m) 386 | => Int 387 | -- ^ Base delay in microseconds 388 | -> RetryPolicyM m 389 | fullJitterBackoff base = RetryPolicyM $ \ RetryStatus { rsIterNumber = n } -> do 390 | let d = (base `boundedMult` boundedPow 2 n) `div` 2 391 | rand <- liftIO $ randomRIO (0, d) 392 | return $! Just $! d `boundedPlus` rand 393 | 394 | 395 | ------------------------------------------------------------------------------- 396 | -- | Implement Fibonacci backoff. 397 | fibonacciBackoff 398 | :: (Monad m) 399 | => Int 400 | -- ^ Base delay in microseconds 401 | -> RetryPolicyM m 402 | fibonacciBackoff base = retryPolicy $ \RetryStatus { rsIterNumber = n } -> 403 | Just $ fib (n + 1) (0, base) 404 | where 405 | fib 0 (a, _) = a 406 | fib !m (!a, !b) = fib (m-1) (b, a `boundedPlus` b) 407 | 408 | 409 | ------------------------------------------------------------------------------- 410 | -- | Set a time-upperbound for any delays that may be directed by the 411 | -- given policy. This function does not terminate the retrying. The policy 412 | -- `capDelay maxDelay (exponentialBackoff n)` will never stop retrying. It 413 | -- will reach a state where it retries forever with a delay of `maxDelay` 414 | -- between each one. To get termination you need to use one of the 415 | -- 'limitRetries' function variants. 416 | capDelay 417 | :: Monad m 418 | => Int 419 | -- ^ A maximum delay in microseconds 420 | -> RetryPolicyM m 421 | -> RetryPolicyM m 422 | capDelay limit p = RetryPolicyM $ \ n -> 423 | fmap (min limit) `fmap` getRetryPolicyM p n 424 | 425 | 426 | ------------------------------------------------------------------------------- 427 | -- | Retry combinator for actions that don't raise exceptions, but 428 | -- signal in their type the outcome has failed. Examples are the 429 | -- 'Maybe', 'Either' and 'EitherT' monads. 430 | -- 431 | -- Let's write a function that always fails and watch this combinator 432 | -- retry it 5 additional times following the initial run: 433 | -- 434 | -- >>> import Data.Maybe 435 | -- >>> let f _ = putStrLn "Running action" >> return Nothing 436 | -- >>> retrying retryPolicyDefault (const $ return . isNothing) f 437 | -- Running action 438 | -- Running action 439 | -- Running action 440 | -- Running action 441 | -- Running action 442 | -- Running action 443 | -- Nothing 444 | -- 445 | -- Note how the latest failing result is returned after all retries 446 | -- have been exhausted. 447 | retrying :: MonadIO m 448 | => RetryPolicyM m 449 | -> (RetryStatus -> b -> m Bool) 450 | -- ^ An action to check whether the result should be retried. 451 | -- If True, we delay and retry the operation. 452 | -> (RetryStatus -> m b) 453 | -- ^ Action to run 454 | -> m b 455 | retrying = resumeRetrying defaultRetryStatus 456 | 457 | 458 | ------------------------------------------------------------------------------- 459 | -- | A variant of 'retrying' that allows specifying the initial 460 | -- 'RetryStatus' so that the retrying operation may pick up where it left 461 | -- off in regards to its retry policy. 462 | resumeRetrying 463 | :: MonadIO m 464 | => RetryStatus 465 | -> RetryPolicyM m 466 | -> (RetryStatus -> b -> m Bool) 467 | -- ^ An action to check whether the result should be retried. 468 | -- If True, we delay and retry the operation. 469 | -> (RetryStatus -> m b) 470 | -- ^ Action to run 471 | -> m b 472 | resumeRetrying retryStatus policy chk f = 473 | resumeRetryingDynamic 474 | retryStatus 475 | policy 476 | (\rs -> fmap toRetryAction . chk rs) 477 | f 478 | 479 | 480 | ------------------------------------------------------------------------------- 481 | -- | Same as 'retrying', but with the ability to override 482 | -- the delay of the retry policy based on information 483 | -- obtained after initiation. 484 | -- 485 | -- For example, if the action to run is a HTTP request that 486 | -- turns out to fail with a status code 429 ("too many requests"), 487 | -- the response may contain a "Retry-After" HTTP header which 488 | -- specifies the number of seconds 489 | -- the client should wait until performing the next request. 490 | -- This function allows overriding the delay calculated by the given 491 | -- retry policy with the delay extracted from this header value. 492 | -- 493 | -- In other words, given an arbitrary 'RetryPolicyM' @rp@, the 494 | -- following invocation will always delay by 1000 microseconds: 495 | -- 496 | -- > retryingDynamic rp (\_ _ -> return $ ConsultPolicyOverrideDelay 1000) f 497 | -- 498 | -- Note that a 'RetryPolicy's decision to /not/ perform a retry 499 | -- cannot be overridden. Ie. /when/ to /stop/ retrying is always decided 500 | -- by the retry policy, regardless of the returned 'RetryAction' value. 501 | retryingDynamic 502 | :: MonadIO m 503 | => RetryPolicyM m 504 | -> (RetryStatus -> b -> m RetryAction) 505 | -- ^ An action to check whether the result should be retried. 506 | -- The returned 'RetryAction' determines how/if a retry is performed. 507 | -- See documentation on 'RetryAction'. 508 | -> (RetryStatus -> m b) 509 | -- ^ Action to run 510 | -> m b 511 | retryingDynamic = resumeRetryingDynamic defaultRetryStatus 512 | 513 | 514 | ------------------------------------------------------------------------------- 515 | -- | A variant of 'retryingDynamic' that allows specifying the initial 516 | -- 'RetryStatus' so that a retrying operation may pick up where it left off 517 | -- in regards to its retry policy. 518 | resumeRetryingDynamic 519 | :: MonadIO m 520 | => RetryStatus 521 | -> RetryPolicyM m 522 | -> (RetryStatus -> b -> m RetryAction) 523 | -- ^ An action to check whether the result should be retried. 524 | -- The returned 'RetryAction' determines how/if a retry is performed. 525 | -- See documentation on 'RetryAction'. 526 | -> (RetryStatus -> m b) 527 | -- ^ Action to run 528 | -> m b 529 | resumeRetryingDynamic retryStatus policy chk f = go retryStatus 530 | where 531 | go s = do 532 | res <- f s 533 | let consultPolicy policy' = do 534 | rs <- applyAndDelay policy' s 535 | case rs of 536 | Nothing -> return res 537 | Just rs' -> go $! rs' 538 | chk' <- chk s res 539 | case chk' of 540 | DontRetry -> return res 541 | ConsultPolicy -> consultPolicy policy 542 | ConsultPolicyOverrideDelay delay -> 543 | consultPolicy $ modifyRetryPolicyDelay (const delay) policy 544 | 545 | 546 | ------------------------------------------------------------------------------- 547 | -- | Retry ALL exceptions that may be raised. To be used with caution; 548 | -- this matches the exception on 'SomeException'. Note that this 549 | -- handler explicitly does not handle 'AsyncException' nor 550 | -- 'SomeAsyncException' (for versions of base >= 4.7). It is not a 551 | -- good idea to catch async exceptions as it can result in hanging 552 | -- threads and programs. Note that if you just throw an exception to 553 | -- this thread that does not descend from SomeException, recoverAll 554 | -- will not catch it. 555 | -- 556 | -- See how the action below is run once and retried 5 more times 557 | -- before finally failing for good: 558 | -- 559 | -- >>> let f _ = putStrLn "Running action" >> error "this is an error" 560 | -- >>> recoverAll retryPolicyDefault f 561 | -- Running action 562 | -- Running action 563 | -- Running action 564 | -- Running action 565 | -- Running action 566 | -- Running action 567 | -- *** Exception: this is an error 568 | recoverAll 569 | #if MIN_VERSION_exceptions(0, 6, 0) 570 | :: (MonadIO m, MonadMask m) 571 | #else 572 | :: (MonadIO m, MonadCatch m) 573 | #endif 574 | => RetryPolicyM m 575 | -> (RetryStatus -> m a) 576 | -> m a 577 | recoverAll = resumeRecoverAll defaultRetryStatus 578 | 579 | 580 | ------------------------------------------------------------------------------- 581 | -- | A variant of 'recoverAll' that allows specifying the initial 582 | -- 'RetryStatus' so that a recovering operation may pick up where it left 583 | -- off in regards to its retry policy. 584 | resumeRecoverAll 585 | #if MIN_VERSION_exceptions(0, 6, 0) 586 | :: (MonadIO m, MonadMask m) 587 | #else 588 | :: (MonadIO m, MonadCatch m) 589 | #endif 590 | => RetryStatus 591 | -> RetryPolicyM m 592 | -> (RetryStatus -> m a) 593 | -> m a 594 | resumeRecoverAll retryStatus set f = resumeRecovering retryStatus set handlers f 595 | where 596 | handlers = skipAsyncExceptions ++ [h] 597 | h _ = Handler $ \ (_ :: SomeException) -> return True 598 | 599 | 600 | ------------------------------------------------------------------------------- 601 | -- | List of pre-made handlers that will skip retries on 602 | -- 'AsyncException' and 'SomeAsyncException'. Append your handlers to 603 | -- this list as a convenient way to make sure you're not catching 604 | -- async exceptions like user interrupt. 605 | skipAsyncExceptions 606 | :: ( MonadIO m 607 | ) 608 | => [RetryStatus -> Handler m Bool] 609 | skipAsyncExceptions = handlers 610 | where 611 | asyncH _ = Handler $ \ (_ :: AsyncException) -> return False 612 | #if MIN_VERSION_base(4, 7, 0) 613 | someAsyncH _ = Handler $ \(_ :: SomeAsyncException) -> return False 614 | handlers = [asyncH, someAsyncH] 615 | #else 616 | handlers = [asyncH] 617 | #endif 618 | 619 | 620 | ------------------------------------------------------------------------------- 621 | -- | Run an action and recover from a raised exception by potentially 622 | -- retrying the action a number of times. Note that if you're going to 623 | -- use a handler for 'SomeException', you should add explicit cases 624 | -- *earlier* in the list of handlers to reject 'AsyncException' and 625 | -- 'SomeAsyncException', as catching these can cause thread and 626 | -- program hangs. 'recoverAll' already does this for you so if you 627 | -- just plan on catching 'SomeException', you may as well use 628 | -- 'recoverAll' 629 | recovering 630 | #if MIN_VERSION_exceptions(0, 6, 0) 631 | :: (MonadIO m, MonadMask m) 632 | #else 633 | :: (MonadIO m, MonadCatch m) 634 | #endif 635 | => RetryPolicyM m 636 | -- ^ Just use 'retryPolicyDefault' for default settings 637 | -> [RetryStatus -> Handler m Bool] 638 | -- ^ Should a given exception be retried? Action will be 639 | -- retried if this returns True *and* the policy allows it. 640 | -- This action will be consulted first even if the policy 641 | -- later blocks it. 642 | -> (RetryStatus -> m a) 643 | -- ^ Action to perform 644 | -> m a 645 | recovering = resumeRecovering defaultRetryStatus 646 | 647 | 648 | ------------------------------------------------------------------------------- 649 | -- | A variant of 'recovering' that allows specifying the initial 650 | -- 'RetryStatus' so that a recovering operation may pick up where it left 651 | -- off in regards to its retry policy. 652 | resumeRecovering 653 | #if MIN_VERSION_exceptions(0, 6, 0) 654 | :: (MonadIO m, MonadMask m) 655 | #else 656 | :: (MonadIO m, MonadCatch m) 657 | #endif 658 | => RetryStatus 659 | -> RetryPolicyM m 660 | -- ^ Just use 'retryPolicyDefault' for default settings 661 | -> [(RetryStatus -> Handler m Bool)] 662 | -- ^ Should a given exception be retried? Action will be 663 | -- retried if this returns True *and* the policy allows it. 664 | -- This action will be consulted first even if the policy 665 | -- later blocks it. 666 | -> (RetryStatus -> m a) 667 | -- ^ Action to perform 668 | -> m a 669 | resumeRecovering retryStatus policy hs f = 670 | resumeRecoveringDynamic retryStatus policy hs' f 671 | where 672 | hs' = map (fmap toRetryAction .) hs 673 | 674 | 675 | ------------------------------------------------------------------------------- 676 | -- | The difference between this and 'recovering' is the same as 677 | -- the difference between 'retryingDynamic' and 'retrying'. 678 | recoveringDynamic 679 | #if MIN_VERSION_exceptions(0, 6, 0) 680 | :: (MonadIO m, MonadMask m) 681 | #else 682 | :: (MonadIO m, MonadCatch m) 683 | #endif 684 | => RetryPolicyM m 685 | -- ^ Just use 'retryPolicyDefault' for default settings 686 | -> [RetryStatus -> Handler m RetryAction] 687 | -- ^ Should a given exception be retried? Action will be 688 | -- retried if this returns either 'ConsultPolicy' or 689 | -- 'ConsultPolicyOverrideDelay' *and* the policy allows it. 690 | -- This action will be consulted first even if the policy 691 | -- later blocks it. 692 | -> (RetryStatus -> m a) 693 | -- ^ Action to perform 694 | -> m a 695 | recoveringDynamic = resumeRecoveringDynamic defaultRetryStatus 696 | 697 | 698 | ------------------------------------------------------------------------------- 699 | -- | A variant of 'recoveringDynamic' that allows specifying the initial 700 | -- 'RetryStatus' so that a recovering operation may pick up where it left 701 | -- off in regards to its retry policy. 702 | resumeRecoveringDynamic 703 | #if MIN_VERSION_exceptions(0, 6, 0) 704 | :: (MonadIO m, MonadMask m) 705 | #else 706 | :: (MonadIO m, MonadCatch m) 707 | #endif 708 | => RetryStatus 709 | -> RetryPolicyM m 710 | -- ^ Just use 'retryPolicyDefault' for default settings 711 | -> [(RetryStatus -> Handler m RetryAction)] 712 | -- ^ Should a given exception be retried? Action will be 713 | -- retried if this returns either 'ConsultPolicy' or 714 | -- 'ConsultPolicyOverrideDelay' *and* the policy allows it. 715 | -- This action will be consulted first even if the policy 716 | -- later blocks it. 717 | -> (RetryStatus -> m a) 718 | -- ^ Action to perform 719 | -> m a 720 | resumeRecoveringDynamic retryStatus policy hs f = mask $ \restore -> go restore retryStatus 721 | where 722 | go restore = loop 723 | where 724 | loop s = do 725 | r <- try $ restore (f s) 726 | case r of 727 | Right x -> return x 728 | Left e -> recover (e :: SomeException) hs 729 | where 730 | recover e [] = throwM e 731 | recover e ((($ s) -> Handler h) : hs') 732 | | Just e' <- fromException e = do 733 | let consultPolicy policy' = do 734 | rs <- applyAndDelay policy' s 735 | case rs of 736 | Just rs' -> loop $! rs' 737 | Nothing -> throwM e' 738 | chk <- h e' 739 | case chk of 740 | DontRetry -> throwM e' 741 | ConsultPolicy -> consultPolicy policy 742 | ConsultPolicyOverrideDelay delay -> 743 | consultPolicy $ modifyRetryPolicyDelay (const delay) policy 744 | | otherwise = recover e hs' 745 | 746 | 747 | ------------------------------------------------------------------------------- 748 | -- | A version of 'recovering' that tries to run the action only a 749 | -- single time. The control will return immediately upon both success 750 | -- and failure. Useful for implementing retry logic in distributed 751 | -- queues and similar external-interfacing systems. 752 | stepping 753 | #if MIN_VERSION_exceptions(0, 6, 0) 754 | :: (MonadIO m, MonadMask m) 755 | #else 756 | :: (MonadIO m, MonadCatch m) 757 | #endif 758 | => RetryPolicyM m 759 | -- ^ Just use 'retryPolicyDefault' for default settings 760 | -> [RetryStatus -> Handler m Bool] 761 | -- ^ Should a given exception be retried? Action will be 762 | -- retried if this returns True *and* the policy allows it. 763 | -- This action will be consulted first even if the policy 764 | -- later blocks it. 765 | -> (RetryStatus -> m ()) 766 | -- ^ Action to run with updated status upon failure. 767 | -> (RetryStatus -> m a) 768 | -- ^ Main action to perform with current status. 769 | -> RetryStatus 770 | -- ^ Current status of this step 771 | -> m (Maybe a) 772 | stepping policy hs schedule f s = do 773 | r <- try $ f s 774 | case r of 775 | Right x -> return $ Just x 776 | Left e -> recover (e :: SomeException) hs 777 | where 778 | recover e [] = throwM e 779 | recover e ((($ s) -> Handler h) : hs') 780 | | Just e' <- fromException e = do 781 | chk <- h e' 782 | case chk of 783 | True -> do 784 | res <- applyPolicy policy s 785 | case res of 786 | Just rs -> do 787 | schedule $! rs 788 | return Nothing 789 | Nothing -> throwM e' 790 | False -> throwM e' 791 | | otherwise = recover e hs' 792 | 793 | 794 | ------------------------------------------------------------------------------- 795 | -- | Helper function for constructing handler functions of the form required 796 | -- by 'recovering'. 797 | logRetries 798 | :: ( Monad m 799 | , Exception e) 800 | => (e -> m Bool) 801 | -- ^ Test for whether action is to be retried 802 | -> (Bool -> e -> RetryStatus -> m ()) 803 | -- ^ How to report the generated warning message. Boolean is 804 | -- whether it's being retried or crashed. 805 | -> RetryStatus 806 | -- ^ Retry number 807 | -> Handler m Bool 808 | logRetries test reporter status = Handler $ \ err -> do 809 | result <- test err 810 | reporter result err status 811 | return result 812 | 813 | -- | For use with 'logRetries'. 814 | defaultLogMsg :: (Exception e) => Bool -> e -> RetryStatus -> String 815 | defaultLogMsg shouldRetry err status = 816 | "[retry:" <> iter <> "] Encountered " <> show err <> ". " <> nextMsg 817 | where 818 | iter = show $ rsIterNumber status 819 | nextMsg = if shouldRetry then "Retrying." else "Crashing." 820 | 821 | 822 | ------------------------------------------------------------------------------- 823 | retryOnError 824 | :: (Functor m, MonadIO m, MonadError e m) 825 | => RetryPolicyM m 826 | -- ^ Policy 827 | -> (RetryStatus -> e -> m Bool) 828 | -- ^ Should an error be retried? 829 | -> (RetryStatus -> m a) 830 | -- ^ Action to perform 831 | -> m a 832 | retryOnError policy chk f = go defaultRetryStatus 833 | where 834 | go stat = do 835 | res <- (Right <$> f stat) `catchError` (\e -> Left . (e, ) <$> chk stat e) 836 | case res of 837 | Right x -> return x 838 | Left (e, True) -> do 839 | mstat' <- applyAndDelay policy stat 840 | case mstat' of 841 | Just stat' -> do 842 | go $! stat' 843 | Nothing -> throwError e 844 | Left (e, False) -> throwError e 845 | 846 | 847 | ------------------------------------------------------------------------------- 848 | -- | Run given policy up to N iterations and gather results. In the 849 | -- pair, the @Int@ is the iteration number and the @Maybe Int@ is the 850 | -- delay in microseconds. 851 | simulatePolicy :: Monad m => Int -> RetryPolicyM m -> m [(Int, Maybe Int)] 852 | simulatePolicy n (RetryPolicyM f) = flip evalStateT defaultRetryStatus $ forM [0..n] $ \i -> do 853 | stat <- get 854 | delay <- TC.lift (f stat) 855 | put $! stat 856 | { rsIterNumber = i + 1 857 | , rsCumulativeDelay = rsCumulativeDelay stat `boundedPlus` fromMaybe 0 delay 858 | , rsPreviousDelay = delay 859 | } 860 | return (i, delay) 861 | 862 | 863 | ------------------------------------------------------------------------------- 864 | -- | Run given policy up to N iterations and pretty print results on 865 | -- the console. 866 | simulatePolicyPP :: Int -> RetryPolicyM IO -> IO () 867 | simulatePolicyPP n p = do 868 | ps <- simulatePolicy n p 869 | forM_ ps $ \ (iterNo, res) -> putStrLn $ 870 | show iterNo <> ": " <> maybe "Inhibit" ppTime res 871 | putStrLn $ "Total cumulative delay would be: " <> 872 | ppTime (boundedSum $ mapMaybe snd ps) 873 | 874 | 875 | ------------------------------------------------------------------------------- 876 | ppTime :: (Integral a, Show a) => a -> String 877 | ppTime n | n < 1000 = show n <> "us" 878 | | n < 1000000 = show ((fromIntegral n / 1000) :: Double) <> "ms" 879 | | otherwise = show ((fromIntegral n / 1000) :: Double) <> "ms" 880 | 881 | ------------------------------------------------------------------------------- 882 | -- Bounded arithmetic 883 | ------------------------------------------------------------------------------- 884 | 885 | -- | Same as '+' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or 886 | -- @'minBound' :: 'Int'@ rather than rolling over 887 | boundedPlus :: Int -> Int -> Int 888 | boundedPlus i@(I# i#) j@(I# j#) = case addIntC# i# j# of 889 | (# k#, 0# #) -> I# k# 890 | (# _, _ #) 891 | | maxBy abs i j < 0 -> minBound 892 | | otherwise -> maxBound 893 | where 894 | maxBy f a b = if f a >= f b then a else b 895 | 896 | -- | Same as '*' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or 897 | -- @'minBound' :: 'Int'@ rather than rolling over 898 | boundedMult :: Int -> Int -> Int 899 | boundedMult i@(I# i#) j@(I# j#) = case mulIntMayOflo# i# j# of 900 | 0# -> I# (i# *# j#) 901 | _ | signum i * signum j < 0 -> minBound 902 | | otherwise -> maxBound 903 | 904 | -- | Same as 'sum' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or 905 | -- @'minBound' :: 'Int'@ rather than rolling over 906 | boundedSum :: [Int] -> Int 907 | boundedSum = foldl' boundedPlus 0 908 | 909 | -- | Same as '^' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or 910 | -- @'MinBound' :: 'Int'@ rather than rolling over 911 | boundedPow :: Int -> Int -> Int 912 | boundedPow x0 y0 913 | | y0 < 0 = error "Negative exponent" 914 | | y0 == 0 = 1 915 | | otherwise = f x0 y0 916 | where 917 | f x y 918 | | even y = f (x `boundedMult` x) (y `quot` 2) 919 | | y == 1 = x 920 | | otherwise = g (x `boundedMult` x) ((y - 1) `quot` 2) x 921 | g x y z 922 | | even y = g (x `boundedMult` x) (y `quot` 2) z 923 | | y == 1 = x `boundedMult` z 924 | | otherwise = g (x `boundedMult` x) ((y - 1) `quot` 2) (x `boundedMult` z) 925 | 926 | ------------------------------------------------------------------------------- 927 | -- Lens machinery 928 | ------------------------------------------------------------------------------- 929 | -- Unexported type aliases to clean up the documentation 930 | type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t 931 | 932 | type Lens' s a = Lens s s a a 933 | 934 | 935 | ------------------------------------------------------------------------------- 936 | lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b 937 | lens sa sbt afb s = sbt s <$> afb (sa s) 938 | {-# INLINE lens #-} 939 | 940 | 941 | ------------------ 942 | -- Simple Tests -- 943 | ------------------ 944 | 945 | 946 | 947 | -- data TestException = TestException deriving (Show, Typeable) 948 | -- data AnotherException = AnotherException deriving (Show, Typeable) 949 | 950 | -- instance Exception TestException 951 | -- instance Exception AnotherException 952 | 953 | 954 | -- test = retrying retryPolicyDefault [h1,h2] f 955 | -- where 956 | -- f = putStrLn "Running action" >> throwM AnotherException 957 | -- h1 = Handler $ \ (e :: TestException) -> return False 958 | -- h2 = Handler $ \ (e :: AnotherException) -> return True 959 | -------------------------------------------------------------------------------- /src/UnliftIO/Retry.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | ----------------------------------------------------------------------------- 4 | -- | 5 | -- Module : UnliftIO.Retry 6 | -- Copyright : Ozgun Ataman 7 | -- License : BSD3 8 | -- 9 | -- Maintainer : Patrick Brisbin 10 | -- Stability : provisional 11 | -- 12 | -- Unlifted "Control.Retry". 13 | -- 14 | -- @since 0.9.3.0 15 | ---------------------------------------------------------------------------- 16 | 17 | 18 | module UnliftIO.Retry 19 | ( 20 | -- * Types and Operations 21 | RetryPolicyM (..) 22 | , RetryPolicy 23 | , retryPolicy 24 | , retryPolicyDefault 25 | , natTransformRetryPolicy 26 | , RetryAction (..) 27 | , toRetryAction 28 | , RetryStatus (..) 29 | , defaultRetryStatus 30 | , applyPolicy 31 | , applyAndDelay 32 | 33 | 34 | -- ** Lenses for 'RetryStatus' 35 | , rsIterNumberL 36 | , rsCumulativeDelayL 37 | , rsPreviousDelayL 38 | 39 | -- * Applying Retry Policies 40 | , retrying 41 | , retryingDynamic 42 | , recovering 43 | , recoveringDynamic 44 | , stepping 45 | , recoverAll 46 | , skipAsyncExceptions 47 | , logRetries 48 | , defaultLogMsg 49 | , retryOnError 50 | -- ** Resumable variants 51 | , resumeRetrying 52 | , resumeRetryingDynamic 53 | , resumeRecovering 54 | , resumeRecoveringDynamic 55 | , resumeRecoverAll 56 | 57 | -- * Retry Policies 58 | , constantDelay 59 | , exponentialBackoff 60 | , fullJitterBackoff 61 | , fibonacciBackoff 62 | , limitRetries 63 | 64 | -- * Policy Transformers 65 | , limitRetriesByDelay 66 | , limitRetriesByCumulativeDelay 67 | , capDelay 68 | 69 | -- * Development Helpers 70 | , simulatePolicy 71 | , simulatePolicyPP 72 | ) where 73 | 74 | ------------------------------------------------------------------------------- 75 | import Control.Retry hiding 76 | ( recoverAll 77 | , recovering 78 | , recoveringDynamic 79 | , resumeRecovering 80 | , resumeRecoveringDynamic 81 | , resumeRecoverAll 82 | , stepping 83 | ) 84 | import qualified Control.Retry as Retry 85 | import Control.Monad.Catch (Handler(..)) 86 | import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) 87 | import Prelude 88 | ------------------------------------------------------------------------------- 89 | 90 | 91 | ------------------------------------------------------------------------------- 92 | -- | Run an action and recover from a raised exception by potentially 93 | -- retrying the action a number of times. Note that if you're going to 94 | -- use a handler for 'SomeException', you should add explicit cases 95 | -- *earlier* in the list of handlers to reject 'AsyncException' and 96 | -- 'SomeAsyncException', as catching these can cause thread and 97 | -- program hangs. 'recoverAll' already does this for you so if you 98 | -- just plan on catching 'SomeException', you may as well use 99 | -- 'recoverAll' 100 | recovering 101 | :: MonadUnliftIO m 102 | => RetryPolicyM m 103 | -- ^ Just use 'retryPolicyDefault' for default settings 104 | -> [RetryStatus -> Handler m Bool] 105 | -- ^ Should a given exception be retried? Action will be 106 | -- retried if this returns True *and* the policy allows it. 107 | -- This action will be consulted first even if the policy 108 | -- later blocks it. 109 | -> (RetryStatus -> m a) 110 | -- ^ Action to perform 111 | -> m a 112 | recovering = resumeRecovering defaultRetryStatus 113 | 114 | 115 | ------------------------------------------------------------------------------- 116 | -- | A variant of 'recovering' that allows specifying the initial 117 | -- 'RetryStatus' so that a recovering operation may pick up where it left 118 | -- off in regards to its retry policy. 119 | resumeRecovering 120 | :: MonadUnliftIO m 121 | => RetryStatus 122 | -> RetryPolicyM m 123 | -- ^ Just use 'retryPolicyDefault' for default settings 124 | -> [RetryStatus -> Handler m Bool] 125 | -- ^ Should a given exception be retried? Action will be 126 | -- retried if this returns True *and* the policy allows it. 127 | -- This action will be consulted first even if the policy 128 | -- later blocks it. 129 | -> (RetryStatus -> m a) 130 | -- ^ Action to perform 131 | -> m a 132 | resumeRecovering retryStatus policy hs f = withRunInIO $ \runInIO -> 133 | Retry.resumeRecovering 134 | retryStatus 135 | (transRetryPolicy runInIO policy) 136 | (map ((.) $ transHandler runInIO) hs) 137 | (runInIO . f) 138 | 139 | 140 | ------------------------------------------------------------------------------- 141 | -- | The difference between this and 'recovering' is the same as 142 | -- the difference between 'retryingDynamic' and 'retrying'. 143 | recoveringDynamic 144 | :: MonadUnliftIO m 145 | => RetryPolicyM m 146 | -- ^ Just use 'retryPolicyDefault' for default settings 147 | -> [RetryStatus -> Handler m RetryAction] 148 | -- ^ Should a given exception be retried? Action will be 149 | -- retried if this returns either 'ConsultPolicy' or 150 | -- 'ConsultPolicyOverrideDelay' *and* the policy allows it. 151 | -- This action will be consulted first even if the policy 152 | -- later blocks it. 153 | -> (RetryStatus -> m a) 154 | -- ^ Action to perform 155 | -> m a 156 | recoveringDynamic = resumeRecoveringDynamic defaultRetryStatus 157 | 158 | 159 | ------------------------------------------------------------------------------- 160 | -- | A variant of 'recoveringDynamic' that allows specifying the initial 161 | -- 'RetryStatus' so that a recovering operation may pick up where it left 162 | -- off in regards to its retry policy. 163 | resumeRecoveringDynamic 164 | :: MonadUnliftIO m 165 | => RetryStatus 166 | -> RetryPolicyM m 167 | -- ^ Just use 'retryPolicyDefault' for default settings 168 | -> [RetryStatus -> Handler m RetryAction] 169 | -- ^ Should a given exception be retried? Action will be 170 | -- retried if this returns either 'ConsultPolicy' or 171 | -- 'ConsultPolicyOverrideDelay' *and* the policy allows it. 172 | -- This action will be consulted first even if the policy 173 | -- later blocks it. 174 | -> (RetryStatus -> m a) 175 | -- ^ Action to perform 176 | -> m a 177 | resumeRecoveringDynamic retryStatus policy hs f = withRunInIO $ \runInIO -> 178 | Retry.resumeRecoveringDynamic 179 | retryStatus 180 | (transRetryPolicy runInIO policy) 181 | (map ((.) $ transHandler runInIO) hs) 182 | (runInIO . f) 183 | 184 | 185 | ------------------------------------------------------------------------------- 186 | -- | Retry ALL exceptions that may be raised. To be used with caution; 187 | -- this matches the exception on 'SomeException'. Note that this 188 | -- handler explicitly does not handle 'AsyncException' nor 189 | -- 'SomeAsyncException' (for versions of base >= 4.7). It is not a 190 | -- good idea to catch async exceptions as it can result in hanging 191 | -- threads and programs. Note that if you just throw an exception to 192 | -- this thread that does not descend from SomeException, recoverAll 193 | -- will not catch it. 194 | -- 195 | -- See how the action below is run once and retried 5 more times 196 | -- before finally failing for good: 197 | -- 198 | -- >>> let f _ = putStrLn "Running action" >> error "this is an error" 199 | -- >>> recoverAll retryPolicyDefault f 200 | -- Running action 201 | -- Running action 202 | -- Running action 203 | -- Running action 204 | -- Running action 205 | -- Running action 206 | -- *** Exception: this is an error 207 | recoverAll 208 | :: MonadUnliftIO m 209 | => RetryPolicyM m 210 | -> (RetryStatus -> m a) 211 | -> m a 212 | recoverAll = resumeRecoverAll defaultRetryStatus 213 | 214 | 215 | ------------------------------------------------------------------------------- 216 | -- | A variant of 'recoverAll' that allows specifying the initial 217 | -- 'RetryStatus' so that a recovering operation may pick up where it left 218 | -- off in regards to its retry policy. 219 | resumeRecoverAll 220 | :: MonadUnliftIO m 221 | => RetryStatus 222 | -> RetryPolicyM m 223 | -> (RetryStatus -> m a) 224 | -> m a 225 | resumeRecoverAll retryStatus policy f = withRunInIO $ \runInIO -> 226 | Retry.resumeRecoverAll 227 | retryStatus 228 | (transRetryPolicy runInIO policy) 229 | (runInIO . f) 230 | 231 | ------------------------------------------------------------------------------- 232 | -- | A version of 'recovering' that tries to run the action only a 233 | -- single time. The control will return immediately upon both success 234 | -- and failure. Useful for implementing retry logic in distributed 235 | -- queues and similar external-interfacing systems. 236 | stepping 237 | :: MonadUnliftIO m 238 | => RetryPolicyM m 239 | -- ^ Just use 'retryPolicyDefault' for default settings 240 | -> [RetryStatus -> Handler m Bool] 241 | -- ^ Should a given exception be retried? Action will be 242 | -- retried if this returns True *and* the policy allows it. 243 | -- This action will be consulted first even if the policy 244 | -- later blocks it. 245 | -> (RetryStatus -> m ()) 246 | -- ^ Action to run with updated status upon failure. 247 | -> (RetryStatus -> m a) 248 | -- ^ Main action to perform with current status. 249 | -> RetryStatus 250 | -- ^ Current status of this step 251 | -> m (Maybe a) 252 | stepping policy hs schedule f s = withRunInIO $ \runInIO -> 253 | Retry.stepping 254 | (transRetryPolicy runInIO policy) 255 | (map ((.) $ transHandler runInIO) hs) 256 | (runInIO . schedule) 257 | (runInIO . f) 258 | s 259 | 260 | 261 | ------------------------------------------------------------------------------- 262 | transRetryPolicy :: (forall a. m a -> n a) -> RetryPolicyM m -> RetryPolicyM n 263 | transRetryPolicy f (RetryPolicyM p) = RetryPolicyM $ f . p 264 | 265 | 266 | ------------------------------------------------------------------------------- 267 | transHandler :: (forall b. m b -> n b) -> Handler m a -> Handler n a 268 | transHandler f (Handler h) = Handler $ f . h 269 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.27 2 | packages: 3 | - "." 4 | extra-deps: [] 5 | flags: 6 | retry: 7 | lib-Werror: true 8 | extra-package-dbs: [] 9 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( main 3 | ) where 4 | 5 | 6 | ------------------------------------------------------------------------------- 7 | import Test.Tasty 8 | ------------------------------------------------------------------------------- 9 | import qualified Tests.Control.Retry 10 | import qualified Tests.UnliftIO.Retry 11 | ------------------------------------------------------------------------------- 12 | 13 | 14 | 15 | main :: IO () 16 | main = defaultMain tests 17 | 18 | 19 | ------------------------------------------------------------------------------- 20 | tests :: TestTree 21 | tests = testGroup "retry" 22 | [ Tests.Control.Retry.tests 23 | , Tests.UnliftIO.Retry.tests 24 | ] 25 | -------------------------------------------------------------------------------- /test/Tests/Control/Retry.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | module Tests.Control.Retry 7 | ( tests 8 | 9 | -- * Used to test UnliftIO versions of the same functions 10 | , recoveringTestsWith 11 | , maskingStateTestsWith 12 | , quadraticDelayTestsWith 13 | , recoveringTest 14 | , testHandlers 15 | , testHandlersDynamic 16 | ) where 17 | 18 | ------------------------------------------------------------------------------- 19 | import Control.Applicative 20 | import Control.Concurrent 21 | import Control.Concurrent.STM as STM 22 | import qualified Control.Exception as EX 23 | import Control.Monad as M ( forM_ ) 24 | import Control.Monad.Catch 25 | import Control.Monad.Except 26 | import Control.Monad.Identity 27 | import Control.Monad.IO.Class as MIO 28 | import Control.Monad.Writer.Strict 29 | import Data.Either 30 | import Data.IORef 31 | import Data.List 32 | import Data.Maybe 33 | import Data.Time.Clock 34 | import Data.Time.LocalTime () 35 | import Data.Typeable 36 | import Hedgehog as HH 37 | import qualified Hedgehog.Gen as Gen 38 | import qualified Hedgehog.Range as Range 39 | import System.IO.Error 40 | import Test.Tasty 41 | import Test.Tasty.Hedgehog 42 | import Test.Tasty.HUnit ( assertBool, assertFailure 43 | , testCase, (@=?), (@?=) 44 | ) 45 | ------------------------------------------------------------------------------- 46 | import Control.Retry 47 | ------------------------------------------------------------------------------- 48 | 49 | 50 | tests :: TestTree 51 | tests = testGroup "Control.Retry" 52 | [ recoveringTests 53 | , monoidTests 54 | , retryStatusTests 55 | , quadraticDelayTests 56 | , policyTransformersTests 57 | , maskingStateTests 58 | , capDelayTests 59 | , limitRetriesByCumulativeDelayTests 60 | , overridingDelayTests 61 | , resumableTests 62 | , retryOnErrorTests 63 | ] 64 | 65 | 66 | ------------------------------------------------------------------------------- 67 | recoveringTests :: TestTree 68 | recoveringTests = recoveringTestsWith recovering 69 | 70 | 71 | recoveringTestsWith 72 | :: Monad m 73 | => (RetryPolicyM m -> [RetryStatus -> Handler IO Bool] -> (a -> IO ()) -> IO ()) 74 | -> TestTree 75 | recoveringTestsWith recovering' = testGroup "recovering" 76 | [ testProperty "recovering test without quadratic retry delay" $ property $ do 77 | startTime <- liftIO getCurrentTime 78 | timeout <- forAll (Gen.int (Range.linear 0 15)) 79 | retries <- forAll (Gen.int (Range.linear 0 50)) 80 | res <- liftIO $ try $ recovering' 81 | (constantDelay timeout <> limitRetries retries) 82 | testHandlers 83 | (const $ throwM (userError "booo")) 84 | endTime <- liftIO getCurrentTime 85 | HH.assert (isLeftAnd isUserError res) 86 | let ms' = (fromInteger . toInteger $ (timeout * retries)) / 1000000.0 87 | HH.assert (diffUTCTime endTime startTime >= ms') 88 | , testGroup "exception hierarchy semantics" 89 | [ testCase "does not catch async exceptions" $ do 90 | counter <- newTVarIO (0 :: Int) 91 | done <- newEmptyMVar 92 | let work = atomically (modifyTVar' counter succ) >> threadDelay 1000000 93 | 94 | tid <- forkIO $ 95 | recoverAll (limitRetries 2) (const work) `finally` putMVar done () 96 | 97 | atomically (STM.check . (== 1) =<< readTVar counter) 98 | EX.throwTo tid EX.UserInterrupt 99 | 100 | takeMVar done 101 | 102 | count <- atomically (readTVar counter) 103 | count @?= 1 104 | 105 | , testCase "recovers from custom exceptions" $ do 106 | f <- mkFailN Custom1 2 107 | res <- try $ recovering' 108 | (constantDelay 5000 <> limitRetries 3) 109 | [const $ Handler $ \ Custom1 -> return shouldRetry] 110 | f 111 | (res :: Either Custom1 ()) @?= Right () 112 | 113 | , testCase "fails beyond policy using custom exceptions" $ do 114 | f <- mkFailN Custom1 3 115 | res <- try $ recovering' 116 | (constantDelay 5000 <> limitRetries 2) 117 | [const $ Handler $ \ Custom1 -> return shouldRetry] 118 | f 119 | (res :: Either Custom1 ()) @?= Left Custom1 120 | 121 | , testCase "recoverAll won't catch exceptions which are not decendants of SomeException" $ do 122 | f <- mkFailN Custom1 4 123 | res <- try $ recoverAll 124 | (constantDelay 5000 <> limitRetries 3) 125 | f 126 | (res :: Either Custom1 ()) @?= Left Custom1 127 | 128 | , testCase "does not recover from unhandled exceptions" $ do 129 | f <- mkFailN Custom2 2 130 | res <- try $ recovering' 131 | (constantDelay 5000 <> limitRetries 5) 132 | [const $ Handler $ \ Custom1 -> return shouldRetry] 133 | f 134 | (res :: Either Custom2 ()) @?= Left Custom2 135 | 136 | 137 | , testCase "recovers in presence of multiple handlers" $ do 138 | f <- mkFailN Custom2 2 139 | res <- try $ recovering' 140 | (constantDelay 5000 <> limitRetries 5) 141 | [ const $ Handler $ \ Custom1 -> return shouldRetry 142 | , const $ Handler $ \ Custom2 -> return shouldRetry ] 143 | f 144 | (res :: Either Custom2 ()) @?= Right () 145 | 146 | 147 | , testCase "general exceptions catch specific ones" $ do 148 | f <- mkFailN Custom2 2 149 | res <- try $ recovering' 150 | (constantDelay 5000 <> limitRetries 5) 151 | [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] 152 | f 153 | (res :: Either Custom2 ()) @?= Right () 154 | 155 | 156 | , testCase "(redundant) even general catchers don't go beyond policy" $ do 157 | f <- mkFailN Custom2 3 158 | res <- try $ recovering' 159 | (constantDelay 5000 <> limitRetries 2) 160 | [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] 161 | f 162 | (res :: Either Custom2 ()) @?= Left Custom2 163 | 164 | 165 | , testCase "rethrows in presence of failed exception casts" $ do 166 | f <- mkFailN Custom2 3 167 | final <- try $ do 168 | res <- try $ recovering' 169 | (constantDelay 5000 <> limitRetries 2) 170 | [ const $ Handler $ \ (_::SomeException) -> return shouldRetry ] 171 | f 172 | (res :: Either Custom1 ()) @?= Left Custom1 173 | final @?= Left Custom2 174 | ] 175 | ] 176 | 177 | 178 | ------------------------------------------------------------------------------- 179 | monoidTests :: TestTree 180 | monoidTests = testGroup "Policy is a monoid" 181 | [ testProperty "left identity" $ property $ 182 | propIdentity (\p -> mempty <> p) id 183 | , testProperty "right identity" $ property $ 184 | propIdentity (\p -> p <> mempty) id 185 | , testProperty "associativity" $ property $ 186 | propAssociativity (\x y z -> x <> (y <> z)) (\x y z -> (x <> y) <> z) 187 | ] 188 | where 189 | propIdentity left right = do 190 | retryStatus <- forAll genRetryStatus 191 | fixedDelay <- forAll (Gen.maybe (Gen.int (Range.linear 0 maxBound))) 192 | let calculateDelay _rs = fixedDelay 193 | let applyPolicy' f = getRetryPolicyM (f $ retryPolicy calculateDelay) retryStatus 194 | validRes = maybe True (>= 0) 195 | l <- liftIO $ applyPolicy' left 196 | r <- liftIO $ applyPolicy' right 197 | if validRes r && validRes l 198 | then l === r 199 | else return () 200 | propAssociativity left right = do 201 | retryStatus <- forAll genRetryStatus 202 | let genDelay = Gen.maybe (Gen.int (Range.linear 0 maxBound)) 203 | delayA <- forAll genDelay 204 | delayB <- forAll genDelay 205 | delayC <- forAll genDelay 206 | let applyPolicy' f = liftIO $ getRetryPolicyM (f (retryPolicy (const delayA)) (retryPolicy (const delayB)) (retryPolicy (const delayC))) retryStatus 207 | res <- liftIO (liftA2 (==) (applyPolicy' left) (applyPolicy' right)) 208 | assert res 209 | 210 | 211 | ------------------------------------------------------------------------------- 212 | retryStatusTests :: TestTree 213 | retryStatusTests = testGroup "retry status" 214 | [ testCase "passes the correct retry status each time" $ do 215 | let policy = limitRetries 2 <> constantDelay 100 216 | rses <- gatherStatuses policy 217 | rsIterNumber <$> rses @?= [0, 1, 2] 218 | rsCumulativeDelay <$> rses @?= [0, 100, 200] 219 | rsPreviousDelay <$> rses @?= [Nothing, Just 100, Just 100] 220 | ] 221 | 222 | 223 | ------------------------------------------------------------------------------- 224 | policyTransformersTests :: TestTree 225 | policyTransformersTests = testGroup "policy transformers" 226 | [ testProperty "always produces positive delay with positive constants (no rollover)" $ property $ do 227 | delay <- forAll (Gen.int (Range.linear 0 maxBound)) 228 | let res = runIdentity (simulatePolicy 1000 (exponentialBackoff delay)) 229 | delays = catMaybes (snd <$> res) 230 | mnDelay = if null delays 231 | then Nothing 232 | else Just (minimum delays) 233 | case mnDelay of 234 | Nothing -> return () 235 | Just n -> do 236 | footnote (show n ++ " is not >= 0") 237 | HH.assert (n >= 0) 238 | , testProperty "positive, nonzero exponential backoff is always incrementing" $ property $ do 239 | delay <- forAll (Gen.int (Range.linear 1 maxBound)) 240 | let res = runIdentity (simulatePolicy 1000 (limitRetriesByDelay maxBound (exponentialBackoff delay))) 241 | delays = catMaybes (snd <$> res) 242 | sort delays === delays 243 | length (group delays) === length delays 244 | ] 245 | 246 | 247 | ------------------------------------------------------------------------------- 248 | maskingStateTests :: TestTree 249 | maskingStateTests = maskingStateTestsWith recovering 250 | 251 | 252 | maskingStateTestsWith 253 | :: Monad m 254 | => (RetryPolicyM m -> [RetryStatus -> Handler IO Bool] -> (a -> IO b) -> IO ()) 255 | -> TestTree 256 | maskingStateTestsWith recovering' = testGroup "masking state" 257 | [ testCase "shouldn't change masking state in a recovered action" $ do 258 | maskingState <- EX.getMaskingState 259 | final <- try $ recovering' retryPolicyDefault testHandlers $ const $ do 260 | maskingState' <- EX.getMaskingState 261 | maskingState' @?= maskingState 262 | fail "Retrying..." 263 | assertBool 264 | ("Expected EX.IOException but didn't get one") 265 | (isLeft (final :: Either EX.IOException ())) 266 | 267 | , testCase "should mask asynchronous exceptions in exception handlers" $ do 268 | let checkMaskingStateHandlers = 269 | [ const $ Handler $ \(_ :: SomeException) -> do 270 | maskingState <- EX.getMaskingState 271 | maskingState @?= EX.MaskedInterruptible 272 | return shouldRetry 273 | ] 274 | final <- try $ recovering' retryPolicyDefault checkMaskingStateHandlers $ const $ fail "Retrying..." 275 | assertBool 276 | ("Expected EX.IOException but didn't get one") 277 | (isLeft (final :: Either EX.IOException ())) 278 | ] 279 | 280 | 281 | ------------------------------------------------------------------------------- 282 | capDelayTests :: TestTree 283 | capDelayTests = testGroup "capDelay" 284 | [ testProperty "respects limitRetries" $ property $ do 285 | retries <- forAll (Gen.int (Range.linear 1 100)) 286 | cap <- forAll (Gen.int (Range.linear 1 maxBound)) 287 | let policy = capDelay cap (limitRetries retries) 288 | let delays = runIdentity (simulatePolicy (retries + 1) policy) 289 | let lastDelay = fromMaybe (error "impossible: empty delays") (lookup (retries - 1) delays) 290 | let gaveUp = fromMaybe (error "impossible: empty delays") (lookup retries delays) 291 | let noDelay = 0 292 | lastDelay === Just noDelay 293 | gaveUp === Nothing 294 | , testProperty "does not allow any delays higher than the given delay" $ property $ do 295 | cap <- forAll (Gen.int (Range.linear 1 maxBound)) 296 | baseDelay <- forAll (Gen.int (Range.linear 1 100)) 297 | basePolicy <- forAllWith (const "RetryPolicy") (genScalingPolicy baseDelay) 298 | let policy = capDelay cap basePolicy 299 | let delays = catMaybes (snd <$> runIdentity (simulatePolicy 100 policy)) 300 | let baddies = filter (> cap) delays 301 | baddies === [] 302 | ] 303 | 304 | 305 | ------------------------------------------------------------------------------- 306 | -- | Generates policies that increase on each iteration 307 | genScalingPolicy :: (Alternative m) => Int -> m (RetryPolicyM Identity) 308 | genScalingPolicy baseDelay = 309 | (pure (exponentialBackoff baseDelay) <|> pure (fibonacciBackoff baseDelay)) 310 | 311 | 312 | ------------------------------------------------------------------------------- 313 | limitRetriesByCumulativeDelayTests :: TestTree 314 | limitRetriesByCumulativeDelayTests = testGroup "limitRetriesByCumulativeDelay" 315 | [ testProperty "never exceeds the given cumulative delay" $ property $ do 316 | baseDelay <- forAll (Gen.int (Range.linear 1 100)) 317 | basePolicy <- forAllWith (const "RetryPolicy") (genScalingPolicy baseDelay) 318 | cumulativeDelayMax <- forAll (Gen.int (Range.linear 1 10000)) 319 | let policy = limitRetriesByCumulativeDelay cumulativeDelayMax basePolicy 320 | let delays = catMaybes (snd <$> runIdentity (simulatePolicy 100 policy)) 321 | footnoteShow delays 322 | let actualCumulativeDelay = sum delays 323 | footnote (show actualCumulativeDelay <> " <= " <> show cumulativeDelayMax) 324 | HH.assert (actualCumulativeDelay <= cumulativeDelayMax) 325 | 326 | ] 327 | 328 | ------------------------------------------------------------------------------- 329 | quadraticDelayTests :: TestTree 330 | quadraticDelayTests = quadraticDelayTestsWith recovering 331 | 332 | 333 | quadraticDelayTestsWith 334 | :: Monad m 335 | => (RetryPolicyM m -> [RetryStatus -> Handler IO Bool] -> (a -> IO b) -> IO ()) 336 | -> TestTree 337 | quadraticDelayTestsWith recovering' = testGroup "quadratic delay" 338 | [ testProperty "recovering test with quadratic retry delay" $ property $ do 339 | startTime <- liftIO getCurrentTime 340 | timeout <- forAll (Gen.int (Range.linear 0 15)) 341 | retries <- forAll (Gen.int (Range.linear 0 8)) 342 | res <- liftIO $ try $ recovering' 343 | (exponentialBackoff timeout <> limitRetries retries) 344 | [const $ Handler (\(_::SomeException) -> return True)] 345 | (const $ throwM (userError "booo")) 346 | endTime <- liftIO getCurrentTime 347 | HH.assert (isLeftAnd isUserError res) 348 | let tmo = if retries > 0 then timeout * 2 ^ (retries - 1) else 0 349 | let ms' = ((fromInteger . toInteger $ tmo) / 1000000.0) 350 | HH.assert (diffUTCTime endTime startTime >= ms') 351 | ] 352 | 353 | 354 | ------------------------------------------------------------------------------- 355 | overridingDelayTests :: TestTree 356 | overridingDelayTests = testGroup "overriding delay" 357 | [ testGroup "actual delays don't exceed specified delays" 358 | [ testProperty "retryingDynamic" $ 359 | testOverride 360 | retryingDynamic 361 | (\delays rs _ -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs)) 362 | (\_ _ -> liftIO getCurrentTime >>= \time -> tell [time]) 363 | , testProperty "recoveringDynamic" $ 364 | testOverride 365 | recoveringDynamic 366 | (\delays -> [\rs -> Handler (\(_::SomeException) -> return $ ConsultPolicyOverrideDelay (delays !! rsIterNumber rs))]) 367 | (\delays rs -> do 368 | liftIO getCurrentTime >>= \time -> tell [time] 369 | if rsIterNumber rs < length delays 370 | then throwM (userError "booo") 371 | else return () 372 | ) 373 | ] 374 | ] 375 | where 376 | -- Transform a list of timestamps into a list of differences 377 | -- between adjacent timestamps. 378 | diffTimes = compareAdjacent (flip diffUTCTime) 379 | microsToNominalDiffTime = toNominal . picosecondsToDiffTime . (* 1000000) . fromIntegral 380 | toNominal :: DiffTime -> NominalDiffTime 381 | toNominal = realToFrac 382 | -- Generic test case used to test both "retryingDynamic" and "recoveringDynamic" 383 | testOverride retryer handler action = property $ do 384 | retryPolicy' <- forAll $ genPolicyNoLimit (Range.linear 1 1000000) 385 | delays <- forAll $ Gen.list (Range.linear 1 10) (Gen.int (Range.linear 10 1000)) 386 | (_, measuredTimestamps) <- liftIO $ runWriterT $ retryer 387 | -- Stop retrying when we run out of delays 388 | (retryPolicy' <> limitRetries (length delays)) 389 | (handler delays) 390 | (action delays) 391 | let expectedDelays = map microsToNominalDiffTime delays 392 | M.forM_ (zip (diffTimes measuredTimestamps) expectedDelays) $ 393 | \(actual, expected) -> diff actual (>=) expected 394 | 395 | 396 | ------------------------------------------------------------------------------- 397 | resumableTests :: TestTree 398 | resumableTests = testGroup "resumable" 399 | [ testGroup "resumeRetrying" 400 | [ testCase "can resume" $ do 401 | retryingTest resumeRetrying (\_ _ -> pure shouldRetry) 402 | ] 403 | , testGroup "resumeRetryingDynamic" 404 | [ testCase "can resume" $ do 405 | retryingTest resumeRetryingDynamic (\_ _ -> pure $ ConsultPolicy) 406 | ] 407 | , testGroup "resumeRecovering" 408 | [ testCase "can resume" $ do 409 | recoveringTest resumeRecovering testHandlers 410 | ] 411 | , testGroup "resumeRecoveringDynamic" 412 | [ testCase "can resume" $ do 413 | recoveringTest resumeRecoveringDynamic testHandlersDynamic 414 | ] 415 | , testGroup "resumeRecoverAll" 416 | [ testCase "can resume" $ do 417 | recoveringTest 418 | (\status policy () action -> resumeRecoverAll status policy action) 419 | () 420 | ] 421 | ] 422 | 423 | retryingTest 424 | :: (RetryStatus -> RetryPolicyM IO -> p -> (RetryStatus -> IO ()) -> IO ()) 425 | -> p 426 | -> IO () 427 | retryingTest resumableOp isRetryNeeded = do 428 | counterRef <- newIORef (0 :: Int) 429 | 430 | let go policy status = do 431 | atomicWriteIORef counterRef 0 432 | resumableOp 433 | status 434 | policy 435 | isRetryNeeded 436 | (const $ atomicModifyIORef' counterRef $ \n -> (1 + n, ())) 437 | 438 | let policy = limitRetries 2 439 | let nextStatus = nextStatusUsingPolicy policy 440 | 441 | go policy defaultRetryStatus 442 | (3 @=?) =<< readIORef counterRef 443 | 444 | go policy =<< nextStatus defaultRetryStatus 445 | (2 @=?) =<< readIORef counterRef 446 | 447 | go policy =<< nextStatus =<< nextStatus defaultRetryStatus 448 | (1 @=?) =<< readIORef counterRef 449 | 450 | recoveringTest 451 | :: (RetryStatus -> RetryPolicyM IO -> handlers -> (RetryStatus -> IO ()) -> IO ()) 452 | -> handlers 453 | -> IO () 454 | recoveringTest resumableOp handlers = do 455 | counterRef <- newIORef (0 :: Int) 456 | 457 | let go policy status = do 458 | action <- do 459 | mkFailUntilIO 460 | (\_ -> atomicModifyIORef' counterRef $ \n -> (1 + n, False)) 461 | Custom1 462 | try $ resumableOp status policy handlers action 463 | 464 | let policy = limitRetries 2 465 | let nextStatus = nextStatusUsingPolicy policy 466 | 467 | do 468 | atomicWriteIORef counterRef 0 469 | res <- go policy defaultRetryStatus 470 | res @?= Left Custom1 471 | (3 @=?) =<< readIORef counterRef 472 | 473 | do 474 | atomicWriteIORef counterRef 0 475 | res <- go policy =<< nextStatus defaultRetryStatus 476 | res @?= Left Custom1 477 | (2 @=?) =<< readIORef counterRef 478 | 479 | do 480 | atomicWriteIORef counterRef 0 481 | res <- go policy =<< nextStatus =<< nextStatus defaultRetryStatus 482 | res @?= Left Custom1 483 | (1 @=?) =<< readIORef counterRef 484 | 485 | 486 | ------------------------------------------------------------------------------- 487 | retryOnErrorTests :: TestTree 488 | retryOnErrorTests = testGroup "retryOnError" 489 | [ testCase "passes in the error type" $ do 490 | errCalls <- newTVarIO [] 491 | let policy = limitRetries 2 492 | let shouldWeRetry _retryStat e = do 493 | liftIO (atomically (modifyTVar' errCalls (++ [e]))) 494 | return True 495 | let action rs = (throwError ("boom" ++ show (rsIterNumber rs))) 496 | res <- runExceptT (retryOnError policy shouldWeRetry action) 497 | res @?= (Left "boom2" :: Either String ()) 498 | calls <- atomically (readTVar errCalls) 499 | calls @?= ["boom0", "boom1", "boom2"] 500 | ] 501 | 502 | ------------------------------------------------------------------------------- 503 | nextStatusUsingPolicy :: RetryPolicyM IO -> RetryStatus -> IO RetryStatus 504 | nextStatusUsingPolicy policy status = do 505 | applyPolicy policy status >>= \case 506 | Nothing -> do 507 | assertFailure "applying policy produced no new status" 508 | Just status' -> do 509 | pure status' 510 | 511 | 512 | ------------------------------------------------------------------------------- 513 | isLeftAnd :: (a -> Bool) -> Either a b -> Bool 514 | isLeftAnd f ei = case ei of 515 | Left v -> f v 516 | _ -> False 517 | 518 | 519 | ------------------------------------------------------------------------------- 520 | testHandlers :: [a -> Handler IO Bool] 521 | testHandlers = [const $ Handler (\(_::SomeException) -> return shouldRetry)] 522 | 523 | 524 | ------------------------------------------------------------------------------- 525 | testHandlersDynamic :: [a -> Handler IO RetryAction] 526 | testHandlersDynamic = 527 | [const $ Handler (\(_::SomeException) -> return ConsultPolicy)] 528 | 529 | -- | Apply a function to adjacent list items. 530 | -- 531 | -- Ie.: 532 | -- > compareAdjacent f [a0, a1, a2, a3, ..., a(n-2), a(n-1), an] = 533 | -- > [f a0 a1, f a1 a2, f a2 a3, ..., f a(n-2) a(n-1), f a(n-1) an] 534 | -- 535 | -- Not defined for lists of length < 2. 536 | compareAdjacent :: (a -> a -> b) -> [a] -> [b] 537 | compareAdjacent f lst = 538 | reverse . snd $ foldl 539 | (\(a1, accum) a2 -> (a2, f a1 a2 : accum)) 540 | (head lst, []) 541 | (tail lst) 542 | 543 | data Custom1 = Custom1 deriving (Eq,Show,Read,Ord,Typeable) 544 | data Custom2 = Custom2 deriving (Eq,Show,Read,Ord,Typeable) 545 | 546 | 547 | instance Exception Custom1 548 | instance Exception Custom2 549 | 550 | 551 | ------------------------------------------------------------------------------- 552 | genRetryStatus :: MonadGen m => m RetryStatus 553 | genRetryStatus = do 554 | n <- Gen.int (Range.linear 0 maxBound) 555 | d <- Gen.int (Range.linear 0 maxBound) 556 | l <- Gen.maybe (Gen.int (Range.linear 0 d)) 557 | return $ defaultRetryStatus { rsIterNumber = n 558 | , rsCumulativeDelay = d 559 | , rsPreviousDelay = l} 560 | 561 | 562 | ------------------------------------------------------------------------------- 563 | -- | Generate an arbitrary 'RetryPolicy' without any limits applied. 564 | genPolicyNoLimit 565 | :: forall mg mr. (MonadGen mg, MIO.MonadIO mr) 566 | => Range Int 567 | -> mg (RetryPolicyM mr) 568 | genPolicyNoLimit durationRange = 569 | Gen.choice 570 | [ genConstantDelay 571 | , genExponentialBackoff 572 | , genFullJitterBackoff 573 | , genFibonacciBackoff 574 | ] 575 | where 576 | genDuration = Gen.int durationRange 577 | -- Retry policies 578 | genConstantDelay = fmap constantDelay genDuration 579 | genExponentialBackoff = fmap exponentialBackoff genDuration 580 | genFullJitterBackoff = fmap fullJitterBackoff genDuration 581 | genFibonacciBackoff = fmap fibonacciBackoff genDuration 582 | 583 | -- Needed to generate a 'RetryPolicyM' using 'forAll' 584 | instance Show (RetryPolicyM m) where 585 | show = const "RetryPolicyM" 586 | 587 | 588 | ------------------------------------------------------------------------------- 589 | -- | Create an action that will fail exactly N times with the given 590 | -- exception and will then return () in any subsequent calls. 591 | mkFailN :: (Exception e) => e -> Int -> IO (s -> IO ()) 592 | mkFailN e n = mkFailUntil (\iter -> iter >= n) e 593 | 594 | 595 | ------------------------------------------------------------------------------- 596 | -- | Create an action that will fail with the given exception until the given 597 | -- iteration predicate returns 'True', at which point the action will return 598 | -- '()' in any subsequent calls. 599 | mkFailUntil 600 | :: (Exception e) 601 | => (Int -> Bool) 602 | -> e 603 | -> IO (s -> IO ()) 604 | mkFailUntil p = mkFailUntilIO (pure . p) 605 | 606 | 607 | ------------------------------------------------------------------------------- 608 | -- | The same as 'mkFailUntil' but allows doing IO in the predicate. 609 | mkFailUntilIO 610 | :: (Exception e) 611 | => (Int -> IO Bool) 612 | -> e 613 | -> IO (s -> IO ()) 614 | mkFailUntilIO p e = do 615 | r <- newIORef 0 616 | return $ const $ do 617 | old <- atomicModifyIORef' r $ \ old -> (old+1, old) 618 | p old >>= \case 619 | True -> return () 620 | False -> throwM e 621 | 622 | 623 | ------------------------------------------------------------------------------- 624 | gatherStatuses 625 | :: MonadIO m 626 | => RetryPolicyM (WriterT [RetryStatus] m) 627 | -> m [RetryStatus] 628 | gatherStatuses policy = execWriterT $ 629 | retrying policy (\_ _ -> return shouldRetry) 630 | (\rs -> tell [rs]) 631 | 632 | 633 | ------------------------------------------------------------------------------- 634 | -- | Just makes things a bit easier to follow instead of a magic value 635 | -- of @return True@ 636 | shouldRetry :: Bool 637 | shouldRetry = True 638 | -------------------------------------------------------------------------------- /test/Tests/UnliftIO/Retry.hs: -------------------------------------------------------------------------------- 1 | module Tests.UnliftIO.Retry 2 | ( tests 3 | ) where 4 | 5 | ------------------------------------------------------------------------------- 6 | import Test.Tasty 7 | import Test.Tasty.HUnit (testCase) 8 | ------------------------------------------------------------------------------- 9 | import UnliftIO.Retry 10 | import Tests.Control.Retry hiding (tests) 11 | ------------------------------------------------------------------------------- 12 | 13 | 14 | tests :: TestTree 15 | tests = testGroup "UnliftIO.Retry" 16 | [ recoveringTests 17 | , maskingStateTests 18 | , quadraticDelayTests 19 | , resumableTests 20 | ] 21 | 22 | 23 | ------------------------------------------------------------------------------- 24 | recoveringTests :: TestTree 25 | recoveringTests = recoveringTestsWith recovering 26 | 27 | 28 | ------------------------------------------------------------------------------- 29 | maskingStateTests :: TestTree 30 | maskingStateTests = maskingStateTestsWith recovering 31 | 32 | 33 | ------------------------------------------------------------------------------- 34 | quadraticDelayTests :: TestTree 35 | quadraticDelayTests = quadraticDelayTestsWith recovering 36 | 37 | 38 | ------------------------------------------------------------------------------- 39 | resumableTests :: TestTree 40 | resumableTests = testGroup "resumable" 41 | [ testGroup "resumeRecovering" 42 | [ testCase "can resume" $ do 43 | recoveringTest resumeRecovering testHandlers 44 | ] 45 | , testGroup "resumeRecoveringDynamic" 46 | [ testCase "can resume" $ do 47 | recoveringTest resumeRecoveringDynamic testHandlersDynamic 48 | ] 49 | , testGroup "resumeRecoverAll" 50 | [ testCase "can resume" $ do 51 | recoveringTest 52 | (\status policy () action -> resumeRecoverAll status policy action) 53 | () 54 | ] 55 | ] 56 | --------------------------------------------------------------------------------