From: Clint Adams Date: Thu, 4 Aug 2016 17:39:45 +0000 (+0100) Subject: Import haskell-retry_0.7.4.1.orig.tar.gz X-Git-Tag: archive/raspbian/0.9.2.1-1+rpi1~1^2^2^2~1 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=eb8184f95a086297a783ea47684ddfcad345715c;p=haskell-retry.git Import haskell-retry_0.7.4.1.orig.tar.gz [dgit import orig haskell-retry_0.7.4.1.orig.tar.gz] --- eb8184f95a086297a783ea47684ddfcad345715c diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f42500f --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Ozgun Ataman + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ozgun Ataman nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..0365dbf --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +# 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) + +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 [https://github.com/Soostone/retry/blob/master/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 --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 index 0000000..2d17602 --- /dev/null +++ b/changelog.md @@ -0,0 +1,68 @@ +0.7.4.1 +* Loosen QuickCheck dependency for tests. + +0.7.4 +* Widen transformers dependency + +0.7.3 +* Widen ghc-prim dependency for GHC 8 + +0.7.2 +* Fix premature integer overflow error thanks to Mitsutoshi Aoe + +0.7.1 +* Various documentation updates. +* Add stepping combinator for manual retries. +* Add applyPolicy and applyAndDelay +* Add Read instance for RetryStatus +* Fix logic bug in rsPreviousDelay in first retry + +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 --git a/retry.cabal b/retry.cabal new file mode 100644 index 0000000..e9eb254 --- /dev/null +++ b/retry.cabal @@ -0,0 +1,63 @@ +name: retry + +description: + + This package exposes combinators that can wrap arbitrary + monadic actions. They run the action and potentially retry + running it with some configurable delay for a configurable + number of times. + + The purpose is to make it easier to work with IO and + especially network IO actions that often experience temporary + failure and warrant retrying of the original action. For + example, a database query may time out for a while, in which + case we should hang back for a bit and retry the query instead + of simply raising an exception. + +version: 0.7.4.1 +synopsis: Retry combinators for monadic actions that may fail +license: BSD3 +license-file: LICENSE +author: Ozgun Ataman +maintainer: ozgun.ataman@soostone.com +copyright: Ozgun Ataman, Soostone Inc +category: Control +build-type: Simple +cabal-version: >=1.10 +homepage: http://github.com/Soostone/retry +extra-source-files: + README.md + changelog.md + +library + exposed-modules: Control.Retry + build-depends: + base >= 4.6 && < 5 + , data-default-class + , exceptions >= 0.5 && < 0.9 + , ghc-prim < 0.6 + , random >= 1 && < 1.2 + , transformers < 0.7 + hs-source-dirs: src + default-language: Haskell2010 + + +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test,src + ghc-options: -threaded + build-depends: + base ==4.* + , exceptions + , transformers + , data-default-class + , random + , time + , QuickCheck >= 2.7 && < 2.10 + , 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 new file mode 100644 index 0000000..db7bde6 --- /dev/null +++ b/src/Control/Retry.hs @@ -0,0 +1,656 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ViewPatterns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Retry +-- Copyright : Ozgun Ataman +-- License : BSD3 +-- +-- Maintainer : Ozgun Ataman +-- Stability : provisional +-- +-- This module exposes combinators that can wrap arbitrary monadic +-- actions. They run the action and potentially retry running it with +-- some configurable delay for a configurable number of times. +-- +-- The express purpose of this library is to make it easier to work +-- with IO and especially network IO actions that often experience +-- temporary failure that warrant retrying of the original action. For +-- example, a database query may time out for a while, in which case +-- we should delay a bit and retry the query. +---------------------------------------------------------------------------- + + +module Control.Retry + ( + -- * Types and Operations + RetryPolicyM (..) + , RetryPolicy + , retryPolicy + , RetryStatus (..) + , defaultRetryStatus + , applyPolicy + , applyAndDelay + + + -- ** Lenses for 'RetryStatus' + , rsIterNumberL + , rsCumulativeDelayL + , rsPreviousDelayL + + -- * Applying Retry Policies + , retrying + , recovering + , stepping + , recoverAll + , logRetries + , defaultLogMsg + + -- * Retry Policies + , constantDelay + , exponentialBackoff + , fullJitterBackoff + , fibonacciBackoff + , limitRetries + + -- * Policy Transformers + , limitRetriesByDelay + , capDelay + + -- * 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.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) +------------------------------------------------------------------------------- + + +------------------------------------------------------------------------------- +-- | 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 'RetryPolicyM' is a 'Monoid'. You can collapse +-- multiple strategies into one using 'mappend' or '<>'. The semantics +-- of this combination are as follows: +-- +-- 1. If either policy returns 'Nothing', the combined policy returns +-- 'Nothing'. This can be used to @inhibit@ after a number of retries, +-- for example. +-- +-- 2. If both policies return a delay, the larger delay will be used. +-- This is quite natural when combining multiple policies to achieve a +-- certain effect. +-- +-- Example: +-- +-- One can easily define an exponential backoff policy with a limited +-- number of retries: +-- +-- >> limitedBackoff = exponentialBackoff 50 <> limitRetries 5 +-- +-- Naturally, 'mempty' will retry immediately (delay 0) for an +-- unlimited number of retries, forming the identity for the 'Monoid'. +-- +-- The default under 'def' implements a constant 50ms delay, up to 5 times: +-- +-- >> def = constantDelay 50000 <> limitRetries 5 +-- +-- For anything more complex, just define your own 'RetryPolicyM': +-- +-- >> myPolicy = retryPolicy $ \ rs -> if rsIterNumber n > 10 then Just 1000 else Just 10000 +-- +-- 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 Monad m => Default (RetryPolicyM m) where + def = constantDelay 50000 <> limitRetries 5 + + +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) -- ^ Latest attempt's delay. Will always be Nothing on first run. + } deriving (Read, 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 #-} + + + +------------------------------------------------------------------------------- +-- | Apply policy on status to see what the decision would be. +-- 'Nothing' implies no retry, 'Just' returns updated status. +applyPolicy + :: Monad m + => RetryPolicyM m + -> RetryStatus + -> m (Maybe RetryStatus) +applyPolicy (RetryPolicyM policy) s = do + res <- policy s + case res of + Just delay -> return $! Just $! RetryStatus + { rsIterNumber = rsIterNumber s + 1 + , rsCumulativeDelay = rsCumulativeDelay s `boundedPlus` delay + , rsPreviousDelay = Just delay } + Nothing -> return Nothing + + +------------------------------------------------------------------------------- +-- | Apply policy and delay by its amount if it results in a retry. +-- Return updated status. +applyAndDelay + :: MonadIO m + => RetryPolicyM m + -> RetryStatus + -> m (Maybe RetryStatus) +applyAndDelay policy s = do + chk <- applyPolicy policy s + case chk of + Just rs -> do + case (rsPreviousDelay rs) of + Nothing -> return () + Just delay -> liftIO $ threadDelay delay + return (Just rs) + Nothing -> return Nothing + + + +------------------------------------------------------------------------------- +-- | 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 $ \ RetryStatus { rsIterNumber = n} -> if n >= i then Nothing else (Just 0) + + +------------------------------------------------------------------------------- +-- | Add an upperbound to a policy such that once the given time-delay +-- amount has been reached or exceeded, the policy will stop retrying +-- and fail. +limitRetriesByDelay + :: Int + -- ^ Time-delay limit in microseconds. + -> RetryPolicy + -> RetryPolicy +limitRetriesByDelay i p = RetryPolicyM $ \ n -> + (>>= limit) `liftM` getRetryPolicyM p n + where + limit delay = if delay >= i then Nothing else Just delay + + +------------------------------------------------------------------------------- +-- | Implement a constant delay with unlimited retries. +constantDelay + :: Int + -- ^ Base delay in microseconds + -> RetryPolicy +constantDelay delay = retryPolicy (const (Just delay)) + + +------------------------------------------------------------------------------- +-- | Grow delay exponentially each iteration. Each delay will +-- increase by a factor of two. +exponentialBackoff + :: Int + -- ^ First delay in microseconds + -> RetryPolicy +exponentialBackoff base = retryPolicy $ \ RetryStatus { rsIterNumber = n } -> + Just $! base `boundedMult` boundedPow 2 n + +------------------------------------------------------------------------------- +-- | 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 = (base `boundedMult` boundedPow 2 n) `div` 2 + rand <- liftIO $ randomRIO (0, d) + return $! Just $! d `boundedPlus` rand + + +------------------------------------------------------------------------------- +-- | Implement Fibonacci backoff. +fibonacciBackoff + :: Int + -- ^ Base delay in microseconds + -> RetryPolicy +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 `boundedPlus` b) + + +------------------------------------------------------------------------------- +-- | Set a time-upperbound for any delays that may be directed by the +-- given policy. This function does not terminate the retrying. The policy +-- `capDelay maxDelay (exponentialBackoff n)` will never stop retrying. It +-- will reach a state where it retries forever with a delay of `maxDelay` +-- between each one. To get termination you need to use one of the +-- 'limitRetries' function variants. +capDelay + :: Monad m + => Int + -- ^ A maximum delay in microseconds + -> RetryPolicyM m + -> RetryPolicyM m +capDelay limit p = RetryPolicyM $ \ n -> + (fmap (min limit)) `liftM` (getRetryPolicyM p) n + + +------------------------------------------------------------------------------- +-- | Retry combinator for actions that don't raise exceptions, but +-- signal in their type the outcome has failed. Examples are the +-- 'Maybe', 'Either' and 'EitherT' monads. +-- +-- Let's write a function that always fails and watch this combinator +-- retry it 5 additional times following the initial run: +-- +-- >>> import Data.Maybe +-- >>> let f _ = putStrLn "Running action" >> return Nothing +-- >>> retrying def (const $ return . isNothing) f +-- Running action +-- Running action +-- Running action +-- Running action +-- Running action +-- Running action +-- Nothing +-- +-- Note how the latest failing result is returned after all retries +-- have been exhausted. +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 policy chk f = go defaultRetryStatus + where + go s = do + res <- f s + chk' <- chk s res + case chk' of + True -> do + rs <- applyAndDelay policy s + case rs of + Nothing -> return res + Just rs' -> go $! rs' + False -> return res + + +------------------------------------------------------------------------------- +-- | Retry ALL exceptions that may be raised. To be used with caution; +-- 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" +-- >>> recoverAll def f +-- Running action +-- Running action +-- Running action +-- Running action +-- Running action +-- Running action +-- *** Exception: this is an error +recoverAll +#if MIN_VERSION_exceptions(0, 6, 0) + :: (MonadIO m, MonadMask m) +#else + :: (MonadIO m, MonadCatch m) +#endif + => RetryPolicyM m + -> (RetryStatus -> m a) + -> m a +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. 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 + => RetryPolicyM m + -- ^ Just use 'def' for default settings + -> [(RetryStatus -> Handler m Bool)] + -- ^ Should a given exception be retried? Action will be + -- 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 policy hs f = mask $ \restore -> go restore defaultRetryStatus + where + go restore = loop + where + 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 ((($ s) -> Handler h) : hs') + | Just e' <- fromException e = do + chk <- h e' + case chk of + True -> do + rs <- applyAndDelay policy s + case rs of + Just rs' -> loop $! rs' + Nothing -> throwM e' + False -> throwM e' + | otherwise = recover e hs' + + + +------------------------------------------------------------------------------- +-- | A version of 'recovering' that tries to run the action only a +-- single time. The control will return immediately upon both success +-- and failure. Useful for implementing retry logic in distributed +-- queues and similar external-interfacing systems. +stepping +#if MIN_VERSION_exceptions(0, 6, 0) + :: (MonadIO m, MonadMask m) +#else + :: (MonadIO m, MonadCatch m) +#endif + => RetryPolicyM m + -- ^ Just use 'def' for default settings + -> [(RetryStatus -> Handler m Bool)] + -- ^ Should a given exception be retried? Action will be + -- 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 ()) + -- ^ Action to run with updated status upon failure. + -> (RetryStatus -> m a) + -- ^ Main action to perform with current status. + -> RetryStatus + -- ^ Current status of this step + -> m (Maybe a) +stepping policy hs schedule f s = do + r <- try $ f s + case r of + Right x -> return $ Just x + Left e -> recover (e :: SomeException) hs + where + recover e [] = throwM e + recover e ((($ s) -> Handler h) : hs') + | Just e' <- fromException e = do + chk <- h e' + case chk of + True -> do + res <- applyPolicy policy s + case res of + Just rs -> do + schedule $! rs + return Nothing + Nothing -> throwM e' + False -> throwM e' + | otherwise = recover e hs' + + +------------------------------------------------------------------------------- +-- | Helper function for constructing handler functions of the form required +-- by 'recovering'. +logRetries + :: (Monad m, Show e, Exception e) + => (e -> m Bool) + -- ^ Test for whether action is to be retried + -> (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 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 +-- 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 `boundedPlus` fromMaybe 0 delay + , rsPreviousDelay = 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 $ boundedSum $ (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" + +------------------------------------------------------------------------------- +-- 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 +------------------------------------------------------------------------------- +-- 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 #-} + + + ------------------ + -- Simple Tests -- + ------------------ + + + +-- data TestException = TestException deriving (Show, Typeable) +-- data AnotherException = AnotherException deriving (Show, Typeable) + +-- instance Exception TestException +-- instance Exception AnotherException + + +-- test = retrying def [h1,h2] f +-- where +-- f = putStrLn "Running action" >> throwM AnotherException +-- h1 = Handler $ \ (e :: TestException) -> return False +-- h2 = Handler $ \ (e :: AnotherException) -> return True diff --git a/test/main.hs b/test/main.hs new file mode 100644 index 0000000..038e7c8 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,2 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} +