{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}

{-# HLINT ignore "Use <$>" #-}

-- | Simplified interface to phase-2 validation of transactions, eg. evaluation
-- of Plutus scripts.
--
-- The `evaluateTx` function simplifies the call to ledger and plutus providing
-- an 'EvaluationReport' using pre-canned `ProtocolParameters`. This should only
-- be used for /testing/ or /benchmarking/ purpose as the real evaluation
-- parameters are set when the Hydra node starts.
--
-- __NOTE__: The reason this module is here instead of part of `test/` directory
-- is to be used in @tx-cost@ executable.
module Hydra.Ledger.Cardano.Evaluate where

import Hydra.Prelude hiding (label)

import Cardano.Api.UTxO qualified as UTxO
import Cardano.Ledger.Alonzo.Plutus.Evaluate (collectPlutusScriptsWithContext)
import Cardano.Ledger.Alonzo.Scripts (CostModel, Prices (..), mkCostModel, mkCostModels, txscriptfee)
import Cardano.Ledger.Api (CoinPerByte (..), ppCoinsPerUTxOByteL, ppCostModelsL, ppMaxBlockExUnitsL, ppMaxTxExUnitsL, ppMaxValSizeL, ppMinFeeAL, ppMinFeeBL, ppPricesL, ppProtocolVersionL)
import Cardano.Ledger.BaseTypes (BoundedRational (boundRational), ProtVer (..), getVersion, natVersion)
import Cardano.Ledger.Coin (Coin (Coin))
import Cardano.Ledger.Core (PParams, ppMaxTxSizeL)
import Cardano.Ledger.Plutus (
  LegacyPlutusArgs (..),
  PlutusArgs (..),
  PlutusLanguage (decodePlutusRunnable),
  PlutusRunnable (..),
  PlutusWithContext (..),
  SLanguage (..),
  isLanguage,
  unPlutusV2Args,
 )
import Cardano.Ledger.Plutus.Language (Language (PlutusV2))
import Cardano.Ledger.Val (Val ((<+>)), (<×>))
import Cardano.Slotting.EpochInfo (EpochInfo, fixedEpochInfo)
import Cardano.Slotting.Slot (EpochNo (EpochNo), EpochSize (EpochSize), SlotNo (SlotNo))
import Cardano.Slotting.Time (RelativeTime (RelativeTime), SlotLength, SystemStart (SystemStart), mkSlotLength)
import Control.Arrow (left)
import Control.Lens ((.~))
import Control.Lens.Getter
import Data.ByteString qualified as BS
import Data.Default (def)
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.Ratio ((%))
import Data.SOP.NonEmpty (NonEmpty (NonEmptyOne))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Flat (flat)
import Hydra.Cardano.Api (
  Era,
  EraHistory (EraHistory),
  ExecutionUnits (..),
  IsCardanoEra (cardanoEra),
  LedgerEpochInfo (..),
  LedgerEra,
  LedgerProtocolParameters (..),
  ProtocolParametersConversionError,
  ScriptExecutionError (ScriptErrorMissingScript),
  ScriptWitnessIndex,
  SerialiseAsCBOR (serialiseToCBOR),
  StandardCrypto,
  TransactionValidityError,
  Tx,
  UTxO,
  evaluateTransactionExecutionUnits,
  getTxBody,
  toLedgerExUnits,
  toLedgerTx,
  toLedgerUTxO,
 )
import Hydra.Cardano.Api.Pretty (renderTxWithUTxO)
import Hydra.Ledger.Cardano.Time (slotNoFromUTCTime, slotNoToUTCTime)
import Hydra.Tx.ContestationPeriod (ContestationPeriod (UnsafeContestationPeriod))
import Ouroboros.Consensus.Block (GenesisWindow (..))
import Ouroboros.Consensus.Cardano.Block (CardanoEras)
import Ouroboros.Consensus.HardFork.History (
  Bound (Bound, boundEpoch, boundSlot, boundTime),
  EraEnd (..),
  EraParams (..),
  EraSummary (..),
  SafeZone (..),
  Summary (Summary),
  initBound,
  mkInterpreter,
 )
import PlutusCore qualified as PLC
import PlutusLedgerApi.Common (mkTermToEvaluate, toData)
import PlutusLedgerApi.Common qualified as Plutus
import Test.QuickCheck (Property, choose, counterexample, property)
import Test.QuickCheck.Gen (chooseWord64)
import UntypedPlutusCore (UnrestrictedProgram (..))
import UntypedPlutusCore qualified as UPLC

-- * Evaluate transactions

-- | Thin wrapper around 'evaluateTransactionExecutionUnits', using fixtures
-- from this module for 'systemStart', 'eraHistory' and 'pparams'.
--
-- Additionally, this function checks the overall execution units are not
-- exceeding 'maxTxExecutionUnits'.
evaluateTx ::
  Tx ->
  UTxO ->
  Either EvaluationError EvaluationReport
evaluateTx :: Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx = ExecutionUnits
-> Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx' ExecutionUnits
maxTxExecutionUnits

-- | Like 'evaluateTx', but with a configurable maximum transaction
-- 'ExecutionUnits'.
evaluateTx' ::
  -- | Max tx execution units.
  ExecutionUnits ->
  Tx ->
  UTxO ->
  Either EvaluationError EvaluationReport
evaluateTx' :: ExecutionUnits
-> Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx' ExecutionUnits
maxUnits Tx
tx UTxO
utxo = do
  let pparams' :: PParams StandardConway
pparams' = PParams LedgerEra
PParams StandardConway
pparams PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams StandardConway) ExUnits
ppMaxTxExUnitsL ((ExUnits -> Identity ExUnits)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> ExUnits -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ExecutionUnits -> ExUnits
toLedgerExUnits ExecutionUnits
maxUnits
  case LedgerProtocolParameters Era
-> Either (TransactionValidityError Era) EvaluationReport
result (PParams LedgerEra -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams LedgerEra
PParams StandardConway
pparams') of
    Left TransactionValidityError Era
txValidityError -> EvaluationError -> Either EvaluationError EvaluationReport
forall a b. a -> Either a b
Left (EvaluationError -> Either EvaluationError EvaluationReport)
-> EvaluationError -> Either EvaluationError EvaluationReport
forall a b. (a -> b) -> a -> b
$ TransactionValidityError Era -> EvaluationError
TransactionInvalid TransactionValidityError Era
txValidityError
    Right EvaluationReport
report
      -- Check overall budget when all individual scripts evaluated
      | (Either ScriptExecutionError ExecutionUnits -> Bool)
-> EvaluationReport -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isRight EvaluationReport
report -> ExecutionUnits
-> EvaluationReport -> Either EvaluationError EvaluationReport
checkBudget ExecutionUnits
maxUnits EvaluationReport
report
      | Bool
otherwise -> EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
report
 where
  result ::
    LedgerProtocolParameters UTxO.Era ->
    Either
      (TransactionValidityError UTxO.Era)
      ( Map
          ScriptWitnessIndex
          ( Either
              ScriptExecutionError
              ExecutionUnits
          )
      )
  result :: LedgerProtocolParameters Era
-> Either (TransactionValidityError Era) EvaluationReport
result LedgerProtocolParameters Era
pparams' =
    ((Map
   ScriptWitnessIndex
   (Either
      ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
 -> EvaluationReport)
-> Either
     (TransactionValidityError Era)
     (Map
        ScriptWitnessIndex
        (Either
           ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
-> Either (TransactionValidityError Era) EvaluationReport
forall a b.
(a -> b)
-> Either (TransactionValidityError Era) a
-> Either (TransactionValidityError Era) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map
    ScriptWitnessIndex
    (Either
       ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
  -> EvaluationReport)
 -> Either
      (TransactionValidityError Era)
      (Map
         ScriptWitnessIndex
         (Either
            ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
 -> Either (TransactionValidityError Era) EvaluationReport)
-> (((EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits)
    -> Map
         ScriptWitnessIndex
         (Either
            ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
    -> EvaluationReport)
-> ((EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits)
-> Either
     (TransactionValidityError Era)
     (Map
        ScriptWitnessIndex
        (Either
           ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
-> Either (TransactionValidityError Era) EvaluationReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either
   ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
 -> Either ScriptExecutionError ExecutionUnits)
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> EvaluationReport
forall a b.
(a -> b) -> Map ScriptWitnessIndex a -> Map ScriptWitnessIndex b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either
    ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
  -> Either ScriptExecutionError ExecutionUnits)
 -> Map
      ScriptWitnessIndex
      (Either
         ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
 -> EvaluationReport)
-> (((EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits)
    -> Either
         ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
    -> Either ScriptExecutionError ExecutionUnits)
-> ((EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits)
-> Map
     ScriptWitnessIndex
     (Either
        ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits))
-> EvaluationReport
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits)
-> Either
     ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)
-> Either ScriptExecutionError ExecutionUnits
forall a b.
(a -> b)
-> Either ScriptExecutionError a -> Either ScriptExecutionError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (EvalTxExecutionUnitsLog, ExecutionUnits) -> ExecutionUnits
forall a b. (a, b) -> b
snd (Either
   (TransactionValidityError Era)
   (Map
      ScriptWitnessIndex
      (Either
         ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
 -> Either (TransactionValidityError Era) EvaluationReport)
-> Either
     (TransactionValidityError Era)
     (Map
        ScriptWitnessIndex
        (Either
           ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
-> Either (TransactionValidityError Era) EvaluationReport
forall a b. (a -> b) -> a -> b
$
      CardanoEra Era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters Era
-> UTxO Era
-> TxBody Era
-> Either
     (TransactionValidityError Era)
     (Map
        ScriptWitnessIndex
        (Either
           ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
forall era.
CardanoEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> UTxO era
-> TxBody era
-> Either
     (TransactionValidityError era)
     (Map
        ScriptWitnessIndex
        (Either
           ScriptExecutionError (EvalTxExecutionUnitsLog, ExecutionUnits)))
evaluateTransactionExecutionUnits
        CardanoEra Era
forall era. IsCardanoEra era => CardanoEra era
cardanoEra
        SystemStart
systemStart
        (EpochInfo (Either Text) -> LedgerEpochInfo
LedgerEpochInfo EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
epochInfo)
        LedgerProtocolParameters Era
pparams'
        (UTxO -> UTxO Era
UTxO.toApi UTxO
utxo)
        (Tx -> TxBody Era
forall era. Tx era -> TxBody era
getTxBody Tx
tx)

-- | Check the budget used by provided 'EvaluationReport' does not exceed given
-- maximum 'ExecutionUnits'.
checkBudget :: ExecutionUnits -> EvaluationReport -> Either EvaluationError EvaluationReport
checkBudget :: ExecutionUnits
-> EvaluationReport -> Either EvaluationError EvaluationReport
checkBudget ExecutionUnits
maxUnits EvaluationReport
report
  | Natural
usedMemory Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= ExecutionUnits -> Natural
executionMemory ExecutionUnits
maxUnits Bool -> Bool -> Bool
&& Natural
usedCpu Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
<= ExecutionUnits -> Natural
executionSteps ExecutionUnits
maxUnits =
      EvaluationReport -> Either EvaluationError EvaluationReport
forall a b. b -> Either a b
Right EvaluationReport
report
  | Bool
otherwise =
      EvaluationError -> Either EvaluationError EvaluationReport
forall a b. a -> Either a b
Left
        TransactionBudgetOverspent
          { ExecutionUnits
used :: ExecutionUnits
$sel:used:TransactionBudgetOverspent :: ExecutionUnits
used
          , $sel:available:TransactionBudgetOverspent :: ExecutionUnits
available = ExecutionUnits
maxUnits
          }
 where
  used :: ExecutionUnits
used@ExecutionUnits
    { executionMemory :: ExecutionUnits -> Natural
executionMemory = Natural
usedMemory
    , executionSteps :: ExecutionUnits -> Natural
executionSteps = Natural
usedCpu
    } = EvaluationReport -> ExecutionUnits
usedExecutionUnits EvaluationReport
report

-- | Errors returned by 'evaluateTx' extending the upstream
-- 'TransactionValidityError' with additional cases.
data EvaluationError
  = TransactionBudgetOverspent {EvaluationError -> ExecutionUnits
used :: ExecutionUnits, EvaluationError -> ExecutionUnits
available :: ExecutionUnits}
  | TransactionInvalid (TransactionValidityError Era)
  | PParamsConversion ProtocolParametersConversionError
  deriving stock (Int -> EvaluationError -> ShowS
[EvaluationError] -> ShowS
EvaluationError -> String
(Int -> EvaluationError -> ShowS)
-> (EvaluationError -> String)
-> ([EvaluationError] -> ShowS)
-> Show EvaluationError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EvaluationError -> ShowS
showsPrec :: Int -> EvaluationError -> ShowS
$cshow :: EvaluationError -> String
show :: EvaluationError -> String
$cshowList :: [EvaluationError] -> ShowS
showList :: [EvaluationError] -> ShowS
Show)

-- | Evaluation result for each of the included scripts. Either they failed
-- evaluation or used a number of 'ExecutionUnits'.
type EvaluationReport =
  (Map ScriptWitnessIndex (Either ScriptExecutionError ExecutionUnits))

renderEvaluationReportFailures :: EvaluationReport -> Text
renderEvaluationReportFailures :: EvaluationReport -> Text
renderEvaluationReportFailures EvaluationReport
reportMap =
  EvalTxExecutionUnitsLog -> Text
forall t. IsText t "unlines" => [t] -> t
unlines (EvalTxExecutionUnitsLog -> Text)
-> EvalTxExecutionUnitsLog -> Text
forall a b. (a -> b) -> a -> b
$ ScriptExecutionError -> Text
renderScriptExecutionError (ScriptExecutionError -> Text)
-> [ScriptExecutionError] -> EvalTxExecutionUnitsLog
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ScriptExecutionError]
failures
 where
  failures :: [ScriptExecutionError]
failures = [Either ScriptExecutionError ExecutionUnits]
-> [ScriptExecutionError]
forall a b. [Either a b] -> [a]
lefts ([Either ScriptExecutionError ExecutionUnits]
 -> [ScriptExecutionError])
-> [Either ScriptExecutionError ExecutionUnits]
-> [ScriptExecutionError]
forall a b. (a -> b) -> a -> b
$ (Either ScriptExecutionError ExecutionUnits
 -> [Either ScriptExecutionError ExecutionUnits])
-> EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall m a. Monoid m => (a -> m) -> Map ScriptWitnessIndex a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Either ScriptExecutionError ExecutionUnits
-> [Either ScriptExecutionError ExecutionUnits]
-> [Either ScriptExecutionError ExecutionUnits]
forall a. a -> [a] -> [a]
: []) EvaluationReport
reportMap

  renderScriptExecutionError :: ScriptExecutionError -> Text
renderScriptExecutionError = \case
    ScriptErrorMissingScript ScriptWitnessIndex
missingRdmrPtr ResolvablePointers
_ ->
      Text
"Missing script of redeemer pointer " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ScriptWitnessIndex -> Text
forall b a. (Show a, IsString b) => a -> b
show ScriptWitnessIndex
missingRdmrPtr
    ScriptExecutionError
f ->
      ScriptExecutionError -> Text
forall b a. (Show a, IsString b) => a -> b
show ScriptExecutionError
f

-- | Get the total used 'ExecutionUnits' from an 'EvaluationReport'. Useful to
-- further process the result of 'evaluateTx'.
usedExecutionUnits :: EvaluationReport -> ExecutionUnits
usedExecutionUnits :: EvaluationReport -> ExecutionUnits
usedExecutionUnits EvaluationReport
report =
  ExecutionUnits
    { executionMemory :: Natural
executionMemory = Natural
usedMemory
    , executionSteps :: Natural
executionSteps = Natural
usedCpu
    }
 where
  usedMemory :: Natural
usedMemory = [Natural] -> Natural
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ ExecutionUnits -> Natural
executionMemory (ExecutionUnits -> Natural) -> [ExecutionUnits] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExecutionUnits]
budgets

  usedCpu :: Natural
usedCpu = [Natural] -> Natural
forall a (f :: * -> *). (Foldable f, Num a) => f a -> a
sum ([Natural] -> Natural) -> [Natural] -> Natural
forall a b. (a -> b) -> a -> b
$ ExecutionUnits -> Natural
executionSteps (ExecutionUnits -> Natural) -> [ExecutionUnits] -> [Natural]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ExecutionUnits]
budgets

  budgets :: [ExecutionUnits]
budgets = [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. [Either a b] -> [b]
rights ([Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits])
-> [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall a. Map ScriptWitnessIndex a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList EvaluationReport
report

-- | Estimate minimum fee for given transaction and evaluated redeemers. Instead
-- of using the budgets from the transaction (which are usually set to 0 until
-- balancing), this directly computes the fee from transaction size and the
-- units of the 'EvaluationReport'. Note that this function only provides a
-- rough estimate using this modules' 'pparams' and likely under-estimates cost
-- as we have no witnesses on this 'Tx'.
estimateMinFee ::
  Tx ->
  EvaluationReport ->
  Coin
estimateMinFee :: Tx -> EvaluationReport -> Coin
estimateMinFee Tx
tx EvaluationReport
evaluationReport =
  (Int
txSize Int -> Coin -> Coin
forall i. Integral i => i -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> Coin
a Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
b)
    Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Prices -> ExUnits -> Coin
txscriptfee Prices
prices ExUnits
allExunits
 where
  txSize :: Int
txSize = ByteString -> Int
BS.length (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ Tx -> ByteString
forall a. SerialiseAsCBOR a => a -> ByteString
serialiseToCBOR Tx
tx
  a :: Coin
a = PParams LedgerEra
PParams StandardConway
pparams PParams StandardConway
-> Getting Coin (PParams StandardConway) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams StandardConway) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams StandardConway) Coin
ppMinFeeAL
  b :: Coin
b = PParams LedgerEra
PParams StandardConway
pparams PParams StandardConway
-> Getting Coin (PParams StandardConway) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams StandardConway) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams StandardConway) Coin
ppMinFeeBL
  prices :: Prices
prices = PParams LedgerEra
PParams StandardConway
pparams PParams StandardConway
-> Getting Prices (PParams StandardConway) Prices -> Prices
forall s a. s -> Getting a s a -> a
^. Getting Prices (PParams StandardConway) Prices
forall era. AlonzoEraPParams era => Lens' (PParams era) Prices
Lens' (PParams StandardConway) Prices
ppPricesL
  allExunits :: ExUnits
allExunits = (ExecutionUnits -> ExUnits) -> [ExecutionUnits] -> ExUnits
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ExecutionUnits -> ExUnits
toLedgerExUnits ([ExecutionUnits] -> ExUnits)
-> ([Either ScriptExecutionError ExecutionUnits]
    -> [ExecutionUnits])
-> [Either ScriptExecutionError ExecutionUnits]
-> ExUnits
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either ScriptExecutionError ExecutionUnits] -> [ExecutionUnits]
forall a b. [Either a b] -> [b]
rights ([Either ScriptExecutionError ExecutionUnits] -> ExUnits)
-> [Either ScriptExecutionError ExecutionUnits] -> ExUnits
forall a b. (a -> b) -> a -> b
$ EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall a. Map ScriptWitnessIndex a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList EvaluationReport
evaluationReport

-- * Profile transactions

-- | Like 'evaluateTx', but instead of actual evaluation, return the
-- flat-encoded, fully applied scripts for each redeemer to be evaluated
-- externally by 'uplc'. Use input format "flat-namedDeBruijn". This can be used
-- to gather profiling information.
--
-- NOTE: This assumes we use 'Babbage' and only 'PlutusV2' scripts are used.
prepareTxScripts ::
  Tx ->
  UTxO ->
  Either String [ByteString]
prepareTxScripts :: Tx -> UTxO -> Either String [ByteString]
prepareTxScripts Tx
tx UTxO
utxo = do
  -- Tuples with scripts and their arguments collected from the tx
  [PlutusWithContext StandardCrypto]
results <-
    case EpochInfo (Either Text)
-> SystemStart
-> PParams StandardConway
-> Tx StandardConway
-> UTxO StandardConway
-> Either
     [CollectError StandardConway]
     [PlutusWithContext (EraCrypto StandardConway)]
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 (EraCrypto era)]
collectPlutusScriptsWithContext EpochInfo (Either Text)
forall (m :: * -> *). Monad m => EpochInfo m
epochInfo SystemStart
systemStart PParams LedgerEra
PParams StandardConway
pparams Tx LedgerEra
Tx StandardConway
ltx UTxO LedgerEra
UTxO StandardConway
lutxo of
      Left [CollectError StandardConway]
e -> String -> Either String [PlutusWithContext StandardCrypto]
forall a b. a -> Either a b
Left (String -> Either String [PlutusWithContext StandardCrypto])
-> String -> Either String [PlutusWithContext StandardCrypto]
forall a b. (a -> b) -> a -> b
$ [CollectError StandardConway] -> String
forall b a. (Show a, IsString b) => a -> b
show [CollectError StandardConway]
e
      Right [PlutusWithContext (EraCrypto StandardConway)]
x -> [PlutusWithContext StandardCrypto]
-> Either String [PlutusWithContext StandardCrypto]
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PlutusWithContext StandardCrypto]
[PlutusWithContext (EraCrypto StandardConway)]
x

  -- Fully applied UPLC programs which we could run using the cekMachine
  [Program NamedDeBruijn DefaultUni DefaultFun ()]
programs <- [PlutusWithContext StandardCrypto]
-> (PlutusWithContext StandardCrypto
    -> Either String (Program NamedDeBruijn DefaultUni DefaultFun ()))
-> Either String [Program NamedDeBruijn DefaultUni DefaultFun ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [PlutusWithContext StandardCrypto]
results ((PlutusWithContext StandardCrypto
  -> Either String (Program NamedDeBruijn DefaultUni DefaultFun ()))
 -> Either String [Program NamedDeBruijn DefaultUni DefaultFun ()])
-> (PlutusWithContext StandardCrypto
    -> Either String (Program NamedDeBruijn DefaultUni DefaultFun ()))
-> Either String [Program NamedDeBruijn DefaultUni DefaultFun ()]
forall a b. (a -> b) -> a -> b
$ \(PlutusWithContext Version
protocolVersion Either (Plutus l) (PlutusRunnable l)
script ScriptHash StandardCrypto
_ (PlutusArgs l
arguments :: PlutusArgs l) ExUnits
_exUnits CostModel
_costModel) -> do
    (PlutusRunnable ScriptForEvaluation
rs) <-
      case Either (Plutus l) (PlutusRunnable l)
script of
        Right PlutusRunnable l
runnable -> PlutusRunnable l -> Either String (PlutusRunnable l)
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PlutusRunnable l
runnable
        Left Plutus l
serialised -> (ScriptDecodeError -> String)
-> Either ScriptDecodeError (PlutusRunnable l)
-> Either String (PlutusRunnable l)
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ScriptDecodeError -> String
forall b a. (Show a, IsString b) => a -> b
show (Either ScriptDecodeError (PlutusRunnable l)
 -> Either String (PlutusRunnable l))
-> Either ScriptDecodeError (PlutusRunnable l)
-> Either String (PlutusRunnable l)
forall a b. (a -> b) -> a -> b
$ Version -> Plutus l -> Either ScriptDecodeError (PlutusRunnable l)
forall (l :: Language).
PlutusLanguage l =>
Version -> Plutus l -> Either ScriptDecodeError (PlutusRunnable l)
decodePlutusRunnable Version
protocolVersion Plutus l
serialised
    -- TODO: replace with mkTermToEvaluate from PlutusLanguage type class once available
    let majorProtocolVersion :: MajorProtocolVersion
majorProtocolVersion = Int -> MajorProtocolVersion
Plutus.MajorProtocolVersion (Int -> MajorProtocolVersion) -> Int -> MajorProtocolVersion
forall a b. (a -> b) -> a -> b
$ Version -> Int
forall i. Integral i => Version -> i
getVersion Version
protocolVersion
        args :: [Data]
args =
          case forall (l :: Language). PlutusLanguage l => SLanguage l
isLanguage @l of
            SLanguage l
SPlutusV2 -> case PlutusArgs 'PlutusV2 -> LegacyPlutusArgs 'PlutusV2
unPlutusV2Args PlutusArgs l
PlutusArgs 'PlutusV2
arguments of
              LegacyPlutusArgs2 Data
redeemer PlutusScriptContext 'PlutusV2
scriptContext -> [Data
redeemer, ScriptContext -> Data
forall a. ToData a => a -> Data
toData PlutusScriptContext 'PlutusV2
ScriptContext
scriptContext]
              LegacyPlutusArgs 'PlutusV2
_ -> Text -> [Data]
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unexpeted args"
            SLanguage l
_ -> Text -> [Data]
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"unsupported language"
    Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm <- (EvaluationError -> String)
-> Either
     EvaluationError (Term NamedDeBruijn DefaultUni DefaultFun ())
-> Either String (Term NamedDeBruijn DefaultUni DefaultFun ())
forall b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left EvaluationError -> String
forall b a. (Show a, IsString b) => a -> b
show (Either
   EvaluationError (Term NamedDeBruijn DefaultUni DefaultFun ())
 -> Either String (Term NamedDeBruijn DefaultUni DefaultFun ()))
-> Either
     EvaluationError (Term NamedDeBruijn DefaultUni DefaultFun ())
-> Either String (Term NamedDeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ PlutusLedgerLanguage
-> MajorProtocolVersion
-> ScriptForEvaluation
-> [Data]
-> Either
     EvaluationError (Term NamedDeBruijn DefaultUni DefaultFun ())
forall (m :: * -> *).
MonadError EvaluationError m =>
PlutusLedgerLanguage
-> MajorProtocolVersion
-> ScriptForEvaluation
-> [Data]
-> m (Term NamedDeBruijn DefaultUni DefaultFun ())
mkTermToEvaluate PlutusLedgerLanguage
Plutus.PlutusV2 MajorProtocolVersion
majorProtocolVersion ScriptForEvaluation
rs [Data]
args
    Program NamedDeBruijn DefaultUni DefaultFun ()
-> Either String (Program NamedDeBruijn DefaultUni DefaultFun ())
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Program NamedDeBruijn DefaultUni DefaultFun ()
 -> Either String (Program NamedDeBruijn DefaultUni DefaultFun ()))
-> Program NamedDeBruijn DefaultUni DefaultFun ()
-> Either String (Program NamedDeBruijn DefaultUni DefaultFun ())
forall a b. (a -> b) -> a -> b
$ ()
-> Version
-> Term NamedDeBruijn DefaultUni DefaultFun ()
-> Program NamedDeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
ann -> Version -> Term name uni fun ann -> Program name uni fun ann
UPLC.Program () Version
PLC.latestVersion Term NamedDeBruijn DefaultUni DefaultFun ()
appliedTerm

  [ByteString] -> Either String [ByteString]
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([ByteString] -> Either String [ByteString])
-> [ByteString] -> Either String [ByteString]
forall a b. (a -> b) -> a -> b
$ UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun ()
-> ByteString
forall a. Flat a => a -> ByteString
flat (UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun ()
 -> ByteString)
-> (Program NamedDeBruijn DefaultUni DefaultFun ()
    -> UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun ())
-> Program NamedDeBruijn DefaultUni DefaultFun ()
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program NamedDeBruijn DefaultUni DefaultFun ()
-> UnrestrictedProgram NamedDeBruijn DefaultUni DefaultFun ()
forall name (uni :: * -> *) fun ann.
Program name uni fun ann -> UnrestrictedProgram name uni fun ann
UnrestrictedProgram (Program NamedDeBruijn DefaultUni DefaultFun () -> ByteString)
-> [Program NamedDeBruijn DefaultUni DefaultFun ()] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Program NamedDeBruijn DefaultUni DefaultFun ()]
programs
 where
  ltx :: Tx LedgerEra
ltx = Tx -> Tx LedgerEra
forall era. Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx

  lutxo :: UTxO LedgerEra
lutxo = UTxO -> UTxO LedgerEra
toLedgerUTxO UTxO
utxo

-- * Fixtures

-- | Current (2023-04-12) mainchain protocol parameters.
-- XXX: Avoid specifiying not required parameters here (e.g. max block units
-- should not matter).
-- XXX: Load and use mainnet parameters from a file which we can easily review
-- to be in sync with mainnet.
pparams :: PParams LedgerEra
pparams :: PParams LedgerEra
pparams =
  PParams StandardConway
forall a. Default a => a
def
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (Word32 -> Identity Word32)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams StandardConway) Word32
ppMaxTxSizeL ((Word32 -> Identity Word32)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> Word32 -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
maxTxSize
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (Natural -> Identity Natural)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
Lens' (PParams StandardConway) Natural
ppMaxValSizeL ((Natural -> Identity Natural)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> Natural -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
1000000000
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams StandardConway) Coin
ppMinFeeAL ((Coin -> Identity Coin)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> Coin -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
44
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams StandardConway) Coin
ppMinFeeBL ((Coin -> Identity Coin)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> Coin -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
155381
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (CoinPerByte -> Identity CoinPerByte)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era.
BabbageEraPParams era =>
Lens' (PParams era) CoinPerByte
Lens' (PParams StandardConway) CoinPerByte
ppCoinsPerUTxOByteL ((CoinPerByte -> Identity CoinPerByte)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> CoinPerByte -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> CoinPerByte
CoinPerByte (Integer -> Coin
Coin Integer
4310)
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams StandardConway) ExUnits
ppMaxTxExUnitsL ((ExUnits -> Identity ExUnits)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> ExUnits -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ExecutionUnits -> ExUnits
toLedgerExUnits ExecutionUnits
maxTxExecutionUnits
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams StandardConway) ExUnits
ppMaxBlockExUnitsL
      ((ExUnits -> Identity ExUnits)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> ExUnits -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ExecutionUnits -> ExUnits
toLedgerExUnits
        ExecutionUnits
          { executionMemory :: Natural
executionMemory = Natural
62_000_000
          , executionSteps :: Natural
executionSteps = Natural
40_000_000_000
          }
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (Prices -> Identity Prices)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. AlonzoEraPParams era => Lens' (PParams era) Prices
Lens' (PParams StandardConway) Prices
ppPricesL
      ((Prices -> Identity Prices)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> Prices -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Prices
        { prSteps :: NonNegativeInterval
prSteps = Maybe NonNegativeInterval -> NonNegativeInterval
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe NonNegativeInterval -> NonNegativeInterval)
-> Maybe NonNegativeInterval -> NonNegativeInterval
forall a b. (a -> b) -> a -> b
$ Rational -> Maybe NonNegativeInterval
forall r. BoundedRational r => Rational -> Maybe r
boundRational (Rational -> Maybe NonNegativeInterval)
-> Rational -> Maybe NonNegativeInterval
forall a b. (a -> b) -> a -> b
$ Integer
721 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10000000
        , prMem :: NonNegativeInterval
prMem = Maybe NonNegativeInterval -> NonNegativeInterval
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe NonNegativeInterval -> NonNegativeInterval)
-> Maybe NonNegativeInterval -> NonNegativeInterval
forall a b. (a -> b) -> a -> b
$ Rational -> Maybe NonNegativeInterval
forall r. BoundedRational r => Rational -> Maybe r
boundRational (Rational -> Maybe NonNegativeInterval)
-> Rational -> Maybe NonNegativeInterval
forall a b. (a -> b) -> a -> b
$ Integer
577 Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
10000
        }
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (ProtVer -> Identity ProtVer)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams StandardConway) ProtVer
ppProtocolVersionL ((ProtVer -> Identity ProtVer)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> ProtVer -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer{pvMajor :: Version
pvMajor = forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @8, pvMinor :: Natural
pvMinor = Natural
0}
    PParams StandardConway
-> (PParams StandardConway -> PParams StandardConway)
-> PParams StandardConway
forall a b. a -> (a -> b) -> b
& (CostModels -> Identity CostModels)
-> PParams StandardConway -> Identity (PParams StandardConway)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams StandardConway) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
 -> PParams StandardConway -> Identity (PParams StandardConway))
-> CostModels -> PParams StandardConway -> PParams StandardConway
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map Language CostModel -> CostModels
mkCostModels ([(Language, CostModel)] -> Map Language CostModel
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Language
PlutusV2, CostModel
plutusV2CostModel)])

maxTxSize :: Natural
maxTxSize :: Natural
maxTxSize = Natural
16384

-- | Max transaction execution unit budget of the current 'pparams'.
maxTxExecutionUnits :: ExecutionUnits
maxTxExecutionUnits :: ExecutionUnits
maxTxExecutionUnits =
  ExecutionUnits
    { executionMemory :: Natural
executionMemory = Natural
14_000_000
    , executionSteps :: Natural
executionSteps = Natural
10_000_000_000
    }

-- | Max memory and cpu units of the current 'pparams'.
maxMem, maxCpu :: Natural
maxCpu :: Natural
maxCpu = ExecutionUnits -> Natural
executionSteps ExecutionUnits
maxTxExecutionUnits
maxMem :: Natural
maxMem = ExecutionUnits -> Natural
executionMemory ExecutionUnits
maxTxExecutionUnits

-- | An artifical 'EpochInfo' comprised by a single never ending (forking) era,
-- with fixed 'epochSize' and 'slotLength'.
epochInfo :: Monad m => EpochInfo m
epochInfo :: forall (m :: * -> *). Monad m => EpochInfo m
epochInfo = EpochSize -> SlotLength -> EpochInfo m
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo EpochSize
epochSize SlotLength
slotLength

-- | An era history with a single era which will end at some point.
--
-- A "real" 'EraHistory' received from the cardano-node will have the 'eraEnd'
-- at a known or earliest possible end of the current era + a safe zone.
--
-- See 'Ouroboros.Consensus.HardFork.History.EraParams' for details.
--
-- NOTE: This era is using not so realistic epoch sizes of 1 and sets a slot
-- length of 1
eraHistoryWithHorizonAt :: SlotNo -> EraHistory
eraHistoryWithHorizonAt :: SlotNo -> EraHistory
eraHistoryWithHorizonAt slotNo :: SlotNo
slotNo@(SlotNo Word64
n) =
  Interpreter (CardanoEras StandardCrypto) -> EraHistory
forall (xs :: [*]).
(CardanoBlock StandardCrypto ~ HardForkBlock xs) =>
Interpreter xs -> EraHistory
EraHistory (Summary (CardanoEras StandardCrypto)
-> Interpreter (CardanoEras StandardCrypto)
forall (xs :: [*]). Summary xs -> Interpreter xs
mkInterpreter Summary (CardanoEras StandardCrypto)
summary)
 where
  summary :: Summary (CardanoEras StandardCrypto)
  summary :: Summary (CardanoEras StandardCrypto)
summary =
    NonEmpty (CardanoEras StandardCrypto) EraSummary
-> Summary (CardanoEras StandardCrypto)
forall (xs :: [*]). NonEmpty xs EraSummary -> Summary xs
Summary (NonEmpty (CardanoEras StandardCrypto) EraSummary
 -> Summary (CardanoEras StandardCrypto))
-> (EraSummary -> NonEmpty (CardanoEras StandardCrypto) EraSummary)
-> EraSummary
-> Summary (CardanoEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraSummary -> NonEmpty (CardanoEras StandardCrypto) EraSummary
forall a x (xs1 :: [*]). a -> NonEmpty (x : xs1) a
NonEmptyOne (EraSummary -> Summary (CardanoEras StandardCrypto))
-> EraSummary -> Summary (CardanoEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$
      EraSummary
        { eraStart :: Bound
eraStart = Bound
initBound
        , eraEnd :: EraEnd
eraEnd =
            Bound -> EraEnd
EraEnd (Bound -> EraEnd) -> Bound -> EraEnd
forall a b. (a -> b) -> a -> b
$
              Bound
                { boundTime :: RelativeTime
boundTime = POSIXTime -> RelativeTime
RelativeTime (POSIXTime -> RelativeTime) -> POSIXTime -> RelativeTime
forall a b. (a -> b) -> a -> b
$ Word64 -> POSIXTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n
                , boundSlot :: SlotNo
boundSlot = SlotNo
slotNo
                , boundEpoch :: EpochNo
boundEpoch = Word64 -> EpochNo
EpochNo Word64
n
                }
        , EraParams
eraParams :: EraParams
eraParams :: EraParams
eraParams
        }

  eraParams :: EraParams
eraParams =
    EraParams
      { eraEpochSize :: EpochSize
eraEpochSize = Word64 -> EpochSize
EpochSize Word64
1
      , eraSlotLength :: SlotLength
eraSlotLength = POSIXTime -> SlotLength
mkSlotLength POSIXTime
1
      , -- NOTE: unused if the 'eraEnd' is already defined, but would be used to
        -- extend the last era accordingly in the real cardano-node
        eraSafeZone :: SafeZone
eraSafeZone = SafeZone
UnsafeIndefiniteSafeZone
      , eraGenesisWin :: GenesisWindow
eraGenesisWin = Word64 -> GenesisWindow
GenesisWindow Word64
1
      }

eraHistoryWithoutHorizon :: EraHistory
eraHistoryWithoutHorizon :: EraHistory
eraHistoryWithoutHorizon =
  Interpreter (CardanoEras StandardCrypto) -> EraHistory
forall (xs :: [*]).
(CardanoBlock StandardCrypto ~ HardForkBlock xs) =>
Interpreter xs -> EraHistory
EraHistory (Summary (CardanoEras StandardCrypto)
-> Interpreter (CardanoEras StandardCrypto)
forall (xs :: [*]). Summary xs -> Interpreter xs
mkInterpreter Summary (CardanoEras StandardCrypto)
summary)
 where
  summary :: Summary (CardanoEras StandardCrypto)
  summary :: Summary (CardanoEras StandardCrypto)
summary =
    NonEmpty (CardanoEras StandardCrypto) EraSummary
-> Summary (CardanoEras StandardCrypto)
forall (xs :: [*]). NonEmpty xs EraSummary -> Summary xs
Summary (NonEmpty (CardanoEras StandardCrypto) EraSummary
 -> Summary (CardanoEras StandardCrypto))
-> (EraSummary -> NonEmpty (CardanoEras StandardCrypto) EraSummary)
-> EraSummary
-> Summary (CardanoEras StandardCrypto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EraSummary -> NonEmpty (CardanoEras StandardCrypto) EraSummary
forall a x (xs1 :: [*]). a -> NonEmpty (x : xs1) a
NonEmptyOne (EraSummary -> Summary (CardanoEras StandardCrypto))
-> EraSummary -> Summary (CardanoEras StandardCrypto)
forall a b. (a -> b) -> a -> b
$
      EraSummary
        { eraStart :: Bound
eraStart = Bound
initBound
        , eraEnd :: EraEnd
eraEnd = EraEnd
EraUnbounded
        , EraParams
eraParams :: EraParams
eraParams :: EraParams
eraParams
        }

  eraParams :: EraParams
eraParams =
    EraParams
      { eraEpochSize :: EpochSize
eraEpochSize = Word64 -> EpochSize
EpochSize Word64
1
      , eraSlotLength :: SlotLength
eraSlotLength = POSIXTime -> SlotLength
mkSlotLength POSIXTime
1
      , -- NOTE: unused if the 'eraEnd' is already defined, but would be used to
        -- extend the last era accordingly in the real cardano-node
        eraSafeZone :: SafeZone
eraSafeZone = SafeZone
UnsafeIndefiniteSafeZone
      , eraGenesisWin :: GenesisWindow
eraGenesisWin = Word64 -> GenesisWindow
GenesisWindow Word64
1
      }

epochSize :: EpochSize
epochSize :: EpochSize
epochSize = Word64 -> EpochSize
EpochSize Word64
100

slotLength :: SlotLength
slotLength :: SlotLength
slotLength = POSIXTime -> SlotLength
mkSlotLength POSIXTime
1

systemStart :: SystemStart
systemStart :: SystemStart
systemStart = UTCTime -> SystemStart
SystemStart (UTCTime -> SystemStart) -> UTCTime -> SystemStart
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0

-- * Properties

-- | Expect a given 'Tx' and 'UTxO' to pass evaluation.
propTransactionEvaluates :: (Tx, UTxO) -> Property
propTransactionEvaluates :: (Tx, UTxO) -> Property
propTransactionEvaluates (Tx
tx, UTxO
lookupUTxO) =
  case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
lookupUTxO of
    Left EvaluationError
err ->
      Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
False
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Transaction: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Phase-1 validation failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EvaluationError -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationError
err)
    Right EvaluationReport
redeemerReport ->
      (Either ScriptExecutionError ExecutionUnits -> Bool)
-> [Either ScriptExecutionError ExecutionUnits] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isRight (EvaluationReport -> [Either ScriptExecutionError ExecutionUnits]
forall k a. Map k a -> [a]
Map.elems EvaluationReport
redeemerReport)
        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Transaction: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Phase-2 validation failed"

-- | Expect a given 'Tx' and 'UTxO' to fail phase 1 or phase 2 evaluation.
propTransactionFailsEvaluation :: (Tx, UTxO) -> Property
propTransactionFailsEvaluation :: (Tx, UTxO) -> Property
propTransactionFailsEvaluation (Tx
tx, UTxO
lookupUTxO) =
  case Tx -> UTxO -> Either EvaluationError EvaluationReport
evaluateTx Tx
tx UTxO
lookupUTxO of
    Left EvaluationError
_ -> Bool -> Property
forall prop. Testable prop => prop -> Property
property Bool
True
    Right EvaluationReport
redeemerReport ->
      (Either ScriptExecutionError ExecutionUnits -> Bool)
-> EvaluationReport -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Either ScriptExecutionError ExecutionUnits -> Bool
forall a b. Either a b -> Bool
isLeft EvaluationReport
redeemerReport
        Bool -> (Bool -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Bool -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Transaction: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> UTxO -> Tx -> String
renderTxWithUTxO UTxO
lookupUTxO Tx
tx)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample (String
"Redeemer report: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EvaluationReport -> String
forall b a. (Show a, IsString b) => a -> b
show EvaluationReport
redeemerReport)
        Property -> (Property -> Property) -> Property
forall a b. a -> (a -> b) -> b
& String -> Property -> Property
forall prop. Testable prop => String -> prop -> Property
counterexample String
"Phase-2 validation should have failed"

-- * Generators

genPointInTime :: Gen (SlotNo, UTCTime)
genPointInTime :: Gen (SlotNo, UTCTime)
genPointInTime = do
  SlotNo
slot <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary
  let time :: UTCTime
time = SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime SystemStart
systemStart SlotLength
slotLength SlotNo
slot
  (SlotNo, UTCTime) -> Gen (SlotNo, UTCTime)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
slot, UTCTime
time)

-- | Parameter here is the contestation period (cp) so we need to generate
-- start (tMin) and end (tMax) tx validity bound such that their difference
-- is not higher than the cp.
-- Returned slots are tx validity bounds
genValidityBoundsFromContestationPeriod :: ContestationPeriod -> Gen (SlotNo, (SlotNo, UTCTime))
genValidityBoundsFromContestationPeriod :: ContestationPeriod -> Gen (SlotNo, (SlotNo, UTCTime))
genValidityBoundsFromContestationPeriod (UnsafeContestationPeriod Natural
cpSeconds) = do
  startSlot :: SlotNo
startSlot@(SlotNo Word64
start) <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen Word64
forall a. Arbitrary a => Gen a
arbitrary
  let end :: Word64
end = Word64
start Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Natural -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
cpSeconds
  SlotNo
endSlot <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
chooseWord64 (Word64
start, Word64
end)
  let time :: UTCTime
time = SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime SystemStart
systemStart SlotLength
slotLength SlotNo
endSlot
  (SlotNo, (SlotNo, UTCTime)) -> Gen (SlotNo, (SlotNo, UTCTime))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
startSlot, (SlotNo
endSlot, UTCTime
time))

genPointInTimeBefore :: UTCTime -> Gen (SlotNo, UTCTime)
genPointInTimeBefore :: UTCTime -> Gen (SlotNo, UTCTime)
genPointInTimeBefore UTCTime
deadline = do
  let SlotNo Word64
slotDeadline = SystemStart -> SlotLength -> UTCTime -> SlotNo
slotNoFromUTCTime SystemStart
systemStart SlotLength
slotLength UTCTime
deadline
  SlotNo
slot <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
0, Word64
slotDeadline)
  (SlotNo, UTCTime) -> Gen (SlotNo, UTCTime)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
slot, SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime SystemStart
systemStart SlotLength
slotLength SlotNo
slot)

genPointInTimeAfter :: UTCTime -> Gen (SlotNo, UTCTime)
genPointInTimeAfter :: UTCTime -> Gen (SlotNo, UTCTime)
genPointInTimeAfter UTCTime
deadline = do
  let SlotNo Word64
slotDeadline = SystemStart -> SlotLength -> UTCTime -> SlotNo
slotNoFromUTCTime SystemStart
systemStart SlotLength
slotLength UTCTime
deadline
  SlotNo
slot <- Word64 -> SlotNo
SlotNo (Word64 -> SlotNo) -> Gen Word64 -> Gen SlotNo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word64, Word64) -> Gen Word64
forall a. Random a => (a, a) -> Gen a
choose (Word64
slotDeadline, Word64
forall a. Bounded a => a
maxBound)
  (SlotNo, UTCTime) -> Gen (SlotNo, UTCTime)
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SlotNo
slot, SystemStart -> SlotLength -> SlotNo -> UTCTime
slotNoToUTCTime SystemStart
systemStart SlotLength
slotLength SlotNo
slot)

