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

module Convex.TestingInterface.Trace.TxSummary (
  summarizeTx,
  summarizeTxBody,
  renderAddress,
  toValueSummary,
  renderAssetName,
  renderDatum,
) where

import Cardano.Api qualified as C
import Cardano.Ledger.Alonzo.Scripts qualified as Ledger (AsIx (AsIx))
import Cardano.Ledger.Alonzo.TxWits qualified as Ledger (Redeemers (Redeemers))
import Cardano.Ledger.Conway.Scripts qualified as Conway (ConwayPlutusPurpose (ConwayRewarding, ConwaySpending))
import Convex.TestingInterface.Trace (
  AddressLabeler (..),
  AddressType (..),
  AssetSummary (..),
  RedeemerTag (..),
  RedeemerTagger (..),
  TxInputSummary (..),
  TxOutputSummary (..),
  TxSummary (..),
  TxWithdrawalSummary (..),
  ValueSummary (..),
 )
import Data.Aeson (Value)
import Data.ByteString qualified as BS
import Data.ByteString.Base16 qualified as Base16
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as TE
import Data.Word (Word32)
import GHC.Exts (toList)
import PlutusTx (Data (..))

{- | Summarize a full transaction, resolving inputs from the given UTxO set.
The 'RedeemerTagger' is applied to each script input's parsed redeemer
'Data' to optionally produce Tier 2 ('tisRedeemerKind' /
'tisRedeemerPayload') labels. Pass 'mempty' for Tier 1-only behaviour. The
'AddressLabeler' is applied to every address's credential hash to produce
'tisAddressLabel' / 'tosAddressLabel'.
-}
summarizeTx :: RedeemerTagger -> AddressLabeler -> C.Tx C.ConwayEra -> C.UTxO C.ConwayEra -> TxSummary
summarizeTx :: RedeemerTagger
-> AddressLabeler -> Tx ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTx RedeemerTagger
tagger AddressLabeler
labeler Tx ConwayEra
tx UTxO ConwayEra
utxo =
  let body :: TxBody ConwayEra
body = Tx ConwayEra -> TxBody ConwayEra
forall era. Tx era -> TxBody era
C.getTxBody Tx ConwayEra
tx
      txId :: TxId
txId = TxBody ConwayEra -> TxId
forall era. TxBody era -> TxId
C.getTxId TxBody ConwayEra
body
      summary :: TxSummary
summary = RedeemerTagger
-> AddressLabeler
-> TxBody ConwayEra
-> UTxO ConwayEra
-> TxSummary
summarizeTxBody RedeemerTagger
tagger AddressLabeler
labeler TxBody ConwayEra
body UTxO ConwayEra
utxo
   in TxSummary
summary{txsId = Just (C.serialiseToRawBytesHexText txId)}

{- | Summarize a transaction body, resolving inputs from the given UTxO set.
Spend redeemers are read from the body's 'C.TxBodyScriptData' (always
available on a built 'C.TxBody') and surfaced per script input. The
'RedeemerTagger' supplies the optional Tier 2 labels, and the
'AddressLabeler' supplies the optional friendly address labels.
-}
summarizeTxBody :: RedeemerTagger -> AddressLabeler -> C.TxBody C.ConwayEra -> C.UTxO C.ConwayEra -> TxSummary
summarizeTxBody :: RedeemerTagger
-> AddressLabeler
-> TxBody ConwayEra
-> UTxO ConwayEra
-> TxSummary
summarizeTxBody RedeemerTagger
tagger AddressLabeler
labeler TxBody ConwayEra
body (C.UTxO Map TxIn (TxOut CtxUTxO ConwayEra)
utxoMap) =
  let content :: TxBodyContent ViewTx ConwayEra
content = TxBody ConwayEra -> TxBodyContent ViewTx ConwayEra
forall era. TxBody era -> TxBodyContent ViewTx era
C.getTxBodyContent TxBody ConwayEra
body

      -- Spend redeemers keyed by input position (matches 'C.txIns' order).
      redeemers :: Map Word32 ScriptData
redeemers = TxBody ConwayEra -> Map Word32 ScriptData
bodySpendRedeemers TxBody ConwayEra
body

      -- Inputs (resolved from UTxO). The index is the original position in
      -- 'txIns content' so it lines up with the redeemer keys even when some
      -- inputs are unresolved and filtered out.
      inputTxIns :: TxIns ViewTx ConwayEra
inputTxIns = TxBodyContent ViewTx ConwayEra -> TxIns ViewTx ConwayEra
forall build era. TxBodyContent build era -> TxIns build era
C.txIns TxBodyContent ViewTx ConwayEra
content
      inputs :: [TxInputSummary]
