From 9b8c8229af948711b4485aa8381842e467256360 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Domen=20Ko=C5=BEar?= Date: Sat, 30 Dec 2023 11:38:00 +0000 Subject: [PATCH] implement Stamina --- .github/workflows/ci.yml | 78 ++++++++++++++++++--- README.lhs | 1 + README.md | 75 ++++++++++---------- src/Stamina.hs | 148 +++++++++++++++++++++++++++++---------- src/Stamina/HTTP.hs | 11 +-- stamina.cabal | 86 +++-------------------- 6 files changed, 229 insertions(+), 170 deletions(-) create mode 120000 README.lhs diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 749a329..9304355 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -1,16 +1,72 @@ -name: "CI" - +name: "build & test" on: - pull_request: push: - branches: - - main - tags: - - v* + pull_request: + branches: [main] jobs: - test: - runs-on: ubuntu-latest + build: + name: GHC ${{ matrix.ghc-version }} on ${{ matrix.os }} + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest] + ghc-version: ['9.8', '9.6', '9.4', '9.2'] + + include: + - os: windows-latest + ghc-version: '9.8' + - os: macos-latest + ghc-version: '9.8' + steps: - - uses: actions/checkout@v3 - - uses: freckle/stack-action@v4 + - uses: actions/checkout@v4 + + - name: Set up GHC ${{ matrix.ghc-version }} + uses: haskell-actions/setup@v2 + id: setup + with: + ghc-version: ${{ matrix.ghc-version }} + # Defaults, added for clarity: + cabal-version: 'latest' + cabal-update: true + + - name: Configure the build + run: | + cabal configure --enable-tests --enable-benchmarks --disable-documentation + cabal build all --dry-run + # The last step generates dist-newstyle/cache/plan.json for the cache key. + + - name: Restore cached dependencies + uses: actions/cache/restore@v3 + id: cache + env: + key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }} + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} + restore-keys: ${{ env.key }}- + + - name: Install dependencies + # If we had an exact cache hit, the dependencies will be up to date. + if: steps.cache.outputs.cache-hit != 'true' + run: cabal build all --only-dependencies + + # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. + - name: Save cached dependencies + uses: actions/cache/save@v3 + # If we had an exact cache hit, trying to save the cache would error because of key clash. + if: steps.cache.outputs.cache-hit != 'true' + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: ${{ steps.cache.outputs.cache-primary-key }} + + - name: Build + run: cabal build all + + - name: Run tests + run: cabal test all + + - name: Build documentation + run: cabal haddock all diff --git a/README.lhs b/README.lhs new file mode 120000 index 0000000..42061c0 --- /dev/null +++ b/README.lhs @@ -0,0 +1 @@ +README.md \ No newline at end of file diff --git a/README.md b/README.md index 7fee246..6261f87 100644 --- a/README.md +++ b/README.md @@ -7,57 +7,46 @@ 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`. +- Introspectable retry state for logging using `RetryStatus`, including the exception that occoured. - Support resetting the retry state when the action is long-running and an attempt works. ## API -```haskell -import Control.Exception (Exception, Handler) -import Control.Monad.IO.Class (MonadIO) -import Data.Time.Clock (DiffTime) - -defaults :: RetrySettings - -data RetryStatus = RetryStatus - { attempts :: Int, - delay :: DiffTime, - totalDelay :: DiffTime, - reset :: IO () - } - --- Retry on all sync exceptions -retry :: MonadIO m - => RetrySettings - -> (RetryStatus -> m a) - -> m a - --- Retry on specific exceptions -retryOnExceptions :: (Exception e, MonadIO m) - => RetrySettings - -> [Handler RetryAction] - -> (RetryStatus -> m a) - -> m a - -data RetryAction = - Skip -- Propagate the exception. - | Retry -- Retry with the delay according to the settings. - | RetryDelay DiffTime -- Retry after the given delay. -``` +- `RetryAction` +- `RetryStatus` +- `defaults` +- `retry` +- `retryOnExceptions` ## Example ```haskell - import qualified Stamina +import Control.Monad.Catch (throwM) -main :: IO () -main = do - Stamina.retry Stamina.defaults $ \retryStatus -> do - ... monadic logic that raises exceptions - +go :: IO () +go = do + defaults <- Stamina.defaults + Stamina.retry defaults $ \retryStatus -> do + throwM $ userError "nope" ``` +## Example to catch specific exceptions + +```haskell + +isDoesNotExistError :: IOError -> Stamina.RetryAction +isDoesNotExistError _ = Stamina.Retry + +go2 :: IO () +go2 = do + defaults <- Stamina.defaults + Stamina.retryOnExceptions defaults isDoesNotExistError $ \retryStatus -> do + throwM $ userError "nope" +``` + + + ## Development 1. Install [devenv.sh](https://devenv.sh/getting-started/). @@ -70,3 +59,11 @@ main = do - Heavily inspired by [stamina for Python](https://stamina.hynek.me/en/stable/tutorial.html#retries). - [retry](https://github.com/Soostone/retry) as case study for what needs to be supported. + +
+ Test setup + + ```haskell + main = undefined + ``` +
\ No newline at end of file diff --git a/src/Stamina.hs b/src/Stamina.hs index 49e6b71..9c0f599 100644 --- a/src/Stamina.hs +++ b/src/Stamina.hs @@ -1,60 +1,71 @@ module Stamina - ( retry, + ( -- functions + retry, retryOnExceptions, + -- types RetrySettings (..), defaults, RetryAction (..), RetryStatus (..), + -- raising exceptions + escalateWith, + escalate, + withLeft, ) where -import Control.Exception (Exception, Handler) -import Control.Monad.IO.Class (MonadIO) -import Control.Retry qualified as Retry -import Data.Time.Clock (DiffTime) +import Control.Concurrent (newMVar, putMVar) +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 (DiffTime, secondsToDiffTime) +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 :: Int, -- Maximum number of attempts. Can be combined with a timeout. Default to 10. - maxTime :: DiffTime, -- Maximum time for all retries. Can be combined with attempts. Default to 45.0. - backoffInitialRetryDelay :: DiffTime, -- Minimum backoff before the first retry. Default to 0.1. - backoffMaxRetryDelay :: DiffTime, -- Maximum backoff between retries at any time. Default to 5.0. - backoffJitter :: Double, -- Maximum jitter that is added to retry back-off delays (the actual jitter added is a random number between 0 and backoffJitter). Default to 1.0. + 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. + 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. } - deriving (Show) --- Tracks the status of a retry +-- | Tracks the status of a retry +-- -- 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. - reset :: IO () -- Reset the retry status to the initial state. + reset :: IO (), -- Reset the retry status to the initial state. + lastException :: Maybe SomeException -- The last exception that was thrown. } - deriving (Show) -defaults :: RetrySettings -defaults = - -- TODO: Implement reset - RetrySettings - { initialRetryStatus = - RetryStatus - { attempts = 0, - delay = 0, - totalDelay = 0, - reset = pure () - }, - maxAttempts = 10, - maxTime = 45.0, - backoffInitialRetryDelay = 0.1, - backoffMaxRetryDelay = 5.0, - backoffJitter = 1.0, - backoffExpBase = 2.0 - } +defaults :: IO RetrySettings +defaults = do + resetMVar <- newMVar () + return $ + RetrySettings + { initialRetryStatus = + RetryStatus + { attempts = 0, + delay = 0, + totalDelay = 0, + reset = void $ putMVar resetMVar (), + lastException = Nothing + }, + maxAttempts = Just 10, + maxTime = Just $ secondsToDiffTime 60, + backoffMaxRetryDelay = 5.0, + backoffJitter = 1.0, + backoffExpBase = 2.0 + } data RetryAction - = Skip -- Propagate the exception. + = RaiseException -- Propagate the exception. | Retry -- Retry with the delay according to the settings. | RetryDelay DiffTime -- Retry after the given delay. @@ -68,9 +79,70 @@ data RetryAction -- 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 :: MonadIO m => RetrySettings -> (RetryStatus -> m a) -> m a -retry settings action = undefined +retry :: (MonadCatch m, MonadIO m) => RetrySettings -> (RetryStatus -> m a) -> m a +retry settings = retryOnExceptions settings skipAsyncExceptions + where + skipAsyncExceptions :: SomeException -> RetryAction + skipAsyncExceptions exc = case fromException exc of + Just (SomeAsyncException _) -> RaiseException + Nothing -> Retry --- Same as retry, but only retry on the given exceptions. -retryOnExceptions :: MonadIO m => RetrySettings -> [Handler RetryAction] -> (RetryStatus -> m a) -> m a -retryOnExceptions settings handlers action = undefined +-- TODO: implement reset +-- Same as retry, but only retry the given exceptions. +retryOnExceptions :: + (Exception exc, MonadIO m, MonadCatch m) => + RetrySettings -> + (exc -> RetryAction) -> + (RetryStatus -> m a) -> + m a +retryOnExceptions settings handler action = + go $ initialRetryStatus settings + where + -- go :: (MonadCatch m, MonadIO m) => RetryStatus -> m a + go retryStatus = do + 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_ + + updateRetryStatus :: RetryStatus -> DiffTime -> SomeException -> RetryStatus + updateRetryStatus status delay_ exception = + status + { attempts = attempts status + 1, + delay = delay_, + totalDelay = totalDelay status + delay_, + lastException = Just exception + } + + increaseDelay :: MonadIO m => RetryStatus -> m DiffTime + 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 + + -- maybeAttempt :: (Exception exc, MonadCatch m, MonadIO m) => exc -> RetryStatus -> DiffTime -> m a + maybeAttempt exception retryStatus delay_ = do + let RetrySettings {maxTime, maxAttempts} = settings + if (isJust maxTime && Just (totalDelay retryStatus + delay_) > maxTime) + || (isJust maxAttempts && Just (attempts retryStatus + 1) > maxAttempts) + then throwM exception + else go $ updateRetryStatus retryStatus delay_ $ toException exception + +-- | Escalate an Either to an exception by converting the Left value to an exception. +escalateWith :: (Exception exc) => (err -> exc) -> Either err a -> IO a +escalateWith f = either (throwIO . f) return + +-- | Convert a Maybe to an Either. +withLeft :: a -> Maybe b -> Either a b +withLeft a = maybe (Left a) Right + +-- | Escalate an Either to an exception. +escalate :: (Exception exc) => Either exc a -> IO a +escalate = escalateWith id diff --git a/src/Stamina/HTTP.hs b/src/Stamina/HTTP.hs index b2716d2..441639b 100644 --- a/src/Stamina/HTTP.hs +++ b/src/Stamina/HTTP.hs @@ -1,12 +1,13 @@ module Stamina.HTTP (retry) where -import Control.Exception (Handler) +import Control.Exception (SomeException) +import Control.Monad.Catch (MonadCatch) import Control.Monad.IO.Class (MonadIO) import Network.HTTP.Client qualified as HTTP import Stamina qualified -handlers :: [Handler Stamina.RetryAction] -handlers = undefined +handler :: SomeException -> Stamina.RetryAction +handler = undefined -retry :: MonadIO m => Stamina.RetrySettings -> (Stamina.RetryStatus -> m a) -> m a -retry settings action = Stamina.retryOnExceptions settings handlers action +retry :: (MonadIO m, MonadCatch m) => Stamina.RetrySettings -> (Stamina.RetryStatus -> m a) -> m a +retry settings = Stamina.retryOnExceptions settings handler diff --git a/stamina.cabal b/stamina.cabal index f0c2e98..6e1f9d3 100644 --- a/stamina.cabal +++ b/stamina.cabal @@ -1,109 +1,41 @@ cabal-version: 3.4 --- The cabal-version field refers to the version of the .cabal specification, --- and can be different from the cabal-install (the tool) version and the --- Cabal (the library) version you are using. As such, the Cabal (the library) --- version used must be equal or greater than the version stated in this field. --- Starting from the specification version 2.2, the cabal-version field must be --- the first thing in the cabal file. - --- Initial package description 'stamina' generated by --- 'cabal init'. For further documentation, see: --- http://haskell.org/cabal/users-guide/ --- --- The name of the package. name: stamina - --- The package version. --- See the Haskell package versioning policy (PVP) for standards --- guiding when and how versions should be incremented. --- https://pvp.haskell.org --- PVP summary: +-+------- breaking API changes --- | | +----- non-breaking API additions --- | | | +--- code changes with no API change version: 0.1.0.0 - --- A short (one-line) description of the package. synopsis: Retries for humans - --- A longer description of the package. --- description: - --- URL for the project homepage or repository. homepage: https://github.com/cachix/stamina.hs - --- The license under which the package is released. license: Apache-2.0 - --- The file containing the license text. license-file: LICENSE - --- The package author(s). author: Domen Kožar - --- An email address to which users can send suggestions, bug reports, and patches. maintainer: domen@cachix.org - --- A copyright notice. --- copyright: category: Control build-type: Simple - --- Extra doc files to be distributed with the package, such as a CHANGELOG or a README. extra-doc-files: CHANGELOG.md --- Extra source files to be distributed with the package, such as examples, or a tutorial module. --- extra-source-files: - common warnings ghc-options: -Wall + default-language: GHC2021 library - -- Import common warning flags. import: warnings - - -- Modules exported by the library. exposed-modules: Stamina , Stamina.HTTP - - -- Modules included in this library but not exported. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- Other library packages from which modules are imported. - build-depends: base, http-client, time, retry - - -- Directories containing source files. + build-depends: base, http-client, time, exceptions, random hs-source-dirs: src - -- Base language which the package is written in. - default-language: GHC2021 - test-suite stamina-test - -- Import common warning flags. import: warnings - - -- Base language which the package is written in. default-language: GHC2021 - - -- Modules included in this executable, other than Main. - -- other-modules: - - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - - -- The interface type and version of the test suite. type: exitcode-stdio-1.0 - - -- Directories containing source files. hs-source-dirs: test - - -- The entrypoint to the test suite. main-is: Main.hs - - -- Test dependencies. build-depends: base, stamina + +-- typechecks README during CI but doesn't run it +executable readme + main-is: README.lhs + build-depends: stamina, base, exceptions + ghc-options: -pgmL markdown-unlit + build-tool-depends: markdown-unlit:markdown-unlit