{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}

-- | This module provides utilities to render the result of plutus execution.
module Cardano.Api.Internal.Plutus
  ( DebugPlutusFailure (..)
  , renderDebugPlutusFailure
  , collectPlutusScriptHashes
  )
where

import Cardano.Api.Internal.Eon.AlonzoEraOnwards
  ( AlonzoEraOnwards (..)
  , alonzoEraOnwardsConstraints
  )
import Cardano.Api.Internal.Eon.Convert (convert)
import Cardano.Api.Internal.Eon.ShelleyBasedEra (ShelleyLedgerEra)
import Cardano.Api.Internal.Pretty (Pretty (pretty), docToText)
import Cardano.Api.Internal.Query (toLedgerUTxO)
import Cardano.Api.Internal.ReexposeLedger qualified as L
import Cardano.Api.Internal.Script (ScriptHash, fromShelleyScriptHash)
import Cardano.Api.Internal.Script qualified as Api
import Cardano.Api.Internal.Tx.Body (ScriptWitnessIndex (..), toScriptIndex)
import Cardano.Api.Internal.Tx.Sign (Tx (..))
import Cardano.Api.Internal.Tx.UTxO (UTxO)

import Cardano.Ledger.Alonzo.Scripts qualified as L
import Cardano.Ledger.Alonzo.UTxO qualified as Alonzo
import Cardano.Ledger.Binary.Encoding (serialize')
import Cardano.Ledger.Binary.Plain (serializeAsHexText)
import Cardano.Ledger.Plutus.Evaluate qualified as Plutus
import Cardano.Ledger.Plutus.ExUnits qualified as Plutus
import Cardano.Ledger.Plutus.Language qualified as Plutus
import Cardano.Ledger.UTxO qualified as L
import PlutusLedgerApi.V1 qualified as Plutus

import Data.Bifunctor (Bifunctor (..))
import Data.ByteString.Base64 qualified as B64
import Data.ByteString.Short qualified as BSS
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Lens.Micro ((^.))
import Prettyprinter (indent, line)

-- | A structured representation of Plutus script validation failures,
-- providing detailed information about the failed execution for debugging purposes.
-- This type contains the same information as the data constructor
-- 'Cardano.Ledger.Alonzo.Plutus.Evaluate.TransactionScriptFailure.ValidationFailure'
-- but with named fields and fixed crypto parameters for easier debugging and
-- error reporting.
data DebugPlutusFailure
  = DebugPlutusFailure
  { DebugPlutusFailure -> EvaluationError
dpfEvaluationError :: Plutus.EvaluationError
  , DebugPlutusFailure -> PlutusWithContext StandardCrypto
dpfScriptWithContext :: Plutus.PlutusWithContext L.StandardCrypto
  , DebugPlutusFailure -> ExUnits
dpfExecutionUnits :: Plutus.ExUnits
  , DebugPlutusFailure -> [Text]
dpfExecutionLogs :: [Text]
  }
  deriving (DebugPlutusFailure -> DebugPlutusFailure -> Bool
(DebugPlutusFailure -> DebugPlutusFailure -> Bool)
-> (DebugPlutusFailure -> DebugPlutusFailure -> Bool)
-> Eq DebugPlutusFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DebugPlutusFailure -> DebugPlutusFailure -> Bool
== :: DebugPlutusFailure -> DebugPlutusFailure -> Bool
$c/= :: DebugPlutusFailure -> DebugPlutusFailure -> Bool
/= :: DebugPlutusFailure -> DebugPlutusFailure -> Bool
Eq, Int -> DebugPlutusFailure -> ShowS
[DebugPlutusFailure] -> ShowS
DebugPlutusFailure -> String
(Int -> DebugPlutusFailure -> ShowS)
-> (DebugPlutusFailure -> String)
-> ([DebugPlutusFailure] -> ShowS)
-> Show DebugPlutusFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DebugPlutusFailure -> ShowS
showsPrec :: Int -> DebugPlutusFailure -> ShowS
$cshow :: DebugPlutusFailure -> String
show :: DebugPlutusFailure -> String
$cshowList :: [DebugPlutusFailure] -> ShowS
showList :: [DebugPlutusFailure] -> ShowS
Show)

renderDebugPlutusFailure :: DebugPlutusFailure -> Text
renderDebugPlutusFailure :: DebugPlutusFailure -> Text
renderDebugPlutusFailure DebugPlutusFailure
dpf =
  let pwc :: PlutusWithContext StandardCrypto
pwc = DebugPlutusFailure -> PlutusWithContext StandardCrypto
dpfScriptWithContext DebugPlutusFailure
dpf
      lang :: Language
lang = case PlutusWithContext StandardCrypto
pwc of
        Plutus.PlutusWithContext{pwcScript :: ()
Plutus.pwcScript = Either (Plutus l) (PlutusRunnable l)
script} ->
          (Plutus l -> Language)
-> (PlutusRunnable l -> Language)
-> Either (Plutus l) (PlutusRunnable l)
-> Language
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Plutus l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
Plutus.plutusLanguage PlutusRunnable l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
Plutus.plutusLanguage Either (Plutus l) (PlutusRunnable l)
script

      scriptArgs :: Doc AnsiStyle
scriptArgs = case PlutusWithContext StandardCrypto
pwc of
        Plutus.PlutusWithContext{pwcArgs :: ()
Plutus.pwcArgs = PlutusArgs l
args} ->
          Doc AnsiStyle
forall ann. Doc ann
line Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 (PlutusArgs l -> Doc AnsiStyle
forall ann. PlutusArgs l -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty PlutusArgs l
args)
      protocolVersion :: Version
protocolVersion = PlutusWithContext StandardCrypto -> Version
forall c. PlutusWithContext c -> Version
Plutus.pwcProtocolVersion PlutusWithContext StandardCrypto
pwc
      scriptArgsBase64 :: Text
scriptArgsBase64 = case PlutusWithContext StandardCrypto
pwc of
        Plutus.PlutusWithContext{pwcArgs :: ()
Plutus.pwcArgs = PlutusArgs l
args} ->
          ByteString -> Text
Text.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
B64.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Version -> PlutusArgs l -> ByteString
forall a. EncCBOR a => Version -> a -> ByteString
serialize' Version
protocolVersion PlutusArgs l
args
      evalError :: EvaluationError
evalError = DebugPlutusFailure -> EvaluationError
dpfEvaluationError DebugPlutusFailure
dpf
      binaryScript :: Text
binaryScript = case PlutusWithContext StandardCrypto
pwc of
        Plutus.PlutusWithContext{pwcScript :: ()
Plutus.pwcScript = Either (Plutus l) (PlutusRunnable l)
scr} ->
          let Plutus.Plutus PlutusBinary
bytes = (Plutus l -> Plutus l)
-> (PlutusRunnable l -> Plutus l)
-> Either (Plutus l) (PlutusRunnable l)
-> Plutus l
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Plutus l -> Plutus l
forall a. a -> a
id PlutusRunnable l -> Plutus l
forall (l :: Language). PlutusRunnable l -> Plutus l
Plutus.plutusFromRunnable Either (Plutus l) (PlutusRunnable l)
scr
           in ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> (ShortByteString -> ByteString) -> ShortByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.encode (ByteString -> ByteString)
-> (ShortByteString -> ByteString) -> ShortByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> ByteString
BSS.fromShort (ShortByteString -> Text) -> ShortByteString -> Text
forall a b. (a -> b) -> a -> b
$ PlutusBinary -> ShortByteString
Plutus.unPlutusBinary PlutusBinary
bytes
   in [Text] -> Text
Text.unlines
        [ Text
"Script hash: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptHash StandardCrypto -> Text
forall a. ToCBOR a => a -> Text
serializeAsHexText (PlutusWithContext StandardCrypto -> ScriptHash StandardCrypto
forall c. PlutusWithContext c -> ScriptHash c
Plutus.pwcScriptHash PlutusWithContext StandardCrypto
pwc)
        , Text
"Script language: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Language -> String
forall a. Show a => a -> String
show Language
lang)
        , Text
"Protocol version: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (Version -> String
forall a. Show a => a -> String
show Version
protocolVersion)
        , Text
