{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Alonzo.Plutus.Evaluate (
  evalPlutusScripts,
  evalPlutusScriptsWithLogs,
  CollectError (..),
  collectPlutusScriptsWithContext,

  -- * Execution units estimation
  TransactionScriptFailure (..),
  evalTxExUnits,
  RedeemerReport,
  evalTxExUnitsWithLogs,
  RedeemerReportWithLogs,
)
where

import Cardano.Ledger.Alonzo.Core
import Cardano.Ledger.Alonzo.Plutus.Context (ContextError, EraPlutusContext (..), LedgerTxInfo (..))
import Cardano.Ledger.Alonzo.Scripts (lookupPlutusScript, plutusScriptLanguage, toAsItem, toAsIx)
import Cardano.Ledger.Alonzo.TxWits (lookupRedeemer, unRedeemers)
import Cardano.Ledger.Alonzo.UTxO (AlonzoEraUTxO, AlonzoScriptsNeeded (..))
import Cardano.Ledger.BaseTypes (ProtVer (pvMajor), kindObject, natVersion, pvMajor)
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
import Cardano.Ledger.Binary.Coders
import Cardano.Ledger.Plutus.CostModels (costModelsValid)
import Cardano.Ledger.Plutus.Evaluate (
  PlutusWithContext (..),
  ScriptResult (..),
  evaluatePlutusWithContext,
  runPlutusScriptWithLogs,
 )
import Cardano.Ledger.Plutus.ExUnits
import Cardano.Ledger.Plutus.Language (Language (..))
import Cardano.Ledger.Plutus.TxInfo (exBudgetToExUnits)
import Cardano.Ledger.TxIn (TxIn)
import Cardano.Ledger.UTxO (EraUTxO (..), ScriptsProvided (..), UTxO (..))
import Cardano.Slotting.EpochInfo (EpochInfo)
import Cardano.Slotting.Time (SystemStart)
import Control.DeepSeq (NFData)
import Control.Monad (guard)
import Data.Aeson (ToJSON (..), (.=), pattern String)
import Data.Bifunctor (first)
import Data.List (intercalate)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.MapExtras (fromElems)
import Data.Maybe (mapMaybe)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Debug.Trace as Debug
import GHC.Generics
import Lens.Micro
import NoThunks.Class (NoThunks)
import qualified PlutusLedgerApi.Common as P

-- ===============================================================
-- From the specification, Figure 7 "Scripts and their Arguments"
-- ===============================================================

-- | When collecting inputs for two phase scripts, 3 things can go wrong.
data CollectError era
  = NoRedeemer !(PlutusPurpose AsItem era)
  | NoWitness !ScriptHash
  | NoCostModel !Language
  | BadTranslation !(ContextError era)
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (CollectError era) x -> CollectError era
forall era x. CollectError era -> Rep (CollectError era) x
$cto :: forall era x. Rep (CollectError era) x -> CollectError era
$cfrom :: forall era x. CollectError era -> Rep (CollectError era) x
Generic)

deriving instance
  (AlonzoEraScript era, Eq (ContextError era)) =>
  Eq (CollectError era)

deriving instance
  (AlonzoEraScript era, Show (ContextError era)) =>
  Show (CollectError era)

deriving instance
  (AlonzoEraScript era, NoThunks (ContextError era)) =>
  NoThunks (CollectError era)

deriving instance
  (AlonzoEraScript era, NFData (ContextError era)) =>
  NFData (CollectError era)

instance (AlonzoEraScript era, EncCBOR (ContextError era)) => EncCBOR (CollectError era) where
  encCBOR :: CollectError era -> Encoding
encCBOR (NoRedeemer PlutusPurpose AsItem era
x) = forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Word -> Encode 'Open t
Sum forall era. PlutusPurpose AsItem era -> CollectError era
NoRedeemer Word
0 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PlutusPurpose AsItem era
x
  encCBOR (NoWitness ScriptHash
x) = forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Word -> Encode 'Open t
Sum (forall era. ScriptHash -> CollectError era
NoWitness @era) Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To ScriptHash
x
  encCBOR (NoCostModel Language
x) = forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Word -> Encode 'Open t
Sum forall era. Language -> CollectError era
NoCostModel Word
2 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Language
x
  encCBOR (BadTranslation ContextError era
x) = forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$ forall t. t -> Word -> Encode 'Open t
Sum (forall era. ContextError era -> CollectError era
BadTranslation @era) Word
3 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To ContextError era
x

