{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Cardano.Ledger.Plutus.Evaluate (
  PlutusWithContext (..),
  ScriptFailure (..),
  ScriptResult (..),
  scriptPass,
  scriptFail,
  PlutusDebugInfo (..),
  PlutusDebugOverrides (..),
  defaultPlutusDebugOverrides,
  debugPlutus,
  debugPlutusUnbounded,
  runPlutusScript,
  runPlutusScriptWithLogs,
  evaluatePlutusWithContext,
  explainPlutusEvaluationError,
) where

import Cardano.Ledger.Binary (
  DecCBOR (..),
  EncCBOR (..),
  FromCBOR (..),
  ToCBOR (..),
  Version,
  toPlainDecoder,
  toPlainEncoding,
 )
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Hashes (ScriptHash)
import Cardano.Ledger.Plutus.CostModels (
  CostModel,
  decodeCostModel,
  encodeCostModel,
  getCostModelLanguage,
  getCostModelParams,
  getEvaluationContext,
  mkCostModel,
 )
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
import Cardano.Ledger.Plutus.Language (
  Language,
  Plutus (..),
  PlutusBinary (..),
  PlutusLanguage (..),
  PlutusRunnable (..),
  decodeWithPlutus,
  hashPlutusScript,
  plutusFromRunnable,
  plutusLanguage,
  withSamePlutusLanguage,
 )
import Cardano.Ledger.Plutus.TxInfo
import Codec.Extras.SerialiseViaFlat (DeserialiseFailureInfo (..), DeserialiseFailureReason (..))
import Control.DeepSeq (NFData (..), deepseq, ($!!))
import Control.Monad (unless)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as BSC
import qualified Data.ByteString.Short as SBS
import qualified Data.ByteString.UTF8 as BSU
import Data.Either (fromRight)
import Data.Functor ((<&>))
import Data.Int (Int64)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import GHC.Generics (Generic)
import GHC.Stack (HasCallStack)
import Numeric.Natural (Natural)
import qualified PlutusLedgerApi.Common as P (
  EvaluationError (..),
  ExBudget,
  ScriptDecodeError (..),
  VerboseMode (..),
 )
import Prettyprinter (Pretty (..))
import System.Timeout (timeout)

-- | This type contains all that is necessary from Ledger to evaluate a plutus script.
data PlutusWithContext where
  PlutusWithContext ::
    PlutusLanguage l =>
    { PlutusWithContext -> Version
pwcProtocolVersion :: !Version
    -- ^ Major protocol version that is necessary for [de]serialization
    , ()
pwcScript :: !(Either (Plutus l) (PlutusRunnable l))
    -- ^ Actual plutus script that will be evaluated. Script is allowed to be in two forms:
    -- serialized and deserialized. This is necesary for implementing the opptimization
    -- that preserves deserialized `PlutusRunnable` after verifying wellformedness of
    -- plutus scripts during transaction validation (yet to be implemented).
    , PlutusWithContext -> ScriptHash
pwcScriptHash :: !ScriptHash
    -- ^ Hash of the above script as it would appear on-chain. In other words it is not
    -- just a hash of the script contents. (See `Cardano.Ledger.Core.hashScript` for more info)
    , ()
pwcArgs :: !(PlutusArgs l)
    -- ^ All of the arguments to the Plutus scripts, including the redeemer and the
    -- Plutus context that was obtained from the transaction translation
    , PlutusWithContext -> ExUnits
pwcExUnits :: !ExUnits
    -- ^ Limit on the execution units
    , PlutusWithContext -> CostModel
pwcCostModel :: !CostModel
    -- ^ `CostModel` to be used during script evaluation. It must match the language
    -- version in the `pwcScript`
    } ->
    PlutusWithContext

deriving instance Show PlutusWithContext

instance NFData PlutusWithContext where
  rnf :: PlutusWithContext -> ()
rnf PlutusWithContext {Either (Plutus l) (PlutusRunnable l)
Version
ScriptHash
ExUnits
PlutusArgs l
CostModel
pwcProtocolVersion :: PlutusWithContext -> Version
pwcScript :: ()
pwcScriptHash :: PlutusWithContext -> ScriptHash
pwcArgs :: ()
pwcExUnits :: PlutusWithContext -> ExUnits
pwcCostModel :: PlutusWithContext -> CostModel
pwcProtocolVersion :: Version
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScriptHash :: ScriptHash
pwcArgs :: PlutusArgs l
pwcExUnits :: ExUnits
pwcCostModel :: CostModel
..} =
    Version -> ()
forall a. NFData a => a -> ()
rnf Version
pwcProtocolVersion () -> () -> ()
forall a b. a -> b -> b
`seq`
      Either (Plutus l) (PlutusRunnable l) -> ()
forall a. NFData a => a -> ()
rnf Either (Plutus l) (PlutusRunnable l)
pwcScript () -> () -> ()
forall a b. a -> b -> b
`seq`
        ScriptHash -> ()
forall a. NFData a => a -> ()
rnf ScriptHash
pwcScriptHash () -> () -> ()
forall a b. a -> b -> b
`seq`
          PlutusArgs l -> ()
forall a. NFData a => a -> ()
rnf PlutusArgs l
pwcArgs () -> () -> ()
forall a b. a -> b -> b
`seq`
            ExUnits -> ()
forall a. NFData a => a -> ()
rnf ExUnits
pwcExUnits () -> () -> ()
forall a b. a -> b -> b
`seq`
              CostModel -> ()
forall a. NFData a => a -> ()
rnf CostModel
pwcCostModel

instance Eq PlutusWithContext where
  pwc1 :: PlutusWithContext
pwc1@(PlutusWithContext {pwcScript :: ()
pwcScript = Either (Plutus l) (PlutusRunnable l)
s1, pwcArgs :: ()
pwcArgs = PlutusArgs l
args1})
    == :: PlutusWithContext -> PlutusWithContext -> Bool
== pwc2 :: PlutusWithContext
pwc2@(PlutusWithContext {pwcScript :: ()
pwcScript = Either (Plutus l) (PlutusRunnable l)
s2, pwcArgs :: ()
pwcArgs = PlutusArgs l
args2}) =
      PlutusWithContext -> Version
pwcProtocolVersion PlutusWithContext
pwc1 Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusWithContext -> Version
pwcProtocolVersion PlutusWithContext
pwc2
        Bool -> Bool -> Bool
&& PlutusWithContext -> ScriptHash
pwcScriptHash PlutusWithContext
pwc1 ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusWithContext -> ScriptHash
pwcScriptHash PlutusWithContext
pwc2
        Bool -> Bool -> Bool
&& Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (PlutusArgs l
-> PlutusArgs l
-> (forall (l :: Language).
    PlutusLanguage l =>
    PlutusArgs l -> PlutusArgs l -> Bool)
-> Maybe Bool
forall (f1 :: Language -> *) (f2 :: Language -> *) (l1 :: Language)
       (l2 :: Language) a.
(PlutusLanguage l1, PlutusLanguage l2) =>
f1 l1
-> f2 l2
-> (forall (l :: Language). PlutusLanguage l => f1 l -> f2 l -> a)
-> Maybe a
withSamePlutusLanguage PlutusArgs l
args1 PlutusArgs l
args2 PlutusArgs l -> PlutusArgs l -> Bool
forall a. Eq a => a -> a -> Bool
forall (l :: Language).
PlutusLanguage l =>
PlutusArgs l -> PlutusArgs l -> Bool
(==))
        Bool -> Bool -> Bool
&& PlutusWithContext -> ExUnits
pwcExUnits PlutusWithContext
pwc1 ExUnits -> ExUnits -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusWithContext -> ExUnits
pwcExUnits PlutusWithContext
pwc2
        Bool -> Bool -> Bool
&& PlutusWithContext -> CostModel
pwcCostModel PlutusWithContext
pwc1 CostModel -> CostModel -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusWithContext -> CostModel
pwcCostModel PlutusWithContext
pwc2
        Bool -> Bool -> Bool
&& Either (Plutus l) (PlutusRunnable l)
-> Either (Plutus l) (PlutusRunnable l) -> Bool
forall {l :: Language} {l :: Language} {l :: Language}
       {l :: Language}.
(PlutusLanguage l, PlutusLanguage l, PlutusLanguage l,
 PlutusLanguage l) =>
Either (Plutus l) (PlutusRunnable l)
-> Either (Plutus l) (PlutusRunnable l) -> Bool
eqScripts Either (Plutus l) (PlutusRunnable l)
s1 Either (Plutus l) (PlutusRunnable l)
s2
      where
        eqScripts :: Either (Plutus l) (PlutusRunnable l)
-> Either (Plutus l) (PlutusRunnable l) -> Bool
eqScripts (Left Plutus l
p1) (Left Plutus l
p2) =
          Plutus l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage Plutus l
p1 Language -> Language -> Bool
forall a. Eq a => a -> a -> Bool
== Plutus l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage Plutus l
p2 Bool -> Bool -> Bool
&& Plutus l -> PlutusBinary
forall (l :: Language). Plutus l -> PlutusBinary
plutusBinary Plutus l
p1 PlutusBinary -> PlutusBinary -> Bool
forall a. Eq a => a -> a -> Bool
== Plutus l -> PlutusBinary
forall (l :: Language). Plutus l -> PlutusBinary
plutusBinary Plutus l
p2
        eqScripts (Right PlutusRunnable l
p1) (Right PlutusRunnable l
p2) =
          PlutusRunnable l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage PlutusRunnable l
p1 Language -> Language -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusRunnable l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage PlutusRunnable l
p2 Bool -> Bool -> Bool
&& PlutusRunnable l -> ScriptForEvaluation
forall (l :: Language). PlutusRunnable l -> ScriptForEvaluation
plutusRunnable PlutusRunnable l
p1 ScriptForEvaluation -> ScriptForEvaluation -> Bool
forall a. Eq a => a -> a -> Bool
== PlutusRunnable l -> ScriptForEvaluation
forall (l :: Language). PlutusRunnable l -> ScriptForEvaluation
plutusRunnable PlutusRunnable l
p2
        eqScripts Either (Plutus l) (PlutusRunnable l)
_ Either (Plutus l) (PlutusRunnable l)
_ = Bool
False

data ScriptFailure = ScriptFailure
  { ScriptFailure -> Text
scriptFailureMessage :: Text
  , ScriptFailure -> PlutusWithContext
scriptFailurePlutus :: PlutusWithContext
  }
  deriving (Int -> ScriptFailure -> ShowS
[ScriptFailure] -> ShowS
ScriptFailure -> String
(Int -> ScriptFailure -> ShowS)
-> (ScriptFailure -> String)
-> ([ScriptFailure] -> ShowS)
-> Show ScriptFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptFailure -> ShowS
showsPrec :: Int -> ScriptFailure -> ShowS
$cshow :: ScriptFailure -> String
show :: ScriptFailure -> String
$cshowList :: [ScriptFailure] -> ShowS
showList :: [ScriptFailure] -> ShowS
Show, (forall x. ScriptFailure -> Rep ScriptFailure x)
-> (forall x. Rep ScriptFailure x -> ScriptFailure)
-> Generic ScriptFailure
forall x. Rep ScriptFailure x -> ScriptFailure
forall x. ScriptFailure -> Rep ScriptFailure x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScriptFailure -> Rep ScriptFailure x
from :: forall x. ScriptFailure -> Rep ScriptFailure x
$cto :: forall x. Rep ScriptFailure x -> ScriptFailure
to :: forall x. Rep ScriptFailure x -> ScriptFailure
Generic)

data ScriptResult
  = Passes [PlutusWithContext]
  | Fails [PlutusWithContext] (NonEmpty ScriptFailure)
  deriving ((forall x. ScriptResult -> Rep ScriptResult x)
-> (forall x. Rep ScriptResult x -> ScriptResult)
-> Generic ScriptResult
forall x. Rep ScriptResult x -> ScriptResult
forall x. ScriptResult -> Rep ScriptResult x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScriptResult -> Rep ScriptResult x
from :: forall x. ScriptResult -> Rep ScriptResult x
$cto :: forall x. Rep ScriptResult x -> ScriptResult
to :: forall x. Rep ScriptResult x -> ScriptResult
Generic)

scriptPass :: PlutusWithContext -> ScriptResult
scriptPass :: PlutusWithContext -> ScriptResult
scriptPass PlutusWithContext
pwc = [PlutusWithContext] -> ScriptResult
Passes [PlutusWithContext
pwc]

scriptFail :: ScriptFailure -> ScriptResult
scriptFail :: ScriptFailure -> ScriptResult
scriptFail ScriptFailure
sf = [PlutusWithContext] -> NonEmpty ScriptFailure -> ScriptResult
Fails [] (ScriptFailure -> NonEmpty ScriptFailure
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ScriptFailure
sf)

withRunnablePlutusWithContext ::
  PlutusWithContext ->
  -- | Handle the decoder failure
  (P.EvaluationError -> a) ->
  (forall l. PlutusLanguage l => PlutusRunnable l -> PlutusArgs l -> a) ->
  a
withRunnablePlutusWithContext :: forall a.
PlutusWithContext
-> (EvaluationError -> a)
-> (forall (l :: Language).
    PlutusLanguage l =>
    PlutusRunnable l -> PlutusArgs l -> a)
-> a
withRunnablePlutusWithContext PlutusWithContext {Version
pwcProtocolVersion :: PlutusWithContext -> Version
pwcProtocolVersion :: Version
pwcProtocolVersion, Either (Plutus l) (PlutusRunnable l)
pwcScript :: ()
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript, PlutusArgs l
pwcArgs :: ()
pwcArgs :: PlutusArgs l
pwcArgs} EvaluationError -> a
onError forall (l :: Language).
PlutusLanguage l =>
PlutusRunnable l -> PlutusArgs l -> a
f =
  case Either (Plutus l) (PlutusRunnable l)
pwcScript of
    Right PlutusRunnable l
pr -> PlutusRunnable l -> PlutusArgs l -> a
forall (l :: Language).
PlutusLanguage l =>
PlutusRunnable l -> PlutusArgs l -> a
f PlutusRunnable l
pr PlutusArgs l
pwcArgs
    Left Plutus l
plutus ->
      case Version -> Plutus l -> Either ScriptDecodeError (PlutusRunnable l)
forall (l :: Language).
PlutusLanguage l =>
Version -> Plutus l -> Either ScriptDecodeError (PlutusRunnable l)
decodePlutusRunnable Version
pwcProtocolVersion Plutus l
plutus of
        Right PlutusRunnable l
pr -> PlutusRunnable l -> PlutusArgs l -> a
forall (l :: Language).
PlutusLanguage l =>
PlutusRunnable l -> PlutusArgs l -> a
f PlutusRunnable l
pr PlutusArgs l
pwcArgs
        Left ScriptDecodeError
err -> EvaluationError -> a
onError (ScriptDecodeError -> EvaluationError
P.CodecError ScriptDecodeError
err)

instance Semigroup ScriptResult where
  Passes [PlutusWithContext]
ps <> :: ScriptResult -> ScriptResult -> ScriptResult
<> Passes [PlutusWithContext]
qs = [PlutusWithContext] -> ScriptResult
Passes ([PlutusWithContext]
ps [PlutusWithContext] -> [PlutusWithContext] -> [PlutusWithContext]
forall a. Semigroup a => a -> a -> a
<> [PlutusWithContext]
qs)
  Passes [PlutusWithContext]
ps <> Fails [PlutusWithContext]
qs NonEmpty ScriptFailure
xs = [PlutusWithContext] -> NonEmpty ScriptFailure -> ScriptResult
Fails ([PlutusWithContext]
ps [PlutusWithContext] -> [PlutusWithContext] -> [PlutusWithContext]
forall a. Semigroup a => a -> a -> a
<> [PlutusWithContext]
qs) NonEmpty ScriptFailure
xs
  Fails [PlutusWithContext]
ps NonEmpty ScriptFailure
xs <> Passes [PlutusWithContext]
qs = [PlutusWithContext] -> NonEmpty ScriptFailure -> ScriptResult
Fails ([PlutusWithContext]
ps [PlutusWithContext] -> [PlutusWithContext] -> [PlutusWithContext]
forall a. Semigroup a => a -> a -> a
<> [PlutusWithContext]
qs) NonEmpty ScriptFailure
xs
  Fails [PlutusWithContext]
ps NonEmpty ScriptFailure
xs <> Fails [PlutusWithContext]
qs NonEmpty ScriptFailure
ys = [PlutusWithContext] -> NonEmpty ScriptFailure -> ScriptResult
Fails ([PlutusWithContext]
ps [PlutusWithContext] -> [PlutusWithContext] -> [PlutusWithContext]
forall a. Semigroup a => a -> a -> a
<> [PlutusWithContext]
qs) (NonEmpty ScriptFailure
xs NonEmpty ScriptFailure
-> NonEmpty ScriptFailure -> NonEmpty ScriptFailure
forall a. Semigroup a => a -> a -> a
<> NonEmpty ScriptFailure
ys)

instance Monoid ScriptResult where
  mempty :: ScriptResult
mempty = [PlutusWithContext] -> ScriptResult
Passes [PlutusWithContext]
forall a. Monoid a => a
mempty

instance ToCBOR PlutusWithContext where
  toCBOR :: PlutusWithContext -> Encoding
toCBOR (PlutusWithContext {Either (Plutus l) (PlutusRunnable l)
Version
ScriptHash
ExUnits
PlutusArgs l
CostModel
pwcProtocolVersion :: PlutusWithContext -> Version
pwcScript :: ()
pwcScriptHash :: PlutusWithContext -> ScriptHash
pwcArgs :: ()
pwcExUnits :: PlutusWithContext -> ExUnits
pwcCostModel :: PlutusWithContext -> CostModel
pwcProtocolVersion :: Version
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScriptHash :: ScriptHash
pwcArgs :: PlutusArgs l
pwcExUnits :: ExUnits
pwcCostModel :: CostModel
..}) =
    Word -> Encoding
Plain.encodeListLen Word
6
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Version -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Version
pwcProtocolVersion
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Version -> Encoding -> Encoding
toPlainEncoding Version
pwcProtocolVersion ((Plutus l -> Encoding)
-> (PlutusRunnable l -> Encoding)
-> Either (Plutus l) (PlutusRunnable l)
-> Encoding
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Plutus l -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR PlutusRunnable l -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR Either (Plutus l) (PlutusRunnable l)
pwcScript)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Version -> Encoding -> Encoding
toPlainEncoding Version
pwcProtocolVersion (ScriptHash -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ScriptHash
pwcScriptHash)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Version -> Encoding -> Encoding
toPlainEncoding Version
pwcProtocolVersion (PlutusArgs l -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR PlutusArgs l
pwcArgs)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Version -> Encoding -> Encoding
toPlainEncoding Version
pwcProtocolVersion (ExUnits -> Encoding
forall a. EncCBOR a => a -> Encoding
encCBOR ExUnits
pwcExUnits)
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Version -> Encoding -> Encoding
toPlainEncoding Version
pwcProtocolVersion (CostModel -> Encoding
encodeCostModel CostModel
pwcCostModel)

instance FromCBOR PlutusWithContext where
  fromCBOR :: forall s. Decoder s PlutusWithContext
fromCBOR = Text
-> (PlutusWithContext -> Int)
-> Decoder s PlutusWithContext
-> Decoder s PlutusWithContext
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
Plain.decodeRecordNamed Text
"PlutusWithContext" (Int -> PlutusWithContext -> Int
forall a b. a -> b -> a
const Int
6) (Decoder s PlutusWithContext -> Decoder s PlutusWithContext)
-> Decoder s PlutusWithContext -> Decoder s PlutusWithContext
forall a b. (a -> b) -> a -> b
$ do
    Version
pwcProtocolVersion <- Decoder s Version
forall s. Decoder s Version
forall a s. FromCBOR a => Decoder s a
fromCBOR
    Maybe ByteString
-> Version
-> Decoder s PlutusWithContext
-> Decoder s PlutusWithContext
forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder Maybe ByteString
forall a. Maybe a
Nothing Version
pwcProtocolVersion (Decoder s PlutusWithContext -> Decoder s PlutusWithContext)
-> Decoder s PlutusWithContext -> Decoder s PlutusWithContext
forall a b. (a -> b) -> a -> b
$ (forall si (l :: Language).
 PlutusLanguage l =>
 Plutus l -> Decoder si PlutusWithContext)
-> Decoder s PlutusWithContext
forall a so.
(forall si (l :: Language).
 PlutusLanguage l =>
 Plutus l -> Decoder si a)
-> Decoder so a
decodeWithPlutus ((forall si (l :: Language).
  PlutusLanguage l =>
  Plutus l -> Decoder si PlutusWithContext)
 -> Decoder s PlutusWithContext)
-> (forall si (l :: Language).
    PlutusLanguage l =>
    Plutus l -> Decoder si PlutusWithContext)
-> Decoder s PlutusWithContext
forall a b. (a -> b) -> a -> b
$ \Plutus l
plutus -> do
      let lang :: Language
lang = Plutus l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage Plutus l
plutus
          pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript = Plutus l -> Either (Plutus l) (PlutusRunnable l)
forall a b. a -> Either a b
Left Plutus l
plutus
          scriptHash :: ScriptHash
scriptHash = Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript Plutus l
plutus
      ScriptHash
pwcScriptHash <- Decoder si ScriptHash
forall s. Decoder s ScriptHash
forall a s. DecCBOR a => Decoder s a
decCBOR
      Bool -> Decoder si () -> Decoder si ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ScriptHash
pwcScriptHash ScriptHash -> ScriptHash -> Bool
forall a. Eq a => a -> a -> Bool
== ScriptHash
scriptHash) (Decoder si () -> Decoder si ()) -> Decoder si () -> Decoder si ()
forall a b. (a -> b) -> a -> b
$
        String -> Decoder si ()
