{-# 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 :: forall e (m :: * -> *).
MonadRpc e m =>
Proto SubmitTxRequest -> m (Proto SubmitTxResponse)
submitTxMethod Proto SubmitTxRequest
req = do
  -- index transactions in the request
  let serialisedTxs :: [(Int, ByteString)]
serialisedTxs = forall a b. [a] -> [b] -> [(a, b)]
zip @Int [Int
0 ..] ([ByteString] -> [(Int, ByteString)])
-> [ByteString] -> [(Int, ByteString)]
forall a b. (a -> b) -> a -> b
$ Proto SubmitTxRequest
req Proto SubmitTxRequest
-> Getting (Endo [ByteString]) (Proto SubmitTxRequest) ByteString
-> [ByteString]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ([Proto AnyChainTx]
 -> Const (Endo [ByteString]) [Proto AnyChainTx])
-> Proto SubmitTxRequest
-> Const (Endo [ByteString]) (Proto SubmitTxRequest)
#tx (([Proto AnyChainTx]
  -> Const (Endo [ByteString]) [Proto AnyChainTx])
 -> Proto SubmitTxRequest
 -> Const (Endo [ByteString]) (Proto SubmitTxRequest))
-> ((ByteString -> Const (Endo [ByteString]) ByteString)
    -> [Proto AnyChainTx]
    -> Const (Endo [ByteString]) [Proto AnyChainTx])
-> Getting (Endo [ByteString]) (Proto SubmitTxRequest) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proto AnyChainTx -> Const (Endo [ByteString]) (Proto AnyChainTx))
-> [Proto AnyChainTx]
-> Const (Endo [ByteString]) [Proto AnyChainTx]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((Proto AnyChainTx -> Const (Endo [ByteString]) (Proto AnyChainTx))
 -> [Proto AnyChainTx]
 -> Const (Endo [ByteString]) [Proto AnyChainTx])
-> ((ByteString -> Const (Endo [ByteString]) ByteString)
    -> Proto AnyChainTx
    -> Const (Endo [ByteString]) (Proto AnyChainTx))
-> (ByteString -> Const (Endo [ByteString]) ByteString)
-> [Proto AnyChainTx]
-> Const (Endo [ByteString]) [Proto AnyChainTx]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const (Endo [ByteString]) ByteString)
-> Proto AnyChainTx -> Const (Endo [ByteString]) (Proto AnyChainTx)
#raw

  nodeConnInfo <- m LocalNodeConnectInfo
forall field env (m :: * -> *).
(Has field env, MonadReader env m) =>
m field
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 $ \(Int
i, ByteString
txBytes) -> do
    let eTx :: Either String (Tx era)
eTx =
          (String -> String)