instance (AlonzoEraScript era, DecCBOR (ContextError era)) => DecCBOR (CollectError era) where
  decCBOR :: forall s. Decoder s (CollectError era)
decCBOR = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode (forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"CollectError" forall {era}.
(DecCBOR (PlutusPurpose AsItem era), DecCBOR (ContextError era)) =>
Word -> Decode 'Open (CollectError era)
dec)
    where
      dec :: Word -> Decode 'Open (CollectError era)
dec Word
0 = forall t. t -> Decode 'Open t
SumD forall era. PlutusPurpose AsItem era -> CollectError era
NoRedeemer forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
1 = forall t. t -> Decode 'Open t
SumD forall era. ScriptHash -> CollectError era
NoWitness forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
2 = forall t. t -> Decode 'Open t
SumD forall era. Language -> CollectError era
NoCostModel forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
3 = forall t. t -> Decode 'Open t
SumD forall era. ContextError era -> CollectError era
BadTranslation forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
      dec Word
n = forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
n

instance
  ( Era era
  , ToJSON (PlutusPurpose AsItem era)
  , ToJSON (ContextError era)
  ) =>
  ToJSON (CollectError era)
  where
  toJSON :: CollectError era -> Value
toJSON = \case
    NoRedeemer PlutusPurpose AsItem era
sPurpose ->
      Text -> [Pair] -> Value
kindObject Text
"CollectError" forall a b. (a -> b) -> a -> b
$
        [ Key
"error" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NoRedeemer"
        , Key
"plutusPurpose" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON PlutusPurpose AsItem era
sPurpose
        ]
    NoWitness ScriptHash
sHash ->
      Text -> [Pair] -> Value
kindObject Text
"CollectError" forall a b. (a -> b) -> a -> b
$
        [ Key
"error" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NoWitness"
        , Key
"scriptHash" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON ScriptHash
sHash
        ]
    NoCostModel Language
lang ->
      Text -> [Pair] -> Value
kindObject Text
"CollectError" forall a b. (a -> b) -> a -> b
$
        [ Key
"error" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"NoCostModel"
        , Key
"language" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON Language
lang
        ]
    BadTranslation ContextError era
err ->
      Text -> [Pair] -> Value
kindObject Text
"BadTranslation" [Key
"error" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= forall a. ToJSON a => a -> Value
toJSON ContextError era
err]

collectPlutusScriptsWithContext ::
  forall era.
  ( AlonzoEraTxBody era
  , AlonzoEraTxWits era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , EraPlutusContext era
  ) =>
  EpochInfo (Either Text) ->
  SystemStart ->
  PParams era ->
  Tx era ->
  UTxO era ->
  Either [CollectError era] [PlutusWithContext]
collectPlutusScriptsWithContext :: forall era.
(AlonzoEraTxBody era, AlonzoEraTxWits era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraPlutusContext era) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either [CollectError era] [PlutusWithContext]
collectPlutusScriptsWithContext EpochInfo (Either Text)
epochInfo SystemStart
systemStart PParams era
pp Tx era
tx UTxO era
utxo =
  -- TODO: remove this whole complicated check when we get into Conway. It is much simpler
  -- to fail on a CostModel lookup in the `apply` function (already implemented).
  let missingCostModels :: Set Language
missingCostModels = forall a. (a -> Bool) -> Set a -> Set a
Set.filter (forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Language CostModel
costModels) Set Language
usedLanguages
   in case forall (f :: * -> *). Alternative f => Bool -> f ()