forall a. String -> Decoder si a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Decoder si ()) -> String -> Decoder si ()
forall a b. (a -> b) -> a -> b
$
          String
"ScriptHash mismatch. Encoded: "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ScriptHash -> String
forall a. Show a => a -> String
show ScriptHash
pwcScriptHash
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" doesn't match the actual: "
            String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ScriptHash -> String
forall a. Show a => a -> String
show ScriptHash
scriptHash
      PlutusArgs l
pwcArgs <- Decoder si (PlutusArgs l)
forall s. Decoder s (PlutusArgs l)
forall a s. DecCBOR a => Decoder s a
decCBOR
      ExUnits
pwcExUnits <- Decoder si ExUnits
forall s. Decoder s ExUnits
forall a s. DecCBOR a => Decoder s a
decCBOR
      CostModel
pwcCostModel <- Language -> Decoder si CostModel
forall s. Language -> Decoder s CostModel
decodeCostModel Language
lang
      PlutusWithContext -> Decoder si PlutusWithContext
forall a. a -> Decoder si a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PlutusWithContext {Either (Plutus l) (PlutusRunnable l)
Version
ScriptHash
ExUnits
PlutusArgs l
CostModel
pwcProtocolVersion :: Version
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScriptHash :: ScriptHash
pwcArgs :: PlutusArgs l
pwcExUnits :: ExUnits
pwcCostModel :: CostModel
pwcProtocolVersion :: Version
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScriptHash :: ScriptHash
pwcArgs :: PlutusArgs l
pwcExUnits :: ExUnits
pwcCostModel :: CostModel
..}

