diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,56 @@ +# 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 + * Fix `MempoolUTxOInput` `address` field from `Text` to `Maybe Text` [#83](https://github.com/blockfrost/blockfrost-haskell/issues/83) [#84](https://github.com/blockfrost/blockfrost-haskell/pull/84) + * Mempool API functions adjusted to not require passing in `Project` [#85](https://github.com/blockfrost/blockfrost-haskell/pull/85) + * Previous `getMempoolTransactions prj def def` is now simply `getMempoolTransactions` and a principled + variant `getMempoolTransactions'` is provided accepting page and sort order parameters + (for example `allPages $ \p -> getMempoolTransactions' p def`). + * Similar for `getMempoolTransactionsByAddress`. + * `getMempoolTransaction` now simply doesn't require passing `Project` + +# Version [0.11.0.0](https://github.com/blockfrost/blockfrost-haskell/compare/client-0.10.0.0...client-0.11.0.0) (2025-12-02) + +* Changes + * Add `CustomURL` to `Env`, to allow arbitrary Blockfrost instance [#79](https://github.com/blockfrost/blockfrost-haskell/pull/79) + * `BlockfrostNotFound` constructor of `BlockfrostError` is now `BlockfrostNotFound Text` + containing path that resulted in 404 error [#81](https://github.com/blockfrost/blockfrost-haskell/pull/81) + * Drop `Sanchonet` `Env` [#79](https://github.com/blockfrost/blockfrost-haskell/pull/79) + +# Version [0.10.0.0](https://github.com/blockfrost/blockfrost-haskell/compare/client-0.9.2.0...client-0.10.0.0) (2025-06-03) + +* Additions + * Governance support [#77](https://github.com/blockfrost/blockfrost-haskell/pull/77) + * `AccountInfo` extended with `drepId` field [#77](https://github.com/blockfrost/blockfrost-haskell/pull/77) + # Version [0.9.2.0](https://github.com/blockfrost/blockfrost-haskell/compare/client-0.9.1.0...client-0.9.2.0) (2025-04-07) * Additions 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.9.2.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 @@ -57,6 +57,7 @@ , Blockfrost.Client.Cardano.Assets , Blockfrost.Client.Cardano.Blocks , Blockfrost.Client.Cardano.Epochs + , Blockfrost.Client.Cardano.Governance , Blockfrost.Client.Cardano.Ledger , Blockfrost.Client.Cardano.Mempool , Blockfrost.Client.Cardano.Metadata @@ -68,14 +69,14 @@ , Blockfrost.Client.IPFS , Blockfrost.Client.NutLink build-depends: base >= 4.7 && < 5 - , blockfrost-api >= 0.12.2 - , blockfrost-client-core ^>= 0.6 + , blockfrost-api >= 0.15 + , 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/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -16,20 +16,21 @@ latestBlocks <- getLatestBlock (ers :: Either BlockfrostError [AccountReward]) <- tryError $ getAccountRewards "gonnaFail" - - allMempoolTxs <- - getMempoolTransactions prj def def - - if null allMempoolTxs + + -- variant accepting @Paged@ and @SortOrder@ arguments + -- getAccountRewards' "gonnaFail" (page 10) desc + + allMempoolTxs <- + allPages $ \p -> getMempoolTransactions' p def + + if null allMempoolTxs then return $ (latestBlocks, ers, allMempoolTxs, Nothing) else do let lastTxInMempool = TxHash . unTxHashObject $ last allMempoolTxs - lastMempoolTx <- getMempoolTransaction prj lastTxInMempool - + lastMempoolTx <- getMempoolTransaction lastTxInMempool + return (latestBlocks, ers, allMempoolTxs, Just lastMempoolTx) - - -- variant accepting @Paged@ and @SortOrder@ arguments - -- getAccountRewards' "gonnaFail" (page 10) desc - case res of + + case res of Left e -> print e Right ((latestBlocks, ers, allMempoolTxs, lastMempoolTx)) -> do print "Latest blocks:" @@ -45,16 +46,18 @@ print lastMempoolTx putStrLn "" - case lastMempoolTx of + case lastMempoolTx of Nothing -> print "No mempool transactions found." Just mempoolTx -> do - let inputs = _inputs mempoolTx - if null inputs - then print "No mempool transactions found" -- Should be impossible - else - do let address = Address . _address $ head inputs - mempoolTxByAddress <- runBlockfrost prj $ getMempoolTransactionsByAddress prj address def def - print "Mempool transactions by address:" - print mempoolTxByAddress - - + case _inputs mempoolTx of + [] -> print "No mempool transaction inputs found" -- Should be impossible + (inp:_) -> do + case _address inp of + Nothing -> print "Input has no address" + Just addr -> do + mempoolTxByAddress <- + runBlockfrost prj + $ getMempoolTransactionsByAddress + (Address addr) + print "Mempool transactions by address:" + print mempoolTxByAddress diff --git a/src/Blockfrost/Client.hs b/src/Blockfrost/Client.hs --- a/src/Blockfrost/Client.hs +++ b/src/Blockfrost/Client.hs @@ -92,6 +92,25 @@ , getEpochBlocksByPool , getEpochBlocksByPool' , getEpochProtocolParams + -- Cardano - Governance + , getDReps + , getDReps' + , getDRep + , getDRepDelegators + , getDRepDelegators' + , getDRepMetadata + , getDRepUpdates + , getDRepUpdates' + , getDRepVotes + , getDRepVotes' + , getProposals + , getProposals' + , getProposal + , getParamProposal + , getWithdrawalProposal + , getProposalVotes + , getProposalVotes' + , getProposalMetadata -- Cardano - Ledger , getLedgerGenesis -- Cardano - Metadata @@ -103,8 +122,10 @@ , getTxMetadataByLabelCBOR' -- Cardano - Mempool , getMempoolTransactions + , getMempoolTransactions' , getMempoolTransaction , getMempoolTransactionsByAddress + , getMempoolTransactionsByAddress' -- Cardano - Network , getNetworkInfo , getNetworkEras @@ -185,6 +206,7 @@ import Blockfrost.Client.Cardano.Assets import Blockfrost.Client.Cardano.Blocks import Blockfrost.Client.Cardano.Epochs +import Blockfrost.Client.Cardano.Governance import Blockfrost.Client.Cardano.Ledger import Blockfrost.Client.Cardano.Mempool import Blockfrost.Client.Cardano.Metadata diff --git a/src/Blockfrost/Client/Cardano/Governance.hs b/src/Blockfrost/Client/Cardano/Governance.hs new file mode 100644 --- /dev/null +++ b/src/Blockfrost/Client/Cardano/Governance.hs @@ -0,0 +1,167 @@ +-- | Governance queries + +module Blockfrost.Client.Cardano.Governance + ( getDReps + , getDReps' + , getDRep + , getDRepDelegators + , getDRepDelegators' + , getDRepMetadata + , getDRepUpdates + , getDRepUpdates' + , getDRepVotes + , getDRepVotes' + , getProposals + , getProposals' + , getProposal + , getParamProposal + , getWithdrawalProposal + , getProposalVotes + , getProposalVotes' + , getProposalMetadata + ) where + +import Blockfrost.API +import Blockfrost.Client.Types +import Blockfrost.Types + +governanceClient :: MonadBlockfrost m => Project -> GovernanceAPI (AsClientT m) +governanceClient = fromServant . _governance . cardanoClient + +getDReps_ :: MonadBlockfrost m => Project -> Paged -> SortOrder -> m [DRep] +getDReps_ = _dreps . governanceClient + +-- | Return the information about Delegate Representatives (DReps). +-- Allows custom paging and ordering using 'Paged' and 'SortOrder'. +getDReps' :: MonadBlockfrost m => Paged -> SortOrder -> m [DRep] +getDReps' pg s = go (\p -> getDReps_ p pg s) + +-- | Return the information about Delegate Representatives (DReps). +-- +-- Queries 100 entries. To query all entries use 'Blockfrost.Client.Core.allPages' +-- with principled variant of this function (suffixed with @'@) +-- that accepts 'Paged' argument. +getDReps :: MonadBlockfrost m => m [DRep] +getDReps = getDReps' def def + +getDRep_ :: MonadBlockfrost m => Project -> DRepId -> m DRepInfo +getDRep_ = _drep . governanceClient + +-- | Return the information about specific Delegate Representative (DRep). +getDRep :: MonadBlockfrost m => DRepId -> m DRepInfo +getDRep d = go (`getDRep_` d) + +getDRepDelegators_ :: MonadBlockfrost m => Project -> DRepId -> Paged -> SortOrder -> m [DRepDelegator] +getDRepDelegators_ = _drepDelegators . governanceClient + +-- | Get a list of DRep delegators +-- Allows custom paging and ordering using 'Paged' and 'SortOrder'. +getDRepDelegators' :: MonadBlockfrost m => DRepId -> Paged -> SortOrder -> m [DRepDelegator] +getDRepDelegators' d pg s = go (\p -> getDRepDelegators_ p d pg s) + +-- | Get a list of DRep delegators +-- +-- Queries 100 entries. To query all entries use 'Blockfrost.Client.Core.allPages' +-- with principled variant of this function (suffixed with @'@) +-- that accepts 'Paged' argument. +getDRepDelegators :: MonadBlockfrost m => DRepId -> m [DRepDelegator] +getDRepDelegators d = getDRepDelegators' d def def + +getDRepMetadata_ :: MonadBlockfrost m => Project -> DRepId -> m DRepMeta +getDRepMetadata_ = _drepMetadata . governanceClient + +-- | Get DRep metadata information. +getDRepMetadata :: MonadBlockfrost m => DRepId -> m DRepMeta +getDRepMetadata d = go (`getDRepMetadata_` d) + +getDRepUpdates_ :: MonadBlockfrost m => Project -> DRepId -> Paged -> SortOrder -> m [DRepUpdate] +getDRepUpdates_ = _drepUpdates . governanceClient + +-- | Get a list of certificate updates to the DRep. +-- Allows custom paging and ordering using 'Paged' and 'SortOrder'. +getDRepUpdates' :: MonadBlockfrost m => DRepId -> Paged -> SortOrder -> m [DRepUpdate] +getDRepUpdates' d pg s = go (\p -> getDRepUpdates_ p d pg s) + +-- | Get a list of certificate updates to the DRep. +-- +-- Queries 100 entries. To query all entries use 'Blockfrost.Client.Core.allPages' +-- with principled variant of this function (suffixed with @'@) +-- that accepts 'Paged' argument. +getDRepUpdates :: MonadBlockfrost m => DRepId -> m [DRepUpdate] +getDRepUpdates d = getDRepUpdates' d def def + +getDRepVotes_ :: MonadBlockfrost m => Project -> DRepId -> Paged -> SortOrder -> m [DRepVote] +getDRepVotes_ = _drepVotes . governanceClient + +-- | Get a history of DReps votes. +-- Allows custom paging and ordering using 'Paged' and 'SortOrder'. +getDRepVotes' :: MonadBlockfrost m => DRepId -> Paged -> SortOrder -> m [DRepVote] +getDRepVotes' d pg s = go (\p -> getDRepVotes_ p d pg s) + +-- | Get a history of DReps votes. +-- +-- Queries 100 entries. To query all entries use 'Blockfrost.Client.Core.allPages' +-- with principled variant of this function (suffixed with @'@) +-- that accepts 'Paged' argument. +getDRepVotes :: MonadBlockfrost m => DRepId -> m [DRepVote] +getDRepVotes d = getDRepVotes' d def def + +getProposals_ :: MonadBlockfrost m => Project -> Paged -> SortOrder -> m [Proposal] +getProposals_ = _proposals . governanceClient + +-- | Get a history of DReps proposals. +-- Allows custom paging and ordering using 'Paged' and 'SortOrder'. +getProposals' :: MonadBlockfrost m => Paged -> SortOrder -> m [Proposal] +getProposals' pg s = go (\p -> getProposals_ p pg s) + +-- | Get a history of DReps proposals. +-- +-- Queries 100 entries. To query all entries use 'Blockfrost.Client.Core.allPages' +-- with principled variant of this function (suffixed with @'@) +-- that accepts 'Paged' argument. +getProposals :: MonadBlockfrost m => m [Proposal] +getProposals = getProposals' def def + +getProposal_ :: MonadBlockfrost m => Project -> TxHash -> Integer -> m ProposalInfo +getProposal_ = _proposal . governanceClient + +-- | Get a proposal details. +getProposal :: MonadBlockfrost m => TxHash -> Integer -> m ProposalInfo +getProposal txHash certIdx = go (\p -> getProposal_ p txHash certIdx) + +getParamProposal_ :: MonadBlockfrost m => Project -> TxHash -> Integer -> m ParamProposal +getParamProposal_ = _paramProposal . governanceClient + +-- | Get a parameter proposal details. +getParamProposal :: MonadBlockfrost m => TxHash -> Integer -> m ParamProposal +getParamProposal txHash certIdx = go (\p -> getParamProposal_ p txHash certIdx) + +getWithdrawalProposal_ :: MonadBlockfrost m => Project -> TxHash -> Integer -> m [WithdrawalProposal] +getWithdrawalProposal_ = _withdrawalProposal . governanceClient + +-- | Get a witdhrawal proposal details. +getWithdrawalProposal :: MonadBlockfrost m => TxHash -> Integer -> m [WithdrawalProposal] +getWithdrawalProposal txHash certIdx = go (\p -> getWithdrawalProposal_ p txHash certIdx) + +getProposalVotes_ :: MonadBlockfrost m => Project -> TxHash -> Integer -> Paged -> SortOrder -> m [ProposalVote] +getProposalVotes_ = _proposalVotes . governanceClient + +-- | Get a history of DReps proposals. +-- Allows custom paging and ordering using 'Paged' and 'SortOrder'. +getProposalVotes' :: MonadBlockfrost m => TxHash -> Integer -> Paged -> SortOrder -> m [ProposalVote] +getProposalVotes' txHash certIdx pg s = go (\p -> getProposalVotes_ p txHash certIdx pg s) + +-- | Get a history of DReps proposals. +-- +-- Queries 100 entries. To query all entries use 'Blockfrost.Client.Core.allPages' +-- with principled variant of this function (suffixed with @'@) +-- that accepts 'Paged' argument. +getProposalVotes :: MonadBlockfrost m => TxHash -> Integer -> m [ProposalVote] +getProposalVotes txHash certIdx = getProposalVotes' txHash certIdx def def + +getProposalMetadata_ :: MonadBlockfrost m => Project -> TxHash -> Integer -> m ProposalMeta +getProposalMetadata_ = _proposalMeta . governanceClient + +-- | Get a parameter proposal details. +getProposalMetadata :: MonadBlockfrost m => TxHash -> Integer -> m ProposalMeta +getProposalMetadata txHash certIdx = go (\p -> getProposalMetadata_ p txHash certIdx) diff --git a/src/Blockfrost/Client/Cardano/Mempool.hs b/src/Blockfrost/Client/Cardano/Mempool.hs --- a/src/Blockfrost/Client/Cardano/Mempool.hs +++ b/src/Blockfrost/Client/Cardano/Mempool.hs @@ -2,8 +2,10 @@ module Blockfrost.Client.Cardano.Mempool ( getMempoolTransactions - , getMempoolTransaction + , getMempoolTransactions' + , getMempoolTransaction , getMempoolTransactionsByAddress + , getMempoolTransactionsByAddress' ) where import Blockfrost.API @@ -13,12 +15,43 @@ mempoolClient :: MonadBlockfrost m => Project -> MempoolAPI (AsClientT m) mempoolClient = fromServant . _mempool . cardanoClient -getMempoolTransactions :: MonadBlockfrost m => Project -> Paged -> SortOrder -> m [TxHashObject] -getMempoolTransactions = _mempoolTransactions . mempoolClient +getMempoolTransactions_ :: MonadBlockfrost m => Project -> Paged -> SortOrder -> m [TxHashObject] +getMempoolTransactions_ = _mempoolTransactions . mempoolClient -getMempoolTransaction :: MonadBlockfrost m => Project -> TxHash -> m MempoolTransaction -getMempoolTransaction = _specificTransaction . mempoolClient +-- | Get a list of transactions currently in Blockfrost.io mempool +-- Allows custom paging and ordering using 'Paged' and 'SortOrder'. +getMempoolTransactions' :: MonadBlockfrost m => Paged -> SortOrder -> m [TxHashObject] +getMempoolTransactions' pg s = go (\p -> getMempoolTransactions_ p pg s) -getMempoolTransactionsByAddress :: MonadBlockfrost m => Project -> Address -> Paged -> SortOrder -> m [TxHashObject] -getMempoolTransactionsByAddress = _specificAddress . mempoolClient +-- | Get a list of transactions currently in Blockfrost.io mempool +-- +-- Queries 100 entries. To query all entries use 'Blockfrost.Client.Core.allPages' +-- with principled variant of this function (suffixed with @'@) +-- that accepts 'Paged' argument. +getMempoolTransactions :: MonadBlockfrost m => m [TxHashObject] +getMempoolTransactions = getMempoolTransactions' def def +getMempoolTransaction_ :: MonadBlockfrost m => Project -> TxHash -> m MempoolTransaction +getMempoolTransaction_ = _specificTransaction . mempoolClient + +-- | Get details about a specific @MempoolTransaction@ +getMempoolTransaction :: MonadBlockfrost m => TxHash -> m MempoolTransaction +getMempoolTransaction t = go (`getMempoolTransaction_` t) + +getMempoolTransactionsByAddress_ :: MonadBlockfrost m => Project -> Address -> Paged -> SortOrder -> m [TxHashObject] +getMempoolTransactionsByAddress_ = _specificAddress . mempoolClient + +-- | Get a list of transactions currently in Blockfrost.io mempool +-- where at least one of the transaction inputs or outputs belongs to the address. +-- Allows custom paging and ordering using 'Paged' and 'SortOrder'. +getMempoolTransactionsByAddress' :: MonadBlockfrost m => Address -> Paged -> SortOrder -> m [TxHashObject] +getMempoolTransactionsByAddress' addr pg s = go (\p -> getMempoolTransactionsByAddress_ p addr pg s) + +-- | Get a list of transactions currently in Blockfrost.io mempool +-- where at least one of the transaction inputs or outputs belongs to the address. +-- +-- Queries 100 entries. To query all entries use 'Blockfrost.Client.Core.allPages' +-- with principled variant of this function (suffixed with @'@) +-- that accepts 'Paged' argument. +getMempoolTransactionsByAddress :: MonadBlockfrost m => Address -> m [TxHashObject] +getMempoolTransactionsByAddress addr = go (\p -> getMempoolTransactionsByAddress_ p addr def def) 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