guard (ProtVer -> Version
pvMajor ProtVer
protVer forall a. Ord a => a -> a -> Bool
< forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Set a -> Maybe a
Set.lookupMin Set Language
missingCostModels of
        Just Language
l -> forall a b. a -> Either a b
Left [forall era. Language -> CollectError era
NoCostModel Language
l]
        Maybe Language
Nothing ->
          forall t b a.
(t -> Either a b)
-> [Either a t] -> Either [a] [b] -> Either [a] [b]
merge
            (PlutusScript era, PlutusPurpose AsIxItem era, Data era, ExUnits,
 ScriptHash)
-> Either (CollectError era) PlutusWithContext
apply
            (forall a b. (a -> b) -> [a] -> [b]
map ((ScriptHash, PlutusPurpose AsIxItem era), PlutusScript era)
-> Either
     (CollectError era)
     (PlutusScript era, PlutusPurpose AsIxItem era, Data era, ExUnits,
      ScriptHash)
getScriptWithRedeemer [((ScriptHash, PlutusPurpose AsIxItem era), PlutusScript era)]
neededPlutusScripts)
            (forall a b. b -> Either a b
Right [])
  where
    -- Check on a protocol version to preserve failure mode (a single NoCostModel failure
    -- for languages with missing cost models) until we are in Conway era. After we hard
    -- fork into Conway it will be safe to remove this check together with the
    -- `missingCostModels` lookup
    --
    -- We also need to pass major protocol version to the script for script evaluation
    protVer :: ProtVer
protVer = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
    costModels :: Map Language CostModel
costModels = CostModels -> Map Language CostModel
costModelsValid forall a b. (a -> b) -> a -> b
$ PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL

    ScriptsProvided Map ScriptHash (Script era)
scriptsProvided = forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Tx era
tx
    AlonzoScriptsNeeded [(PlutusPurpose AsIxItem era, ScriptHash)]
scriptsNeeded = forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo (Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL)
    neededPlutusScripts :: [((ScriptHash, PlutusPurpose AsIxItem era), PlutusScript era)]
neededPlutusScripts =
      forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\(PlutusPurpose AsIxItem era
sp, ScriptHash
sh) -> (,) (ScriptHash
sh, PlutusPurpose AsIxItem era
sp) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era.
AlonzoEraScript era =>
ScriptHash
-> Map ScriptHash (Script era) -> Maybe (PlutusScript era)
lookupPlutusScript ScriptHash
sh Map ScriptHash (Script era)
scriptsProvided) [(PlutusPurpose AsIxItem era, ScriptHash)]
scriptsNeeded
    usedLanguages :: Set Language
usedLanguages = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [((ScriptHash, PlutusPurpose AsIxItem era), PlutusScript era)]
neededPlutusScripts

    getScriptWithRedeemer :: ((ScriptHash, PlutusPurpose AsIxItem era), PlutusScript era)
-> Either
     (CollectError era)
     (PlutusScript era, PlutusPurpose AsIxItem era, Data era, ExUnits,
      ScriptHash)
getScriptWithRedeemer ((ScriptHash
plutusScriptHash, PlutusPurpose AsIxItem era
plutusPurpose), PlutusScript era
plutusScript) =
      let redeemerIndex :: PlutusPurpose AsIx era
redeemerIndex = forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx PlutusPurpose AsIxItem era
plutusPurpose
       in case forall era.
Ord (PlutusPurpose AsIx era) =>
PlutusPurpose AsIx era
-> Redeemers era -> Maybe (Data era, ExUnits)
lookupRedeemer PlutusPurpose AsIx era
redeemerIndex forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL of
            Just (Data era
d, ExUnits
exUnits) -> forall a b. b -> Either a b
Right (PlutusScript era
plutusScript, PlutusPurpose AsIxItem era
plutusPurpose, Data era
d, ExUnits
exUnits, ScriptHash
plutusScriptHash)
            Maybe (Data era, ExUnits)
Nothing -> forall a b. a -> Either a b
Left (forall era. PlutusPurpose AsItem era -> CollectError era
NoRedeemer (forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose forall ix it. AsIxItem ix it -> AsItem ix it
toAsItem PlutusPurpose AsIxItem era
plutusPurpose))
    apply :: (PlutusScript era, PlutusPurpose AsIxItem era, Data era, ExUnits,
 ScriptHash)
-> Either (CollectError era) PlutusWithContext
apply (PlutusScript era
plutusScript, PlutusPurpose AsIxItem era
plutusPurpose, Data era
redeemerData, ExUnits
exUnits, ScriptHash
plutusScriptHash) = do
      let lang :: Language
lang = forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage PlutusScript era
plutusScript
          ledgerTxInfo :: LedgerTxInfo era
ledgerTxInfo =
            LedgerTxInfo
              { ltiProtVer :: ProtVer
ltiProtVer = ProtVer
protVer
              , ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo = EpochInfo (Either Text)
epochInfo
              , ltiSystemStart :: SystemStart
ltiSystemStart = SystemStart
systemStart
              , ltiUTxO :: UTxO era
ltiUTxO = UTxO era
utxo
              , ltiTx :: Tx era
ltiTx = Tx era
tx
              }
      CostModel
