Merge pull request #3963 from IntersectMBO/lehins/getWitsVKeyNeeded

Abstract `getWitsVKeyNeeded`

CHANGELOG.md

@@ -8,7 +8,7 @@ If you are looking for the Ledger Releasing and Versioning Process then you can
 [RELEASING.md](https://github.com/intersectmbo/cardano-ledger/blob/master/RELEASING.md#changelogmd).
 
 ## 8.7
-	
+
 - Fix `PParamsUpdate` governance action ratification. Votes of DReps are now accounted for.
 - Move CDDL specification files from test packages into libraries that actually implement each era.
 - Add ability to retain Plutus logs for debugging when running scripts

eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs

@@ -44,6 +44,7 @@ import Cardano.Ledger.Binary (
   invalidKey,
   serialize,
  )
+import Cardano.Ledger.CertState (certDState, dsGenDelegs)
 import Cardano.Ledger.Coin (Coin)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Crypto (Crypto)
@@ -169,9 +170,10 @@ utxoTransition ::
   ) =>
   TransitionRule (AllegraUTXO era)
 utxoTransition = do
-  TRC (Shelley.UtxoEnv slot pp certState genDelegs, utxos, tx) <- judgmentContext
+  TRC (Shelley.UtxoEnv slot pp certState, utxos, tx) <- judgmentContext
   let Shelley.UTxOState utxo _ _ ppup _ _ = utxos
-  let txBody = tx ^. bodyTxL
+      txBody = tx ^. bodyTxL
+      genDelegs = dsGenDelegs (certDState certState)
 
   {- ininterval slot (txvld tx) -}
   runTest $ validateOutsideValidityIntervalUTxO slot txBody

eras/allegra/impl/src/Cardano/Ledger/Allegra/UTxO.hs

@@ -6,15 +6,14 @@
 
 module Cardano.Ledger.Allegra.UTxO () where
 
+import Cardano.Ledger.Allegra.Core
 import Cardano.Ledger.Allegra.Era (AllegraEra)
-import Cardano.Ledger.Allegra.Tx ()
-import Cardano.Ledger.Allegra.TxBody ()
-import Cardano.Ledger.Core
 import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Shelley.UTxO (
   ShelleyScriptsNeeded (..),
   getConsumedCoin,
   getShelleyScriptsNeeded,
+  getShelleyWitsVKeyNeeded,
   shelleyProducedValue,
  )
 import Cardano.Ledger.UTxO (EraUTxO (..), ScriptsProvided (..))
@@ -32,3 +31,5 @@ instance Crypto c => EraUTxO (AllegraEra c) where
   getScriptsNeeded = getShelleyScriptsNeeded
 
   getScriptsHashesNeeded (ShelleyScriptsNeeded scriptHashes) = scriptHashes
+
+  getWitsVKeyNeeded = getShelleyWitsVKeyNeeded

eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/ImpTest.hs

@@ -12,7 +12,6 @@ import Test.Cardano.Ledger.Allegra.TreeDiff ()
 import Test.Cardano.Ledger.Shelley.ImpTest (
   ShelleyEraImp (..),
   emptyShelleyImpNES,
-  shelleyImpWitsVKeyNeeded,
  )
 
 instance
@@ -24,5 +23,3 @@ instance
   ShelleyEraImp (AllegraEra c)
   where
   emptyImpNES = emptyShelleyImpNES
-
-  impWitsVKeyNeeded = shelleyImpWitsVKeyNeeded

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs

@@ -24,7 +24,6 @@ import Cardano.Ledger.Keys (DSignable, Hash)
 import Cardano.Ledger.Shelley.Core
 import Cardano.Ledger.Shelley.LedgerState (
   CertState (..),
-  DState (..),
   LedgerState (..),
   UTxOState (..),
  )
@@ -79,31 +78,28 @@ ledgerTransition ::
   ) =>
   TransitionRule (someLEDGER era)
 ledgerTransition = do
-  TRC (LedgerEnv slot txIx pp account, LedgerState utxoSt dpstate, tx) <- judgmentContext
+  TRC (LedgerEnv slot txIx pp account, LedgerState utxoSt certState, tx) <- judgmentContext
   let txBody = tx ^. bodyTxL
 
