{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# 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 (
  PlutusDebugOverrides (..),
  PlutusWithContext (..),
  ScriptFailure (..),
  ScriptResult (..),
  scriptPass,
  scriptFail,
  PlutusDebugInfo (..),
  debugPlutus,
  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 Control.DeepSeq (NFData (..), force)
import Control.Exception (evaluate)
import Control.Monad (join, 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.Int (Int64)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack)
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import qualified PlutusLedgerApi.Common as P (
  EvaluationError (CodecError),
  ExBudget,
  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
pwcCostModel :: CostModel
pwcExUnits :: ExUnits
pwcArgs :: PlutusArgs l
pwcScriptHash :: ScriptHash
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcProtocolVersion :: Version
pwcCostModel :: PlutusWithContext -> CostModel
pwcExUnits :: PlutusWithContext -> ExUnits
pwcArgs :: ()
pwcScriptHash :: PlutusWithContext -> ScriptHash
pwcScript :: ()
pwcProtocolVersion :: PlutusWithContext -> Version
..} =
    forall a. NFData a => a -> ()
rnf Version
pwcProtocolVersion seq :: forall a b. a -> b -> b
`seq`
      forall a. NFData a => a -> ()
rnf Either (Plutus l) (PlutusRunnable l)
pwcScript seq :: forall a b. a -> b -> b
`seq`
        forall a. NFData a => a -> ()
rnf ScriptHash
pwcScriptHash seq :: forall a b. a -> b -> b
`seq`
          forall a. NFData a => a -> ()
rnf PlutusArgs l
pwcArgs seq :: forall a b. a -> b -> b
`seq`
            forall a. NFData a => a -> ()
rnf ExUnits
pwcExUnits seq :: forall a b. a -> b -> b
`seq`
              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 forall a. Eq a => a -> a -> Bool
== PlutusWithContext -> Version
pwcProtocolVersion PlutusWithContext
pwc2
        Bool -> Bool -> Bool
&& PlutusWithContext -> ScriptHash
pwcScriptHash PlutusWithContext
pwc1 forall a. Eq a => a -> a -> Bool
== PlutusWithContext -> ScriptHash
pwcScriptHash PlutusWithContext
pwc2
        Bool -> Bool -> Bool
&& forall a. a -> Maybe a -> a
fromMaybe Bool
False (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 forall a. Eq a => a -> a -> Bool
(==))
        Bool -> Bool -> Bool
&& PlutusWithContext -> ExUnits
pwcExUnits PlutusWithContext
pwc1 forall a. Eq a => a -> a -> Bool
== PlutusWithContext -> ExUnits
pwcExUnits PlutusWithContext
pwc2
        Bool -> Bool -> Bool
&& PlutusWithContext -> CostModel
pwcCostModel PlutusWithContext
pwc1 forall a. Eq a => a -> a -> Bool
== PlutusWithContext -> CostModel
pwcCostModel PlutusWithContext
pwc2
        Bool -> Bool -> 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) =
          forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage Plutus l
p1 forall a. Eq a => a -> a -> Bool
== forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage Plutus l
p2 Bool -> Bool -> Bool
&& forall (l :: Language). Plutus l -> PlutusBinary
plutusBinary Plutus l
p1 forall a. Eq a => a -> a -> Bool
== forall (l :: Language). Plutus l -> PlutusBinary
plutusBinary Plutus l
p2
        eqScripts (Right PlutusRunnable l
p1) (Right PlutusRunnable l
p2) =
          forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage PlutusRunnable l
p1 forall a. Eq a => a -> a -> Bool
== forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage PlutusRunnable l
p2 Bool -> Bool -> Bool
&& forall (l :: Language). PlutusRunnable l -> ScriptForEvaluation
plutusRunnable PlutusRunnable l
p1 forall a. Eq a => a -> a -> Bool
== 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScriptFailure] -> ShowS
$cshowList :: [ScriptFailure] -> ShowS
show :: ScriptFailure -> String
$cshow :: ScriptFailure -> String
showsPrec :: Int -> ScriptFailure -> ShowS
$cshowsPrec :: Int -> ScriptFailure -> ShowS
Show, 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
$cto :: forall x. Rep ScriptFailure x -> ScriptFailure
$cfrom :: forall x. ScriptFailure -> Rep ScriptFailure x
Generic)

