{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Cardano.Rpc.Server.Internal.UtxoRpc.Submit
  ( submitTxMethod
  , readMempoolMethod
  )
where

import Cardano.Api
import Cardano.Rpc.Proto.Api.UtxoRpc.Submit qualified as U5c
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 Cardano.Rpc.Server.Internal.Tracing
import Cardano.Rpc.Server.Internal.UtxoRpc.Type.Mempool (txInModeToTxInMempool)
import Cardano.Rpc.Server.NodeKernelAccess (grabNodeKernelAccess, readMempoolTxs)

import Cardano.Ledger.Core qualified as L

import RIO hiding (toList)

import Data.Default
import GHC.Stack
import Network.GRPC.Spec

-- | Handle the @ReadMempool@ SubmitService RPC method: a point-in-time
-- snapshot of the mempool's contents. Transactions added or removed after
-- the read are not reflected.
readMempoolMethod
  :: MonadRpc e m
  => Proto UtxoRpc.ReadMempoolRequest
  -> m (Proto UtxoRpc.ReadMempoolResponse)
readMempoolMethod :: forall e (m :: * -> *).
MonadRpc e m =>
Proto ReadMempoolRequest -> m (Proto ReadMempoolResponse)
readMempoolMethod Proto ReadMempoolRequest
_request = do
  nodeKernelAccess <- m NodeKernelAccess
forall e (m :: * -> *). MonadRpc e m => m NodeKernelAccess
grabNodeKernelAccess
  txs <- readMempoolTxs nodeKernelAccess
  pure $ def & U5c.items .~ mapMaybe (txInModeToTxInMempool . fromConsensusGenTx) txs

-- | Submit a CBOR-serialised list of transactions to the node
submitTxMethod
  :: MonadRpc e m
  => Proto UtxoRpc.SubmitTxRequest
  -> m (Proto UtxoRpc.SubmitTxResponse)
submitTxMethod :: forall e (m :: * -> *).
MonadRpc e m =>
Proto SubmitTxRequest -> m (Proto SubmitTxResponse)
submitTxMethod Proto SubmitTxRequest
req = do
  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

  tx <-
    putTraceThrowEither
      . first TraceRpcSubmitTxDecodingError
      . deserialiseTx eon
      $ req ^. U5c.tx . U5c.raw

  txId' <- submitTx eon tx

  pure $ def & U5c.ref .~ serialiseToRawBytes txId'
 where
  deserialiseTx :: ShelleyBasedEra era -> ByteString -> Either DecoderError (Tx era)
  deserialiseTx :: forall era.
ShelleyBasedEra era -> ByteString -> Either DecoderError (Tx era)
deserialiseTx ShelleyBasedEra era
sbe = ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era =>
    ByteString -> Either DecoderError (Tx era))
-> ByteString
-> Either DecoderError (Tx era)
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era =>
  ByteString -> Either DecoderError (Tx era))
 -> ByteString -> Either DecoderError (Tx era))
-> (ShelleyBasedEraConstraints era =>
    ByteString -> Either DecoderError (Tx era))
-> ByteString
-> Either DecoderError (Tx era)
forall a b. (a -> b) -> a -> b
$ 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 TxId
  submitTx :: forall e (m :: * -> *) era.
MonadRpc e m =>
ShelleyBasedEra era -> Tx era -> m 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
    result <-
      submitTxToNodeLocal nodeConnInfo (TxInMode sbe tx) <&> \case
        TxSubmitError SomeException
e -> TraceRpcSubmit -> Either TraceRpcSubmit TxId
forall a b. a -> Either a b
Left (TraceRpcSubmit -> Either TraceRpcSubmit TxId)
-> TraceRpcSubmit -> Either TraceRpcSubmit TxId
forall a b. (a -> b) -> a -> b
$ SomeException -> TraceRpcSubmit
TraceRpcSubmitN2cConnectionError SomeException
e
        TxSubmitFail TxValidationErrorInCardanoMode
reason -> TraceRpcSubmit -> Either TraceRpcSubmit TxId
forall a b. a -> Either a b
Left (TraceRpcSubmit -> Either TraceRpcSubmit TxId)
-> TraceRpcSubmit -> Either TraceRpcSubmit TxId
forall a b. (a -> b) -> a -> b
$ TxValidationErrorInCardanoMode -> TraceRpcSubmit
TraceRpcSubmitTxValidationError TxValidationErrorInCardanoMode
reason
        TxSubmitResult
TxSubmitSuccess ->
          let ShelleyTx ShelleyBasedEra era
_ Tx TopTx (ShelleyLedgerEra era)
ledgerTx = Tx era
tx
           in TxId -> Either TraceRpcSubmit TxId
forall a b. b -> Either a b
Right (TxId -> Either TraceRpcSubmit TxId)
-> TxId -> Either TraceRpcSubmit TxId
forall a b. (a -> b) -> a -> b
$ ShelleyBasedEra era
-> (ShelleyBasedEraConstraints era => TxId) -> TxId
forall era a.
ShelleyBasedEra era -> (ShelleyBasedEraConstraints era => a) -> a
shelleyBasedEraConstraints ShelleyBasedEra era
sbe ((ShelleyBasedEraConstraints era => TxId) -> TxId)
-> (ShelleyBasedEraConstraints era => TxId) -> TxId
forall a b. (a -> b) -> a -> b
$ TxId -> TxId
fromShelleyTxId (Tx TopTx (ShelleyLedgerEra era) -> TxId
forall era (l :: TxLevel). EraTx era => Tx l era -> TxId
L.txIdTx Tx TopTx (ShelleyLedgerEra era)
ledgerTx)
    putTraceThrowEither result

  putTraceThrowEither :: Either e b -> m b
putTraceThrowEither Either e b
v = (HasCallStack => m b) -> m b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => m b) -> m b) -> (HasCallStack => m b) -> m b
forall a b. (a -> b) -> a -> b
$ do
    -- See Cardano.Node.Tracing.Tracers.Rpc in cardano-node for details how this is logged
    (e -> m ()) -> (b -> m ()) -> Either e b -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> m ()
forall t' t e (m :: * -> *).
(t ~ TraceRpc, Inject t' t, Has (Tracer m t) e, MonadReader e m) =>
t' -> m ()
putTrace (m () -> b -> m ()
forall a b. a -> b -> a
const (m () -> b -> m ()) -> m () -> b -> m ()
forall a b. (a -> b) -> a -> b
$ () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) Either e b
v
    Either e b -> m b
forall e (m :: * -> *) a.
(Error e, HasCallStack, MonadIO m, Show e, Typeable e) =>
Either e a -> m a
throwEither Either e b
v