data PlutusDebugInfo
  = DebugBadHex String
  | DebugCannotDecode String
  | DebugSuccess
      -- | Execution logs from the plutus interpreter
      [Text]
      -- | Execution budget that was consumed. It will always be less or equal to what was
      -- supplied during execution.
      P.ExBudget
  | DebugFailure
      -- | Execution logs from the plutus interpreter
      [Text]
      -- | Evaluation error from Plutus interpreter
      P.EvaluationError
      -- | Everything that is needed in order to run the script
      PlutusWithContext
      -- | Expected execution budget. This value is Nothing when the supplied script can't
      -- be executed within 5 second limit or there is a problem with decoding plutus script
      -- itself.
      (Maybe P.ExBudget)
  | -- | Script did not terminate within the imposed limit
    DebugTimedOut
      -- | Wall clock limit in microseconds that was imposed on the script execution.
      Int
  deriving (Int -> PlutusDebugInfo -> ShowS
[PlutusDebugInfo] -> ShowS
PlutusDebugInfo -> String
(Int -> PlutusDebugInfo -> ShowS)
-> (PlutusDebugInfo -> String)
-> ([PlutusDebugInfo] -> ShowS)
-> Show PlutusDebugInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PlutusDebugInfo -> ShowS
showsPrec :: Int -> PlutusDebugInfo -> ShowS
$cshow :: PlutusDebugInfo -> String
show :: PlutusDebugInfo -> String
$cshowList :: [PlutusDebugInfo] -> ShowS
showList :: [PlutusDebugInfo] -> ShowS
Show)

