{-# 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 (evalPlutusScripts)
import qualified Cardano.Ledger.Alonzo.Rules as Alonzo
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)
import Cardano.Ledger.Binary (EncCBOR (..))
import Cardano.Ledger.Plutus.Evaluate (
  ScriptFailure (..),
  ScriptResult (..),
 )
import Cardano.Ledger.Shelley.PParams (Update)
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Control.Monad (forM_)
import Control.State.Transition.Extended
import Data.List.NonEmpty (nonEmpty)
import qualified Debug.Trace as Debug
import Lens.Micro

type instance EraRuleFailure "UTXOS" BabbageEra = Alonzo.AlonzoUtxosPredFailure BabbageEra

type instance EraRuleEvent "UTXOS" BabbageEra = Alonzo.AlonzoUtxosEvent BabbageEra

instance InjectRuleFailure "UTXOS" Alonzo.AlonzoUtxosPredFailure BabbageEra

instance InjectRuleEvent "UTXOS" Alonzo.AlonzoUtxosEvent BabbageEra

instance InjectRuleFailure "UTXOS" Shelley.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
Alonzo.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) ~ Shelley.PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , Signal (BabbageUTXOS era) ~ StAnnTx TopTx era
  , EncCBOR (EraRuleFailure "PPUP" era)
  , Eq (EraRuleFailure "PPUP" era)
  , Show (EraRuleFailure "PPUP" era)
  , InjectRuleFailure "UTXOS" Alonzo.AlonzoUtxosPredFailure era
  , InjectRuleEvent "UTXOS" Alonzo.AlonzoUtxosEvent era
  , EraRule "UTXOS" era ~ BabbageUTXOS era
  ) =>
  STS (BabbageUTXOS era)
  where
  type BaseM (BabbageUTXOS era) = ShelleyBase
  type Environment (BabbageUTXOS era) = Alonzo.UtxosEnv era
  type State (BabbageUTXOS era) = ShelleyGovState era
  type Signal (BabbageUTXOS era) = StAnnTx TopTx era
  type PredicateFailure (BabbageUTXOS era) = Alonzo.AlonzoUtxosPredFailure era
  type Event (BabbageUTXOS era) = Alonzo.AlonzoUtxosEvent era
  transitionRules :: [TransitionRule (BabbageUTXOS era)]
