{-# 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.Tx
import Cardano.Ledger.BaseTypes (
  ShelleyBase,
  StrictMaybe,
  epochInfo,
  systemStart,
 )
import Cardano.Ledger.Binary (EncCBOR (..))
import Cardano.Ledger.CertState (certDState, dsGenDelegs)
import Cardano.Ledger.Coin (Coin (..), DeltaCoin (..))
import Cardano.Ledger.Plutus.Evaluate (
  ScriptFailure (..),
  ScriptResult (..),
 )
import Cardano.Ledger.SafeHash (hashAnnotated)
import Cardano.Ledger.Shelley.LedgerState (UTxOState (..), updateStakeDistribution)
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Rules (
  PpupEnv (..),
  PpupEvent,
  ShelleyPPUP,
  ShelleyPpupPredFailure,
  UtxoEnv (..),
  updateUTxOState,
 )
import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..))
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 c) = AlonzoUtxosPredFailure (BabbageEra c)
type instance EraRuleEvent "UTXOS" (BabbageEra c) = AlonzoUtxosEvent (BabbageEra c)

instance InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure (BabbageEra c)

instance InjectRuleEvent "UTXOS" AlonzoUtxosEvent (BabbageEra c)

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

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

instance
  ( AlonzoEraTx era
  , AlonzoEraPParams era
  , ShelleyEraTxBody era
  , BabbageEraTxBody era
  , AlonzoEraUTxO era
  , EraPlutusContext 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,
 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
  , 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,
 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,
 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.
(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 (EraCrypto era)]
collectPlutusScriptsWithContext EpochInfo (Either Text)
ei SystemStart
sysSt PParams era
pp Tx era
tx UTxO era
utxo of
    Right [PlutusWithContext (EraCrypto era)]
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 forall c. [PlutusWithContext c] -> ScriptResult c
evalPlutusScripts [PlutusWithContext (EraCrypto era)]
sLst of
          Fails [PlutusWithContext (EraCrypto era)]
_ NonEmpty (ScriptFailure (EraCrypto era))
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 (forall c. Crypto c => ScriptFailure c -> FailureDescription
scriptFailureToFailureDescription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ScriptFailure (EraCrypto era))
fs))
          Passes [PlutusWithContext (EraCrypto era)]
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 (EraCrypto era))
-> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent) (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext (EraCrypto era)]
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
  , 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,
 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 IncrementalStake (EraCrypto 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 (EraCrypto era)
genDelegs = forall era. DState era -> GenDelegs (EraCrypto era)
dsGenDelegs (forall era. CertState era -> DState era
certDState CertState era
certState)

  -- 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 (EraCrypto era) -> PpupEnv era
PPUPEnv SlotNo
slot PParams era
pp GenDelegs (EraCrypto era)
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, 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 (EraCrypto era) EraIndependentTxBody
-> Coin -> AlonzoUtxosEvent era
TotalDeposits (forall x index c.
(HashAnnotated x index c, HashAlgorithm (HASH c)) =>
x -> SafeHash c index
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.
  ( 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.
(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
_, us :: State (EraRule "UTXOS" era)
us@(UTxOState UTxO era
utxo Coin
_ Coin
fees GovState era
_ IncrementalStake (EraCrypto 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 (EraCrypto era)]
collectPlutusScriptsWithContext EpochInfo (Either Text)
ei SystemStart
sysSt PParams era
pp Signal (EraRule "UTXOS" era)
tx UTxO era
utxo of
    Right [PlutusWithContext (EraCrypto era)]
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 forall c. [PlutusWithContext c] -> ScriptResult c
evalPlutusScripts [PlutusWithContext (EraCrypto era)]
sLst of
          Passes [PlutusWithContext (EraCrypto era)]
_ ->
            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 (EraCrypto era)]
ps NonEmpty (ScriptFailure (EraCrypto era))
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 (EraCrypto era))
-> AlonzoUtxosEvent era
SuccessfulPlutusScriptsEvent @era) (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusWithContext (EraCrypto era)]
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 (EraCrypto era))
-> AlonzoUtxosEvent era
FailedPlutusScriptsEvent (forall c. ScriptFailure c -> PlutusWithContext c
scriptFailurePlutus forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (ScriptFailure (EraCrypto era))
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 (EraCrypto era)) (TxOut era)
utxoKeep, Map (TxIn (EraCrypto era)) (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 (EraCrypto era)) (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 (EraCrypto era)))
collateralInputsTxBodyL)
      UTxO Map (TxIn (EraCrypto era)) (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 (EraCrypto era)) (TxOut era) -> DeltaCoin
collAdaBalance TxBody era
txBody Map (TxIn (EraCrypto era)) (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)
us {- (collInputs txb ⋪ utxo) ∪ collouts tx -}
      { utxosUtxo :: UTxO era
utxosUtxo = forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO (forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map (TxIn (EraCrypto era)) (TxOut era)
utxoKeep Map (TxIn (EraCrypto era)) (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
      , utxosStakeDistr :: IncrementalStake (EraCrypto era)
utxosStakeDistr = forall era.
EraTxOut era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> UTxO era
-> UTxO era
-> IncrementalStake (EraCrypto era)
updateStakeDistribution PParams era
pp (forall era. UTxOState era -> IncrementalStake (EraCrypto era)
utxosStakeDistr State (EraRule "UTXOS" era)
us) (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (EraCrypto era)) (TxOut era)
utxoDel) (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (EraCrypto era)) (TxOut era)
collouts)
      }