{-# 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 (..),
  invalidBegin,
  invalidEnd,
  scriptFailureToFailureDescription,
  validBegin,
  validEnd,
  when2Phase,
 )
import Cardano.Ledger.Alonzo.UTxO (
  AlonzoEraUTxO (..),
  AlonzoScriptsNeeded,
 )
import Cardano.Ledger.Babbage.Collateral (
  collAdaBalance,
  collOuts,
 )
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.Babbage.Tx
import Cardano.Ledger.BaseTypes (
  ShelleyBase,
  StrictMaybe,
  epochInfo,
  systemStart,
 )
import Cardano.Ledger.Binary (EncCBOR (..))
import Cardano.Ledger.CertState (EraCertState (..))
import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
import Cardano.Ledger.Plutus.Evaluate (
  ScriptFailure (..),
  ScriptResult (..),
 )
import Cardano.Ledger.Shelley.LedgerState (UTxOState (..), dsGenDelegsL)
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Rules (
  PpupEnv (..),
  PpupEvent,
  ShelleyPPUP,
  ShelleyPpupPredFailure,
  UtxoEnv (..),
  updateUTxOState,
 )
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition.Extended
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as Map
import Data.MapExtras (extractKeys)
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 = 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 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) = UtxoEnv era
  type State (BabbageUTXOS era) = UTxOState era
  type Signal (BabbageUTXOS era) = AlonzoTx era
  type PredicateFailure (BabbageUTXOS era) = AlonzoUtxosPredFailure era
  type Event (BabbageUTXOS era) = AlonzoUtxosEvent era
  transitionRules :: [TransitionRule (BabbageUTXOS era)]
