diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,31 @@ +# Version [0.13.0.0](https://github.com/blockfrost/blockfrost-haskell/compare/client-0.12.0.0...client-0.13.0.0) (2026-04-15) + +* 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: "` 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 diff --git a/blockfrost-client.cabal b/blockfrost-client.cabal --- a/blockfrost-client.cabal +++ b/blockfrost-client.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: blockfrost-client -version: 0.12.0.0 +version: 0.13.0.0 synopsis: blockfrost.io basic client description: Simple Blockfrost clients for use with transformers or mtl homepage: https://github.com/blockfrost/blockfrost-haskell @@ -70,13 +70,13 @@ , Blockfrost.Client.NutLink build-depends: base >= 4.7 && < 5 , blockfrost-api >= 0.15 - , blockfrost-client-core ^>= 0.7 + , blockfrost-client-core ^>= 0.8 , bytestring - , directory , data-default , filepath , text , mtl + , retry >= 0.9 && < 0.10 , servant >= 0.18 && < 0.21 , servant-client , servant-client-core diff --git a/src/Blockfrost/Client/IPFS.hs b/src/Blockfrost/Client/IPFS.hs --- a/src/Blockfrost/Client/IPFS.hs +++ b/src/Blockfrost/Client/IPFS.hs @@ -15,28 +15,19 @@ 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 diff --git a/src/Blockfrost/Client/Types.hs b/src/Blockfrost/Client/Types.hs --- a/src/Blockfrost/Client/Types.hs +++ b/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 @@ import Control.Monad.Except import Control.Monad.Reader +import Control.Retry import Data.Default import Servant.API.Generic @@ -39,8 +46,26 @@ 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 :: ExceptT BlockfrostError @@ -62,13 +87,33 @@ 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 @@ -76,11 +121,16 @@ 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 @@ -> 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