costModel <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left (forall era. Language -> CollectError era
NoCostModel Language
lang)) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Language
lang Map Language CostModel
costModels
      forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall era. ContextError era -> CollectError era
BadTranslation forall a b. (a -> b) -> a -> b
$
        forall era.
EraPlutusContext era =>
PlutusScript era
-> ScriptHash
-> PlutusPurpose AsIxItem era
-> LedgerTxInfo era
-> (Data era, ExUnits)
-> CostModel
-> Either (ContextError era) PlutusWithContext
mkPlutusWithContext
          PlutusScript era
plutusScript
          ScriptHash
plutusScriptHash
          PlutusPurpose AsIxItem era
plutusPurpose
          LedgerTxInfo era
ledgerTxInfo
          (Data era
redeemerData, ExUnits
exUnits)
          CostModel
costModel

-- | Merge two lists (the first of which may have failures, i.e. (Left _)), collect all the failures
--   but if there are none, use 'f' to construct a success.
merge :: forall t b a. (t -> Either a b) -> [Either a t] -> Either [a] [b] -> Either [a] [b]
merge :: forall t b a.
(t -> Either a b)
-> [Either a t] -> Either [a] [b] -> Either [a] [b]
merge t -> Either a b
_f [] Either [a] [b]
answer = Either [a] [b]
answer
merge t -> Either a b
f (Either a t
x : [Either a t]
xs) Either [a] [b]
zs = forall t b a.
(t -> Either a b)
-> [Either a t] -> Either [a] [b] -> Either [a] [b]
merge t -> Either a b
f [Either a t]
xs (Either a t -> Either [a] [b] -> Either [a] [b]
gg Either a t
x Either [a] [b]
zs)
  where
    gg :: Either a t -> Either [a] [b] -> Either [a] [b]
    gg :: Either a t -> Either [a] [b] -> Either [a] [b]
gg (Right t
t) (Right [b]
cs) =
      case t -> Either a b
f t
t of
        Right b
c -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ b
c forall a. a -> [a] -> [a]
: [b]
cs
        Left a
e -> forall a b. a -> Either a b
Left [a
e]
    gg (Left a
a) (Right [b]
_) = forall a b. a -> Either a b
Left [a
a]
    gg (Right t
_) (Left [a]
cs) = forall a b. a -> Either a b
Left [a]
cs
    gg (Left a
a) (Left [a]
cs) = forall a b. a -> Either a b
Left (a
a forall a. a -> [a] -> [a]
: [a]
cs)

-- | Evaluate a list of Plutus scripts. All scripts in the list must evaluate to `True`.
evalPlutusScripts :: [PlutusWithContext] -> ScriptResult
evalPlutusScripts :: [PlutusWithContext] -> ScriptResult
evalPlutusScripts [PlutusWithContext]
pwcs = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ [PlutusWithContext] -> ([Text], ScriptResult)
evalPlutusScriptsWithLogs [PlutusWithContext]
pwcs

evalPlutusScriptsWithLogs :: [PlutusWithContext] -> ([Text], ScriptResult)
evalPlutusScriptsWithLogs :: [PlutusWithContext] -> ([Text], ScriptResult)
evalPlutusScriptsWithLogs [] = forall a. Monoid a => a
mempty
evalPlutusScriptsWithLogs (PlutusWithContext
plutusWithContext : [PlutusWithContext]
rest) =
  let beginMsg :: String
beginMsg =
        forall a. [a] -> [[a]] -> [a]
intercalate
          String
","
          [ String
"[LEDGER][PLUTUS_SCRIPT]"
          , String
"BEGIN"
          ]
      !res :: ([Text], ScriptResult)
res = forall a. String -> a -> a
Debug.traceEvent String
beginMsg forall a b. (a -> b) -> a -> b
$ PlutusWithContext -> ([Text], ScriptResult)
runPlutusScriptWithLogs PlutusWithContext
plutusWithContext
      endMsg :: String
endMsg =
        forall a. [a] -> [[a]] -> [a]
intercalate
          String
","
          [ String
"[LEDGER][PLUTUS_SCRIPT]"
          , String
"END"
          ]
   in forall a. String -> a -> a
Debug.traceEvent String
endMsg ([Text], ScriptResult)
res forall a. Semigroup a => a -> a -> a
<> [PlutusWithContext] -> ([Text], ScriptResult)
evalPlutusScriptsWithLogs [PlutusWithContext]
rest