-  dpstate' <-
+  certState' <-
     if tx ^. isValidTxL == IsValid True
       then
         trans @(EraRule "DELEGS" era) $
           TRC
             ( DelegsEnv slot txIx pp tx account
-            , dpstate
+            , certState
             , StrictSeq.fromStrict $ txBody ^. certsTxBodyL
             )
-      else pure dpstate
-
-  let CertState _ _pstate dstate = dpstate
-      genDelegs = dsGenDelegs dstate
+      else pure certState
 
   utxoSt' <-
     trans @(EraRule "UTXOW" era) $
       TRC
-        ( UtxoEnv @era slot pp dpstate genDelegs
+        ( UtxoEnv @era slot pp certState
         , utxoSt
         , tx
         )
-  pure $ LedgerState utxoSt' dpstate'
+  pure $ LedgerState utxoSt' certState'
 
 instance
   ( DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody)

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxo.hs

@@ -83,7 +83,7 @@ import Cardano.Ledger.Rules.ValidationMode (
  )
 import Cardano.Ledger.Shelley.LedgerState (
   PPUPPredFailure,
-  UTxOState (UTxOState),
+  UTxOState (utxosUtxo),
  )
 import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, UtxoEnv (..))
 import qualified Cardano.Ledger.Shelley.Rules as Shelley
@@ -468,8 +468,8 @@ utxoTransition ::
   ) =>
   TransitionRule (AlonzoUTXO era)
 utxoTransition = do
-  TRC (UtxoEnv slot pp dpstate _genDelegs, u, tx) <- judgmentContext
-  let UTxOState utxo _deposits _fees _ppup _ _ = u
+  TRC (UtxoEnv slot pp dpstate, utxos, tx) <- judgmentContext
+  let utxo = utxosUtxo utxos
 
   {-   txb := txbody tx   -}
   let txBody = tx ^. bodyTxL

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs

@@ -72,6 +72,7 @@ import Cardano.Ledger.Binary (
  )
 import Cardano.Ledger.Binary.Coders
 import qualified Cardano.Ledger.Binary.Plain as Plain
+import Cardano.Ledger.CertState (certDState, dsGenDelegs)
 import Cardano.Ledger.Coin (Coin)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Plutus.Evaluate (
@@ -257,9 +258,10 @@ alonzoEvalScriptsTxValid ::
   ) =>
   TransitionRule (AlonzoUTXOS era)
 alonzoEvalScriptsTxValid = do
-  TRC (UtxoEnv slot pp certState genDelegs, utxos@(UTxOState utxo _ _ pup _ _), tx) <-
+  TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ pup _ _), tx) <-
     judgmentContext
   let txBody = tx ^. bodyTxL
+      genDelegs = dsGenDelegs (certDState certState)
 
   () <- pure $! traceEvent validBegin ()
 
@@ -297,7 +299,7 @@ alonzoEvalScriptsTxInvalid ::
   ) =>
   TransitionRule (AlonzoUTXOS era)
 alonzoEvalScriptsTxInvalid = do
-  TRC (UtxoEnv slot pp _ _, us@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext
+  TRC (UtxoEnv slot pp _, us@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext
   let txBody = tx ^. bodyTxL
 
   let !_ = traceEvent invalidBegin ()

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxow.hs

@@ -64,6 +64,7 @@ import Cardano.Ledger.BaseTypes (
  )
 import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..))
 import Cardano.Ledger.Binary.Coders
+import Cardano.Ledger.CertState (certDState, dsGenDelegs)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Crypto (DSIGN, HASH)
 import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
@@ -73,7 +74,6 @@ import Cardano.Ledger.Shelley.Rules (
   ShelleyUtxowEvent (UtxoEvent),
   ShelleyUtxowPredFailure (..),
   UtxoEnv (..),
-  shelleyWitsVKeyNeeded,
   validateNeededWitnesses,
  )
 import qualified Cardano.Ledger.Shelley.Rules as Shelley
@@ -325,7 +325,7 @@ alonzoStyleWitness ::
   ) =>
   TransitionRule (AlonzoUTXOW era)
 alonzoStyleWitness = do
-  (TRC (UtxoEnv slot pp stakepools genDelegs, u, tx)) <- judgmentContext
+  (TRC (utxoEnv@(UtxoEnv _ pp certState), u, tx)) <- judgmentContext
 
   {-  (utxo,_,_,_ ) := utxoSt  -}
   {-  txb := txbody tx  -}