inputs =
        [ RedeemerTagger
-> AddressLabeler
-> Word32
-> TxIn
-> TxOut CtxUTxO ConwayEra
-> Maybe ScriptData
-> TxInputSummary
mkInputSummary RedeemerTagger
tagger AddressLabeler
labeler Word32
ix TxIn
txIn TxOut CtxUTxO ConwayEra
txOut (Word32 -> Map Word32 ScriptData -> Maybe ScriptData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word32
ix Map Word32 ScriptData
redeemers)
        | (Word32
ix, (TxIn
txIn, BuildTxWith ViewTx (Witness WitCtxTxIn ConwayEra)
_)) <- [Word32]
-> TxIns ViewTx ConwayEra
-> [(Word32,
     (TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn ConwayEra)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word32
0 ..] TxIns ViewTx ConwayEra
inputTxIns
        , Just TxOut CtxUTxO ConwayEra
txOut <- [TxIn
-> Map TxIn (TxOut CtxUTxO ConwayEra)
-> Maybe (TxOut CtxUTxO ConwayEra)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TxIn
txIn Map TxIn (TxOut CtxUTxO ConwayEra)
utxoMap]
        ]

      -- Outputs
      outputs :: [TxOutputSummary]
outputs = (Int -> TxOut CtxTx ConwayEra -> TxOutputSummary)
-> [Int] -> [TxOut CtxTx ConwayEra] -> [TxOutputSummary]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (AddressLabeler
-> TxId -> Int -> TxOut CtxTx ConwayEra -> TxOutputSummary
mkOutputSummary AddressLabeler
labeler (TxBody ConwayEra -> TxId
forall era. TxBody era -> TxId
C.getTxId TxBody ConwayEra
body)) [Int
0 ..] (TxBodyContent ViewTx ConwayEra -> [TxOut CtxTx ConwayEra]
forall build era. TxBodyContent build era -> [TxOut CtxTx era]
C.txOuts TxBodyContent ViewTx ConwayEra
content)

      -- Fee
      fee :: Integer
fee = case TxBodyContent ViewTx ConwayEra -> TxFee ConwayEra
forall build era. TxBodyContent build era -> TxFee era
C.txFee TxBodyContent ViewTx ConwayEra
content of
        C.TxFeeExplicit ShelleyBasedEra ConwayEra
_ Coin
coin -> Coin -> Integer
C.unCoin Coin
coin

      -- Mint
      mint :: Maybe ValueSummary
mint = case TxBodyContent ViewTx ConwayEra -> TxMintValue ViewTx ConwayEra
forall build era. TxBodyContent build era -> TxMintValue build era
C.txMintValue TxBodyContent ViewTx ConwayEra
content of
        TxMintValue ViewTx ConwayEra
C.TxMintNone -> Maybe ValueSummary
forall a. Maybe a
Nothing
        mv :: TxMintValue ViewTx ConwayEra
mv@C.TxMintValue{} ->
          let v :: Value
v = TxMintValue ViewTx ConwayEra -> Value
forall build era. TxMintValue build era -> Value
C.txMintValueToValue TxMintValue ViewTx ConwayEra
mv
           in if Value
v Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
forall a. Monoid a => a
mempty then Maybe ValueSummary
forall a. Maybe a
Nothing else ValueSummary -> Maybe ValueSummary
forall a. a -> Maybe a
Just (Value -> ValueSummary
toValueSummary Value
v)

      -- Required signers
      signers :: [Text]
signers = case TxBodyContent ViewTx ConwayEra -> TxExtraKeyWitnesses ConwayEra
forall build era.
TxBodyContent build era -> TxExtraKeyWitnesses era
C.txExtraKeyWits TxBodyContent ViewTx ConwayEra
content of
        TxExtraKeyWitnesses ConwayEra
C.TxExtraKeyWitnessesNone -> []
        C.TxExtraKeyWitnesses AlonzoEraOnwards ConwayEra
_ [Hash PaymentKey]
hashes -> (Hash PaymentKey -> Text) -> [Hash PaymentKey] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Hash PaymentKey -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText [Hash PaymentKey]
hashes

      -- Validity range
      validRange :: Maybe Text
validRange =
        TxValidityLowerBound ConwayEra
-> TxValidityUpperBound ConwayEra -> Maybe Text
renderValidityRange
          (TxBodyContent ViewTx ConwayEra -> TxValidityLowerBound ConwayEra
forall build era.
TxBodyContent build era -> TxValidityLowerBound era
C.txValidityLowerBound TxBodyContent ViewTx ConwayEra
content)
          (TxBodyContent ViewTx ConwayEra -> TxValidityUpperBound ConwayEra
forall build era.
TxBodyContent build era -> TxValidityUpperBound era
C.txValidityUpperBound TxBodyContent ViewTx ConwayEra
content)

      -- Withdrawal redeemers keyed by position (matches the sorted withdrawals list).
      withdrawalRedeemers :: Map Word32 ScriptData
withdrawalRedeemers = TxBody ConwayEra -> Map Word32 ScriptData
bodyWithdrawalRedeemers TxBody ConwayEra
body

      -- Withdrawals, including zero-lovelace ones (the "withdraw zero trick").
      withdrawals :: [TxWithdrawalSummary]
withdrawals = case TxBodyContent ViewTx ConwayEra -> TxWithdrawals ViewTx ConwayEra
forall build era.
TxBodyContent build era -> TxWithdrawals build era
C.txWithdrawals TxBodyContent ViewTx ConwayEra
content of
        TxWithdrawals ViewTx ConwayEra
C.TxWithdrawalsNone -> []
        C.TxWithdrawals ShelleyBasedEra ConwayEra
_ [(StakeAddress, Coin,
  BuildTxWith ViewTx (Witness WitCtxStake ConwayEra))]
ws -> (Word32
 -> (StakeAddress, Coin,
     BuildTxWith ViewTx (Witness WitCtxStake ConwayEra))
 -> TxWithdrawalSummary)
-> [Word32]
-> [(StakeAddress, Coin,
     BuildTxWith ViewTx (Witness WitCtxStake ConwayEra))]
-> [TxWithdrawalSummary]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (RedeemerTagger
-> AddressLabeler
-> Map Word32 ScriptData
-> Word32
-> (StakeAddress, Coin,
    BuildTxWith ViewTx (Witness WitCtxStake ConwayEra))
-> TxWithdrawalSummary
mkWithdrawalSummary RedeemerTagger
tagger AddressLabeler
labeler Map Word32 ScriptData
withdrawalRedeemers) [Word32
0 ..] [(StakeAddress, Coin,
  BuildTxWith ViewTx (Witness WitCtxStake ConwayEra))]
ws
   in TxSummary
        { txsId :: Maybe Text
txsId = Maybe Text
forall a. Maybe a
Nothing
        , txsInputs :: [TxInputSummary]
txsInputs = [TxInputSummary]
inputs
        , txsOutputs :: [TxOutputSummary]
txsOutputs = [TxOutputSummary]
outputs
        , txsMint :: Maybe ValueSummary
txsMint = Maybe ValueSummary
mint
        , txsFee :: Integer
txsFee = Integer
fee
        , txsSigners :: [Text]
txsSigners = [Text]
signers
        , txsValidRange :: Maybe Text
txsValidRange = Maybe Text
validRange
        , txsWithdrawals :: [TxWithdrawalSummary]
txsWithdrawals = [TxWithdrawalSummary]
withdrawals
        }

{- | The four redeemer fields that 'mkInputSummary' and 'mkWithdrawalSummary'
project identically: Tier 1 hex CBOR and constructor index, plus the Tier 2
kind/payload the 'RedeemerTagger' derives from the parsed Plutus 'Data'.
All four are @Nothing@ when the entry carries no redeemer.
-}
data RedeemerFields = RedeemerFields
  { RedeemerFields -> Maybe Text
rfRaw :: !(Maybe Text)
  , RedeemerFields -> Maybe Integer
rfConstr :: !(Maybe Integer)
  , RedeemerFields -> Maybe Text
rfKind :: !(Maybe Text)
  , RedeemerFields -> Maybe Value
rfPayload :: !(Maybe Value)
  }

redeemerFields :: RedeemerTagger -> Maybe C.ScriptData -> RedeemerFields
redeemerFields :: RedeemerTagger -> Maybe ScriptData -> RedeemerFields
redeemerFields RedeemerTagger
tagger Maybe ScriptData
mRedeemer =
  let mTag :: Maybe RedeemerTag
mTag = do
        ScriptData
sd <- Maybe ScriptData
mRedeemer
        let d :: Data
d = ScriptData -> Data
C.toPlutusData ScriptData
sd
        RedeemerTagger -> Data -> Maybe RedeemerTag
applyRedeemerTagger RedeemerTagger
tagger Data
d
   in RedeemerFields
        { rfRaw :: Maybe Text
rfRaw = ScriptData -> Text
redeemerToHex (ScriptData -> Text) -> Maybe ScriptData -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe ScriptData
mRedeemer
        , rfConstr :: Maybe Integer
rfConstr = Maybe ScriptData
mRedeemer Maybe ScriptData -> (ScriptData -> Maybe Integer) -> Maybe Integer
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ScriptData -> Maybe Integer
redeemerConstrIx
        , rfKind :: Maybe Text
rfKind = RedeemerTag -> Text
rtKind (RedeemerTag -> Text) -> Maybe RedeemerTag -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe RedeemerTag
mTag
        , rfPayload :: Maybe Value
rfPayload = Maybe RedeemerTag
mTag Maybe RedeemerTag -> (RedeemerTag -> Maybe Value) -> Maybe Value
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= RedeemerTag -> Maybe Value
rtPayload
        }

{- | Build an input summary from its (0-based) position in the tx inputs, the
resolved 'C.TxOut', and the optional spend redeemer's 'C.ScriptData'.
The 'RedeemerTagger' is applied to the parsed Plutus 'Data' of the
redeemer to produce Tier 2 labels when present. The 'AddressLabeler' is
applied to the address's credential hash to produce 'tisAddressLabel'.
-}
mkInputSummary :: RedeemerTagger -> AddressLabeler -> Word32 -> C.TxIn -> C.TxOut C.CtxUTxO C.ConwayEra -> Maybe C.ScriptData -> TxInputSummary
mkInputSummary :: RedeemerTagger
-> AddressLabeler
-> Word32
-> TxIn
-> TxOut CtxUTxO ConwayEra
-> Maybe ScriptData
-> TxInputSummary
mkInputSummary RedeemerTagger
tagger AddressLabeler
labeler Word32
_ix TxIn
txIn (C.TxOut AddressInEra ConwayEra
addr TxOutValue ConwayEra
val TxOutDatum CtxUTxO ConwayEra
_datum ReferenceScript ConwayEra
_refScript) Maybe ScriptData
mRedeemer =
  let rf :: RedeemerFields
rf = RedeemerTagger -> Maybe ScriptData -> RedeemerFields
redeemerFields RedeemerTagger
tagger Maybe ScriptData
mRedeemer
   in TxInputSummary
        { tisUtxo :: Text
tisUtxo = TxIn -> Text
renderTxIn TxIn
txIn
        , tisAddress :: Text
tisAddress = AddressInEra ConwayEra -> Text
renderAddressInEra AddressInEra ConwayEra
addr
        , tisAddressType :: AddressType
tisAddressType = AddressInEra ConwayEra -> AddressType
addressType AddressInEra ConwayEra
addr
        , tisAddressLabel :: Maybe Text
tisAddressLabel = AddressInEra ConwayEra -> Maybe Text
addressCredentialHashHex AddressInEra ConwayEra
addr Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AddressLabeler -> Text -> Maybe Text
applyAddressLabeler AddressLabeler
labeler
        , tisValue :: ValueSummary
tisValue = Value -> ValueSummary
toValueSummary (TxOutValue ConwayEra -> Value
forall era. TxOutValue era -> Value
C.txOutValueToValue TxOutValue ConwayEra
val)
        , tisRedeemerRaw :: Maybe Text
tisRedeemerRaw = RedeemerFields -> Maybe Text
rfRaw RedeemerFields
rf
        , tisRedeemerConstr :: Maybe Integer
tisRedeemerConstr = RedeemerFields -> Maybe Integer
rfConstr RedeemerFields
rf
        , tisRedeemerKind :: Maybe Text
tisRedeemerKind = RedeemerFields -> Maybe Text
rfKind RedeemerFields
rf
        , tisRedeemerPayload :: Maybe Value
tisRedeemerPayload = RedeemerFields -> Maybe Value
rfPayload RedeemerFields
rf
        }

{- | Build a withdrawal summary from its (0-based) position in the sorted
withdrawals list and the raw @(StakeAddress, Coin, _witness)@ triple. The
'RedeemerTagger' is applied to the parsed Plutus 'Data' of the withdrawal's
redeemer to produce Tier 2 labels when present. The 'AddressLabeler' is
applied to the stake credential's hash to produce 'twsAddressLabel'.
-}
mkWithdrawalSummary
  :: RedeemerTagger
  -> AddressLabeler
  -> Map Word32 C.ScriptData
  -> Word32
  -> (C.StakeAddress, C.Coin, C.BuildTxWith C.ViewTx (C.Witness C.WitCtxStake C.ConwayEra))
  -> TxWithdrawalSummary
mkWithdrawalSummary :: RedeemerTagger
-> AddressLabeler
-> Map Word32 ScriptData
-> Word32
-> (StakeAddress, Coin,
    BuildTxWith ViewTx (Witness WitCtxStake ConwayEra))
-> TxWithdrawalSummary
mkWithdrawalSummary RedeemerTagger
tagger AddressLabeler
labeler Map Word32 ScriptData
redeemers Word32
ix (StakeAddress
stakeAddr, Coin
coin, BuildTxWith ViewTx (Witness WitCtxStake ConwayEra)
_witness) =
  let rf :: RedeemerFields
rf = RedeemerTagger -> Maybe ScriptData -> RedeemerFields
redeemerFields RedeemerTagger
tagger (Word32 -> Map Word32 ScriptData -> Maybe ScriptData
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Word32
ix Map Word32 ScriptData
redeemers)
   in TxWithdrawalSummary
        { twsStakeAddress :: Text
twsStakeAddress = StakeAddress -> Text
forall addr. SerialiseAddress addr => addr -> Text
C.serialiseAddress StakeAddress
stakeAddr
        , twsAddressType :: AddressType
twsAddressType = StakeAddress -> AddressType
stakeAddressType StakeAddress
stakeAddr
        , twsAddressLabel :: Maybe Text
twsAddressLabel = AddressLabeler -> Text -> Maybe Text
applyAddressLabeler AddressLabeler
labeler (StakeAddress -> Text
stakeCredentialHashHex StakeAddress
stakeAddr)
        , twsAmount :: Integer
twsAmount = Coin -> Integer
C.unCoin Coin
coin
        , twsRedeemerRaw :: Maybe Text
twsRedeemerRaw = RedeemerFields -> Maybe Text
rfRaw RedeemerFields
rf
        , twsRedeemerConstr :: Maybe Integer
twsRedeemerConstr = RedeemerFields -> Maybe Integer
rfConstr RedeemerFields
rf
        , twsRedeemerKind :: Maybe Text
twsRedeemerKind = RedeemerFields -> Maybe Text
rfKind RedeemerFields
rf
        , twsRedeemerPayload :: Maybe Value
twsRedeemerPayload = RedeemerFields -> Maybe Value
rfPayload RedeemerFields
rf
        }

{- | Build an output summary from a TxId, an index, and a TxOut. The
'AddressLabeler' is applied to the address's credential hash to produce
'tosAddressLabel'.
-}
mkOutputSummary :: AddressLabeler -> C.TxId -> Int -> C.TxOut C.CtxTx C.ConwayEra -> TxOutputSummary
mkOutputSummary :: AddressLabeler
-> TxId -> Int -> TxOut CtxTx ConwayEra -> TxOutputSummary
mkOutputSummary AddressLabeler
labeler TxId
txId Int
idx (C.TxOut AddressInEra ConwayEra
addr TxOutValue ConwayEra
val TxOutDatum CtxTx ConwayEra
datum ReferenceScript ConwayEra
_refScript) =
  TxOutputSummary
    { tosUtxo :: Text
tosUtxo = TxIn -> Text
renderTxIn (TxId -> TxIx -> TxIn
C.TxIn TxId
txId (Word -> TxIx
C.TxIx (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
idx)))
    , tosAddress :: Text
tosAddress = AddressInEra ConwayEra -> Text
renderAddressInEra AddressInEra ConwayEra
addr
    , tosAddressType :: AddressType
tosAddressType = AddressInEra ConwayEra -> AddressType
addressType AddressInEra ConwayEra
addr
    , tosAddressLabel :: Maybe Text
tosAddressLabel = AddressInEra ConwayEra -> Maybe Text
addressCredentialHashHex AddressInEra ConwayEra
addr Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AddressLabeler -> Text -> Maybe Text
applyAddressLabeler AddressLabeler
labeler
    , tosValue :: ValueSummary
tosValue = Value -> ValueSummary
toValueSummary (TxOutValue ConwayEra -> Value
forall era. TxOutValue era -> Value
C.txOutValueToValue TxOutValue ConwayEra
val)
    , tosDatum :: Maybe Text
tosDatum = TxOutDatum CtxTx ConwayEra -> Maybe Text
renderDatum TxOutDatum CtxTx ConwayEra
datum
    }

-- ---------------------------------------------------------------------
-- Redeemer helpers
-- ---------------------------------------------------------------------

{- | Extract the spend-purpose redeemers from a 'C.TxBody', keyed by the
0-based position of the input in the tx body's spend input list. Mirrors
the destructure used by 'Convex.ThreatModel.Cardano.Api.redeemerOfTxIn':
the redeemers live in the 'C.TxBodyScriptData' carried by the
'C.ShelleyTxBody' constructor (cardano-api 10.x).
-}

{- | Extract redeemers of a given script purpose from a 'C.TxBody', keyed by
the 0-based index ('Ledger.AsIx') within that purpose's own list. Used to
get 'bodySpendRedeemers' and 'bodyWithdrawalRedeemers' by specialising
@selectIx@ to the Spending and Rewarding purposes respectively.
-}
bodyRedeemersOfPurpose
  :: (Conway.ConwayPlutusPurpose Ledger.AsIx (C.ShelleyLedgerEra C.ConwayEra) -> Maybe Word32)
  -> C.TxBody C.ConwayEra
  -> Map Word32 C.ScriptData
bodyRedeemersOfPurpose :: (ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
 -> Maybe Word32)
-> TxBody ConwayEra -> Map Word32 ScriptData
bodyRedeemersOfPurpose ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
-> Maybe Word32
selectIx TxBody ConwayEra
body =
  case TxBody ConwayEra
body of
    C.ShelleyTxBody ShelleyBasedEra ConwayEra
_ TxBody (ShelleyLedgerEra ConwayEra)
_ [Script (ShelleyLedgerEra ConwayEra)]
_ TxBodyScriptData ConwayEra
scriptData Maybe (TxAuxData (ShelleyLedgerEra ConwayEra))
_ TxScriptValidity ConwayEra
_ -> (ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
 -> Maybe Word32)
-> TxBodyScriptData ConwayEra -> Map Word32 ScriptData
scriptDataRedeemersOfPurpose ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
-> Maybe Word32
selectIx TxBodyScriptData ConwayEra
scriptData

-- | Project the redeemers of a given purpose out of a 'C.TxBodyScriptData' value.
scriptDataRedeemersOfPurpose
  :: (Conway.ConwayPlutusPurpose Ledger.AsIx (C.ShelleyLedgerEra C.ConwayEra) -> Maybe Word32)
  -> C.TxBodyScriptData C.ConwayEra
  -> Map Word32 C.ScriptData
scriptDataRedeemersOfPurpose :: (ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
 -> Maybe Word32)
-> TxBodyScriptData ConwayEra -> Map Word32 ScriptData
scriptDataRedeemersOfPurpose ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
-> Maybe Word32
selectIx = \case
  TxBodyScriptData ConwayEra
C.TxBodyNoScriptData -> Map Word32 ScriptData
forall k a. Map k a
Map.empty
  C.TxBodyScriptData AlonzoEraOnwards ConwayEra
_ TxDats (ShelleyLedgerEra ConwayEra)
_ (Ledger.Redeemers Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs) ->
    [(Word32, ScriptData)] -> Map Word32 ScriptData
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (Word32
idx, HashableScriptData -> ScriptData
C.getScriptData (Data ConwayEra -> HashableScriptData
forall ledgerera. Data ledgerera -> HashableScriptData
C.fromAlonzoData Data ConwayEra
d))
      | (ConwayPlutusPurpose AsIx ConwayEra
purpose, (Data ConwayEra
d, ExUnits
_exUnits)) <- Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
-> [(ConwayPlutusPurpose AsIx ConwayEra,
     (Data ConwayEra, ExUnits))]
forall k a. Map k a -> [(k, a)]
Map.toList Map (PlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
Map (ConwayPlutusPurpose AsIx ConwayEra) (Data ConwayEra, ExUnits)
rdmrs
      , Just Word32
idx <- [ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
-> Maybe Word32
selectIx ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
ConwayPlutusPurpose AsIx ConwayEra
purpose]
      ]

-- | Spend (Spending-purpose) redeemers, keyed by input position.
bodySpendRedeemers :: C.TxBody C.ConwayEra -> Map Word32 C.ScriptData
bodySpendRedeemers :: TxBody ConwayEra -> Map Word32 ScriptData
bodySpendRedeemers = (ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
 -> Maybe Word32)
-> TxBody ConwayEra -> Map Word32 ScriptData
bodyRedeemersOfPurpose ((ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
  -> Maybe Word32)
 -> TxBody ConwayEra -> Map Word32 ScriptData)
-> (ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
    -> Maybe Word32)
-> TxBody ConwayEra
-> Map Word32 ScriptData
forall a b. (a -> b) -> a -> b
$ \case
  Conway.ConwaySpending (Ledger.AsIx Word32
idx) -> Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
idx
  ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
_ -> Maybe Word32
forall a. Maybe a
Nothing

{- | Withdrawal (Rewarding-purpose) redeemers, keyed by the 0-based position
of the withdrawal in the tx body's sorted withdrawals list.
-}
bodyWithdrawalRedeemers :: C.TxBody C.ConwayEra -> Map Word32 C.ScriptData
bodyWithdrawalRedeemers :: TxBody ConwayEra -> Map Word32 ScriptData
bodyWithdrawalRedeemers = (ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
 -> Maybe Word32)
-> TxBody ConwayEra -> Map Word32 ScriptData
bodyRedeemersOfPurpose ((ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
  -> Maybe Word32)
 -> TxBody ConwayEra -> Map Word32 ScriptData)
-> (ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
    -> Maybe Word32)
-> TxBody ConwayEra
-> Map Word32 ScriptData
forall a b. (a -> b) -> a -> b
$ \case
  Conway.ConwayRewarding (Ledger.AsIx Word32
idx) -> Word32 -> Maybe Word32
forall a. a -> Maybe a
Just Word32
idx
  ConwayPlutusPurpose AsIx (ShelleyLedgerEra ConwayEra)
_ -> Maybe Word32
forall a. Maybe a
Nothing

-- | Render a redeemer's 'C.ScriptData' as the hex of its CBOR encoding.
redeemerToHex :: C.ScriptData -> Text
redeemerToHex :: ScriptData -> Text
redeemerToHex = ByteString -> Text
TE.decodeUtf8 (ByteString -> Text)
-> (ScriptData -> ByteString) -> ScriptData -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Base16.encode (ByteString -> ByteString)
-> (ScriptData -> ByteString) -> ScriptData -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScriptData -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
C.serialiseToCBOR

-- | Extract the Constr index when the redeemer parses to @Constr n _@.
redeemerConstrIx :: C.ScriptData -> Maybe Integer
redeemerConstrIx :: ScriptData -> Maybe Integer
redeemerConstrIx ScriptData
sd = case ScriptData -> Data
C.toPlutusData ScriptData
sd of
  Constr Integer
n [Data]
_ -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n
  Data
_ -> Maybe Integer
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------
-- Rendering helpers
-- ---------------------------------------------------------------------

-- | Render a TxIn as @"txid#index"@.
renderTxIn :: C.TxIn -> Text
renderTxIn :: TxIn -> Text
renderTxIn (C.TxIn TxId
txId (C.TxIx Word
ix)) =
  TxId -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText TxId
txId Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Word -> String
forall a. Show a => a -> String
show Word
ix)