instance NFData PlutusDebugInfo where
  rnf :: PlutusDebugInfo -> ()
rnf = \case
    DebugBadHex String
str -> String -> ()
forall a. NFData a => a -> ()
rnf String
str
    DebugCannotDecode String
str -> String -> ()
forall a. NFData a => a -> ()
rnf String
str
    DebugSuccess [Text]
logs ExBudget
exBudget -> [Text]
logs [Text] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ExBudget -> ()
forall a. NFData a => a -> ()
rnf ExBudget
exBudget
    DebugFailure [Text]
logs EvaluationError
evalError PlutusWithContext
pwc Maybe ExBudget
mExBudget ->
      let
        -- TODO: Upstream `NFData` instance for `EvaluationError`
        seqEvalError :: EvaluationError -> b -> b
seqEvalError = \case
          P.CekError CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
exc -> CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
-> b -> b
forall a b. NFData a => a -> b -> b
deepseq CekEvaluationException NamedDeBruijn DefaultUni DefaultFun
exc
          P.DeBruijnError FreeVariableError
err -> FreeVariableError -> b -> b
forall a b. NFData a => a -> b -> b
deepseq FreeVariableError
err
          P.CodecError ScriptDecodeError
err -> ScriptDecodeError -> b -> b
forall {a}. ScriptDecodeError -> a -> a
deepseqCodecError ScriptDecodeError
err
          EvaluationError
P.CostModelParameterMismatch -> b -> b
forall a. a -> a
id
          EvaluationError
P.InvalidReturnValue -> b -> b
forall a. a -> a
id
        -- TODO: Upstream `NFData` instance for `CodecError` and `MajorProtocolVersion`
        deepseqCodecError :: ScriptDecodeError -> a -> a
deepseqCodecError = \case
          P.CBORDeserialiseError DeserialiseFailureInfo
failureInfo -> DeserialiseFailureInfo -> a -> a
forall {a}. DeserialiseFailureInfo -> a -> a
deepseqDeserialiseFailureInfo DeserialiseFailureInfo
failureInfo
          P.RemainderError ByteString
bsl -> ByteString -> a -> a
forall a b. NFData a => a -> b -> b
deepseq ByteString
bsl
          P.LedgerLanguageNotAvailableError PlutusLedgerLanguage
pll MajorProtocolVersion
ipv MajorProtocolVersion
tpv -> PlutusLedgerLanguage
pll PlutusLedgerLanguage -> (a -> a) -> a -> a
forall a b. NFData a => a -> b -> b
`deepseq` MajorProtocolVersion
ipv MajorProtocolVersion -> (a -> a) -> a -> a
forall a b. a -> b -> b
`seq` (MajorProtocolVersion
tpv MajorProtocolVersion -> a -> a
forall a b. a -> b -> b
`seq`)
          P.PlutusCoreLanguageNotAvailableError Version
