cachix/stamina.hs
1
1
Fork 0
mirror of https://github.com/cachix/stamina.hs.git synced 2024-07-14 22:00:34 +03:00
Code Issues Packages Projects Releases Wiki Activity

implement Stamina

Browse Source
This commit is contained in:
Domen Kožar 2023-12-30 11:38:00 +00:00
parent ad977f7248
commit 9b8c8229af
6 changed files with 229 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
.github/workflows/ci.yml vendored
View File

@ -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
View File

@ -0,0 +1 @@
README.md

75
README.md
View File

@ -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>

148
src/Stamina.hs
View File

@ -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

11
src/Stamina/HTTP.hs
View File

@ -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

86
stamina.cabal
View File

@ -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