-- | Script failures that can be returned by 'evalTxExUnitsWithLogs'.
data TransactionScriptFailure era
  = -- | A redeemer was supplied which points to a script hash which
    -- we cannot connect to a Plutus script.
    RedeemerPointsToUnknownScriptHash !(PlutusPurpose AsIx era)
  | -- | Missing redeemer.
    MissingScript
      -- | Redeemer pointer which cannot be resolved
      !(PlutusPurpose AsIx era)
      -- | Map of pointers which can be resolved together with PlutusScripts and their
      -- respective contexts
      !( Map
          (PlutusPurpose AsIx era)
          (PlutusPurpose AsItem era, Maybe (PlutusScript era), ScriptHash)
       )
  | -- | Missing datum.
    MissingDatum !DataHash
  | -- | Plutus evaluation error, for any version
    ValidationFailure
      -- | Supplied execution units in the transaction, which were ignored for calculating
      -- the actual execution units.
      !ExUnits
      !P.EvaluationError
      ![Text]
      !PlutusWithContext
  | -- | A redeemer points to a transaction input which is not
    --  present in the current UTxO.
    UnknownTxIn !TxIn
  | -- | A redeemer points to a transaction input which is not
    --  plutus locked.
    InvalidTxIn !TxIn
  | -- | The execution budget that was calculated by the Plutus
    --  evaluator is out of bounds.
    IncompatibleBudget !P.ExBudget
  | -- | There was no cost model for a given version of Plutus in the ledger state
    NoCostModelInLedgerState !Language
  | -- | Error that can happen during plutus context translation
    ContextError !(ContextError era)

deriving instance
  ( Era era
  , Eq (TxCert era)
  , Eq (PlutusScript era)
  , Eq (ContextError era)
  , Eq (PlutusPurpose AsIx era)
  , Eq (PlutusPurpose AsItem era)
  ) =>
  Eq (TransactionScriptFailure era)

deriving instance
  ( Era era
  , Show (TxCert era)
  , Show (ContextError era)
  , Show (PlutusScript era)
  , Show (PlutusPurpose AsIx era)
  , Show (PlutusPurpose AsItem era)
  ) =>
  Show (TransactionScriptFailure era)

note :: e -> Maybe a -> Either e a
note :: forall e a. e -> Maybe a -> Either e a
note e
_ (Just a
x) = forall a b. b -> Either a b
Right a
x
note e
e Maybe a
Nothing = forall a b. a -> Either a b
Left e
e

type RedeemerReport era =
  Map (PlutusPurpose AsIx era) (Either (TransactionScriptFailure era) ExUnits)

type RedeemerReportWithLogs era =
  Map (PlutusPurpose AsIx era) (Either (TransactionScriptFailure era) ([Text], ExUnits))

-- | Evaluate the execution budgets needed for all the redeemers in
--  a given transaction. If a redeemer is invalid, a failure is returned instead.
--
--  The execution budgets in the supplied transaction are completely ignored.
--  The results of 'evalTxExUnitsWithLogs' are intended to replace them.
evalTxExUnits ::
  forall era.
  ( AlonzoEraTx era
  , EraUTxO era
  , EraPlutusContext era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  ) =>
  PParams era ->
  -- | The transaction.
  Tx era ->
  -- | The current UTxO set (or the relevant portion for the transaction).
  UTxO era ->
  -- | The epoch info, used to translate slots to POSIX time for plutus.
  EpochInfo (Either Text) ->
  -- | The start time of the given block chain.
  SystemStart ->
  -- | We return a map from redeemer pointers to either a failure or a
  --  sufficient execution budget.
  RedeemerReport era
evalTxExUnits :: forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReport era
evalTxExUnits PParams era
pp Tx era
tx UTxO era
utxo EpochInfo (Either Text)
epochInfo SystemStart
systemStart =
  forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReportWithLogs era
evalTxExUnitsWithLogs PParams era
pp Tx era
tx UTxO era
utxo EpochInfo (Either Text)
epochInfo SystemStart
systemStart

