cardano-rpc | Add UTxO RPC: submitTx method

Author: carbolymer

cardano-rpc/cardano-rpc.cabal

@@ -55,19 +55,23 @@ library
     Cardano.Rpc.Client
     Cardano.Rpc.Proto.Api.Node
     Cardano.Rpc.Proto.Api.UtxoRpc.Query
+    Cardano.Rpc.Proto.Api.UtxoRpc.Submit
     Cardano.Rpc.Server
     Cardano.Rpc.Server.Config
     Cardano.Rpc.Server.Internal.Env
     Cardano.Rpc.Server.Internal.Error
     Cardano.Rpc.Server.Internal.Monad
     Cardano.Rpc.Server.Internal.UtxoRpc.Query
     Cardano.Rpc.Server.Internal.UtxoRpc.Type
+    Cardano.Rpc.Server.Internal.UtxoRpc.Submit
     Proto.Cardano.Rpc.Node
     Proto.Cardano.Rpc.Node_Fields
     Proto.Utxorpc.V1alpha.Cardano.Cardano
     Proto.Utxorpc.V1alpha.Cardano.Cardano_Fields
     Proto.Utxorpc.V1alpha.Query.Query
     Proto.Utxorpc.V1alpha.Query.Query_Fields
+    Proto.Utxorpc.V1alpha.Submit.Submit
+    Proto.Utxorpc.V1alpha.Submit.Submit_Fields
 
   other-modules:
     Cardano.Rpc.Server.Internal.Orphans
@@ -81,6 +85,8 @@ library
     Proto.Utxorpc.V1alpha.Cardano.Cardano_Fields
     Proto.Utxorpc.V1alpha.Query.Query
     Proto.Utxorpc.V1alpha.Query.Query_Fields
+    Proto.Utxorpc.V1alpha.Submit.Submit
+    Proto.Utxorpc.V1alpha.Submit.Submit_Fields
 
   build-depends:
     base,

cardano-rpc/proto/utxorpc/v1alpha/submit/submit.proto

@@ -14,9 +14,18 @@ message SubmitTxRequest {
   repeated AnyChainTx tx = 1; // List of transactions to submit.
 }
 
+// TODO u5c: new type
+message TxSubmitResult {
+  oneof result {
+    bytes ref = 1; // Transaction references.
+    string error_message = 2; // The error message
+  }
+}
+
 // Response containing references to the submitted transactions.
+// TODO u5c: changed type
 message SubmitTxResponse {
-  repeated bytes ref = 1; // List of transaction references.
+  repeated TxSubmitResult results = 1; // List of either transaction references or error messages.
 }
 
 // Service definition for submitting transactions and checking their status.

cardano-rpc/src/Cardano/Rpc/Proto/Api/UtxoRpc/Submit.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Cardano.Rpc.Proto.Api.UtxoRpc.Submit
+  ( module Proto.Utxorpc.V1alpha.Submit.Submit
+  , module Proto.Utxorpc.V1alpha.Submit.Submit_Fields
+  )
+where
+
+import Network.GRPC.Common
+import Network.GRPC.Common.Protobuf
+
+import Proto.Utxorpc.V1alpha.Submit.Submit
+import Proto.Utxorpc.V1alpha.Submit.Submit_Fields
+
+type instance RequestMetadata (Protobuf SubmitService meth) = NoMetadata
+
+type instance ResponseInitialMetadata (Protobuf SubmitService meth) = NoMetadata
+
+type instance ResponseTrailingMetadata (Protobuf SubmitService meth) = NoMetadata

cardano-rpc/src/Cardano/Rpc/Server.hs

@@ -17,11 +17,13 @@ where
 import Cardano.Api
 import Cardano.Rpc.Proto.Api.Node qualified as Rpc
 import Cardano.Rpc.Proto.Api.UtxoRpc.Query qualified as UtxoRpc
+import Cardano.Rpc.Proto.Api.UtxoRpc.Submit qualified as UtxoRpc
 import Cardano.Rpc.Server.Config
 import Cardano.Rpc.Server.Internal.Env
 import Cardano.Rpc.Server.Internal.Monad
 import Cardano.Rpc.Server.Internal.Orphans ()
 import Cardano.Rpc.Server.Internal.UtxoRpc.Query
