Hello community, here is the log from the commit of package ghc-retry for openSUSE:Factory checked in at 2016-05-17 17:14:41 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-retry (Old) and /work/SRC/openSUSE:Factory/.ghc-retry.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-retry" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-retry/ghc-retry.changes 2016-01-22 01:08:27.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-retry.new/ghc-retry.changes 2016-05-17 17:14:43.000000000 +0200 @@ -1,0 +2,6 @@ +Wed May 4 07:11:22 UTC 2016 - [email protected] + +- update to 0.7.2 +* Fix premature integer overflow + +------------------------------------------------------------------- Old: ---- retry-0.7.1.tar.gz New: ---- retry-0.7.2.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-retry.spec ++++++ --- /var/tmp/diff_new_pack.c3fvQx/_old 2016-05-17 17:14:44.000000000 +0200 +++ /var/tmp/diff_new_pack.c3fvQx/_new 2016-05-17 17:14:44.000000000 +0200 @@ -20,7 +20,7 @@ %bcond_with tests Name: ghc-retry -Version: 0.7.1 +Version: 0.7.2 Release: 0 Summary: Retry combinators for monadic actions that may fail Group: System/Libraries ++++++ retry-0.7.1.tar.gz -> retry-0.7.2.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.7.1/changelog.md new/retry-0.7.2/changelog.md --- old/retry-0.7.1/changelog.md 2016-01-13 18:40:22.000000000 +0100 +++ new/retry-0.7.2/changelog.md 2016-05-03 17:49:56.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.7.1/retry.cabal new/retry-0.7.2/retry.cabal --- old/retry-0.7.1/retry.cabal 2016-01-13 18:40:22.000000000 +0100 +++ new/retry-0.7.2/retry.cabal 2016-05-03 17:49:56.000000000 +0200 @@ -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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/retry-0.7.1/src/Control/Retry.hs new/retry-0.7.2/src/Control/Retry.hs --- old/retry-0.7.1/src/Control/Retry.hs 2016-01-13 18:40:22.000000000 +0100 +++ new/retry-0.7.2/src/Control/Retry.hs 2016-05-03 17:49:56.000000000 +0200 @@ -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,19 +522,24 @@ :: (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." ------------------------------------------------------------------------------- @@ -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
