implement Stamina

.github/workflows/ci.yml

@@ -1,16 +1,72 @@
-name: "CI"
+name: "build & test"
-
 on:
-  pull_request:
   push:
-    branches:
+  pull_request:
-      - main
+    branches: [main]
-    tags:
-      - v*
 
 jobs:
-  test:
+  build:
-    runs-on: ubuntu-latest
+    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: actions/checkout@v4
-      - uses: freckle/stack-action@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

README.lhs

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

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
+- `RetryAction`
-import Control.Exception (Exception, Handler)
+- `RetryStatus`
-import Control.Monad.IO.Class (MonadIO)
+- `defaults`
-import Data.Time.Clock (DiffTime)
+- `retry`
-
+- `retryOnExceptions`
-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.
-```
 
 ## Example
 
 ```haskell
-
 import qualified Stamina
+import Control.Monad.Catch (throwM)
 
-main :: IO ()
+go :: IO ()
-main = do
+go = do 
-    Stamina.retry Stamina.defaults $ \retryStatus -> do
+    defaults <- Stamina.defaults
-        ... monadic logic that raises exceptions
+    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>

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.Concurrent (newMVar, putMVar)
-import Control.Monad.IO.Class (MonadIO)
+import Control.Exception (Exception (..), SomeAsyncException (SomeAsyncException), SomeException, throwIO)
-import Control.Retry qualified as Retry
+import Control.Monad (void)
-import Data.Time.Clock (DiffTime)
+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.
+    maxAttempts :: Maybe 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.
+    maxTime :: Maybe DiffTime, -- Maximum time for all retries. Can be combined with attempts. Default to 60s.
-    backoffInitialRetryDelay :: DiffTime, -- Minimum backoff before the first retry. Default to 0.1.
+    backoffMaxRetryDelay :: DiffTime, -- Maximum backoff between retries at any time. Default to 5s.
-    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). Defaults to 1.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.
     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 :: IO RetrySettings
-defaults =
+defaults = do
-  -- TODO: Implement reset
+  resetMVar <- newMVar ()
-  RetrySettings
+  return $
-    { initialRetryStatus =
+    RetrySettings
-        RetryStatus
+      { initialRetryStatus =
-          { attempts = 0,
+          RetryStatus
-            delay = 0,
+            { attempts = 0,
-            totalDelay = 0,
+              delay = 0,
-            reset = pure ()
+              totalDelay = 0,
-          },
+              reset = void $ putMVar resetMVar (),
-      maxAttempts = 10,
+              lastException = Nothing
-      maxTime = 45.0,
+            },
-      backoffInitialRetryDelay = 0.1,
+        maxAttempts = Just 10,
-      backoffMaxRetryDelay = 5.0,
+        maxTime = Just $ secondsToDiffTime 60,
-      backoffJitter = 1.0,
+        backoffMaxRetryDelay = 5.0,
-      backoffExpBase = 2.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 :: (MonadCatch m, MonadIO m) => RetrySettings -> (RetryStatus -> m a) -> m a
-retry settings action = undefined
+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.
+-- TODO: implement reset
-retryOnExceptions :: MonadIO m => RetrySettings -> [Handler RetryAction] -> (RetryStatus -> m a) -> m a
+-- Same as retry, but only retry the given exceptions.
-retryOnExceptions settings handlers action = undefined
+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

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]
+handler :: SomeException -> Stamina.RetryAction
-handlers = undefined
+handler = undefined
 
-retry :: MonadIO m => Stamina.RetrySettings -> (Stamina.RetryStatus -> m a) -> m a
+retry :: (MonadIO m, MonadCatch m) => Stamina.RetrySettings -> (Stamina.RetryStatus -> m a) -> m a
-retry settings action = Stamina.retryOnExceptions settings handlers action
+retry settings = Stamina.retryOnExceptions settings handler

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
-
+    build-depends:    base, http-client, time, exceptions, random
-    -- 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.
     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