-- | Render an AddressInEra as bech32 text.
renderAddressInEra :: C.AddressInEra C.ConwayEra -> Text
renderAddressInEra :: AddressInEra ConwayEra -> Text
renderAddressInEra (C.AddressInEra C.ShelleyAddressInEra{} Address addrtype
addr) = Address addrtype -> Text
forall addr. SerialiseAddress addr => addr -> Text
C.serialiseAddress Address addrtype
addr
renderAddressInEra (C.AddressInEra C.ByronAddressInAnyEra{} Address addrtype
addr) = String -> Text
Text.pack (Address addrtype -> String
forall a. Show a => a -> String
show Address addrtype
addr)

-- | Render a Shelley address as bech32 text.
renderAddress :: C.Address C.ShelleyAddr -> Text
renderAddress :: Address ShelleyAddr -> Text
renderAddress = Address ShelleyAddr -> Text
forall addr. SerialiseAddress addr => addr -> Text
C.serialiseAddress

{- | Classify a credential as a public key or script, alongside the raw hex
of its hash. 'addressType'/'addressCredentialHashHex' (payment credentials)
and 'stakeAddressType'/'stakeCredentialHashHex' (stake credentials) both
specialise this one rule to their respective credential types.
-}
classifyCredential :: Either Text Text -> (AddressType, Text)
classifyCredential :: Either Text Text -> (AddressType, Text)
classifyCredential (Left Text
keyHashHex) = (AddressType
PublicKey, Text
keyHashHex)
classifyCredential (Right Text
scriptHashHex) = (AddressType
Script, Text
scriptHashHex)

