{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}

-- | Conversion of a mempool transaction to the UTxO RPC @TxInMempool@
-- message.
module Cardano.Rpc.Server.Internal.UtxoRpc.Type.Mempool
  ( txInModeToTxInMempool
  )
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.UtxoRpc.Type.Byron (byronTxToUtxoRpcTx)
import Cardano.Rpc.Server.Internal.UtxoRpc.Type.Tx (anyEraTxConstraints, txToUtxoRpcTx)

import Cardano.Crypto qualified as Byron (hashToBytes)
import Cardano.Ledger.Binary qualified as CBOR
import Cardano.Ledger.Core qualified as L

import RIO

import Data.ProtoLens (defMessage)
import Network.GRPC.Spec

-- | Convert a transaction read from the mempool to the UTxO RPC
-- 'UtxoRpc.TxInMempool' message, always at 'U5c.STAGE_MEMPOOL'.
--
-- @native_bytes@ fidelity differs by era: the Shelley-onwards ledger @Tx@ is
-- not 'SafeToHash'-backed, so its @native_bytes@ is a canonical
-- re-encoding, not the submitter's original bytes (same caveat as
-- 'Cardano.Rpc.Server.Internal.UtxoRpc.Type.TxOutput.txOutToUtxoRpcTxOutput').
-- The Byron arm has no such caveat: its @ATxAux@ carries a real byte
-- annotation, so 'CBOR.recoverBytes' recovers the true original bytes.
--
-- 'Nothing' for the three Byron special payloads (delegation certificates,
-- update proposals, update votes): they have no proto @Tx@ representation,
-- and cannot occur on any network still running today, since Byron
-- transitioned to Shelley years before any currently live Cardano network
-- started.
txInModeToTxInMempool :: TxInMode -> Maybe (Proto UtxoRpc.TxInMempool)
txInModeToTxInMempool :: TxInMode -> Maybe (Proto TxInMempool)
txInModeToTxInMempool = \case
  TxInMode ShelleyBasedEra era
sbe tx :: Tx era
tx@(ShelleyTx ShelleyBasedEra era
_ Tx TopTx (ShelleyLedgerEra era)
ledgerTx) ->
    Proto TxInMempool -> Maybe (Proto TxInMempool)
forall a. a -> Maybe a
Just (Proto TxInMempool -> Maybe (Proto TxInMempool))
-> Proto TxInMempool -> Maybe (Proto TxInMempool)
forall a b. (a -> b) -> a -> b
$
      ShelleyBasedEra era
-> ((IsShelleyBasedEra era, AnyEraTx (ShelleyLedgerEra era)) =>
    Proto TxInMempool)
-> Proto TxInMempool
forall era a.
ShelleyBasedEra era
-> ((IsShelleyBasedEra era, AnyEraTx (ShelleyLedgerEra era)) => a)
-> a
anyEraTxConstraints ShelleyBasedEra era
sbe (((IsShelleyBasedEra era, AnyEraTx (ShelleyLedgerEra era)) =>
  Proto TxInMempool)
 -> Proto TxInMempool)
-> ((IsShelleyBasedEra era, AnyEraTx (ShelleyLedgerEra era)) =>
    Proto TxInMempool)
-> Proto TxInMempool
forall a b. (a -> b) -> a -> b
$
        Proto TxInMempool
forall msg. Message msg => msg
defMessage
          Proto TxInMempool
-> (Proto TxInMempool -> Proto TxInMempool) -> Proto TxInMempool
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxInMempool) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "ref" a) =>
LensLike' f s a
U5c.ref LensLike' Identity (Proto TxInMempool) ByteString
-> ByteString -> Proto TxInMempool -> Proto TxInMempool
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxId -> ByteString
forall a. SerialiseAsRawBytes a => a -> ByteString
serialiseToRawBytes (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))
          Proto TxInMempool
-> (Proto TxInMempool -> Proto TxInMempool) -> Proto TxInMempool
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxInMempool) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "nativeBytes" a) =>
LensLike' f s a
U5c.nativeBytes LensLike' Identity (Proto TxInMempool) ByteString
-> ByteString -> Proto TxInMempool -> Proto TxInMempool
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Tx era -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx era
tx
          Proto TxInMempool
