From c0894249a8a38a1e55b719bab9686d98ed527a39 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Sun, 29 Dec 2024 10:24:30 -0700 Subject: [PATCH] Add a check to `MEMPOOL` rule that prevents unelected CC from voting --- .../src/Cardano/Ledger/Conway/Governance.hs | 35 ++++++++++++++- .../src/Cardano/Ledger/Conway/Rules/Ledger.hs | 5 ++- .../Cardano/Ledger/Conway/Rules/Mempool.hs | 36 +++++++++++++-- .../Cardano/Ledger/Conway/Imp/LedgerSpec.hs | 44 ++++++++++++++++++- 4 files changed, 112 insertions(+), 8 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index 95eac0f9262..0ed8e36726b 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -24,6 +26,7 @@ module Cardano.Ledger.Conway.Governance ( Committee (..), committeeMembersL, committeeThresholdL, + authorizedElectedHotCommitteeCredentials, GovAction (..), GovActionState (..), GovActionIx (..), @@ -195,7 +198,12 @@ import Cardano.Ledger.Binary.Coders ( (!>), ( + LedgerState era -> + Set.Set (Credential HotCommitteeRole) +authorizedElectedHotCommitteeCredentials ledgerState = + case ledgerState ^. lsUTxOStateL . utxosGovStateL . committeeGovStateL of + SNothing -> Set.empty + SJust electedCommiteee -> + collectAuthorizedHotCreds $ + csCommitteeCreds committeeState `Map.intersection` committeeMembers electedCommiteee + where + committeeState = ledgerState ^. lsCertStateL . certVStateL . vsCommitteeStateL + collectAuthorizedHotCreds = + let toHotCredSet !acc = \case + CommitteeHotCredential hotCred -> Set.insert hotCred acc + CommitteeMemberResigned {} -> acc + in F.foldl' toHotCredSet Set.empty 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 e494c2d4d00..c515f11b909 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs @@ -587,8 +587,9 @@ instance wrapEvent = CertsEvent . CertEvent . DelegEvent instance - ( EraGov era - , EraTx era + ( EraTx era + , ConwayEraGov era + , ConwayEraTxBody era , EraRule "MEMPOOL" era ~ ConwayMEMPOOL era , PredicateFailure (EraRule "MEMPOOL" era) ~ ConwayMempoolPredFailure era , Event (EraRule "MEMPOOL" era) ~ ConwayMempoolEvent era diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs index 1c76d168300..9200a70ec78 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -23,6 +24,12 @@ import Cardano.Ledger.BaseTypes (ShelleyBase) import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), FromCBOR, ToCBOR) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Era (ConwayEra, ConwayMEMPOOL) +import Cardano.Ledger.Conway.Governance ( + ConwayEraGov, + Voter (..), + authorizedElectedHotCommitteeCredentials, + unVotingProcedures, + ) import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Rules (LedgerEnv (..)) import Control.DeepSeq (NFData) @@ -36,12 +43,17 @@ import Control.State.Transition ( State, TRC (TRC), TransitionRule, + failOnNonEmpty, judgmentContext, tellEvent, transitionRules, ) -import Data.Text (Text, pack) +import qualified Data.List.NonEmpty as NE +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Text as T (Text, pack) import GHC.Generics (Generic) +import Lens.Micro ((^.)) import NoThunks.Class (NoThunks) newtype ConwayMempoolPredFailure era = ConwayMempoolPredFailure Text @@ -58,7 +70,7 @@ newtype ConwayMempoolEvent era = ConwayMempoolEvent Text type instance EraRuleEvent "MEMPOOL" ConwayEra = ConwayMempoolEvent ConwayEra instance - (EraTx era, EraGov era) => + (EraTx era, ConwayEraTxBody era, ConwayEraGov era) => STS (ConwayMEMPOOL era) where type State (ConwayMEMPOOL era) = LedgerState era @@ -70,11 +82,27 @@ instance transitionRules = [mempoolTransition @era] -mempoolTransition :: EraTx era => TransitionRule (ConwayMEMPOOL era) +mempoolTransition :: + (EraTx era, ConwayEraTxBody era, ConwayEraGov era) => TransitionRule (ConwayMEMPOOL era) mempoolTransition = do TRC (_ledgerEnv, ledgerState, tx) <- judgmentContext -- This rule only gets invoked on transactions within the mempool. -- Add checks here that sanitize undesired transactions. - tellEvent . ConwayMempoolEvent . ("Mempool rule for tx " <>) . pack . show . txIdTx $ tx + tellEvent . ConwayMempoolEvent . ("Mempool rule for tx " <>) . T.pack . show $ txIdTx tx + let + authorizedElectedHotCreds = authorizedElectedHotCommitteeCredentials ledgerState + collectUnelectedCommitteeVotes !unelectedHotCreds voter _ = + case voter of + CommitteeVoter hotCred + | hotCred `Set.notMember` authorizedElectedHotCreds -> + Set.insert hotCred unelectedHotCreds + _ -> unelectedHotCreds + unelectedCommitteeVoters = + Map.foldlWithKey' collectUnelectedCommitteeVotes Set.empty $ + unVotingProcedures (tx ^. bodyTxL . votingProceduresTxBodyL) + addPrefix = + ("Unelected committee members are not allowed to cast votes: " <>) + failOnNonEmpty unelectedCommitteeVoters $ + ConwayMempoolPredFailure . addPrefix . T.pack . show . NE.toList pure ledgerState diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs index e0f56455e8f..a3c223e6955 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs @@ -12,6 +12,7 @@ module Test.Cardano.Ledger.Conway.Imp.LedgerSpec (spec) where import Cardano.Ledger.BaseTypes import Cardano.Ledger.Coin (Coin (..)) import Cardano.Ledger.Conway.Core +import Cardano.Ledger.Conway.Governance import Cardano.Ledger.Conway.Rules ( ConwayLedgerEvent (..), ConwayLedgerPredFailure (..), @@ -21,16 +22,18 @@ import Cardano.Ledger.Conway.Rules ( import Cardano.Ledger.Credential (Credential (..)) import Cardano.Ledger.DRep import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript) -import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..), mkMempoolEnv) +import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..), applyTx, mkMempoolEnv) import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase) import Cardano.Ledger.Shelley.LedgerState import Cardano.Ledger.Shelley.Rules (ShelleyLedgersEnv (..), ShelleyLedgersEvent (..)) import Control.State.Transition.Extended +import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set import Lens.Micro ((&), (.~), (^.)) import Lens.Micro.Mtl (use) import Test.Cardano.Ledger.Conway.ImpTest +import Test.Cardano.Ledger.Core.Rational (IsRatio (..)) import Test.Cardano.Ledger.Imp.Common import Test.Cardano.Ledger.Plutus.Examples ( alwaysFailsWithDatum, @@ -254,3 +257,42 @@ spec = do assertFailure $ "Unexpected failure while applyingTx: " <> show tx <> ": " <> show e Right (_, evs) -> length [ev | ev@(MempoolEvent (ConwayMempoolEvent _)) <- evs] `shouldBe` 1 + + it "Unelected Committee voting" $ whenPostBootstrap $ do + globals <- use impGlobalsL + slotNo <- use impLastTickG + _ <- registerInitialCommittee + ccCold <- KeyHashObj <$> freshKeyHash + curEpochNo <- getsNES nesELL + let action = + UpdateCommittee + SNothing + mempty + (Map.singleton ccCold (addEpochInterval curEpochNo (EpochInterval 7))) + (1 %! 1) + proposal <- mkProposal action + submitTx_ $ + mkBasicTx (mkBasicTxBody & proposalProceduresTxBodyL .~ [proposal]) + ccHot <- registerCommitteeHotKey ccCold + govActionId <- do + rewardAccount <- registerRewardAccount + submitTreasuryWithdrawals [(rewardAccount, Coin 1)] + + nes <- use impNESL + let ls = nes ^. nesEsL . esLStateL + mempoolEnv = mkMempoolEnv nes slotNo + tx <- + fixupTx $ + mkBasicTx $ + mkBasicTxBody + & votingProceduresTxBodyL + .~ VotingProcedures + ( Map.singleton + (CommitteeVoter ccHot) + (Map.singleton govActionId (VotingProcedure VoteYes SNothing)) + ) + + case applyTx globals mempoolEnv ls tx of + Left _ -> pure () + Right _ -> assertFailure $ "Expected failure due to an unallowed vote: " <> show tx + withNoFixup $ submitTx_ tx