@@ -363,8 +363,7 @@ alonzoStyleWitness = do
   runTestOnSignal $ Shelley.validateVerifiedWits tx
 
   {-  witsVKeyNeeded utxo tx genDelegs ⊆ witsKeyHashes                   -}
-  let needed = shelleyWitsVKeyNeeded utxo (tx ^. bodyTxL) genDelegs
-  runTest $ validateNeededWitnesses @era witsKeyHashes needed
+  runTest $ validateNeededWitnesses witsKeyHashes certState utxo txBody
 
   {-  THIS DOES NOT APPPEAR IN THE SPEC as a separate check, but
       witsVKeyNeeded must include the reqSignerHashes in the union   -}
@@ -374,6 +373,7 @@ alonzoStyleWitness = do
   -- check genesis keys signatures for instantaneous rewards certificates
   {-  genSig := { hashKey gkey | gkey ∈ dom(genDelegs)} ∩ witsKeyHashes  -}
   {-  { c ∈ txcerts txb ∩ TxCert_mir} ≠ ∅  ⇒ (|genSig| ≥ Quorum) ∧ (d pp > 0)  -}
+  let genDelegs = dsGenDelegs (certDState certState)
   coreNodeQuorum <- liftSTS $ asks quorum
   runTest $
     Shelley.validateMIRInsufficientGenesisSigs genDelegs coreNodeQuorum witsKeyHashes tx
@@ -392,8 +392,7 @@ alonzoStyleWitness = do
   {-  scriptIntegrityHash txb = hashScriptIntegrity pp (languages txw) (txrdmrs txw)  -}
   runTest $ ppViewHashesMatch tx pp scriptsProvided scriptsHashesNeeded
 
-  trans @(EraRule "UTXO" era) $
-    TRC (UtxoEnv slot pp stakepools genDelegs, u, tx)
+  trans @(EraRule "UTXO" era) $ TRC (utxoEnv, u, tx)
 
 -- ================================
 

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/UTxO.hs

@@ -35,7 +35,7 @@ import Cardano.Ledger.Mary.UTxO (getConsumedMaryValue)
 import Cardano.Ledger.Mary.Value (PolicyID (..))
 import Cardano.Ledger.Plutus.Data (Data, Datum (..))
 import Cardano.Ledger.Shelley.TxBody (Withdrawals (..), getRwdCred)
-import Cardano.Ledger.Shelley.UTxO (shelleyProducedValue)
+import Cardano.Ledger.Shelley.UTxO (getShelleyWitsVKeyNeeded, shelleyProducedValue)
 import Cardano.Ledger.TxIn
 import Cardano.Ledger.UTxO (
   EraUTxO (..),
@@ -72,6 +72,8 @@ instance Crypto c => EraUTxO (AlonzoEra c) where
 
   getScriptsHashesNeeded = getAlonzoScriptsHashesNeeded
 
+  getWitsVKeyNeeded = getShelleyWitsVKeyNeeded
+
 class EraUTxO era => AlonzoEraUTxO era where
   -- | Get data hashes for a transaction that are not required. Such datums are optional,
   -- but they can be added to the witness set. In a broaded terms datums corresponding to

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/ImpTest.hs

@@ -46,5 +46,3 @@ instance
   ShelleyEraImp (AlonzoEra c)
   where
   emptyImpNES = emptyAlonzoImpNES
-
-  impWitsVKeyNeeded = shelleyImpWitsVKeyNeeded

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxo.hs

@@ -64,8 +64,7 @@ import Cardano.Ledger.Rules.ValidationMode (
   runTest,
   runTestOnSignal,
  )
-import Cardano.Ledger.Shelley.LedgerState (PPUPPredFailure)
-import qualified Cardano.Ledger.Shelley.LedgerState as Shelley
+import Cardano.Ledger.Shelley.LedgerState (PPUPPredFailure, UTxOState (utxosUtxo))
 import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, UtxoEnv)
 import qualified Cardano.Ledger.Shelley.Rules as Shelley
 import Cardano.Ledger.TxIn (TxIn)