"Script arguments: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> Text
docToText Doc AnsiStyle
scriptArgs
        , Text
"Script evaluation error: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> Text
docToText (EvaluationError -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
forall ann. EvaluationError -> Doc ann
pretty EvaluationError
evalError)
        , Text
"Script execution logs: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
Text.unlines (DebugPlutusFailure -> [Text]
dpfExecutionLogs DebugPlutusFailure
dpf)
        , Text
"Script base64 encoded arguments: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
scriptArgsBase64
        , Text
"Script base64 encoded bytes: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
binaryScript
        ]

{-
-- Should be used on `dpfExecutionLogs dpf`. Disabled until next plutus release.
See: https://github.com/IntersectMBO/cardano-api/pull/672#issuecomment-2455909946

PlutusTx.ErrorCodes.plutusPreludeErrorCodes

lookupPlutusErrorCode :: Text -> Text
lookupPlutusErrorCode code =
  let codeString = PlutusTx.stringToBuiltinString $ Text.unpack code
   in case Map.lookup codeString plutusPreludeErrorCodes of
        Just err -> Text.pack err
        Nothing -> "Unknown error code: " <> code
-}

-- | Collect all plutus script hashes that are needed to validate the given transaction
-- and return them in a map with their corresponding 'ScriptWitnessIndex' as key.
collectPlutusScriptHashes
  :: AlonzoEraOnwards era
  -> Tx era
  -> UTxO era
  -> Map ScriptWitnessIndex ScriptHash
