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

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

import Cardano.Api qualified as C
import Convex.TestingInterface.Trace (
  AssetSummary (..),
  TxInputSummary (..),
  TxOutputSummary (..),
  TxSummary (..),
  ValueSummary (..),
 )
import Data.ByteString qualified as BS
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 GHC.Exts (toList)

-- | Summarize a full transaction, resolving inputs from the given UTxO set.
summarizeTx :: C.Tx C.ConwayEra -> C.UTxO C.ConwayEra -> TxSummary
summarizeTx :: Tx ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTx 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 = TxBody ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTxBody 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.
summarizeTxBody :: C.TxBody C.ConwayEra -> C.UTxO C.ConwayEra -> TxSummary
summarizeTxBody :: TxBody ConwayEra -> UTxO ConwayEra -> TxSummary
summarizeTxBody 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

      -- Inputs (resolved from UTxO)
      inputTxIns :: [TxIn]
inputTxIns = ((TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn ConwayEra)) -> TxIn)
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn ConwayEra))]
-> [TxIn]
forall a b. (a -> b) -> [a] -> [b]
map (TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn ConwayEra)) -> TxIn
forall a b. (a, b) -> a
fst (TxBodyContent ViewTx ConwayEra
-> [(TxIn, BuildTxWith ViewTx (Witness WitCtxTxIn ConwayEra))]
forall build era. TxBodyContent build era -> TxIns build era
C.txIns TxBodyContent ViewTx ConwayEra
content)
      inputs :: [TxInputSummary]
inputs =
        [ TxIn -> TxOut CtxUTxO ConwayEra -> TxInputSummary
mkInputSummary TxIn
txIn TxOut CtxUTxO ConwayEra
txOut
        | TxIn
txIn <- [TxIn]
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 (TxId -> Int -> TxOut CtxTx ConwayEra -> TxOutputSummary
mkOutputSummary (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)
   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
        }

-- | Build an input summary from a TxIn and its resolved TxOut.
mkInputSummary :: C.TxIn -> C.TxOut C.CtxUTxO C.ConwayEra -> TxInputSummary
mkInputSummary :: TxIn -> TxOut CtxUTxO ConwayEra -> TxInputSummary
mkInputSummary TxIn
txIn (C.TxOut AddressInEra ConwayEra
addr TxOutValue ConwayEra
val TxOutDatum CtxUTxO ConwayEra
_datum ReferenceScript ConwayEra
_refScript) =
  TxInputSummary
    { tisUtxo :: Text
tisUtxo = TxIn -> Text
renderTxIn TxIn
txIn
    , tisAddress :: Text
tisAddress = AddressInEra ConwayEra -> Text
renderAddressInEra AddressInEra ConwayEra
addr
    , tisValue :: ValueSummary
tisValue = Value -> ValueSummary
toValueSummary (TxOutValue ConwayEra -> Value
forall era. TxOutValue era -> Value
C.txOutValueToValue TxOutValue ConwayEra
val)
    }

-- | Build an output summary from a TxId, an index, and a TxOut.
mkOutputSummary :: C.TxId -> Int -> C.TxOut C.CtxTx C.ConwayEra -> TxOutputSummary
mkOutputSummary :: TxId -> Int -> TxOut CtxTx ConwayEra -> TxOutputSummary
mkOutputSummary 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
    , 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
    }

-- ---------------------------------------------------------------------
-- 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

-- | 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
")"