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 a5b7a2c9bb0..d2ded01c01f 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs @@ -94,7 +94,7 @@ import Cardano.Ledger.Shelley.Rules ( ) import qualified Cardano.Ledger.Shelley.Rules as Shelley import Cardano.Ledger.Slot (EpochNo) -import Cardano.Ledger.UMap (UView (..), unionKeyDeposits, (∪+), (◁)) +import Cardano.Ledger.UMap (UView (..), unionRewAgg, (∪+), (◁)) import Cardano.Ledger.Val (zero, (<->)) import Control.SetAlgebra (eval, (⨃)) import Control.State.Transition ( @@ -169,7 +169,7 @@ returnProposalDeposits removedProposals = dsUnifiedL %~ returnProposalDepositsUMap where returnProposalDepositsUMap umap = - unionKeyDeposits (RewDepUView umap) $ foldl' addReward mempty removedProposals + unionRewAgg (RewDepUView umap) $ foldl' addReward mempty removedProposals where addReward m' GovActionState {..} = Map.insertWith diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs index ccf41e60b87..20a146d2f5e 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/EpochSpec.hs @@ -11,15 +11,14 @@ module Test.Cardano.Ledger.Conway.Imp.EpochSpec (spec, electBasicCommittee) where -import Cardano.Ledger.Address import Cardano.Ledger.BaseTypes (textToUrl) import Cardano.Ledger.Coin -import Cardano.Ledger.Compactible import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Governance ( Anchor (..), ConwayGovState, GovAction (..), + ProposalProcedure (..), Voter (..), cgEnactStateL, ensCommitteeL, @@ -27,20 +26,19 @@ import Cardano.Ledger.Conway.Governance ( import Cardano.Ledger.Conway.PParams ( ppCommitteeMaxTermLengthL, ppDRepVotingThresholdsL, + ppGovActionDepositL, ppGovActionLifetimeL, ) import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.Keys import Cardano.Ledger.Shelley.LedgerState ( asTreasuryL, - epochStateUMapL, esAccountStateL, esLStateL, lsUTxOStateL, nesEsL, utxosGovStateL, ) -import Cardano.Ledger.UMap as UMap import Cardano.Ledger.Val import Data.Default.Class (Default (..)) import qualified Data.Map.Strict as Map @@ -126,13 +124,35 @@ spec = passEpoch treasuryEnd <- getsNES $ nesEsL . esAccountStateL . asTreasuryL - umap <- getsNES $ nesEsL . epochStateUMapL - let cred = getRwdCred rewardAcount - case UMap.lookup cred (RewDepUView umap) of - Nothing -> error $ "Expected a reward account: " ++ show cred - Just RDPair {rdReward} -> fromCompact rdReward `shouldBe` withdrawalAmount + treasuryStart <-> treasuryEnd `shouldBe` withdrawalAmount + it "Expired proposl deposit refunded" $ do + let deposit = Coin 999 + modifyPParams $ \pp -> + pp + & ppGovActionLifetimeL .~ 1 + & ppGovActionDepositL .~ deposit + rewardAcount <- registerRewardAccount + + getRewardAccountAmount rewardAcount `shouldReturn` Coin 0 + + govActionId <- + submitProposal $ + ProposalProcedure + { pProcDeposit = deposit + , pProcReturnAddr = rewardAcount + , pProcGovAction = TreasuryWithdrawals [(rewardAcount, Coin 123456789)] + , pProcAnchor = def + } + expectPresentGovActionId govActionId + passEpoch + passEpoch + passEpoch + expectMissingGovActionId govActionId + + getRewardAccountAmount rewardAcount `shouldReturn` deposit + electBasicCommittee :: forall era. ( HasCallStack @@ -152,6 +172,7 @@ electBasicCommittee = do } & ppCommitteeMaxTermLengthL .~ 10 & ppGovActionLifetimeL .~ 2 + & ppGovActionDepositL .~ Coin 123 khDRep <- setupSingleDRep logEntry "Registering committee member" diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs index aee54e5ce46..000e25cbb8d 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/ImpTest.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} @@ -16,6 +17,7 @@ module Test.Cardano.Ledger.Conway.ImpTest ( ConwayEraImp, submitGovAction, submitGovAction_, + submitProposal, submitFailingProposal, trySubmitGovAction, trySubmitProposal, @@ -28,7 +30,10 @@ module Test.Cardano.Ledger.Conway.ImpTest ( setupSingleDRep, conwayModifyPParams, getEnactState, + getGovActionState, lookupGovActionState, + expectPresentGovActionId, + expectMissingGovActionId, getRatifyEnv, calculateDRepAcceptedRatio, calculateCommitteeAcceptedRatio, @@ -86,7 +91,12 @@ import Cardano.Ledger.Conway.Governance ( votingDRepThreshold, votingStakePoolThreshold, ) -import Cardano.Ledger.Conway.PParams (ConwayEraPParams, ppDRepActivityL, ppGovActionLifetimeL) +import Cardano.Ledger.Conway.PParams ( + ConwayEraPParams, + ppDRepActivityL, + ppGovActionDepositL, + ppGovActionLifetimeL, + ) import Cardano.Ledger.Conway.Rules ( EnactSignal, committeeAccepted, @@ -349,6 +359,16 @@ trySubmitVote vote voter gaId = do ) ) +submitProposal :: + forall era. + ( ShelleyEraImp era + , ConwayEraTxBody era + , HasCallStack + ) => + ProposalProcedure era -> + ImpTestM era (GovActionId (EraCrypto era)) +submitProposal proposal = trySubmitProposal proposal >>= expectRightExpr + -- | Submits a transaction that proposes the given proposal trySubmitProposal :: ( ShelleyEraImp era @@ -399,14 +419,12 @@ trySubmitGovAction :: (GovActionId (EraCrypto era)) ) trySubmitGovAction ga = do + pp <- getsNES $ nesEsL . curPParamsEpochStateL khPropRwd <- freshKeyHash trySubmitProposal $ ProposalProcedure - { pProcDeposit = zero - , pProcReturnAddr = - RewardAcnt - Testnet - (KeyHashObj khPropRwd) + { pProcDeposit = pp ^. ppGovActionDepositL + , pProcReturnAddr = RewardAcnt Testnet (KeyHashObj khPropRwd) , pProcGovAction = ga , pProcAnchor = def } @@ -434,17 +452,43 @@ submitGovAction_ = void . submitGovAction getEnactState :: ConwayEraGov era => ImpTestM era (EnactState era) getEnactState = getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . enactStateGovStateL --- | Looks up the governance action state corresponding to the governance --- action id +-- | Looks up the governance action state corresponding to the governance action id lookupGovActionState :: - (HasCallStack, ConwayEraGov era) => + ConwayEraGov era => GovActionId (EraCrypto era) -> - ImpTestM era (GovActionState era) + ImpTestM era (Maybe (GovActionState era)) lookupGovActionState aId = do proposals <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . proposalsGovStateL + pure $ snapshotLookupId aId proposals + +-- | Looks up the governance action state corresponding to the governance action id +getGovActionState :: + (HasCallStack, ConwayEraGov era) => + GovActionId (EraCrypto era) -> + ImpTestM era (GovActionState era) +getGovActionState govActionId = impAnn "Expecting an action state" $ do - maybe (assertFailure $ "Could not find action state for govActionId: " <> show aId) pure $ - snapshotLookupId aId proposals + lookupGovActionState govActionId >>= \case + Nothing -> + assertFailure $ "Could not find action state for govActionId: " <> show govActionId + Just govActionState -> pure govActionState + +expectPresentGovActionId :: + (HasCallStack, ConwayEraGov era) => + GovActionId (EraCrypto era) -> + ImpTestM era () +expectPresentGovActionId govActionId = void $ getGovActionState govActionId + +expectMissingGovActionId :: + (HasCallStack, ConwayEraGov era) => + GovActionId (EraCrypto era) -> + ImpTestM era () +expectMissingGovActionId govActionId = + impAnn "Expecting for gov action state to be missing" $ do + lookupGovActionState govActionId >>= \case + Just _ -> + expectationFailure $ "Found gov action state for govActionId: " <> show govActionId + Nothing -> pure () -- | Builds a RatifyState from the current state getRatifyEnv :: ConwayEraGov era => ImpTestM era (RatifyEnv era) @@ -473,7 +517,7 @@ calculateDRepAcceptedRatio :: ImpTestM era Rational calculateDRepAcceptedRatio gaId = do ratEnv <- getRatifyEnv - gas <- lookupGovActionState gaId + gas <- getGovActionState gaId pure $ dRepAcceptedRatio @era ratEnv @@ -490,7 +534,7 @@ calculateCommitteeAcceptedRatio :: calculateCommitteeAcceptedRatio gaId = do eNo <- getsNES nesELL RatifyEnv {reCommitteeState} <- getRatifyEnv - GovActionState {gasCommitteeVotes} <- lookupGovActionState gaId + GovActionState {gasCommitteeVotes} <- getGovActionState gaId ens <- getEnactState let committee = ens ^. ensCommitteeL @@ -524,7 +568,7 @@ canGovActionBeDRepAccepted gaId = do poolDistr <- getsNES nesPdL drepDistr <- getsNES $ nesEsL . epochStateDRepPulsingStateL . psDRepDistrG drepState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL - action <- lookupGovActionState gaId + action <- getGovActionState gaId enactSt <- getEnactState committeeState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsCommitteeStateL let @@ -551,7 +595,7 @@ logRatificationChecks :: GovActionId (EraCrypto era) -> ImpTestM era () logRatificationChecks gaId = do - gas@GovActionState {gasDRepVotes, gasAction} <- lookupGovActionState gaId + gas@GovActionState {gasDRepVotes, gasAction} <- getGovActionState gaId ens@EnactState {..} <- getEnactState ratEnv <- getRatifyEnv let diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs index 49048df276d..67c03cebc3d 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/ImpTest.hs @@ -47,6 +47,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest ( impNESL, runImpRule, registerRewardAccount, + getRewardAccountAmount, constitutionShouldBe, withImpState, ) where @@ -70,7 +71,7 @@ import Cardano.Ledger.BaseTypes ( ) import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Core -import Cardano.Ledger.Credential (Credential (..), StakeReference (..)) +import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credToText) import Cardano.Ledger.Crypto (Crypto (..)) import Cardano.Ledger.EpochBoundary (emptySnapShots) import Cardano.Ledger.Keys ( @@ -82,7 +83,7 @@ import Cardano.Ledger.Keys ( import Cardano.Ledger.PoolDistr (IndividualPoolStake (..), PoolDistr (..)) import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeHash) import Cardano.Ledger.Shelley (ShelleyEra) -import Cardano.Ledger.Shelley.Core (Constitution (..), EraGov (..), ShelleyEraTxBody) +import Cardano.Ledger.Shelley.Core (Constitution (..), EraGov (..), ShelleyEraTxBody (..)) import Cardano.Ledger.Shelley.LedgerState ( AccountState (..), EpochState (..), @@ -93,6 +94,7 @@ import Cardano.Ledger.Shelley.LedgerState ( curPParamsEpochStateL, dsGenDelegsL, epochStateIncrStakeDistrL, + epochStateUMapL, esAccountStateL, esLStateL, lsCertStateL, @@ -108,6 +110,7 @@ import Cardano.Ledger.Shelley.LedgerState ( import Cardano.Ledger.Shelley.Rules (LedgerEnv (..), shelleyWitsVKeyNeeded) import Cardano.Ledger.Shelley.TxCert import Cardano.Ledger.TxIn (TxId (..), TxIn (..)) +import Cardano.Ledger.UMap as UMap import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..), sumAllCoin) import Cardano.Ledger.Val (Val (..)) import Control.DeepSeq (NFData) @@ -200,6 +203,7 @@ class (Hash (HASH (EraCrypto era)) EraIndependentTxBody) , ToExpr (PredicateFailure (EraRule "LEDGER" era)) , EraUTxO era + , ShelleyEraTxBody era , State (EraRule "LEDGER" era) ~ LedgerState era , Environment (EraRule "LEDGER" era) ~ LedgerEnv era , EraGov era @@ -401,6 +405,14 @@ instance Example (ImpTestM era ()) where runShelleyBase :: Globals -> ShelleyBase a -> a runShelleyBase globals act = runIdentity $ runReaderT act globals +getRewardAccountAmount :: RewardAcnt (EraCrypto era) -> ImpTestM era Coin +getRewardAccountAmount rewardAcount = do + umap <- getsNES $ nesEsL . epochStateUMapL + let cred = getRwdCred rewardAcount + case UMap.lookup cred (RewDepUView umap) of + Nothing -> assertFailure $ "Expected a reward account: " ++ show cred + Just RDPair {rdReward} -> pure $ fromCompact rdReward + fixupFees :: forall era. ShelleyEraImp era => @@ -409,11 +421,14 @@ fixupFees :: fixupFees tx = do ImpTestState {impRootTxId, impRootTxCoin} <- get pp <- getsNES $ nesEsL . curPParamsEpochStateL + certState <- getsNES $ nesEsL . esLStateL . lsCertStateL kpSpending <- lookupKeyPair =<< freshKeyHash kpStaking <- lookupKeyPair =<< freshKeyHash let + deposits = getTotalDepositsTxBody pp certState (tx ^. bodyTxL) + refunds = getTotalRefundsTxBody pp certState (tx ^. bodyTxL) outputsTotalCoin = sumAllCoin $ tx ^. bodyTxL . outputsTxBodyL - remainingCoin = impRootTxCoin <-> outputsTotalCoin + remainingCoin = impRootTxCoin <-> (outputsTotalCoin <+> deposits <-> refunds) remainingTxOut = mkBasicTxOut @era (mkAddr (kpSpending, kpStaking)) @@ -675,7 +690,6 @@ registerRewardAccount :: forall era. ( HasCallStack , ShelleyEraImp era - , ShelleyEraTxCert era ) => ImpTestM era (RewardAcnt (EraCrypto era)) registerRewardAccount = do @@ -684,7 +698,7 @@ registerRewardAccount = do kpSpending <- lookupKeyPair =<< freshKeyHash let stakingCredential = KeyHashObj khDelegator _ <- - submitTx "Delegate to DRep" $ + submitTx ("Register Reward Account: " <> T.unpack (credToText stakingCredential)) $ mkBasicTx mkBasicTxBody & bodyTxL . outputsTxBodyL .~ SSeq.fromList