Merge pull request #4813 from IntersectMBO/lehins/sanitize-non-elected-cc-votes

Add a check to `MEMPOOL` rule that prevents unelected CC from voting

Author: neilmayhew

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 (
   (!>),
   (<!),
  )
-import Cardano.Ledger.CertState (Obligations (..))
+import Cardano.Ledger.CertState (
+  CommitteeAuthorization (..),
+  Obligations (..),
+  certVStateL,
+  csCommitteeCreds,
+ )
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.Era (ConwayEra)
 import Cardano.Ledger.Conway.Governance.DRepPulser
@@ -210,6 +218,7 @@ import Cardano.Ledger.PoolParams (PoolParams (ppRewardAccount))
 import Cardano.Ledger.Shelley.Governance
 import Cardano.Ledger.Shelley.LedgerState (
   EpochState (..),
+  LedgerState,
   NewEpochState (..),
   certDState,
   certVState,
@@ -220,10 +229,14 @@ import Cardano.Ledger.Shelley.LedgerState (
   epochStateTreasuryL,
   esLStateL,
   lsCertState,
+  lsCertStateL,
   lsUTxOState,
+  lsUTxOStateL,
   newEpochStateGovStateL,
+  utxosGovStateL,
   utxosStakeDistr,
   vsCommitteeState,
+  vsCommitteeStateL,
   vsDReps,
  )
 import Cardano.Ledger.UMap
@@ -234,8 +247,10 @@ 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
 import Data.Word (Word64)
 import GHC.Generics (Generic)
 import Lens.Micro
@@ -539,3 +554,21 @@ defaultStakePoolVote poolId poolParams dRepDelegations =
     toDefaultVote (Just DRepAlwaysAbstain) = DefaultAbstain
     toDefaultVote (Just DRepAlwaysNoConfidence) = DefaultNoConfidence
     toDefaultVote _ = DefaultNo
+
+authorizedElectedHotCommitteeCredentials ::
+  ConwayEraGov era =>
+  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

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

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

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