classifyPaymentCredential :: C.PaymentCredential -> (AddressType, Text)
classifyPaymentCredential :: PaymentCredential -> (AddressType, Text)
classifyPaymentCredential (C.PaymentCredentialByKey Hash PaymentKey
h) = Either Text Text -> (AddressType, Text)
classifyCredential (Text -> Either Text Text
forall a b. a -> Either a b
Left (Hash PaymentKey -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText Hash PaymentKey
h))
classifyPaymentCredential (C.PaymentCredentialByScript ScriptHash
h) = Either Text Text -> (AddressType, Text)
classifyCredential (Text -> Either Text Text
forall a b. b -> Either a b
Right (ScriptHash -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText ScriptHash
h))

classifyStakeCredential :: C.StakeCredential -> (AddressType, Text)
classifyStakeCredential :: StakeCredential -> (AddressType, Text)
classifyStakeCredential (C.StakeCredentialByKey Hash StakeKey
h) = Either Text Text -> (AddressType, Text)
classifyCredential (Text -> Either Text Text
forall a b. a -> Either a b
Left (Hash StakeKey -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText Hash StakeKey
h))
classifyStakeCredential (C.StakeCredentialByScript ScriptHash
h) = Either Text Text -> (AddressType, Text)
classifyCredential (Text -> Either Text Text
forall a b. b -> Either a b
Right (ScriptHash -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText ScriptHash
h))

