-- | This module provides an error to conveniently render plutus related failures.
module Cardano.Api.Plutus
  ( DebugPlutusFailure (..)
  , renderDebugPlutusFailure
  )
where

import           Cardano.Api.Pretty

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

import qualified Data.ByteString.Base64 as B64
import           Data.ByteString.Short as BSS
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Prettyprinter

-- | 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 ann
scriptArgs = case PlutusWithContext StandardCrypto
pwc of
        Plutus.PlutusWithContext{pwcArgs :: ()
Plutus.pwcArgs = PlutusArgs l
args} ->
          Doc ann
forall ann. Doc ann
line Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
3 (PlutusArgs l -> Doc ann
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
forall ann. Doc ann
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
-}