-- | 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 (..), natVersion)
import Cardano.Ledger.Binary (getVersion)
import Cardano.Ledger.Coin (Coin (Coin))
import Cardano.Ledger.Core (PParams, ppMaxTxSizeL)
import Cardano.Ledger.Plutus (PlutusDatums (unPlutusDatums), PlutusLanguage (decodePlutusRunnable), PlutusRunnable (..), PlutusWithContext (..))
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.ContestationPeriod (ContestationPeriod (UnsafeContestationPeriod))
import Hydra.Ledger.Cardano.Time (slotNoFromUTCTime, slotNoToUTCTime)
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)
import PlutusLedgerApi.Common qualified as Plutus
import Test.QuickCheck (choose)
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 StandardBabbage
pparams' = PParams (ShelleyLedgerEra Era)
PParams StandardBabbage
pparams PParams StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams StandardBabbage) ExUnits
ppMaxTxExUnitsL ((ExUnits -> Identity ExUnits)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> ExUnits -> PParams StandardBabbage -> PParams StandardBabbage
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 (ShelleyLedgerEra Era) -> LedgerProtocolParameters Era
forall era.
PParams (ShelleyLedgerEra era) -> LedgerProtocolParameters era
LedgerProtocolParameters PParams (ShelleyLedgerEra Era)
PParams StandardBabbage
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 Era
-> Either (TransactionValidityError Era) EvaluationReport
result LedgerProtocolParameters Era
pparams' =
    CardanoEra Era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters Era
-> UTxO Era
-> TxBody Era
-> Either (TransactionValidityError Era) EvaluationReport
forall era.
CardanoEra era
-> SystemStart
-> LedgerEpochInfo
-> LedgerProtocolParameters era
-> UTxO era
-> TxBody era
-> Either (TransactionValidityError era) EvaluationReport
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 =
  [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ScriptExecutionError -> Text
renderScriptExecutionError (ScriptExecutionError -> Text) -> [ScriptExecutionError] -> [Text]
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 (ShelleyLedgerEra Era)
PParams StandardBabbage
pparams PParams StandardBabbage
-> Getting Coin (PParams StandardBabbage) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams StandardBabbage) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams StandardBabbage) Coin
ppMinFeeAL
  b :: Coin
b = PParams (ShelleyLedgerEra Era)
PParams StandardBabbage
pparams PParams StandardBabbage
-> Getting Coin (PParams StandardBabbage) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams StandardBabbage) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams StandardBabbage) Coin
ppMinFeeBL
  prices :: Prices
prices = PParams (ShelleyLedgerEra Era)
PParams StandardBabbage
pparams PParams StandardBabbage
-> Getting Prices (PParams StandardBabbage) Prices -> Prices
forall s a. s -> Getting a s a -> a
^. Getting Prices (PParams StandardBabbage) Prices
forall era. AlonzoEraPParams era => Lens' (PParams era) Prices
Lens' (PParams StandardBabbage) 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]
results <-
    case EpochInfo (Either Text)
-> SystemStart
-> PParams StandardBabbage
-> Tx StandardBabbage
-> UTxO StandardBabbage
-> Either [CollectError StandardBabbage] [PlutusWithContext]
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)
forall (m :: * -> *). Monad m => EpochInfo m
epochInfo SystemStart
systemStart PParams (ShelleyLedgerEra Era)
PParams StandardBabbage
pparams Tx (ShelleyLedgerEra Era)
Tx StandardBabbage
ltx UTxO (ShelleyLedgerEra Era)
UTxO StandardBabbage
lutxo of
      Left [CollectError StandardBabbage]
e -> String -> Either String [PlutusWithContext]
forall a b. a -> Either a b
Left (String -> Either String [PlutusWithContext])
-> String -> Either String [PlutusWithContext]
forall a b. (a -> b) -> a -> b
$ [CollectError StandardBabbage] -> String
forall b a. (Show a, IsString b) => a -> b
show [CollectError StandardBabbage]
e
      Right [PlutusWithContext]
x -> [PlutusWithContext] -> Either String [PlutusWithContext]
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PlutusWithContext]
x

  -- Fully applied UPLC programs which we could run using the cekMachine
  [Program NamedDeBruijn DefaultUni DefaultFun ()]
