{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Babbage.Rules.Utxos (
  BabbageUTXOS,
  utxosTransition,
  expectScriptsToPass,
  babbageEvalScriptsTxInvalid,
) where

import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext)
import Cardano.Ledger.Alonzo.Plutus.Evaluate (
  collectPlutusScriptsWithContext,
  evalPlutusScripts,
 )
import Cardano.Ledger.Alonzo.Rules (
  AlonzoUtxosEvent (..),
  AlonzoUtxosPredFailure (..),
  TagMismatchDescription (..),
  UtxosEnv (..),
  invalidBegin,
  invalidEnd,
  scriptFailureToFailureDescription,
  validBegin,
  validEnd,
  when2Phase,
 )
import Cardano.Ledger.Alonzo.UTxO (
  AlonzoEraUTxO (..),
  AlonzoScriptsNeeded,
 )
import Cardano.Ledger.Babbage.Core
import Cardano.Ledger.Babbage.Era (BabbageEra, BabbageUTXOS)
import Cardano.Ledger.Babbage.Rules.Ppup ()
import Cardano.Ledger.Babbage.State
import Cardano.Ledger.BaseTypes (
  ShelleyBase,
  StrictMaybe,
  epochInfo,
  systemStart,
 )
import Cardano.Ledger.Binary (EncCBOR (..))
import Cardano.Ledger.Plutus.Evaluate (
  ScriptFailure (..),
  ScriptResult (..),
 )
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Rules (
  PpupEnv (..),
  PpupEvent,
  ShelleyPPUP,
  ShelleyPpupPredFailure,
 )
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition.Extended
import Data.List.NonEmpty (nonEmpty)
import qualified Debug.Trace as Debug
import Lens.Micro

type instance EraRuleFailure "UTXOS" BabbageEra = AlonzoUtxosPredFailure BabbageEra

type instance EraRuleEvent "UTXOS" BabbageEra = AlonzoUtxosEvent BabbageEra

instance InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure BabbageEra

instance InjectRuleEvent "UTXOS" AlonzoUtxosEvent BabbageEra

instance InjectRuleFailure "UTXOS" ShelleyPpupPredFailure BabbageEra where
  injectFailure :: ShelleyPpupPredFailure BabbageEra
-> EraRuleFailure "UTXOS" BabbageEra
injectFailure = EraRuleFailure "PPUP" BabbageEra
-> AlonzoUtxosPredFailure BabbageEra
ShelleyPpupPredFailure BabbageEra
-> EraRuleFailure "UTXOS" BabbageEra
forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure

-- =====================================================

instance
  ( AlonzoEraTx era
  , AlonzoEraPParams era
  , ShelleyEraTxBody era
  , BabbageEraTxBody era
  , AlonzoEraUTxO era
  , EraPlutusContext era
  , EraStake era
  , EraCertState era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , EraGov era
  , GovState era ~ ShelleyGovState era
  , Embed (EraRule "PPUP" era) (BabbageUTXOS era)
  , Environment (EraRule "PPUP" era) ~ PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , Signal (BabbageUTXOS era) ~ Tx TopTx era
  , EncCBOR (EraRuleFailure "PPUP" era)
  , Eq (EraRuleFailure "PPUP" era)
  , Show (EraRuleFailure "PPUP" era)
  , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era
  , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era
  , EraRule "UTXOS" era ~ BabbageUTXOS era
  ) =>
  STS (BabbageUTXOS era)
  where
  type BaseM (BabbageUTXOS era) = ShelleyBase
  type Environment (BabbageUTXOS era) = UtxosEnv era
  type State (BabbageUTXOS era) = ShelleyGovState era
  type Signal (BabbageUTXOS era) = Tx TopTx era
  type PredicateFailure (BabbageUTXOS era) = AlonzoUtxosPredFailure era
  type Event (BabbageUTXOS era) = AlonzoUtxosEvent era
  transitionRules :: [TransitionRule (BabbageUTXOS era)]
