diff --git a/eras/allegra/impl/cardano-ledger-allegra.cabal b/eras/allegra/impl/cardano-ledger-allegra.cabal index 6d926a4f7e0..1bdbb3e5dfc 100644 --- a/eras/allegra/impl/cardano-ledger-allegra.cabal +++ b/eras/allegra/impl/cardano-ledger-allegra.cabal @@ -53,7 +53,7 @@ library cardano-crypto-class, cardano-ledger-binary >=1.0, cardano-ledger-core >=1.6 && <1.7, - cardano-ledger-shelley >=1.5.1 && <1.6, + cardano-ledger-shelley >=1.6 && <1.7, cardano-strict-containers, cardano-slotting, cborg, diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/PParams.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/PParams.hs index 421ce005ce3..733ea0ff213 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/PParams.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/PParams.hs @@ -8,6 +8,7 @@ import Cardano.Ledger.Core import Cardano.Ledger.Crypto import Cardano.Ledger.Shelley.Governance import Cardano.Ledger.Shelley.PParams +import Cardano.Ledger.Val (Val (..)) import Data.Coerce import Lens.Micro @@ -55,3 +56,5 @@ instance Crypto c => EraGov (AllegraEra c) where curPParamsGovStateL = curPParamsShelleyGovStateL prevPParamsGovStateL = prevPParamsShelleyGovStateL + + obligationGovState = const zero diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs index 0390e004e89..e7385d3d493 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/Rules/Utxo.hs @@ -54,12 +54,13 @@ import Cardano.Ledger.Rules.ValidationMode ( ) import Cardano.Ledger.SafeHash (SafeHash, hashAnnotated) import Cardano.Ledger.Shelley.Governance -import Cardano.Ledger.Shelley.LedgerState (PPUPPredFailure, keyTxRefunds, totalTxDeposits) +import Cardano.Ledger.Shelley.LedgerState (PPUPPredFailure, keyTxRefunds) import qualified Cardano.Ledger.Shelley.LedgerState as Shelley import Cardano.Ledger.Shelley.PParams (Update) import Cardano.Ledger.Shelley.Rules (PpupEnv (..), ShelleyPPUP, ShelleyPpupPredFailure) import qualified Cardano.Ledger.Shelley.Rules as Shelley import Cardano.Ledger.Shelley.Tx (ShelleyTx (..), TxIn) +import Cardano.Ledger.Shelley.TxBody (ShelleyEraTxBody (..)) import Cardano.Ledger.Shelley.UTxO (txup) import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..), txouts) import qualified Cardano.Ledger.Val as Val @@ -205,7 +206,7 @@ utxoTransition = do runTest $ Shelley.validateMaxTxSizeUTxO pp tx let refunded = keyTxRefunds pp dpstate txb - let depositChange = totalTxDeposits pp dpstate txb Val.<-> refunded + let depositChange = getTotalDepositsTxBody pp dpstate txb Val.<-> refunded tellEvent $ TotalDeposits (hashAnnotated txb) depositChange pure $! Shelley.updateUTxOState pp u txb depositChange ppup' diff --git a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs index ec6e6f8b63a..58479203a0e 100644 --- a/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs +++ b/eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs @@ -76,6 +76,7 @@ import Cardano.Ledger.Shelley.PParams (Update) import Cardano.Ledger.Shelley.TxBody ( ShelleyEraTxBody (..), Withdrawals (..), + totalTxDepositsShelley, ) import Cardano.Ledger.TxIn (TxIn (..)) import Control.DeepSeq (NFData (..)) @@ -348,6 +349,8 @@ instance Crypto c => ShelleyEraTxBody (AllegraEra c) where lensMemoRawType atbrUpdate $ \txBodyRaw update -> txBodyRaw {atbrUpdate = update} {-# INLINEABLE updateTxBodyL #-} + getTotalDepositsTxBody = totalTxDepositsShelley + instance Crypto c => AllegraEraTxBody (AllegraEra c) where {-# SPECIALIZE instance AllegraEraTxBody (AllegraEra StandardCrypto) #-} diff --git a/eras/alonzo/impl/cardano-ledger-alonzo.cabal b/eras/alonzo/impl/cardano-ledger-alonzo.cabal index c9b01b3e88c..bf09af4618c 100644 --- a/eras/alonzo/impl/cardano-ledger-alonzo.cabal +++ b/eras/alonzo/impl/cardano-ledger-alonzo.cabal @@ -69,7 +69,7 @@ library cardano-ledger-binary >=1.0.1, cardano-ledger-core >=1.6 && <1.7, cardano-ledger-mary >=1.1, - cardano-ledger-shelley ^>=1.5.1, + cardano-ledger-shelley ^>=1.6, cardano-slotting, cardano-strict-containers, containers, diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs index 7fbf0614129..af91345ed3f 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/PParams.hs @@ -119,6 +119,7 @@ import Cardano.Ledger.Shelley.PParams ( shelleyCommonPParamsHKDPairsV6, ) import Cardano.Ledger.TreeDiff (ToExpr (..)) +import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) import Data.Aeson as Aeson ( FromJSON (parseJSON), @@ -290,6 +291,8 @@ instance Crypto c => EraGov (AlonzoEra c) where prevPParamsGovStateL = prevPParamsShelleyGovStateL + obligationGovState = const zero + instance Era era => EncCBOR (AlonzoPParams Identity era) where encCBOR AlonzoPParams {..} = encodeListLen (23 + listLen appProtocolVersion) diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs index 62e58de83cd..ececdf06449 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Ledger.hs @@ -27,7 +27,6 @@ import Cardano.Ledger.Shelley.LedgerState ( DState (..), LedgerState (..), UTxOState (..), - obligationCertState, ) import Cardano.Ledger.Shelley.Rules ( DelegsEnv (..), @@ -36,6 +35,7 @@ import Cardano.Ledger.Shelley.Rules ( ShelleyDelegsPredFailure, ShelleyLEDGERS, UtxoEnv (..), + shelleyLedgerAssertions, ) import Cardano.Ledger.Shelley.Rules as Shelley ( LedgerEnv (..), @@ -46,7 +46,6 @@ import Cardano.Ledger.Shelley.Rules as Shelley ( depositEqualsObligation, ) import Control.State.Transition ( - Assertion (..), Embed (..), STS (..), TRC (..), @@ -109,6 +108,7 @@ ledgerTransition = do instance ( DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) , AlonzoEraTx era + , EraGov era , Tx era ~ AlonzoTx era , Embed (EraRule "DELEGS" era) (AlonzoLEDGER era) , Embed (EraRule "UTXOW" era) (AlonzoLEDGER era) @@ -134,13 +134,7 @@ instance renderAssertionViolation = Shelley.depositEqualsObligation - assertions = - [ PostCondition - "Deposit pot must equal obligation (AlonzoLEDGER)" - ( \(TRC (_, _, _)) - (LedgerState utxoSt dpstate) -> obligationCertState dpstate == utxosDeposited utxoSt - ) - ] + assertions = shelleyLedgerAssertions instance ( Era era diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs index a8db0140229..f367dac0479 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs @@ -76,7 +76,6 @@ import Cardano.Ledger.Shelley.LedgerState ( PPUPPredFailure, UTxOState (..), keyTxRefunds, - totalTxDeposits, updateStakeDistribution, ) import qualified Cardano.Ledger.Shelley.LedgerState as Shelley @@ -250,7 +249,7 @@ alonzoEvalScriptsTxValid = do let txBody = tx ^. bodyTxL protVer = pp ^. ppProtocolVersionL refunded = keyTxRefunds pp dpstate txBody - depositChange = totalTxDeposits pp dpstate txBody <-> refunded + depositChange = getTotalDepositsTxBody pp dpstate txBody <-> refunded tellEvent $ TotalDeposits (hashAnnotated txBody) depositChange () <- pure $! traceEvent validBegin () diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs index e451b12c2b5..7ee0ea1860b 100644 --- a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs +++ b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/TxBody.hs @@ -108,6 +108,7 @@ import Cardano.Ledger.MemoBytes ( ) import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) import Cardano.Ledger.Shelley.PParams (Update) +import Cardano.Ledger.Shelley.TxBody (totalTxDepositsShelley) import Cardano.Ledger.TxIn (TxIn (..)) import Control.DeepSeq (NFData (..)) import Data.Sequence.Strict (StrictSeq) @@ -208,6 +209,8 @@ instance Crypto c => ShelleyEraTxBody (AlonzoEra c) where lensMemoRawType atbrUpdate (\txBodyRaw update_ -> txBodyRaw {atbrUpdate = update_}) {-# INLINEABLE updateTxBodyL #-} + getTotalDepositsTxBody = totalTxDepositsShelley + instance Crypto c => AllegraEraTxBody (AlonzoEra c) where {-# SPECIALIZE instance AllegraEraTxBody (AlonzoEra StandardCrypto) #-} diff --git a/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal b/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal index 7db04c4aaa9..0dd1d4eaa81 100644 --- a/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal +++ b/eras/alonzo/test-suite/cardano-ledger-alonzo-test.cabal @@ -54,7 +54,7 @@ library cardano-ledger-core:{cardano-ledger-core, testlib} >=1.5 && <1.7, cardano-ledger-pretty, cardano-ledger-allegra ^>=1.2, - cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.5 && <1.6, + cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.6 && <1.7, cardano-ledger-shelley-test ^>=1.2, cardano-ledger-shelley-ma-test ^>=1.2, cardano-ledger-mary ^>=1.3, diff --git a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Trace.hs b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Trace.hs index a2fede426f0..65405b85442 100644 --- a/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Trace.hs +++ b/eras/alonzo/test-suite/src/Test/Cardano/Ledger/Alonzo/Trace.hs @@ -45,6 +45,7 @@ import Test.Cardano.Ledger.Shelley.Generator.Utxo (genTx) -- with meaningful delegation certificates. instance ( EraGen era + , EraGov era , AlonzoEraTx era , Mock (EraCrypto era) , MinLEDGER_STS era diff --git a/eras/babbage/impl/cardano-ledger-babbage.cabal b/eras/babbage/impl/cardano-ledger-babbage.cabal index f196da23115..1867ec2f29f 100644 --- a/eras/babbage/impl/cardano-ledger-babbage.cabal +++ b/eras/babbage/impl/cardano-ledger-babbage.cabal @@ -64,7 +64,7 @@ library cardano-ledger-binary >=1.0, cardano-ledger-core >=1.6 && <1.7, cardano-ledger-mary >=1.1, - cardano-ledger-shelley ^>=1.5, + cardano-ledger-shelley ^>=1.6, cardano-slotting, cardano-strict-containers, containers, diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs index 5b9fbd6781a..4ee017cadf2 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/PParams.hs @@ -86,6 +86,7 @@ import Cardano.Ledger.Orphans () import Cardano.Ledger.Shelley.PParams (emptyPPPUpdates) import Cardano.Ledger.Slot (EpochNo (..)) import Cardano.Ledger.TreeDiff (ToExpr (..)) +import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) import Data.Aeson as Aeson ( Key, @@ -246,6 +247,8 @@ instance Crypto c => EraGov (BabbageEra c) where prevPParamsGovStateL = prevPParamsShelleyGovStateL + obligationGovState = const zero + instance Era era => EncCBOR (BabbagePParams Identity era) where encCBOR BabbagePParams {..} = encodeListLen (21 + listLen bppProtocolVersion) diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Ledger.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Ledger.hs index 2b1c0430929..ae256553ba7 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Ledger.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Ledger.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -23,7 +22,6 @@ import Cardano.Ledger.Shelley.LedgerState ( CertState (..), LedgerState (..), UTxOState (..), - obligationCertState, ) import Cardano.Ledger.Shelley.Rules ( DelegsEnv (..), @@ -35,6 +33,7 @@ import Cardano.Ledger.Shelley.Rules ( ShelleyLedgerEvent (..), ShelleyLedgerPredFailure (..), UtxoEnv (..), + shelleyLedgerAssertions, ) import Cardano.Ledger.Shelley.Rules as Shelley ( ShelleyLedgersEvent (LedgerEvent), @@ -42,10 +41,8 @@ import Cardano.Ledger.Shelley.Rules as Shelley ( depositEqualsObligation, ) import Control.State.Transition ( - Assertion (..), Embed (..), STS (..), - TRC (..), ) import Data.Sequence (Seq) @@ -53,6 +50,7 @@ import Data.Sequence (Seq) instance ( AlonzoEraTx era + , EraGov era , Embed (EraRule "DELEGS" era) (BabbageLEDGER era) , Embed (EraRule "UTXOW" era) (BabbageLEDGER era) , Environment (EraRule "UTXOW" era) ~ UtxoEnv era @@ -77,15 +75,7 @@ instance renderAssertionViolation = Shelley.depositEqualsObligation - assertions = - [ PostCondition - "Deposit pot must equal obligation (BabbageLEDGER)" - ( \(TRC (_, _, _)) - (LedgerState utxoSt dpstate) -> - obligationCertState dpstate - == utxosDeposited utxoSt - ) - ] + assertions = shelleyLedgerAssertions instance ( Era era diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs index 944fb10f977..cc8def9bca9 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs @@ -52,7 +52,6 @@ import Cardano.Ledger.Shelley.LedgerState ( PPUPPredFailure, UTxOState (..), keyTxRefunds, - totalTxDeposits, updateStakeDistribution, ) import Cardano.Ledger.Shelley.PParams (Update) @@ -161,7 +160,7 @@ tellDepositChangeEvent pp dpstate txBody = do {- refunded := keyRefunds pp txb -} let refunded = keyTxRefunds pp dpstate txBody {- depositChange := (totalDeposits pp poolParams txcerts txb) − refunded -} - let depositChange = totalTxDeposits pp dpstate txBody <-> refunded + let depositChange = getTotalDepositsTxBody pp dpstate txBody <-> refunded tellEvent $ TotalDeposits (hashAnnotated txBody) depositChange pure depositChange diff --git a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs index 24c69e736a2..15788778609 100644 --- a/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs +++ b/eras/babbage/impl/src/Cardano/Ledger/Babbage/TxBody.hs @@ -152,6 +152,7 @@ import Cardano.Ledger.MemoBytes ( ) import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) import Cardano.Ledger.Shelley.PParams (Update) +import Cardano.Ledger.Shelley.TxBody (totalTxDepositsShelley) import Cardano.Ledger.TxIn (TxIn (..)) import Control.DeepSeq (NFData) import Data.Sequence.Strict (StrictSeq, (|>)) @@ -418,6 +419,8 @@ instance Crypto c => ShelleyEraTxBody (BabbageEra c) where updateTxBodyL = updateBabbageTxBodyL {-# INLINE updateTxBodyL #-} + getTotalDepositsTxBody = totalTxDepositsShelley + instance Crypto c => AllegraEraTxBody (BabbageEra c) where {-# SPECIALIZE instance AllegraEraTxBody (BabbageEra StandardCrypto) #-} diff --git a/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal b/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal index 6d6ccbdf0c9..6a6c2d25eee 100644 --- a/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal +++ b/eras/babbage/test-suite/cardano-ledger-babbage-test.cabal @@ -45,7 +45,7 @@ library cardano-ledger-shelley-ma-test >=1.1, cardano-ledger-mary ^>=1.3, cardano-ledger-shelley-test >=1.1, - cardano-ledger-shelley >=1.4 && <1.6, + cardano-ledger-shelley >=1.6 && <1.7, cardano-strict-containers, cardano-slotting, containers, diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index bf396059d32..f0ce4bc3672 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,35 @@ ## 1.8.0.0 +* Remove `rsFuture` from `RatifyState` +* Add to `GovActionsState`: + * `curGovActionsState` + * `prevGovActionsState` + * `prevDRepState` + * `prevCommitteeState` +* Add `ToExpr` instances to: + * `PoolVotingThresholds` + * `DRepVotingThresholds` + * `GovActionState` + * `GovActionsState` + * `EnactState` + * `RatifyState` + * `ConwayGovState` + * `GovActionIx` + * `GovActionId` + * `Vote` + * `Committee` + * `PrevGovActionId` + * `GovAction` + * `ConwayPParams` with `Identity` and `StrictMaybe` +* Add lenses: + * `cgEnactStateL` + * `curGovActionsStateL` + * `prevGovActionsStateL` + * `prevDRepStateL` + * `prevCommitteeStateL` +* Replace `cgRatifyState` with `cgEnactState` +* Deprecate `cgRatifyStateL` * Add `ProposalDepositIncorrect` predicate failure, that is produced when `ProposalProcedure` deposit does not match `"govActionDeposit"` from `PParams` #3669 * Add "minCommitteeSize" `PParam` validation for `NewCommittee` `GovAction` #3668 * Add `committeeMembersL` and `committeeQuorumL` lenses for `Committee` diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 5c2255ac000..7bdbdf6b9c5 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/eras/conway/impl/cardano-ledger-conway.cabal @@ -73,7 +73,7 @@ library cardano-ledger-babbage >=1.4.1, cardano-ledger-core ^>=1.6, cardano-ledger-mary >=1.1, - cardano-ledger-shelley ^>=1.5.1, + cardano-ledger-shelley ^>=1.6, cardano-slotting, cardano-strict-containers, containers, diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs index a3c009fe626..ae1bb8d8356 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs @@ -45,6 +45,7 @@ import Cardano.Ledger.Binary.Encoding (EncCBOR (encCBOR)) import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Conway.Governance.Procedures (ProposalProcedure, VotingProcedures) import Cardano.Ledger.HKD (HKD, HKDFunctor) +import Cardano.Ledger.TreeDiff (ToExpr) import Control.DeepSeq (NFData) import Data.Aeson (ToJSON) import Data.Default.Class (Default) @@ -136,6 +137,8 @@ data PoolVotingThresholds = PoolVotingThresholds } deriving (Eq, Ord, Show, Generic, Default, ToJSON, NFData, NoThunks) +instance ToExpr PoolVotingThresholds + instance EncCBOR PoolVotingThresholds where encCBOR PoolVotingThresholds {..} = encodeListLen 4 @@ -167,6 +170,8 @@ data DRepVotingThresholds = DRepVotingThresholds } deriving (Eq, Ord, Show, Generic, Default, ToJSON, NFData, NoThunks) +instance ToExpr DRepVotingThresholds + instance EncCBOR DRepVotingThresholds where encCBOR DRepVotingThresholds {..} = encodeListLen 10 diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index 090dafe7db6..21bb6e0625e 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -42,6 +42,7 @@ module Cardano.Ledger.Conway.Governance ( ConwayEraGov (..), -- Lenses cgGovActionsStateL, + cgEnactStateL, cgRatifyStateL, ensConstitutionL, rsEnactStateL, @@ -49,6 +50,10 @@ module Cardano.Ledger.Conway.Governance ( prevPParamsConwayGovStateL, constitutionScriptL, constitutionAnchorL, + curGovActionsStateL, + prevGovActionsStateL, + prevDRepsStateL, + prevCommitteeStateL, ) where import Cardano.Ledger.Address (RewardAcnt) @@ -67,6 +72,7 @@ import Cardano.Ledger.Binary.Coders ( (!>), ( ToExpr (GovActionState era) + instance EraPParams era => ToJSON (GovActionState era) where toJSON = object . toGovActionStatePairs toEncoding = pairs . mconcat . toGovActionStatePairs @@ -170,32 +181,88 @@ instance EraPParams era => EncCBOR (GovActionState era) where !> To gasProposedIn !> To gasExpiresAfter -newtype GovActionsState era = GovActionsState - { unGovActionsState :: Map (GovActionId (EraCrypto era)) (GovActionState era) +data GovActionsState era = GovActionsState + { curGovActionsState :: !(Map (GovActionId (EraCrypto era)) (GovActionState era)) + , prevGovActionsState :: !(Map (GovActionId (EraCrypto era)) (GovActionState era)) + , prevDRepsState :: !(Map (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))) + , prevCommitteeState :: !(CommitteeState era) } - deriving (Generic, NFData, Semigroup, Monoid) + deriving (Generic) + +instance EraPParams era => ToExpr (GovActionsState era) insertGovActionsState :: GovActionState era -> GovActionsState era -> GovActionsState era -insertGovActionsState v@GovActionState {gasId} (GovActionsState m) = - GovActionsState $ Map.insert gasId v m +insertGovActionsState v@GovActionState {gasId} = + curGovActionsStateL %~ Map.insert gasId v + +curGovActionsStateL :: + Lens' + (GovActionsState era) + (Map (GovActionId (EraCrypto era)) (GovActionState era)) +curGovActionsStateL = lens curGovActionsState (\x y -> x {curGovActionsState = y}) + +prevGovActionsStateL :: + Lens' + (GovActionsState era) + (Map (GovActionId (EraCrypto era)) (GovActionState era)) +prevGovActionsStateL = lens prevGovActionsState (\x y -> x {prevGovActionsState = y}) + +prevDRepsStateL :: + Lens' + (GovActionsState era) + (Map (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))) +prevDRepsStateL = lens prevDRepsState (\x y -> x {prevDRepsState = y}) + +prevCommitteeStateL :: + Lens' + (GovActionsState era) + (CommitteeState era) +prevCommitteeStateL = lens prevCommitteeState (\x y -> x {prevCommitteeState = y}) deriving instance EraPParams era => Eq (GovActionsState era) deriving instance EraPParams era => Show (GovActionsState era) -deriving instance EraPParams era => ToJSON (GovActionsState era) +toGovActionsStatePairs :: (KeyValue a, EraPParams era) => GovActionsState era -> [a] +toGovActionsStatePairs gas@(GovActionsState _ _ _ _) = + let GovActionsState {..} = gas + in [ "curGovActionsState" .= curGovActionsState + , "prevGovActionsState" .= prevGovActionsState + , "prevDRepsState" .= prevDRepsState + , "prevCommitteeState" .= prevCommitteeState + ] + +instance EraPParams era => ToJSON (GovActionsState era) where + toJSON = object . toGovActionsStatePairs + toEncoding = pairs . mconcat . toGovActionsStatePairs + +instance EraPParams era => NFData (GovActionsState era) instance EraPParams era => NoThunks (GovActionsState era) instance Default (GovActionsState era) where - def = GovActionsState mempty + def = GovActionsState mempty mempty mempty def -deriving instance EraPParams era => EncCBOR (GovActionsState era) +instance EraPParams era => EncCBOR (GovActionsState era) where + encCBOR GovActionsState {..} = + encode $ + Rec GovActionsState + !> To curGovActionsState + !> To prevGovActionsState + !> To prevDRepsState + !> To prevCommitteeState -deriving instance EraPParams era => DecCBOR (GovActionsState era) +instance EraPParams era => DecCBOR (GovActionsState era) where + decCBOR = + decode $ + RecD GovActionsState + ToCBOR (GovActionsState era) where toCBOR = toEraCBOR @era @@ -225,6 +292,8 @@ ensCurPParamsL = lens ensPParams (\es x -> es {ensPParams = x}) ensPrevPParamsL :: Lens' (EnactState era) (PParams era) ensPrevPParamsL = lens ensPrevPParams (\es x -> es {ensPrevPParams = x}) +instance ToExpr (PParamsHKD Identity era) => ToExpr (EnactState era) + instance EraPParams era => ToJSON (EnactState era) where toJSON = object . toEnactStatePairs toEncoding = pairs . mconcat . toEnactStatePairs @@ -292,7 +361,6 @@ instance EraPParams era => NoThunks (EnactState era) data RatifyState era = RatifyState { rsEnactState :: !(EnactState era) - , rsFuture :: !(StrictSeq (GovActionState era)) , rsRemoved :: !(StrictSeq (GovActionState era)) } deriving (Generic) @@ -304,6 +372,8 @@ deriving instance EraPParams era => Show (RatifyState era) rsEnactStateL :: Lens' (RatifyState era) (EnactState era) rsEnactStateL = lens rsEnactState (\x y -> x {rsEnactState = y}) +instance EraPParams era => ToExpr (RatifyState era) + instance EraPParams era => Default (RatifyState era) instance EraPParams era => DecCBOR (RatifyState era) where @@ -312,14 +382,12 @@ instance EraPParams era => DecCBOR (RatifyState era) where RecD RatifyState EncCBOR (RatifyState era) where encCBOR RatifyState {..} = encode $ Rec RatifyState !> To rsEnactState - !> To rsFuture !> To rsRemoved instance EraPParams era => ToCBOR (RatifyState era) where @@ -337,30 +405,36 @@ instance EraPParams era => ToJSON (RatifyState era) where toEncoding = pairs . mconcat . toRatifyStatePairs toRatifyStatePairs :: (KeyValue a, EraPParams era) => RatifyState era -> [a] -toRatifyStatePairs cg@(RatifyState _ _ _) = +toRatifyStatePairs cg@(RatifyState _ _) = let RatifyState {..} = cg in [ "enactState" .= rsEnactState - , "future" .= rsFuture , "removed" .= rsRemoved ] data ConwayGovState era = ConwayGovState { cgGovActionsState :: !(GovActionsState era) - , cgRatifyState :: !(RatifyState era) + , cgEnactState :: !(EnactState era) } deriving (Generic, Eq, Show) cgGovActionsStateL :: Lens' (ConwayGovState era) (GovActionsState era) cgGovActionsStateL = lens cgGovActionsState (\x y -> x {cgGovActionsState = y}) +cgEnactStateL :: Lens' (ConwayGovState era) (EnactState era) +cgEnactStateL = lens cgEnactState (\x y -> x {cgEnactState = y}) + +{-# DEPRECATED cgRatifyStateL "Use cgEnactStateL instead" #-} cgRatifyStateL :: Lens' (ConwayGovState era) (RatifyState era) -cgRatifyStateL = lens cgRatifyState (\x y -> x {cgRatifyState = y}) +cgRatifyStateL = + lens + (\ConwayGovState {..} -> RatifyState cgEnactState mempty) + (\x RatifyState {..} -> x & cgEnactStateL .~ rsEnactState) curPParamsConwayGovStateL :: Lens' (ConwayGovState era) (PParams era) -curPParamsConwayGovStateL = cgRatifyStateL . rsEnactStateL . ensCurPParamsL +curPParamsConwayGovStateL = cgEnactStateL . ensCurPParamsL prevPParamsConwayGovStateL :: Lens' (ConwayGovState era) (PParams era) -prevPParamsConwayGovStateL = cgRatifyStateL . rsEnactStateL . ensPrevPParamsL +prevPParamsConwayGovStateL = cgEnactStateL . ensPrevPParamsL instance EraPParams era => DecCBOR (ConwayGovState era) where decCBOR = @@ -374,7 +448,7 @@ instance EraPParams era => EncCBOR (ConwayGovState era) where encode $ Rec ConwayGovState !> To cgGovActionsState - !> To cgRatifyState + !> To cgEnactState instance EraPParams era => ToCBOR (ConwayGovState era) where toCBOR = toEraCBOR @era @@ -392,24 +466,29 @@ instance EraPParams era => ToJSON (ConwayGovState era) where toJSON = object . toConwayGovPairs toEncoding = pairs . mconcat . toConwayGovPairs +instance EraPParams era => ToExpr (ConwayGovState era) + toConwayGovPairs :: (KeyValue a, EraPParams era) => ConwayGovState era -> [a] toConwayGovPairs cg@(ConwayGovState _ _) = let ConwayGovState {..} = cg in [ "gov" .= cgGovActionsState - , "ratify" .= cgRatifyState + , "ratify" .= cgEnactState ] instance EraPParams (ConwayEra c) => EraGov (ConwayEra c) where type GovState (ConwayEra c) = ConwayGovState (ConwayEra c) - getConstitution g = Just $ g ^. cgRatifyStateL . rsEnactStateL . ensConstitutionL + getConstitution g = Just $ g ^. cgEnactStateL . ensConstitutionL curPParamsGovStateL = curPParamsConwayGovStateL prevPParamsGovStateL = prevPParamsConwayGovStateL + obligationGovState st = + foldMap' gasDeposit (st ^. cgGovActionsStateL . curGovActionsStateL) + class EraGov era => ConwayEraGov era where constitutionGovStateL :: Lens' (GovState era) (Constitution era) instance Crypto c => ConwayEraGov (ConwayEra c) where - constitutionGovStateL = cgRatifyStateL . rsEnactStateL . ensConstitutionL + constitutionGovStateL = cgEnactStateL . ensConstitutionL diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs index ffee1e84ede..37ad9c2793d 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance/Procedures.hs @@ -69,13 +69,14 @@ import Cardano.Ledger.Binary.Coders ( ( DecCBOR (GovActionId c) where decCBOR = decode $ @@ -194,6 +199,8 @@ data Vote | Abstain deriving (Generic, Eq, Show, Enum, Bounded) +instance ToExpr Vote + instance ToJSON Vote instance NoThunks Vote @@ -325,6 +332,8 @@ data Committee era = Committee } deriving (Eq, Show, Generic) +instance ToExpr (Committee era) + instance Era era => NoThunks (Committee era) instance Era era => NFData (Committee era) @@ -369,7 +378,7 @@ data GovActionPurpose deriving (Eq, Show) newtype PrevGovActionId (r :: GovActionPurpose) c = PrevGovActionId (GovActionId c) - deriving (Eq, Show, Generic, EncCBOR, DecCBOR, NoThunks, NFData, ToJSON) + deriving (Eq, Show, Generic, EncCBOR, DecCBOR, NoThunks, NFData, ToJSON, ToExpr) type role PrevGovActionId nominal nominal @@ -411,6 +420,8 @@ data GovAction era | InfoAction deriving (Generic) +instance ToExpr (PParamsHKD StrictMaybe era) => ToExpr (GovAction era) + deriving instance EraPParams era => Eq (GovAction era) deriving instance EraPParams era => Show (GovAction era) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs index 58360a4320b..30ad13d9f83 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs @@ -46,6 +46,7 @@ import Cardano.Ledger.Conway.Core hiding (Value) import Cardano.Ledger.Conway.Era (ConwayEra) import Cardano.Ledger.Crypto import Cardano.Ledger.HKD (HKD, HKDFunctor (..)) +import Cardano.Ledger.TreeDiff (ToExpr) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) import Data.Aeson hiding (Encoding, decode, encode) @@ -137,6 +138,8 @@ data ConwayPParams f era = ConwayPParams } deriving (Generic) +instance ToExpr (ConwayPParams Identity era) + deriving instance Eq (ConwayPParams Identity era) deriving instance Ord (ConwayPParams Identity era) @@ -179,6 +182,8 @@ instance NoThunks (UpgradeConwayPParams Identity) instance NFData (UpgradeConwayPParams Identity) +instance ToExpr (ConwayPParams StrictMaybe era) + deriving instance Eq (UpgradeConwayPParams StrictMaybe) deriving instance Ord (UpgradeConwayPParams StrictMaybe) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs index 22be3211af8..e82139e9c16 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs @@ -24,7 +24,7 @@ where import Cardano.Ledger.Address (RewardAcnt (getRwdCred)) import Cardano.Ledger.BaseTypes (ShelleyBase) -import Cardano.Ledger.CertState (certDStateL, dsUnifiedL, vsDRepsL) +import Cardano.Ledger.CertState (certDStateL, certVStateL, dsUnifiedL, vsCommitteeStateL, vsDRepsL) import Cardano.Ledger.Coin (Coin) import Cardano.Ledger.Compactible (Compactible (..)) import Cardano.Ledger.Conway.Core @@ -34,9 +34,9 @@ import Cardano.Ledger.Conway.Governance ( GovActionState (..), GovActionsState (..), RatifyState (..), + cgEnactStateL, cgGovActionsStateL, - cgRatifyStateL, - insertGovActionsState, + curGovActionsStateL, ) import Cardano.Ledger.Conway.Rules.Enact (EnactPredFailure) import Cardano.Ledger.Conway.Rules.Ratify (RatifyEnv (..), RatifySignal (..)) @@ -49,7 +49,6 @@ import Cardano.Ledger.Shelley.LedgerState ( LedgerState (..), PState (..), UTxOState (..), - asReserves, asTreasuryL, curPParamsEpochStateL, epochStateDRepDistrL, @@ -63,8 +62,8 @@ import Cardano.Ledger.Shelley.LedgerState ( lsCertStateL, lsUTxOState, lsUTxOStateL, - obligationCertState, prevPParamsEpochStateL, + totalObligation, utxosDonationL, utxosGovStateL, pattern CertState, @@ -170,17 +169,13 @@ returnProposalDepositsUMap gaids m = returnProposalDeposits :: forall era. - GovState era ~ ConwayGovState era => + StrictSeq (GovActionState era) -> LedgerState era -> LedgerState era -returnProposalDeposits ls@LedgerState {..} = - ls - & lsCertStateL . certDStateL . dsUnifiedL %~ dstate +returnProposalDeposits removedProposals = + lsCertStateL . certDStateL . dsUnifiedL %~ updateUMap where - govSt = utxosGovState lsUTxOState - ratifyState = cgRatifyState govSt - removedProposals = rsRemoved ratifyState - dstate = returnProposalDepositsUMap removedProposals + updateUMap = returnProposalDepositsUMap removedProposals epochTransition :: forall era. @@ -235,49 +230,85 @@ epochTransition = do { lsUTxOState = utxoSt' , lsCertState = adjustedCertState } - epochState' = + es' = EpochState acnt' - (returnProposalDeposits adjustedLState) + adjustedLState ss' nm let - utxoSt''' = utxoSt' {utxosDeposited = obligationCertState adjustedCertState} - acnt'' = acnt' {asReserves = asReserves acnt'} - govSt = utxosGovState utxoSt''' - stakeDistr = credMap $ utxosStakeDistr utxoSt''' - drepDistr = extractDRepDistr (epochState' ^. epochStateDRepDistrL) + utxoSt'' = + utxoSt' + { utxosDeposited = + totalObligation + adjustedCertState + (utxoSt' ^. utxosGovStateL) + } + govSt = utxosGovState utxoSt'' + stakeDistr = credMap $ utxosStakeDistr utxoSt'' + drepDistr = extractDRepDistr (es' ^. epochStateDRepDistrL) ratEnv = RatifyEnv { reStakeDistr = stakeDistr , reStakePoolDistr = stakePoolDistr , reDRepDistr = drepDistr - , reCurrentEpoch = eNo + , reCurrentEpoch = eNo - 1 , reDRepState = vstate ^. vsDRepsL } - ratSig = - RatifySignal . Seq.fromList . Map.elems . unGovActionsState $ - cgGovActionsState govSt - rs@RatifyState {rsFuture} <- - trans @(EraRule "RATIFY" era) $ TRC (ratEnv, cgRatifyState govSt, ratSig) - let es'' = - epochState' - { esAccountState = acnt'' - , esLState = (esLState epochState') {lsUTxOState = utxoSt'''} - } - & prevPParamsEpochStateL .~ pp - & curPParamsEpochStateL .~ pp - -- TODO can we be more efficient? - newGov = foldr' insertGovActionsState mempty rsFuture - esGovernanceL = esLStateL . lsUTxOStateL . utxosGovStateL - esDonationL :: Lens' (EpochState era) Coin - esDonationL = esLStateL . lsUTxOStateL . utxosDonationL - donations = es'' ^. esDonationL + govStateToSeq = Seq.fromList . Map.elems + -- TODO the order of governance actions is probably messed up here. Investigate + ratSig = RatifySignal . govStateToSeq . prevGovActionsState $ cgGovActionsState govSt + RatifyState {rsRemoved, rsEnactState} <- + trans @(EraRule "RATIFY" era) $ + TRC + ( ratEnv + , RatifyState + { rsRemoved = mempty + , rsEnactState = govSt ^. cgEnactStateL + } + , ratSig + ) + let + lState = returnProposalDeposits rsRemoved $ esLState es' + es'' = + es' + { esAccountState = acnt' + , esLState = lState {lsUTxOState = utxoSt''} + } + & prevPParamsEpochStateL .~ pp + & curPParamsEpochStateL .~ pp + esGovernanceL :: Lens' (EpochState era) (GovState era) + esGovernanceL = esLStateL . lsUTxOStateL . utxosGovStateL + oldGovActionsState = + es ^. esGovernanceL . cgGovActionsStateL . curGovActionsStateL + newGovActionsState = + foldr' + (Map.delete . gasId) + oldGovActionsState + rsRemoved + newGov = + GovActionsState + { -- We set both curGovActionsState and prevGovActionsState to the same + -- value at the epoch boundary. We only change curGovActionsState + -- during the next epoch while prevGovActionsState stays unchanged + -- so we can tally the votes from the previous epoch. + curGovActionsState = newGovActionsState + , prevGovActionsState = newGovActionsState + , prevDRepsState = + es' + ^. esLStateL . lsCertStateL . certVStateL . vsDRepsL + , prevCommitteeState = + es' + ^. esLStateL . lsCertStateL . certVStateL . vsCommitteeStateL + } + esDonationL :: Lens' (EpochState era) Coin + esDonationL = esLStateL . lsUTxOStateL . utxosDonationL + donations = es'' ^. esDonationL pure $ es'' + & esGovernanceL . cgEnactStateL .~ rsEnactState & esGovernanceL . cgGovActionsStateL .~ newGov - & esGovernanceL . cgRatifyStateL .~ rs -- Move donations to treasury & esAccountStateL . asTreasuryL <>~ donations -- Clear the donations field diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs index 17cbc066866..3a9456636f7 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs @@ -35,6 +35,7 @@ import Cardano.Ledger.Conway.Governance ( Voter (..), VotingProcedure (..), VotingProcedures (..), + curGovActionsStateL, indexedGovProps, ) import Cardano.Ledger.Conway.Governance.Procedures (GovAction (..), committeeMembersL) @@ -55,7 +56,7 @@ import qualified Data.Map.Strict as Map import Data.Sequence (Seq (..)) import qualified Data.Set as Set import GHC.Generics (Generic) -import Lens.Micro ((^.)) +import Lens.Micro ((%~), (&), (^.)) import NoThunks.Class (NoThunks (..)) import Numeric.Natural (Natural) import Validation (failureUnless) @@ -135,8 +136,8 @@ addVoterVote :: GovActionId (EraCrypto era) -> VotingProcedure era -> GovActionsState era -addVoterVote voter (GovActionsState st) govActionId VotingProcedure {vProcVote} = - GovActionsState $ Map.update (Just . updateVote) govActionId st +addVoterVote voter as govActionId VotingProcedure {vProcVote} = + as & curGovActionsStateL %~ Map.update (Just . updateVote) govActionId where updateVote GovActionState {..} = case voter of @@ -165,9 +166,8 @@ addAction :: GovAction era -> GovActionsState era -> GovActionsState era -addAction epoch gaExpiry gaid c addr act (GovActionsState st) = - GovActionsState $ - Map.insert gaid gai' st +addAction epoch gaExpiry gaid c addr act as = + as & curGovActionsStateL %~ Map.insert gaid gai' where gai' = GovActionState @@ -186,8 +186,8 @@ noSuchGovActions :: GovActionsState era -> Set.Set (GovActionId (EraCrypto era)) -> Test (ConwayGovPredFailure era) -noSuchGovActions (GovActionsState st) gaIds = - let unknownGovActionIds = Set.filter (`Map.notMember` st) gaIds +noSuchGovActions gas gaIds = + let unknownGovActionIds = Set.filter (`Map.notMember` curGovActionsState gas) gaIds in failureUnless (Set.null unknownGovActionIds) $ GovActionsDoNotExist unknownGovActionIds diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs index 137a88d06e0..6af226e37f2 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs @@ -54,7 +54,6 @@ import Cardano.Ledger.Shelley.LedgerState ( DState (..), LedgerState (..), UTxOState (..), - obligationCertState, utxosGovStateL, ) import Cardano.Ledger.Shelley.Rules ( @@ -63,6 +62,7 @@ import Cardano.Ledger.Shelley.Rules ( ShelleyLedgersEvent (..), ShelleyLedgersPredFailure (..), UtxoEnv (..), + shelleyLedgerAssertions, ) import Cardano.Ledger.Slot (epochInfoEpoch) import Cardano.Ledger.UMap (UView (..), dRepMap) @@ -72,7 +72,6 @@ import Control.DeepSeq (NFData) import Control.Monad (when) import Control.Monad.Trans.Reader (asks) import Control.State.Transition.Extended ( - Assertion (..), AssertionViolation (..), Embed (..), STS (..), @@ -172,7 +171,7 @@ data ConwayLedgerEvent era instance ( AlonzoEraTx era , ConwayEraTxBody era - , ConwayEraPParams era + , EraGov era , GovState era ~ ConwayGovState era , Embed (EraRule "UTXOW" era) (ConwayLEDGER era) , Embed (EraRule "GOV" era) (ConwayLEDGER era) @@ -209,15 +208,7 @@ instance <> "\n" <> show avState - assertions = - [ PostCondition - "Deposit pot must equal obligation" - ( \(TRC (_, _, _)) - (LedgerState utxoSt certState) -> - obligationCertState certState - == utxosDeposited utxoSt - ) - ] + assertions = shelleyLedgerAssertions -- ======================================= @@ -265,7 +256,6 @@ ledgerTransition = do , certState , StrictSeq.fromStrict $ txBody ^. certsTxBodyL ) - let wdrlAddrs = Map.keysSet . unWithdrawals $ tx ^. bodyTxL . withdrawalsTxBodyL wdrlCreds = Set.map getRwdCred wdrlAddrs dUnified = dsUnified $ certDState certStateAfterCERTS @@ -288,7 +278,6 @@ ledgerTransition = do , utxoState ^. utxosGovStateL . cgGovActionsStateL , govProcedures ) - let utxoState' = utxoState & utxosGovStateL . cgGovActionsStateL .~ govActionsState' pure (utxoState', certStateAfterCERTS) else pure (utxoState, certState) @@ -365,6 +354,7 @@ instance , State (EraRule "GOV" era) ~ GovActionsState era , PredicateFailure (EraRule "LEDGER" era) ~ ConwayLedgerPredFailure era , Event (EraRule "LEDGER" era) ~ ConwayLedgerEvent era + , EraGov era ) => Embed (ConwayLEDGER era) (ShelleyLEDGERS era) where diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs index 984916a7913..cd9b3fded9c 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs @@ -196,7 +196,7 @@ ratifyTransition :: ratifyTransition = do TRC ( env@RatifyEnv {reCurrentEpoch} - , st@RatifyState {rsEnactState, rsFuture, rsRemoved} + , st@RatifyState {rsEnactState, rsRemoved} , RatifySignal rsig ) <- judgmentContext @@ -220,7 +220,7 @@ ratifyTransition = do -- Finally, filter out actions that are not processed. if gasExpiresAfter < reCurrentEpoch then pure st' {rsRemoved = ast :<| rsRemoved} -- Action expires after current Epoch. Remove it. - else pure st' {rsFuture = ast :<| rsFuture} + else pure st' Empty -> pure st instance EraGov era => Embed (ConwayENACT era) (ConwayRATIFY era) where diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs index 5320df635ca..14c1d4a4eae 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/TxBody.hs @@ -71,6 +71,7 @@ import Cardano.Ledger.Binary.Coders ( ofield, (!>), ) +import Cardano.Ledger.CertState (CertState) import Cardano.Ledger.Coin (Coin (..), decodePositiveCoin) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Era (ConwayEra) @@ -99,6 +100,7 @@ import Cardano.Ledger.MemoBytes ( mkMemoized, ) import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) +import Cardano.Ledger.Shelley.TxBody (totalTxDepositsShelley) import Cardano.Ledger.TxIn (TxIn (..)) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) @@ -326,6 +328,28 @@ instance updateTxBodyG = to (const SNothing) + getTotalDepositsTxBody = totalTxDepositsConway + +totalProposalDeposits :: + (ConwayEraTxBody era, ConwayEraPParams era) => + PParams era -> + TxBody era -> + Coin +totalProposalDeposits pp txb = nProposals <×> depositPerProposal + where + nProposals = length (txb ^. proposalProceduresTxBodyL) + depositPerProposal = pp ^. ppGovActionDepositL + +totalTxDepositsConway :: + Crypto c => + PParams (ConwayEra c) -> + CertState (ConwayEra c) -> + TxBody (ConwayEra c) -> + Coin +totalTxDepositsConway pp cs txb = + totalTxDepositsShelley pp cs txb + <> totalProposalDeposits pp txb + instance Crypto c => AllegraEraTxBody (ConwayEra c) where {-# SPECIALIZE instance AllegraEraTxBody (ConwayEra StandardCrypto) #-} diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs index ba2b2c59a6c..f16facd342e 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -105,7 +105,6 @@ instance RatifyState <$> arbitrary <*> arbitrary - <*> arbitrary instance (Era era, Arbitrary (PParams era), Arbitrary (PParamsUpdate era)) => @@ -136,7 +135,13 @@ instance <*> arbitrary <*> arbitrary -deriving instance (Era era, Arbitrary (PParamsUpdate era)) => Arbitrary (GovActionsState era) +instance (Era era, Arbitrary (PParamsUpdate era)) => Arbitrary (GovActionsState era) where + arbitrary = + GovActionsState + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary instance (Era era, Arbitrary (PParamsUpdate era)) => Arbitrary (GovActionState era) where arbitrary = diff --git a/eras/conway/test-suite/cardano-ledger-conway-test.cabal b/eras/conway/test-suite/cardano-ledger-conway-test.cabal index 8b155b7d7d4..a94b1eb4545 100644 --- a/eras/conway/test-suite/cardano-ledger-conway-test.cabal +++ b/eras/conway/test-suite/cardano-ledger-conway-test.cabal @@ -48,7 +48,7 @@ library cardano-ledger-mary ^>=1.3, cardano-ledger-shelley-ma-test >=1.1, cardano-ledger-shelley-test >=1.1, - cardano-ledger-shelley >=1.3 && <1.6, + cardano-ledger-shelley >=1.6 && <1.7, cardano-slotting, containers, data-default-class, diff --git a/eras/mary/impl/cardano-ledger-mary.cabal b/eras/mary/impl/cardano-ledger-mary.cabal index 0118d23b895..8c951d170ad 100644 --- a/eras/mary/impl/cardano-ledger-mary.cabal +++ b/eras/mary/impl/cardano-ledger-mary.cabal @@ -60,7 +60,7 @@ library cardano-ledger-allegra >=1.1, cardano-ledger-binary >=1.0, cardano-ledger-core >=1.6 && <1.7, - cardano-ledger-shelley >=1.5.1 && <1.6, + cardano-ledger-shelley >=1.6 && <1.7, containers, deepseq, groups, diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/PParams.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/PParams.hs index ab33bfa7b7a..e5317ac7a68 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/PParams.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/PParams.hs @@ -8,6 +8,7 @@ import Cardano.Ledger.Crypto import Cardano.Ledger.Mary.Era (MaryEra) import Cardano.Ledger.Shelley.Governance (EraGov (..), ShelleyGovState (..), curPParamsShelleyGovStateL, prevPParamsShelleyGovStateL) import Cardano.Ledger.Shelley.PParams +import Cardano.Ledger.Val (Val (..)) import Data.Coerce import Lens.Micro @@ -55,3 +56,5 @@ instance Crypto c => EraGov (MaryEra c) where curPParamsGovStateL = curPParamsShelleyGovStateL prevPParamsGovStateL = prevPParamsShelleyGovStateL + + obligationGovState = const zero diff --git a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs index a85156d8a44..72c866e72a8 100644 --- a/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs +++ b/eras/mary/impl/src/Cardano/Ledger/Mary/TxBody.hs @@ -57,6 +57,7 @@ import Cardano.Ledger.MemoBytes ( ) import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) import Cardano.Ledger.Shelley.PParams (Update) +import Cardano.Ledger.Shelley.TxBody (totalTxDepositsShelley) import Cardano.Ledger.TxIn (TxIn (..)) import Control.DeepSeq (NFData (..)) import Data.Sequence.Strict (StrictSeq) @@ -265,6 +266,8 @@ instance Crypto c => ShelleyEraTxBody (MaryEra c) where lensMaryTxBodyRaw atbrUpdate $ \txBodyRaw update -> txBodyRaw {atbrUpdate = update} {-# INLINEABLE updateTxBodyL #-} + getTotalDepositsTxBody = totalTxDepositsShelley + instance Crypto c => AllegraEraTxBody (MaryEra c) where {-# SPECIALIZE instance AllegraEraTxBody (MaryEra StandardCrypto) #-} diff --git a/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal b/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal index 7c2512263f4..6280fbf6e84 100644 --- a/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal +++ b/eras/shelley-ma/test-suite/cardano-ledger-shelley-ma-test.cabal @@ -54,7 +54,7 @@ library containers, hashable, cardano-ledger-shelley-test >=1.1, - cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.5 && <1.6, + cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.6 && <1.7, cardano-strict-containers, microlens, mtl, diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 5394cc2951a..5907b95dbfe 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -1,7 +1,15 @@ # Version history for `cardano-ledger-shelley` -## 1.5.1.0 - +## 1.6.0.0 + +* Add `getTotalTxDepositsBody` to `ShelleyEraTxBody` +* Add `obligationGovState` to `EraGov` +* Add `ToExpr` instance to `Constitution` +* Replace `obligationCertState` with `totalObligation` +* Deprecated `totalTxDeposits` +* Add `potEqualsObligation` +* Add `shelleyLedgerAssertions` +* Add `totalTxDepositsShelley` * Add `eqMultiSigRaw`, `shelleyEqTxRaw` and `shelleyEqTxWitsRaw` * Add `EqRaw` instance for `MultiSig`, `ShelleyTxWits`, `ShelleyTxAuxData`, `TxBody` and `Tx` * Add `ToExpr` instance for `GenesisDelegCert`, `MIRPot`, `MirTarget`, `MIRCert`, diff --git a/eras/shelley/impl/cardano-ledger-shelley.cabal b/eras/shelley/impl/cardano-ledger-shelley.cabal index 9ec4e666cfd..1e3b1472f07 100644 --- a/eras/shelley/impl/cardano-ledger-shelley.cabal +++ b/eras/shelley/impl/cardano-ledger-shelley.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-shelley -version: 1.5.1.0 +version: 1.6.0.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs index 39458441d48..49df3a6b2bc 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/AdaPots.hs @@ -28,7 +28,6 @@ import Cardano.Ledger.Compactible (fromCompact) import Cardano.Ledger.Core import Cardano.Ledger.Shelley.LedgerState.RefundsAndDeposits ( keyTxRefunds, - totalTxDeposits, ) import Cardano.Ledger.Shelley.LedgerState.Types ( AccountState (..), @@ -166,5 +165,5 @@ producedTxBody txBody pp dpstate = Produced { proOutputs = coinBalance (txouts txBody) , proFees = txBody ^. feeTxBodyL - , proDeposits = totalTxDeposits pp dpstate txBody + , proDeposits = getTotalDepositsTxBody pp dpstate txBody } diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Core.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Core.hs index c4a1f4dbd31..11517ccdaa4 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Core.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Core.hs @@ -20,6 +20,7 @@ module Cardano.Ledger.Shelley.Core ( where import Cardano.Ledger.Address +import Cardano.Ledger.CertState (CertState) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Core import Cardano.Ledger.Shelley.Era (ShelleyEra) @@ -41,6 +42,8 @@ class (ShelleyEraTxCert era, EraTxBody era) => ShelleyEraTxBody era where default updateTxBodyG :: ProtVerAtMost era 8 => SimpleGetter (TxBody era) (StrictMaybe (Update era)) updateTxBodyG = updateTxBodyL + getTotalDepositsTxBody :: PParams era -> CertState era -> TxBody era -> Coin + type Wdrl c = Withdrawals c {-# DEPRECATED Wdrl "In favor of `Cardano.Ledger.Address.Withdrawals`" #-} pattern Wdrl :: Map (RewardAcnt c) Coin -> Withdrawals c diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs index 3549da6d1d1..939b9d116eb 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Governance.hs @@ -32,11 +32,13 @@ import Cardano.Ledger.Binary ( encodeNullStrictMaybe, ) import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), ( Coin + instance ( ToExpr (PParamsUpdate era) , ToExpr (PParams era) @@ -97,6 +101,8 @@ instance Crypto c => EraGov (ShelleyEra c) where prevPParamsGovStateL = prevPParamsShelleyGovStateL + obligationGovState = const zero + data ShelleyGovState era = ShelleyGovState { proposals :: !(ProposedPPUpdates era) , futureProposals :: !(ProposedPPUpdates era) @@ -215,6 +221,8 @@ data Constitution era = Constitution } deriving (Generic) +instance ToExpr (Constitution era) + constitutionAnchorL :: Lens' (Constitution era) (Anchor (EraCrypto era)) constitutionAnchorL = lens constitutionAnchor (\x y -> x {constitutionAnchor = y}) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs index 8e250fd5961..6f719d1106c 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs @@ -51,7 +51,7 @@ module Cardano.Ledger.Shelley.LedgerState ( payPoolDeposit, refundPoolDeposit, totalTxDeposits, - obligationCertState, + totalObligation, keyCertsRefunds, keyCertsRefundsCertState, totalCertsDeposits, diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs index 8261e880845..abccadfaf62 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/NewEpochState.hs @@ -36,7 +36,6 @@ import Cardano.Ledger.Keys ( import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.LedgerState.RefundsAndDeposits ( keyTxRefunds, - totalTxDeposits, ) import Cardano.Ledger.Shelley.LedgerState.Types import Cardano.Ledger.Shelley.TxBody (MIRPot (..)) @@ -118,7 +117,7 @@ depositPoolChange ls pp txBody = (currentPool <+> txDeposits) <-> txRefunds -- to emphasize this point. currentPool = (utxosDeposited . lsUTxOState) ls - txDeposits = totalTxDeposits pp (lsCertState ls) txBody + txDeposits = getTotalDepositsTxBody pp (lsCertState ls) txBody txRefunds = keyTxRefunds pp (lsCertState ls) txBody -- Remove the rewards from the UMap, but leave the deposits alone diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs index 741c762d5a9..bab610bf24d 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/RefundsAndDeposits.hs @@ -8,12 +8,13 @@ {-# LANGUAGE TypeApplications #-} module Cardano.Ledger.Shelley.LedgerState.RefundsAndDeposits ( - totalTxDeposits, totalCertsDeposits, totalCertsDepositsCertState, keyTxRefunds, keyCertsRefunds, keyCertsRefundsCertState, + totalTxDeposits, + totalTxDepositsShelley, ) where @@ -79,15 +80,24 @@ totalCertsDepositsCertState pp dpstate = -- | Calculates the total amount of deposits needed for all pool registration and -- stake delegation certificates to be valid. -totalTxDeposits :: +totalTxDepositsShelley :: ShelleyEraTxBody era => PParams era -> CertState era -> TxBody era -> Coin -totalTxDeposits pp dpstate txb = +totalTxDepositsShelley pp dpstate txb = totalCertsDepositsCertState pp dpstate (txb ^. certsTxBodyL) +{-# DEPRECATED totalTxDeposits "Use totalTxDepositsShelley or getTotalDepositsTxBody instead" #-} +totalTxDeposits :: + ShelleyEraTxBody era => + PParams era -> + CertState era -> + TxBody era -> + Coin +totalTxDeposits = totalTxDepositsShelley + -- | Compute the key deregistration refunds in a transaction keyCertsRefundsCertState :: (EraPParams era, Foldable f, ShelleyEraTxCert era) => diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs index b6f1cd67bd3..06d59ef3916 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs @@ -47,6 +47,7 @@ import Cardano.Ledger.CertState ( certDStateL, certVStateL, dsUnifiedL, + obligationCertState, vsDRepDistrL, vsDRepsL, ) @@ -274,7 +275,8 @@ toIncrementalStakePairs iStake@(IStake _ _) = -- this invariant. This happens in the UTxO rule. data UTxOState era = UTxOState { utxosUtxo :: !(UTxO era) - , utxosDeposited :: !Coin + , utxosDeposited :: Coin + -- ^ This field is left lazy, because we only use it for assertions , utxosFees :: !Coin , utxosGovState :: !(GovState era) , utxosStakeDistr :: !(IncrementalStake (EraCrypto era)) @@ -757,3 +759,18 @@ freshDRepPulser n es = (es ^. epochStateUMapL) (es ^. epochStateRegDrepL) (VMap.fromMap (compactCoinOrError <$> (es ^. epochStateIncrStakeDistrL))) + +potEqualsObligation :: + EraGov era => + CertState era -> + UTxOState era -> + Bool +potEqualsObligation certState utxoSt = obligation == pot + where + obligation = totalObligation certState (utxoSt ^. utxosGovStateL) + pot = utxoSt ^. utxosDepositedL + +totalObligation :: EraGov era => CertState era -> GovState era -> Coin +totalObligation certState govState = + obligationCertState certState + <> obligationGovState govState diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs index 11904e728d1..9279880f096 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Epoch.hs @@ -39,7 +39,8 @@ import Cardano.Ledger.Shelley.LedgerState ( lsCertState, lsUTxOState, lsUTxOStateL, - obligationCertState, + totalObligation, + utxosGovStateL, pattern CertState, pattern EpochState, ) @@ -214,7 +215,7 @@ epochTransition = do -- kept (dsUnified of DState and psDeposits of PState) are adjusted by -- the rules, So we can recompute the utxosDeposited field using adjustedCertState -- since we have the invariant that: obligationCertState dpstate == utxosDeposited utxostate - oblgNew = obligationCertState adjustedCertState + oblgNew = totalObligation adjustedCertState (utxoSt'' ^. utxosGovStateL) reserves = asReserves acnt' utxoSt''' = utxoSt'' {utxosDeposited = oblgNew} acnt'' = acnt' {asReserves = reserves} diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs index b59834fde7e..cb1bda1fd46 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs @@ -24,6 +24,7 @@ module Cardano.Ledger.Shelley.Rules.Ledger ( PredicateFailure, epochFromSlot, depositEqualsObligation, + shelleyLedgerAssertions, ) where @@ -45,8 +46,8 @@ import Cardano.Ledger.Shelley.LedgerState ( LedgerState (..), PState (..), UTxOState (..), - obligationCertState, ) +import Cardano.Ledger.Shelley.LedgerState.Types (potEqualsObligation) import Cardano.Ledger.Shelley.Rules.Delegs ( DelegsEnv (..), ShelleyDELEGS, @@ -163,9 +164,23 @@ epochFromSlot slot = do ei <- asks epochInfoPure epochInfoEpoch ei slot +shelleyLedgerAssertions :: + ( EraGov era + , State (rule era) ~ LedgerState era + ) => + [Assertion (rule era)] +shelleyLedgerAssertions = + [ PostCondition + "Deposit pot must equal obligation (LEDGER)" + ( \(TRC (_, _, _)) + (LedgerState utxoSt dpstate) -> potEqualsObligation dpstate utxoSt + ) + ] + instance ( DSignable (EraCrypto era) (Hash (EraCrypto era) EraIndependentTxBody) , EraTx era + , EraGov era , ShelleyEraTxBody era , Embed (EraRule "DELEGS" era) (ShelleyLEDGER era) , Embed (EraRule "UTXOW" era) (ShelleyLEDGER era) @@ -191,14 +206,7 @@ instance renderAssertionViolation = depositEqualsObligation - assertions = - [ PostCondition - "Deposit pot must equal obligation (ShelleyLedger)" - ( \(TRC (_, _, _)) - (LedgerState utxoSt dpstate) -> - obligationCertState dpstate == utxosDeposited utxoSt - ) - ] + assertions = shelleyLedgerAssertions ledgerTransition :: forall era. diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Newpp.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Newpp.hs index b588d577199..5f4a2f34fac 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Newpp.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Newpp.hs @@ -26,7 +26,8 @@ import Cardano.Ledger.Shelley.LedgerState ( DState (..), PState (..), UTxOState (utxosDeposited), - obligationCertState, + totalObligation, + utxosGovStateL, ) import Cardano.Ledger.Shelley.PParams ( ProposedPPUpdates (ProposedPPUpdates), @@ -63,7 +64,7 @@ data ShelleyNewppPredFailure era instance NoThunks (ShelleyNewppPredFailure era) instance - ( EraPParams era + ( EraGov era , GovState era ~ ShelleyGovState era ) => STS (ShelleyNEWPP era) @@ -80,8 +81,8 @@ instance EraPParams era => Default (ShelleyNewppState era) where newPpTransition :: forall era. - ( EraPParams era - , GovState era ~ ShelleyGovState era + ( GovState era ~ ShelleyGovState era + , EraGov era ) => TransitionRule (ShelleyNEWPP era) newPpTransition = do @@ -94,7 +95,10 @@ newPpTransition = do case ppNew of Just ppNew' -> do - let Coin oblgCurr = obligationCertState (CertState def pstate dstate) + let Coin oblgCurr = + totalObligation + (CertState def pstate dstate) + (utxoSt ^. utxosGovStateL) Coin oblgCurr == utxosDeposited utxoSt ?! UnexpectedDepositPot (Coin oblgCurr) (utxosDeposited utxoSt) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs index 9ea721a574d..142ff4fcbde 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs @@ -27,15 +27,16 @@ import Cardano.Ledger.Core import Cardano.Ledger.Credential (Credential) import Cardano.Ledger.Keys (KeyHash, KeyRole (StakePool, Staking)) import Cardano.Ledger.Shelley.Era (ShelleyPOOLREAP) +import Cardano.Ledger.Shelley.Governance (EraGov) import Cardano.Ledger.Shelley.LedgerState ( AccountState (..), CertState (..), DState (..), PState (..), UTxOState (..), - obligationCertState, rewards, ) +import Cardano.Ledger.Shelley.LedgerState.Types (potEqualsObligation) import Cardano.Ledger.Shelley.TxBody (RewardAcnt, getRwdCred, ppRewardAcnt) import Cardano.Ledger.Slot (EpochNo (..)) import Cardano.Ledger.UMap (UView (RewDepUView, SPoolUView), compactCoinOrError) @@ -90,7 +91,13 @@ instance NoThunks (ShelleyPoolreapPredFailure era) instance Default (UTxOState era) => Default (ShelleyPoolreapState era) where def = PoolreapState def def def def -instance (Default (ShelleyPoolreapState era), EraPParams era) => STS (ShelleyPOOLREAP era) where +instance + ( Default (ShelleyPoolreapState era) + , EraPParams era + , EraGov era + ) => + STS (ShelleyPOOLREAP era) + where type State (ShelleyPOOLREAP era) = ShelleyPoolreapState era type Signal (ShelleyPOOLREAP era) = EpochNo type Environment (ShelleyPOOLREAP era) = ShelleyPoolreapEnv era @@ -101,9 +108,10 @@ instance (Default (ShelleyPoolreapState era), EraPParams era) => STS (ShelleyPOO assertions = [ PostCondition "Deposit pot must equal obligation (PoolReap)" - ( \(TRC (e, _, _)) st -> - obligationCertState (CertState (speVState e) (prPState st) (prDState st)) - == utxosDeposited (prUTxOSt st) + ( \(TRC (_, _, _)) st -> + potEqualsObligation + (CertState def (prPState st) (prDState st)) + (prUTxOSt st) ) , PostCondition "PoolReap may not create or remove reward accounts" diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Upec.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Upec.hs index abb6a6365c6..ebd56091c2b 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Upec.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Upec.hs @@ -75,7 +75,7 @@ newtype ShelleyUpecPredFailure era instance NoThunks (ShelleyUpecPredFailure era) instance - ( EraPParams era + ( EraGov era , Default (PParams era) , GovState era ~ ShelleyGovState era ) => diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs index 569b881e2fc..196015b977a 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Utxo.hs @@ -67,7 +67,6 @@ import Cardano.Ledger.Shelley.LedgerState ( PPUPPredFailure, UTxOState (..), keyTxRefunds, - totalTxDeposits, ) import Cardano.Ledger.Shelley.LedgerState.IncrementalStake import Cardano.Ledger.Shelley.PParams (Update) @@ -427,7 +426,7 @@ utxoInductive = do runTest $ validateMaxTxSizeUTxO pp tx let refunded = keyTxRefunds pp dpstate txBody - let totalDeposits' = totalTxDeposits pp dpstate txBody + let totalDeposits' = getTotalDepositsTxBody pp dpstate txBody let depositChange = totalDeposits' Val.<-> refunded tellEvent $ TotalDeposits (hashAnnotated txBody) depositChange pure $! updateUTxOState pp u txBody depositChange ppup' diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs index 7038e5e0b5b..bc7e85bbdac 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/TxBody.hs @@ -61,6 +61,7 @@ module Cardano.Ledger.Shelley.TxBody ( -- * Helpers addrEitherShelleyTxOutL, valueEitherShelleyTxOutL, + totalTxDepositsShelley, ) where import Cardano.Ledger.Address (RewardAcnt (..)) @@ -106,6 +107,7 @@ import Cardano.Ledger.PoolParams import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeToHash) import Cardano.Ledger.Shelley.Core import Cardano.Ledger.Shelley.Era (ShelleyEra) +import Cardano.Ledger.Shelley.LedgerState.RefundsAndDeposits (totalTxDepositsShelley) import Cardano.Ledger.Shelley.PParams (Update) import Cardano.Ledger.Shelley.TxCert ( GenesisDelegCert (..), @@ -320,6 +322,8 @@ instance Crypto c => ShelleyEraTxBody (ShelleyEra c) where lensMemoRawType stbrUpdate $ \txBodyRaw update -> txBodyRaw {stbrUpdate = update} {-# INLINEABLE updateTxBodyL #-} + getTotalDepositsTxBody = totalTxDepositsShelley + deriving newtype instance (Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) => NoThunks (ShelleyTxBody era) diff --git a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal index a47c9124a62..f54af533a62 100644 --- a/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal +++ b/eras/shelley/test-suite/cardano-ledger-shelley-test.cabal @@ -89,7 +89,7 @@ library cardano-ledger-byron-test, cardano-ledger-core:{cardano-ledger-core, testlib} >=1.3.1, cardano-ledger-pretty, - cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.5 && <1.6, + cardano-ledger-shelley:{cardano-ledger-shelley, testlib} >=1.6 && <1.7, cardano-protocol-tpraos:{cardano-protocol-tpraos, testlib} >=1.0.1, cardano-slotting, cborg, diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Ledger.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Ledger.hs index 5a601999815..66850d10e1f 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Ledger.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Generator/Trace/Ledger.hs @@ -74,6 +74,7 @@ genAccountState Constants {minTreasury, maxTreasury, minReserves, maxReserves} = -- with meaningful delegation certificates. instance ( EraGen era + , EraGov era , Mock (EraCrypto era) , MinLEDGER_STS era , Embed (EraRule "DELPL" era) (CERTS era) diff --git a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs index 3b8bd0696c0..fe421a94a31 100644 --- a/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs +++ b/eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs @@ -52,7 +52,6 @@ import Cardano.Ledger.Shelley.LedgerState ( prevPParamsEpochStateL, rewards, rs, - totalTxDeposits, ) import Cardano.Ledger.Shelley.Rewards (sumRewards) import Cardano.Ledger.Shelley.Rules ( @@ -295,7 +294,7 @@ checkPreservation SourceSignalTarget {source, target, signal} count = ++ "\ncerts:" ++ showListy ((" " ++) . synopsisCert) (toList $ tx ^. bodyTxL . certsTxBodyL) ++ "total deposits " - ++ show (totalTxDeposits currPP oldCertState (tx ^. bodyTxL)) + ++ show (getTotalDepositsTxBody currPP oldCertState (tx ^. bodyTxL)) ++ "\ntotal refunds " ++ show (keyTxRefunds currPP oldCertState (tx ^. bodyTxL)) @@ -481,7 +480,7 @@ preserveBalance SourceSignalTarget {source = chainSt, signal = block} = created = coinBalance u' <+> (txb ^. feeTxBodyL) - <+> totalTxDeposits pp_ dpstate txb + <+> getTotalDepositsTxBody pp_ dpstate txb consumed_ = coinBalance u <+> keyTxRefunds pp_ dpstate txb @@ -522,7 +521,7 @@ preserveBalanceRestricted SourceSignalTarget {source = chainSt, signal = block} coinBalance (txouts @era txb) <> txb ^. feeTxBodyL - <> totalTxDeposits pp_ dpstate txb + <> getTotalDepositsTxBody pp_ dpstate txb preserveOutputsTx :: forall era ledger. diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/RulesTests.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/RulesTests.hs index f88a3f4ae6a..ceaeda9cc5e 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/RulesTests.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/RulesTests.hs @@ -25,7 +25,8 @@ import Cardano.Ledger.Shelley.LedgerState ( LedgerState (..), NewEpochState (..), UTxOState (..), - obligationCertState, + totalObligation, + utxosGovStateL, ) import Cardano.Ledger.Shelley.RewardUpdate (PulsingRewUpdate (..), RewardUpdate (..)) import Cardano.Ledger.Shelley.Rules (ShelleyUtxowPredFailure (..)) @@ -37,6 +38,7 @@ import Data.Either (isRight) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe) import qualified Data.Set as Set +import Lens.Micro ((^.)) import Test.Cardano.Ledger.Core.KeyPair (vKey) import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (C, C_Crypto) import Test.Cardano.Ledger.Shelley.Examples (testCHAINExample) @@ -568,7 +570,13 @@ setDepositsToObligation nes = nes {nesEs = es {esLState = ls {lsUTxOState = utxo where es = nesEs nes ls = esLState es - utxoState = (lsUTxOState ls) {utxosDeposited = obligationCertState $ lsCertState ls} + utxoState = + (lsUTxOState ls) + { utxosDeposited = + totalObligation + (lsCertState ls) + (utxoState ^. utxosGovStateL) + } -- | This property test checks the correctness of the TICKF transation. -- TICKF is used by the consensus layer to get a ledger view in a computationally diff --git a/libs/cardano-ledger-api/CHANGELOG.md b/libs/cardano-ledger-api/CHANGELOG.md index 9d9e75611a2..99c203c4930 100644 --- a/libs/cardano-ledger-api/CHANGELOG.md +++ b/libs/cardano-ledger-api/CHANGELOG.md @@ -1,8 +1,8 @@ # Version history for `cardano-ledger-api` -## 1.4.0.1 +## 1.4.1.0 -* +* Add `cgEnactStateL` ## 1.4.0.0 diff --git a/libs/cardano-ledger-api/cardano-ledger-api.cabal b/libs/cardano-ledger-api/cardano-ledger-api.cabal index e776aafd7d7..396c80ffa14 100644 --- a/libs/cardano-ledger-api/cardano-ledger-api.cabal +++ b/libs/cardano-ledger-api/cardano-ledger-api.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: cardano-ledger-api -version: 1.4.0.1 +version: 1.4.1.0 license: Apache-2.0 maintainer: operations@iohk.io author: IOHK @@ -56,7 +56,7 @@ library cardano-ledger-conway >=1.7, cardano-ledger-core >=1.5 && <1.7, cardano-ledger-mary >=1.1, - cardano-ledger-shelley ^>=1.5, + cardano-ledger-shelley ^>=1.6, cardano-slotting, containers, microlens, diff --git a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Governance.hs b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Governance.hs index e393c88f36c..93656909c05 100644 --- a/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Governance.hs +++ b/libs/cardano-ledger-api/src/Cardano/Ledger/Api/Governance.hs @@ -23,6 +23,7 @@ module Cardano.Ledger.Api.Governance ( -- ** Governance State ConwayGovState (..), cgRatifyStateL, + cgEnactStateL, cgGovActionsStateL, GovActionsState (..), RatifyState (..), @@ -68,6 +69,7 @@ import Cardano.Ledger.Conway.Governance ( Voter (..), VotingProcedure (..), VotingProcedures (..), + cgEnactStateL, cgGovActionsStateL, cgRatifyStateL, constitutionAnchorL, diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs index f1f5b1b8c80..79c9675cf99 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/CertState.hs @@ -291,6 +291,8 @@ deriving instance Era era => EncCBOR (CommitteeState era) deriving instance Era era => DecCBOR (CommitteeState era) +deriving instance Era era => ToJSON (CommitteeState era) + instance Era era => ToCBOR (CommitteeState era) where toCBOR = toEraCBOR @era diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs index dca0e36c3cd..1a6242be591 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Core/PParams.hs @@ -220,6 +220,7 @@ class , FromCBOR (PParamsHKD Identity era) , NoThunks (PParamsHKD Identity era) , ToJSON (PParamsHKD Identity era) + , ToExpr (PParamsHKD Identity era) , Eq (PParamsHKD StrictMaybe era) , Ord (PParamsHKD StrictMaybe era) , Show (PParamsHKD StrictMaybe era) @@ -230,6 +231,7 @@ class , FromCBOR (PParamsHKD StrictMaybe era) , NoThunks (PParamsHKD StrictMaybe era) , ToJSON (PParamsHKD StrictMaybe era) + , ToExpr (PParamsHKD StrictMaybe era) ) => EraPParams era where diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/DRepDistr.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/DRepDistr.hs index 40719f2ffca..78a9835a1be 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/DRepDistr.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/DRepDistr.hs @@ -34,6 +34,7 @@ import Cardano.Ledger.UMap import qualified Cardano.Ledger.UMap as UMap import Control.DeepSeq (NFData (..), deepseq) import Control.Monad.Identity (Identity (..)) +import Data.Aeson (ToJSON) import Data.Kind import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -74,7 +75,9 @@ instance Crypto c => EncCBOR (DRepState c) where !> To drepAnchor !> To drepDeposit -instance ToExpr (DRepState era) +instance ToExpr (DRepState c) + +instance Crypto c => ToJSON (DRepState c) drepExpiryL :: Lens' (DRepState c) EpochNo drepExpiryL = lens drepExpiry (\x y -> x {drepExpiry = y}) diff --git a/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal b/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal index f65e449c442..fa92be44568 100644 --- a/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal +++ b/libs/cardano-ledger-pretty/cardano-ledger-pretty.cabal @@ -42,7 +42,7 @@ library cardano-ledger-conway ^>=1.8, cardano-ledger-core ^>=1.6, cardano-ledger-mary >=1.0, - cardano-ledger-shelley ^>=1.5, + cardano-ledger-shelley ^>=1.6, cardano-protocol-tpraos >=1.0, cardano-slotting, containers, diff --git a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs index 43947029766..6a8ad745163 100644 --- a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs +++ b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs @@ -266,7 +266,15 @@ instance EraPParams era => PrettyA (ConwayGovPredFailure era) where prettyA = viaShow instance PrettyA (PParamsUpdate era) => PrettyA (GovActionsState era) where - prettyA (GovActionsState x) = prettyA x + prettyA x@(GovActionsState _ _ _ _) = + let GovActionsState {..} = x + in ppRecord + "GovActionsState" + [ ("curGovActionsState", prettyA curGovActionsState) + , ("prevGovActionsState", prettyA prevGovActionsState) + , ("prevDRepsState", prettyA prevDRepsState) + , ("prevCommitteeState", prettyA prevCommitteeState) + ] instance PrettyA (GovActionId era) where prettyA gaid@(GovActionId _ _) = @@ -330,12 +338,11 @@ instance ) => PrettyA (RatifyState era) where - prettyA rs@(RatifyState _ _ _) = + prettyA rs@(RatifyState _ _) = let RatifyState {..} = rs in ppRecord "RatifyState" [ ("EnactState", prettyA rsEnactState) - , ("Future", prettyA rsFuture) , ("Removed", prettyA rsRemoved) ] @@ -350,7 +357,7 @@ instance in ppRecord "ConwayGovState" [ ("GovActionsState", prettyA cgGovActionsState) - , ("RatifyState", prettyA cgRatifyState) + , ("EnactState", prettyA cgEnactState) ] instance diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs index 6bba81c3801..3a5a7d33d65 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/ConwayFeatures.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} @@ -28,7 +29,13 @@ import Cardano.Ledger.BaseTypes ( ) import Cardano.Ledger.Block (txid) import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) -import Cardano.Ledger.Conway.Core (ConwayEraPParams (..), ConwayEraTxBody, ppDRepActivityL, ppGovActionDepositL, ppGovActionExpirationL) +import Cardano.Ledger.Conway.Core ( + ConwayEraPParams (..), + ConwayEraTxBody, + ppDRepActivityL, + ppGovActionDepositL, + ppGovActionExpirationL, + ) import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Conway.TxCert import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) @@ -53,7 +60,6 @@ import Cardano.Ledger.TxIn (TxIn (..)) import Cardano.Ledger.Val (Val (..), inject) import Control.State.Transition.Extended hiding (Assertion) import Data.Default.Class (Default (..)) -import Data.Foldable (toList) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust) import Data.Proxy (Proxy (..)) @@ -93,6 +99,10 @@ import Test.Cardano.Protocol.Crypto.VRF (VRFKeyPair (..)) import Test.Tasty import Test.Tasty.HUnit +import Control.Exception (evaluate) +import Test.Cardano.Ledger.Binary.TreeDiff (assertExprEqualWithMessage) +import Test.Cardano.Ledger.Generic.PrettyCore () + stakeKeyHash :: forall era. Era era => Proof era -> KeyHash 'Staking (EraCrypto era) stakeKeyHash _pf = hashKey . snd $ mkKeyPair (RawSeed 0 0 0 0 2) @@ -138,7 +148,7 @@ proposedConstitution = Constitution (SLE.mkDummyAnchor 1) SNothing newConstitutionProposal :: forall era. Scriptic era => Proof era -> ProposalProcedure era newConstitutionProposal pf = ProposalProcedure - (Coin proposalDeposit) + proposalDeposit (RewardAcnt Testnet (KeyHashObj (stakeKeyHash pf))) (NewConstitution SNothing (proposedConstitution @era)) (Anchor (fromJust $ textToUrl "new.constitution.com") (SLE.mkDummySafeHash Proxy 1)) @@ -151,7 +161,7 @@ anotherConstitutionProposal :: ProposalProcedure era anotherConstitutionProposal pf prevGovActionId = ProposalProcedure - (Coin proposalDeposit) + proposalDeposit (RewardAcnt Testnet (KeyHashObj (stakeKeyHash pf))) ( NewConstitution (SJust (PrevGovActionId prevGovActionId)) @@ -206,16 +216,17 @@ pp = & ppMaxValSizeL .~ 1000000000 & ppDRepActivityL .~ 100 & ppGovActionExpirationL .~ 30 - & ppGovActionDepositL .~ Coin proposalDeposit + & ppGovActionDepositL .~ proposalDeposit fee :: Integer fee = 5 -proposalDeposit :: Integer -proposalDeposit = 10 +proposalDeposit :: Coin +proposalDeposit = Coin 10 -expectRight :: Show a => String -> Either a b -> b -expectRight msg = either (\x -> error (msg <> show x)) id +-- | Evaluates an `Either` value and fails immediately if the result is `Left` +expectRight :: (HasCallStack, Show a) => String -> Either a b -> IO b +expectRight msg = either (\x -> error (msg <> show x)) evaluate proposal :: forall era. (Scriptic era, EraTxBody era) => Proof era -> TestCaseData era proposal pf = @@ -226,7 +237,7 @@ proposal pf = [ Inputs' [someTxIn] , Collateral' [] , Outputs' - [ newTxOut pf [Address (addrKeys2 pf), Amount (inject $ Coin (15000 - 10000 - fee - proposalDeposit))] -- 4985 + [ newTxOut pf [Address (addrKeys2 pf), Amount (inject $ Coin (15000 - 10000 - fee) <-> proposalDeposit)] -- 4985 , newTxOut pf [Address (addrKeys1 pf), Amount (inject $ Coin 10000)] ] , Txfee (Coin fee) @@ -257,7 +268,7 @@ secondProposal pf govActionId = [ Inputs' [TxIn (gaidTxId govActionId) (mkTxIx 1)] , Collateral' [] , Outputs' - [ newTxOut pf [Address (addrKeys2 pf), Amount (inject $ Coin (10000 - 7000 - fee - proposalDeposit))] + [ newTxOut pf [Address (addrKeys2 pf), Amount (inject $ Coin (10000 - 7000 - fee) <-> proposalDeposit)] , newTxOut pf [Address (addrKeys1 pf), Amount (inject $ Coin 7000)] ] , Txfee (Coin fee) @@ -337,28 +348,35 @@ testGov pf = do govActionId = GovActionId (txid (proposalTx ^. bodyTxL)) (GovActionIx 0) expectedGovState0 = - GovActionsState $ - Map.fromList - [ (govActionId, govActionState govActionId (newConstitutionProposal pf)) - ] - expectedGov0 = ConwayGovState expectedGovState0 (initialGov ^. cgRatifyStateL) + GovActionsState + (Map.fromList [(govActionId, govActionState govActionId (newConstitutionProposal pf))]) + mempty + mempty + def + expectedGov0 = ConwayGovState expectedGovState0 (initialGov ^. cgEnactStateL) eitherLedgerState0 = runLEDGER (LEDGER pf) initialLedgerState pp (trustMeP pf True proposalTx) - ledgerState0@(LedgerState (UTxOState _ _ _ govState0 _ _) _) = - expectRight "Error running LEDGER when proposing: " eitherLedgerState0 + ledgerState0@(LedgerState (UTxOState _ _ _ govState0 _ _) _) <- + expectRight "Error running LEDGER when proposing: " eitherLedgerState0 - assertEqual "govState after proposal" govState0 expectedGov0 + assertExprEqualWithMessage "govState after proposal" govState0 expectedGov0 + -- Propose first constitution let voteTx = txFromTestCaseData pf (vote pf govActionId) gas = govActionStateWithYesVotes govActionId pf (newConstitutionProposal pf) - expectedGovState1 = GovActionsState $ Map.fromList [(govActionId, gas)] - expectedGov1 = ConwayGovState expectedGovState1 (initialGov ^. cgRatifyStateL) + expectedGovState1 = + GovActionsState + (Map.fromList [(govActionId, gas)]) + mempty + mempty + def + expectedGov1 = ConwayGovState expectedGovState1 (initialGov ^. cgEnactStateL) eitherLedgerState1 = runLEDGER (LEDGER pf) ledgerState0 pp (trustMeP pf True voteTx) - ledgerState1@(LedgerState (UTxOState _ _ _ govState1 _ _) _) = - expectRight "Error running LEDGER when voting: " eitherLedgerState1 + ledgerState1@(LedgerState (UTxOState _ _ _ govState1 _ _) _) <- + expectRight "Error running LEDGER when voting: " eitherLedgerState1 - assertEqual "govState after vote" govState1 expectedGov1 + assertExprEqualWithMessage "govState after vote" govState1 expectedGov1 let drepDistr = DRComplete $ Map.fromList [(DRepCredential (drepCredential pf), CompactCoin 1000)] @@ -378,47 +396,66 @@ testGov pf = do ) ] ) + -- Wait two epochs eitherEpochState1 = runEPOCH (EPOCH pf) epochState0 (EpochNo 2) poolDistr - epochState1 = expectRight "Error running runEPOCH: " eitherEpochState1 - ledgerState2 = epochState1 ^. esLStateL - constitution = (ensConstitution . rsEnactState) (epochState1 ^. esLStateL . lsUTxOStateL . utxosGovStateL . cgRatifyStateL) - assertEqual "constitution after enactment" constitution (proposedConstitution @era) - + epochState1 <- expectRight "Error running runEPOCH: " eitherEpochState1 let + constitution = epochState1 ^. esLStateL . lsUTxOStateL . utxosGovStateL . cgEnactStateL . ensConstitutionL + assertExprEqualWithMessage "constitution after one epoch" constitution def + let + epochState1' = case runEPOCH (EPOCH pf) epochState1 (EpochNo 3) poolDistr of + Left e -> error $ "Error running runEPOCH the second time: " <> show e + Right x -> x + ledgerState2 = epochState1' ^. esLStateL + constitution1 = epochState1' ^. esLStateL . lsUTxOStateL . utxosGovStateL . cgEnactStateL . ensConstitutionL + prevDRepsState1 = epochState1 ^. esLStateL . lsCertStateL . certVStateL . vsDRepsL + assertExprEqualWithMessage "constitution after enactment" constitution1 (proposedConstitution @era) + let + -- Propose another constitution secondProposalTx = txFromTestCaseData pf (secondProposal pf govActionId) secondGovActionId = GovActionId (txid (secondProposalTx ^. bodyTxL)) (GovActionIx 0) + curGAState = Map.fromList [(secondGovActionId, govActionState secondGovActionId (anotherConstitutionProposal pf govActionId))] expectedGovActionsState2 = - GovActionsState $ - Map.fromList - [ - ( secondGovActionId - , govActionState - secondGovActionId - (anotherConstitutionProposal pf govActionId) - ) - ] + GovActionsState + curGAState + mempty + prevDRepsState1 + def expectedGovState2 = ConwayGovState expectedGovActionsState2 - (ledgerState2 ^. lsUTxOStateL . utxosGovStateL . cgRatifyStateL) + (ledgerState2 ^. lsUTxOStateL . utxosGovStateL . cgEnactStateL) eitherLedgerState3 = runLEDGER (LEDGER pf) ledgerState2 pp (trustMeP pf True secondProposalTx) - ledgerState3@(LedgerState (UTxOState _ _ _ govState2 _ _) _) = - expectRight "Error running LEDGER when proposing:" eitherLedgerState3 + ledgerState3@(LedgerState (UTxOState _ _ _ govState2 _ _) _) <- + expectRight "Error running LEDGER when proposing:" eitherLedgerState3 - assertEqual "govState after second proposal" govState2 expectedGovState2 + assertExprEqualWithMessage "govState after second proposal" govState2 expectedGovState2 + -- Wait two epochs + let + epochState2 = epochState1' & esLStateL .~ ledgerState3 + epochState3 = case runEPOCH (EPOCH pf) epochState2 (EpochNo 4) poolDistr of + Right x -> x + Left e -> error $ "Error running runEPOCH: " <> show e + epochState4 = case runEPOCH (EPOCH pf) epochState3 (EpochNo 5) poolDistr of + Right x -> x + Left e -> error $ "Error running runEPOCH: " <> show e + constitution2 = epochState4 ^. esLStateL . lsUTxOStateL . utxosGovStateL . cgEnactStateL . ensConstitutionL + assertEqual "constitution after enactment after no votes" constitution2 (proposedConstitution @era) let - epochState2 = epochState1 & esLStateL .~ ledgerState3 - eitherEpochState2 = runEPOCH (EPOCH pf) epochState2 (EpochNo 2) poolDistr - epochState3 = expectRight "Error running runEPOCH: " eitherEpochState2 - constitution1 = (ensConstitution . rsEnactState) (epochState3 ^. esLStateL . lsUTxOStateL . utxosGovStateL . cgRatifyStateL) - assertEqual "constitution after enactment after no votes" constitution1 (proposedConstitution @era) - - case toList $ rsFuture (epochState3 ^. esLStateL . lsUTxOStateL . utxosGovStateL . cgRatifyStateL) of - [gas'] -> - assertEqual + currentGovActions = + epochState4 + ^. esLStateL + . lsUTxOStateL + . utxosGovStateL + . cgGovActionsStateL + . curGovActionsStateL + + case Map.toList currentGovActions of + [(gId, gas')] -> + assertExprEqualWithMessage "un-enacted govAction is recorded in rsFuture" - (gasId gas', gas') + (gId, gas') ( secondGovActionId , govActionState secondGovActionId diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs index 9583a2696e9..b5415c4de3a 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Fields.hs @@ -231,6 +231,8 @@ data PParamsField era CollateralPercentage Natural | -- | Maximum number of collateral inputs allowed in a transaction MaxCollateralInputs Natural + | -- | Proposal deposit + GovActionDeposit Coin -- ========================================================================= -- Era parametric "empty" or initial values. diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs index 2def5ec94e4..f5d2dbcd8d8 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs @@ -96,8 +96,9 @@ import Cardano.Ledger.Shelley.LedgerState ( LedgerState (..), PState (..), RewardAccounts, - obligationCertState, smartUTxOState, + totalObligation, + utxosGovStateL, ) import qualified Cardano.Ledger.Shelley.Scripts as Shelley (MultiSig (..)) import Cardano.Ledger.Shelley.TxBody (PoolParams (..)) @@ -704,7 +705,7 @@ initialLedgerState gstate = LedgerState utxostate dpstate instantaneousRewardsZero pstate = PState pools Map.empty Map.empty (fmap (const poolDeposit) pools) -- In a wellformed LedgerState the deposited equals the obligation - deposited = obligationCertState dpstate + deposited = totalObligation dpstate (utxostate ^. utxosGovStateL) pools = gsInitialPoolParams gstate pp = mPParams (gsModel gstate) keyDeposit = pp ^. ppKeyDepositL diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs index ad907d34e8d..8266926986f 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs @@ -1627,13 +1627,13 @@ pcTxBody proof txbody = ppRecord ("TxBody " <> pack (show proof)) pairs pairs = concatMap (pcTxBodyField proof) fields instance PrettyC (GovActionsState era) era where - prettyC proof (GovActionsState x) = case proof of - Shelley _ -> ppMap prettyA prettyA x - Mary _ -> ppMap prettyA prettyA x - Allegra _ -> ppMap prettyA prettyA x - Alonzo _ -> ppMap prettyA prettyA x - Babbage _ -> ppMap prettyA prettyA x - Conway _ -> ppMap prettyA prettyA x + prettyC proof x = case proof of + Shelley _ -> prettyA x + Mary _ -> prettyA x + Allegra _ -> prettyA x + Alonzo _ -> prettyA x + Babbage _ -> prettyA x + Conway _ -> prettyA x pc :: PrettyC t era => Proof era -> t -> IO () pc proof x = putStrLn (show (prettyC proof x)) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs index 8b9607b6aa9..a35a0c145b0 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/Updaters.hs @@ -390,6 +390,7 @@ updatePParams proof pp' ppf = MaxValSize maxValSize -> pp & ppMaxValSizeL .~ maxValSize CollateralPercentage colPerc -> pp & ppCollateralPercentageL .~ colPerc MaxCollateralInputs maxColInputs -> pp & ppMaxCollateralInputsL .~ maxColInputs + GovActionDeposit c -> pp & ppGovActionDepositL .~ c _ -> pp newPParams :: EraPParams era => Proof era -> [PParamsField era] -> PParams era diff --git a/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal b/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal index e60c414077d..fb991bf5f6b 100644 --- a/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal +++ b/libs/cardano-protocol-tpraos/cardano-protocol-tpraos.cabal @@ -41,7 +41,7 @@ library cardano-ledger-conway >=1.1, cardano-ledger-core >=1.2 && <1.7, cardano-ledger-mary >=1.1, - cardano-ledger-shelley >=1.5 && <1.6, + cardano-ledger-shelley >=1.6 && <1.7, cardano-slotting, containers, deepseq,