-- | Evaluate the execution budgets needed for all the redeemers in
--  a given transaction.
--
--  The execution budgets in the supplied transaction are completely ignored.
--  The results of 'evalTxExUnitsWithLogs' are intended to replace them.
evalTxExUnitsWithLogs ::
  forall era.
  ( AlonzoEraTx era
  , EraUTxO era
  , EraPlutusContext era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  ) =>
  PParams era ->
  -- | The transaction.
  Tx era ->
  -- | The current UTxO set (or the relevant portion for the transaction).
  UTxO era ->
  -- | The epoch info, used to translate slots to POSIX time for plutus.
  EpochInfo (Either Text) ->
  -- | The start time of the given block chain.
  SystemStart ->
  -- | We return a map from redeemer pointers to either a failure or a sufficient
  --  execution budget with logs of the script.  Otherwise, we return a 'TranslationError'
  --  manifesting from failed attempts to construct a valid execution context for the
  --  given transaction.
  --
  --  Unlike `evalTxExUnits`, this function also returns evaluation logs, useful for
  --  debugging.
  RedeemerReportWithLogs era
evalTxExUnitsWithLogs :: forall era.
(AlonzoEraTx era, EraUTxO era, EraPlutusContext era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era) =>
PParams era
-> Tx era
-> UTxO era
-> EpochInfo (Either Text)
-> SystemStart
-> RedeemerReportWithLogs era
evalTxExUnitsWithLogs PParams era
pp Tx era
tx UTxO era
utxo EpochInfo (Either Text)
epochInfo SystemStart
systemStart = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Either (TransactionScriptFailure era) ([Text], ExUnits)
findAndCount Map (PlutusPurpose AsIx era) (Data era, ExUnits)
rdmrs
  where
    keyedByPurpose :: (PlutusPurpose AsIxItem era, b) -> PlutusPurpose AsIx era
keyedByPurpose (PlutusPurpose AsIxItem era
plutusPurpose, b
_) = forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose forall ix it. AsIxItem ix it -> AsIx ix it
toAsIx PlutusPurpose AsIxItem era
plutusPurpose
    purposeToScriptHash :: Map
  (PlutusPurpose AsIx era) (PlutusPurpose AsIxItem era, ScriptHash)
purposeToScriptHash = forall (f :: * -> *) k v.
(Foldable f, Ord k) =>
(v -> k) -> f v -> Map k v
fromElems forall {era} {b}.
AlonzoEraScript era =>
(PlutusPurpose AsIxItem era, b) -> PlutusPurpose AsIx era
keyedByPurpose [(PlutusPurpose AsIxItem era, ScriptHash)]
scriptsNeeded
    ledgerTxInfo :: LedgerTxInfo era
ledgerTxInfo =
      LedgerTxInfo
        { ltiProtVer :: ProtVer
ltiProtVer = ProtVer
protVer
        , ltiEpochInfo :: EpochInfo (Either Text)
ltiEpochInfo = EpochInfo (Either Text)
epochInfo
        , ltiSystemStart :: SystemStart
ltiSystemStart = SystemStart
systemStart
        , ltiUTxO :: UTxO era
ltiUTxO = UTxO era
utxo
        , ltiTx :: Tx era
ltiTx = Tx era
tx
        }
    maxBudget :: ExUnits
maxBudget = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
    txBody :: TxBody era
txBody = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
    wits :: TxWits era
wits = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL
    rdmrs :: Map (PlutusPurpose AsIx era) (Data era, ExUnits)
rdmrs = forall era.
Redeemers era -> Map (PlutusPurpose AsIx era) (Data era, ExUnits)
unRedeemers forall a b. (a -> b) -> a -> b
$ TxWits era
wits forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxWits era =>
Lens' (TxWits era) (Redeemers era)
rdmrsTxWitsL
    protVer :: ProtVer
protVer = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) ProtVer
ppProtocolVersionL
    costModels :: Map Language CostModel
costModels = CostModels -> Map Language CostModel
costModelsValid forall a b. (a -> b) -> a -> b
$ PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
ppCostModelsL
    ScriptsProvided Map ScriptHash (Script era)
scriptsProvided = forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Tx era
tx
    AlonzoScriptsNeeded [(PlutusPurpose AsIxItem era, ScriptHash)]
scriptsNeeded = forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
utxo TxBody era
txBody
    findAndCount :: PlutusPurpose AsIx era
-> (Data era, ExUnits)
-> Either (TransactionScriptFailure era) ([Text], ExUnits)
findAndCount PlutusPurpose AsIx era
pointer (Data era
redeemerData, ExUnits
exUnits) = do
      (PlutusPurpose AsIxItem era
plutusPurpose, ScriptHash
plutusScriptHash) <-
        forall e a. e -> Maybe a -> Either e a