transitionRules = [TransitionRule (BabbageUTXOS era)
forall era.
(AlonzoEraTx era, ShelleyEraTxBody era, BabbageEraTxBody era,
 AlonzoEraUTxO era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraCertState era, EraStake era, EraGov era,
 GovState era ~ ShelleyGovState era,
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (BabbageUTXOS era),
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 EncCBOR (EraRuleFailure "PPUP" era),
 Eq (EraRuleFailure "PPUP" era), Show (EraRuleFailure "PPUP" era),
 EraPlutusContext era, EraRule "UTXOS" era ~ BabbageUTXOS era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
TransitionRule (BabbageUTXOS era)
utxosTransition]

instance
  ( Era era
  , STS (ShelleyPPUP era)
  , EraRuleFailure "PPUP" era ~ ShelleyPpupPredFailure era
  , EraRuleEvent "PPUP" era ~ PpupEvent era
  ) =>
  Embed (ShelleyPPUP era) (BabbageUTXOS era)
  where
  wrapFailed :: PredicateFailure (ShelleyPPUP era)
-> PredicateFailure (BabbageUTXOS era)
wrapFailed = EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
PredicateFailure (ShelleyPPUP era)
-> PredicateFailure (BabbageUTXOS era)
forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure
  wrapEvent :: Event (ShelleyPPUP era) -> Event (BabbageUTXOS era)
wrapEvent = EraRuleEvent "PPUP" era -> AlonzoUtxosEvent era
Event (ShelleyPPUP era) -> Event (BabbageUTXOS era)
forall era. EraRuleEvent "PPUP" era -> AlonzoUtxosEvent era
AlonzoPpupToUtxosEvent

utxosTransition ::
  forall era.
  ( AlonzoEraTx era
  , ShelleyEraTxBody era
  , BabbageEraTxBody era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , EraCertState era
  , EraStake era
  , EraGov era
  , GovState era ~ ShelleyGovState era
  , Environment (EraRule "PPUP" era) ~ PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , Embed (EraRule "PPUP" era) (BabbageUTXOS era)
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , EncCBOR (EraRuleFailure "PPUP" era)
  , Eq (EraRuleFailure "PPUP" era)
  , Show (EraRuleFailure "PPUP" era)
  , EraPlutusContext era
  , EraRule "UTXOS" era ~ BabbageUTXOS era
  , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era
  , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era
  ) =>
  TransitionRule (BabbageUTXOS era)
utxosTransition :: forall era.
(AlonzoEraTx era, ShelleyEraTxBody era, BabbageEraTxBody era,
 AlonzoEraUTxO era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 EraCertState era, EraStake era, EraGov era,
 GovState era ~ ShelleyGovState era,
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (BabbageUTXOS era),
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 EncCBOR (EraRuleFailure "PPUP" era),
 Eq (EraRuleFailure "PPUP" era), Show (EraRuleFailure "PPUP" era),
 EraPlutusContext era, EraRule "UTXOS" era ~ BabbageUTXOS era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
TransitionRule (BabbageUTXOS era)
utxosTransition =
  Rule
  (BabbageUTXOS era)
  'Transition
  (RuleContext 'Transition (BabbageUTXOS era))
F (Clause (BabbageUTXOS era) 'Transition) (TRC (BabbageUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext F (Clause (BabbageUTXOS era) 'Transition) (TRC (BabbageUTXOS era))
-> (TRC (BabbageUTXOS era)
    -> F (Clause (BabbageUTXOS era) 'Transition) (ShelleyGovState era))
-> F (Clause (BabbageUTXOS era) 'Transition) (ShelleyGovState era)
forall a b.
F (Clause (BabbageUTXOS era) 'Transition) a
-> (a -> F (Clause (BabbageUTXOS era) 'Transition) b)
-> F (Clause (BabbageUTXOS era) 'Transition) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(TRC (UtxosEnv SlotNo
_ PParams era
pp CertState era
_ UTxO era
utxo, State (BabbageUTXOS era)
pup, Signal (BabbageUTXOS era)
tx)) -> do
    case Tx TopTx era
Signal (BabbageUTXOS era)
tx Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL of
      IsValid Bool
True -> F (Clause (BabbageUTXOS era) 'Transition) (ShelleyGovState era)
F (Clause (BabbageUTXOS era) 'Transition)
  (State (BabbageUTXOS era))
forall era.
(AlonzoEraTx era, AlonzoEraUTxO era, ShelleyEraTxBody era,
 EraCertState era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 STS (BabbageUTXOS era),
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (BabbageUTXOS era),
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 EraPlutusContext era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 EraRule "UTXOS" era ~ BabbageUTXOS era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
TransitionRule (BabbageUTXOS era)
babbageEvalScriptsTxValid
      IsValid Bool
False -> do
        forall era.
(AlonzoEraTx era, EraPlutusContext era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era,
 BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 STS (EraRule "UTXOS" era)) =>
PParams era
-> Tx TopTx era
-> UTxO era
-> Rule (EraRule "UTXOS" era) 'Transition ()
babbageEvalScriptsTxInvalid @era PParams era
pp Tx TopTx era
Signal (BabbageUTXOS era)
tx UTxO era
utxo
        ShelleyGovState era
-> F (Clause (BabbageUTXOS era) 'Transition) (ShelleyGovState era)
forall a. a -> F (Clause (BabbageUTXOS era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShelleyGovState era
State (BabbageUTXOS era)
pup

-- ===================================================================

expectScriptsToPass ::
  forall era.
  ( AlonzoEraTx era
  , EraPlutusContext era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , STS (EraRule "UTXOS" era)
  , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era
  , BaseM (EraRule "UTXOS" era) ~ ShelleyBase
  , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era
  ) =>
  PParams era ->
  Tx TopTx era ->
  UTxO era ->
  Rule (EraRule "UTXOS" era) 'Transition ()
expectScriptsToPass :: forall era.
(AlonzoEraTx era, EraPlutusContext era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 STS (EraRule "UTXOS" era),
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
PParams era
-> Tx TopTx era
-> UTxO era
-> Rule (EraRule "UTXOS" era) 'Transition ()
expectScriptsToPass PParams era
pp Tx TopTx era
tx UTxO era
utxo = do
  sysSt <- BaseM (EraRule "UTXOS" era) SystemStart
-> Rule (EraRule "UTXOS" era) 'Transition SystemStart
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (EraRule "UTXOS" era) SystemStart
 -> Rule (EraRule "UTXOS" era) 'Transition SystemStart)
-> BaseM (EraRule "UTXOS" era) SystemStart
-> Rule (EraRule "UTXOS" era) 'Transition SystemStart
forall a b. (a -> b) -> a -> b
$ (Globals -> SystemStart) -> ReaderT Globals Identity SystemStart
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> SystemStart
systemStart
  ei <- liftSTS $ asks epochInfo
  {- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
  case collectPlutusScriptsWithContext ei sysSt pp tx utxo of
    Right [PlutusWithContext]
sLst -> do
      {- isValid tx = evalScripts tx sLst = True -}
      F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
whenFailureFree (F (Clause (EraRule "UTXOS" era) 'Transition) ()
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
when2Phase (F (Clause (EraRule "UTXOS" era) 'Transition) ()
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ case [PlutusWithContext] -> ScriptResult
evalPlutusScripts [PlutusWithContext]
sLst of
          Fails [PlutusWithContext]
_ NonEmpty ScriptFailure
fs ->
            PredicateFailure (EraRule "UTXOS" era)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (EraRule "UTXOS" era)
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> PredicateFailure (EraRule "UTXOS" era)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
              AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era)
-> AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era
forall a b. (a -> b) -> a -> b
$
                IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch
                  (Tx TopTx era
tx Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL)
                  (NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly (ScriptFailure -> FailureDescription
scriptFailureToFailureDescription (ScriptFailure -> FailureDescription)
-> NonEmpty ScriptFailure -> NonEmpty FailureDescription
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ScriptFailure
fs))
          Passes [PlutusWithContext]
ps -> (NonEmpty PlutusWithContext
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> Maybe (NonEmpty PlutusWithContext)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (EraRuleEvent "UTXOS" era
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
Event (EraRule "UTXOS" era)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (EraRuleEvent "UTXOS" era
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> (NonEmpty PlutusWithContext -> EraRuleEvent "UTXOS" era)
-> NonEmpty PlutusWithContext
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoUtxosEvent era -> EraRuleEvent "UTXOS" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent (AlonzoUtxosEvent era -> EraRuleEvent "UTXOS" era)
-> (NonEmpty PlutusWithContext -> AlonzoUtxosEvent era)
-> NonEmpty PlutusWithContext
-> EraRuleEvent "UTXOS" era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent) ([PlutusWithContext] -> Maybe (NonEmpty PlutusWithContext)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext]
ps)
    Left NonEmpty (CollectError era)
info -> PredicateFailure (EraRule "UTXOS" era)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era)
-> AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era
forall a b. (a -> b) -> a -> b
$ NonEmpty (CollectError era) -> AlonzoUtxosPredFailure era
forall era.
NonEmpty (CollectError era) -> AlonzoUtxosPredFailure era
CollectErrors NonEmpty (CollectError era)
info)

babbageEvalScriptsTxValid ::
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraUTxO era
  , ShelleyEraTxBody era
  , EraCertState era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , STS (BabbageUTXOS era)
  , Environment (EraRule "PPUP" era) ~ PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , Embed (EraRule "PPUP" era) (BabbageUTXOS era)
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , EraPlutusContext era
  , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era
  , EraRule "UTXOS" era ~ BabbageUTXOS era
  , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era
  ) =>
  TransitionRule (BabbageUTXOS era)
babbageEvalScriptsTxValid :: forall era.
(AlonzoEraTx era, AlonzoEraUTxO era, ShelleyEraTxBody era,
 EraCertState era, ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 STS (BabbageUTXOS era),
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (BabbageUTXOS era),
 State (EraRule "PPUP" era) ~ ShelleyGovState era,
 EraPlutusContext era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 EraRule "UTXOS" era ~ BabbageUTXOS era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
TransitionRule (BabbageUTXOS era)
babbageEvalScriptsTxValid = do
  TRC (UtxosEnv slot pp certState utxo, pup, tx) <-
    Rule
  (BabbageUTXOS era)
  'Transition
  (RuleContext 'Transition (BabbageUTXOS era))
F (Clause (BabbageUTXOS era) 'Transition) (TRC (BabbageUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txBody = Tx TopTx era
Signal (BabbageUTXOS era)
tx Tx TopTx era
-> Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
-> TxBody TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (TxBody TopTx era) (Tx TopTx era) (TxBody TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL
      genDelegs = CertState era
certState CertState era
-> Getting GenDelegs (CertState era) GenDelegs -> GenDelegs
forall s a. s -> Getting a s a -> a
^. (DState era -> Const GenDelegs (DState era))
-> CertState era -> Const GenDelegs (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const GenDelegs (DState era))
 -> CertState era -> Const GenDelegs (CertState era))
-> ((GenDelegs -> Const GenDelegs GenDelegs)
    -> DState era -> Const GenDelegs (DState era))
-> Getting GenDelegs (CertState era) GenDelegs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenDelegs -> Const GenDelegs GenDelegs)
-> DState era -> Const GenDelegs (DState era)
forall era (f :: * -> *).
Functor f =>
(GenDelegs -> f GenDelegs) -> DState era -> f (DState era)
dsGenDelegsL

  -- We intentionally run the PPUP rule before evaluating any Plutus scripts.
  -- We do not want to waste computation running plutus scripts if the
  -- transaction will fail due to `PPUP`
  updatedGovState <-
    trans @(EraRule "PPUP" era) $
      TRC (PPUPEnv slot pp genDelegs, pup, txBody ^. updateTxBodyL)

  () <- pure $! Debug.traceEvent validBegin ()
  expectScriptsToPass pp tx utxo
  () <- pure $! Debug.traceEvent validEnd ()

  pure updatedGovState

babbageEvalScriptsTxInvalid ::
  forall era.
  ( AlonzoEraTx era
  , EraPlutusContext era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era
  , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era
  , BaseM (EraRule "UTXOS" era) ~ ShelleyBase
  , STS (EraRule "UTXOS" era)
  ) =>
  PParams era ->
  Tx TopTx era ->
  UTxO era ->
  Rule (EraRule "UTXOS" era) 'Transition ()
babbageEvalScriptsTxInvalid :: forall era.
(AlonzoEraTx era, EraPlutusContext era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era,
 BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 STS (EraRule "UTXOS" era)) =>
PParams era
-> Tx TopTx era
-> UTxO era
-> Rule (EraRule "UTXOS" era) 'Transition ()
babbageEvalScriptsTxInvalid PParams era
pp Tx TopTx era
tx UTxO era
utxo = do
  sysSt <- BaseM (EraRule "UTXOS" era) SystemStart
-> Rule (EraRule "UTXOS" era) 'Transition SystemStart
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (EraRule "UTXOS" era) SystemStart
 -> Rule (EraRule "UTXOS" era) 'Transition SystemStart)
-> BaseM (EraRule "UTXOS" era) SystemStart
-> Rule (EraRule "UTXOS" era) 'Transition SystemStart
forall a b. (a -> b) -> a -> b
$ (Globals -> SystemStart) -> ReaderT Globals Identity SystemStart
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> SystemStart
systemStart
  ei <- liftSTS $ asks epochInfo
  () <- pure $! Debug.traceEvent invalidBegin ()
  case collectPlutusScriptsWithContext @era ei sysSt pp tx utxo of
    Right [PlutusWithContext]
sLst ->
      {- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
      {- isValid tx = evalScripts tx sLst = False -}
      F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
whenFailureFree (F (Clause (EraRule "UTXOS" era) 'Transition) ()
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
when2Phase (F (Clause (EraRule "UTXOS" era) 'Transition) ()
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ case [PlutusWithContext] -> ScriptResult
evalPlutusScripts [PlutusWithContext]
sLst of
          Passes [PlutusWithContext]
_ ->
            PredicateFailure (EraRule "UTXOS" era)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (EraRule "UTXOS" era)
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> PredicateFailure (EraRule "UTXOS" era)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
              AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era)
-> AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era
forall a b. (a -> b) -> a -> b
$
                IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch (Tx TopTx era
tx Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL) TagMismatchDescription
PassedUnexpectedly
          Fails [PlutusWithContext]
ps NonEmpty ScriptFailure
fs -> do
            (NonEmpty PlutusWithContext
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> Maybe (NonEmpty PlutusWithContext)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
              (EraRuleEvent "UTXOS" era
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
Event (EraRule "UTXOS" era)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (EraRuleEvent "UTXOS" era
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> (NonEmpty PlutusWithContext -> EraRuleEvent "UTXOS" era)
-> NonEmpty PlutusWithContext
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoUtxosEvent era -> EraRuleEvent "UTXOS" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent (AlonzoUtxosEvent era -> EraRuleEvent "UTXOS" era)
-> (NonEmpty PlutusWithContext -> AlonzoUtxosEvent era)
-> NonEmpty PlutusWithContext
-> EraRuleEvent "UTXOS" era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent @era)
              ([PlutusWithContext] -> Maybe (NonEmpty PlutusWithContext)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext]
ps)
            EraRuleEvent "UTXOS" era
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
Event (EraRule "UTXOS" era)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (EraRuleEvent "UTXOS" era
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> (AlonzoUtxosEvent era -> EraRuleEvent "UTXOS" era)
-> AlonzoUtxosEvent era
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AlonzoUtxosEvent era -> EraRuleEvent "UTXOS" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent (AlonzoUtxosEvent era
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> AlonzoUtxosEvent era
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
              NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
FailedPlutusScriptsEvent (ScriptFailure -> PlutusWithContext
scriptFailurePlutus (ScriptFailure -> PlutusWithContext)
-> NonEmpty ScriptFailure -> NonEmpty PlutusWithContext
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ScriptFailure
fs)
    Left NonEmpty (CollectError era)
info -> PredicateFailure (EraRule "UTXOS" era)
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (AlonzoUtxosPredFailure era -> EraRuleFailure "UTXOS" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (NonEmpty (CollectError era) -> AlonzoUtxosPredFailure era
forall era.
NonEmpty (CollectError era) -> AlonzoUtxosPredFailure era
CollectErrors NonEmpty (CollectError era)
info))
  pure $! Debug.traceEvent invalidEnd ()