Update UTxOState and send events in UTXO rather than UTXOS in conway

Author: teodanciu

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.21.0.0
 
+* Change `STS` instance of `ConwayUTOXS`: use `PParams` as `Environment`
+* Remove `TotalDeposits` and `TxUTxODiff` data constructors from `ConwayUtxosEvent`
 * Add `Generic` instance for `ApplyTxError`
 * Change `ScriptsNotPaidUTxO` to use `NonEmptyMap TxIn (TxOut era)` instead of `UTxO era`
 * Add `conwayLedgerTransitionTRC`

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxo.hs

@@ -26,18 +26,20 @@ module Cardano.Ledger.Conway.Rules.Utxo (
 import Cardano.Ledger.Allegra.Rules (AllegraUtxoPredFailure, shelleyToAllegraUtxoPredFailure)
 import qualified Cardano.Ledger.Allegra.Rules as Allegra (AllegraUtxoPredFailure (..))
 import Cardano.Ledger.Alonzo.Rules (
-  AlonzoUtxoEvent,
+  AlonzoUtxoEvent (..),
   AlonzoUtxoPredFailure,
   AlonzoUtxosPredFailure,
  )
 import qualified Cardano.Ledger.Alonzo.Rules as Alonzo (
-  AlonzoUtxoEvent (UtxosEvent),
   AlonzoUtxoPredFailure (..),
  )
-import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure)
+import Cardano.Ledger.Babbage.Rules (
+  BabbageUtxoPredFailure,
+  babbageUtxoValidation,
+  updateUTxOStateByTxValidity,
+ )
 import qualified Cardano.Ledger.Babbage.Rules as Babbage (
   BabbageUtxoPredFailure (..),
-  utxoTransition,
  )
 import Cardano.Ledger.BaseTypes (
   Mismatch (..),
@@ -65,13 +67,16 @@ import Cardano.Ledger.Conway.Rules.Utxos (
   ConwayUtxosPredFailure (..),
  )
 import Cardano.Ledger.Plutus (ExUnits)
-import qualified Cardano.Ledger.Shelley.LedgerState as Shelley (UTxOState)
-import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, UtxoEnv (..))
-import qualified Cardano.Ledger.Shelley.Rules as Shelley (UtxoEnv, validSizeComputationCheck)
-import Cardano.Ledger.State (EraCertState (..), EraUTxO)
+import Cardano.Ledger.Shelley.LedgerState (UTxOState (..))
+import Cardano.Ledger.Shelley.Rules (
+  ShelleyUtxoPredFailure,
+  UtxoEnv (..),
+  validSizeComputationCheck,
+ )
+import Cardano.Ledger.State (EraCertState (..), EraStake, EraUTxO)
 import Cardano.Ledger.TxIn (TxIn)
 import Control.DeepSeq (NFData)
-import Control.State.Transition.Extended (Embed (..), STS (..))
+import Control.State.Transition.Extended
 import Data.List.NonEmpty (NonEmpty)
 import Data.Map.NonEmpty (NonEmptyMap)
 import Data.Set.NonEmpty (NonEmptySet)
@@ -174,7 +179,7 @@ instance InjectRuleFailure "UTXO" ShelleyUtxoPredFailure ConwayEra where
     allegraToConwayUtxoPredFailure
       . shelleyToAllegraUtxoPredFailure
 
-instance InjectRuleFailure "UTXO" Allegra.AllegraUtxoPredFailure ConwayEra where
+instance InjectRuleFailure "UTXO" AllegraUtxoPredFailure ConwayEra where
   injectFailure = allegraToConwayUtxoPredFailure
 
 instance InjectRuleFailure "UTXO" AlonzoUtxosPredFailure ConwayEra where
@@ -216,6 +221,36 @@ instance
   ) =>
   NFData (ConwayUtxoPredFailure era)
 
+conwayUtxoTransition ::
+  forall era.
+  ( EraUTxO era
+  , EraCertState era
+  , BabbageEraTxBody era
+  , AlonzoEraTx era
+  , EraStake era
+  , InjectRuleFailure "UTXO" ShelleyUtxoPredFailure era
+  , InjectRuleFailure "UTXO" AllegraUtxoPredFailure era
+  , InjectRuleFailure "UTXO" AlonzoUtxoPredFailure era
+  , InjectRuleFailure "UTXO" BabbageUtxoPredFailure era
+  , Environment (EraRule "UTXO" era) ~ UtxoEnv era
+  , State (EraRule "UTXO" era) ~ UTxOState era
+  , Signal (EraRule "UTXO" era) ~ Tx TopTx era
+  , BaseM (EraRule "UTXO" era) ~ ShelleyBase
+  , STS (EraRule "UTXO" era)
+  , Event (EraRule "UTXO" era) ~ AlonzoUtxoEvent era
+  , -- In this function we we call the UTXOS rule, so we need some assumptions
+    Environment (EraRule "UTXOS" era) ~ PParams era
+  , State (EraRule "UTXOS" era) ~ UTxOState era
+  , Signal (EraRule "UTXOS" era) ~ Tx TopTx era
+  , Embed (EraRule "UTXOS" era) (EraRule "UTXO" era)
+  ) =>
+  TransitionRule (EraRule "UTXO" era)
+conwayUtxoTransition = do
+  TRC (UtxoEnv _ pp certState, utxos, tx) <- judgmentContext
+  babbageUtxoValidation
+  updatedUtxos <- trans @(EraRule "UTXOS" era) $ TRC (pp, utxos, tx)
+  updateUTxOStateByTxValidity pp certState (utxosGovState utxos) tx updatedUtxos
+
 --------------------------------------------------------------------------------
 -- ConwayUTXO STS
 --------------------------------------------------------------------------------
