From 490c638b80c8c5267fac11b1aefef059f8eaa3a6 Mon Sep 17 00:00:00 2001 From: Aniket Deshpande Date: Thu, 17 Aug 2023 16:44:38 +0530 Subject: [PATCH] Update DELEG, GOVCERT to spec-v0.8 --- eras/conway/impl/CHANGELOG.md | 4 + .../src/Cardano/Ledger/Conway/Rules/Cert.hs | 23 ++-- .../src/Cardano/Ledger/Conway/Rules/Certs.hs | 77 ++++++++--- .../src/Cardano/Ledger/Conway/Rules/Deleg.hs | 76 +++++----- .../Cardano/Ledger/Conway/Rules/GovCert.hs | 130 ++++++++---------- .../src/Cardano/Ledger/Conway/Rules/Ledger.hs | 54 ++++---- .../impl/src/Cardano/Ledger/Conway/UTxO.hs | 4 +- .../Test/Cardano/Ledger/Conway/Arbitrary.hs | 8 +- eras/conway/test-suite/cddl-files/conway.cddl | 2 +- .../src/Cardano/Ledger/Shelley/Rules/Pool.hs | 4 +- .../src/Cardano/Ledger/DRepDistr.hs | 6 + .../Test/Cardano/Ledger/Core/Arbitrary.hs | 2 +- .../src/Cardano/Ledger/Pretty/Conway.hs | 8 +- .../Test/Cardano/Ledger/Generic/PrettyCore.hs | 3 +- 14 files changed, 220 insertions(+), 181 deletions(-) diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 72c8c1eb287..43d226ad85f 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,10 @@ ## 1.7.0.0 +* Make `DELEG`, `POOL` and `GOVCERT` conform to spec-v0.8 #3628 + * Add `CertEnv` and `CertsEnv` to pass `EpochNo` down from `LEDGER` to sub-rules + * Add `drepDeposit` to `DRepState` to track deposits paid by `DRep`s + * Update `DRep` expiry in `LEDGER` for all `DRep`s who are voting in current `Tx` * Add `ConwayGovCertEnv` * Change the environment of `GOVCERT` to `ConwayGovCertEnv` * Add `ConwayEraGov` with `constitutionGovStateL` diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs index 05e52bcde63..e2da3abda80 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Cert.hs @@ -18,9 +18,10 @@ module Cardano.Ledger.Conway.Rules.Cert ( ConwayCERT, ConwayCertPredFailure (..), ConwayCertEvent, + CertEnv (..), ) where -import Cardano.Ledger.BaseTypes (ShelleyBase) +import Cardano.Ledger.BaseTypes (EpochNo, ShelleyBase, SlotNo) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Conway.Core @@ -43,8 +44,6 @@ import Cardano.Ledger.Conway.TxCert ( import Cardano.Ledger.Shelley.API ( CertState (..), DState, - DelegEnv (DelegEnv), - DelplEnv (DelplEnv), PState, PoolEnv (PoolEnv), VState, @@ -65,6 +64,12 @@ import Data.Typeable (Typeable) import GHC.Generics (Generic) import NoThunks.Class (NoThunks) +data CertEnv era = CertEnv + { ceSlotNo :: !SlotNo + , cePParams :: !(PParams era) + , ceCurrentEpoch :: !EpochNo + } + data ConwayCertPredFailure era = DelegFailure (PredicateFailure (EraRule "DELEG" era)) | PoolFailure (PredicateFailure (EraRule "POOL" era)) @@ -110,7 +115,7 @@ instance , State (EraRule "DELEG" era) ~ DState era , State (EraRule "POOL" era) ~ PState era , State (EraRule "GOVCERT" era) ~ VState era - , Environment (EraRule "DELEG" era) ~ DelegEnv era + , Environment (EraRule "DELEG" era) ~ PParams era , Environment (EraRule "POOL" era) ~ PoolEnv era , Environment (EraRule "GOVCERT" era) ~ ConwayGovCertEnv era , Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era) @@ -125,7 +130,7 @@ instance where type State (ConwayCERT era) = CertState era type Signal (ConwayCERT era) = TxCert era - type Environment (ConwayCERT era) = DelplEnv era + type Environment (ConwayCERT era) = CertEnv era type BaseM (ConwayCERT era) = ShelleyBase type PredicateFailure (ConwayCERT era) = ConwayCertPredFailure era type Event (ConwayCERT era) = ConwayCertEvent era @@ -137,7 +142,7 @@ certTransition :: ( State (EraRule "DELEG" era) ~ DState era , State (EraRule "POOL" era) ~ PState era , State (EraRule "GOVCERT" era) ~ VState era - , Environment (EraRule "DELEG" era) ~ DelegEnv era + , Environment (EraRule "DELEG" era) ~ PParams era , Environment (EraRule "POOL" era) ~ PoolEnv era , Environment (EraRule "GOVCERT" era) ~ ConwayGovCertEnv era , Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era) @@ -150,17 +155,17 @@ certTransition :: ) => TransitionRule (ConwayCERT era) certTransition = do - TRC (DelplEnv slot ptr pp acnt, cState, c) <- judgmentContext + TRC (CertEnv slot pp currentEpoch, cState, c) <- judgmentContext let CertState {certDState, certPState, certVState} = cState case c of ConwayTxCertDeleg delegCert -> do - newDState <- trans @(EraRule "DELEG" era) $ TRC (DelegEnv slot ptr acnt pp, certDState, delegCert) + newDState <- trans @(EraRule "DELEG" era) $ TRC (pp, certDState, delegCert) pure $ cState {certDState = newDState} ConwayTxCertPool poolCert -> do newPState <- trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp, certPState, poolCert) pure $ cState {certPState = newPState} ConwayTxCertGov govCert -> do - newVState <- trans @(EraRule "GOVCERT" era) $ TRC (ConwayGovCertEnv pp slot, certVState, govCert) + newVState <- trans @(EraRule "GOVCERT" era) $ TRC (ConwayGovCertEnv pp currentEpoch, certVState, govCert) pure $ cState {certVState = newVState} instance diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs index 29a85afab98..475d488626b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs @@ -19,9 +19,10 @@ module Cardano.Ledger.Conway.Rules.Certs ( ConwayCERTS, ConwayCertsPredFailure (..), ConwayCertsEvent (..), + CertsEnv (..), ) where -import Cardano.Ledger.BaseTypes (Globals (..), ShelleyBase, mkCertIxPartial) +import Cardano.Ledger.BaseTypes (EpochNo, Globals (..), ShelleyBase, SlotNo) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) import Cardano.Ledger.Binary.Coders ( Decode (..), @@ -31,20 +32,29 @@ import Cardano.Ledger.Binary.Coders ( (!>), ( STS (ConwayCERTS era) where type State (ConwayCERTS era) = CertState era type Signal (ConwayCERTS era) = Seq (TxCert era) - type Environment (ConwayCERTS era) = DelegsEnv era + type Environment (ConwayCERTS era) = CertsEnv era type BaseM (ConwayCERTS era) = ShelleyBase type PredicateFailure (ConwayCERTS era) = @@ -140,34 +158,49 @@ instance conwayCertsTransition :: forall era. ( EraTx era - , ShelleyEraTxBody era + , ConwayEraTxBody era + , ConwayEraPParams era , State (EraRule "CERT" era) ~ CertState era , Embed (EraRule "CERT" era) (ConwayCERTS era) - , Environment (EraRule "CERT" era) ~ DelplEnv era + , Environment (EraRule "CERT" era) ~ CertEnv era , Signal (EraRule "CERT" era) ~ TxCert era ) => TransitionRule (ConwayCERTS era) conwayCertsTransition = do - TRC (env@(DelegsEnv slot txIx pp tx acnt), certState, certificates) <- judgmentContext + TRC + ( env@(CertsEnv tx pp slot currentEpoch) + , certState + , certificates + ) <- + judgmentContext network <- liftSTS $ asks networkId case certificates of Empty -> do - let dState = certDState certState + -- Update DRep expiry for all DReps that are voting in this transaction + let drepActivity = pp ^. ppDRepActivityL + updatedVSDReps = + Map.foldlWithKey' + ( \dreps voter _ -> case voter of + DRepVoter cred -> Map.adjust (drepExpiryL .~ currentEpoch + drepActivity) cred dreps + _ -> dreps + ) + (certState ^. certVStateL . vsDRepsL) + (unVotingProcedures $ tx ^. bodyTxL . votingProceduresTxBodyL) + certStateWithDRepExpiryUpdated = certState & certVStateL . vsDRepsL .~ updatedVSDReps + dState = certStateWithDRepExpiryUpdated ^. certDStateL withdrawals = tx ^. bodyTxL . withdrawalsTxBodyL + -- Validate withdrawals and rewards and drain withdrawals validateTrans WithdrawalsNotInRewardsCERTS $ validateZeroRewards dState withdrawals network - pure $ certState {certDState = drainWithdrawals dState withdrawals} + pure $ certStateWithDRepExpiryUpdated & certDStateL .~ drainWithdrawals dState withdrawals gamma :|> c -> do certState' <- trans @(ConwayCERTS era) $ TRC (env, certState, gamma) validateTrans DelegateeNotRegisteredDELEG $ validateDelegationRegistered certState' c - -- It is impossible to have 65535 number of certificates in a - -- transaction, therefore partial function is justified. - let ptr = Ptr slot txIx (mkCertIxPartial $ toInteger $ length gamma) trans @(EraRule "CERT" era) $ - TRC (DelplEnv slot ptr pp acnt, certState', c) + TRC (CertEnv slot pp currentEpoch, certState', c) instance ( Era era diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs index 5ae4c4d2cff..e5c3f996a54 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Deleg.hs @@ -34,11 +34,10 @@ import Cardano.Ledger.Conway.TxCert ( ConwayDelegCert (ConwayDelegCert, ConwayRegCert, ConwayRegDelegCert, ConwayUnRegCert), Delegatee (DelegStake, DelegStakeVote, DelegVote), ) -import Cardano.Ledger.Core (Era (EraCrypto), EraPParams, EraRule) +import Cardano.Ledger.Core (Era (EraCrypto), EraPParams, EraRule, PParams) import Cardano.Ledger.Credential (Credential) import Cardano.Ledger.Keys (KeyRole (Staking)) import Cardano.Ledger.Shelley.LedgerState (DState (..)) -import Cardano.Ledger.Shelley.Rules (DelegEnv (DelegEnv)) import qualified Cardano.Ledger.UMap as UM import Control.DeepSeq (NFData) import Control.Monad (forM_) @@ -64,9 +63,9 @@ import NoThunks.Class (NoThunks) data ConwayDelegPredFailure era = IncorrectDepositDELEG !Coin - | StakeKeyAlreadyRegisteredDELEG !(Credential 'Staking (EraCrypto era)) + | StakeKeyRegisteredDELEG !(Credential 'Staking (EraCrypto era)) | StakeKeyNotRegisteredDELEG !(Credential 'Staking (EraCrypto era)) - | StakeKeyHasNonZeroAccountBalanceDELEG !Coin + | StakeKeyHasNonZeroRewardAccountBalanceDELEG !Coin | DRepAlreadyRegisteredForStakeKeyDELEG !(Credential 'Staking (EraCrypto era)) | WrongCertificateTypeDELEG deriving (Show, Eq, Generic) @@ -80,12 +79,12 @@ instance Era era => EncCBOR (ConwayDelegPredFailure era) where encode . \case IncorrectDepositDELEG mCoin -> Sum (IncorrectDepositDELEG @era) 1 !> To mCoin - StakeKeyAlreadyRegisteredDELEG stakeCred -> - Sum (StakeKeyAlreadyRegisteredDELEG @era) 2 !> To stakeCred + StakeKeyRegisteredDELEG stakeCred -> + Sum (StakeKeyRegisteredDELEG @era) 2 !> To stakeCred StakeKeyNotRegisteredDELEG stakeCred -> Sum (StakeKeyNotRegisteredDELEG @era) 3 !> To stakeCred - StakeKeyHasNonZeroAccountBalanceDELEG mCoin -> - Sum (StakeKeyHasNonZeroAccountBalanceDELEG @era) 4 !> To mCoin + StakeKeyHasNonZeroRewardAccountBalanceDELEG mCoin -> + Sum (StakeKeyHasNonZeroRewardAccountBalanceDELEG @era) 4 !> To mCoin DRepAlreadyRegisteredForStakeKeyDELEG stakeCred -> Sum (DRepAlreadyRegisteredForStakeKeyDELEG @era) 5 !> To stakeCred WrongCertificateTypeDELEG -> @@ -94,9 +93,9 @@ instance Era era => EncCBOR (ConwayDelegPredFailure era) where instance Era era => DecCBOR (ConwayDelegPredFailure era) where decCBOR = decode $ Summands "ConwayDelegPredFailure" $ \case 1 -> SumD IncorrectDepositDELEG SumD StakeKeyAlreadyRegisteredDELEG SumD StakeKeyRegisteredDELEG SumD StakeKeyNotRegisteredDELEG SumD StakeKeyHasNonZeroAccountBalanceDELEG SumD StakeKeyHasNonZeroRewardAccountBalanceDELEG SumD DRepAlreadyRegisteredForStakeKeyDELEG SumD WrongCertificateTypeDELEG n -> Invalid n @@ -107,14 +106,14 @@ instance ( EraPParams era , State (EraRule "DELEG" era) ~ DState era , Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era) - , Environment (EraRule "DELEG" era) ~ DelegEnv era + , Environment (EraRule "DELEG" era) ~ PParams era , EraRule "DELEG" era ~ ConwayDELEG era ) => STS (ConwayDELEG era) where type State (ConwayDELEG era) = DState era type Signal (ConwayDELEG era) = ConwayDelegCert (EraCrypto era) - type Environment (ConwayDELEG era) = DelegEnv era + type Environment (ConwayDELEG era) = PParams era type BaseM (ConwayDELEG era) = ShelleyBase type PredicateFailure (ConwayDELEG era) = ConwayDelegPredFailure era type Event (ConwayDELEG era) = ConwayDelegEvent era @@ -124,7 +123,7 @@ instance conwayDelegTransition :: forall era. EraPParams era => TransitionRule (ConwayDELEG era) conwayDelegTransition = do TRC - ( DelegEnv _slot _ptr _acnt pp + ( pp , dState@DState {dsUnified} , c ) <- @@ -133,34 +132,29 @@ conwayDelegTransition = do case c of ConwayRegCert stakeCred sMayDeposit -> do forM_ sMayDeposit $ checkDepositAgainstPParams ppKeyDeposit - checkStakeKeyNotAlreadyRegistered stakeCred dsUnified - pure $ dState {dsUnified = acceptDepositForStakeKey stakeCred dsUnified ppKeyDeposit} + dsUnified' <- checkAndAcceptDepositForStakeCred stakeCred ppKeyDeposit dsUnified + pure $ dState {dsUnified = dsUnified'} ConwayUnRegCert stakeCred sMayDeposit -> do - checkStakeKeyIsAlreadyRegistered stakeCred dsUnified - checkStakeKeyHasZeroBalance stakeCred dsUnified + checkStakeKeyIsRegistered stakeCred dsUnified + checkStakeKeyHasZeroRewardBalance stakeCred dsUnified forM_ sMayDeposit $ checkDepositAgainstPaidDeposit stakeCred dsUnified - pure $ - dState - { dsUnified = UM.domDeleteAll (Set.singleton stakeCred) dsUnified - } + pure $ dState {dsUnified = UM.domDeleteAll (Set.singleton stakeCred) dsUnified} ConwayDelegCert stakeCred delegatee -> do - checkStakeKeyIsAlreadyRegistered stakeCred dsUnified - pure $ - dState - { dsUnified = processDelegation stakeCred delegatee dsUnified - } + checkStakeKeyIsRegistered stakeCred dsUnified + pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified} ConwayRegDelegCert stakeCred delegatee deposit -> do - deposit == ppKeyDeposit ?! IncorrectDepositDELEG deposit - checkStakeKeyNotAlreadyRegistered stakeCred dsUnified - pure $ - dState - { dsUnified = - processDelegation stakeCred delegatee $ - acceptDepositForStakeKey stakeCred dsUnified ppKeyDeposit - } + checkDepositAgainstPParams ppKeyDeposit deposit + dsUnified' <- checkAndAcceptDepositForStakeCred stakeCred deposit dsUnified + pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified'} where - acceptDepositForStakeKey stakeCred dsUnified ppKeyDeposit = - UM.RewDepUView dsUnified UM.∪ (stakeCred, UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError ppKeyDeposit)) + -- Whenever we want to accept new deposit, we must always check if the stake credential isn't already registered. + checkAndAcceptDepositForStakeCred stakeCred deposit dsUnified = do + checkStakeKeyNotRegistered stakeCred dsUnified + -- This looks like it should have been a right-biased union, so that the (reward, deposit) pair would be inserted + -- (or overwritten) in the UMap. But since we are sure that the stake credential isn't a member yet + -- it will still work. The reason we cannot use a right-biased union here is because UMap treats deposits specially + -- in right-biased unions, and is unable to accept new deposits. + pure $ UM.RewDepUView dsUnified UM.∪ (stakeCred, UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError deposit)) delegStake stakeCred sPool dsUnified = UM.SPoolUView dsUnified UM.⨃ Map.singleton stakeCred sPool delegVote stakeCred dRep dsUnified = @@ -174,10 +168,10 @@ conwayDelegTransition = do deposit == ppKeyDeposit ?! IncorrectDepositDELEG deposit checkDepositAgainstPaidDeposit stakeCred dsUnified deposit = Just deposit == fmap (UM.fromCompact . UM.rdDeposit) (UM.lookup stakeCred $ UM.RewDepUView dsUnified) ?! IncorrectDepositDELEG deposit - checkStakeKeyNotAlreadyRegistered stakeCred dsUnified = - UM.notMember stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyAlreadyRegisteredDELEG stakeCred - checkStakeKeyIsAlreadyRegistered stakeCred dsUnified = + checkStakeKeyNotRegistered stakeCred dsUnified = + UM.notMember stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyRegisteredDELEG stakeCred + checkStakeKeyIsRegistered stakeCred dsUnified = UM.member stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyNotRegisteredDELEG stakeCred - checkStakeKeyHasZeroBalance stakeCred dsUnified = + checkStakeKeyHasZeroRewardBalance stakeCred dsUnified = let mReward = UM.rdReward <$> UM.lookup stakeCred (UM.RewDepUView dsUnified) - in forM_ mReward $ \r -> r == mempty ?! StakeKeyHasNonZeroAccountBalanceDELEG (UM.fromCompact r) + in forM_ mReward $ \r -> r == mempty ?! StakeKeyHasNonZeroRewardAccountBalanceDELEG (UM.fromCompact r) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs index 9334abd6e08..3a4c9fbfa3a 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/GovCert.hs @@ -4,8 +4,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -23,37 +23,32 @@ where import Cardano.Ledger.BaseTypes ( EpochNo, ShelleyBase, - SlotNo, - epochInfoPure, ) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), encodeListLen) import Cardano.Ledger.Binary.Coders -import Cardano.Ledger.CertState (CommitteeState (..), DRepState (..), VState (..), vsDRepsL) +import Cardano.Ledger.CertState (CommitteeState (..), DRepState (..), VState (..)) import Cardano.Ledger.Coin (Coin) -import Cardano.Ledger.Conway.Core (ConwayEraPParams, ppDRepActivityL) +import Cardano.Ledger.Conway.Core (ConwayEraPParams, ppDRepActivityL, ppDRepDepositL) import Cardano.Ledger.Conway.Era (ConwayGOVCERT) import Cardano.Ledger.Conway.TxCert (ConwayGovCert (..)) import Cardano.Ledger.Core (Era (EraCrypto), EraRule, PParams) import Cardano.Ledger.Credential (Credential) import Cardano.Ledger.Crypto (Crypto) -import Cardano.Ledger.DRepDistr (drepAnchorL, drepExpiryL) +import Cardano.Ledger.DRepDistr (drepAnchorL, drepDepositL, drepExpiryL) import Cardano.Ledger.Keys (KeyRole (ColdCommitteeRole, DRepRole)) -import Cardano.Ledger.Slot (epochInfoEpoch) import Control.DeepSeq (NFData) -import Control.Monad.Trans.Reader (asks) import Control.State.Transition.Extended ( BaseM, Environment, Event, PredicateFailure, - Rule, STS, Signal, State, TRC (TRC), TransitionRule, + failBecause, judgmentContext, - liftSTS, transitionRules, (?!), ) @@ -62,19 +57,23 @@ import Data.Maybe (isNothing) import Data.Typeable (Typeable) import Data.Word (Word8) import GHC.Generics (Generic) -import Lens.Micro ((%~), (&), (.~), (^.)) +import Lens.Micro ((&), (.~), (^.)) import NoThunks.Class (NoThunks (..)) data ConwayGovCertEnv era = ConwayGovCertEnv { cgcePParams :: !(PParams era) - , cgceCurrentSlot :: !SlotNo + , cgceCurrentEpoch :: !EpochNo } +deriving instance Show (PParams era) => Show (ConwayGovCertEnv era) + +deriving instance Eq (PParams era) => Eq (ConwayGovCertEnv era) + data ConwayGovCertPredFailure era = ConwayDRepAlreadyRegistered !(Credential 'DRepRole (EraCrypto era)) | ConwayDRepNotRegistered !(Credential 'DRepRole (EraCrypto era)) - | ConwayDRepIncorrectDeposit !Coin - | ConwayCommitteeHasResigned !(Credential 'ColdCommitteeRole (EraCrypto era)) + | ConwayDRepIncorrectDeposit !Coin !Coin -- The first is the given and the second is the expected deposit + | ConwayCommitteeHasPreviouslyResigned !(Credential 'ColdCommitteeRole (EraCrypto era)) deriving (Show, Eq, Generic) instance NoThunks (ConwayGovCertPredFailure era) @@ -94,11 +93,12 @@ instance encodeListLen 2 <> encCBOR (1 :: Word8) <> encCBOR cred - ConwayDRepIncorrectDeposit deposit -> - encodeListLen 2 + ConwayDRepIncorrectDeposit deposit expectedDeposit -> + encodeListLen 3 <> encCBOR (2 :: Word8) <> encCBOR deposit - ConwayCommitteeHasResigned keyH -> + <> encCBOR expectedDeposit + ConwayCommitteeHasPreviouslyResigned keyH -> encodeListLen 2 <> encCBOR (3 :: Word8) <> encCBOR keyH @@ -117,10 +117,11 @@ instance pure (2, ConwayDRepNotRegistered cred) 2 -> do deposit <- decCBOR - pure (2, ConwayDRepIncorrectDeposit deposit) + expectedDeposit <- decCBOR + pure (3, ConwayDRepIncorrectDeposit deposit expectedDeposit) 3 -> do keyH <- decCBOR - pure (2, ConwayCommitteeHasResigned keyH) + pure (2, ConwayCommitteeHasPreviouslyResigned keyH) k -> invalidKey k newtype ConwayGovCertEvent era = GovCertEvent (Event (EraRule "GOVCERT" era)) @@ -145,73 +146,60 @@ instance transitionRules = [conwayGovCertTransition @era] -calcDRepExpiryEpoch :: - ( ConwayEraPParams era - , Eq (PredicateFailure (EraRule "GOVCERT" era)) - , Show (PredicateFailure (EraRule "GOVCERT" era)) - , EraRule "GOVCERT" era ~ ConwayGOVCERT era - ) => - SlotNo -> - EpochNo -> - Rule (ConwayGOVCERT era) ctx EpochNo -calcDRepExpiryEpoch slot drepActivity = do - curEpoch <- liftSTS $ do - ei <- asks epochInfoPure - epochInfoEpoch ei slot - pure $ curEpoch + drepActivity - conwayGovCertTransition :: - (ConwayEraPParams era, EraRule "GOVCERT" era ~ ConwayGOVCERT era) => TransitionRule (ConwayGOVCERT era) + ConwayEraPParams era => TransitionRule (ConwayGOVCERT era) conwayGovCertTransition = do TRC - ( ConwayGovCertEnv {..} + ( ConwayGovCertEnv {cgcePParams, cgceCurrentEpoch} , vState@VState {vsDReps} , c ) <- judgmentContext + let ppDRepDeposit = cgcePParams ^. ppDRepDepositL + ppDRepActivity = cgcePParams ^. ppDRepActivityL case c of - ConwayRegDRep cred _deposit mAnchor -> do + ConwayRegDRep cred deposit mAnchor -> do Map.notMember cred vsDReps ?! ConwayDRepAlreadyRegistered cred - -- TODO: check against a new PParam `drepDeposit`, once PParams are updated. -- someCheck ?! ConwayDRepIncorrectDeposit deposit - drepState <- do - expiryEpoch <- - calcDRepExpiryEpoch - cgceCurrentSlot - (cgcePParams ^. ppDRepActivityL) - pure - DRepState - { drepExpiry = expiryEpoch - , drepAnchor = mAnchor - } - pure $ vState {vsDReps = Map.insert cred drepState vsDReps} - ConwayUnRegDRep cred _deposit -> do - -- TODO: check against a new PParam `drepDeposit`, once PParams are updated. -- someCheck ?! ConwayDRepIncorrectDeposit deposit - Map.member cred vsDReps ?! ConwayDRepNotRegistered cred - pure $ vState {vsDReps = Map.delete cred vsDReps} + deposit == ppDRepDeposit ?! ConwayDRepIncorrectDeposit deposit ppDRepDeposit + pure + vState + { vsDReps = + Map.insert cred (DRepState (cgceCurrentEpoch + ppDRepActivity) mAnchor ppDRepDeposit) vsDReps + } + ConwayUnRegDRep cred deposit -> do + checkRegistrationAndDepositAgainstPaidDeposit vsDReps cred deposit + pure vState {vsDReps = Map.delete cred vsDReps} ConwayAuthCommitteeHotKey coldCred hotCred -> - overwriteCommitteeHotCred vState coldCred (Just hotCred) + checkAndOverwriteCommitteeHotCred vState coldCred $ Just hotCred ConwayResignCommitteeColdKey coldCred -> - overwriteCommitteeHotCred vState coldCred Nothing + checkAndOverwriteCommitteeHotCred vState coldCred Nothing + -- Update a DRep expiry too along with its anchor. ConwayUpdateDRep cred mAnchor -> do - Map.notMember cred vsDReps ?! ConwayDRepNotRegistered cred - expiryEpoch <- - calcDRepExpiryEpoch - cgceCurrentSlot - (cgcePParams ^. ppDRepActivityL) - let updateDRepState drepState = - drepState - & drepExpiryL .~ expiryEpoch - & drepAnchorL .~ mAnchor - pure $ vState & vsDRepsL %~ Map.update (Just . updateDRepState) cred + Map.member cred vsDReps ?! ConwayDRepNotRegistered cred + pure + vState + { vsDReps = + Map.adjust + (\drepState -> drepState & drepExpiryL .~ cgceCurrentEpoch + ppDRepActivity & drepAnchorL .~ mAnchor) + cred + vsDReps + } where - overwriteCommitteeHotCred vState coldCred hotCred = do - let hotCredMap = csCommitteeCreds $ vsCommitteeState vState - ((isNothing <$> Map.lookup coldCred hotCredMap) /= Just True) - ?! ConwayCommitteeHasResigned coldCred - pure $ + checkColdCredHasNotResigned coldCred csCommitteeCreds = + ((isNothing <$> Map.lookup coldCred csCommitteeCreds) /= Just True) + ?! ConwayCommitteeHasPreviouslyResigned coldCred + checkRegistrationAndDepositAgainstPaidDeposit vsDReps cred deposit = + case Map.lookup cred vsDReps of + Nothing -> failBecause $ ConwayDRepNotRegistered cred + Just drepState -> + let paidDeposit = drepState ^. drepDepositL + in deposit == paidDeposit ?! ConwayDRepIncorrectDeposit deposit paidDeposit + checkAndOverwriteCommitteeHotCred vState@VState {vsCommitteeState = CommitteeState csCommitteeCreds} coldCred hotCred = do + checkColdCredHasNotResigned coldCred csCommitteeCreds + pure vState { vsCommitteeState = CommitteeState - { csCommitteeCreds = Map.insert coldCred hotCred hotCredMap + { csCommitteeCreds = Map.insert coldCred hotCred csCommitteeCreds } } 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 b8c71b1011f..23b766c9bda 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs @@ -33,6 +33,7 @@ import Cardano.Ledger.BaseTypes (ShelleyBase, epochInfoPure) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..)) import Cardano.Ledger.Binary.Coders import Cardano.Ledger.Block (txid) +import Cardano.Ledger.CertState (certDStateL, dsGenDelegsL) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Era (ConwayCERTS, ConwayGOV, ConwayLEDGER, ConwayUTXOW) import Cardano.Ledger.Conway.Governance ( @@ -41,7 +42,8 @@ import Cardano.Ledger.Conway.Governance ( GovProcedures (..), cgGovActionsStateL, ) -import Cardano.Ledger.Conway.Rules.Certs (ConwayCertsEvent, ConwayCertsPredFailure) +import Cardano.Ledger.Conway.Rules.Cert (CertEnv) +import Cardano.Ledger.Conway.Rules.Certs (CertsEnv (CertsEnv), ConwayCertsEvent, ConwayCertsPredFailure) import Cardano.Ledger.Conway.Rules.Gov (ConwayGovPredFailure, GovEnv (..)) import Cardano.Ledger.Conway.Tx (AlonzoEraTx (..)) import Cardano.Ledger.Credential (Credential) @@ -56,8 +58,6 @@ import Cardano.Ledger.Shelley.LedgerState ( utxosGovStateL, ) import Cardano.Ledger.Shelley.Rules ( - DelegsEnv (DelegsEnv), - DelplEnv, LedgerEnv (..), ShelleyLEDGERS, ShelleyLedgersEvent (..), @@ -172,6 +172,7 @@ data ConwayLedgerEvent era instance ( AlonzoEraTx era , ConwayEraTxBody era + , ConwayEraPParams era , GovState era ~ ConwayGovState era , Embed (EraRule "UTXOW" era) (ConwayLEDGER era) , Embed (EraRule "GOV" era) (ConwayLEDGER era) @@ -180,7 +181,7 @@ instance , State (EraRule "CERTS" era) ~ CertState era , State (EraRule "GOV" era) ~ GovActionsState era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era - , Environment (EraRule "CERTS" era) ~ DelegsEnv era + , Environment (EraRule "CERTS" era) ~ CertsEnv era , Environment (EraRule "GOV" era) ~ GovEnv era , Signal (EraRule "UTXOW" era) ~ Tx era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) @@ -237,7 +238,7 @@ ledgerTransition :: , State (EraRule "GOV" era) ~ GovActionsState era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era , Environment (EraRule "GOV" era) ~ GovEnv era - , Environment (EraRule "CERTS" era) ~ DelegsEnv era + , Environment (EraRule "CERTS" era) ~ CertsEnv era , Signal (EraRule "UTXOW" era) ~ Tx era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) , Signal (EraRule "GOV" era) ~ GovProcedures era @@ -246,24 +247,28 @@ ledgerTransition :: ) => TransitionRule (someLEDGER era) ledgerTransition = do - TRC (LedgerEnv slot txIx pp account, LedgerState utxoState certState, tx) <- judgmentContext + TRC (LedgerEnv slot _txIx pp _account, LedgerState utxoState certState, tx) <- judgmentContext + + currentEpoch <- liftSTS $ do + ei <- asks epochInfoPure + epochInfoEpoch ei slot + let txBody = tx ^. bodyTxL - dstate = certDState certState - genCerts = dsGenDelegs dstate - (utxoState', certState') <- + (utxoState', certStateAfterCERTS) <- if tx ^. isValidTxL == IsValid True then do - certState' <- + certStateAfterCERTS <- trans @(EraRule "CERTS" era) $ TRC - ( DelegsEnv slot txIx pp tx account + ( CertsEnv tx pp slot currentEpoch , certState , StrictSeq.fromStrict $ txBody ^. certsTxBodyL ) + let wdrlAddrs = Map.keysSet . unWithdrawals $ tx ^. bodyTxL . withdrawalsTxBodyL - let wdrlCreds = Set.map getRwdCred wdrlAddrs - let dUnified = dsUnified $ certDState certState' + wdrlCreds = Set.map getRwdCred wdrlAddrs + dUnified = dsUnified $ certDState certStateAfterCERTS delegatedAddrs = DRepUView dUnified -- TODO enable this check once delegation is fully implemented in cardano-api @@ -276,28 +281,29 @@ ledgerTransition = do { gpVotingProcedures = txBody ^. votingProceduresTxBodyL , gpProposalProcedures = fromStrict $ txBody ^. proposalProceduresTxBodyL } - epoch <- liftSTS $ do - ei <- asks epochInfoPure - epochInfoEpoch ei slot govActionsState' <- trans @(EraRule "GOV" era) $ TRC - ( GovEnv (txid txBody) epoch + ( GovEnv (txid txBody) currentEpoch , utxoState ^. utxosGovStateL . cgGovActionsStateL , govProcedures ) + let utxoState' = utxoState & utxosGovStateL . cgGovActionsStateL .~ govActionsState' - pure (utxoState', certState') + pure (utxoState', certStateAfterCERTS) else pure (utxoState, certState) utxoState'' <- trans @(EraRule "UTXOW" era) $ TRC - ( UtxoEnv @era slot pp certState' genCerts + -- Pass to UTXOW the unmodified CertState in its Environment, so it can process + -- refunds of deposits for deregistering stake credentials and DReps. + -- The modified CertState (certStateAfterCERTS) has these already removed from its UMap. + ( UtxoEnv @era slot pp certState (certState ^. certDStateL . dsGenDelegsL) , utxoState' , tx ) - pure $ LedgerState utxoState'' certState' + pure $ LedgerState utxoState'' certStateAfterCERTS instance ( Signable (DSIGN (EraCrypto era)) (Hash (HASH (EraCrypto era)) EraIndependentTxBody) @@ -325,10 +331,11 @@ instance instance ( EraTx era - , ShelleyEraTxBody era + , ConwayEraTxBody era + , ConwayEraPParams era , Embed (EraRule "CERT" era) (ConwayCERTS era) , State (EraRule "CERT" era) ~ CertState era - , Environment (EraRule "CERT" era) ~ DelplEnv era + , Environment (EraRule "CERT" era) ~ CertEnv era , Signal (EraRule "CERT" era) ~ TxCert era , PredicateFailure (EraRule "CERTS" era) ~ ConwayCertsPredFailure era , Event (EraRule "CERTS" era) ~ ConwayCertsEvent era @@ -345,9 +352,10 @@ instance , Embed (EraRule "GOV" era) (ConwayLEDGER era) , AlonzoEraTx era , ConwayEraTxBody era + , ConwayEraPParams era , GovState era ~ ConwayGovState era , Environment (EraRule "UTXOW" era) ~ UtxoEnv era - , Environment (EraRule "CERTS" era) ~ DelegsEnv era + , Environment (EraRule "CERTS" era) ~ CertsEnv era , Environment (EraRule "GOV" era) ~ GovEnv era , Signal (EraRule "UTXOW" era) ~ Tx era , Signal (EraRule "CERTS" era) ~ Seq (TxCert era) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs index bbddbf10566..64d12b1cd22 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/UTxO.hs @@ -72,10 +72,10 @@ conwayProducedValue pp f txb = instance Crypto c => EraUTxO (ConwayEra c) where type ScriptsNeeded (ConwayEra c) = AlonzoScriptsNeeded (ConwayEra c) - getConsumedValue = getConsumedMaryValue + getConsumedValue = getConsumedMaryValue -- TODO: This definitely needs to be updated for Conway getProducedValue = conwayProducedValue getScriptsNeeded = getConwayScriptsNeeded - getScriptsHashesNeeded = getAlonzoScriptsHashesNeeded + getScriptsHashesNeeded = getAlonzoScriptsHashesNeeded -- TODO: This also changes for Conway 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 78403ab0b50..8fbfb5b3a1c 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs @@ -333,9 +333,9 @@ instance arbitrary = oneof [ IncorrectDepositDELEG <$> arbitrary - , StakeKeyAlreadyRegisteredDELEG <$> arbitrary + , StakeKeyRegisteredDELEG <$> arbitrary , StakeKeyNotRegisteredDELEG <$> arbitrary - , StakeKeyHasNonZeroAccountBalanceDELEG <$> arbitrary + , StakeKeyHasNonZeroRewardAccountBalanceDELEG <$> arbitrary , DRepAlreadyRegisteredForStakeKeyDELEG <$> arbitrary , pure WrongCertificateTypeDELEG ] @@ -347,8 +347,8 @@ instance Era era => Arbitrary (ConwayGovCertPredFailure era) where oneof [ ConwayDRepAlreadyRegistered <$> arbitrary , ConwayDRepNotRegistered <$> arbitrary - , ConwayDRepIncorrectDeposit <$> arbitrary - , ConwayCommitteeHasResigned <$> arbitrary + , ConwayDRepIncorrectDeposit <$> arbitrary <*> arbitrary + , ConwayCommitteeHasPreviouslyResigned <$> arbitrary ] instance Era era => Arbitrary (ConwayPParams Identity era) where diff --git a/eras/conway/test-suite/cddl-files/conway.cddl b/eras/conway/test-suite/cddl-files/conway.cddl index 3b2deda55bf..a012e0b0215 100644 --- a/eras/conway/test-suite/cddl-files/conway.cddl +++ b/eras/conway/test-suite/cddl-files/conway.cddl @@ -379,7 +379,7 @@ protocol_param_update = , ? 3: uint ; max transaction size , ? 4: uint ; max block header size , ? 5: coin ; key deposit - , ? 6: coin ; pool deposit (TODO: drep deposit needs to be added) + , ? 6: coin ; pool deposit , ? 7: epoch ; maximum epoch , ? 8: uint ; n_opt: desired number of stake pools , ? 9: rational ; pool pledge influence diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs index ab0dc9ce033..5dc3e706b61 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -56,7 +56,7 @@ import Cardano.Ledger.Slot (EpochNo (..), SlotNo, epochInfoEpoch) import Control.DeepSeq import Control.Monad (forM_, when) import Control.Monad.Trans.Reader (asks) -import Control.SetAlgebra (dom, eval, setSingleton, singleton, (∈), (∉), (∪), (⋪), (⨃)) +import Control.SetAlgebra (dom, eval, setSingleton, singleton, (∈), (∉), (⋪), (⨃)) import Control.State.Transition ( STS (..), TRC (..), @@ -196,7 +196,7 @@ poolCertTransition (PoolEnv slot pp) ps@PState {psStakePoolParams, psFutureStake tellEvent $ RegisterPool ppId pure $ payPoolDeposit ppId pp $ - ps {psStakePoolParams = eval (psStakePoolParams ∪ singleton ppId poolParams)} + ps {psStakePoolParams = eval (psStakePoolParams ⨃ singleton ppId poolParams)} else do tellEvent $ ReregisterPool ppId -- hk is already registered, so we want to reregister it. That means adding it to the diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/DRepDistr.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/DRepDistr.hs index ed1da098c41..3d537c3a9ab 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/DRepDistr.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/DRepDistr.hs @@ -50,6 +50,7 @@ import NoThunks.Class (NoThunks (..), allNoThunks) data DRepState c = DRepState { drepExpiry :: !EpochNo , drepAnchor :: !(StrictMaybe (Anchor c)) + , drepDeposit :: !Coin } deriving (Show, Eq, Ord, Generic) @@ -63,6 +64,7 @@ instance Crypto c => DecCBOR (DRepState c) where RecD DRepState EncCBOR (DRepState c) where encCBOR DRepState {..} = @@ -70,6 +72,7 @@ instance Crypto c => EncCBOR (DRepState c) where Rec DRepState !> To drepExpiry !> To drepAnchor + !> To drepDeposit instance ToExpr (DRepState era) @@ -79,6 +82,9 @@ drepExpiryL = lens drepExpiry (\x y -> x {drepExpiry = y}) drepAnchorL :: Lens' (DRepState c) (StrictMaybe (Anchor c)) drepAnchorL = lens drepAnchor (\x y -> x {drepAnchor = y}) +drepDepositL :: Lens' (DRepState c) Coin +drepDepositL = lens drepDeposit (\x y -> x {drepDeposit = y}) + -- ================================================================= -- Algorithm for computing the DRep stake distrubution diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs index 6219cc361a5..cf23cf71119 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs @@ -684,7 +684,7 @@ instance Crypto c => Arbitrary (Anchor c) where <*> arbitrary instance Crypto c => Arbitrary (DRepState c) where - arbitrary = DRepState <$> arbitrary <*> arbitrary + arbitrary = DRepState <$> arbitrary <*> arbitrary <*> arbitrary deriving instance Era era => Arbitrary (CommitteeState era) 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 8d0f0965d0f..b825de56163 100644 --- a/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs +++ b/libs/cardano-ledger-pretty/src/Cardano/Ledger/Pretty/Conway.hs @@ -391,17 +391,17 @@ instance PrettyA (ConwayDelegPredFailure era) where ppRecord "IncorrectDepositDELEG" [("Coin", prettyA x)] - StakeKeyAlreadyRegisteredDELEG x -> + StakeKeyRegisteredDELEG x -> ppRecord - "StakeKeyAlreadyRegisteredDELEG" + "StakeKeyRegisteredDELEG" [("Credential", prettyA x)] StakeKeyNotRegisteredDELEG x -> ppRecord "StakeKeyNotRegisteredDELEG" [("Credential", prettyA x)] - StakeKeyHasNonZeroAccountBalanceDELEG x -> + StakeKeyHasNonZeroRewardAccountBalanceDELEG x -> ppRecord - "StakeKeyHasNonZeroAccountBalanceDELEG" + "StakeKeyHasNonZeroRewardAccountBalanceDELEG" [("Coin", prettyA x)] DRepAlreadyRegisteredForStakeKeyDELEG x -> ppRecord 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 4228059d82a..64cdd031b4d 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 @@ -1697,11 +1697,12 @@ pcVState (VState dreps drepDistr (CommitteeState committeeHotCreds)) = ] pcDRepState :: DRepState c -> PDoc -pcDRepState (DRepState expire anchor) = +pcDRepState (DRepState expire anchor deposit) = ppRecord "DRepState" [ ("expire", ppEpochNo expire) , ("anchor", ppStrictMaybe (ppString . show) anchor) + , ("deposit", ppCoin deposit) ] pcDRep :: DRep c -> PDoc