-> (Proto TxInMempool -> Proto TxInMempool) -> Proto TxInMempool
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxInMempool) (Proto Stage)
forall (f :: * -> *) s a.
(Functor f, HasField s "stage" a) =>
LensLike' f s a
U5c.stage LensLike' Identity (Proto TxInMempool) (Proto Stage)
-> Proto Stage -> Proto TxInMempool -> Proto TxInMempool
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Stage -> Proto Stage
forall msg. msg -> Proto msg
Proto Stage
U5c.STAGE_MEMPOOL
          Proto TxInMempool
-> (Proto TxInMempool -> Proto TxInMempool) -> Proto TxInMempool
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxInMempool) (Proto Tx)
forall (f :: * -> *) s a.
(Functor f, HasField s "cardano" a) =>
LensLike' f s a
U5c.cardano LensLike' Identity (Proto TxInMempool) (Proto Tx)
-> Proto Tx -> Proto TxInMempool -> Proto TxInMempool
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Tx TopTx (ShelleyLedgerEra era) -> Proto Tx
forall era.
IsShelleyBasedEra era =>
Tx TopTx (ShelleyLedgerEra era) -> Proto Tx
txToUtxoRpcTx Tx TopTx (ShelleyLedgerEra era)
ledgerTx
  TxInByronSpecial GenTx ByronBlock
genTx -> case GenTx ByronBlock
genTx of
    ByronTx TxId
byronTxId ATxAux ByteString
aTxAux ->
      Proto TxInMempool -> Maybe (Proto TxInMempool)
forall a. a -> Maybe a
Just (Proto TxInMempool -> Maybe (Proto TxInMempool))
-> Proto TxInMempool -> Maybe (Proto TxInMempool)
forall a b. (a -> b) -> a -> b
$
        Proto TxInMempool
forall msg. Message msg => msg
defMessage
          Proto TxInMempool
-> (Proto TxInMempool -> Proto TxInMempool) -> Proto TxInMempool
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxInMempool) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "ref" a) =>
LensLike' f s a
U5c.ref LensLike' Identity (Proto TxInMempool) ByteString
-> ByteString -> Proto TxInMempool -> Proto TxInMempool
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxId -> ByteString
forall algo a. AbstractHash algo a -> ByteString
Byron.hashToBytes TxId
byronTxId
          Proto TxInMempool
-> (Proto TxInMempool -> Proto TxInMempool) -> Proto TxInMempool
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxInMempool) ByteString
forall (f :: * -> *) s a.
(Functor f, HasField s "nativeBytes" a) =>
LensLike' f s a
U5c.nativeBytes LensLike' Identity (Proto TxInMempool) ByteString
-> ByteString -> Proto TxInMempool -> Proto TxInMempool
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ATxAux ByteString -> ByteString
forall t. Decoded t => t -> ByteString
CBOR.recoverBytes ATxAux ByteString
aTxAux
          Proto TxInMempool
-> (Proto TxInMempool -> Proto TxInMempool) -> Proto TxInMempool
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxInMempool) (Proto Stage)
forall (f :: * -> *) s a.
(Functor f, HasField s "stage" a) =>
LensLike' f s a
U5c.stage LensLike' Identity (Proto TxInMempool) (Proto Stage)
-> Proto Stage -> Proto TxInMempool -> Proto TxInMempool
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Stage -> Proto Stage
forall msg. msg -> Proto msg
Proto Stage
U5c.STAGE_MEMPOOL
          Proto TxInMempool
-> (Proto TxInMempool -> Proto TxInMempool) -> Proto TxInMempool
forall a b. a -> (a -> b) -> b
& LensLike' Identity (Proto TxInMempool) (Proto Tx)
forall (f :: * -> *) s a.
(Functor f, HasField s "cardano" a) =>
LensLike' f s a
U5c.cardano LensLike' Identity (Proto TxInMempool) (Proto Tx)
-> Proto Tx -> Proto TxInMempool -> Proto TxInMempool
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ATxAux ByteString -> Proto Tx
byronTxToUtxoRpcTx ATxAux ByteString
aTxAux
    ByronDlg{} -> Maybe (Proto TxInMempool)
forall a. Maybe a
Nothing
    ByronUpdateProposal{} -> Maybe (Proto TxInMempool)
forall a. Maybe a
Nothing
    ByronUpdateVote{} -> Maybe (Proto TxInMempool)
forall a. Maybe a
Nothing