Merge #3418

3418: [ADP-2099] post tx without blocking on mempool full in light mode r=paolino a=paolino




- [x] added support for post transactions in light mode
- [x] added error forwarding on mempool (HTTP 425) error from blockfrost


### Issue Number
ADP-2099


Co-authored-by: paolo veronelli <paolo.veronelli@gmail.com>

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -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

lib/core/src/Cardano/Wallet/Api/Types.hs

@@ -1774,6 +1774,7 @@ data ApiErrorCode
     | InvalidValidityBounds
     | KeyNotFoundForAddress
     | MalformedTxPayload
+    | MempoolIsFull
     | MethodNotAllowed
     | MinWithdrawalWrong
     | MintOrBurnAssetQuantityOutOfBounds

lib/core/src/Cardano/Wallet/Network.hs

@@ -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

lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost.hs

@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
 -------------------------------------------------------------------------------}

lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Layer.hs

@@ -21,6 +21,7 @@ import Blockfrost.Client
     , Block
     , BlockHash
     , BlockIndex
+    , CBORString
     , EpochInfo
     , Genesis
     , Network
@@ -61,6 +62,7 @@ import Blockfrost.Client
     , getTxWithdrawals
     , listPools'
     , paged
+    , submitTx
     )
 import Cardano.BM.Tracing
     ( HasSeverityAnnotation (getSeverityAnnotation)
@@ -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
@@ -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
@@ -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 ::
@@ -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

lib/shelley/src/Cardano/Wallet/Shelley/Network/Blockfrost/Monad.hs

@@ -25,7 +25,7 @@ import Control.Monad.Trans.Control
 import Data.Maybe
     ( fromMaybe )
 import Network.HTTP.Types
-    ( status404 )
+    ( Status (statusCode) )
 import Servant.Client
     ( runClientM )
 
@@ -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
+

specifications/api/swagger.yaml

@@ -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
@@ -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
@@ -5578,6 +5596,7 @@ x-responsesPostExternalTransaction: &responsesPostExternalTransaction
   <<: *responsesErr400
   <<: *responsesErr406
   <<: *responsesErr415UnsupportedMediaType
+  <<: *responsesErr425MempoolIsFull
   202:
     description: Accepted
     content: