{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Babbage.Rules.Utxos where

import Cardano.Binary (ToCBOR (..))
import Cardano.Ledger.Alonzo.PlutusScriptApi
  ( collectTwoPhaseScriptInputs,
    evalScripts,
  )
import Cardano.Ledger.Alonzo.Rules.Utxos
  ( TagMismatchDescription (..),
    UtxosEvent (..),
    UtxosPredicateFailure (..),
    invalidBegin,
    invalidEnd,
    scriptFailuresToPlutusDebug,
    scriptFailuresToPredicateFailure,
    validBegin,
    validEnd,
    when2Phase,
  )
import qualified Cardano.Ledger.Alonzo.Scripts as Alonzo
import Cardano.Ledger.Alonzo.Tx (IsValid (..))
import Cardano.Ledger.Alonzo.TxInfo (ExtendedUTxO, ScriptResult (Fails, Passes))
import Cardano.Ledger.Alonzo.TxWitness (TxWitness (..))
import qualified Cardano.Ledger.Babbage.Collateral as Babbage
import qualified Cardano.Ledger.Babbage.PParams as Babbage
import Cardano.Ledger.Babbage.Tx (ValidatedTx (..))
import qualified Cardano.Ledger.Babbage.Tx as Babbage
import qualified Cardano.Ledger.Babbage.TxBody as Babbage
import Cardano.Ledger.BaseTypes (ShelleyBase, epochInfo, systemStart)
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era (Era (..), ValidateScript)
import qualified Cardano.Ledger.Mary.Value as Mary
import Cardano.Ledger.Shelley.LedgerState (PPUPState (..), UTxOState (..), keyRefunds, updateStakeDistribution)
import Cardano.Ledger.Shelley.PParams (Update)
import Cardano.Ledger.Shelley.Rules.Ppup (PPUP, PPUPEnv (..), PpupPredicateFailure)
import Cardano.Ledger.Shelley.Rules.Utxo (UtxoEnv (..), updateUTxOState)
import Cardano.Ledger.Shelley.UTxO (UTxO (..), totalDeposits)
import Cardano.Ledger.TxIn (TxIn)
import qualified Cardano.Ledger.Val as Val
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition.Extended
import Data.Foldable (toList)
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as Map
import Data.MapExtras (extractKeys)
import Data.Maybe.Strict
import Data.Set (Set)
import Debug.Trace (traceEvent)
import GHC.Records (HasField (..))

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

type ConcreteBabbage era =
  ( Core.Script era ~ Alonzo.Script era,
    Core.Value era ~ Mary.Value (Crypto era),
    Core.TxBody era ~ Babbage.TxBody era,
    Core.PParams era ~ Babbage.PParams era,
    Core.PParamsDelta era ~ Babbage.PParamsUpdate era,
    Core.TxOut era ~ Babbage.TxOut era,
    Core.Tx era ~ ValidatedTx era,
    Core.Witnesses era ~ TxWitness era
  )

data BabbageUTXOS era

instance
  forall era.
  ( Era era,
    ConcreteBabbage era,
    ExtendedUTxO era,
    Embed (Core.EraRule "PPUP" era) (BabbageUTXOS era),
    Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
    State (Core.EraRule "PPUP" era) ~ PPUPState era,
    Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
    ValidateScript era,
    ToCBOR (PredicateFailure (Core.EraRule "PPUP" era)) -- Serializing the PredicateFailure
  ) =>
  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) = ValidatedTx era
  type PredicateFailure (BabbageUTXOS era) = UtxosPredicateFailure era
  type Event (BabbageUTXOS era) = UtxosEvent era
  transitionRules :: [TransitionRule (BabbageUTXOS era)]