transitionRules = [TransitionRule (BabbageUTXOS era)
forall era.
(AlonzoEraTx era, ShelleyEraTxBody era, AlonzoEraUTxO era,
 EraCertState 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,
 EraRule "UTXOS" era ~ BabbageUTXOS era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
TransitionRule (BabbageUTXOS era)
utxosTransition]

instance
  ( Era era
  , STS (Shelley.ShelleyPPUP era)
  , EraRuleFailure "PPUP" era ~ Shelley.ShelleyPpupPredFailure era
  , EraRuleEvent "PPUP" era ~ Shelley.PpupEvent era
  ) =>
  Embed (Shelley.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
Alonzo.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
Alonzo.AlonzoPpupToUtxosEvent

utxosTransition ::
  forall era.
  ( AlonzoEraTx era
  , ShelleyEraTxBody era
  , AlonzoEraUTxO era
  , EraCertState era
  , Environment (EraRule "PPUP" era) ~ Shelley.PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , Embed (EraRule "PPUP" era) (BabbageUTXOS era)
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , EraRule "UTXOS" era ~ BabbageUTXOS era
  , InjectRuleFailure "UTXOS" Alonzo.AlonzoUtxosPredFailure era
  , InjectRuleEvent "UTXOS" Alonzo.AlonzoUtxosEvent era
  ) =>
  TransitionRule (BabbageUTXOS era)
utxosTransition :: forall era.
(AlonzoEraTx era, ShelleyEraTxBody era, AlonzoEraUTxO era,
 EraCertState 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,
 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 (Environment (BabbageUTXOS era)
_, State (BabbageUTXOS era)
pup, Signal (BabbageUTXOS era)
stAnnTx)) -> do
    let tx :: Tx TopTx era
tx = StAnnTx TopTx era
Signal (BabbageUTXOS era)
stAnnTx StAnnTx TopTx era
-> Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
-> Tx TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
SimpleGetter (StAnnTx l era) (Tx l era)
forall (l :: TxLevel). SimpleGetter (StAnnTx l era) (Tx l era)
txStAnnTxG
    case 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 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, 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,
 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, AlonzoEraUTxO era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
StAnnTx TopTx era -> Rule (EraRule "UTXOS" era) 'Transition ()
babbageEvalScriptsTxInvalid @era StAnnTx TopTx era
Signal (BabbageUTXOS era)
stAnnTx
        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
  , AlonzoEraUTxO era
  , InjectRuleFailure "UTXOS" Alonzo.AlonzoUtxosPredFailure era
  , InjectRuleEvent "UTXOS" Alonzo.AlonzoUtxosEvent era
  ) =>
  StAnnTx TopTx era ->
  Rule (EraRule "UTXOS" era) 'Transition ()
expectScriptsToPass :: forall era.
(AlonzoEraTx era, AlonzoEraUTxO era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
StAnnTx TopTx era -> Rule (EraRule "UTXOS" era) 'Transition ()
expectScriptsToPass StAnnTx TopTx era
stAnnTx = do
  let tx :: Tx TopTx era
tx = StAnnTx TopTx era
stAnnTx StAnnTx TopTx era
-> Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
-> Tx TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
SimpleGetter (StAnnTx l era) (Tx l era)
forall (l :: TxLevel). SimpleGetter (StAnnTx l era) (Tx l era)
txStAnnTxG
  {- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
  let scriptsWithContextEither :: Either (NonEmpty (CollectError era)) [PlutusWithContext]
scriptsWithContextEither = StAnnTx TopTx era
-> Either (NonEmpty (CollectError era)) [PlutusWithContext]
forall era (l :: TxLevel).
AlonzoEraUTxO era =>
StAnnTx l era
-> Either (NonEmpty (CollectError era)) [PlutusWithContext]
forall (l :: TxLevel).
StAnnTx l era
-> Either (NonEmpty (CollectError era)) [PlutusWithContext]
plutusScriptsWithContextStAnnTx StAnnTx TopTx era
stAnnTx
  (() ()
-> Either (NonEmpty (CollectError era)) [PlutusWithContext]
-> Either (NonEmpty (CollectError era)) ()
forall a b.
a
-> Either (NonEmpty (CollectError era)) b
-> Either (NonEmpty (CollectError era)) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Either (NonEmpty (CollectError era)) [PlutusWithContext]
scriptsWithContextEither) Either (NonEmpty (CollectError era)) ()
-> (NonEmpty (CollectError era)
    -> PredicateFailure (EraRule "UTXOS" era))
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall e sts (ctx :: RuleType).
Either e () -> (e -> PredicateFailure sts) -> Rule sts ctx ()
?!: (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)
-> (NonEmpty (CollectError era) -> AlonzoUtxosPredFailure era)
-> NonEmpty (CollectError era)
-> EraRuleFailure "UTXOS" era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (CollectError era) -> AlonzoUtxosPredFailure era
forall era.
NonEmpty (CollectError era) -> AlonzoUtxosPredFailure era
Alonzo.CollectErrors)
  {- isValid tx = evalScripts tx sLst = True -}
  F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (ctx :: RuleType). Rule sts ctx () -> Rule sts ctx ()
Alonzo.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
$
    F (Clause (EraRule "UTXOS" era) 'Transition) ()
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall sts (ctx :: RuleType). Rule sts ctx () -> Rule sts ctx ()
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
$
      Either (NonEmpty (CollectError era)) [PlutusWithContext]
-> ([PlutusWithContext]
    -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Either (NonEmpty (CollectError era)) [PlutusWithContext]
scriptsWithContextEither (([PlutusWithContext]
  -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
 -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> ([PlutusWithContext]
    -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ \[PlutusWithContext]
scriptsWithContext ->
        case [PlutusWithContext] -> ScriptResult
evalPlutusScripts [PlutusWithContext]
scriptsWithContext 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
Alonzo.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
Alonzo.FailedUnexpectedly (ScriptFailure -> FailureDescription
Alonzo.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
Alonzo.SuccessfulPlutusScriptsEvent) ([PlutusWithContext] -> Maybe (NonEmpty PlutusWithContext)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext]
ps)

babbageEvalScriptsTxValid ::
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraUTxO era
  , ShelleyEraTxBody era
  , EraCertState era
  , Environment (EraRule "PPUP" era) ~ Shelley.PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , Embed (EraRule "PPUP" era) (BabbageUTXOS era)
  , State (EraRule "PPUP" era) ~ ShelleyGovState era
  , InjectRuleFailure "UTXOS" Alonzo.AlonzoUtxosPredFailure era
  , EraRule "UTXOS" era ~ BabbageUTXOS era
  , InjectRuleEvent "UTXOS" Alonzo.AlonzoUtxosEvent era
  ) =>
  TransitionRule (BabbageUTXOS era)
babbageEvalScriptsTxValid :: forall era.
(AlonzoEraTx era, AlonzoEraUTxO era, ShelleyEraTxBody era,
 EraCertState 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,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 EraRule "UTXOS" era ~ BabbageUTXOS era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
TransitionRule (BabbageUTXOS era)
babbageEvalScriptsTxValid = do
  TRC (Alonzo.UtxosEnv slot pp certState _utxo, pup, stAnnTx) <-
    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 tx = StAnnTx TopTx era
Signal (BabbageUTXOS era)
stAnnTx StAnnTx TopTx era
-> Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
-> Tx TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
SimpleGetter (StAnnTx l era) (Tx l era)
forall (l :: TxLevel). SimpleGetter (StAnnTx l era) (Tx l era)
txStAnnTxG
      txBody = Tx TopTx 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 (Shelley.PPUPEnv slot pp genDelegs, pup, txBody ^. updateTxBodyL)

  () <- pure $! Debug.traceEvent Alonzo.validBegin ()
  expectScriptsToPass stAnnTx
  () <- pure $! Debug.traceEvent Alonzo.validEnd ()

  pure updatedGovState

babbageEvalScriptsTxInvalid ::
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraUTxO era
  , InjectRuleFailure "UTXOS" Alonzo.AlonzoUtxosPredFailure era
  , InjectRuleEvent "UTXOS" Alonzo.AlonzoUtxosEvent era
  ) =>
  StAnnTx TopTx era ->
  Rule (EraRule "UTXOS" era) 'Transition ()
babbageEvalScriptsTxInvalid :: forall era.
(AlonzoEraTx era, AlonzoEraUTxO era,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
StAnnTx TopTx era -> Rule (EraRule "UTXOS" era) 'Transition ()
babbageEvalScriptsTxInvalid StAnnTx TopTx era
stAnnTx = do
  let tx :: Tx TopTx era
tx = StAnnTx TopTx era
stAnnTx StAnnTx TopTx era
-> Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
-> Tx TopTx era
forall s a. s -> Getting a s a -> a
^. Getting (Tx TopTx era) (StAnnTx TopTx era) (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
SimpleGetter (StAnnTx l era) (Tx l era)
forall (l :: TxLevel). SimpleGetter (StAnnTx l era) (Tx l era)
txStAnnTxG
  () <- () -> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a. a -> F (Clause (EraRule "UTXOS" era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> F (Clause (EraRule "UTXOS" era) 'Transition) ())
-> () -> F (Clause (EraRule "UTXOS" era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$! String -> () -> ()
forall a. String -> a -> a
Debug.traceEvent String
Alonzo.invalidBegin ()
  {- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
  let scriptsWithContextEither = StAnnTx TopTx era
-> Either (NonEmpty (CollectError era)) [PlutusWithContext]
forall era (l :: TxLevel).
AlonzoEraUTxO era =>
StAnnTx l era
-> Either (NonEmpty (CollectError era)) [PlutusWithContext]
forall (l :: TxLevel).
StAnnTx l era
-> Either (NonEmpty (CollectError era)) [PlutusWithContext]
plutusScriptsWithContextStAnnTx StAnnTx TopTx era
stAnnTx
  (() <$ scriptsWithContextEither) ?!: (injectFailure . Alonzo.CollectErrors)
  {- isValid tx = evalScripts tx sLst = False -}
  Alonzo.when2Phase $
    whenFailureFree $
      forM_ scriptsWithContextEither $ \[PlutusWithContext]
scriptsWithContext ->
        case [PlutusWithContext] -> ScriptResult
evalPlutusScripts [PlutusWithContext]
scriptsWithContext 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
Alonzo.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
Alonzo.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
Alonzo.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
Alonzo.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)
  pure $! Debug.traceEvent Alonzo.invalidEnd ()