Merge pull request #4815 from IntersectMBO/release/cardano-ledger-conway-1.17.4.0

Backport release `cardano-ledger-conway-1.17.4.0`

Author: neilmayhew

eras/conway/impl/CHANGELOG.md

@@ -1,5 +1,9 @@
 # Version history for `cardano-ledger-conway`
 
+## 1.17.4.0
+
+* Add a check to `MEMPOOL` rule that prevents unelected CC from voting.
+
 ## 1.17.3.0
 
 * Fix buggy behavior of DRep delegations: #4772

eras/conway/impl/cardano-ledger-conway.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               cardano-ledger-conway
-version:            1.17.3.0
+version:            1.17.4.0
 license:            Apache-2.0
 maintainer:         operations@iohk.io
 author:             IOHK

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

@@ -1,5 +1,8 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -23,6 +26,7 @@ module Cardano.Ledger.Conway.Governance (
   Committee (..),
   committeeMembersL,
   committeeThresholdL,
+  authorizedElectedHotCommitteeCredentials,
   GovAction (..),
   GovActionState (..),
   GovActionIx (..),
@@ -191,20 +195,28 @@ 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
 import Cardano.Ledger.Conway.Governance.Internal
 import Cardano.Ledger.Conway.Governance.Procedures
 import Cardano.Ledger.Conway.Governance.Proposals
 import Cardano.Ledger.Core
+import Cardano.Ledger.Credential (Credential)
 import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.DRep (DRep (..))
+import Cardano.Ledger.Keys (KeyRole (..))
 import Cardano.Ledger.PoolDistr (PoolDistr (..))
 import Cardano.Ledger.Shelley.Governance
 import Cardano.Ledger.Shelley.LedgerState (
   EpochState (..),
+  LedgerState,
   NewEpochState (..),
   certDState,
   certVState,
@@ -215,10 +227,14 @@ import Cardano.Ledger.Shelley.LedgerState (
   epochStateTreasuryL,
   esLStateL,
   lsCertState,
+  lsCertStateL,
   lsUTxOState,
+  lsUTxOStateL,
   newEpochStateGovStateL,
+  utxosGovStateL,
   utxosStakeDistr,
   vsCommitteeState,
+  vsCommitteeStateL,
   vsDReps,
  )
 import Cardano.Ledger.UMap
@@ -229,8 +245,10 @@ import Control.Monad.Trans.Reader (ReaderT, ask)
 import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
 import Data.Default.Class (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
@@ -504,3 +522,21 @@ setFreshDRepPulsingState epochNo stakePoolDistr epochState = do
 -- point. Whenever pulser is already in computed state this will be a noop.
 forceDRepPulsingState :: ConwayEraGov era => NewEpochState era -> NewEpochState era
 forceDRepPulsingState nes = nes & newEpochStateDRepPulsingStateL %~ completeDRepPulsingState
+
+authorizedElectedHotCommitteeCredentials ::
+  ConwayEraGov era =>
+  LedgerState era ->
+  Set.Set (Credential 'HotCommitteeRole (EraCrypto era))
+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

@@ -584,8 +584,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 c) = ConwayMempoolEvent (ConwayEra c)
 
 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/GovSpec.hs

@@ -559,7 +559,7 @@ proposalsSpec = do
       unregisteredRewardAccount <- freshKeyHash >>= getRewardAccountFor . KeyHashObj
       deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
       anchor <- arbitrary
-      let mkProposal rewardAccount =
+      let mkProposal' rewardAccount =
             ProposalProcedure
               { pProcDeposit = deposit
               , pProcReturnAddr = rewardAccount
@@ -568,12 +568,12 @@ proposalsSpec = do
               }
       if HF.bootstrapPhase protVer
         then do
-          submitProposal_ $ mkProposal registeredRewardAccount
-          submitProposal_ $ mkProposal unregisteredRewardAccount
+          submitProposal_ $ mkProposal' registeredRewardAccount
+          submitProposal_ $ mkProposal' unregisteredRewardAccount
         else do
-          submitProposal_ $ mkProposal registeredRewardAccount
+          submitProposal_ $ mkProposal' registeredRewardAccount
           submitFailingProposal
-            (mkProposal unregisteredRewardAccount)
+            (mkProposal' unregisteredRewardAccount)
             [ injectFailure $ ProposalReturnAccountDoesNotExist unregisteredRewardAccount
             ]
     describe "Consistency" $ do

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 (..),
@@ -22,17 +23,19 @@ import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep
 import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
 import Cardano.Ledger.SafeHash (originalBytesSize)
-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 Data.Default.Class (def)
+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,
@@ -249,3 +252,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

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

@@ -47,6 +47,7 @@ module Test.Cardano.Ledger.Conway.ImpTest (
   setupPoolWithStake,
   setupPoolWithoutStake,
   conwayModifyPParams,
+  mkProposal,
   getProposals,
   getEnactState,
   getGovActionState,
@@ -789,6 +790,30 @@ submitAndExpireProposalToMakeReward stakingC = do
   passNEpochs $ 2 + fromIntegral lifetime
   expectMissingGovActionId gai
 
+mkProposalWithRewardAccount ::
+  (ShelleyEraImp era, ConwayEraTxBody era) =>
+  GovAction era ->
+  RewardAccount (EraCrypto era) ->
+  ImpTestM era (ProposalProcedure era)
+mkProposalWithRewardAccount ga rewardAccount = do
+  deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
+  anchor <- arbitrary
+  pure
+    ProposalProcedure
+      { pProcDeposit = deposit
+      , pProcReturnAddr = rewardAccount
+      , pProcGovAction = ga
+      , pProcAnchor = anchor
+      }
+
+mkProposal ::
+  (ShelleyEraImp era, ConwayEraTxBody era) =>
+  GovAction era ->
+  ImpTestM era (ProposalProcedure era)
+mkProposal ga = do
+  rewardAccount <- registerRewardAccount
+  mkProposalWithRewardAccount ga rewardAccount
+
 -- | Submits a transaction that proposes the given governance action
 trySubmitGovActions ::
   (ShelleyEraImp era, ConwayEraTxBody era) =>