data ScriptResult
  = Passes [PlutusWithContext]
  | Fails [PlutusWithContext] (NonEmpty ScriptFailure)
  deriving (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
$cto :: forall x. Rep ScriptResult x -> ScriptResult
$cfrom :: forall x. ScriptResult -> Rep ScriptResult x
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 [] (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 :: Version
pwcProtocolVersion :: PlutusWithContext -> Version
pwcProtocolVersion, Either (Plutus l) (PlutusRunnable l)
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript :: ()
pwcScript, PlutusArgs l
pwcArgs :: PlutusArgs l
pwcArgs :: ()
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 -> forall (l :: Language).
PlutusLanguage l =>
PlutusRunnable l -> PlutusArgs l -> a
f PlutusRunnable l
pr PlutusArgs l
pwcArgs
    Left Plutus l
plutus ->
      case forall (l :: Language).
PlutusLanguage l =>
Version -> Plutus l -> Either ScriptDecodeError (PlutusRunnable l)
decodePlutusRunnable Version
pwcProtocolVersion Plutus l
plutus of
        Right PlutusRunnable l
pr -> 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 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 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 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 forall a. Semigroup a => a -> a -> a
<> [PlutusWithContext]
qs) (NonEmpty ScriptFailure
xs forall a. Semigroup a => a -> a -> a
<> NonEmpty ScriptFailure
ys)

instance Monoid ScriptResult where
  mempty :: ScriptResult
mempty = [PlutusWithContext] -> ScriptResult
Passes 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
pwcCostModel :: CostModel
pwcExUnits :: ExUnits
pwcArgs :: PlutusArgs l
pwcScriptHash :: ScriptHash
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcProtocolVersion :: Version
pwcCostModel :: PlutusWithContext -> CostModel
pwcExUnits :: PlutusWithContext -> ExUnits
pwcArgs :: ()
pwcScriptHash :: PlutusWithContext -> ScriptHash
pwcScript :: ()
pwcProtocolVersion :: PlutusWithContext -> Version
..}) =
    Word -> Encoding
Plain.encodeListLen Word
6
      forall a. Semigroup a => a -> a -> a
<> forall a. ToCBOR a => a -> Encoding
toCBOR Version
pwcProtocolVersion
      forall a. Semigroup a => a -> a -> a
<> Version -> Encoding -> Encoding
toPlainEncoding Version
pwcProtocolVersion (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. EncCBOR a => a -> Encoding
encCBOR forall a. EncCBOR a => a -> Encoding
encCBOR Either (Plutus l) (PlutusRunnable l)
pwcScript)
      forall a. Semigroup a => a -> a -> a
<> Version -> Encoding -> Encoding
toPlainEncoding Version
pwcProtocolVersion (forall a. EncCBOR a => a -> Encoding
encCBOR ScriptHash
pwcScriptHash)
      forall a. Semigroup a => a -> a -> a
<> Version -> Encoding -> Encoding
toPlainEncoding Version
pwcProtocolVersion (forall a. EncCBOR a => a -> Encoding
encCBOR PlutusArgs l
pwcArgs)
      forall a. Semigroup a => a -> a -> a
<> Version -> Encoding -> Encoding
toPlainEncoding Version
pwcProtocolVersion (forall a. EncCBOR a => a -> Encoding
encCBOR ExUnits
pwcExUnits)
      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 = forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
Plain.decodeRecordNamed Text
"PlutusWithContext" (forall a b. a -> b -> a
const Int
6) forall a b. (a -> b) -> a -> b
$ do
    Version
pwcProtocolVersion <- forall a s. FromCBOR a => Decoder s a
fromCBOR
    forall s a.
Maybe ByteString -> Version -> Decoder s a -> Decoder s a
toPlainDecoder forall a. Maybe a
Nothing Version
pwcProtocolVersion forall a b. (a -> b) -> a -> b
$ forall a so.
(forall si (l :: Language).
 PlutusLanguage l =>
 Plutus l -> Decoder si a)
-> Decoder so a
decodeWithPlutus forall a b. (a -> b) -> a -> b
$ \Plutus l
plutus -> do
      let lang :: Language
lang = forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage Plutus l
plutus
          pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript = forall a b. a -> Either a b
Left Plutus l
plutus
          scriptHash :: ScriptHash
scriptHash = forall (l :: Language). PlutusLanguage l => Plutus l -> ScriptHash
hashPlutusScript Plutus l
plutus
      ScriptHash
