retry 0.7.1 → 0.7.2
raw patch · 3 files changed
+88/−21 lines, 3 filesdep +ghc-primdep +mtldep ~HUnitdep ~transformers
Dependencies added: ghc-prim, mtl
Dependency ranges changed: HUnit, transformers
Files
- changelog.md +3/−0
- retry.cabal +6/−3
- src/Control/Retry.hs +79/−18
changelog.md view
@@ -1,3 +1,6 @@+0.7.2+* Fix premature integer overflow error thanks to Mitsutoshi Aoe+ 0.7.1 * Various documentation updates. * Add stepping combinator for manual retries.
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.7.1+version: 0.7.2 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE@@ -35,8 +35,9 @@ base >= 4.6 && < 5 , data-default-class , exceptions >= 0.5 && < 0.9+ , ghc-prim < 0.5 , random >= 1 && < 1.2- , transformers < 0.5+ , transformers < 0.6 hs-source-dirs: src default-language: Haskell2010 @@ -54,7 +55,9 @@ , random , time , QuickCheck >= 2.7 && < 2.9- , HUnit >= 1.2.5.2 && < 1.3+ , HUnit >= 1.2.5.2 && < 1.4 , hspec >= 1.9 , stm+ , ghc-prim+ , mtl default-language: Haskell2010
src/Control/Retry.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ViewPatterns #-} -----------------------------------------------------------------------------@@ -49,6 +52,7 @@ , stepping , recoverAll , logRetries+ , defaultLogMsg -- * Retry Policies , constantDelay@@ -82,9 +86,12 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.State import Data.Default.Class+import Data.List (foldl') import Data.Functor.Identity import Data.Maybe import GHC.Generics+import GHC.Prim+import GHC.Types (Int(I#)) import System.Random import Data.Monoid import Prelude hiding (catch)@@ -204,7 +211,7 @@ case res of Just delay -> return $! Just $! RetryStatus { rsIterNumber = rsIterNumber s + 1- , rsCumulativeDelay = rsCumulativeDelay s + delay+ , rsCumulativeDelay = rsCumulativeDelay s `boundedPlus` delay , rsPreviousDelay = Just delay } Nothing -> return Nothing @@ -276,8 +283,8 @@ :: Int -- ^ First delay in microseconds -> RetryPolicy-exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> Just (2^n * base)-+exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n } ->+ Just $! base `boundedMult` boundedPow 2 n ------------------------------------------------------------------------------- -- | FullJitter exponential backoff as explained in AWS Architecture@@ -289,10 +296,10 @@ -- -- sleep = temp / 2 + random_between(0, temp / 2) fullJitterBackoff :: MonadIO m => Int -> RetryPolicyM m-fullJitterBackoff base = RetryPolicyM $ \RetryStatus { rsIterNumber = n } -> do- let d = (2^n * base) `div` 2+fullJitterBackoff base = RetryPolicyM $ \ RetryStatus { rsIterNumber = n } -> do+ let d = (base `boundedMult` boundedPow 2 n) `div` 2 rand <- liftIO $ randomRIO (0, d)- return $ Just $! d + rand+ return $! Just $! d `boundedPlus` rand -------------------------------------------------------------------------------@@ -301,10 +308,11 @@ :: Int -- ^ Base delay in microseconds -> RetryPolicy-fibonacciBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n } -> Just $ fib (n + 1) (0, base)+fibonacciBackoff base = retryPolicy $ \RetryStatus { rsIterNumber = n } ->+ Just $ fib (n + 1) (0, base) where fib 0 (a, _) = a- fib !m (!a, !b) = fib (m-1) (b, a + b)+ fib !m (!a, !b) = fib (m-1) (b, a `boundedPlus` b) -------------------------------------------------------------------------------@@ -514,21 +522,26 @@ :: (Monad m, Show e, Exception e) => (e -> m Bool) -- ^ Test for whether action is to be retried- -> (Bool -> String -> m ())+ -> (Bool -> e -> RetryStatus -> m ()) -- ^ How to report the generated warning message. Boolean is -- whether it's being retried or crashed. -> RetryStatus -- ^ Retry number -> Handler m Bool-logRetries f report s = Handler $ \ e -> do- res <- f e- let msg = "[retry:" <> show n <> "] Encountered " <> show e <> ". " <>- if res then "Retrying." else "Crashing."- report res msg- return res- where n = rsIterNumber s+logRetries test reporter status = Handler $ \ err -> do+ result <- test err+ reporter result err status+ return result +-- | For use with 'logRetries'.+defaultLogMsg :: (Show e, Exception e) => Bool -> e -> RetryStatus -> String+defaultLogMsg shouldRetry err status =+ "[retry:" <> iter <> "] Encountered " <> show err <> ". " <> next+ where+ iter = show $ rsIterNumber status+ next = if shouldRetry then "Retrying." else "Crashing." + ------------------------------------------------------------------------------- -- | Run given policy up to N iterations and gather results. In the -- pair, the @Int@ is the iteration number and the @Maybe Int@ is the@@ -537,7 +550,11 @@ simulatePolicy n (RetryPolicyM f) = flip evalStateT defaultRetryStatus $ forM [0..n] $ \i -> do stat <- get delay <- lift (f stat)- put stat { rsIterNumber = i + 1, rsCumulativeDelay = rsCumulativeDelay stat + fromMaybe 0 delay}+ put $! stat+ { rsIterNumber = i + 1+ , rsCumulativeDelay = rsCumulativeDelay stat `boundedPlus` fromMaybe 0 delay+ , rsPreviousDelay = delay+ } return (i, delay) @@ -550,7 +567,7 @@ forM_ ps $ \ (n, res) -> putStrLn $ show n <> ": " <> maybe "Inhibit" ppTime res putStrLn $ "Total cumulative delay would be: " <>- (ppTime $ sum $ (mapMaybe snd) ps)+ (ppTime $ boundedSum $ (mapMaybe snd) ps) -------------------------------------------------------------------------------@@ -559,6 +576,50 @@ | n < 1000000 = show (fromIntegral n / 1000) <> "ms" | otherwise = show (fromIntegral n / 1000) <> "ms" +-------------------------------------------------------------------------------+-- Bounded arithmetic+-------------------------------------------------------------------------------++-- | Same as '+' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or+-- @'minBound' :: 'Int'@ rather than rolling over+boundedPlus :: Int -> Int -> Int+boundedPlus i@(I# i#) j@(I# j#) = case addIntC# i# j# of+ (# k#, 0# #) -> I# k#+ (# _, _ #)+ | maxBy abs i j < 0 -> minBound+ | otherwise -> maxBound+ where+ maxBy f a b = if f a >= f b then a else b++-- | Same as '*' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or+-- @'minBound' :: 'Int'@ rather than rolling over+boundedMult :: Int -> Int -> Int+boundedMult i@(I# i#) j@(I# j#) = case mulIntMayOflo# i# j# of+ 0# -> I# (i# *# j#)+ _ | signum i * signum j < 0 -> minBound+ | otherwise -> maxBound++-- | Same as 'sum' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or+-- @'minBound' :: 'Int'@ rather than rolling over+boundedSum :: [Int] -> Int+boundedSum = foldl' boundedPlus 0++-- | Same as '^' on 'Int' but it maxes out at @'maxBound' :: 'Int'@ or+-- @'MinBound' :: 'Int'@ rather than rolling over+boundedPow :: Int -> Int -> Int+boundedPow x0 y0+ | y0 < 0 = error "Negative exponent"+ | y0 == 0 = 1+ | otherwise = f x0 y0+ where+ f x y+ | even y = f (x `boundedMult` x) (y `quot` 2)+ | y == 1 = x+ | otherwise = g (x `boundedMult` x) ((y - 1) `quot` 2) x+ g x y z+ | even y = g (x `boundedMult` x) (y `quot` 2) z+ | y == 1 = x `boundedMult` z+ | otherwise = g (x `boundedMult` x) ((y - 1) `quot` 2) (x `boundedMult` z) ------------------------------------------------------------------------------- -- Lens machinery