collectPlutusScriptHashes :: forall era.
AlonzoEraOnwards era
-> Tx era -> UTxO era -> Map ScriptWitnessIndex ScriptHash
collectPlutusScriptHashes AlonzoEraOnwards era
aeo Tx era
tx UTxO era
utxo =
  AlonzoEraOnwards era
-> (AlonzoEraOnwardsConstraints era =>
    Map ScriptWitnessIndex ScriptHash)
-> Map ScriptWitnessIndex ScriptHash
forall era a.
AlonzoEraOnwards era -> (AlonzoEraOnwardsConstraints era => a) -> a
alonzoEraOnwardsConstraints AlonzoEraOnwards era
aeo ((AlonzoEraOnwardsConstraints era =>
  Map ScriptWitnessIndex ScriptHash)
 -> Map ScriptWitnessIndex ScriptHash)
-> (AlonzoEraOnwardsConstraints era =>
    Map ScriptWitnessIndex ScriptHash)
-> Map ScriptWitnessIndex ScriptHash
forall a b. (a -> b) -> a -> b
$
    let ShelleyTx ShelleyBasedEra era
_ Tx (ShelleyLedgerEra era)
ledgerTx' = Tx era
tx
        ledgerUTxO :: UTxO (ShelleyLedgerEra era)
ledgerUTxO = ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
forall era.
ShelleyBasedEra era -> UTxO era -> UTxO (ShelleyLedgerEra era)
toLedgerUTxO (AlonzoEraOnwards era -> ShelleyBasedEra era
forall era. AlonzoEraOnwards era -> ShelleyBasedEra era
forall a (f :: a -> *) (g :: a -> *) (era :: a).
Convert f g =>
f era -> g era
convert AlonzoEraOnwards era
aeo) UTxO era
utxo
     in AlonzoEraOnwards era
-> AlonzoScriptsNeeded (ShelleyLedgerEra era)
-> Map ScriptWitnessIndex ScriptHash
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) =>
AlonzoEraOnwards era
-> AlonzoScriptsNeeded (ShelleyLedgerEra era)
-> Map ScriptWitnessIndex ScriptHash
getPurposes AlonzoEraOnwards era
aeo (AlonzoScriptsNeeded (ShelleyLedgerEra era)
 -> Map ScriptWitnessIndex ScriptHash)