@@ -225,35 +260,36 @@ instance
   ( EraTx era
   , EraUTxO era
   , ConwayEraTxBody era
-  , AlonzoEraTxWits era
+  , AlonzoEraTx era
+  , EraStake era
   , EraRule "UTXO" era ~ ConwayUTXO era
   , InjectRuleFailure "UTXO" ShelleyUtxoPredFailure era
   , InjectRuleFailure "UTXO" AllegraUtxoPredFailure era
   , InjectRuleFailure "UTXO" AlonzoUtxoPredFailure era
   , InjectRuleFailure "UTXO" BabbageUtxoPredFailure era
   , InjectRuleFailure "UTXO" ConwayUtxoPredFailure era
   , Embed (EraRule "UTXOS" era) (ConwayUTXO era)
-  , Environment (EraRule "UTXOS" era) ~ Shelley.UtxoEnv era
-  , State (EraRule "UTXOS" era) ~ Shelley.UTxOState era
+  , Environment (EraRule "UTXOS" era) ~ PParams era
+  , State (EraRule "UTXOS" era) ~ UTxOState era
   , Signal (EraRule "UTXOS" era) ~ Tx TopTx era
   , PredicateFailure (EraRule "UTXO" era) ~ ConwayUtxoPredFailure era
   , EraCertState era
   , SafeToHash (TxWits era)
   ) =>
   STS (ConwayUTXO era)
   where
-  type State (ConwayUTXO era) = Shelley.UTxOState era
+  type State (ConwayUTXO era) = UTxOState era
   type Signal (ConwayUTXO era) = Tx TopTx era
-  type Environment (ConwayUTXO era) = Shelley.UtxoEnv era
+  type Environment (ConwayUTXO era) = UtxoEnv era
   type BaseM (ConwayUTXO era) = ShelleyBase
   type PredicateFailure (ConwayUTXO era) = ConwayUtxoPredFailure era
   type Event (ConwayUTXO era) = AlonzoUtxoEvent era
 
   initialRules = []
 
-  transitionRules = [Babbage.utxoTransition @era]
+  transitionRules = [conwayUtxoTransition]
 