-- | An address's payment credential, or @Nothing@ for Byron (which has none).
paymentCredentialOf :: C.AddressInEra C.ConwayEra -> Maybe C.PaymentCredential
paymentCredentialOf :: AddressInEra ConwayEra -> Maybe PaymentCredential
paymentCredentialOf (C.AddressInEra C.ByronAddressInAnyEra{} Address addrtype
_) = Maybe PaymentCredential
forall a. Maybe a
Nothing
paymentCredentialOf (C.AddressInEra C.ShelleyAddressInEra{} (C.ShelleyAddress Network
_ PaymentCredential
paymentCred StakeReference
_)) =
  PaymentCredential -> Maybe PaymentCredential
forall a. a -> Maybe a
Just (PaymentCredential -> PaymentCredential
C.fromShelleyPaymentCredential PaymentCredential
paymentCred)

{- | Classify a payment address's credential as a public key or script
address, so a client doesn't have to parse the address itself to find out.
Byron addresses are always key-based (Byron has no script credentials).
-}
addressType :: C.AddressInEra C.ConwayEra -> AddressType
addressType :: AddressInEra ConwayEra -> AddressType
addressType = AddressType
-> (PaymentCredential -> AddressType)
-> Maybe PaymentCredential
-> AddressType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe AddressType
PublicKey ((AddressType, Text) -> AddressType
forall a b. (a, b) -> a
fst ((AddressType, Text) -> AddressType)
-> (PaymentCredential -> (AddressType, Text))
-> PaymentCredential
-> AddressType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentCredential -> (AddressType, Text)
classifyPaymentCredential) (Maybe PaymentCredential -> AddressType)
-> (AddressInEra ConwayEra -> Maybe PaymentCredential)
-> AddressInEra ConwayEra
-> AddressType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressInEra ConwayEra -> Maybe PaymentCredential
paymentCredentialOf

