Implement Stamina.HTTP

README.md

@@ -7,7 +7,7 @@ A retry Haskell library for humans:
 - **Exponential backoff** with **jitter** between retries.
 - Limit the **attempts** of retries and **total** time.
 - `Stamina.HTTP` for retrying retriable `Network.HTTP.Client` exceptions.
-- Introspectable retry state for logging using `RetryStatus`, including the exception that occoured.
+- Introspectable retry state for logging using `RetryStatus`, including the exception that occured.
 - Support resetting the retry state when the action is long-running and an attempt works.
 
 ## API
@@ -41,7 +41,7 @@ isDoesNotExistError _ = Stamina.Retry
 go2 :: IO ()
 go2 = do 
     defaults <- Stamina.defaults
-    Stamina.retryOnExceptions defaults isDoesNotExistError $ \retryStatus -> do
+    Stamina.retryOnExceptions defaults (return . isDoesNotExistError) $ \retryStatus -> do
         throwM $ userError "nope"
 ```
 

devenv.lock

@@ -3,11 +3,11 @@
     "devenv": {
       "locked": {
         "dir": "src/modules",
-        "lastModified": 1688422948,
-        "narHash": "sha256-D5Le0gJgaB5fT9qKZ5jBmnBvdZJTOBr1cyeWsRiWZXc=",
+        "lastModified": 1703939110,
+        "narHash": "sha256-GgjYWkkHQ8pUBwXX++ah+4d07DqOeCDaaQL6Ab86C50=",
         "owner": "cachix",
         "repo": "devenv",
-        "rev": "6f761f07c5f53d5cc4a139db3f41a7f4a0821ffa",
+        "rev": "7354096fc026f79645fdac73e9aeea71a09412c3",
         "type": "github"
       },
       "original": {
@@ -74,11 +74,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1688465017,
-        "narHash": "sha256-xzFcCnzPOgQaX7Acprfqo+tqHJ2UKWC38pXrcqvdXHU=",
+        "lastModified": 1703499205,
+        "narHash": "sha256-lF9rK5mSUfIZJgZxC3ge40tp1gmyyOXZ+lRY3P8bfbg=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "0d5682acc109add20f70440269587a1b169cc2fe",
+        "rev": "e1fa12d4f6c6fe19ccb59cac54b5b3f25e160870",
         "type": "github"
       },
       "original": {
@@ -115,11 +115,11 @@
         "nixpkgs-stable": "nixpkgs-stable"
       },
       "locked": {
-        "lastModified": 1688473851,
-        "narHash": "sha256-j+ViA3lh4uQGIDqB6TjM4+wijX2M5mfNb6MVJVekpAs=",
+        "lastModified": 1703939133,
+        "narHash": "sha256-Gxe+mfOT6bL7wLC/tuT2F+V+Sb44jNr8YsJ3cyIl4Mo=",
         "owner": "cachix",
         "repo": "pre-commit-hooks.nix",
-        "rev": "f6a6863a3bcb61e846a9e4777b90ee365607a925",
+        "rev": "9d3d7e18c6bc4473d7520200d4ddab12f8402d38",
         "type": "github"
       },
       "original": {

devenv.nix

@@ -1,6 +1,6 @@
 { pkgs, ... }: {
   languages.haskell.enable = true;
-  languages.haskell.package = pkgs.haskell.compiler.ghc945;
+  languages.haskell.package = pkgs.haskell.compiler.ghc963;
 
   pre-commit.hooks.ormolu.enable = true;
 }

devenv.yaml

@@ -1,3 +0,0 @@
-inputs:
-  nixpkgs:
-    url: github:NixOS/nixpkgs/nixpkgs-unstable

src/Stamina.hs

@@ -20,15 +20,15 @@ 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 (DiffTime, secondsToDiffTime)
+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime, 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 DiffTime, -- Maximum time for all retries. Can be combined with attempts. Default to 60s.
-    backoffMaxRetryDelay :: DiffTime, -- Maximum backoff between retries at any time. Default to 5s.
+    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.
     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.
   }
@@ -38,8 +38,8 @@ data RetrySettings = RetrySettings
 -- All fields will be zero if no retries have been attempted yet.
 data RetryStatus = RetryStatus
   { attempts :: Int, -- Number of retry attempts so far.
-    delay :: DiffTime, -- Delay before the next retry.
-    totalDelay :: DiffTime, -- Total delay so far.
+    delay :: NominalDiffTime, -- Delay before the next retry.
+    totalDelay :: NominalDiffTime, -- Total delay so far.
     reset :: IO (), -- Reset the retry status to the initial state.
     lastException :: Maybe SomeException -- The last exception that was thrown.
   }
@@ -58,7 +58,7 @@ defaults = do
               lastException = Nothing
             },
         maxAttempts = Just 10,
-        maxTime = Just $ secondsToDiffTime 60,
+        maxTime = Just $ secondsToNominalDiffTime 60,
         backoffMaxRetryDelay = 5.0,
         backoffJitter = 1.0,
         backoffExpBase = 2.0
@@ -67,10 +67,11 @@ defaults = do
 data RetryAction
   = RaiseException -- Propagate the exception.
   | Retry -- Retry with the delay according to the settings.
-  | RetryDelay DiffTime -- Retry after the given delay.
+  | RetryDelay NominalDiffTime -- Retry after the given delay.
+  | RetryTime UTCTime -- Retry after the given time.
 
 -- | 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:
 --
@@ -82,17 +83,17 @@ data RetryAction
 retry :: (MonadCatch m, MonadIO m) => RetrySettings -> (RetryStatus -> m a) -> m a
 retry settings = retryOnExceptions settings skipAsyncExceptions
   where
-    skipAsyncExceptions :: SomeException -> RetryAction
+    -- skipAsyncExceptions :: SomeException -> m RetryAction
     skipAsyncExceptions exc = case fromException exc of
-      Just (SomeAsyncException _) -> RaiseException
-      Nothing -> Retry
+      Just (SomeAsyncException _) -> return RaiseException
+      Nothing -> return Retry
 
 -- TODO: implement reset
 -- Same as retry, but only retry the given exceptions.
 retryOnExceptions ::
   (Exception exc, MonadIO m, MonadCatch m) =>
   RetrySettings ->
-  (exc -> RetryAction) ->
+  (exc -> m RetryAction) ->
   (RetryStatus -> m a) ->
   m a
 retryOnExceptions settings handler action =
@@ -103,15 +104,22 @@ retryOnExceptions settings handler action =
       result <- try $ action retryStatus
       case result of
         Right out -> return out
-        Left exception -> case handler exception of
-          RaiseException -> throwM exception
-          Retry -> do
-            delay_ <- liftIO $ increaseDelay retryStatus
-            maybeAttempt exception retryStatus delay_
-          RetryDelay delay_ -> do
-            maybeAttempt exception retryStatus delay_
+        Left exception -> do
+          exceptionAction <- handler exception
+          case exceptionAction of
+            RaiseException -> throwM exception
+            Retry -> do
+              delay_ <- liftIO $ increaseDelay retryStatus
+              maybeAttempt exception retryStatus delay_
+            RetryDelay delay_ -> do
+              maybeAttempt exception retryStatus delay_
+            RetryTime time -> do
+              delay_ <- liftIO $ do
+                now <- getCurrentTime
+                return $ diffUTCTime time now
+              maybeAttempt exception retryStatus delay_
 
-    updateRetryStatus :: RetryStatus -> DiffTime -> SomeException -> RetryStatus
+    updateRetryStatus :: RetryStatus -> NominalDiffTime -> SomeException -> RetryStatus
     updateRetryStatus status delay_ exception =
       status
         { attempts = attempts status + 1,
@@ -120,12 +128,12 @@ retryOnExceptions settings handler action =
           lastException = Just exception
         }
 
-    increaseDelay :: MonadIO m => RetryStatus -> m DiffTime
+    increaseDelay :: (MonadIO m) => RetryStatus -> m NominalDiffTime
     increaseDelay retryStatus = do
       let RetryStatus {attempts} = retryStatus
       let RetrySettings {backoffMaxRetryDelay, backoffJitter, backoffExpBase} = settings
       jitter <- randomRIO (0, backoffJitter)
-      return $ min backoffMaxRetryDelay $ secondsToDiffTime $ floor $ backoffExpBase ** (fromIntegral attempts - 1) + jitter
+      return $ min backoffMaxRetryDelay $ secondsToNominalDiffTime $ realToFrac $ backoffExpBase ** (fromIntegral attempts - 1) + jitter
 
     -- maybeAttempt :: (Exception exc, MonadCatch m, MonadIO m) => exc -> RetryStatus -> DiffTime -> m a
     maybeAttempt exception retryStatus delay_ = do

src/Stamina/HTTP.hs

@@ -1,13 +1,74 @@
-module Stamina.HTTP (retry) where
+module Stamina.HTTP (retry, handler) where
 
-import Control.Exception (SomeException)
+import Control.Applicative ((<|>))
+import Control.Exception (SomeException, fromException)
 import Control.Monad.Catch (MonadCatch)
 import Control.Monad.IO.Class (MonadIO)
+import Data.Time (UTCTime, defaultTimeLocale, readPTime, rfc822DateFormat, secondsToNominalDiffTime)
 import Network.HTTP.Client qualified as HTTP
+import Network.HTTP.Types.Header (hRetryAfter)
+import Network.HTTP.Types.Status (statusIsServerError, tooManyRequests429)
 import Stamina qualified
+import Text.Read (Read (readPrec), readMaybe)
+import Text.Read qualified as ReadPrec
 
-handler :: SomeException -> Stamina.RetryAction
-handler = undefined
-
+-- | Retry handler for HTTP requests.
+--
+-- Retries a subset of HTTP exceptions and overrides the delay with the Retry-After header if present.
 retry :: (MonadIO m, MonadCatch m) => Stamina.RetrySettings -> (Stamina.RetryStatus -> m a) -> m a
 retry settings = Stamina.retryOnExceptions settings handler
+
+handler :: (MonadIO m) => SomeException -> m Stamina.RetryAction
+handler =
+  httpExceptionToRetryAction . fromException
+  where
+    -- httpExceptionToRetryAction :: Maybe HTTP.HttpException -> m Stamina.RetryAction
+    httpExceptionToRetryAction (Just exc@(HTTP.HttpExceptionRequest _ (HTTP.StatusCodeException response _))) = do
+      case lookupRetryAfter response of
+        Just (RetryAfterSeconds seconds) -> return $ Stamina.RetryDelay $ secondsToNominalDiffTime $ fromIntegral seconds
+        Just (RetryAfterDate date) -> return $ Stamina.RetryTime date
+        Nothing ->
+          if shouldRetryHttpException exc
+            then return Stamina.Retry
+            else return Stamina.RaiseException
+    httpExceptionToRetryAction (Just exc) | shouldRetryHttpException exc = return Stamina.Retry
+    httpExceptionToRetryAction _ = return Stamina.RaiseException
+
+    -- https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Retry-After
+    lookupRetryAfter :: HTTP.Response body -> Maybe RetryAfterHeader
+    lookupRetryAfter = readMaybe . show . snd . head . filter ((== hRetryAfter) . fst) . HTTP.responseHeaders
+
+data RetryAfterHeader
+  = RetryAfterDate UTCTime
+  | RetryAfterSeconds Int
+  deriving (Eq, Show)
+
+instance Read RetryAfterHeader where
+  readPrec = parseSeconds <|> parseWebDate
+    where
+      parseSeconds = RetryAfterSeconds <$> readPrec
+      parseWebDate = ReadPrec.lift $ RetryAfterDate <$> readPTime True defaultTimeLocale rfc822DateFormat
+
+shouldRetryHttpException :: HTTP.HttpException -> Bool
+shouldRetryHttpException (HTTP.InvalidUrlException _ _) = False
+shouldRetryHttpException (HTTP.HttpExceptionRequest _ reason) =
+  case reason of
+    HTTP.ConnectionClosed -> True
+    HTTP.ConnectionFailure _ -> True
+    HTTP.ConnectionTimeout -> True
+    HTTP.IncompleteHeaders -> True
+    HTTP.InternalException _ -> True
+    HTTP.InvalidChunkHeaders -> True
+    HTTP.InvalidProxyEnvironmentVariable _ _ -> True
+    HTTP.InvalidStatusLine _ -> True
+    HTTP.NoResponseDataReceived -> True
+    HTTP.ProxyConnectException _ _ status
+      | statusIsServerError status -> True
+    HTTP.ResponseBodyTooShort _ _ -> True
+    HTTP.ResponseTimeout -> True
+    HTTP.StatusCodeException response _
+      | HTTP.responseStatus response == tooManyRequests429 -> True
+    HTTP.StatusCodeException response _
+      | statusIsServerError (HTTP.responseStatus response) -> True
+    HTTP.HttpZlibException _ -> True
+    _ -> False

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-21.1
+resolver: lts-22.3
 
 packages:
 - .

stamina.cabal

@@ -20,7 +20,7 @@ library
     exposed-modules:  
        Stamina
      , Stamina.HTTP
-    build-depends:    base, http-client, time, exceptions, random
+    build-depends:    base, http-client, http-types, time, exceptions, random
     hs-source-dirs:   src
 
 test-suite stamina-test