pll PlutusLedgerLanguage
ipv MajorProtocolVersion
tpv -> Version
pll Version -> (a -> a) -> a -> a
forall a b. NFData a => a -> b -> b
`deepseq` PlutusLedgerLanguage
ipv PlutusLedgerLanguage -> (a -> a) -> a -> a
forall a b. a -> b -> b
`seq` (MajorProtocolVersion
tpv MajorProtocolVersion -> a -> a
forall a b. a -> b -> b
`seq`)
        -- TODO: Upstream `NFData` instance for `DeserialiseFailureInfo`
        deepseqDeserialiseFailureInfo :: DeserialiseFailureInfo -> a -> a
deepseqDeserialiseFailureInfo = \case
          DeserialiseFailureInfo ByteOffset
bo DeserialiseFailureReason
reason ->
            ByteOffset
bo ByteOffset -> (a -> a) -> a -> a
forall a b. NFData a => a -> b -> b
`deepseq`
              ( -- TODO: Upstream `NFData` instance for `DeserialiseFailureReason`
                case DeserialiseFailureReason
reason of
                  DeserialiseFailureReason
EndOfInput -> a -> a
forall a. a -> a
id
                  DeserialiseFailureReason
ExpectedBytes -> a -> a
forall a. a -> a
id
                  OtherReason String
str -> String -> a -> a
forall a b. NFData a => a -> b -> b
deepseq String
str
              )
       in
        [Text]
logs [Text] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` EvaluationError
evalError EvaluationError -> PlutusWithContext -> PlutusWithContext
forall {b}. EvaluationError -> b -> b
`seqEvalError` PlutusWithContext
pwc PlutusWithContext -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` Maybe ExBudget -> ()
forall a. NFData a => a -> ()
rnf Maybe ExBudget
mExBudget
    DebugTimedOut Int
t -> Int -> ()
forall a. NFData a => a -> ()
rnf Int
t

-- | Various overrides that can be supplied to `plutusDebug` and `plutusDebugUnbouded`
data PlutusDebugOverrides = PlutusDebugOverrides
  { PlutusDebugOverrides -> Maybe ByteString
pdoScript :: !(Maybe ByteString)
  -- ^ Hex encoded version of the script
  , PlutusDebugOverrides -> Maybe Version
pdoProtocolVersion :: !(Maybe Version)
  -- ^ Protocol version to be used for decoding and exection
  , PlutusDebugOverrides -> Maybe Language
pdoLanguage :: !(Maybe Language)
  -- ^ Plutus ledger language version
  , PlutusDebugOverrides -> Maybe [ByteOffset]
pdoCostModelValues :: !(Maybe [Int64])
  -- ^ Cost model to be used for deciding execution units
  , PlutusDebugOverrides -> Maybe Natural
pdoExUnitsMem :: !(Maybe Natural)
  -- ^ Memory execution units to be used for execution
  , PlutusDebugOverrides -> Maybe Natural
pdoExUnitsSteps :: !(Maybe Natural)
  -- ^ CPU execution units to be used for execution
  , PlutusDebugOverrides -> Bool
pdoExUnitsEnforced :: !Bool
  -- ^ Setting this flag to True will disable reporting expected execution units upon a failure,
  -- which would protect against a potentially unbounded script execution.
  }
  deriving (Int -> PlutusDebugOverrides -> ShowS
[PlutusDebugOverrides] -> ShowS
PlutusDebugOverrides -> String
(Int -> PlutusDebugOverrides -> ShowS)
-> (PlutusDebugOverrides -> String)
-> ([PlutusDebugOverrides] -> ShowS)
-> Show PlutusDebugOverrides
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PlutusDebugOverrides -> ShowS
showsPrec :: Int -> PlutusDebugOverrides -> ShowS
$cshow :: PlutusDebugOverrides -> String
show :: PlutusDebugOverrides -> String
$cshowList :: [PlutusDebugOverrides] -> ShowS
showList :: [PlutusDebugOverrides] -> ShowS
Show)

defaultPlutusDebugOverrides :: PlutusDebugOverrides
defaultPlutusDebugOverrides :: PlutusDebugOverrides
defaultPlutusDebugOverrides =
  PlutusDebugOverrides
    { pdoScript :: Maybe ByteString
pdoScript = Maybe ByteString
forall a. Maybe a
Nothing
    , pdoProtocolVersion :: Maybe Version
pdoProtocolVersion = Maybe Version
forall a. Maybe a
Nothing
    , pdoLanguage :: Maybe Language
pdoLanguage = Maybe Language
forall a. Maybe a
Nothing
    , pdoCostModelValues :: Maybe [ByteOffset]
pdoCostModelValues = Maybe [ByteOffset]
forall a. Maybe a
Nothing
    , pdoExUnitsMem :: Maybe Natural
pdoExUnitsMem = Maybe Natural
forall a. Maybe a
Nothing
    , pdoExUnitsSteps :: Maybe Natural
pdoExUnitsSteps = Maybe Natural
forall a. Maybe a
Nothing
    , pdoExUnitsEnforced :: Bool
pdoExUnitsEnforced = Bool
False
    }

-- TODO: Add support for overriding arguments.
overrideContext :: HasCallStack => PlutusWithContext -> PlutusDebugOverrides -> PlutusWithContext
overrideContext :: HasCallStack =>
PlutusWithContext -> PlutusDebugOverrides -> PlutusWithContext
overrideContext PlutusWithContext {Either (Plutus l) (PlutusRunnable l)
Version
ScriptHash
ExUnits
PlutusArgs l
CostModel
pwcProtocolVersion :: PlutusWithContext -> Version
pwcScript :: ()
pwcScriptHash :: PlutusWithContext -> ScriptHash
pwcArgs :: ()
pwcExUnits :: PlutusWithContext -> ExUnits
pwcCostModel :: PlutusWithContext -> CostModel
pwcProtocolVersion :: Version
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScriptHash :: ScriptHash
pwcArgs :: PlutusArgs l
pwcExUnits :: ExUnits
pwcCostModel :: CostModel
..} PlutusDebugOverrides {Bool
Maybe Natural
Maybe [ByteOffset]
Maybe ByteString
Maybe Version
Maybe Language
pdoScript :: PlutusDebugOverrides -> Maybe ByteString
pdoProtocolVersion :: PlutusDebugOverrides -> Maybe Version
pdoLanguage :: PlutusDebugOverrides -> Maybe Language
pdoCostModelValues :: PlutusDebugOverrides -> Maybe [ByteOffset]
pdoExUnitsMem :: PlutusDebugOverrides -> Maybe Natural
pdoExUnitsSteps :: PlutusDebugOverrides -> Maybe Natural
pdoExUnitsEnforced :: PlutusDebugOverrides -> Bool
pdoScript :: Maybe ByteString
pdoProtocolVersion :: Maybe Version
pdoLanguage :: Maybe Language
pdoCostModelValues :: Maybe [ByteOffset]
pdoExUnitsMem :: Maybe Natural
pdoExUnitsSteps :: Maybe Natural
pdoExUnitsEnforced :: Bool
..} =
  -- NOTE: due to GADTs, we can't do a record update here and need to
  -- copy all the fields. Otherwise GHC will greet us with
  -- `Record update for insufficiently polymorphic field...` error
  PlutusWithContext
    { pwcProtocolVersion :: Version
pwcProtocolVersion = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe Version
pwcProtocolVersion Maybe Version
pdoProtocolVersion
    , pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript = Either (Plutus l) (PlutusRunnable l)
overrideScript
    , pwcExUnits :: ExUnits
pwcExUnits = ExUnits
overrideExUnits
    , pwcCostModel :: CostModel
pwcCostModel = CostModel
overrideCostModel
    , pwcScriptHash :: ScriptHash
pwcScriptHash = ScriptHash
overrideSriptHash
    , PlutusArgs l
pwcArgs :: PlutusArgs l
pwcArgs :: PlutusArgs l
..
    }
  where
    overrideExUnits :: ExUnits