{- | The raw hex of a payment address's credential hash (key or script hash),
for looking up a friendly label via 'AddressLabeler'. @Nothing@ for Byron
addresses.
-}
addressCredentialHashHex :: C.AddressInEra C.ConwayEra -> Maybe Text
addressCredentialHashHex :: AddressInEra ConwayEra -> Maybe Text
addressCredentialHashHex = (PaymentCredential -> Text)
-> Maybe PaymentCredential -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AddressType, Text) -> Text
forall a b. (a, b) -> b
snd ((AddressType, Text) -> Text)
-> (PaymentCredential -> (AddressType, Text))
-> PaymentCredential
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PaymentCredential -> (AddressType, Text)
classifyPaymentCredential) (Maybe PaymentCredential -> Maybe Text)
-> (AddressInEra ConwayEra -> Maybe PaymentCredential)
-> AddressInEra ConwayEra
-> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AddressInEra ConwayEra -> Maybe PaymentCredential
paymentCredentialOf

{- | Classify a stake address's credential as a public key or script
address, mirroring 'addressType' for payment addresses.
-}
stakeAddressType :: C.StakeAddress -> AddressType
stakeAddressType :: StakeAddress -> AddressType
stakeAddressType (C.StakeAddress Network
_ StakeCredential
cred) = (AddressType, Text) -> AddressType
forall a b. (a, b) -> a
fst (StakeCredential -> (AddressType, Text)
classifyStakeCredential (StakeCredential -> StakeCredential
C.fromShelleyStakeCredential StakeCredential
cred))

