mirror of
https://github.com/cachix/stamina.hs.git
synced 2024-08-17 06:20:33 +03:00
implement Stamina
This commit is contained in:
parent
ad977f7248
commit
9b8c8229af
78
.github/workflows/ci.yml
vendored
78
.github/workflows/ci.yml
vendored
@ -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
|
||||
|
1
README.lhs
Symbolic link
1
README.lhs
Symbolic link
@ -0,0 +1 @@
|
||||
README.md
|
75
README.md
75
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.
|
||||
|
||||
<details>
|
||||
<summary>Test setup</summary>
|
||||
|
||||
```haskell
|
||||
main = undefined
|
||||
```
|
||||
</details>
|
126
src/Stamina.hs
126
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
|
||||
defaults :: IO RetrySettings
|
||||
defaults = do
|
||||
resetMVar <- newMVar ()
|
||||
return $
|
||||
RetrySettings
|
||||
{ initialRetryStatus =
|
||||
RetryStatus
|
||||
{ attempts = 0,
|
||||
delay = 0,
|
||||
totalDelay = 0,
|
||||
reset = pure ()
|
||||
reset = void $ putMVar resetMVar (),
|
||||
lastException = Nothing
|
||||
},
|
||||
maxAttempts = 10,
|
||||
maxTime = 45.0,
|
||||
backoffInitialRetryDelay = 0.1,
|
||||
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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user