programs <- [PlutusWithContext]
-> (PlutusWithContext
    -> 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]
results ((PlutusWithContext
  -> Either String (Program NamedDeBruijn DefaultUni DefaultFun ()))
 -> Either String [Program NamedDeBruijn DefaultUni DefaultFun ()])
-> (PlutusWithContext
    -> 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 PlutusDatums
arguments ExUnits
_exUnits CostModel
_costModel) -> do
    (PlutusRunnable ScriptForEvaluation
x) <-
      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
    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
    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
x (PlutusDatums -> [Data]
unPlutusDatums PlutusDatums
arguments)
    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 (ShelleyLedgerEra Era)
ltx = Tx -> Tx (ShelleyLedgerEra Era)
forall era.
(EraCrypto (ShelleyLedgerEra era) ~ StandardCrypto,
 AlonzoEraTx (ShelleyLedgerEra era)) =>
Tx era -> Tx (ShelleyLedgerEra era)
toLedgerTx Tx
tx

  lutxo :: UTxO (ShelleyLedgerEra Era)
lutxo = UTxO -> UTxO (ShelleyLedgerEra Era)
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 (ShelleyLedgerEra Era)
pparams =
  PParams StandardBabbage
forall a. Default a => a
def
    PParams StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (Word32 -> Identity Word32)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams StandardBabbage) Word32
