retry 0.9.1.0 → 0.9.2.0
raw patch · 5 files changed
+60/−10 lines, 5 filesdep +mtl-compatdep ~hedgehogdep ~mtl
Dependencies added: mtl-compat
Dependency ranges changed: hedgehog, mtl
Files
- README.md +1/−3
- changelog.md +3/−0
- retry.cabal +5/−2
- src/Control/Retry.hs +30/−3
- test/Tests/Control/Retry.hs +21/−2
README.md view
@@ -11,7 +11,6 @@ with IO and similar actions that often fail. Common examples are database queries and large file uploads. - ## Documentation Please see haddocks for documentation.@@ -24,7 +23,6 @@ Ozgun Ataman, Soostone Inc - ## Contributors Contributors, please list yourself here.@@ -33,5 +31,5 @@ - John Wiegley - Michael Snoyman - Michael Xavier+- Toralf Wittner - Marco Zocca (@ocramz)-
changelog.md view
@@ -1,3 +1,6 @@+0.9.2.0+* Add `retryOnError` [PR 44](https://github.com/Soostone/retry/pull/44)+ 0.9.1.0 * Add resumable retry/recover variants: * `resumeRetrying`
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.9.1.0+version: 0.9.2.0 synopsis: Retry combinators for monadic actions that may fail license: BSD3 license-file: LICENSE@@ -41,6 +41,8 @@ , ghc-prim , random >= 1 , transformers+ , mtl+ , mtl-compat hs-source-dirs: src default-language: Haskell2010 @@ -67,10 +69,11 @@ , tasty , tasty-hunit , tasty-hedgehog- , hedgehog+ , hedgehog >= 1.0 , stm , ghc-prim , mtl+ , mtl-compat default-language: Haskell2010 if flag(lib-Werror)
src/Control/Retry.hs view
@@ -4,6 +4,7 @@ {-# LANGUAGE MagicHash #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE ViewPatterns #-} @@ -59,6 +60,7 @@ , skipAsyncExceptions , logRetries , defaultLogMsg+ , retryOnError -- ** Resumable variants , resumeRetrying , resumeRetryingDynamic@@ -93,8 +95,8 @@ #endif import Control.Monad import Control.Monad.Catch-import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import Control.Monad.Except+import Control.Monad.IO.Class as MIO import Control.Monad.Trans.Maybe import Control.Monad.Trans.State import Data.List (foldl')@@ -280,7 +282,7 @@ -- | Apply policy and delay by its amount if it results in a retry. -- Return updated status. applyAndDelay- :: MonadIO m+ :: MIO.MonadIO m => RetryPolicyM m -> RetryStatus -> m (Maybe RetryStatus)@@ -814,6 +816,31 @@ where iter = show $ rsIterNumber status nextMsg = if shouldRetry then "Retrying." else "Crashing."+++-------------------------------------------------------------------------------+retryOnError+ :: (Functor m, MonadIO m, MonadError e m)+ => RetryPolicyM m+ -- ^ Policy+ -> (RetryStatus -> e -> m Bool)+ -- ^ Should an error be retried?+ -> (RetryStatus -> m a)+ -- ^ Action to perform+ -> m a+retryOnError policy chk f = go defaultRetryStatus+ where+ go stat = do+ res <- (Right <$> f stat) `catchError` (\e -> Left . (e, ) <$> chk stat e)+ case res of+ Right x -> return x+ Left (e, True) -> do+ mstat' <- applyAndDelay policy stat+ case mstat' of+ Just stat' -> do+ go $! stat'+ Nothing -> throwError e+ Left (e, False) -> throwError e -------------------------------------------------------------------------------
test/Tests/Control/Retry.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-} module Tests.Control.Retry ( tests ) where@@ -12,8 +13,9 @@ import Control.Concurrent.STM as STM import qualified Control.Exception as EX import Control.Monad.Catch+import Control.Monad.Except import Control.Monad.Identity-import Control.Monad.IO.Class+import Control.Monad.IO.Class as MIO import Control.Monad.Writer.Strict import Data.Either import Data.IORef@@ -48,6 +50,7 @@ , limitRetriesByCumulativeDelayTests , overridingDelayTests , resumableTests+ , retryOnErrorTests ] @@ -451,6 +454,22 @@ -------------------------------------------------------------------------------+retryOnErrorTests :: TestTree+retryOnErrorTests = testGroup "retryOnError"+ [ testCase "passes in the error type" $ do+ errCalls <- newTVarIO []+ let policy = limitRetries 2+ let shouldWeRetry _retryStat e = do+ liftIO (atomically (modifyTVar' errCalls (++ [e])))+ return True+ let action rs = (throwError ("boom" ++ show (rsIterNumber rs)))+ res <- runExceptT (retryOnError policy shouldWeRetry action)+ res @?= (Left "boom2" :: Either String ())+ calls <- atomically (readTVar errCalls)+ calls @?= ["boom0", "boom1", "boom2"]+ ]++------------------------------------------------------------------------------- nextStatusUsingPolicy :: RetryPolicyM IO -> RetryStatus -> IO RetryStatus nextStatusUsingPolicy policy status = do applyPolicy policy status >>= \case@@ -513,7 +532,7 @@ ------------------------------------------------------------------------------- -- | Generate an arbitrary 'RetryPolicy' without any limits applied. genPolicyNoLimit- :: forall mg mr. (MonadGen mg, MonadIO mr)+ :: forall mg mr. (MonadGen mg, MIO.MonadIO mr) => Range Int -> mg (RetryPolicyM mr) genPolicyNoLimit durationRange =