pwcScriptHash <- forall a s. DecCBOR a => Decoder s a
decCBOR
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ScriptHash
pwcScriptHash forall a. Eq a => a -> a -> Bool
== ScriptHash
scriptHash) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$
          String
"ScriptHash mismatch. Encoded: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ScriptHash
pwcScriptHash
            forall a. Semigroup a => a -> a -> a
<> String
" doesn't match the actual: "
            forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ScriptHash
scriptHash
      PlutusArgs l
pwcArgs <- forall a s. DecCBOR a => Decoder s a
decCBOR
      ExUnits
pwcExUnits <- forall a s. DecCBOR a => Decoder s a
decCBOR
      CostModel
pwcCostModel <- forall s. Language -> Decoder s CostModel
decodeCostModel Language
lang
      forall (f :: * -> *) a. Applicative f => a -> f a
pure PlutusWithContext {Either (Plutus l) (PlutusRunnable l)
Version
ScriptHash
ExUnits
PlutusArgs l
CostModel
pwcCostModel :: CostModel
pwcExUnits :: ExUnits
pwcArgs :: PlutusArgs l
pwcScriptHash :: ScriptHash
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcProtocolVersion :: Version
pwcCostModel :: CostModel
pwcExUnits :: ExUnits
pwcArgs :: PlutusArgs l
pwcScriptHash :: ScriptHash
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcProtocolVersion :: Version
..}

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)
  deriving (Int -> PlutusDebugInfo -> ShowS
[PlutusDebugInfo] -> ShowS
PlutusDebugInfo -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlutusDebugInfo] -> ShowS
$cshowList :: [PlutusDebugInfo] -> ShowS
show :: PlutusDebugInfo -> String
$cshow :: PlutusDebugInfo -> String
showsPrec :: Int -> PlutusDebugInfo -> ShowS
$cshowsPrec :: Int -> PlutusDebugInfo -> ShowS
Show)

data PlutusDebugOverrides = PlutusDebugOverrides
  { PlutusDebugOverrides -> Maybe ByteString
pdoScript :: !(Maybe ByteString)
  , PlutusDebugOverrides -> Maybe Version
pdoProtocolVersion :: !(Maybe Version)
  , PlutusDebugOverrides -> Maybe Language
pdoLanguage :: !(Maybe Language)
  , PlutusDebugOverrides -> Maybe [Int64]
pdoCostModelValues :: !(Maybe [Int64])
  , PlutusDebugOverrides -> Maybe Natural
pdoExUnitsMem :: !(Maybe Natural)
  , PlutusDebugOverrides -> Maybe Natural
pdoExUnitsSteps :: !(Maybe Natural)
  }
  deriving (Int -> PlutusDebugOverrides -> ShowS
[PlutusDebugOverrides] -> ShowS
PlutusDebugOverrides -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlutusDebugOverrides] -> ShowS
$cshowList :: [PlutusDebugOverrides] -> ShowS
show :: PlutusDebugOverrides -> String
$cshow :: PlutusDebugOverrides -> String
showsPrec :: Int -> PlutusDebugOverrides -> ShowS
$cshowsPrec :: Int -> PlutusDebugOverrides -> ShowS
Show)

-- TODO: Add support for overriding arguments.
overrideContext :: PlutusWithContext -> PlutusDebugOverrides -> PlutusWithContext
overrideContext :: PlutusWithContext -> PlutusDebugOverrides -> PlutusWithContext
overrideContext PlutusWithContext {Either (Plutus l) (PlutusRunnable l)
Version
ScriptHash
ExUnits
PlutusArgs l
CostModel
pwcCostModel :: CostModel
pwcExUnits :: ExUnits
pwcArgs :: PlutusArgs l
pwcScriptHash :: ScriptHash
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcProtocolVersion :: Version
pwcCostModel :: PlutusWithContext -> CostModel
pwcExUnits :: PlutusWithContext -> ExUnits
pwcArgs :: ()
pwcScriptHash :: PlutusWithContext -> ScriptHash
pwcScript :: ()
pwcProtocolVersion :: PlutusWithContext -> Version
..} PlutusDebugOverrides {Maybe Natural
Maybe [Int64]
Maybe ByteString
Maybe Version
Maybe Language
pdoExUnitsSteps :: Maybe Natural
pdoExUnitsMem :: Maybe Natural
pdoCostModelValues :: Maybe [Int64]
pdoLanguage :: Maybe Language
pdoProtocolVersion :: Maybe Version
pdoScript :: Maybe ByteString
pdoExUnitsSteps :: PlutusDebugOverrides -> Maybe Natural
pdoExUnitsMem :: PlutusDebugOverrides -> Maybe Natural
pdoCostModelValues :: PlutusDebugOverrides -> Maybe [Int64]
pdoLanguage :: PlutusDebugOverrides -> Maybe Language
pdoProtocolVersion :: PlutusDebugOverrides -> Maybe Version
pdoScript :: PlutusDebugOverrides -> Maybe ByteString
..} =
  -- 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 = 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
    , ScriptHash
