Hello community,
here is the log from the commit of package ghc-retry for openSUSE:Factory
checked in at 2016-01-08 15:22:46
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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 2015-11-26
17:03:06.000000000 +0100
+++ /work/SRC/openSUSE:Factory/.ghc-retry.new/ghc-retry.changes 2016-01-08
15:22:47.000000000 +0100
@@ -1,0 +2,17 @@
+Wed Dec 23 16:32:10 UTC 2015 - mimi...@gmail.com
+
+- update to 0.7.0.1
+* RetryPolicy has become RetryPolicyM, allowing for policy logic to consult
the
+ monad context.
+* RetryPolicyM now takes a RetryStatus value. Use the function rsIterNum to
+ preserve existing behavior of RetryPolicy only receiving the number.
+* The monadic action now gets the RetryStatus on each try. Use const if you
+ don't need it.
+* recoverAll explicitly does not handle the standard async exceptions. Users
are
+ encouraged to do the same when using recovering, as catching async
exceptions
+ can be hazardous.
+* We no longer re-export (<>) from Monoid.
+* Utility functions simulatePolicy and simulatePolicyPP have been added which
help
+ predict how a policy will behave on each iteration.
+
+-------------------------------------------------------------------
Old:
----
retry-0.6.tar.gz
New:
----
retry-0.7.0.1.tar.gz
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Other differences:
------------------
++++++ ghc-retry.spec ++++++
--- /var/tmp/diff_new_pack.ewQWge/_old 2016-01-08 15:22:48.000000000 +0100
+++ /var/tmp/diff_new_pack.ewQWge/_new 2016-01-08 15:22:48.000000000 +0100
@@ -20,7 +20,7 @@
%bcond_with tests
Name: ghc-retry
-Version: 0.6
+Version: 0.7.0.1
Release: 0
Summary: Retry combinators for monadic actions that may fail
Group: System/Libraries
@@ -35,6 +35,7 @@
# Begin cabal-rpm deps:
BuildRequires: ghc-data-default-class-devel
BuildRequires: ghc-exceptions-devel
+BuildRequires: ghc-random-devel
BuildRequires: ghc-transformers-devel
%if %{with tests}
BuildRequires: ghc-HUnit-devel
++++++ retry-0.6.tar.gz -> retry-0.7.0.1.tar.gz ++++++
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.6/README.md new/retry-0.7.0.1/README.md
--- old/retry-0.6/README.md 1970-01-01 01:00:00.000000000 +0100
+++ new/retry-0.7.0.1/README.md 2015-11-15 01:28:27.000000000 +0100
@@ -0,0 +1,36 @@
+# README [](https://travis-ci.org/Soostone/retry)
[](https://coveralls.io/r/Soostone/retry?branch=master)
+
+retry - combinators for monadic actions that may fail
+
+## About
+
+Monadic action combinators that add delayed-retry functionality,
+potentially with exponential-backoff, to arbitrary actions.
+
+The main purpose of this package is to make it easy to work reliably
+with IO and similar actions that often fail. Common examples are
+database queries and large file uploads.
+
+
+## Documentation
+
+Please see haddocks for documentation.
+
+## Changes
+
+See [changelog.md](changelog.md).
+
+## Author
+
+Ozgun Ataman, Soostone Inc
+
+
+## Contributors
+
+Contributors, please list yourself here.
+
+- Mitsutoshi Aoe (@maoe)
+- John Wiegley
+- Michael Snoyman
+- Michael Xavier
+
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.6/changelog.md new/retry-0.7.0.1/changelog.md
--- old/retry-0.6/changelog.md 1970-01-01 01:00:00.000000000 +0100
+++ new/retry-0.7.0.1/changelog.md 2015-11-15 01:28:27.000000000 +0100
@@ -0,0 +1,49 @@
+0.7.0.1
+* Officially drop support for GHC < 7.6 due to usage of Generics.
+
+0.7
+* RetryPolicy has become RetryPolicyM, allowing for policy logic to
+ consult the monad context.
+* RetryPolicyM now takes a RetryStatus value. Use the function
+ rsIterNum to preserve existing behavior of RetryPolicy only
+ receiving the number.
+* The monadic action now gets the RetryStatus on each try. Use const
+ if you don't need it.
+* recoverAll explicitly does not handle the standard async
+ exceptions. Users are encouraged to do the same when using
+ recovering, as catching async exceptions can be hazardous.
+* We no longer re-export (<>) from Monoid.
+* Utility functions simulatePolicy and simulatePolicyPP have been
+ added which help predict how a policy will behave on each iteration.
+
+0.6
+
+* Actions are now retried in the original masking state, while
+ handlers continue to run in `MaskedInterruptible` (@maoe)
+* Added several tests confirming exception hierarchy semantics under
+ `recovering` (@ozataman)
+
+0.5
+
+* Mitsutoshi's backoff work inspired a complete redo of the
+ RetryPolicy interface, replacing it with a monoidal RetryPolicy. The
+ result is a much thinner API that actually provides much more power
+ to the end user.
+* Now using microseconds in all premade policies. PLEASE TAKE CARE
+ WHEN UPGRADING. It was a bad idea to use miliseconds and deviate
+ from norms in the first place.
+
+0.4
+
+* Transitioned to using Edward Kmett's exceptions package instead of
+ monad-control. Use 0.3 series if you still need monad-control
+ support.
+
+0.3
+
+Thanks to John Wiegley and Michael Snoyman for their contributions:
+
+* Now using monad-control instead of MonadCatchIO, which is widely
+ agreed to be broken.
+* Now using transformers instead of mtl, which was a broader than
+ needed dependency.
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.6/retry.cabal new/retry-0.7.0.1/retry.cabal
--- old/retry-0.6/retry.cabal 2015-03-03 20:33:00.000000000 +0100
+++ new/retry-0.7.0.1/retry.cabal 2015-11-15 01:28:27.000000000 +0100
@@ -1,6 +1,6 @@
name: retry
-description:
+description:
This package exposes combinators that can wrap arbitrary
monadic actions. They run the action and potentially retry
@@ -14,7 +14,7 @@
case we should hang back for a bit and retry the query instead
of simply raising an exception.
-version: 0.6
+version: 0.7.0.1
synopsis: Retry combinators for monadic actions that may fail
license: BSD3
license-file: LICENSE
@@ -24,14 +24,18 @@
category: Control
build-type: Simple
cabal-version: >=1.10
-Homepage: http://github.com/Soostone/retry
+homepage: http://github.com/Soostone/retry
+extra-source-files:
+ README.md
+ changelog.md
library
exposed-modules: Control.Retry
- build-depends:
- base ==4.*
+ build-depends:
+ base >= 4.6 && < 5
, data-default-class
, exceptions >= 0.5 && < 0.9
+ , random >= 1 && < 1.2
, transformers < 0.5
hs-source-dirs: src
default-language: Haskell2010
@@ -42,18 +46,15 @@
main-is: main.hs
hs-source-dirs: test,src
ghc-options: -threaded
- build-depends:
- base ==4.*
+ build-depends:
+ base ==4.*
, exceptions
, transformers
, data-default-class
+ , random
, time
- , QuickCheck >= 2.7 && < 2.8
+ , QuickCheck >= 2.7 && < 2.9
, HUnit >= 1.2.5.2 && < 1.3
, hspec >= 1.9
+ , stm
default-language: Haskell2010
-
-
-
-
-
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn'
'--exclude=.svnignore' old/retry-0.6/src/Control/Retry.hs
new/retry-0.7.0.1/src/Control/Retry.hs
--- old/retry-0.6/src/Control/Retry.hs 2015-03-03 20:33:00.000000000 +0100
+++ new/retry-0.7.0.1/src/Control/Retry.hs 2015-11-15 01:28:27.000000000
+0100
@@ -1,9 +1,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
@@ -30,9 +28,23 @@
module Control.Retry
(
- -- * High Level Operation
- RetryPolicy (..)
+ -- * Types and Operations
+ RetryPolicyM (..)
+ , RetryPolicy
+ , retryPolicy
+ , RetryStatus
+ -- ** Fields for 'RetryStatus'
+ , rsIterNumber
+ , rsCumulativeDelay
+ , rsPreviousDelay
+ , defaultRetryStatus
+
+ -- ** Lenses for 'RetryStatus'
+ , rsIterNumberL
+ , rsCumulativeDelayL
+ , rsPreviousDelayL
+ -- * Applying Retry Policies
, retrying
, recovering
, recoverAll
@@ -41,33 +53,51 @@
-- * Retry Policies
, constantDelay
, exponentialBackoff
+ , fullJitterBackoff
, fibonacciBackoff
, limitRetries
+
+ -- * Policy Transformers
, limitRetriesByDelay
, capDelay
- -- * Re-export from Data.Monoid
-
- , (<>)
-
+ -- * Development Helpers
+ , simulatePolicy
+ , simulatePolicyPP
) where
-------------------------------------------------------------------------------
+import Control.Applicative
+import Control.Arrow
import Control.Concurrent
+#if MIN_VERSION_base(4, 7, 0)
+import Control.Exception (AsyncException, SomeAsyncException)
+#else
+import Control.Exception (AsyncException)
+#endif
+import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.State
import Data.Default.Class
+import Data.Functor.Identity
+import Data.Maybe
+import GHC.Generics
+import System.Random
import Data.Monoid
import Prelude hiding (catch)
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
--- | A 'RetryPolicy' is a function that takes an iteration number and
--- possibly returns a delay in microseconds. *Nothing* implies we have
--- reached the retry limit.
+-- | A 'RetryPolicyM' is a function that takes an 'RetryStatus' and
+-- possibly returns a delay in microseconds. Iteration numbers start
+-- at zero and increase by one on each retry. A *Nothing* return value from
+-- the function implies we have reached the retry limit.
--
--- Please note that 'RetryPolicy' is a 'Monoid'. You can collapse
+-- Please note that 'RetryPolicyM' is a 'Monoid'. You can collapse
-- multiple strategies into one using 'mappend' or '<>'. The semantics
-- of this combination are as follows:
--
@@ -93,30 +123,87 @@
--
-- >> def = constantDelay 50000 <> limitRetries 5
--
--- For anything more complex, just define your own 'RetryPolicy':
+-- For anything more complex, just define your own 'RetryPolicyM':
+--
+-- >> myPolicy = retryPolicy $ \ rs -> if rsIterNumber n > 10 then Just 1000
else Just 10000
--
--- >> myPolicy = RetryPolicy $ \ n -> if n > 10 then Just 1000 else Just 10000
-newtype RetryPolicy = RetryPolicy { getRetryPolicy :: Int -> Maybe Int }
+-- Since 0.7.
+newtype RetryPolicyM m = RetryPolicyM { getRetryPolicyM :: RetryStatus -> m
(Maybe Int) }
+
+
+-- | Simplified 'RetryPolicyM' without any use of the monadic context in
+-- determining policy. Mostly maintains backwards compatitibility with
+-- type signatures pre-0.7.
+type RetryPolicy = forall m . Monad m => RetryPolicyM m
-instance Default RetryPolicy where
+instance Monad m => Default (RetryPolicyM m) where
def = constantDelay 50000 <> limitRetries 5
-instance Monoid RetryPolicy where
- mempty = RetryPolicy $ (const (Just 0))
- (RetryPolicy a) `mappend` (RetryPolicy b) = RetryPolicy $ \ n -> do
- a' <- a n
- b' <- b n
+
+instance Monad m => Monoid (RetryPolicyM m) where
+ mempty = retryPolicy $ const (Just 0)
+ (RetryPolicyM a) `mappend` (RetryPolicyM b) = RetryPolicyM $ \ n ->
runMaybeT $ do
+ a' <- MaybeT $ a n
+ b' <- MaybeT $ b n
return $! max a' b'
-------------------------------------------------------------------------------
+-- | Datatype with stats about retries made thus far. The constructor
+-- is deliberately not exported to make additional fields easier to
+-- add in a backward-compatible manner. To read or modify fields in
+-- RetryStatus, use the accessors or lenses below. Note that if you
+-- don't want to use lenses, the exported field names can be used for
+-- updates:
+--
+-- >> retryStatus { rsIterNumber = newIterNumber }
+-- >> retryStatus & rsIterNumberL .~ newIterNumber
+data RetryStatus = RetryStatus
+ { rsIterNumber :: !Int -- ^ Iteration number, where 0 is the first try
+ , rsCumulativeDelay :: !Int -- ^ Delay incurred so far from retries in
microseconds
+ , rsPreviousDelay :: !(Maybe Int) -- ^ Previous attempt's delay. Will
always be Nothing on first run.
+ } deriving (Show, Eq, Generic)
+
+
+-------------------------------------------------------------------------------
+-- | Initial, default retry status. Exported mostly to allow user code
+-- to test their handlers and retry policies. Use fields or lenses to update.
+defaultRetryStatus :: RetryStatus
+defaultRetryStatus = RetryStatus 0 0 Nothing
+
+-------------------------------------------------------------------------------
+rsIterNumberL :: Lens' RetryStatus Int
+rsIterNumberL = lens rsIterNumber (\rs x -> rs { rsIterNumber = x })
+{-# INLINE rsIterNumberL #-}
+
+
+-------------------------------------------------------------------------------
+rsCumulativeDelayL :: Lens' RetryStatus Int
+rsCumulativeDelayL = lens rsCumulativeDelay (\rs x -> rs { rsCumulativeDelay =
x })
+{-# INLINE rsCumulativeDelayL #-}
+
+
+-------------------------------------------------------------------------------
+rsPreviousDelayL :: Lens' RetryStatus (Maybe Int)
+rsPreviousDelayL = lens rsPreviousDelay (\rs x -> rs { rsPreviousDelay = x })
+{-# INLINE rsPreviousDelayL #-}
+
+
+-------------------------------------------------------------------------------
+-- | Helper for making simplified policies that don't use the monadic
+-- context.
+retryPolicy :: (RetryStatus -> Maybe Int) -> RetryPolicy
+retryPolicy f = RetryPolicyM $ \ s -> return (f s)
+
+
+-------------------------------------------------------------------------------
-- | Retry immediately, but only up to @n@ times.
limitRetries
:: Int
-- ^ Maximum number of retries.
-> RetryPolicy
-limitRetries i = RetryPolicy $ \ n -> if n >= i then Nothing else (Just 0)
+limitRetries i = retryPolicy $ \ RetryStatus { rsIterNumber = n} -> if n >= i
then Nothing else (Just 0)
-------------------------------------------------------------------------------
@@ -125,10 +212,11 @@
-- and fail.
limitRetriesByDelay
:: Int
- -- ^ Time-delay limit in microseconds.
+ -- ^ Time-delay limit in microseconds.
-> RetryPolicy
-> RetryPolicy
-limitRetriesByDelay i p = RetryPolicy $ \ n -> getRetryPolicy p n >>= limit
+limitRetriesByDelay i p = RetryPolicyM $ \ n ->
+ (>>= limit) `liftM` getRetryPolicyM p n
where
limit delay = if delay >= i then Nothing else Just delay
@@ -139,16 +227,33 @@
:: Int
-- ^ Base delay in microseconds
-> RetryPolicy
-constantDelay delay = RetryPolicy (const (Just delay))
+constantDelay delay = retryPolicy (const (Just delay))
-------------------------------------------------------------------------------
--- | Grow delay exponentially each iteration.
+-- | Grow delay exponentially each iteration. Each delay will
+-- increase by a factor of two.
exponentialBackoff
:: Int
- -- ^ Base delay in microseconds
+ -- ^ First delay in microseconds
-> RetryPolicy
-exponentialBackoff base = RetryPolicy $ \ n -> Just (2^n * base)
+exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n} ->
Just (2^n * base)
+
+
+-------------------------------------------------------------------------------
+-- | FullJitter exponential backoff as explained in AWS Architecture
+-- Blog article.
+--
+-- @http:\/\/www.awsarchitectureblog.com\/2015\/03\/backoff.html@
+--
+-- temp = min(cap, base * 2 ** attempt)
+--
+-- 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
+ rand <- liftIO $ randomRIO (0, d)
+ return $ Just $! d + rand
-------------------------------------------------------------------------------
@@ -157,7 +262,7 @@
:: Int
-- ^ Base delay in microseconds
-> RetryPolicy
-fibonacciBackoff base = RetryPolicy $ \ 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)
@@ -171,11 +276,13 @@
-- between each one. To get termination you need to use one of the
-- 'limitRetries' function variants.
capDelay
- :: Int
+ :: Monad m
+ => Int
-- ^ A maximum delay in microseconds
- -> RetryPolicy
- -> RetryPolicy
-capDelay limit p = RetryPolicy $ \ n -> min limit `fmap` (getRetryPolicy p) n
+ -> RetryPolicyM m
+ -> RetryPolicyM m
+capDelay limit p = RetryPolicyM $ \ n ->
+ (fmap (min limit)) `liftM` (getRetryPolicyM p) n
-------------------------------------------------------------------------------
@@ -187,7 +294,7 @@
-- retry it 5 additional times following the initial run:
--
-- >>> import Data.Maybe
--- >>> let f = putStrLn "Running action" >> return Nothing
+-- >>> let f _ = putStrLn "Running action" >> return Nothing
-- >>> retrying def (const $ return . isNothing) f
-- Running action
-- Running action
@@ -199,38 +306,46 @@
--
-- Note how the latest failing result is returned after all retries
-- have been exhausted.
-retrying :: MonadIO m
- => RetryPolicy
- -> (Int -> b -> m Bool)
- -- ^ An action to check whether the result should be retried.
- -- If True, we delay and retry the operation.
- -> m b
- -- ^ Action to run
- -> m b
-retrying (RetryPolicy policy) chk f = go 0
- where
- go n = do
- res <- f
- chk' <- chk n res
- case chk' of
- True ->
- case (policy n) of
- Just delay -> do
- liftIO (threadDelay delay)
- go $! n+1
- Nothing -> return res
- False -> return res
-
+retrying :: MonadIO m
+ => RetryPolicyM m
+ -> (RetryStatus -> b -> m Bool)
+ -- ^ An action to check whether the result should be retried.
+ -- If True, we delay and retry the operation.
+ -> (RetryStatus -> m b)
+ -- ^ Action to run
+ -> m b
+retrying (RetryPolicyM policy) chk f = go defaultRetryStatus
+ where
+ go s = do
+ res <- f s
+ chk' <- chk s res
+ case chk' of
+ True -> do
+ chk <- policy s
+ case chk of
+ Just delay -> do
+ liftIO (threadDelay delay)
+ go $! RetryStatus { rsIterNumber = rsIterNumber s + 1
+ , rsCumulativeDelay = rsCumulativeDelay s +
delay
+ , rsPreviousDelay = Just (maybe 0 (const
delay) (rsPreviousDelay s))}
+ Nothing -> return res
+ False -> return res
-------------------------------------------------------------------------------
-- | Retry ALL exceptions that may be raised. To be used with caution;
--- this matches the exception on 'SomeException'.
+-- this matches the exception on 'SomeException'. Note that this
+-- handler explicitly does not handle 'AsyncException' nor
+-- 'SomeAsyncException' (for versions of base >= 4.7). It is not a
+-- good idea to catch async exceptions as it can result in hanging
+-- threads and programs. Note that if you just throw an exception to
+-- this thread that does not descend from SomeException, recoverAll
+-- will catch it.
--
-- See how the action below is run once and retried 5 more times
-- before finally failing for good:
--
--- >>> let f = putStrLn "Running action" >> error "this is an error"
+-- >>> let f _ = putStrLn "Running action" >> error "this is an error"
-- >>> recoverAll def f
-- Running action
-- Running action
@@ -245,52 +360,71 @@
#else
:: (MonadIO m, MonadCatch m)
#endif
- => RetryPolicy
- -> m a
+ => RetryPolicyM m
+ -> (RetryStatus -> m a)
-> m a
-recoverAll set f = recovering set [h] f
+recoverAll set f = recovering set handlers f
where
+#if MIN_VERSION_base(4, 7, 0)
+ someAsyncH _ = Handler $ \(_ :: SomeAsyncException) -> return False
+ handlers = [asyncH, someAsyncH, h]
+#else
+ handlers = [asyncH, h]
+#endif
+ asyncH _ = Handler $ \ (_ :: AsyncException) -> return False
h _ = Handler $ \ (_ :: SomeException) -> return True
-------------------------------------------------------------------------------
-- | Run an action and recover from a raised exception by potentially
--- retrying the action a number of times.
+-- retrying the action a number of times. Note that if you're going to
+-- use a handler for 'SomeException', you should add explicit cases
+-- *earlier* in the list of handlers to reject 'AsyncException' and
+-- 'SomeAsyncException', as catching these can cause thread and
+-- program hangs. 'recoverAll' already does this for you so if you
+-- just plan on catching 'SomeException', you may as well ues
+-- 'recoverAll'
recovering
#if MIN_VERSION_exceptions(0, 6, 0)
:: (MonadIO m, MonadMask m)
#else
:: (MonadIO m, MonadCatch m)
#endif
- => RetryPolicy
+ => RetryPolicyM m
-- ^ Just use 'def' for default settings
- -> [(Int -> Handler m Bool)]
+ -> [(RetryStatus -> Handler m Bool)]
-- ^ Should a given exception be retried? Action will be
- -- retried if this returns True.
- -> m a
+ -- retried if this returns True *and* the policy allows it.
+ -- This action will be consulted first even if the policy
+ -- later blocks it.
+ -> (RetryStatus -> m a)
-- ^ Action to perform
-> m a
-recovering (RetryPolicy policy) hs f = mask $ \restore -> go restore 0
+recovering p@(RetryPolicyM policy) hs f = mask $ \restore -> go restore
defaultRetryStatus
where
go restore = loop
where
- loop n = do
- r <- try $ restore f
+ loop s = do
+ r <- try $ restore (f s)
case r of
Right x -> return x
Left e -> recover (e :: SomeException) hs
where
recover e [] = throwM e
- recover e ((($ n) -> Handler h) : hs')
+ recover e ((($ s) -> Handler h) : hs')
| Just e' <- fromException e = do
chk <- h e'
- if chk
- then case policy n of
- Just delay -> do
- liftIO $ threadDelay delay
- loop $! n+1
- Nothing -> throwM e'
- else throwM e'
+ case chk of
+ True -> do
+ res <- policy s
+ case res of
+ Just delay -> do
+ liftIO $ threadDelay delay
+ loop $! RetryStatus { rsIterNumber = rsIterNumber
s + 1
+ , rsCumulativeDelay =
rsCumulativeDelay s + delay
+ , rsPreviousDelay = Just
(maybe 0 (const delay) (rsPreviousDelay s))}
+ Nothing -> throwM e'
+ False -> throwM e'
| otherwise = recover e hs'
@@ -301,17 +435,65 @@
:: (Monad m, Show e, Exception e)
=> (e -> m Bool)
-- ^ Test for whether action is to be retried
- -> (String -> m ())
- -- ^ How to report the generated warning message.
- -> Int
+ -> (Bool -> String -> 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 n = Handler $ \ e -> do
+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 msg
+ report res msg
return res
+ where n = rsIterNumber s
+
+
+-------------------------------------------------------------------------------
+-- | 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
+-- delay in microseconds.
+simulatePolicy :: Monad m => Int -> RetryPolicyM m -> m [(Int, Maybe Int)]
+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}
+ return (i, delay)
+
+
+-------------------------------------------------------------------------------
+-- | Run given policy up to N iterations and pretty print results on
+-- the console.
+simulatePolicyPP :: Int -> RetryPolicyM IO -> IO ()
+simulatePolicyPP n p = do
+ ps <- simulatePolicy n p
+ forM_ ps $ \ (n, res) -> putStrLn $
+ show n <> ": " <> maybe "Inhibit" ppTime res
+ putStrLn $ "Total cumulative delay would be: " <>
+ (ppTime $ sum $ (mapMaybe snd) ps)
+
+
+-------------------------------------------------------------------------------
+ppTime :: (Integral a, Show a) => a -> String
+ppTime n | n < 1000 = show n <> "us"
+ | n < 1000000 = show (fromIntegral n / 1000) <> "ms"
+ | otherwise = show (fromIntegral n / 1000) <> "ms"
+
+
+-------------------------------------------------------------------------------
+-- Lens machinery
+-------------------------------------------------------------------------------
+-- Unexported type aliases to clean up the documentation
+type Lens s t a b = forall f. Functor f => (a -> f b) -> s -> f t
+
+type Lens' s a = Lens s s a a
+
+
+-------------------------------------------------------------------------------
+lens :: (s -> a) -> (s -> b -> t) -> Lens s t a b
+lens sa sbt afb s = sbt s <$> afb (sa s)
+{-# INLINE lens #-}
------------------