@@ -309,14 +308,14 @@ utxoTransition ::
   , -- In this function we we call the UTXOS rule, so we need some assumptions
     Embed (EraRule "UTXOS" era) (BabbageUTXO era)
   , Environment (EraRule "UTXOS" era) ~ UtxoEnv era
-  , State (EraRule "UTXOS" era) ~ Shelley.UTxOState era
+  , State (EraRule "UTXOS" era) ~ UTxOState era
   , Signal (EraRule "UTXOS" era) ~ Tx era
   , Inject (PPUPPredFailure era) (PredicateFailure (EraRule "UTXOS" era))
   ) =>
   TransitionRule (BabbageUTXO era)
 utxoTransition = do
-  TRC (Shelley.UtxoEnv slot pp dpstate _genDelegs, u, tx) <- judgmentContext
-  let Shelley.UTxOState utxo _deposits _fees _ppup _ _ = u
+  TRC (Shelley.UtxoEnv slot pp certState, utxos, tx) <- judgmentContext
+  let utxo = utxosUtxo utxos
 
   {-   txb := txbody tx   -}
   let txBody = body tx
@@ -342,7 +341,7 @@ utxoTransition = do
   runTest $ Shelley.validateBadInputsUTxO utxo allInputs
 
   {- consumed pp utxo txb = produced pp poolParams txb -}
-  runTest $ Shelley.validateValueNotConservedUTxO pp utxo dpstate txBody
+  runTest $ Shelley.validateValueNotConservedUTxO pp utxo certState txBody
 
   {-   adaID ∉ supp mint tx - check not needed because mint field of type MultiAsset
    cannot contain ada -}
@@ -394,14 +393,14 @@ instance
   , -- instructions for calling UTXOS from BabbageUTXO
     Embed (EraRule "UTXOS" era) (BabbageUTXO era)
   , Environment (EraRule "UTXOS" era) ~ UtxoEnv era
-  , State (EraRule "UTXOS" era) ~ Shelley.UTxOState era
+  , State (EraRule "UTXOS" era) ~ UTxOState era
   , Signal (EraRule "UTXOS" era) ~ Tx era
   , Inject (PPUPPredFailure era) (PredicateFailure (EraRule "UTXOS" era))
   , PredicateFailure (EraRule "UTXO" era) ~ BabbageUtxoPredFailure era
   ) =>
   STS (BabbageUTXO era)
   where
-  type State (BabbageUTXO era) = Shelley.UTxOState era
+  type State (BabbageUTXO era) = UTxOState era
   type Signal (BabbageUTXO era) = AlonzoTx era
   type Environment (BabbageUTXO era) = UtxoEnv era
   type BaseM (BabbageUTXO era) = ShelleyBase

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs

@@ -52,6 +52,7 @@ import Cardano.Ledger.BaseTypes (
   systemStart,
  )
 import Cardano.Ledger.Binary (EncCBOR (..))
+import Cardano.Ledger.CertState (certDState, dsGenDelegs)
 import Cardano.Ledger.Plutus.Evaluate (
   ScriptFailure (..),
   ScriptResult (..),
@@ -198,9 +199,10 @@ babbageEvalScriptsTxValid ::
   ) =>
   TransitionRule (BabbageUTXOS era)
 babbageEvalScriptsTxValid = do
-  TRC (UtxoEnv slot pp certState genDelegs, utxos@(UTxOState utxo _ _ pup _ _), tx) <-
+  TRC (UtxoEnv slot pp certState, utxos@(UTxOState utxo _ _ pup _ _), tx) <-
     judgmentContext
   let txBody = tx ^. bodyTxL
+      genDelegs = dsGenDelegs (certDState certState)
 
   -- We intentionally run the PPUP rule before evaluating any Plutus scripts.
   -- We do not want to waste computation running plutus scripts if the
@@ -240,7 +242,7 @@ babbageEvalScriptsTxInvalid ::
   ) =>
   TransitionRule (s era)
 babbageEvalScriptsTxInvalid = do