PlutusArgs l
pwcArgs :: PlutusArgs l
pwcScriptHash :: ScriptHash
pwcArgs :: PlutusArgs l
pwcScriptHash :: ScriptHash
..
    }
  where
    overrideExUnits :: ExUnits
overrideExUnits =
      Natural -> Natural -> ExUnits
ExUnits
        (forall a. a -> Maybe a -> a
fromMaybe (ExUnits -> Natural
exUnitsMem ExUnits
pwcExUnits) Maybe Natural
pdoExUnitsMem)
        (forall a. a -> Maybe a -> a
fromMaybe (ExUnits -> Natural
exUnitsSteps ExUnits
pwcExUnits) Maybe Natural
pdoExUnitsSteps)
    overrideCostModel :: CostModel
overrideCostModel =
      forall b a. b -> Either a b -> b
fromRight CostModel
pwcCostModel forall a b. (a -> b) -> a -> b
$
        Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel
          (forall a. a -> Maybe a -> a
fromMaybe (CostModel -> Language
getCostModelLanguage CostModel
pwcCostModel) Maybe Language
pdoLanguage)
          (forall a. a -> Maybe a -> a
fromMaybe (CostModel -> [Int64]
getCostModelParams CostModel
pwcCostModel) Maybe [Int64]
pdoCostModelValues)
    overrideScript :: Either (Plutus l) (PlutusRunnable l)
overrideScript =
      case Maybe ByteString
pdoScript of
        Maybe ByteString
Nothing -> Either (Plutus l) (PlutusRunnable l)
pwcScript
        Just ByteString
script ->
          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (l :: Language). PlutusBinary -> Plutus l
Plutus forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShortByteString -> PlutusBinary
PlutusBinary forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ShortByteString
SBS.toShort) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String ByteString
B16.decode forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BSC.filter (forall a. Eq a => a -> a -> Bool
/= Char
'\n') ByteString
script

debugPlutus :: String -> PlutusDebugOverrides -> IO PlutusDebugInfo
debugPlutus :: String -> PlutusDebugOverrides -> IO PlutusDebugInfo
debugPlutus String
scriptsWithContext PlutusDebugOverrides
opts =
  case ByteString -> Either String ByteString
B64.decode (String -> ByteString
BSU.fromString String
scriptsWithContext) of
    Left String
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> PlutusDebugInfo
DebugBadHex (forall a. Show a => a -> String
show String
e)
    Right ByteString
bs ->
      case forall a. FromCBOR a => ByteString -> Either DecoderError a
Plain.decodeFull' ByteString
bs of
        Left DecoderError
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> PlutusDebugInfo
DebugCannotDecode forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show DecoderError
e
        Right PlutusWithContext
pwcOriginal ->
          let pwc :: PlutusWithContext
pwc = PlutusWithContext -> PlutusDebugOverrides -> PlutusWithContext
overrideContext PlutusWithContext
pwcOriginal PlutusDebugOverrides
opts
              cm :: EvaluationContext
cm = CostModel -> EvaluationContext
getEvaluationContext forall a b. (a -> b) -> a -> b
$ PlutusWithContext -> CostModel
pwcCostModel PlutusWithContext
pwc
              eu :: ExBudget
eu = ExUnits -> ExBudget
transExUnits forall a b. (a -> b) -> a -> b
$ PlutusWithContext -> ExUnits
pwcExUnits PlutusWithContext
pwc
              onDecoderError :: EvaluationError -> IO PlutusDebugInfo
onDecoderError EvaluationError
err = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text]
-> EvaluationError
-> PlutusWithContext
-> Maybe ExBudget
-> PlutusDebugInfo
DebugFailure [] EvaluationError
err PlutusWithContext
pwc forall a. Maybe a
Nothing
           in forall a.
PlutusWithContext
-> (EvaluationError -> a)
-> (forall (l :: Language).
    PlutusLanguage l =>
    PlutusRunnable l -> PlutusArgs l -> a)
