Retry logic

blockfrost-client-core/CHANGELOG.md

@@ -1,5 +1,13 @@
 # Version [next](https://github.com/blockfrost/blockfrost-haskell/compare/client-core-0.7.0.0...master) (2025-MM-DD)
 
+* Changes
+  * `BlockfrostError` constructor of `BlockfrostError` type now contains
+    `Status` from `Network.HTTP.Types.Status` (HTTP status code and an explanation message).
+    Previously `BlockfrostError Text`, now `BlockfrostError Status Text`.
+  * `BlockfrostFatal` constructor (HTTP 500) of `BlockfrostError` merged into `BlockfrostError` constructor.
+  * `Blockfrost.Client.Core` module now exports `retriableError`, for retry logic
+    implemented in `blockfrost-client` package (using `Control.Retry` from `retry` package).
+
 # Version [0.7.0.0](https://github.com/blockfrost/blockfrost-haskell/compare/client-core-0.6.0.1...client-core-0.7.0.0) (2025-12-02)
 
 * Changes

blockfrost-client-core/blockfrost-client-core.cabal

@@ -54,6 +54,7 @@ library
                       , http-client
                       , http-client-tls
                       , http-types
+                      , retry                    >= 0.9  && < 0.10
                       , servant                  >= 0.18 && < 0.21
                       , servant-client
                       , servant-client-core

blockfrost-client-core/src/Blockfrost/Client/Core.hs