{- | The raw hex of a stake address's credential hash (key or script hash),
for looking up a friendly label via 'AddressLabeler', mirroring
'addressCredentialHashHex' for payment addresses.
-}
stakeCredentialHashHex :: C.StakeAddress -> Text
stakeCredentialHashHex :: StakeAddress -> Text
stakeCredentialHashHex (C.StakeAddress Network
_ StakeCredential
cred) = (AddressType, Text) -> Text
forall a b. (a, b) -> b
snd (StakeCredential -> (AddressType, Text)
classifyStakeCredential (StakeCredential -> StakeCredential
C.fromShelleyStakeCredential StakeCredential
cred))

-- | Build a structured ValueSummary from a cardano-api Value.
toValueSummary :: C.Value -> ValueSummary
toValueSummary :: Value -> ValueSummary
toValueSummary Value
val =
  let items :: [Item Value]
items = Value -> [Item Value]
forall l. IsList l => l -> [Item l]
toList Value
val -- [(AssetId, Quantity)]
      lovelace :: Integer
lovelace = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Integer
n | (AssetId
C.AdaAssetId, C.Quantity Integer
n) <- [(AssetId, Quantity)]
[Item Value]
items]
      assets :: [AssetSummary]
assets = [PolicyId -> AssetName -> Integer -> AssetSummary
toAssetSummary PolicyId
pid AssetName
name Integer
qty | (C.AssetId PolicyId
pid AssetName
name, C.Quantity Integer
qty) <- [(AssetId, Quantity)]
[Item Value]
items]
   in ValueSummary
        { vsLovelace :: Integer
vsLovelace = Integer
lovelace
        , vsAssets :: [AssetSummary]
vsAssets = [AssetSummary]
assets
        }