overrideExUnits =
      Natural -> Natural -> ExUnits
ExUnits
        (Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe (ExUnits -> Natural
exUnitsMem ExUnits
pwcExUnits) Maybe Natural
pdoExUnitsMem)
        (Natural -> Maybe Natural -> Natural
forall a. a -> Maybe a -> a
fromMaybe (ExUnits -> Natural
exUnitsSteps ExUnits
pwcExUnits) Maybe Natural
pdoExUnitsSteps)
    overrideCostModel :: CostModel
overrideCostModel =
      CostModel -> Either CostModelApplyError CostModel -> CostModel
forall b a. b -> Either a b -> b
fromRight CostModel
pwcCostModel (Either CostModelApplyError CostModel -> CostModel)
-> Either CostModelApplyError CostModel -> CostModel
forall a b. (a -> b) -> a -> b
$
        Language -> [ByteOffset] -> Either CostModelApplyError CostModel
mkCostModel
          (Language -> Maybe Language -> Language
forall a. a -> Maybe a -> a
fromMaybe (CostModel -> Language
getCostModelLanguage CostModel
pwcCostModel) Maybe Language
pdoLanguage)
          ([ByteOffset] -> Maybe [ByteOffset] -> [ByteOffset]
forall a. a -> Maybe a -> a
fromMaybe (CostModel -> [ByteOffset]
getCostModelParams CostModel
pwcCostModel) Maybe [ByteOffset]
pdoCostModelValues)
    (ScriptHash
overrideSriptHash, Either (Plutus l) (PlutusRunnable l)
overrideScript) =
      case Maybe ByteString
pdoScript of
        Maybe ByteString
Nothing -> (ScriptHash
pwcScriptHash, Either (Plutus l) (PlutusRunnable l)
pwcScript)
        Just ByteString
hexScript ->
          case PlutusBinary -> Plutus l
forall (l :: Language). PlutusBinary -> Plutus l
Plutus (PlutusBinary -> Plutus l)
-> (ByteString -> PlutusBinary) -> ByteString -> Plutus l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> PlutusBinary
PlutusBinary (ShortByteString -> PlutusBinary)
-> (ByteString -> ShortByteString) -> ByteString -> PlutusBinary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
SBS.toShort (ByteString -> Plutus l)
-> Either String ByteString -> Either String (Plutus l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Either String ByteString
B16.decode ((Char -> Bool) -> ByteString -> ByteString
BSC.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') ByteString
hexScript) of
            Left String
err -> String -> (ScriptHash, Either (Plutus l) (PlutusRunnable l))
forall a. HasCallStack => String -> a
error (String -> (ScriptHash, Either (Plutus l) (PlutusRunnable l)))
-> String -> (ScriptHash, Either (Plutus l) (PlutusRunnable l))
forall a b. (a -> b) -> a -> b
$ String
"Failed hex decoding of the custom script: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err
            Right Plutus l
script -> (Plutus l -> ScriptHash
forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript Plutus l
script, Plutus l -> Either (Plutus l) (PlutusRunnable l)
forall a b. a -> Either a b
Left Plutus l
script)

-- | Execute a hex encoded script with the context that was produced within the ledger predicate
-- failure. Using `PlutusDebugOverrides` it is possible to override any part of the execution.
debugPlutus :: HasCallStack => String -> Int -> PlutusDebugOverrides -> IO PlutusDebugInfo
debugPlutus :: HasCallStack =>
String -> Int -> PlutusDebugOverrides -> IO PlutusDebugInfo
debugPlutus String
scriptsWithContext Int
limit PlutusDebugOverrides
opts =
  Int -> IO PlutusDebugInfo -> IO (Maybe PlutusDebugInfo)
forall a. Int -> IO a -> IO (Maybe a)
timeout Int
limit (PlutusDebugInfo -> IO PlutusDebugInfo
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PlutusDebugInfo -> IO PlutusDebugInfo)
-> PlutusDebugInfo -> IO PlutusDebugInfo
forall a b. NFData a => (a -> b) -> a -> b
$!! HasCallStack => String -> PlutusDebugOverrides -> PlutusDebugInfo
String -> PlutusDebugOverrides -> PlutusDebugInfo
debugPlutusUnbounded String
scriptsWithContext PlutusDebugOverrides
opts)
    IO (Maybe PlutusDebugInfo)
-> (Maybe PlutusDebugInfo -> PlutusDebugInfo) -> IO PlutusDebugInfo
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
      Maybe PlutusDebugInfo
Nothing -> Int -> PlutusDebugInfo
DebugTimedOut Int
limit
      Just PlutusDebugInfo
res -> PlutusDebugInfo
res

-- | This is just like `debugPlutus`, except it is pure and if a supplied script contains an
-- infinite loop or a very expensive computation, it might not terminate within a reasonable
-- timeframe.
debugPlutusUnbounded :: HasCallStack => String -> PlutusDebugOverrides -> PlutusDebugInfo
debugPlutusUnbounded :: HasCallStack => String -> PlutusDebugOverrides -> PlutusDebugInfo
debugPlutusUnbounded String
scriptsWithContext PlutusDebugOverrides
opts =
  case ByteString -> Either String ByteString
B64.decode (String -> ByteString
BSU.fromString String
scriptsWithContext) of
    Left String
e -> String -> PlutusDebugInfo
DebugBadHex String
e
    Right ByteString
bs ->
      case ByteString -> Either DecoderError PlutusWithContext
forall a. FromCBOR a => ByteString -> Either DecoderError a
Plain.decodeFull' ByteString
bs of
        Left DecoderError
e -> String -> PlutusDebugInfo
DebugCannotDecode (String -> PlutusDebugInfo) -> String -> PlutusDebugInfo
forall a b. (a -> b) -> a -> b
$ DecoderError -> String
forall a. Show a => a -> String
show DecoderError
e
        Right PlutusWithContext
