diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -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. diff --git a/retry.cabal b/retry.cabal --- a/retry.cabal +++ b/retry.cabal @@ -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 diff --git a/src/Control/Retry.hs b/src/Control/Retry.hs --- a/src/Control/Retry.hs +++ b/src/Control/Retry.hs @@ -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