diff --git a/README.md b/README.md index 6261f87..7ecc6e8 100644 --- a/README.md +++ b/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" ``` diff --git a/devenv.lock b/devenv.lock index aa720f7..afeb921 100644 --- a/devenv.lock +++ b/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": { diff --git a/devenv.nix b/devenv.nix index 7ce8d85..703376a 100644 --- a/devenv.nix +++ b/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; } \ No newline at end of file diff --git a/devenv.yaml b/devenv.yaml deleted file mode 100644 index c7cb5ce..0000000 --- a/devenv.yaml +++ /dev/null @@ -1,3 +0,0 @@ -inputs: - nixpkgs: - url: github:NixOS/nixpkgs/nixpkgs-unstable diff --git a/src/Stamina.hs b/src/Stamina.hs index 9c0f599..1be5cee 100644 --- a/src/Stamina.hs +++ b/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 diff --git a/src/Stamina/HTTP.hs b/src/Stamina/HTTP.hs index 441639b..4e0eae1 100644 --- a/src/Stamina/HTTP.hs +++ b/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 diff --git a/stack.yaml b/stack.yaml index c2279c5..0cdd51c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-21.1 +resolver: lts-22.3 packages: - . diff --git a/stamina.cabal b/stamina.cabal index 6e1f9d3..928e6e0 100644 --- a/stamina.cabal +++ b/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