|
| 1 | +{-# LANGUAGE ConstraintKinds #-} |
| 2 | +{-# LANGUAGE DataKinds #-} |
| 3 | +{-# LANGUAGE DerivingVia #-} |
| 4 | +{-# LANGUAGE FlexibleContexts #-} |
| 5 | +{-# LANGUAGE GADTs #-} |
| 6 | +{-# LANGUAGE LambdaCase #-} |
| 7 | +{-# LANGUAGE OverloadedLabels #-} |
| 8 | +{-# LANGUAGE QuantifiedConstraints #-} |
| 9 | +{-# LANGUAGE RankNTypes #-} |
| 10 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 11 | +{-# LANGUAGE TupleSections #-} |
| 12 | +{-# LANGUAGE TypeApplications #-} |
| 13 | + |
| 14 | +module Cardano.Rpc.Server.Internal.UtxoRpc.Submit |
| 15 | + ( submitTxMethod |
| 16 | + ) |
| 17 | +where |
| 18 | + |
| 19 | +import Cardano.Api |
| 20 | +import Cardano.Api.Network.IPC qualified as Net.Tx |
| 21 | +import Cardano.Rpc.Proto.Api.UtxoRpc.Submit qualified as UtxoRpc |
| 22 | +import Cardano.Rpc.Server.Internal.Error |
| 23 | +import Cardano.Rpc.Server.Internal.Monad |
| 24 | +import Cardano.Rpc.Server.Internal.Orphans () |
| 25 | + |
| 26 | +import RIO hiding (toList) |
| 27 | + |
| 28 | +import Data.ProtoLens (defMessage) |
| 29 | +import Network.GRPC.Spec |
| 30 | + |
| 31 | +submitTxMethod |
| 32 | + :: forall e m |
| 33 | + . MonadRpc e m |
| 34 | + => Proto UtxoRpc.SubmitTxRequest |
| 35 | + -> m (Proto UtxoRpc.SubmitTxResponse) |
| 36 | +submitTxMethod req = do |
| 37 | + let serialisedTxs = zip @Int [0 ..] $ req ^.. #tx . traverse . #raw |
| 38 | + |
| 39 | + nodeConnInfo <- grab |
| 40 | + AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo |
| 41 | + eon <- forEraInEon era (error "Minimum Shelley era required") pure |
| 42 | + |
| 43 | + let (failedTxs, txs) = partitionEithers $ serialisedTxs <&> \(i, tx) -> bimap (i,) (i,) $ deserialiseTx eon tx |
| 44 | + |
| 45 | + -- TODO failures need to be included in the returned type, and not dumped to node logs |
| 46 | + forM_ failedTxs $ \(i, err) -> do |
| 47 | + putTrace $ "Failed to decode transaction with index: " <> show i <> " / " <> err |
| 48 | + |
| 49 | + (failedSubmissionTxs, txIds) <- fmap partitionEithers . forM txs $ \(i, tx) -> bimap (i,) (i,) <$> submitTx eon tx |
| 50 | + |
| 51 | + -- TODO failures need to be included in the returned type, and not dumped to node logs |
| 52 | + forM_ failedSubmissionTxs $ \(i, err) -> do |
| 53 | + putTrace $ "Failed to submit transaction with index: " <> show i <> " / " <> err |
| 54 | + |
| 55 | + -- TODO: so now, to check if the submission has succeeded, one has to check if the TxId is in the returned list. |
| 56 | + pure $ defMessage & #ref .~ map (serialiseToRawBytes . snd) txIds |
| 57 | + where |
| 58 | + deserialiseTx :: ShelleyBasedEra era -> ByteString -> Either String (Tx era) |
| 59 | + deserialiseTx sbe = shelleyBasedEraConstraints sbe $ first show . deserialiseFromCBOR asType |
| 60 | + |
| 61 | + submitTx |
| 62 | + :: ShelleyBasedEra era |
| 63 | + -> Tx era |
| 64 | + -> m (Either String TxId) |
| 65 | + submitTx sbe tx = do |
| 66 | + nodeConnInfo <- grab |
| 67 | + eRes <- |
| 68 | + tryAny $ |
| 69 | + submitTxToNodeLocal nodeConnInfo (TxInMode sbe tx) >>= \case |
| 70 | + Net.Tx.SubmitFail reason -> pure . Left $ show reason |
| 71 | + Net.Tx.SubmitSuccess -> pure $ Right . getTxId $ getTxBody tx |
| 72 | + case eRes of |
| 73 | + Left err -> do |
| 74 | + let errString = displayException err |
| 75 | + putTrace $ "N2C connection error while trying to submit a transaction: " <> errString |
| 76 | + pure $ Left errString |
| 77 | + Right res -> pure res |
0 commit comments