{-# 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
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
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)
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
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 ->
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 ()
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$!
State (EraRule "UTXOS" era)
us
{ 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)
, utxosFees :: Coin
utxosFees = Coin
fees forall a. Semigroup a => a -> a -> a
<> Integer -> Coin
Coin Integer
collateralFees
, 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)
}