pwcOriginal ->
          let pwc :: PlutusWithContext
pwc = HasCallStack =>
PlutusWithContext -> PlutusDebugOverrides -> PlutusWithContext
PlutusWithContext -> PlutusDebugOverrides -> PlutusWithContext
overrideContext PlutusWithContext
pwcOriginal PlutusDebugOverrides
opts
              cm :: EvaluationContext
cm = CostModel -> EvaluationContext
getEvaluationContext (CostModel -> EvaluationContext) -> CostModel -> EvaluationContext
forall a b. (a -> b) -> a -> b
$ PlutusWithContext -> CostModel
pwcCostModel PlutusWithContext
pwc
              eu :: ExBudget
eu = ExUnits -> ExBudget
transExUnits (ExUnits -> ExBudget) -> ExUnits -> ExBudget
forall a b. (a -> b) -> a -> b
$ PlutusWithContext -> ExUnits
pwcExUnits PlutusWithContext
pwc
              onDecoderError :: EvaluationError -> PlutusDebugInfo
onDecoderError EvaluationError
err = [Text]
-> EvaluationError
-> PlutusWithContext
-> Maybe ExBudget
-> PlutusDebugInfo
DebugFailure [] EvaluationError
err PlutusWithContext
pwc Maybe ExBudget
forall a. Maybe a
Nothing
           in PlutusWithContext
-> (EvaluationError -> PlutusDebugInfo)
-> (forall {l :: Language}.
    PlutusLanguage l =>
    PlutusRunnable l -> PlutusArgs l -> PlutusDebugInfo)
-> PlutusDebugInfo
forall a.
PlutusWithContext
-> (EvaluationError -> a)
-> (forall (l :: Language).
    PlutusLanguage l =>
    PlutusRunnable l -> PlutusArgs l -> a)
-> a
withRunnablePlutusWithContext PlutusWithContext
pwc EvaluationError -> PlutusDebugInfo
onDecoderError ((forall {l :: Language}.
  PlutusLanguage l =>
  PlutusRunnable l -> PlutusArgs l -> PlutusDebugInfo)
 -> PlutusDebugInfo)
-> (forall {l :: Language}.
    PlutusLanguage l =>
    PlutusRunnable l -> PlutusArgs l -> PlutusDebugInfo)
-> PlutusDebugInfo
forall a b. (a -> b) -> a -> b
$ \PlutusRunnable l
plutusRunnable PlutusArgs l
args ->
                let toDebugInfo :: [Text] -> Either EvaluationError ExBudget -> PlutusDebugInfo
toDebugInfo [Text]
logs = \case
                      Left err :: EvaluationError
err@(P.CodecError {}) -> [Text]
-> EvaluationError
-> PlutusWithContext
-> Maybe ExBudget
-> PlutusDebugInfo
DebugFailure [Text]
logs EvaluationError
err PlutusWithContext
pwc Maybe ExBudget
forall a. Maybe a
Nothing
                      Left EvaluationError
err | PlutusDebugOverrides -> Bool
pdoExUnitsEnforced PlutusDebugOverrides
opts -> [Text]
-> EvaluationError
-> PlutusWithContext
-> Maybe ExBudget
-> PlutusDebugInfo
DebugFailure [Text]
logs EvaluationError
err PlutusWithContext
pwc Maybe ExBudget
forall a. Maybe a
Nothing
                      Left EvaluationError
err ->
                        let res :: ([Text], Either EvaluationError ExBudget)
res =
                              Version
-> VerboseMode
-> EvaluationContext
-> PlutusRunnable l
-> PlutusArgs l
-> ([Text], Either EvaluationError ExBudget)
forall (l :: Language).
PlutusLanguage l =>
Version
-> VerboseMode
-> EvaluationContext
-> PlutusRunnable l
-> PlutusArgs l
-> ([Text], Either EvaluationError ExBudget)
evaluatePlutusRunnableBudget (PlutusWithContext -> Version
pwcProtocolVersion PlutusWithContext
pwc) VerboseMode
P.Verbose EvaluationContext
cm PlutusRunnable l
plutusRunnable PlutusArgs l
args
                            mExpectedExUnits :: Maybe ExBudget
mExpectedExUnits =
                              case ([Text], Either EvaluationError ExBudget)
-> Either EvaluationError ExBudget
forall a b. (a, b) -> b
snd ([Text], Either EvaluationError ExBudget)
res of
                                Left {} -> Maybe ExBudget
forall a. Maybe a
Nothing
                                Right ExBudget
exUnits -> ExBudget -> Maybe ExBudget
forall a. a -> Maybe a
Just ExBudget
exUnits
                         in [Text]
-> EvaluationError
-> PlutusWithContext
-> Maybe ExBudget
-> PlutusDebugInfo
DebugFailure [Text]
logs EvaluationError
err PlutusWithContext
pwc Maybe ExBudget
mExpectedExUnits
                      Right ExBudget
ex -> [Text] -> ExBudget -> PlutusDebugInfo
DebugSuccess [Text]
logs ExBudget
ex
                 in ([Text] -> Either EvaluationError ExBudget -> PlutusDebugInfo)
-> ([Text], Either EvaluationError ExBudget) -> PlutusDebugInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Text] -> Either EvaluationError ExBudget -> PlutusDebugInfo
toDebugInfo (([Text], Either EvaluationError ExBudget) -> PlutusDebugInfo)
-> ([Text], Either EvaluationError ExBudget) -> PlutusDebugInfo
forall a b. (a -> b) -> a -> b
$
                      Version
-> VerboseMode
-> EvaluationContext
-> ExBudget
-> PlutusRunnable l
-> PlutusArgs l
-> ([Text], Either EvaluationError ExBudget)
forall (l :: Language).
PlutusLanguage l =>
Version
-> VerboseMode
-> EvaluationContext
-> ExBudget
-> PlutusRunnable l
-> PlutusArgs l
-> ([Text], Either EvaluationError ExBudget)
evaluatePlutusRunnable (PlutusWithContext -> Version
pwcProtocolVersion PlutusWithContext
pwc) VerboseMode
P.Verbose EvaluationContext
cm ExBudget
eu PlutusRunnable l
plutusRunnable PlutusArgs l
args

runPlutusScript :: PlutusWithContext -> ScriptResult
runPlutusScript :: PlutusWithContext -> ScriptResult
runPlutusScript = ([Text], ScriptResult) -> ScriptResult
forall a b. (a, b) -> b
snd (([Text], ScriptResult) -> ScriptResult)
-> (PlutusWithContext -> ([Text], ScriptResult))
-> PlutusWithContext
-> ScriptResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PlutusWithContext -> ([Text], ScriptResult)
runPlutusScriptWithLogs

runPlutusScriptWithLogs ::
  PlutusWithContext ->
  ([Text], ScriptResult)