-  TRC (UtxoEnv _ pp _ _, us@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext
+  TRC (UtxoEnv _ pp _, us@(UTxOState utxo _ fees _ _ _), tx) <- judgmentContext
   {- txb := txbody tx -}
   let txBody = tx ^. bodyTxL
   sysSt <- liftSTS $ asks systemStart

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxow.hs

@@ -49,14 +49,14 @@ import Cardano.Ledger.Binary.Coders (
   (!>),
   (<!),
  )
+import Cardano.Ledger.CertState (certDState, dsGenDelegs)
 import Cardano.Ledger.Crypto (DSIGN, HASH)
 import Cardano.Ledger.Rules.ValidationMode (Inject (..), Test, runTest, runTestOnSignal)
 import Cardano.Ledger.Shelley.LedgerState (UTxOState (..))
 import Cardano.Ledger.Shelley.Rules (
   ShelleyUtxowEvent (UtxoEvent),
   ShelleyUtxowPredFailure,
   UtxoEnv (..),
-  shelleyWitsVKeyNeeded,
   validateNeededWitnesses,
  )
 import qualified Cardano.Ledger.Shelley.Rules as Shelley
@@ -271,7 +271,7 @@ babbageUtxowTransition ::
   ) =>
   TransitionRule (BabbageUTXOW era)
 babbageUtxowTransition = do
-  (TRC (UtxoEnv slot pp stakepools genDelegs, u, tx)) <- judgmentContext
+  (TRC (utxoEnv@(UtxoEnv _ pp certState), u, tx)) <- judgmentContext
 
   {-  (utxo,_,_,_ ) := utxoSt  -}
   {-  txb := txbody tx  -}
@@ -310,8 +310,7 @@ babbageUtxowTransition = do
   runTestOnSignal $ Shelley.validateVerifiedWits tx
 
   {-  witsVKeyNeeded utxo tx genDelegs ⊆ witsKeyHashes                   -}
-  let needed = shelleyWitsVKeyNeeded utxo (tx ^. bodyTxL) genDelegs
-  runTest $ validateNeededWitnesses @era witsKeyHashes needed
+  runTest $ validateNeededWitnesses @era witsKeyHashes certState utxo txBody
   -- TODO can we add the required signers to witsVKeyNeeded so we dont need the check below?
 
   {-  THIS DOES NOT APPPEAR IN THE SPEC as a separate check, but
@@ -322,6 +321,7 @@ babbageUtxowTransition = do
   -- check genesis keys signatures for instantaneous rewards certificates
   {-  genSig := { hashKey gkey | gkey ∈ dom(genDelegs)} ∩ witsKeyHashes  -}
   {-  { c ∈ txcerts txb ∩ TxCert_mir} ≠ ∅  ⇒ |genSig| ≥ Quorum  -}
+  let genDelegs = dsGenDelegs (certDState certState)
   coreNodeQuorum <- liftSTS $ asks quorum
   runTest $
     Shelley.validateMIRInsufficientGenesisSigs genDelegs coreNodeQuorum witsKeyHashes tx
@@ -347,8 +347,7 @@ babbageUtxowTransition = do
   {-  scriptIntegrityHash txb = hashScriptIntegrity pp (languages txw) (txrdmrs txw)  -}
   runTest $ ppViewHashesMatch tx pp scriptsProvided scriptHashesNeeded
 
-  trans @(EraRule "UTXO" era) $
-    TRC (UtxoEnv slot pp stakepools genDelegs, u, tx)
+  trans @(EraRule "UTXO" era) $ TRC (utxoEnv, u, tx)
 
 -- ================================
 

eras/babbage/impl/src/Cardano/Ledger/Babbage/UTxO.hs

@@ -36,7 +36,7 @@ import Cardano.Ledger.Core
 import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Mary.UTxO (getConsumedMaryValue)
 import Cardano.Ledger.Plutus.Data (Data)
-import Cardano.Ledger.Shelley.UTxO (shelleyProducedValue)
+import Cardano.Ledger.Shelley.UTxO (getShelleyWitsVKeyNeeded, shelleyProducedValue)
 import Cardano.Ledger.TxIn (TxIn)
 import Cardano.Ledger.UTxO (EraUTxO (..), ScriptsProvided (..), UTxO (..))
 import Control.Applicative
@@ -60,6 +60,8 @@ instance Crypto c => EraUTxO (BabbageEra c) where
 
   getScriptsHashesNeeded = getAlonzoScriptsHashesNeeded
 
+  getWitsVKeyNeeded = getShelleyWitsVKeyNeeded
+
 instance Crypto c => AlonzoEraUTxO (BabbageEra c) where
   getSupplementalDataHashes = getBabbageSupplementalDataHashes