transitionRules = [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,
 Signal (BabbageUTXOS era) ~ Tx 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 = forall era. EraRuleFailure "PPUP" era -> AlonzoUtxosPredFailure era
UpdateFailure
  wrapEvent :: Event (ShelleyPPUP era) -> Event (BabbageUTXOS era)
wrapEvent = 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
  , Signal (BabbageUTXOS era) ~ Tx 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,
 Signal (BabbageUTXOS era) ~ Tx 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 sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(TRC (Environment (BabbageUTXOS era)
_, State (BabbageUTXOS era)
_, Signal (BabbageUTXOS era)
tx)) -> do
    case Signal (BabbageUTXOS era)
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL of
      IsValid Bool
True -> forall era.
(AlonzoEraTx era, AlonzoEraUTxO era, ShelleyEraTxBody era,
 EraStake era, EraCertState era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 STS (BabbageUTXOS era), Signal (BabbageUTXOS era) ~ Tx era,
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (BabbageUTXOS era),
 GovState era ~ ShelleyGovState 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 -> forall era.
(EraStake era, AlonzoEraTx era, BabbageEraTxBody era,
 EraPlutusContext era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 STS (EraRule "UTXOS" era),
 Environment (EraRule "UTXOS" era) ~ UtxoEnv era,
 Signal (EraRule "UTXOS" era) ~ Tx era,
 State (EraRule "UTXOS" era) ~ UTxOState era,
 BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
TransitionRule (EraRule "UTXOS" era)
babbageEvalScriptsTxInvalid

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

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

babbageEvalScriptsTxValid ::
  forall era.
  ( AlonzoEraTx era
  , AlonzoEraUTxO era
  , ShelleyEraTxBody era
  , EraStake era
  , EraCertState era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , STS (BabbageUTXOS era)
  , Signal (BabbageUTXOS era) ~ Tx era
  , Environment (EraRule "PPUP" era) ~ PpupEnv era
  , Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era)
  , Embed (EraRule "PPUP" era) (BabbageUTXOS era)
  , GovState era ~ ShelleyGovState 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,
 EraStake era, EraCertState era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 STS (BabbageUTXOS era), Signal (BabbageUTXOS era) ~ Tx era,
 Environment (EraRule "PPUP" era) ~ PpupEnv era,
 Signal (EraRule "PPUP" era) ~ StrictMaybe (Update era),
 Embed (EraRule "PPUP" era) (BabbageUTXOS era),
 GovState era ~ ShelleyGovState 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 (UtxoEnv SlotNo
slot PParams era
pp CertState era
certState, utxos :: State (BabbageUTXOS era)
utxos@(UTxOState UTxO era
utxo Coin
_ Coin
_ GovState era
pup InstantStake era
_ Coin
_), Signal (BabbageUTXOS era)
tx) <-
    forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let txBody :: TxBody era
txBody = Signal (BabbageUTXOS era)
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
      genDelegs :: GenDelegs
genDelegs = CertState era
certState forall s a. s -> Getting a s a -> a
^. forall era. EraCertState era => Lens' (CertState era) (DState era)
certDStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (DState era) GenDelegs
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`
  ShelleyGovState era
ppup' <-
    forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "PPUP" era) forall a b. (a -> b) -> a -> b
$
      forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (forall era. SlotNo -> PParams era -> GenDelegs -> PpupEnv era
PPUPEnv SlotNo
slot PParams era
pp GenDelegs
genDelegs, GovState era
pup, TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
ShelleyEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (Update era))
updateTxBodyL)

  () <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. String -> a -> a
Debug.traceEvent String
validBegin ()
  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 era -> UTxO era -> Rule (EraRule "UTXOS" era) 'Transition ()
expectScriptsToPass PParams era
pp Signal (BabbageUTXOS era)
tx UTxO era
utxo
  () <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. String -> a -> a
Debug.traceEvent String
validEnd ()

  forall era (m :: * -> *).
(EraTxBody era, EraStake era, EraCertState era, Monad m) =>
PParams era
-> UTxOState era
-> TxBody era
-> CertState era
-> GovState era
-> (Coin -> m ())
-> (UTxO era -> UTxO era -> m ())
-> m (UTxOState era)
updateUTxOState
    PParams era
pp
    State (BabbageUTXOS era)
utxos
    TxBody era
txBody
    CertState era
certState
    ShelleyGovState era
ppup'
    (forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
SafeHash EraIndependentTxBody -> Coin -> AlonzoUtxosEvent era
TotalDeposits (forall x i. HashAnnotated x i => x -> SafeHash i
hashAnnotated TxBody era
txBody))
    (\UTxO era
a UTxO era
b -> forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall a b. (a -> b) -> a -> b
$ forall era. UTxO era -> UTxO era -> AlonzoUtxosEvent era
TxUTxODiff UTxO era
a UTxO era
b)

babbageEvalScriptsTxInvalid ::
  forall era.
  ( EraStake era
  , AlonzoEraTx era
  , BabbageEraTxBody era
  , EraPlutusContext era
  , AlonzoEraUTxO era
  , ScriptsNeeded era ~ AlonzoScriptsNeeded era
  , STS (EraRule "UTXOS" era)
  , Environment (EraRule "UTXOS" era) ~ UtxoEnv era
  , Signal (EraRule "UTXOS" era) ~ Tx era
  , State (EraRule "UTXOS" era) ~ UTxOState era
  , BaseM (EraRule "UTXOS" era) ~ ShelleyBase
  , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era
  , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era
  ) =>
  TransitionRule (EraRule "UTXOS" era)
babbageEvalScriptsTxInvalid :: forall era.
(EraStake era, AlonzoEraTx era, BabbageEraTxBody era,
 EraPlutusContext era, AlonzoEraUTxO era,
 ScriptsNeeded era ~ AlonzoScriptsNeeded era,
 STS (EraRule "UTXOS" era),
 Environment (EraRule "UTXOS" era) ~ UtxoEnv era,
 Signal (EraRule "UTXOS" era) ~ Tx era,
 State (EraRule "UTXOS" era) ~ UTxOState era,
 BaseM (EraRule "UTXOS" era) ~ ShelleyBase,
 InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era,
 InjectRuleEvent "UTXOS" AlonzoUtxosEvent era) =>
TransitionRule (EraRule "UTXOS" era)
babbageEvalScriptsTxInvalid = do
  TRC (UtxoEnv SlotNo
_ PParams era
pp CertState era
_, utxos :: State (EraRule "UTXOS" era)
utxos@(UTxOState UTxO era
utxo Coin
_ Coin
fees GovState era
_ InstantStake era
_ Coin
_), Signal (EraRule "UTXOS" era)
tx) <- forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  {- txb := txbody tx -}
  let txBody :: TxBody era
txBody = Signal (EraRule "UTXOS" era)
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL
  SystemStart
sysSt <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> SystemStart
systemStart
  EpochInfo (Either Text)
ei <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo (Either Text)
epochInfo

  () <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. String -> a -> a
Debug.traceEvent String
invalidBegin ()

  case 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)
ei SystemStart
sysSt PParams era
pp Signal (EraRule "UTXOS" era)
tx UTxO era
utxo of
    Right [PlutusWithContext]
sLst ->
      {- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
      {- isValid tx = evalScripts tx sLst = False -}
      forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
whenFailureFree forall a b. (a -> b) -> a -> b
$
        forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
when2Phase forall a b. (a -> b) -> a -> b
$ case [PlutusWithContext] -> ScriptResult
evalPlutusScripts [PlutusWithContext]
sLst of
          Passes [PlutusWithContext]
_ ->
            forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause forall a b. (a -> b) -> a -> b
$
              forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$
                forall era.
IsValid -> TagMismatchDescription -> AlonzoUtxosPredFailure era
ValidationTagMismatch (Signal (EraRule "UTXOS" era)
tx forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTx era => Lens' (Tx era) IsValid
isValidTxL) TagMismatchDescription
PassedUnexpectedly
          Fails [PlutusWithContext]
ps NonEmpty ScriptFailure
fs -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent @"UTXOS" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent @era) (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext]
ps)
            forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent forall a b. (a -> b) -> a -> b
$ forall era. NonEmpty PlutusWithContext -> AlonzoUtxosEvent era
FailedPlutusScriptsEvent (ScriptFailure -> PlutusWithContext
scriptFailurePlutus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty ScriptFailure
fs))
    Left [CollectError era]
info -> forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. [CollectError era] -> AlonzoUtxosPredFailure era
CollectErrors [CollectError era]
info)

  () <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! forall a. String -> a -> a
Debug.traceEvent String
invalidEnd ()

  {- utxoKeep = txBody ^. collateralInputsTxBodyL ⋪ utxo -}
  {- utxoDel  = txBody ^. collateralInputsTxBodyL ◁ utxo -}
  let !(Map TxIn (TxOut era)
utxoKeep, Map TxIn (TxOut era)
utxoDel) = forall k a. Ord k => Map k a -> Set k -> (Map k a, Map k a)
extractKeys (forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO UTxO era
utxo) (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL)
      UTxO Map TxIn (TxOut era)
collouts = forall era. BabbageEraTxBody era => TxBody era -> UTxO era
collOuts TxBody era
txBody
      DeltaCoin Integer
collateralFees = forall era.
BabbageEraTxBody era =>
TxBody era -> Map TxIn (TxOut era) -> DeltaCoin
collAdaBalance TxBody era
txBody Map TxIn (TxOut era)
utxoDel -- NEW to Babbage
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$!
    State (EraRule "UTXOS" era)
utxos {- (collInputs txb ⋪ utxo) ∪ collouts tx -}
      { utxosUtxo :: UTxO era
utxosUtxo = forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map TxIn (TxOut era)
utxoKeep Map TxIn (TxOut era)
collouts) -- NEW to Babbage
      {- fees + collateralFees -}
      , utxosFees :: Coin
utxosFees = Coin
fees forall a. Semigroup a => a -> a -> a
<> Integer -> Coin
Coin Integer
collateralFees -- NEW to Babbage
      , utxosInstantStake :: InstantStake era
utxosInstantStake =
          forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
deleteInstantStake (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
utxoDel) (forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
addInstantStake (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO Map TxIn (TxOut era)
collouts) (State (EraRule "UTXOS" era)
utxos forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) era.
CanSetInstantStake t =>
Lens' (t era) (InstantStake era)
instantStakeL))
      }