transitionRules = [TransitionRule (BabbageUTXOS era)
forall era.
(ConcreteBabbage era, ExtendedUTxO era,
 Environment (EraRule "PPUP" era) ~ PPUPEnv era,
 State (EraRule "PPUP" era) ~ PPUPState era,
 Signal (EraRule "PPUP" era) ~ Maybe (Update era),
 Embed (EraRule "PPUP" era) (BabbageUTXOS era), ValidateScript era,
 ToCBOR (PredicateFailure (EraRule "PPUP" era)),
 HasField "collateral" (TxBody era) (Set (TxIn (Crypto era)))) =>
TransitionRule (BabbageUTXOS era)
utxosTransition]

instance
  ( Era era,
    STS (PPUP era),
    PredicateFailure (Core.EraRule "PPUP" era) ~ PpupPredicateFailure era,
    Event (Core.EraRule "PPUP" era) ~ Event (PPUP era)
  ) =>
  Embed (PPUP era) (BabbageUTXOS era)
  where
  wrapFailed :: PredicateFailure (PPUP era) -> PredicateFailure (BabbageUTXOS era)
wrapFailed = PredicateFailure (PPUP era) -> PredicateFailure (BabbageUTXOS era)
forall era.
PredicateFailure (EraRule "PPUP" era) -> UtxosPredicateFailure era
UpdateFailure
  wrapEvent :: Event (PPUP era) -> Event (BabbageUTXOS era)
wrapEvent = Event (PPUP era) -> Event (BabbageUTXOS era)
forall era. Event (EraRule "PPUP" era) -> UtxosEvent era
AlonzoPpupToUtxosEvent

utxosTransition ::
  forall era.
  ( ConcreteBabbage era,
    ExtendedUTxO era,
    Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
    State (Core.EraRule "PPUP" era) ~ PPUPState era,
    Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
    Embed (Core.EraRule "PPUP" era) (BabbageUTXOS era),
    ValidateScript era,
    ToCBOR (PredicateFailure (Core.EraRule "PPUP" era)),
    HasField "collateral" (Babbage.TxBody era) (Set (TxIn (Crypto era)))
  ) =>
  TransitionRule (BabbageUTXOS era)
utxosTransition :: TransitionRule (BabbageUTXOS era)
utxosTransition =
  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) (UTxOState era))
