Skip to content

Commit

Permalink
Try #3418:
Browse files Browse the repository at this point in the history
  • Loading branch information
iohk-bors[bot] authored Aug 11, 2022
2 parents 8dd5d6f + 8807103 commit 4ff7ba7
Show file tree
Hide file tree
Showing 7 changed files with 78 additions and 11 deletions.
10 changes: 10 additions & 0 deletions lib/core/src/Cardano/Wallet/Api/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -4881,6 +4881,16 @@ instance IsServerError ErrPostTx where
, "node. Here's an error message that may help with "
, "debugging:\n", err
]
ErrPostTxMempoolFull ->
apiError err425
{errBody = "Mempool is full, please try resubmitting again later."}
MempoolIsFull $ mconcat
[ "The submitted transaction was rejected by the Cardano node "
, "because its mempool was full."
]

err425 :: ServerError
err425 = ServerError 425 "Too early" "" []

instance IsServerError ErrSubmitTransaction where
toServerError = \case
Expand Down
1 change: 1 addition & 0 deletions lib/core/src/Cardano/Wallet/Api/Types.hs
Original file line number Diff line number Diff line change
Expand Up @@ -1774,6 +1774,7 @@ data ApiErrorCode
| InvalidValidityBounds
| KeyNotFoundForAddress
| MalformedTxPayload
| MempoolIsFull
| MethodNotAllowed
| MinWithdrawalWrong
| MintOrBurnAssetQuantityOutOfBounds
Expand Down
4 changes: 3 additions & 1 deletion lib/core/src/Cardano/Wallet/Network.hs
Original file line number Diff line number Diff line change
Expand Up @@ -279,12 +279,14 @@ mapChainFollower fpoint12 fpoint21 ftip fblocks cf =
-------------------------------------------------------------------------------}

-- | Error while trying to send a transaction
newtype ErrPostTx = ErrPostTxValidationError Text
data ErrPostTx = ErrPostTxValidationError Text | ErrPostTxMempoolFull
deriving (Generic, Show, Eq)

instance ToText ErrPostTx where
toText = \case
ErrPostTxValidationError msg -> msg
ErrPostTxMempoolFull ->
"mempool was full and refused posted transaction"