toAssetSummary :: C.PolicyId -> C.AssetName -> Integer -> AssetSummary
toAssetSummary :: PolicyId -> AssetName -> Integer -> AssetSummary
toAssetSummary PolicyId
pid AssetName
name Integer
qty =
  AssetSummary
    { asPolicyId :: Text
asPolicyId = PolicyId -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText PolicyId
pid -- FULL hex, no truncation
    , asName :: Text
asName = AssetName -> Text
renderAssetName AssetName
name -- UTF-8 or hex fallback
    , asQuantity :: Integer
asQuantity = Integer
qty
    }

-- | Render an AssetName as text, trying UTF-8 decoding first.
renderAssetName :: C.AssetName -> Text
renderAssetName :: AssetName -> Text
renderAssetName AssetName
an =
  let C.UnsafeAssetName ByteString
bs = AssetName
an
   in if ByteString -> Bool
BS.null ByteString
bs
        then Text
"<empty>"
        else case ByteString -> Either UnicodeException Text
TE.decodeUtf8' ByteString
bs of
          Right Text
t -> Text
t
          Left UnicodeException
_ -> AssetName -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText AssetName
an

-- | Render a datum reference for a transaction output.
renderDatum :: C.TxOutDatum C.CtxTx C.ConwayEra -> Maybe Text
renderDatum :: TxOutDatum CtxTx ConwayEra -> Maybe Text
renderDatum TxOutDatum CtxTx ConwayEra
C.TxOutDatumNone = Maybe Text
forall a. Maybe a
Nothing
renderDatum (C.TxOutDatumHash AlonzoEraOnwards ConwayEra
_ Hash ScriptData
h) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"hash:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Hash ScriptData -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText Hash ScriptData
h)
renderDatum (C.TxOutSupplementalDatum AlonzoEraOnwards ConwayEra
_ HashableScriptData
d) =
  Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"supplemental:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Hash ScriptData -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText (HashableScriptData -> Hash ScriptData
C.hashScriptDataBytes HashableScriptData
d))
renderDatum (C.TxOutDatumInline BabbageEraOnwards ConwayEra
_ HashableScriptData
d) =
  Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"inline:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Hash ScriptData -> Text
forall a. SerialiseAsRawBytes a => a -> Text
C.serialiseToRawBytesHexText (HashableScriptData -> Hash ScriptData
C.hashScriptDataBytes HashableScriptData
d))

-- | Render validity range as text. Returns @Nothing@ for unbounded ranges.
renderValidityRange
  :: C.TxValidityLowerBound C.ConwayEra
  -> C.TxValidityUpperBound C.ConwayEra
  -> Maybe Text
renderValidityRange :: TxValidityLowerBound ConwayEra
-> TxValidityUpperBound ConwayEra -> Maybe Text
renderValidityRange TxValidityLowerBound ConwayEra
lower TxValidityUpperBound ConwayEra
upper =
  case (TxValidityLowerBound ConwayEra
lower, TxValidityUpperBound ConwayEra
upper) of
    (TxValidityLowerBound ConwayEra
C.TxValidityNoLowerBound, C.TxValidityUpperBound ShelleyBasedEra ConwayEra
_ Maybe SlotNo
Nothing) ->
      Maybe Text
forall a. Maybe a
Nothing -- unbounded, no need to show
    (TxValidityLowerBound ConwayEra, TxValidityUpperBound ConwayEra)
_ ->
      Text -> Maybe Text
forall a. a -> Maybe a
Just (TxValidityLowerBound ConwayEra -> Text
forall {era}. TxValidityLowerBound era -> Text
renderLower TxValidityLowerBound ConwayEra
lower Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TxValidityUpperBound ConwayEra -> Text
forall {era}. TxValidityUpperBound era -> Text
renderUpper TxValidityUpperBound ConwayEra
upper)
 where
  renderLower :: TxValidityLowerBound era -> Text
renderLower TxValidityLowerBound era
C.TxValidityNoLowerBound = Text
"(-inf"
  renderLower (C.TxValidityLowerBound AllegraEraOnwards era
_ (C.SlotNo Word64
n)) = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Word64 -> String
forall a. Show a => a -> String
show Word64
n)
  renderUpper :: TxValidityUpperBound era -> Text
renderUpper (C.TxValidityUpperBound ShelleyBasedEra era
_ Maybe SlotNo
Nothing) = Text
"+inf)"
  renderUpper (C.TxValidityUpperBound ShelleyBasedEra era
_ (Just (C.SlotNo Word64
n))) = String -> Text
Text.pack (Word64 -> String
forall a. Show a => a -> String
show Word64
n) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"