-> AlonzoScriptsNeeded (ShelleyLedgerEra era)
-> Map ScriptWitnessIndex ScriptHash
forall a b. (a -> b) -> a -> b
$ UTxO (ShelleyLedgerEra era)
-> TxBody (ShelleyLedgerEra era)
-> ScriptsNeeded (ShelleyLedgerEra era)
forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
L.getScriptsNeeded UTxO (ShelleyLedgerEra era)
ledgerUTxO (Tx (ShelleyLedgerEra era)
ledgerTx' Tx (ShelleyLedgerEra era)
-> Getting
     (TxBody (ShelleyLedgerEra era))
     (Tx (ShelleyLedgerEra era))
     (TxBody (ShelleyLedgerEra era))
-> TxBody (ShelleyLedgerEra era)
forall s a. s -> Getting a s a -> a
^. Getting
  (TxBody (ShelleyLedgerEra era))
  (Tx (ShelleyLedgerEra era))
  (TxBody (ShelleyLedgerEra era))
forall era. EraTx era => Lens' (Tx era) (TxBody era)
Lens' (Tx (ShelleyLedgerEra era)) (TxBody (ShelleyLedgerEra era))
L.bodyTxL)
 where
  getPurposes
    :: L.EraCrypto (ShelleyLedgerEra era) ~ L.StandardCrypto
    => AlonzoEraOnwards era
    -> Alonzo.AlonzoScriptsNeeded (ShelleyLedgerEra era)
    -> Map ScriptWitnessIndex Api.ScriptHash
  getPurposes :: forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto) =>
AlonzoEraOnwards era
-> AlonzoScriptsNeeded (ShelleyLedgerEra era)
-> Map ScriptWitnessIndex ScriptHash
getPurposes AlonzoEraOnwards era
aeo' (Alonzo.AlonzoScriptsNeeded [(PlutusPurpose AsIxItem (ShelleyLedgerEra era),
  ScriptHash (EraCrypto (ShelleyLedgerEra era)))]
purposes) =
    AlonzoEraOnwards era
-> (AlonzoEraOnwardsConstraints era =>
    Map ScriptWitnessIndex ScriptHash)
-> Map ScriptWitnessIndex ScriptHash
forall era a.
AlonzoEraOnwards era -> (AlonzoEraOnwardsConstraints era => a) -> a
alonzoEraOnwardsConstraints AlonzoEraOnwards era
aeo ((AlonzoEraOnwardsConstraints era =>
  Map ScriptWitnessIndex ScriptHash)
 -> Map ScriptWitnessIndex ScriptHash)
-> (AlonzoEraOnwardsConstraints era =>
    Map ScriptWitnessIndex ScriptHash)
-> Map ScriptWitnessIndex ScriptHash
forall a b. (a -> b) -> a -> b
$
      [(ScriptWitnessIndex, ScriptHash)]
-> Map ScriptWitnessIndex ScriptHash
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ScriptWitnessIndex, ScriptHash)]
 -> Map ScriptWitnessIndex ScriptHash)
-> [(ScriptWitnessIndex, ScriptHash)]
-> Map ScriptWitnessIndex ScriptHash
forall a b. (a -> b) -> a -> b
$
        ((PlutusPurpose AsIxItem (ShelleyLedgerEra era),
  ScriptHash StandardCrypto)
 -> (ScriptWitnessIndex, ScriptHash))
-> [(PlutusPurpose AsIxItem (ShelleyLedgerEra era),
     ScriptHash StandardCrypto)]
