Move unelected CC votes MEMPOOL check to GOV

Author: aniketd

eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs

@@ -214,17 +214,13 @@ import Cardano.Ledger.Credential (Credential)
 import Cardano.Ledger.PoolParams (PoolParams (ppRewardAccount))
 import Cardano.Ledger.Shelley.LedgerState (
   EpochState (..),
-  LedgerState,
   NewEpochState (..),
   epochStateGovStateL,
   epochStatePoolParamsL,
   esLStateL,
   lsCertState,
-  lsCertStateL,
   lsUTxOState,
-  lsUTxOStateL,
   newEpochStateGovStateL,
-  utxosGovStateL,
  )
 import Cardano.Ledger.UMap
 import Cardano.Ledger.Val (Val (..))
@@ -235,7 +231,6 @@ import Control.Monad.Trans.Reader (ReaderT, ask)
 import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
 import Data.Default (Default (..))
 import Data.Foldable (Foldable (..))
-import qualified Data.Foldable as F (foldl')
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
@@ -568,19 +563,14 @@ defaultStakePoolVote poolId poolParams dRepDelegations =
     toDefaultVote _ = DefaultNo
 
 authorizedElectedHotCommitteeCredentials ::
-  (ConwayEraGov era, ConwayEraCertState era) =>
-  LedgerState era ->
+  ConwayEraGov era =>
+  GovState era ->
+  CommitteeState era ->
   Set.Set (Credential 'HotCommitteeRole)
-authorizedElectedHotCommitteeCredentials ledgerState =
-  case ledgerState ^. lsUTxOStateL . utxosGovStateL . committeeGovStateL of
+authorizedElectedHotCommitteeCredentials govState committeeState =
+  case govState ^. 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
+      authorizedHotCommitteeCredentials $
+        CommitteeState $
+          csCommitteeCreds committeeState `Map.intersection` committeeMembers electedCommiteee

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Gov.hs

@@ -26,6 +26,7 @@ module Cardano.Ledger.Conway.Rules.Gov (
   GovSignal (..),
   ConwayGovEvent (..),
   ConwayGovPredFailure (..),
+  unelectedCommitteeVoters,
 ) where
 
 import Cardano.Ledger.Address (RewardAccount, raCredential, raNetwork)
@@ -34,11 +35,12 @@ import Cardano.Ledger.BaseTypes (
   EpochNo (..),
   Mismatch (..),
   Network,
-  ProtVer,
+  ProtVer (ProtVer),
   Relation (..),
   ShelleyBase,
   StrictMaybe (SJust),
   addEpochInterval,
+  natVersion,
   networkId,
  )
 import Cardano.Ledger.Binary (
@@ -61,17 +63,24 @@ import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.Core (ppGovActionDepositL, ppGovActionLifetimeL)
 import Cardano.Ledger.Conway.Era (ConwayEra, ConwayGOV)
 import Cardano.Ledger.Conway.Governance (
+  ConwayEraGov,
+  ConwayGovState,
+  EraGov,
   GovAction (..),
   GovActionId (..),
   GovActionPurpose (..),
   GovActionState (..),
   GovPurposeId (..),
   GovRelation (..),
+  GovState,
   ProposalProcedure (..),
   Proposals,
   Voter (..),
   VotingProcedure (..),
   VotingProcedures (..),
+  authorizedElectedHotCommitteeCredentials,
+  constitutionGovStateL,
+  constitutionScriptL,
   foldrVotingProcedures,
   gasAction,
   gasDRepVotesL,
@@ -146,27 +155,27 @@ data GovEnv era = GovEnv
   { geTxId :: TxId
   , geEpoch :: EpochNo
   , gePParams :: PParams era
-  , gePPolicy :: StrictMaybe ScriptHash
+  , geGovState :: GovState era
   , geCertState :: CertState era
   }
   deriving (Generic)
 
-instance (EraPParams era, EraCertState era) => EncCBOR (GovEnv era) where
+instance (EraGov era, EraPParams era, EraCertState era) => EncCBOR (GovEnv era) where
   encCBOR x@(GovEnv _ _ _ _ _) =
     let GovEnv {..} = x
      in encode $
           Rec GovEnv
             !> To geTxId
             !> To geEpoch
             !> To gePParams
-            !> To gePPolicy
+            !> To geGovState
             !> To geCertState
 
-instance (NFData (PParams era), Era era, EraCertState era) => NFData (GovEnv era)
+instance (NFData (PParams era), EraGov era, EraCertState era) => NFData (GovEnv era)
 
-deriving instance (Show (PParams era), Era era, EraCertState era) => Show (GovEnv era)
+deriving instance (Show (PParams era), EraGov era, EraCertState era) => Show (GovEnv era)
 
-deriving instance (Eq (PParams era), EraCertState era) => Eq (GovEnv era)
+deriving instance (Eq (PParams era), EraGov era, EraCertState era) => Eq (GovEnv era)
 
 data ConwayGovPredFailure era
   = GovActionsDoNotExist (NonEmpty GovActionId)
@@ -207,6 +216,8 @@ data ConwayGovPredFailure era
     ProposalReturnAccountDoesNotExist RewardAccount
   | -- | Treasury withdrawal proposals to an invalid reward account
     TreasuryWithdrawalReturnAccountsDoNotExist (NonEmpty RewardAccount)
+  | -- | Disallow votes by unelected committee members
+    UnelectedCommitteeVoters (NonEmpty (Credential 'HotCommitteeRole))
   deriving (Eq, Show, Generic)
 
 type instance EraRuleFailure "GOV" ConwayEra = ConwayGovPredFailure ConwayEra
@@ -239,6 +250,7 @@ instance EraPParams era => DecCBOR (ConwayGovPredFailure era) where
     15 -> SumD ZeroTreasuryWithdrawals <! From
     16 -> SumD ProposalReturnAccountDoesNotExist <! From
     17 -> SumD TreasuryWithdrawalReturnAccountsDoNotExist <! From
+    18 -> SumD UnelectedCommitteeVoters <! From
     k -> Invalid k
 
 instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where
@@ -280,6 +292,8 @@ instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where
         Sum ProposalReturnAccountDoesNotExist 16 !> To returnAccount
       TreasuryWithdrawalReturnAccountsDoNotExist accounts ->
         Sum TreasuryWithdrawalReturnAccountsDoNotExist 17 !> To accounts
+      UnelectedCommitteeVoters committee ->
+        Sum UnelectedCommitteeVoters 18 !> To committee
 
 instance EraPParams era => ToCBOR (ConwayGovPredFailure era) where
   toCBOR = toEraCBOR @era
@@ -324,6 +338,8 @@ instance (EraPParams era, NFData (TxCert era)) => NFData (GovSignal era)
 instance
   ( ConwayEraTxCert era
   , ConwayEraPParams era
+  , ConwayEraGov era
+  , GovState era ~ ConwayGovState era
   , EraRule "GOV" era ~ ConwayGOV era
   , InjectRuleFailure "GOV" ConwayGovPredFailure era
   , EraCertState era
@@ -427,6 +443,8 @@ checkBootstrapProposal pp proposal@ProposalProcedure {pProcGovAction}
 govTransition ::
   forall era.
   ( ConwayEraTxCert era
+  , ConwayEraGov era
+  , GovState era ~ ConwayGovState era
   , ConwayEraPParams era
   , STS (EraRule "GOV" era)
   , Event (EraRule "GOV" era) ~ ConwayGovEvent era
@@ -441,7 +459,7 @@ govTransition ::
   TransitionRule (EraRule "GOV" era)
 govTransition = do
   TRC
-    ( GovEnv txid currentEpoch pp constitutionPolicy certState
+    ( GovEnv txid currentEpoch pp govState certState
       , st
       , GovSignal {gsVotingProcedures, gsProposalProcedures, gsCertificates}
       ) <-
@@ -450,13 +468,19 @@ govTransition = do
       certVState = certState ^. certVStateL
       certPState = certState ^. certPStateL
       certDState = certState ^. certDStateL
+      constitutionPolicy = govState ^. constitutionGovStateL . constitutionScriptL
       committeeState = vsCommitteeState certVState
       knownDReps = vsDReps certVState
       knownStakePools = psStakePoolParams certPState
       knownCommitteeMembers = authorizedHotCommitteeCredentials committeeState
 
   expectedNetworkId <- liftSTS $ asks networkId
 
+  unless (pp ^. ppProtocolVersionL < ProtVer (natVersion @11) 0) $
+    failOnNonEmpty
+      (unelectedCommitteeVoters govState committeeState gsVotingProcedures)
+      UnelectedCommitteeVoters
+
   let processProposal ps (idx, proposal@ProposalProcedure {..}) = do
         runTest $ checkBootstrapProposal pp proposal
 
@@ -623,6 +647,22 @@ checkDisallowedVotes votes failure canBeVotedOnBy =
     disallowedVotes =
       [(voter, gasId gas) | (voter, gas) <- votes, not (gas `canBeVotedOnBy` voter)]
 
+unelectedCommitteeVoters ::
+  ConwayEraGov era =>
+  GovState era ->
+  CommitteeState era ->
+  VotingProcedures era ->
+  Set (Credential 'HotCommitteeRole)
+unelectedCommitteeVoters govState committeeState gsVotingProcedures =
+  let authorizedElectedCommittee = authorizedElectedHotCommitteeCredentials govState committeeState
+      collectUnelectedCommitteeVotes !unelectedHotCreds voter _ =
+        case voter of
+          CommitteeVoter hotCred
+            | hotCred `Set.notMember` authorizedElectedCommittee ->
+                Set.insert hotCred unelectedHotCreds
+          _ -> unelectedHotCreds
+   in Map.foldlWithKey' collectUnelectedCommitteeVotes Set.empty $ unVotingProcedures gsVotingProcedures
+
 -- | If the GovAction is a HardFork, then return 3 things (if they exist)
 -- 1) The (StrictMaybe GovPurposeId), pointed to by the HardFork proposal
 -- 2) The proposed ProtVer

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs

@@ -61,7 +61,6 @@ import Cardano.Ledger.Conway.Governance (
   ConwayEraGov (..),
   ConwayGovState,
   Proposals,
-  constitutionScriptL,
   grCommitteeL,
   proposalsGovStateL,
   proposalsWithPurpose,
@@ -438,7 +437,7 @@ ledgerTransition = do
                   (txIdTxBody txBody)
                   curEpochNo
                   pp
-                  (govState ^. constitutionGovStateL . constitutionScriptL)
+                  govState
                   certStateAfterCERTS
               , proposals
               , govSignal
@@ -538,6 +537,8 @@ instance
 instance
   ( ConwayEraTxCert era
   , ConwayEraPParams era
+  , ConwayEraGov era
+  , GovState era ~ ConwayGovState era
   , BaseM (ConwayLEDGER era) ~ ShelleyBase
   , PredicateFailure (EraRule "GOV" era) ~ ConwayGovPredFailure era
   , Event (EraRule "GOV" era) ~ ConwayGovEvent era

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Mempool.hs

@@ -17,23 +17,17 @@ module Cardano.Ledger.Conway.Rules.Mempool (
   ConwayMEMPOOL,
 ) where
 
-import Cardano.Ledger.BaseTypes (ShelleyBase)
+import Cardano.Ledger.BaseTypes (ProtVer (ProtVer), ShelleyBase, natVersion)
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Era (ConwayLEDGER, ConwayMEMPOOL)
-import Cardano.Ledger.Conway.Governance (
-  ConwayEraGov,
-  ConwayGovState,
-  Proposals,
-  Voter (..),
-  authorizedElectedHotCommitteeCredentials,
-  unVotingProcedures,
- )
+import Cardano.Ledger.Conway.Governance (ConwayEraGov, ConwayGovState, Proposals)
 import Cardano.Ledger.Conway.Rules.Certs (CertsEnv)
-import Cardano.Ledger.Conway.Rules.Gov (GovEnv, GovSignal)
+import Cardano.Ledger.Conway.Rules.Gov (GovEnv, GovSignal, unelectedCommitteeVoters)
 import Cardano.Ledger.Conway.Rules.Ledger (ConwayLedgerEvent, ConwayLedgerPredFailure (..))
 import Cardano.Ledger.Conway.State
 import Cardano.Ledger.Shelley.LedgerState
-import Cardano.Ledger.Shelley.Rules (LedgerEnv (..), UtxoEnv)
+import Cardano.Ledger.Shelley.Rules (LedgerEnv (..), UtxoEnv, ledgerPpL)
+import Control.Monad (when)
 import Control.State.Transition (
   BaseM,
   Environment,
@@ -54,7 +48,6 @@ import Control.State.Transition.Extended (Embed (..), trans)
 import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import Data.Sequence (Seq)
-import qualified Data.Set as Set
 import Data.Text as T (pack)
 import Lens.Micro ((^.))
 
@@ -100,7 +93,7 @@ mempoolTransition ::
   ) =>
   TransitionRule (ConwayMEMPOOL era)
 mempoolTransition = do
-  TRC trc@(_ledgerEnv, ledgerState, tx) <-
+  TRC trc@(ledgerEnv, ledgerState, tx) <-
     judgmentContext
 
   -- This rule only gets invoked on transactions within the mempool.
@@ -117,22 +110,22 @@ mempoolTransition = do
 
   -- Skip all other checks if the transaction is probably a duplicate
   whenFailureFreeDefault ledgerState $ do
-    -- Disallow votes by unelected committee members
-    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 $
-      ConwayMempoolFailure . addPrefix . T.pack . show . NE.toList
+    when (ledgerEnv ^. ledgerPpL . ppProtocolVersionL < ProtVer (natVersion @11) 0) $
+      -- This check can completely be removed once mainnet switches to protocol
+      -- version 11, since the same check has been implemented in the GOV rule.
+      -- We have to also carefully make the GOV rule check consistent for all
+      -- protocol versions, even those below version 11, once we remove this
+      -- check.
+      --
+      -- Disallow votes by unelected committee members
+      let addPrefix = ("Unelected committee members are not allowed to cast votes: " <>)
+       in failOnNonEmpty
+            ( unelectedCommitteeVoters
+                (ledgerState ^. lsUTxOStateL . utxosGovStateL)
+                (ledgerState ^. lsCertStateL . certVStateL . vsCommitteeStateL)
+                (tx ^. bodyTxL . votingProceduresTxBodyL)
+            )
+            (ConwayMempoolFailure . addPrefix . T.pack . show . NE.toList)
 
     -- Continue with LEDGER rules
     trans @(EraRule "LEDGER" era) $ TRC trc

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Arbitrary.hs

@@ -621,7 +621,14 @@ genConwayPlutusPurposePointer i =
 
 -- GOV
 
-instance (Era era, Arbitrary (PParamsHKD Identity era), Arbitrary (CertState era)) => Arbitrary (GovEnv era) where
+instance
+  ( Era era
+  , Arbitrary (PParamsHKD Identity era)
+  , Arbitrary (CertState era)
+  , Arbitrary (GovState era)
+  ) =>
+  Arbitrary (GovEnv era)
+  where
   arbitrary =
     GovEnv
       <$> arbitrary

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/TreeDiff.hs

@@ -43,6 +43,7 @@ instance
   ( Era era
   , ToExpr (TxCert era)
   , ToExpr (PParamsHKD StrictMaybe era)
+  , ToExpr (GovState era)
   ) =>
   ToExpr (ConwayPlutusPurpose AsItem era)
 
@@ -245,7 +246,12 @@ instance
   ) =>
   ToExpr (GovSignal era)
 
-instance (ToExpr (PParams era), ToExpr (CertState era)) => ToExpr (GovEnv era)
+instance
+  ( ToExpr (PParams era)
+  , ToExpr (CertState era)
+  , ToExpr (GovState era)
+  ) =>
+  ToExpr (GovEnv era)
 
 instance
   ( ToExpr (PParams era)

libs/cardano-ledger-conformance/src/Test/Cardano/Ledger/Conformance/SpecTranslate/Conway/Gov.hs

@@ -34,6 +34,7 @@ instance
   , SpecTranslate ctx (CertState era)
   , SpecRep (CertState era) ~ Agda.CertState
   , EraCertState era
+  , ConwayEraGov era
   ) =>
   SpecTranslate ctx (GovEnv era)
   where
@@ -46,7 +47,7 @@ instance
       <$> toSpecRep geTxId
       <*> toSpecRep geEpoch
       <*> toSpecRep gePParams
-      <*> toSpecRep gePPolicy
+      <*> toSpecRep (geGovState ^. constitutionGovStateL . constitutionScriptL)
       <*> toSpecRep enactState
       <*> toSpecRep geCertState
       <*> toSpecRep rewardAccounts