{-------------------------------------------------------------------------------
Logging
Expand Down
31 changes: 27 additions & 4 deletions lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs
Original file line number Diff line number Diff line change
Expand Up @@ -63,7 +63,7 @@ import Cardano.Wallet.Api.Types
import Cardano.Wallet.Logging
( BracketLog, bracketTracer )
import Cardano.Wallet.Network
( ChainFollower, NetworkLayer (..) )
( ChainFollower, ErrPostTx (..), NetworkLayer (..) )
import Cardano.Wallet.Network.Light
( Consensual (..), LightSyncSource (..) )
import Cardano.Wallet.Primitive.BlockSummary
Expand Down Expand Up @@ -134,7 +134,14 @@ import Cardano.Wallet.Primitive.Types.TokenMap
import Cardano.Wallet.Primitive.Types.TokenQuantity
( TokenQuantity (..) )
import Cardano.Wallet.Primitive.Types.Tx
( Tx (..), TxIn (..), TxOut (..), TxScriptValidity (..), TxSize (..) )
( SealedTx
, Tx (..)
, TxIn (..)
, TxOut (..)
, TxScriptValidity (..)
, TxSize (..)
, serialisedTx
)
import Cardano.Wallet.Shelley.Network.Blockfrost.Conversion
( bfBlockHeader
, fromBfAddress
Expand All @@ -150,7 +157,11 @@ import Cardano.Wallet.Shelley.Network.Blockfrost.Error
, (<?#>)
)
import Cardano.Wallet.Shelley.Network.Blockfrost.Layer
( BlockfrostLayer (..), rateLimitedBlockfrostLayer, withRecovery )
( BlockfrostLayer (..)
, PostTxResult (..)
, rateLimitedBlockfrostLayer
, withRecovery
)
import Cardano.Wallet.Shelley.Network.Discriminant
( SomeNetworkDiscriminant (..), networkDiscriminantToId )
import Control.Concurrent
Expand Down Expand Up @@ -250,6 +261,7 @@ import qualified Cardano.Wallet.Shelley.Network.Blockfrost.Layer as Layer
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as Aeson
import qualified Data.Aeson.KeyMap as Aeson
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
Expand Down Expand Up @@ -284,7 +296,7 @@ withNetworkLayer tr network np project k = do
, currentProtocolParameters = currentProtocolParameters bfLayer
, currentSlottingParameters = currentSlottingParameters bfLayer
, watchNodeTip = subscribeNodeTip tipBroadcast
, postTx = undefined
, postTx = postBFTransaction bfLayer
, stakeDistribution = stakePoolsSummary bfLayer
, getCachedRewardAccountBalance =
getCachedRewardAccountBalance bfLayer
Expand Down Expand Up @@ -447,6 +459,17 @@ withNetworkLayer tr network np project k = do
throwIO . BlockfrostException $
PoolStakePercentageError total live

postBFTransaction ::
BlockfrostLayer IO ->
SealedTx ->
ExceptT ErrPostTx IO ()
postBFTransaction BlockfrostLayer{..} sealed = ExceptT $ do
result <- bfPostTx $ BF.CBORString
$ BL.fromStrict $ serialisedTx sealed
pure $ case result of
Accepted _ -> Right ()
NotAcceptedMempoolFull -> Left ErrPostTxMempoolFull

{-------------------------------------------------------------------------------
LightSyncSource
-------------------------------------------------------------------------------}
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -21,6 +21,7 @@ import Blockfrost.Client
, Block
, BlockHash
, BlockIndex
, CBORString
, EpochInfo
, Genesis
, Network
Expand Down Expand Up @@ -61,6 +62,7 @@ import Blockfrost.Client
, getTxWithdrawals
, listPools'
, paged
, submitTx
)
import Cardano.BM.Tracing
( HasSeverityAnnotation (getSeverityAnnotation)
Expand All @@ -71,7 +73,7 @@ import Cardano.BM.Tracing
import Cardano.Wallet.Network.Light
( Consensual )
import Cardano.Wallet.Shelley.Network.Blockfrost.Monad
( BFM, consensual404, empty404, maybe404 )
( BFM, consensual404, empty404, handleStatus, maybe404 )
import Control.Concurrent
( threadDelay )
import Control.Monad
Expand Down Expand Up @@ -144,8 +146,11 @@ data BlockfrostLayer m = BlockfrostLayer
m Network
, bfListPools ::
m [PoolId]
, bfPostTx :: CBORString -> m PostTxResult
}

data PostTxResult = Accepted TxHash | NotAcceptedMempoolFull

blockfrostLayer :: BlockfrostLayer BFM
blockfrostLayer = BlockfrostLayer
{ bfGetLatestBlock = getLatestBlock
Expand Down Expand Up @@ -177,6 +182,7 @@ blockfrostLayer = BlockfrostLayer
empty404 $ allPages' \p -> getAccountWithdrawals' a p Ascending
, bfGetNetworkInfo = getNetworkInfo
, bfListPools = allPages' (`listPools'` Ascending)
, bfPostTx = handleStatus NotAcceptedMempoolFull Accepted 425 . submitTx
}

hoistBlockfrostLayer ::
Expand Down Expand Up @@ -206,6 +212,7 @@ hoistBlockfrostLayer BlockfrostLayer{..} nt =
, bfGetAccountWithdrawals = nt . bfGetAccountWithdrawals
, bfGetNetworkInfo = nt bfGetNetworkInfo
, bfListPools = nt bfListPools
, bfPostTx = nt . bfPostTx
}

withRecovery :: Tracer IO Log -> BlockfrostLayer IO -> BlockfrostLayer IO
Expand Down
15 changes: 10 additions & 5 deletions lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,7 +25,7 @@ import Control.Monad.Trans.Control
import Data.Maybe
( fromMaybe )
import Network.HTTP.Types
( status404 )
( Status (statusCode) )
import Servant.Client
( runClientM )

Expand Down Expand Up @@ -57,13 +57,18 @@ run :: BF.ClientConfig -> (forall a. BFM a -> IO a)
run cfg (BFM c) = throwBlockfrostError (runReaderT c cfg)

maybe404 :: BFM a -> BFM (Maybe a)
maybe404 bfm = (Just <$> bfm) `catchError` \case
ClientError (Servant.FailureResponse _ (Servant.Response s _ _ _))
| s == status404 -> pure Nothing
e -> throwError e
maybe404 = handleStatus Nothing Just 404

empty404 :: Monoid a => BFM a -> BFM a
empty404 = (fromMaybe mempty <$>) . maybe404

consensual404 :: BFM a -> BFM (Consensual a)
consensual404 = (maybe NotConsensual Consensual <$>) . maybe404

handleStatus :: b -> (a -> b) -> Int -> BFM a -> BFM b
handleStatus notMatched matched status bfm =
(matched <$> bfm) `catchError` \case
ClientError (Servant.FailureResponse _ (Servant.Response s _ _ _))
| statusCode s == status -> pure notMatched
e -> throwError e

19 changes: 19 additions & 0 deletions specifications/api/swagger.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -4163,6 +4163,17 @@ x-errMalformedTxPayload: &errMalformedTxPayload
type: string
enum: ['malformed_tx_payload']

x-errMempoolIsFull: &errMempoolIsFull
<<: *responsesErr
title: mempool_is_full
properties:
message:
type: string
description: May occur when submitting a serialized transaction to a node with full mempool.
code:
type: string
enum: [mempool_is_full]

x-errTokensMintedButNotSpentOrBurned: &errTokensMintedButNotSpentOrBurned
<<: *responsesErr
title: tokens_minted_but_not_spent_or_burned
Expand Down Expand Up @@ -5110,6 +5121,13 @@ x-responsesErr423: &responsesErr423
application/json:
schema: *responsesErr

x-responsesErr425MempoolIsFull: &responsesErr425MempoolIsFull
425:
description: Mempool is Full
content:
application/json:
schema: *errMempoolIsFull

x-responsesErr404WalletNotFound: &responsesErr404WalletNotFound
404:
description: Not Found
Expand Down Expand Up @@ -5578,6 +5596,7 @@ x-responsesPostExternalTransaction: &responsesPostExternalTransaction
<<: *responsesErr400
<<: *responsesErr406
<<: *responsesErr415UnsupportedMediaType
<<: *responsesErr425MempoolIsFull
202:
description: Accepted
content:
Expand Down

0 comments on commit 4ff7ba7

Please sign in to comment.