+import Cardano.Rpc.Server.Internal.UtxoRpc.Submit
 
 import RIO
 
@@ -60,6 +62,12 @@ methodsUtxoRpc =
     . Method (mkNonStreaming readUtxosMethod)
     $ NoMoreMethods
 
+methodsUtxoRpcSubmit
+  :: MonadRpc e m
+  => Methods m (ProtobufMethodsOf UtxoRpc.SubmitService)
+methodsUtxoRpcSubmit =
+  Method (mkNonStreaming submitTxMethod) NoMoreMethods
+
 runRpcServer
   :: Tracer IO String
   -> IO (RpcConfig, NetworkMagic)
@@ -97,6 +105,7 @@ runRpcServer tracer loadRpcConfig = handleFatalExceptions $ do
           mconcat
             [ fromMethods methodsNodeRpc
             , fromMethods methodsUtxoRpc
+            , fromMethods methodsUtxoRpcSubmit
             ]
  where
   serverParams :: ServerParams

cardano-rpc/src/Cardano/Rpc/Server/Internal/UtxoRpc/Submit.hs

@@ -0,0 +1,85 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingVia #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Cardano.Rpc.Server.Internal.UtxoRpc.Submit
+  ( submitTxMethod
+  )
+where
+
+import Cardano.Api
+import Cardano.Api.Network.IPC qualified as Net.Tx
+import Cardano.Rpc.Proto.Api.UtxoRpc.Submit qualified as UtxoRpc
+import Cardano.Rpc.Server.Internal.Error
+import Cardano.Rpc.Server.Internal.Monad
+import Cardano.Rpc.Server.Internal.Orphans ()
+
+import RIO hiding (toList)
+
+import Data.Default
+import Network.GRPC.Spec
+
+-- | Submit a CBOR-serialised list of transactions to the node
+submitTxMethod
+  :: MonadRpc e m
+  => Proto UtxoRpc.SubmitTxRequest
+  -> m (Proto UtxoRpc.SubmitTxResponse)
+-- ^ A list of succeeded transaction ids or errors for failed ones
+submitTxMethod req = do
+  -- index transactions in the request
+  let serialisedTxs = zip @Int [0 ..] $ req ^.. #tx . traverse . #raw
+
+  nodeConnInfo <- grab
+  AnyCardanoEra era <- liftIO . throwExceptT $ determineEra nodeConnInfo
+  eon <- forEraInEon era (error "Minimum Shelley era required") pure
+
+  -- try to submit each one consecutively
+  submitResults <- forM serialisedTxs $ \(i, txBytes) -> do
+    let eTx =
+          first (("Failed to decode transaction with index " <> show i <> ": ") <>) $
+            deserialiseTx eon txBytes
+
+    eTxId <-
+      fmap join . forM eTx $
+        fmap
+          ( first
+              ( ("Failed to submit transaction with index " <> show i <> ": ")
+                  <>
+              )
+          )
+          . submitTx eon
+
+    pure $ case eTxId of
+      Left err -> def & #errorMessage .~ fromString err
+      Right txId' -> def & #ref .~ serialiseToRawBytes txId'
+
+  pure $ def & #results .~ submitResults
+ where
+  deserialiseTx :: ShelleyBasedEra era -> ByteString -> Either String (Tx era)
+  deserialiseTx sbe = shelleyBasedEraConstraints sbe $ first show . deserialiseFromCBOR asType
+
+  submitTx
+    :: MonadRpc e m
+    => ShelleyBasedEra era
+    -> Tx era
+    -> m (Either String TxId)
+  submitTx sbe tx = do
+    nodeConnInfo <- grab
+    eRes <-
+      tryAny $
+        submitTxToNodeLocal nodeConnInfo (TxInMode sbe tx) >>= \case
+          Net.Tx.SubmitFail reason -> pure . Left $ show reason
+          Net.Tx.SubmitSuccess -> pure $ Right . getTxId $ getTxBody tx
+    case eRes of
+      Left err -> do
+        let errString = displayException err
+        putTrace $ "N2C connection error while trying to submit a transaction: " <> errString
+        pure $ Left errString
+      Right res -> pure res