-- ** Plutus cost model fixtures

-- | Current (2023-08-04) mainnet PlutusV2 cost model.
plutusV2CostModel :: CostModel
plutusV2CostModel :: CostModel
plutusV2CostModel =
  (CostModelApplyError -> CostModel)
-> (CostModel -> CostModel)
-> Either CostModelApplyError CostModel
-> CostModel
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Text -> CostModel
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> CostModel)
-> (CostModelApplyError -> Text)
-> CostModelApplyError
-> CostModel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CostModelApplyError -> Text
forall b a. (Show a, IsString b) => a -> b
show) CostModel -> CostModel
forall a. a -> a
id (Either CostModelApplyError CostModel -> CostModel)
-> Either CostModelApplyError CostModel -> CostModel
forall a b. (a -> b) -> a -> b
$
    Language -> [Int64] -> Either CostModelApplyError CostModel
mkCostModel
      Language
PlutusV2
      [ Int64
205665
      , Int64
812
      , Int64
1
      , Int64
1
      , Int64
1000
      , Int64
571
      , Int64
0
      , Int64
1
      , Int64
1000
      , Int64
24177
      , Int64
4
      , Int64
1
      , Int64
1000
      , Int64
32
      , Int64
117366
      , Int64
10475
      , Int64
4
      , Int64
23000
      , Int64
100
      , Int64
23000
      , Int64
100
      , Int64
23000
      , Int64
100
      , Int64
23000
      , Int64
100
      , Int64
23000
      , Int64
100
      , Int64
23000
      , Int64
100
      , Int64
100
      , Int64
100
      , Int64
23000
      , Int64
100
      , Int64
19537
      , Int64
32
      , Int64
175354
      , Int64
32
      , Int64
46417
      , Int64
4
      , Int64
221973
      , Int64
511
      , Int64
0
      , Int64
1
      , Int64
89141
      , Int64
32
      , Int64
497525
      , Int64
14068
      , Int64
4
      , Int64
2
      , Int64
196500
      , Int64
453240
      , Int64
220
      , Int64
0
      , Int64
1
      , Int64
1
      , Int64
1000
      , Int64
28662
      , Int64
4
      , Int64
2
      , Int64
245000
      , Int64
216773
      , Int64
62
      , Int64
1
      , Int64
1060367
      , Int64
12586
      , Int64
1
      , Int64
208512
      , Int64
421
      , Int64
1
      , Int64
187000
      , Int64
1000
      , Int64
52998
      , Int64
1
      , Int64
80436
      , Int64
32
      , Int64
43249
      , Int64
32
      , Int64
1000
      , Int64
32
      , Int64
80556
      , Int64
1
      , Int64
57667
      , Int64
4
      , Int64
1000
      , Int64
10
      , Int64
197145
      , Int64
156
      , Int64
1
      , Int64
197145
      , Int64
156
      , Int64
1
      , Int64
204924
      , Int64
473
      , Int64
1
      , Int64
208896
      , Int64
511
      , Int64
1
      , Int64
52467
      , Int64
32
      , Int64
64832
      , Int64
32
      , Int64
65493
      , Int64
32
      , Int64
22558
      , Int64
32
      , Int64
16563
      , Int64
32
      , Int64
76511
      , Int64
32
      , Int64
196500
      , Int64
453240
      , Int64
220
      , Int64
0
      , Int64
1
      , Int64
1
      , Int64
69522
      , Int64
11687
      , Int64
0
      , Int64
1
      , Int64
60091
      , Int64
32
      , Int64
196500
      , Int64
453240
      , Int64
220
      , Int64
0
      , Int64
1
      , Int64
1
      , Int64
196500
      , Int64
453240
      , Int64
220
      , Int64
0
      , Int64
1
      , Int64
1
      , Int64
1159724
      , Int64
392670
      , Int64
0
      , Int64
2
      , Int64
806990
      , Int64
30482
      , Int64
4
      , Int64
1927926
      , Int64
82523
      , Int64
4
      , Int64
265318
      , Int64
0
      , Int64
4
      , Int64
0
      , Int64
85931
      , Int64
32
      , Int64
205665
      , Int64
812
      , Int64
1
      , Int64
1
      , Int64
41182
      , Int64
32
      , Int64
212342
      , Int64
32
      , Int64
31220
      , Int64
32
      , Int64
32696
      , Int64
32
      , Int64
43357
      , Int64
32
      , Int64
32247
      , Int64
32
      , Int64
38314
      , Int64
32
      , Int64
35892428
      , Int64
10
      , Int64
57996947
      , Int64
18975
      , Int64
10
      , Int64
38887044
      , Int64
32947
      , Int64
10
      ]