note (forall era. PlutusPurpose AsIx era -> TransactionScriptFailure era
RedeemerPointsToUnknownScriptHash PlutusPurpose AsIx era
pointer) forall a b. (a -> b) -> a -> b
$
          forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PlutusPurpose AsIx era
pointer Map
  (PlutusPurpose AsIx era) (PlutusPurpose AsIxItem era, ScriptHash)
purposeToScriptHash
      let ptrToPlutusScriptNoContext :: Map
  (PlutusPurpose AsIx era)
  (PlutusPurpose AsItem era, Maybe (PlutusScript era), ScriptHash)
ptrToPlutusScriptNoContext =
            forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
              ( \(PlutusPurpose AsIxItem era
sp, ScriptHash
sh) ->
                  ( forall era (g :: * -> * -> *) (f :: * -> * -> *).
AlonzoEraScript era =>
(forall ix it. g ix it -> f ix it)
-> PlutusPurpose g era -> PlutusPurpose f era
hoistPlutusPurpose forall ix it. AsIxItem ix it -> AsItem ix it
toAsItem PlutusPurpose AsIxItem era
sp
                  , forall era.
AlonzoEraScript era =>
ScriptHash
-> Map ScriptHash (Script era) -> Maybe (PlutusScript era)
lookupPlutusScript ScriptHash
sh Map ScriptHash (Script era)
scriptsProvided
                  , ScriptHash
sh
                  )
              )
              Map
  (PlutusPurpose AsIx era) (PlutusPurpose AsIxItem era, ScriptHash)
purposeToScriptHash
      PlutusScript era
plutusScript <-
        forall e a. e -> Maybe a -> Either e a
note (forall era.
PlutusPurpose AsIx era
-> Map
     (PlutusPurpose AsIx era)
     (PlutusPurpose AsItem era, Maybe (PlutusScript era), ScriptHash)
-> TransactionScriptFailure era
MissingScript PlutusPurpose AsIx era
pointer Map
  (PlutusPurpose AsIx era)
  (PlutusPurpose AsItem era, Maybe (PlutusScript era), ScriptHash)
ptrToPlutusScriptNoContext) forall a b. (a -> b) -> a -> b
$
          forall era.
AlonzoEraScript era =>
ScriptHash
-> Map ScriptHash (Script era) -> Maybe (PlutusScript era)
lookupPlutusScript ScriptHash
plutusScriptHash Map ScriptHash (Script era)
scriptsProvided
      let lang :: Language
lang = forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage PlutusScript era
plutusScript
      CostModel
costModel <-
        forall e a. e -> Maybe a -> Either e a
note (forall era. Language -> TransactionScriptFailure era
NoCostModelInLedgerState Language
lang) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Language
lang Map Language CostModel
costModels
      PlutusWithContext
pwc <-
        forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall era. ContextError era -> TransactionScriptFailure era
ContextError forall a b. (a -> b) -> a -> b
$
          forall era.
EraPlutusContext era =>
PlutusScript era
-> ScriptHash
-> PlutusPurpose AsIxItem era
-> LedgerTxInfo era
-> (Data era, ExUnits)
-> CostModel
-> Either (ContextError era) PlutusWithContext
mkPlutusWithContext
            PlutusScript era
plutusScript
            ScriptHash
plutusScriptHash
            PlutusPurpose AsIxItem era
plutusPurpose
            LedgerTxInfo era
ledgerTxInfo
            (Data era
redeemerData, ExUnits
maxBudget)
            CostModel
costModel
      case VerboseMode
-> PlutusWithContext -> ([Text], Either EvaluationError ExBudget)
evaluatePlutusWithContext VerboseMode
P.Verbose PlutusWithContext
pwc of
        ([Text]
logs, Left EvaluationError
err) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall era.
ExUnits
-> EvaluationError
-> [Text]
-> PlutusWithContext
-> TransactionScriptFailure era
ValidationFailure ExUnits
exUnits EvaluationError
err [Text]
logs PlutusWithContext
pwc
        ([Text]
logs, Right ExBudget
exBudget) ->
          forall e a. e -> Maybe a -> Either e a
note (forall era. ExBudget -> TransactionScriptFailure era
IncompatibleBudget ExBudget
exBudget) forall a b. (a -> b) -> a -> b
$
            (,) [Text]
logs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExBudget -> Maybe ExUnits
exBudgetToExUnits ExBudget
exBudget