-> Either String (Tx era) -> Either String (Tx era)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((String
"Failed to decode transaction with index " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ") String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (Either String (Tx era) -> Either String (Tx era))
-> Either String (Tx era) -> Either String (Tx era)
forall a b. (a -> b) -> a -> b
$
            ShelleyBasedEra era -> ByteString -> Either String (Tx era)
forall era.
ShelleyBasedEra era -> ByteString -> Either String (Tx era)
deserialiseTx ShelleyBasedEra era
eon ByteString
txBytes

    eTxId <-
      (Either String (Either String TxId) -> Either String TxId)
-> m (Either String (Either String TxId)) -> m (Either String TxId)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either String (Either String TxId) -> Either String TxId
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (m (Either String (Either String TxId)) -> m (Either String TxId))
-> ((Tx era -> m (Either String TxId))
    -> m (Either String (Either String TxId)))
-> (Tx era -> m (Either String TxId))
-> m (Either String TxId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String (Tx era)
-> (Tx era -> m (Either String TxId))
-> m (Either String (Either String TxId))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Either String (Tx era)
eTx ((Tx era -> m (Either String TxId)) -> m (Either String TxId))
-> (Tx era -> m (Either String TxId)) -> m (Either String TxId)
forall a b. (a -> b) -> a -> b
$
        (Either String TxId -> Either String TxId)
-> m (Either String TxId) -> m (Either String TxId)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
          ( (String -> String) -> Either String TxId -> Either String TxId
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
              ( (String
"Failed to submit transaction with index " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": ")
                  String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
              )
          )
          (m (Either String TxId) -> m (Either String TxId))
-> (Tx era -> m (Either String TxId))
-> Tx era
-> m (Either String TxId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra era -> Tx era -> m (Either String TxId)
forall e (m :: * -> *) era.
MonadRpc e m =>
ShelleyBasedEra era -> Tx era -> m (Either String TxId)
submitTx ShelleyBasedEra era
eon

    pure $ case eTxId of
      Left String
err -> Proto TxSubmitResult
forall a. Default a => a
def Proto TxSubmitResult
-> (Proto TxSubmitResult -> Proto TxSubmitResult)
-> Proto TxSubmitResult
forall a b. a -> (a -> b) -> b
& ASetter (Proto TxSubmitResult) (Proto TxSubmitResult) Text Text
#errorMessage ASetter (Proto TxSubmitResult) (Proto TxSubmitResult) Text Text
-> Text -> Proto TxSubmitResult -> Proto TxSubmitResult
forall s t a b. ASetter s t a b -> b -> s -> t
.~ String -> Text
forall a. IsString a => String -> a
fromString String
err
      Right TxId
txId' -> Proto TxSubmitResult
forall a. Default a => a
def Proto TxSubmitResult
-> (Proto TxSubmitResult -> Proto TxSubmitResult)
-> Proto TxSubmitResult
forall a b. a -> (a -> b) -> b
& ASetter
  (Proto TxSubmitResult) (Proto TxSubmitResult) ByteString ByteString
#ref ASetter
  (Proto TxSubmitResult) (Proto TxSubmitResult) ByteString ByteString
-> ByteString -> Proto TxSubmitResult -> Proto TxSubmitResult
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes TxId
txId'

  pure $ def & #results .~ submitResults
 where
  deserialiseTx :: ShelleyBasedEra era -> ByteString -> Either String (Tx era)
  deserialiseTx :: forall era.
ShelleyBasedEra era -> ByteString -> Either String (Tx era)
deserialiseTx ShelleyBasedEra era
sbe = ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era =>
    ByteString -> Either String (Tx era))
-> ByteString
-> Either String (Tx era)
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era =>
  ByteString -> Either String (Tx era))
 -> ByteString -> Either String (Tx era))
-> (ShelleyBasedEraConstraints era =>
    ByteString -> Either String (Tx era))
-> ByteString
-> Either String (Tx era)
forall a b. (a -> b) -> a -> b
$ (DecoderError -> String)
-> Either DecoderError (Tx era) -> Either String (Tx era)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DecoderError -> String
forall a. Show a => a -> String
show (Either DecoderError (Tx era) -> Either String (Tx era))
-> (ByteString -> Either DecoderError (Tx era))
-> ByteString
-> Either String (Tx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AsType (Tx era) -> ByteString -> Either DecoderError (Tx era)
forall a.
SerialiseAsCBOR a =>
AsType a -> ByteString -> Either DecoderError a
deserialiseFromCBOR AsType (Tx era)
forall t. HasTypeProxy t => AsType t
asType

  submitTx
    :: MonadRpc e m
    => ShelleyBasedEra era
    -> Tx era
    -> m (Either String TxId)
  submitTx :: forall e (m :: * -> *) era.
MonadRpc e m =>
ShelleyBasedEra era -> Tx era -> m (Either String TxId)
submitTx ShelleyBasedEra era
sbe Tx era
tx = do
    nodeConnInfo <- m LocalNodeConnectInfo
forall field env (m :: * -> *).
(Has field env, MonadReader env m) =>
m field
grab
    eRes <-
      tryAny $
        submitTxToNodeLocal nodeConnInfo (TxInMode sbe tx) >>= \case
          Net.Tx.SubmitFail TxValidationErrorInCardanoMode
reason -> Either String TxId -> m (Either String TxId)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String TxId -> m (Either String TxId))
-> (String -> Either String TxId)
-> String
-> m (Either String TxId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String TxId
forall a b. a -> Either a b
Left (String -> m (Either String TxId))
-> String -> m (Either String TxId)
forall a b. (a -> b) -> a -> b
$ TxValidationErrorInCardanoMode -> String
forall a. Show a => a -> String
show TxValidationErrorInCardanoMode
reason
          SubmitResult TxValidationErrorInCardanoMode
Net.Tx.SubmitSuccess -> Either String TxId -> m (Either String TxId)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String TxId -> m (Either String TxId))
-> Either String TxId -> m (Either String TxId)
forall a b. (a -> b) -> a -> b
$ TxId -> Either String TxId
forall a b. b -> Either a b
Right (TxId -> Either String TxId)
-> (TxBody era -> TxId) -> TxBody era -> Either String TxId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> TxId
forall era. TxBody era -> TxId
getTxId (TxBody era -> Either String TxId)
-> TxBody era -> Either String TxId
forall a b. (a -> b) -> a -> b
$ Tx era -> TxBody era
forall era. Tx era -> TxBody era
getTxBody Tx era
tx
    case eRes of
      Left SomeException
err -> do
        let errString :: String
errString = SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err
        String -> m ()
forall (m :: * -> *) t e.
(Has (Tracer m t) e, MonadReader e m) =>
t -> m ()
putTrace (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"N2C connection error while trying to submit a transaction: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
errString
        Either String TxId -> m (Either String TxId)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String TxId -> m (Either String TxId))
-> Either String TxId -> m (Either String TxId)
forall a b. (a -> b) -> a -> b
$ String -> Either String TxId
forall a b. a -> Either a b
Left String
errString
      Right Either String TxId
res -> Either String TxId -> m (Either String TxId)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String TxId
res