ppMaxTxSizeL ((Word32 -> Identity Word32)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> Word32 -> PParams StandardBabbage -> PParams StandardBabbage
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 StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (Natural -> Identity Natural)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
Lens' (PParams StandardBabbage) Natural
ppMaxValSizeL ((Natural -> Identity Natural)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> Natural -> PParams StandardBabbage -> PParams StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
1000000000
    PParams StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams StandardBabbage) Coin
ppMinFeeAL ((Coin -> Identity Coin)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> Coin -> PParams StandardBabbage -> PParams StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
44
    PParams StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams StandardBabbage) Coin
ppMinFeeBL ((Coin -> Identity Coin)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> Coin -> PParams StandardBabbage -> PParams StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
155381
    PParams StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (CoinPerByte -> Identity CoinPerByte)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era.
BabbageEraPParams era =>
Lens' (PParams era) CoinPerByte
Lens' (PParams StandardBabbage) CoinPerByte
ppCoinsPerUTxOByteL ((CoinPerByte -> Identity CoinPerByte)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> CoinPerByte
-> PParams StandardBabbage
-> PParams StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> CoinPerByte
CoinPerByte (Integer -> Coin
Coin Integer
4310)
    PParams StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams StandardBabbage) ExUnits
ppMaxTxExUnitsL ((ExUnits -> Identity ExUnits)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> ExUnits -> PParams StandardBabbage -> PParams StandardBabbage
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ExecutionUnits -> ExUnits
toLedgerExUnits ExecutionUnits
maxTxExecutionUnits
    PParams StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (ExUnits -> Identity ExUnits)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
Lens' (PParams StandardBabbage) ExUnits
ppMaxBlockExUnitsL
      ((ExUnits -> Identity ExUnits)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> ExUnits -> PParams StandardBabbage -> PParams StandardBabbage
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 StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (Prices -> Identity Prices)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. AlonzoEraPParams era => Lens' (PParams era) Prices
Lens' (PParams StandardBabbage) Prices
ppPricesL
      ((Prices -> Identity Prices)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> Prices -> PParams StandardBabbage -> PParams StandardBabbage
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 StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (ProtVer -> Identity ProtVer)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams StandardBabbage) ProtVer
ppProtocolVersionL ((ProtVer -> Identity ProtVer)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> ProtVer -> PParams StandardBabbage -> PParams StandardBabbage
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 StandardBabbage
-> (PParams StandardBabbage -> PParams StandardBabbage)
-> PParams StandardBabbage
forall a b. a -> (a -> b) -> b
& (CostModels -> Identity CostModels)
-> PParams StandardBabbage -> Identity (PParams StandardBabbage)
forall era. AlonzoEraPParams era => Lens' (PParams era) CostModels
Lens' (PParams StandardBabbage) CostModels
ppCostModelsL ((CostModels -> Identity CostModels)
 -> PParams StandardBabbage -> Identity (PParams StandardBabbage))
-> CostModels -> PParams StandardBabbage -> PParams StandardBabbage
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
      }

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
      }

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

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 -> [Integer] -> Either CostModelApplyError CostModel
mkCostModel
      Language
PlutusV2
      [ Integer
205665
      , Integer
812
      , Integer
1
      , Integer
1
      , Integer
1000
      , Integer
571
      , Integer
0
      , Integer
1
      , Integer
1000
      , Integer
24177
      , Integer
4
      , Integer
1
      , Integer
1000
      , Integer
32
      , Integer
117366
      , Integer
10475
      , Integer
4
      , Integer
23000
      , Integer
100
      , Integer
23000
      , Integer
100
      , Integer
23000
      , Integer
100
      , Integer
23000
      , Integer
100
      , Integer
23000
      , Integer
100
      , Integer
23000
      , Integer
100
      , Integer
100
      , Integer
100
      , Integer
23000
      , Integer
100
      , Integer
19537
      , Integer
32
      , Integer
175354
      , Integer
32
      , Integer
46417
      , Integer
4
      , Integer
221973
      , Integer
511
      , Integer
0
      , Integer
1
      , Integer
89141
      , Integer
32
      , Integer
497525
      , Integer
14068
      , Integer
4
      , Integer
2
      , Integer
196500
      , Integer
453240
      , Integer
220
      , Integer
0
      , Integer
1
      , Integer
1
      , Integer
1000
      , Integer
28662
      , Integer
4
      , Integer
2
      , Integer
245000
      , Integer
216773
      , Integer
62
      , Integer
1
      , Integer
1060367
      , Integer
12586
      , Integer
1
      , Integer
208512
      , Integer
421
      , Integer
1
      , Integer
187000
      , Integer
1000
      , Integer
52998
      , Integer
1
      , Integer
80436
      , Integer
32
      , Integer
43249
      , Integer
32
      , Integer
1000
      , Integer
32
      , Integer
80556
      , Integer
1
      , Integer
57667
      , Integer
4
      , Integer
1000
      , Integer
10
      , Integer
197145
      , Integer
156
      , Integer
1
      , Integer
197145
      , Integer
156
      , Integer
1
      , Integer
204924
      , Integer
473
      , Integer
1
      , Integer
208896
      , Integer
511
      , Integer
1
      , Integer
52467
      , Integer
32
      , Integer
64832
      , Integer
32
      , Integer
65493
      , Integer
32
      , Integer
22558
      , Integer
32
      , Integer
16563
      , Integer
32
      , Integer
76511
      , Integer
32
      , Integer
196500
      , Integer
453240
      , Integer
220
      , Integer
0
      , Integer
1
      , Integer
1
      , Integer
69522
      , Integer
11687
      , Integer
0
      , Integer
1
      , Integer
60091
      , Integer
32
      , Integer
196500
      , Integer
453240
      , Integer
220
      , Integer
0
      , Integer
1
      , Integer
1
      , Integer
196500
      , Integer
453240
      , Integer
220
      , Integer
0
      , Integer
1
      , Integer
1
      , Integer
1159724
      , Integer
392670
      , Integer
0
      , Integer
2
      , Integer
806990
      , Integer
30482
      , Integer
4
      , Integer
1927926
      , Integer
82523
      , Integer
4
      , Integer
265318
      , Integer
0
      , Integer
4
      , Integer
0
      , Integer
85931
      , Integer
32
      , Integer
205665
      , Integer
812
      , Integer
1
      , Integer
1
      , Integer
41182
      , Integer
32
      , Integer
212342
      , Integer
32
      , Integer
31220
      , Integer
32
      , Integer
32696
      , Integer
32
      , Integer
43357
      , Integer
32
      , Integer
32247
      , Integer
32
      , Integer
38314
      , Integer
32
      , Integer
35892428
      , Integer
10
      , Integer
57996947
      , Integer
18975
      , Integer
10
      , Integer
38887044
      , Integer
32947
      , Integer
10
      ]