@@ -1,4 +1,5 @@
 -- | Core shared by clients
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
@@ -7,6 +8,7 @@
 
 module Blockfrost.Client.Core
   ( BlockfrostError (..)
+  , retriableError
   , Paged (..)
   , SortOrder (..)
   , asc
@@ -46,6 +48,7 @@ import Servant.Multipart.API
 import Servant.Multipart.Client ()
 import qualified System.Environment
 import Control.Monad.Catch.Pure (runCatch)
+import Control.Retry (RetryAction(..))
 
 domain :: String
 domain = "blockfrost.io"
@@ -96,15 +99,14 @@ projectFromFile :: FilePath -> IO Project
 projectFromFile f = mkProject <$> Data.Text.IO.readFile f
 
 data BlockfrostError =
-    BlockfrostError Text
-  | BlockfrostBadRequest Text   -- 400
-  | BlockfrostTokenMissing Text -- 403
-  | BlockfrostNotFound Text     -- 404
-  | BlockfrostIPBanned          -- 418
-  | BlockfrostMempoolFullOrPinQueueFull -- 425
-  | BlockfrostUsageLimitReached -- 429
-  | BlockfrostFatal Text        -- 500
-  | ServantClientError ClientError
+    BlockfrostError Status Text         -- ^ Other HTTP error codes
+  | BlockfrostBadRequest Text           -- ^ 400
+  | BlockfrostTokenMissing Text         -- ^ 403
+  | BlockfrostNotFound Text             -- ^ 404
+  | BlockfrostIPBanned                  -- ^ 418
+  | BlockfrostMempoolFullOrPinQueueFull -- ^ 425
+  | BlockfrostUsageLimitReached         -- ^ 429
+  | ServantClientError ClientError      -- ^ Unhandled @ClientError@ (either @ConnectionError@ or @DecodeFailure@)
   deriving (Eq, Show)
 
 fromServantClientError :: ClientError -> BlockfrostError
@@ -126,17 +128,46 @@ fromServantClientError e = case e of
         BlockfrostMempoolFullOrPinQueueFull
     | s == status429 ->
         BlockfrostUsageLimitReached
-    | s == status500 ->
-        BlockfrostFatal (withMessage body)
     | otherwise ->
-        BlockfrostError (withMessage body)
+        BlockfrostError s (withMessage body)
   _ -> ServantClientError e
   where
     withMessage body =
       case eitherDecode body of
         (Right (ae :: ApiError)) -> apiErrorMessage ae
         _                        -> mempty
 
+retriableError :: BlockfrostError -> RetryAction
+retriableError BlockfrostIPBanned
+  = ConsultPolicyOverrideDelay (5 * 60 * 1000 * 1000) -- 5 minutes
+retriableError BlockfrostMempoolFullOrPinQueueFull
+  = ConsultPolicy
+retriableError BlockfrostUsageLimitReached
+  = ConsultPolicyOverrideDelay (5 * 60 * 1000 * 1000) -- 5 minutes
+retriableError (BlockfrostError s _) =
+  (\case
+     True  -> ConsultPolicy
+     False -> DontRetry
+  )
+  . elem
+    s
+    $ [ requestTimeout408
+      , internalServerError500
+      , badGateway502
+      , serviceUnavailable503
+      , gatewayTimeout504
+      ]
+      -- CF reverse proxy
+      ++ map
+          (flip mkStatus mempty)
+          [ 520
+          , 521
+          , 522
+          , 524
+          ]
+retriableError (ServantClientError (ConnectionError _)) = ConsultPolicy
+retriableError _ = DontRetry
+
 instance ToMultipart Tmp Form where
   toMultipart (Form fileName filePath) =
     MultipartData

blockfrost-client/CHANGELOG.md

@@ -1,5 +1,31 @@
 # Version [next](https://github.com/blockfrost/blockfrost-haskell/compare/client-0.12.0.0...master) (2026-MM-DD)
 
+* Changes
+  * Retry logic added
+
+    Client will retry most transient errors like connection timeouts,
+    up to 5 times with exponential backoff. This can be customized
+    via `clientConfigRetryPolicy` field of `ClientConfig`. See [`Control.Retry`](https://hackage.haskell.org/package/retry/docs/Control-Retry.html#g:5)
+    for available options.
+
+    * `type ClientConfig = (ClientEnv, Project)` is now
+
+      ```
+      data ClientConfig =
+        ClientConfig
+          { clientConfigClientEnv   :: ClientEnv
+          , clientConfigProject     :: Project
+          , clientConfigRetryPolicy :: RetryPolicy
+          , clientConfigRetryJudge  :: RetryStatus -> BlockfrostError -> RetryAction
+          }
+      ```
+      last two fields are populated with `defaultRetryPolicy` and `defaultRetryJudge`.
+
+  * `ipfsAdd`
+    * no longer throws `BlockfrostError "File not found"`
+    * no longer checks if the file exists
+    * no longer prints `"Uploading: <filename>"` message to stdout
+
 # Version [0.12.0.0](https://github.com/blockfrost/blockfrost-haskell/compare/client-0.11.0.0...client-0.12.0.0) (2026-02-02)
 
 * Changes

blockfrost-client/blockfrost-client.cabal

@@ -72,11 +72,11 @@ library
                       , blockfrost-api           >= 0.15
                       , blockfrost-client-core   ^>= 0.7
                       , bytestring
-                      , directory
                       , data-default
                       , filepath
                       , text
                       , mtl
+                      , retry                    >= 0.9  && < 0.10
                       , servant                  >= 0.18 && < 0.21
                       , servant-client
                       , servant-client-core

blockfrost-client/src/Blockfrost/Client/IPFS.hs

@@ -15,28 +15,19 @@ module Blockfrost.Client.IPFS
 import Blockfrost.API
 import Blockfrost.Client.Types
 import Blockfrost.Types
-import Control.Monad.Except (MonadError, throwError)
-import Control.Monad.IO.Class (liftIO)
 import Data.ByteString.Lazy (ByteString)
 import Data.Text (Text)
 import qualified Data.Text
-import qualified System.Directory
 import qualified System.FilePath
 
 ipfsAdd_ :: MonadBlockfrost m => Project -> (ByteString, Form) -> m IPFSAdd
 ipfsAdd_ = _add . ipfsClient
 
 -- | Add a file or directory to IPFS
-ipfsAdd :: (MonadError BlockfrostError m, MonadBlockfrost m) => FilePath -> m IPFSAdd
+ipfsAdd :: MonadBlockfrost m => FilePath -> m IPFSAdd
 ipfsAdd fp = do
-  hasFile <- liftIO $ System.Directory.doesFileExist fp
-  if hasFile
-    then do
-      liftIO $ putStrLn $ "Uploading: " ++ fp
-      let fn = Data.Text.pack $ System.FilePath.takeBaseName fp
-      go (\proj -> ipfsAdd_ proj ("suchBoundary", (Form fn fp)))
-    else
-      throwError (BlockfrostError "No such file")
+  let fn = Data.Text.pack $ System.FilePath.takeBaseName fp
+  go (\proj -> ipfsAdd_ proj ("suchBoundary", (Form fn fp)))
 
 ipfsGateway_ :: MonadBlockfrost m => Project -> Text -> m IPFSData
 ipfsGateway_ = _gateway . ipfsClient

blockfrost-client/src/Blockfrost/Client/Types.hs

@@ -2,11 +2,17 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE Rank2Types #-}
 
 module Blockfrost.Client.Types
   ( BlockfrostClient
   , BlockfrostError (..)
   , ClientConfig
+  , defaultRetryPolicy
+  , endlessRetryPolicy
+  , defaultRetryJudge
   , runBlockfrost
   , apiClient
   , api0Client
@@ -30,6 +36,7 @@ module Blockfrost.Client.Types
 
 import Control.Monad.Except
 import Control.Monad.Reader
+import Control.Retry
 import Data.Default
 
 import Servant.API.Generic
@@ -39,7 +46,25 @@ import Servant.Client.Generic
 import Blockfrost.API
 import Blockfrost.Client.Core
 
-type ClientConfig = (ClientEnv, Project)
+data ClientConfig =
+  ClientConfig
+    { clientConfigClientEnv   :: ClientEnv
+    , clientConfigProject     :: Project
+    , clientConfigRetryPolicy :: RetryPolicy
+    , clientConfigRetryJudge  :: RetryStatus -> BlockfrostError -> RetryAction
+    }
+
+defaultRetryPolicy :: RetryPolicy
+defaultRetryPolicy = exponentialBackoff (1000 * 1000) <> limitRetries 5
+
+endlessRetryPolicy :: RetryPolicy
+endlessRetryPolicy = exponentialBackoff (1000 * 1000)
+
+defaultRetryJudge
+  :: RetryStatus
+  -> BlockfrostError
+  -> RetryAction
+defaultRetryJudge _retryStatus err = retriableError err
 
 newtype BlockfrostClientT m a = BlockfrostClientT {
   unBlockfrostClientT
@@ -62,25 +87,50 @@ class MonadIO m => MonadBlockfrost m where
 
 instance MonadIO m => MonadBlockfrost (BlockfrostClientT m) where
   liftBlockfrostClient act = BlockfrostClientT $ do
-    (env, _proj) <- ask
-    liftIO (runClientM act env)
-      >>= either
-            (throwError . fromServantClientError)
-            pure
+    clientConfig <- ask
+    liftIO
+      $ withRetry
+          clientConfig
+          $ runClientM act (clientConfigClientEnv clientConfig)
+    >>= either
+          (throwError . fromServantClientError)
+          pure
   getConf = BlockfrostClientT ask
 
+withRetry
+  :: ClientConfig
+  -> IO (Either ClientError a)
+  -> IO (Either ClientError a)
+withRetry ClientConfig{..} act =
+  retryingDynamic
+    clientConfigRetryPolicy
+    (\retryStatus -> \case
+        Right{} -> pure DontRetry
+        Left err ->
+          pure
+          $ clientConfigRetryJudge
+              retryStatus
+              (fromServantClientError err)
+    )
+    (const act)
+
 instance MonadBlockfrost ClientM where
   liftBlockfrostClient = id
   getConf = newClientConfig
 
 instance MonadBlockfrost IO where
   liftBlockfrostClient act =
     getConf
-      >>= \(env, _prj) ->
-        runClientM act env
-          >>= either
-                (error . show)
-                pure
+      >>= \clientConfig ->
+        withRetry
+          clientConfig
+          ( runClientM
+              act
+              (clientConfigClientEnv clientConfig)
+          )
+        >>= either
+              (error . show)
+              pure
   getConf = newClientConfig
 
 apiClient
@@ -110,24 +160,37 @@ runBlockfrostClientT
   -> BlockfrostClientT m a
   -> m (Either BlockfrostError a)
 runBlockfrostClientT proj act = do
-  env <- liftIO $ newEnvByProject proj
-  flip runReaderT (env, proj)
+  cc <- liftIO $ mkClientConfig proj
+  flip runReaderT cc
     $ runExceptT $ unBlockfrostClientT act
 
 -- | Build default `ClientConfig` using BLOCKFROST_TOKEN_PATH environment variable
 newClientConfig
   :: MonadIO m
   => m ClientConfig
-newClientConfig = liftIO $ do
-  prj <- projectFromEnv
-  env <- newEnvByProject prj
-  pure (env, prj)
+newClientConfig =
+  liftIO
+    $ projectFromEnv >>= mkClientConfig
+
+mkClientConfig
+  :: MonadIO m
+  => Project
+  -> m ClientConfig
+mkClientConfig prj = do
+  env <- liftIO $ newEnvByProject prj
+  pure
+    $ ClientConfig
+        { clientConfigClientEnv   = env
+        , clientConfigProject     = prj
+        , clientConfigRetryPolicy = defaultRetryPolicy
+        , clientConfigRetryJudge  = defaultRetryJudge
+        }
 
 -- | Helper
 go :: MonadBlockfrost m
    => (Project -> m a)
    -> m a
-go act = getConf >>= act . snd
+go act = getConf >>= act . clientConfigProject
 
 -- Until mtl > 2.2.2
 -- https://github.com/haskell/mtl/pull/66