add tests

src/Stamina.hs

@@ -14,21 +14,21 @@ 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.
 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

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

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