-  assertions = [Shelley.validSizeComputationCheck]
+  assertions = [validSizeComputationCheck]
 
 instance
   ( Era era
@@ -264,7 +300,7 @@ instance
   Embed (ConwayUTXOS era) (ConwayUTXO era)
   where
   wrapFailed = UtxosFailure
-  wrapEvent = Alonzo.UtxosEvent
+  wrapEvent = UtxosEvent
 
 --------------------------------------------------------------------------------
 -- Serialisation
@@ -381,7 +417,7 @@ alonzoToConwayUtxoPredFailure = \case
 allegraToConwayUtxoPredFailure ::
   forall era.
   EraRuleFailure "PPUP" era ~ VoidEraRule "PPUP" era =>
-  Allegra.AllegraUtxoPredFailure era ->
+  AllegraUtxoPredFailure era ->
   ConwayUtxoPredFailure era
 allegraToConwayUtxoPredFailure = \case
   Allegra.BadInputsUTxO x -> BadInputsUTxO x

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Utxos.hs

@@ -49,7 +49,7 @@ import Cardano.Ledger.Babbage.Rules (
   expectScriptsToPass,
  )
 import Cardano.Ledger.Babbage.Tx
-import Cardano.Ledger.BaseTypes (ShelleyBase)
+import Cardano.Ledger.BaseTypes
 import Cardano.Ledger.Binary (
   DecCBOR (..),
   EncCBOR (..),
@@ -64,6 +64,7 @@ import Cardano.Ledger.Plutus (PlutusWithContext)
 import Cardano.Ledger.Shelley.LedgerState (UTxOState (..), utxosDonationL)
 import Cardano.Ledger.Shelley.Rules (UtxoEnv (..), updateUTxOState)
 import Control.DeepSeq (NFData)
+import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition.Extended
 import Data.List.NonEmpty (NonEmpty)
 import qualified Debug.Trace as Debug
@@ -86,20 +87,13 @@ data ConwayUtxosPredFailure era
     (Generic)
 
 data ConwayUtxosEvent era
-  = TotalDeposits (SafeHash EraIndependentTxBody) Coin
-  | SuccessfulPlutusScriptsEvent (NonEmpty PlutusWithContext)
+  = SuccessfulPlutusScriptsEvent (NonEmpty PlutusWithContext)
   | FailedPlutusScriptsEvent (NonEmpty PlutusWithContext)
-  | -- | The UTxOs consumed and created by a signal tx
-    TxUTxODiff
-      -- | UTxO consumed
-      (UTxO era)
-      -- | UTxO created
-      (UTxO era)
   deriving (Generic)
 
-deriving instance (Era era, Eq (TxOut era)) => Eq (ConwayUtxosEvent era)
+deriving instance Eq (ConwayUtxosEvent era)
 
-instance (Era era, NFData (TxOut era)) => NFData (ConwayUtxosEvent era)
+instance NFData (ConwayUtxosEvent era)
 
 type instance EraRuleFailure "UTXOS" ConwayEra = ConwayUtxosPredFailure ConwayEra
 
@@ -132,10 +126,8 @@ alonzoToConwayUtxosEvent ::
   ConwayUtxosEvent era
 alonzoToConwayUtxosEvent = \case
   Alonzo.AlonzoPpupToUtxosEvent x -> absurdEraRule @"PPUP" @era x
-  Alonzo.TotalDeposits h c -> TotalDeposits h c
   Alonzo.SuccessfulPlutusScriptsEvent l -> SuccessfulPlutusScriptsEvent l
   Alonzo.FailedPlutusScriptsEvent l -> FailedPlutusScriptsEvent l
-  Alonzo.TxUTxODiff x y -> TxUTxODiff x y
 
 instance
   ( EraTxCert era
@@ -214,7 +206,7 @@ instance
   STS (ConwayUTXOS era)
   where
   type BaseM (ConwayUTXOS era) = Cardano.Ledger.BaseTypes.ShelleyBase
-  type Environment (ConwayUTXOS era) = UtxoEnv era
+  type Environment (ConwayUTXOS era) = PParams era
   type State (ConwayUTXOS era) = UTxOState era
   type Signal (ConwayUTXOS era) = Tx TopTx era
   type PredicateFailure (ConwayUTXOS era) = ConwayUtxosPredFailure era
@@ -256,7 +248,7 @@ utxosTransition ::
   , ScriptsNeeded era ~ AlonzoScriptsNeeded era
   , Signal (EraRule "UTXOS" era) ~ Tx TopTx era
   , STS (EraRule "UTXOS" era)
-  , Environment (EraRule "UTXOS" era) ~ UtxoEnv era
+  , Environment (EraRule "UTXOS" era) ~ PParams era
   , State (EraRule "UTXOS" era) ~ UTxOState era
   , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era
   , BaseM (EraRule "UTXOS" era) ~ ShelleyBase
@@ -265,10 +257,14 @@ utxosTransition ::
   ) =>
   TransitionRule (EraRule "UTXOS" era)
 utxosTransition =
-  judgmentContext >>= \(TRC (_, _, tx)) -> do
+  judgmentContext >>= \(TRC (pp, utxos, tx)) -> do
     case tx ^. isValidTxL of
       IsValid True -> conwayEvalScriptsTxValid
-      IsValid False -> babbageEvalScriptsTxInvalid
+      IsValid False -> do
+        sysSt <- liftSTS $ asks systemStart
+        ei <- liftSTS $ asks epochInfo
+        babbageEvalScriptsTxInvalid @era ei sysSt pp tx (utxosUtxo utxos)
+        pure utxos
 
 conwayEvalScriptsTxValid ::
   forall era.
@@ -282,29 +278,19 @@ conwayEvalScriptsTxValid ::
   , Signal (EraRule "UTXOS" era) ~ Tx TopTx era
   , STS (EraRule "UTXOS" era)
   , State (EraRule "UTXOS" era) ~ UTxOState era
-  , Environment (EraRule "UTXOS" era) ~ UtxoEnv era
+  , Environment (EraRule "UTXOS" era) ~ PParams era
   , InjectRuleFailure "UTXOS" AlonzoUtxosPredFailure era
   , BaseM (EraRule "UTXOS" era) ~ ShelleyBase
   , InjectRuleEvent "UTXOS" AlonzoUtxosEvent era
   , InjectRuleEvent "UTXOS" ConwayUtxosEvent era
   ) =>
   TransitionRule (EraRule "UTXOS" era)
 conwayEvalScriptsTxValid = do
-  TRC (UtxoEnv _ pp certState, utxos@(UTxOState utxo _ _ govState _ _), tx) <-
-    judgmentContext
+  TRC (pp, utxos, tx) <- judgmentContext
   let txBody = tx ^. bodyTxL
 
   () <- pure $! Debug.traceEvent validBegin ()
-  expectScriptsToPass pp tx utxo
+  expectScriptsToPass pp tx (utxosUtxo utxos)
   () <- pure $! Debug.traceEvent validEnd ()
 
-  utxos' <-
-    updateUTxOState
-      pp
-      utxos
-      txBody
-      certState
-      govState
-      (tellEvent . injectEvent . TotalDeposits (hashAnnotated txBody))
-      (\a b -> tellEvent . injectEvent $ TxUTxODiff a b)
-  pure $! utxos' & utxosDonationL <>~ txBody ^. treasuryDonationTxBodyL
+  pure $! utxos & utxosDonationL <>~ txBody ^. treasuryDonationTxBodyL