diff --git a/src/Stamina.hs b/src/Stamina.hs index a7c75f2..de62973 100644 --- a/src/Stamina.hs +++ b/src/Stamina.hs @@ -14,13 +14,13 @@ module Stamina ) where -import Control.Concurrent (isEmptyMVar, newMVar, tryPutMVar) +import Control.Concurrent (isEmptyMVar, newEmptyMVar, threadDelay, tryPutMVar) import Control.Exception (Exception (..), SomeAsyncException (SomeAsyncException), SomeException, throwIO) import Control.Monad (void) import Control.Monad.Catch (MonadCatch, throwM, try) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Maybe (isJust) -import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime, secondsToNominalDiffTime) +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime, nominalDiffTimeToSeconds, secondsToNominalDiffTime) import System.Random (randomRIO) -- | Settings for the retry functions. @@ -28,7 +28,7 @@ data RetrySettings = RetrySettings { initialRetryStatus :: RetryStatus, -- Initial status of the retry, useful to override when resuming a retry maxAttempts :: Maybe Int, -- Maximum number of attempts. Can be combined with a timeout. Default to 10. maxTime :: Maybe NominalDiffTime, -- Maximum time for all retries. Can be combined with attempts. Default to 60s. - backoffMaxRetryDelay :: NominalDiffTime, -- Maximum backoff between retries at any time. Default to 5s. + backoffMaxRetryDelay :: Maybe NominalDiffTime, -- Maximum backoff between retries at any time. Default to 60s. backoffJitter :: Double, -- Maximum jitter that is added to retry back-off delays (the actual jitter added is a random number between 0 and backoffJitter). Defaults to 1.0. backoffExpBase :: Double -- The exponential base used to compute the retry backoff. Defaults to 2.0. } @@ -57,7 +57,7 @@ defaults = }, maxAttempts = Just 10, maxTime = Just $ secondsToNominalDiffTime 60, - backoffMaxRetryDelay = 5.0, + backoffMaxRetryDelay = Just $ secondsToNominalDiffTime 60.0, backoffJitter = 1.0, backoffExpBase = 2.0 } @@ -67,16 +67,23 @@ data RetryAction | Retry -- Retry with the delay according to the settings. | RetryDelay NominalDiffTime -- Retry after the given delay. | RetryTime UTCTime -- Retry after the given time. + deriving (Show, Eq) -- | Retry on all sync exceptions, async exceptions will still be thrown. -- The backoff delays between retries grow exponentially plus a random jitter. -- The backoff for retry attempt number _attempt_ is computed as: -- --- backoffInitial * backoffExpBase ** (attempt - 1) + random(0, backoffJitter) +-- backoffExpBase ** (attempt - 1) + random(0, backoffJitter) +-- +-- With the default values, the backoff for the first 5 attempts will be: +-- +-- 2 ** 0 + random(0, 1) = 1 + random(0, 1) +-- 2 ** 1 + random(0, 1) = 2 + random(0, 1) +-- 2 ** 2 + random(0, 1) = 4 + random(0, 1) +-- 2 ** 3 + random(0, 1) = 8 + random(0, 1) +-- 2 ** 4 + random(0, 1) = 16 + random(0, 1) -- --- Since x**0 is always 1, the first backoff is within the interval [backoff_initial,backoff_initial+backoff_jitter]. Thus, with default values between 0.1 and 1.1 seconds. - -- If all retries fail, the last exception is let through. retry :: (MonadCatch m, MonadIO m) => RetrySettings -> (RetryStatus -> m a) -> m a retry settings = retryFor settings skipAsyncExceptions @@ -96,7 +103,7 @@ retryFor :: retryFor settings handler action = initialize >>= go where initialize = do - resetMVar <- liftIO $ newMVar () + resetMVar <- liftIO $ newEmptyMVar let retryStatus = (initialRetryStatus settings) {resetInitial = void $ tryPutMVar resetMVar ()} return (retryStatus, resetMVar) -- go :: (MonadCatch m, MonadIO m) => RetryStatus -> m a @@ -117,10 +124,12 @@ retryFor settings handler action = initialize >>= go RetryDelay delay_ -> return delay_ RetryTime time -> liftIO $ diffUTCTime time <$> getCurrentTime let RetrySettings {maxTime, maxAttempts} = settings - if (isJust maxTime && Just (totalDelay retryStatus + delay_) > maxTime) - || (isJust maxAttempts && Just (attempts retryStatus + 1) > maxAttempts) + if (isJust maxTime && Just (totalDelay newRetryStatus + delay_) > maxTime) + || (isJust maxAttempts && Just (attempts newRetryStatus) == maxAttempts) then throwM exception - else go (updateRetryStatus retryStatus delay_ $ toException exception, newResetMVar) + else do + liftIO $ threadDelay $ round $ 1000 * 1000 * (nominalDiffTimeToSeconds delay_) + go (updateRetryStatus newRetryStatus delay_ $ toException exception, newResetMVar) updateRetryStatus :: RetryStatus -> NominalDiffTime -> SomeException -> RetryStatus updateRetryStatus status delay_ exception = @@ -136,7 +145,8 @@ retryFor settings handler action = initialize >>= go let RetryStatus {attempts} = retryStatus let RetrySettings {backoffMaxRetryDelay, backoffJitter, backoffExpBase} = settings jitter <- randomRIO (0, backoffJitter) - return $ min backoffMaxRetryDelay $ secondsToNominalDiffTime $ realToFrac $ backoffExpBase ** (fromIntegral attempts - 1) + jitter + let delay = secondsToNominalDiffTime $ realToFrac $ backoffExpBase ** (fromIntegral attempts - 1) + jitter + return $ maybe delay (min delay) backoffMaxRetryDelay -- | Escalate an Either to an exception by converting the Left value to an exception. escalateWith :: (Exception exc) => (err -> exc) -> Either err a -> IO a diff --git a/stamina.cabal b/stamina.cabal index 928e6e0..817b7ea 100644 --- a/stamina.cabal +++ b/stamina.cabal @@ -31,7 +31,12 @@ test-suite stamina-test main-is: Main.hs build-depends: base, - stamina + stamina, + hspec, + mtl, + exceptions, + time, + http-client -- typechecks README during CI but doesn't run it executable readme diff --git a/test/Main.hs b/test/Main.hs index 3e2059e..f2dcd80 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,76 @@ module Main (main) where +import Control.Exception (fromException, try) +import Control.Monad.Catch (throwM) +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Time.Clock (secondsToNominalDiffTime) +import Network.HTTP.Client qualified as HTTP +import Stamina qualified +import Stamina.HTTP qualified +import Test.Hspec + main :: IO () -main = putStrLn "Test suite not yet implemented." +main = hspec $ do + describe "Stamina" $ do + it "should be able to retry until it recovers" $ do + lastStatus <- newIORef $ Stamina.initialRetryStatus Stamina.defaults + result <- Stamina.retry Stamina.defaults $ \status -> do + if Stamina.attempts status < 5 + then throwM $ userError "error" + else do + writeIORef lastStatus status + return "ok" + result `shouldBe` "ok" + status <- readIORef lastStatus + Stamina.attempts status `shouldBe` 5 + Stamina.totalDelay status `shouldSatisfy` (> secondsToNominalDiffTime 8) + it "should be able to retry until maxAttemps" $ do + lastStatus <- newIORef $ Stamina.initialRetryStatus Stamina.defaults + result <- try $ Stamina.retry (Stamina.defaults {Stamina.maxAttempts = Just 2}) $ \status -> do + writeIORef lastStatus status + throwM $ userError "error" + (result :: Either IOError String) `shouldBe` Left (userError "error") + status <- readIORef lastStatus + Stamina.attempts status `shouldBe` 2 + Stamina.totalDelay status `shouldSatisfy` (< secondsToNominalDiffTime 5) + it "should be able to retry until maxTime" $ do + lastStatus <- newIORef $ Stamina.initialRetryStatus Stamina.defaults + result <- try $ Stamina.retry (Stamina.defaults {Stamina.maxTime = Just $ secondsToNominalDiffTime 2}) $ \status -> do + writeIORef lastStatus status + throwM $ userError "error" + (result :: Either IOError String) `shouldBe` Left (userError "error") + status <- readIORef lastStatus + Stamina.attempts status `shouldBe` 1 + Stamina.totalDelay status `shouldSatisfy` (< secondsToNominalDiffTime 3) + it "should respect resetInitial the retry status" $ do + lastStatus <- newIORef $ Stamina.initialRetryStatus Stamina.defaults + result <- Stamina.retry Stamina.defaults $ \status -> do + if Stamina.attempts status < 3 + && (Stamina.lastException status >>= fromException) /= Just (userError "error2") + then throwM $ userError "error1" + else + if (Stamina.lastException status >>= fromException) == Just (userError "error1") + then do + Stamina.resetInitial status + throwM $ userError "error2" + else do + writeIORef lastStatus status + return "ok" + result `shouldBe` "ok" + status <- readIORef lastStatus + Stamina.attempts status `shouldBe` 1 + Stamina.totalDelay status `shouldSatisfy` (< secondsToNominalDiffTime 2) + + describe "Stamina.HTTP" $ do + it "should be able to retry on http exceptions until IO exception" $ do + lastStatus <- newIORef $ Stamina.initialRetryStatus Stamina.defaults + result <- try $ Stamina.HTTP.retry Stamina.defaults $ \status -> do + writeIORef lastStatus status + if Stamina.attempts status < 3 + then throwM $ HTTP.HttpExceptionRequest HTTP.defaultRequest HTTP.ResponseTimeout + else throwM $ userError "error" + (result :: Either IOError String) `shouldBe` Left (userError "error") + status <- readIORef lastStatus + Stamina.attempts status `shouldBe` 3 + +-- TODO: test RetryAfter