-> F (Clause (BabbageUTXOS era) 'Transition) (UTxOState era)
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 ValidatedTx era -> IsValid
forall k (x :: k) r a. HasField x r a => r -> a
getField @"isValid" ValidatedTx era
Signal (BabbageUTXOS era)
tx of
      IsValid Bool
True -> F (Clause (BabbageUTXOS era) 'Transition) (UTxOState era)
forall era.
(ValidateScript era, ConcreteBabbage era, ExtendedUTxO era,
 STS (BabbageUTXOS era),
 Environment (EraRule "PPUP" era) ~ PPUPEnv era,
 State (EraRule "PPUP" era) ~ PPUPState era,
 Signal (EraRule "PPUP" era) ~ Maybe (Update era),
 Embed (EraRule "PPUP" era) (BabbageUTXOS era)) =>
TransitionRule (BabbageUTXOS era)
scriptsYes
      IsValid Bool
False -> F (Clause (BabbageUTXOS era) 'Transition) (UTxOState era)
forall era.
(ValidateScript era, ConcreteBabbage era, ExtendedUTxO era,
 STS (BabbageUTXOS era),
 HasField "collateral" (TxBody era) (Set (TxIn (Crypto era)))) =>
TransitionRule (BabbageUTXOS era)
scriptsNo

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

scriptsYes ::
  forall era.
  ( ValidateScript era,
    ConcreteBabbage era,
    ExtendedUTxO era,
    STS (BabbageUTXOS era),
    Environment (Core.EraRule "PPUP" era) ~ PPUPEnv era,
    State (Core.EraRule "PPUP" era) ~ PPUPState era,
    Signal (Core.EraRule "PPUP" era) ~ Maybe (Update era),
    Embed (Core.EraRule "PPUP" era) (BabbageUTXOS era)
  ) =>
  TransitionRule (BabbageUTXOS era)
scriptsYes :: TransitionRule (BabbageUTXOS era)
scriptsYes = do
  TRC (UtxoEnv slot pp poolParams genDelegs, u :: State (BabbageUTXOS era)
u@(UTxOState utxo _ _ pup _), Signal (BabbageUTXOS era)
tx) <-
    F (Clause (BabbageUTXOS era) 'Transition) (TRC (BabbageUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  let {- txb := txbody tx -}
      txb :: TxBody era
txb = ValidatedTx era -> TxBody era
forall era. ValidatedTx era -> TxBody era
body ValidatedTx era
Signal (BabbageUTXOS era)
tx
      {- refunded := keyRefunds pp txb -}
      refunded :: Coin
refunded = PParams era -> TxBody era -> Coin
forall txb crypto pp.
(HasField "certs" txb (StrictSeq (DCert crypto)),
 HasField "_keyDeposit" pp Coin) =>
pp -> txb -> Coin
keyRefunds PParams era
PParams era
pp TxBody era
TxBody era
txb
      txcerts :: [DCert (Crypto era)]
txcerts = StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)])
-> StrictSeq (DCert (Crypto era)) -> [DCert (Crypto era)]
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictSeq (DCert (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
TxBody era
txb
      {- depositChange := (totalDeposits pp poolParams txcerts txb) − refunded -}
      depositChange :: Coin
depositChange =
        PParams era
-> (KeyHash 'StakePool (Crypto era) -> Bool)
-> [DCert (Crypto era)]
-> Coin
forall pp crypto.
(HasField "_poolDeposit" pp Coin,
 HasField "_keyDeposit" pp Coin) =>
pp -> (KeyHash 'StakePool crypto -> Bool) -> [DCert crypto] -> Coin
totalDeposits PParams era
PParams era
pp (KeyHash 'StakePool (Crypto era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
-> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map (KeyHash 'StakePool (Crypto era)) (PoolParams (Crypto era))
poolParams) [DCert (Crypto era)]
txcerts Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
Val.<-> Coin
refunded
  SystemStart
sysSt <- BaseM (BabbageUTXOS era) SystemStart
-> Rule (BabbageUTXOS era) 'Transition SystemStart
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (BabbageUTXOS era) SystemStart
 -> Rule (BabbageUTXOS era) 'Transition SystemStart)
-> BaseM (BabbageUTXOS era) SystemStart
-> Rule (BabbageUTXOS era) 'Transition SystemStart
forall a b. (a -> b) -> a -> b
$ (Globals -> SystemStart) -> ReaderT Globals Identity SystemStart
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> SystemStart
systemStart
  EpochInfo (Either Text)
ei <- BaseM (BabbageUTXOS era) (EpochInfo (Either Text))
-> Rule (BabbageUTXOS era) 'Transition (EpochInfo (Either Text))
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (BabbageUTXOS era) (EpochInfo (Either Text))
 -> Rule (BabbageUTXOS era) 'Transition (EpochInfo (Either Text)))
-> BaseM (BabbageUTXOS era) (EpochInfo (Either Text))
-> Rule (BabbageUTXOS era) 'Transition (EpochInfo (Either Text))
forall a b. (a -> b) -> a -> b
$ (Globals -> EpochInfo (Either Text))
-> ReaderT Globals Identity (EpochInfo (Either Text))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo (Either Text)
epochInfo

  -- 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`
  PPUPState era
ppup' <-
    forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
forall super (rtype :: RuleType).
Embed (EraRule "PPUP" era) super =>
RuleContext rtype (EraRule "PPUP" era)
-> Rule super rtype (State (EraRule "PPUP" era))
trans @(Core.EraRule "PPUP" era) (RuleContext 'Transition (EraRule "PPUP" era)
 -> Rule
      (BabbageUTXOS era) 'Transition (State (EraRule "PPUP" era)))
-> RuleContext 'Transition (EraRule "PPUP" era)
-> Rule (BabbageUTXOS era) 'Transition (State (EraRule "PPUP" era))
forall a b. (a -> b) -> a -> b
$
      (Environment (EraRule "PPUP" era), State (EraRule "PPUP" era),
 Signal (EraRule "PPUP" era))
-> TRC (EraRule "PPUP" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC
        (SlotNo -> PParams era -> GenDelegs (Crypto era) -> PPUPEnv era
forall era.
SlotNo -> PParams era -> GenDelegs (Crypto era) -> PPUPEnv era
PPUPEnv SlotNo
slot PParams era
pp GenDelegs (Crypto era)
genDelegs, State (EraRule "PPUP" era)
pup, StrictMaybe (Update era) -> Maybe (Update era)
forall a. StrictMaybe a -> Maybe a
strictMaybeToMaybe (StrictMaybe (Update era) -> Maybe (Update era))
-> StrictMaybe (Update era) -> Maybe (Update era)
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictMaybe (Update era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"update" TxBody era
TxBody era
txb)

  let !()
_ = String -> () -> ()
forall a. String -> a -> a
traceEvent String
validBegin ()

  {- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
  case EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either
     [CollectError (Crypto era)]
     [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
forall era.
(Era era, ExtendedUTxO era, Script era ~ Script era,
 HasField "_costmdls" (PParams era) CostModels,
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "wits" (Tx era) (TxWitness era)) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either
     [CollectError (Crypto era)]
     [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
collectTwoPhaseScriptInputs EpochInfo (Either Text)
ei SystemStart
sysSt PParams era
pp Tx era
Signal (BabbageUTXOS era)
tx UTxO era
utxo of
    Right [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
sLst ->
      {- isValid tx = evalScripts tx sLst = True -}
      F (Clause (BabbageUTXOS era) 'Transition) ()
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
whenFailureFree (F (Clause (BabbageUTXOS era) 'Transition) ()
 -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> F (Clause (BabbageUTXOS era) 'Transition) ()
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        F (Clause (BabbageUTXOS era) 'Transition) ()
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
when2Phase (F (Clause (BabbageUTXOS era) 'Transition) ()
 -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> F (Clause (BabbageUTXOS era) 'Transition) ()
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
          case ProtVer
-> ValidatedTx era
-> [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
-> ScriptResult
forall era tx.
(Era era, Show (Script era), HasField "body" tx (TxBody era),
 HasField "wits" tx (TxWitness era),
 HasField "vldt" (TxBody era) ValidityInterval) =>
ProtVer
-> tx
-> [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
-> ScriptResult
evalScripts @era (PParams era -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" PParams era
PParams era
pp) ValidatedTx era
Signal (BabbageUTXOS era)
tx [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
sLst of
            Fails [PlutusDebug]
_ NonEmpty ScriptFailure
fs ->
              PredicateFailure (BabbageUTXOS era)
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (BabbageUTXOS era)
 -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> PredicateFailure (BabbageUTXOS era)
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
                IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
forall era.
IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
ValidationTagMismatch
                  (ValidatedTx era -> IsValid
forall k (x :: k) r a. HasField x r a => r -> a
getField @"isValid" ValidatedTx era
Signal (BabbageUTXOS era)
tx)
                  (NonEmpty FailureDescription -> TagMismatchDescription
FailedUnexpectedly (NonEmpty ScriptFailure -> NonEmpty FailureDescription
scriptFailuresToPredicateFailure NonEmpty ScriptFailure
fs))
            Passes [PlutusDebug]
ps -> (NonEmpty PlutusDebug
 -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> Maybe (NonEmpty PlutusDebug)
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UtxosEvent era -> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (UtxosEvent era -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> (NonEmpty PlutusDebug -> UtxosEvent era)
-> NonEmpty PlutusDebug
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PlutusDebug -> UtxosEvent era
forall era. NonEmpty PlutusDebug -> UtxosEvent era
SuccessfulPlutusScriptsEvent) ([PlutusDebug] -> Maybe (NonEmpty PlutusDebug)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusDebug]
ps)
    Left [CollectError (Crypto era)]
info -> PredicateFailure (BabbageUTXOS era)
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause ([CollectError (Crypto era)] -> UtxosPredicateFailure era
forall era.
[CollectError (Crypto era)] -> UtxosPredicateFailure era
CollectErrors [CollectError (Crypto era)]
info)

  let !()
_ = String -> () -> ()
forall a. String -> a -> a
traceEvent String
validEnd ()

  UTxOState era
-> F (Clause (BabbageUTXOS era) 'Transition) (UTxOState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxOState era
 -> F (Clause (BabbageUTXOS era) 'Transition) (UTxOState era))
-> UTxOState era
-> F (Clause (BabbageUTXOS era) 'Transition) (UTxOState era)
forall a b. (a -> b) -> a -> b
$! UTxOState era
-> TxBody era
-> Coin
-> State (EraRule "PPUP" era)
-> UTxOState era
forall era.
(Era era,
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era)))) =>
UTxOState era
-> TxBody era
-> Coin
-> State (EraRule "PPUP" era)
-> UTxOState era
updateUTxOState UTxOState era
State (BabbageUTXOS era)
u TxBody era
txb Coin
depositChange PPUPState era
State (EraRule "PPUP" era)
ppup'

scriptsNo ::
  forall era.
  ( ValidateScript era,
    ConcreteBabbage era,
    ExtendedUTxO era,
    STS (BabbageUTXOS era),
    HasField "collateral" (Babbage.TxBody era) (Set (TxIn (Crypto era)))
  ) =>
  TransitionRule (BabbageUTXOS era)
scriptsNo :: TransitionRule (BabbageUTXOS era)
scriptsNo = do
  TRC (UtxoEnv _ pp _ _, us :: State (BabbageUTXOS era)
us@(UTxOState utxo _ fees _ _), Signal (BabbageUTXOS era)
tx) <- F (Clause (BabbageUTXOS era) 'Transition) (TRC (BabbageUTXOS era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  {- txb := txbody tx -}
  let txb :: TxBody era
txb = ValidatedTx era -> TxBody era
forall era. ValidatedTx era -> TxBody era
body ValidatedTx era
Signal (BabbageUTXOS era)
tx
  SystemStart
sysSt <- BaseM (BabbageUTXOS era) SystemStart
-> Rule (BabbageUTXOS era) 'Transition SystemStart
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (BabbageUTXOS era) SystemStart
 -> Rule (BabbageUTXOS era) 'Transition SystemStart)
-> BaseM (BabbageUTXOS era) SystemStart
-> Rule (BabbageUTXOS era) 'Transition SystemStart
forall a b. (a -> b) -> a -> b
$ (Globals -> SystemStart) -> ReaderT Globals Identity SystemStart
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> SystemStart
systemStart
  EpochInfo (Either Text)
ei <- BaseM (BabbageUTXOS era) (EpochInfo (Either Text))
-> Rule (BabbageUTXOS era) 'Transition (EpochInfo (Either Text))
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (BabbageUTXOS era) (EpochInfo (Either Text))
 -> Rule (BabbageUTXOS era) 'Transition (EpochInfo (Either Text)))
-> BaseM (BabbageUTXOS era) (EpochInfo (Either Text))
-> Rule (BabbageUTXOS era) 'Transition (EpochInfo (Either Text))
forall a b. (a -> b) -> a -> b
$ (Globals -> EpochInfo (Either Text))
-> ReaderT Globals Identity (EpochInfo (Either Text))
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> EpochInfo (Either Text)
epochInfo

  () <- () -> F (Clause (BabbageUTXOS era) 'Transition) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> () -> F (Clause (BabbageUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$! String -> () -> ()
forall a. String -> a -> a
traceEvent String
invalidBegin ()

  case EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either
     [CollectError (Crypto era)]
     [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
forall era.
(Era era, ExtendedUTxO era, Script era ~ Script era,
 HasField "_costmdls" (PParams era) CostModels,
 HasField "wdrls" (TxBody era) (Wdrl (Crypto era)),
 HasField "certs" (TxBody era) (StrictSeq (DCert (Crypto era))),
 HasField "inputs" (TxBody era) (Set (TxIn (Crypto era))),
 HasField "wits" (Tx era) (TxWitness era)) =>
EpochInfo (Either Text)
-> SystemStart
-> PParams era
-> Tx era
-> UTxO era
-> Either
     [CollectError (Crypto era)]
     [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
collectTwoPhaseScriptInputs EpochInfo (Either Text)
ei SystemStart
sysSt PParams era
pp Tx era
Signal (BabbageUTXOS era)
tx UTxO era
utxo of
    Right [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
sLst ->
      {- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
      {- isValid tx = evalScripts tx sLst = False -}
      F (Clause (BabbageUTXOS era) 'Transition) ()
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
whenFailureFree (F (Clause (BabbageUTXOS era) 'Transition) ()
 -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> F (Clause (BabbageUTXOS era) 'Transition) ()
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$
        F (Clause (BabbageUTXOS era) 'Transition) ()
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (rtype :: RuleType).
Rule sts rtype () -> Rule sts rtype ()
when2Phase (F (Clause (BabbageUTXOS era) 'Transition) ()
 -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> F (Clause (BabbageUTXOS era) 'Transition) ()
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ case ProtVer
-> ValidatedTx era
-> [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
-> ScriptResult
forall era tx.
(Era era, Show (Script era), HasField "body" tx (TxBody era),
 HasField "wits" tx (TxWitness era),
 HasField "vldt" (TxBody era) ValidityInterval) =>
ProtVer
-> tx
-> [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
-> ScriptResult
evalScripts @era (PParams era -> ProtVer
forall k (x :: k) r a. HasField x r a => r -> a
getField @"_protocolVersion" PParams era
PParams era
pp) ValidatedTx era
Signal (BabbageUTXOS era)
tx [(ShortByteString, Language, [Data era], ExUnits, CostModel)]
sLst of
          Passes [PlutusDebug]
_ -> PredicateFailure (BabbageUTXOS era)
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause (PredicateFailure (BabbageUTXOS era)
 -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> PredicateFailure (BabbageUTXOS era)
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$ IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
forall era.
IsValid -> TagMismatchDescription -> UtxosPredicateFailure era
ValidationTagMismatch (ValidatedTx era -> IsValid
forall k (x :: k) r a. HasField x r a => r -> a
getField @"isValid" ValidatedTx era
Signal (BabbageUTXOS era)
tx) TagMismatchDescription
PassedUnexpectedly
          Fails [PlutusDebug]
ps NonEmpty ScriptFailure
fs -> do
            (NonEmpty PlutusDebug
 -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> Maybe (NonEmpty PlutusDebug)
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (UtxosEvent era -> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (UtxosEvent era -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> (NonEmpty PlutusDebug -> UtxosEvent era)
-> NonEmpty PlutusDebug
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty PlutusDebug -> UtxosEvent era
forall era. NonEmpty PlutusDebug -> UtxosEvent era
SuccessfulPlutusScriptsEvent) ([PlutusDebug] -> Maybe (NonEmpty PlutusDebug)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [PlutusDebug]
ps)
            Event (BabbageUTXOS era)
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType). Event sts -> Rule sts ctx ()
tellEvent (NonEmpty PlutusDebug -> UtxosEvent era
forall era. NonEmpty PlutusDebug -> UtxosEvent era
FailedPlutusScriptsEvent (NonEmpty ScriptFailure -> NonEmpty PlutusDebug
scriptFailuresToPlutusDebug NonEmpty ScriptFailure
fs))
    Left [CollectError (Crypto era)]
info -> PredicateFailure (BabbageUTXOS era)
-> F (Clause (BabbageUTXOS era) 'Transition) ()
forall sts (ctx :: RuleType).
PredicateFailure sts -> Rule sts ctx ()
failBecause ([CollectError (Crypto era)] -> UtxosPredicateFailure era
forall era.
[CollectError (Crypto era)] -> UtxosPredicateFailure era
CollectErrors [CollectError (Crypto era)]
info)

  () <- () -> F (Clause (BabbageUTXOS era) 'Transition) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> F (Clause (BabbageUTXOS era) 'Transition) ())
-> () -> F (Clause (BabbageUTXOS era) 'Transition) ()
forall a b. (a -> b) -> a -> b
$! String -> () -> ()
forall a. String -> a -> a
traceEvent String
invalidEnd ()

  {- utxoKeep = getField @"collateral" txb ⋪ utxo -}
  {- utxoDel  = getField @"collateral" txb ◁ utxo -}
  let !(Map (TxIn (Crypto era)) (TxOut era)
utxoKeep, Map (TxIn (Crypto era)) (TxOut era)
utxoDel) = Map (TxIn (Crypto era)) (TxOut era)
-> Set (TxIn (Crypto era))
-> (Map (TxIn (Crypto era)) (TxOut era),
    Map (TxIn (Crypto era)) (TxOut era))
forall k a. Ord k => Map k a -> Set k -> (Map k a, Map k a)
extractKeys (UTxO era -> Map (TxIn (Crypto era)) (TxOut era)
forall era. UTxO era -> Map (TxIn (Crypto era)) (TxOut era)
unUTxO UTxO era
utxo) (TxBody era -> Set (TxIn (Crypto era))
forall k (x :: k) r a. HasField x r a => r -> a
getField @"collateral" TxBody era
TxBody era
txb)
      UTxO Map (TxIn (Crypto era)) (TxOut era)
collouts = TxBody era -> UTxO era
forall era.
(Era era, TxBody era ~ TxBody era, TxOut era ~ TxOut era) =>
TxBody era -> UTxO era
Babbage.collOuts TxBody era
TxBody era
txb
      collateralFees :: Coin
collateralFees = Value (Crypto era) -> Coin
forall t. Val t => t -> Coin
Val.coin (TxBody era -> UTxO era -> Value era
forall era.
(Era era,
 HasField "collateralReturn" (TxBody era) (StrictMaybe (TxOut era)),
 HasField "collateral" (TxBody era) (Set (TxIn (Crypto era)))) =>
TxBody era -> UTxO era -> Value era
Babbage.collBalance TxBody era
txb UTxO era
utxo) -- NEW to Babbage
  UTxOState era
-> F (Clause (BabbageUTXOS era) 'Transition) (UTxOState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (UTxOState era
 -> F (Clause (BabbageUTXOS era) 'Transition) (UTxOState era))
-> UTxOState era
-> F (Clause (BabbageUTXOS era) 'Transition) (UTxOState era)
forall a b. (a -> b) -> a -> b
$! UTxOState era
State (BabbageUTXOS era)
us {- (collInputs txb ⋪ utxo) ∪ collouts tx -}
      { _utxo :: UTxO era
_utxo = Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO (Map (TxIn (Crypto era)) (TxOut era)
-> Map (TxIn (Crypto era)) (TxOut era)
-> Map (TxIn (Crypto era)) (TxOut era)
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map (TxIn (Crypto era)) (TxOut era)
utxoKeep Map (TxIn (Crypto era)) (TxOut era)
Map (TxIn (Crypto era)) (TxOut era)
collouts), -- NEW to Babbage
      {- fees + collateralFees -}
        _fees :: Coin
_fees = Coin
fees Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
collateralFees, -- NEW to Babbage
        _stakeDistro :: IncrementalStake (Crypto era)
_stakeDistro = IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
forall era.
Era era =>
IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
updateStakeDistribution (UTxOState era -> IncrementalStake (Crypto era)
forall era. UTxOState era -> IncrementalStake (Crypto era)
_stakeDistro UTxOState era
State (BabbageUTXOS era)
us) (Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto era)) (TxOut era)
Map (TxIn (Crypto era)) (TxOut era)
utxoDel) (Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto era)) (TxOut era)
collouts)
      }