runPlutusScriptWithLogs :: PlutusWithContext -> ([Text], ScriptResult)
runPlutusScriptWithLogs PlutusWithContext
pwc = Either EvaluationError ExBudget -> ScriptResult
toScriptResult (Either EvaluationError ExBudget -> ScriptResult)
-> ([Text], Either EvaluationError ExBudget)
-> ([Text], ScriptResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseMode
-> PlutusWithContext -> ([Text], Either EvaluationError ExBudget)
evaluatePlutusWithContext VerboseMode
P.Quiet PlutusWithContext
pwc
  where
    toScriptResult :: Either EvaluationError ExBudget -> ScriptResult
toScriptResult = \case
      Left EvaluationError
evalError -> PlutusWithContext -> EvaluationError -> ScriptResult
explainPlutusEvaluationError PlutusWithContext
pwc EvaluationError
evalError
      Right ExBudget
_ -> PlutusWithContext -> ScriptResult
scriptPass PlutusWithContext
pwc

evaluatePlutusWithContext ::
  P.VerboseMode ->
  PlutusWithContext ->
  ([Text], Either P.EvaluationError P.ExBudget)
evaluatePlutusWithContext :: VerboseMode
-> PlutusWithContext -> ([Text], Either EvaluationError ExBudget)
evaluatePlutusWithContext VerboseMode
mode pwc :: PlutusWithContext
pwc@PlutusWithContext {Either (Plutus l) (PlutusRunnable l)
Version
ScriptHash
ExUnits
PlutusArgs l
CostModel
pwcProtocolVersion :: PlutusWithContext -> Version
pwcScript :: ()
pwcScriptHash :: PlutusWithContext -> ScriptHash
pwcArgs :: ()
pwcExUnits :: PlutusWithContext -> ExUnits
pwcCostModel :: PlutusWithContext -> CostModel
pwcProtocolVersion :: Version
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScriptHash :: ScriptHash
pwcArgs :: PlutusArgs l
pwcExUnits :: ExUnits
pwcCostModel :: CostModel
..} =
  PlutusWithContext
-> (EvaluationError -> ([Text], Either EvaluationError ExBudget))
-> (forall {l :: Language}.
    PlutusLanguage l =>
    PlutusRunnable l
    -> PlutusArgs l -> ([Text], Either EvaluationError ExBudget))
-> ([Text], Either EvaluationError ExBudget)
forall a.
PlutusWithContext
-> (EvaluationError -> a)
-> (forall (l :: Language).
    PlutusLanguage l =>
    PlutusRunnable l -> PlutusArgs l -> a)
-> a
withRunnablePlutusWithContext PlutusWithContext
pwc (([],) (Either EvaluationError ExBudget
 -> ([Text], Either EvaluationError ExBudget))
-> (EvaluationError -> Either EvaluationError ExBudget)
-> EvaluationError
-> ([Text], Either EvaluationError ExBudget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvaluationError -> Either EvaluationError ExBudget
forall a b. a -> Either a b
Left) ((forall {l :: Language}.
  PlutusLanguage l =>
  PlutusRunnable l
  -> PlutusArgs l -> ([Text], Either EvaluationError ExBudget))
 -> ([Text], Either EvaluationError ExBudget))
-> (forall {l :: Language}.
    PlutusLanguage l =>
    PlutusRunnable l
    -> PlutusArgs l -> ([Text], Either EvaluationError ExBudget))
-> ([Text], Either EvaluationError ExBudget)
forall a b. (a -> b) -> a -> b
$
    Version
-> VerboseMode
-> EvaluationContext
-> ExBudget
-> PlutusRunnable l
-> PlutusArgs l
-> ([Text], Either EvaluationError ExBudget)
forall (l :: Language).
PlutusLanguage l =>
Version
-> VerboseMode
-> EvaluationContext
-> ExBudget
-> PlutusRunnable l
-> PlutusArgs l
-> ([Text], Either EvaluationError ExBudget)
evaluatePlutusRunnable
      Version
pwcProtocolVersion
      VerboseMode
mode
      (CostModel -> EvaluationContext
getEvaluationContext CostModel
pwcCostModel)
      (ExUnits -> ExBudget
transExUnits ExUnits
pwcExUnits)

-- | Explain why a script might fail. Scripts come in three flavors:
--
-- (1) with 3 arguments @[data,redeemer,context]@ for `PlutusV1` and `PlustuV2`
--
-- (2) with 2 arguments @[redeemer,context]@ for `PlutusV1` and `PlustuV2`
--
-- (3) with 1 argument @context@ for `PlutusV3` onwards
explainPlutusEvaluationError ::
  PlutusWithContext ->
  P.EvaluationError ->
  ScriptResult
explainPlutusEvaluationError :: PlutusWithContext -> EvaluationError -> ScriptResult
explainPlutusEvaluationError pwc :: PlutusWithContext
pwc@PlutusWithContext {Version
pwcProtocolVersion :: PlutusWithContext -> Version
pwcProtocolVersion :: Version
pwcProtocolVersion, Either (Plutus l) (PlutusRunnable l)
pwcScript :: ()
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript, PlutusArgs l
pwcArgs :: ()
pwcArgs :: PlutusArgs l
pwcArgs} EvaluationError
e =
  let lang :: Language
lang = (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
plutusLanguage PlutusRunnable l -> Language
forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage Either (Plutus l) (PlutusRunnable l)
pwcScript
      Plutus PlutusBinary
binaryScript = (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
plutusFromRunnable Either (Plutus l) (PlutusRunnable l)
pwcScript
      firstLines :: [String]
firstLines =
        [ String
"The " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Language -> String
forall a. Show a => a -> String
show Language
lang String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" script failed:"
        , String
"Base64-encoded script bytes:"
        ]
      shLine :: String
shLine = String
"The script hash is:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ScriptHash -> String
forall a. Show a => a -> String
show (PlutusWithContext -> ScriptHash
pwcScriptHash PlutusWithContext
pwc)
      pvLine :: String
pvLine = String
"The protocol version is: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Show a => a -> String
show Version
pwcProtocolVersion
      plutusError :: String
plutusError = String
"The plutus evaluation error is: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ EvaluationError -> String
forall a. Show a => a -> String
show EvaluationError
e

      dataLines :: String
dataLines = Doc Any -> String
forall a. Show a => a -> String
show (PlutusArgs l -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. PlutusArgs l -> Doc ann
pretty PlutusArgs l
pwcArgs)
      line :: Text
line =
        String -> Text
pack (String -> Text) -> ([String] -> String) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Text) -> [String] -> Text
forall a b. (a -> b) -> a -> b
$ String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
firstLines [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [PlutusBinary -> String
forall a. Show a => a -> String
show PlutusBinary
binaryScript, String
shLine, String
plutusError, String
pvLine, String
dataLines]
   in ScriptFailure -> ScriptResult
scriptFail (ScriptFailure -> ScriptResult) -> ScriptFailure -> ScriptResult
forall a b. (a -> b) -> a -> b
$ Text -> PlutusWithContext -> ScriptFailure
ScriptFailure Text
line PlutusWithContext
pwc