-> [(ScriptWitnessIndex, ScriptHash)]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map
          ((PlutusPurpose AsIxItem (ShelleyLedgerEra era)
 -> ScriptWitnessIndex)
-> (ScriptHash StandardCrypto -> ScriptHash)
-> (PlutusPurpose AsIxItem (ShelleyLedgerEra era),
    ScriptHash StandardCrypto)
-> (ScriptWitnessIndex, ScriptHash)
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (AlonzoEraOnwards era
-> PlutusPurpose AsIx (ShelleyLedgerEra era) -> ScriptWitnessIndex
forall era.
AlonzoEraOnwards era
-> PlutusPurpose AsIx (ShelleyLedgerEra era) -> ScriptWitnessIndex
toScriptIndex AlonzoEraOnwards era
aeo' (PlutusPurpose AsIx (ShelleyLedgerEra era) -> ScriptWitnessIndex)
-> (PlutusPurpose AsIxItem (ShelleyLedgerEra era)
    -> PlutusPurpose AsIx (ShelleyLedgerEra era))
-> PlutusPurpose AsIxItem (ShelleyLedgerEra era)
-> ScriptWitnessIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoEraOnwards era
-> PlutusPurpose AsIxItem (ShelleyLedgerEra era)
-> PlutusPurpose AsIx (ShelleyLedgerEra era)
forall era.
AlonzoEraOnwards era
-> PlutusPurpose AsIxItem (ShelleyLedgerEra era)
-> PlutusPurpose AsIx (ShelleyLedgerEra era)
purposeAsIxItemToAsIx AlonzoEraOnwards era
aeo') ScriptHash StandardCrypto -> ScriptHash
fromShelleyScriptHash)
          [(PlutusPurpose AsIxItem (ShelleyLedgerEra era),
  ScriptHash (EraCrypto (ShelleyLedgerEra era)))]
[(PlutusPurpose AsIxItem (ShelleyLedgerEra era),
  ScriptHash StandardCrypto)]
purposes

  purposeAsIxItemToAsIx
    :: AlonzoEraOnwards era
    -> L.PlutusPurpose L.AsIxItem (ShelleyLedgerEra era)
    -> L.PlutusPurpose L.AsIx (ShelleyLedgerEra era)
  purposeAsIxItemToAsIx :: forall era.
AlonzoEraOnwards era
-> PlutusPurpose AsIxItem (ShelleyLedgerEra era)
-> PlutusPurpose AsIx (ShelleyLedgerEra era)
purposeAsIxItemToAsIx AlonzoEraOnwards era
onwards PlutusPurpose AsIxItem (ShelleyLedgerEra era)
purpose =
    AlonzoEraOnwards era
-> (AlonzoEraOnwardsConstraints era =>
    PlutusPurpose AsIx (ShelleyLedgerEra era))
-> PlutusPurpose AsIx (ShelleyLedgerEra era)
forall era a.
AlonzoEraOnwards era -> (AlonzoEraOnwardsConstraints era => a) -> a
alonzoEraOnwardsConstraints AlonzoEraOnwards era
onwards ((AlonzoEraOnwardsConstraints era =>
  PlutusPurpose AsIx (ShelleyLedgerEra era))
 -> PlutusPurpose AsIx (ShelleyLedgerEra era))
-> (AlonzoEraOnwardsConstraints era =>
    PlutusPurpose AsIx (ShelleyLedgerEra era))
-> PlutusPurpose AsIx (ShelleyLedgerEra era)
forall a b. (a -> b) -> a -> b
$
      (forall ix it. AsIxItem ix it -> AsIx ix it)
-> PlutusPurpose AsIxItem (ShelleyLedgerEra era)
-> PlutusPurpose AsIx (ShelleyLedgerEra era)
forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
forall (g :: * -> * -> *) (f :: * -> * -> *).
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g (ShelleyLedgerEra era)
-> PlutusPurpose f (ShelleyLedgerEra era)
L.hoistPlutusPurpose AsIxItem ix it -> AsIx ix it
forall ix it. AsIxItem ix it -> AsIx ix it
L.toAsIx PlutusPurpose AsIxItem (ShelleyLedgerEra era)
purpose