-> a
withRunnablePlutusWithContext PlutusWithContext
pwc EvaluationError -> IO PlutusDebugInfo
onDecoderError forall a b. (a -> b) -> a -> b
$ \PlutusRunnable l
plutusRunnable PlutusArgs l
args ->
                let toDebugInfo :: ([Text], Either EvaluationError ExBudget) -> IO PlutusDebugInfo
toDebugInfo = \case
                      ([Text]
logs, Left err :: EvaluationError
err@(P.CodecError {})) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text]
-> EvaluationError
-> PlutusWithContext
-> Maybe ExBudget
-> PlutusDebugInfo
DebugFailure [Text]
logs EvaluationError
err PlutusWithContext
pwc forall a. Maybe a
Nothing
                      ([Text]
logs, Left EvaluationError
err) -> do
                        Maybe (Maybe ExBudget)
mExpectedExUnits <-
                          forall a. Int -> IO a -> IO (Maybe a)
timeout Int
5_000_000 forall a b. (a -> b) -> a -> b
$ do
                            let res :: ([Text], Either EvaluationError ExBudget)
res =
                                  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
                            case forall a b. (a, b) -> b
snd ([Text], Either EvaluationError ExBudget)
res of
                              Left {} -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                              Right ExBudget
exUnits -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. a -> IO a
evaluate (forall a. NFData a => a -> a
force ExBudget
exUnits)
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text]
-> EvaluationError
-> PlutusWithContext
-> Maybe ExBudget
-> PlutusDebugInfo
DebugFailure [Text]
logs EvaluationError
err PlutusWithContext
pwc (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join Maybe (Maybe ExBudget)
mExpectedExUnits)
                      ([Text]
logs, Right ExBudget
ex) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Text] -> ExBudget -> PlutusDebugInfo
DebugSuccess [Text]
logs ExBudget
ex
                 in ([Text], Either EvaluationError ExBudget) -> IO PlutusDebugInfo
toDebugInfo forall a b. (a -> b) -> a -> b
$
                      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 = forall a b. (a, b) -> b
snd 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 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
pwcCostModel :: CostModel
pwcExUnits :: ExUnits
pwcArgs :: PlutusArgs l
pwcScriptHash :: ScriptHash
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcProtocolVersion :: Version
pwcCostModel :: PlutusWithContext -> CostModel
pwcExUnits :: PlutusWithContext -> ExUnits
pwcArgs :: ()
pwcScriptHash :: PlutusWithContext -> ScriptHash
pwcScript :: ()
pwcProtocolVersion :: PlutusWithContext -> Version
..} =
  forall a.
PlutusWithContext
-> (EvaluationError -> a)
-> (forall (l :: Language).
    PlutusLanguage l =>
    PlutusRunnable l -> PlutusArgs l -> a)
-> a
withRunnablePlutusWithContext PlutusWithContext
pwc (([],) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left) forall a b. (a -> b) -> a -> b
$
    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 :: Version
pwcProtocolVersion :: PlutusWithContext -> Version
pwcProtocolVersion, Either (Plutus l) (PlutusRunnable l)
pwcScript :: Either (Plutus l) (PlutusRunnable l)
pwcScript :: ()
pwcScript, PlutusArgs l
pwcArgs :: PlutusArgs l
pwcArgs :: ()
pwcArgs} EvaluationError
e =
  let lang :: Language
lang = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage forall (l :: Language) (proxy :: Language -> *).
PlutusLanguage l =>
proxy l -> Language
plutusLanguage Either (Plutus l) (PlutusRunnable l)
pwcScript
      Plutus PlutusBinary
binaryScript = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> a
id forall (l :: Language). PlutusRunnable l -> Plutus l
plutusFromRunnable Either (Plutus l) (PlutusRunnable l)
pwcScript
      firstLines :: [String]
firstLines =
        [ String
"The " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Language
lang forall a. [a] -> [a] -> [a]
++ String
" script failed:"
        , String
"Base64-encoded script bytes:"
        ]
      shLine :: String
shLine = String
"The script hash is:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (PlutusWithContext -> ScriptHash
pwcScriptHash PlutusWithContext
pwc)
      pvLine :: String
pvLine = String
"The protocol version is: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Version
pwcProtocolVersion
      plutusError :: String
plutusError = String
"The plutus evaluation error is: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show EvaluationError
e

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