Merge pull request #4639 from IntersectMBO/aniketd/check-reward-accou…

…nt-for-proposal-refunds-and-treasury-withdrawals

Prevent non-registered return accounts for proposals' deposits and `TreasuryWithdrawals`

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,9 @@
 
 ## 1.17.0.0
 
+* Add predicate failures to guard against invalid reward accounts (return addresses) in proposals and treasury withdrawals. #4639
+  * `ProposalReturnAddressDoesNotExist`, and 
+  * `TreasuryWithdrawalReturnAddressDoesNotExist`.
 * Add `refScriptCostStride` and `refScriptCostMultiplier`
 * Added protocol version argument to `ppuWellFormed`
 * Add `ConwayMempoolEvent` type

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE EmptyDataDeriving #-}
@@ -16,6 +17,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Cardano.Ledger.Conway.Rules.Gov (
@@ -26,7 +28,7 @@ module Cardano.Ledger.Conway.Rules.Gov (
   ConwayGovPredFailure (..),
 ) where
 
-import Cardano.Ledger.Address (RewardAccount, raNetwork)
+import Cardano.Ledger.Address (RewardAccount, raCredential, raNetwork)
 import Cardano.Ledger.BaseTypes (
   EpochInterval (..),
   EpochNo (..),
@@ -59,6 +61,7 @@ import Cardano.Ledger.CertState (
   authorizedHotCommitteeCredentials,
  )
 import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Conway.Core (ppGovActionDepositL, ppGovActionLifetimeL)
 import Cardano.Ledger.Conway.Era (ConwayEra, ConwayGOV)
 import Cardano.Ledger.Conway.Governance (
   GovAction (..),
@@ -81,6 +84,8 @@ import Cardano.Ledger.Conway.Governance (
   isCommitteeVotingAllowed,
   isDRepVotingAllowed,
   isStakePoolVotingAllowed,
+  pProcGovActionL,
+  pProcReturnAddrL,
   pRootsL,
   proposalsActionsMap,
   proposalsAddAction,
@@ -91,17 +96,17 @@ import Cardano.Ledger.Conway.Governance (
 import Cardano.Ledger.Conway.Governance.Proposals (mapProposals)
 import Cardano.Ledger.Conway.PParams (
   ConwayEraPParams (..),
-  ppGovActionDepositL,
-  ppGovActionLifetimeL,
  )
 import Cardano.Ledger.Conway.TxCert
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential)
 import Cardano.Ledger.Keys (KeyRole (..))
 import Cardano.Ledger.Rules.ValidationMode (Test, runTest)
 import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
+import Cardano.Ledger.Shelley.LedgerState (dsUnifiedL)
 import Cardano.Ledger.Shelley.PParams (pvCanFollow)
 import Cardano.Ledger.TxIn (TxId (..))
+import qualified Cardano.Ledger.UMap as UMap
 import Control.DeepSeq (NFData)
 import Control.Monad (unless)
 import Control.Monad.Trans.Reader (asks)
@@ -196,6 +201,10 @@ data ConwayGovPredFailure era
     VotersDoNotExist (NonEmpty (Voter (EraCrypto era)))
   | -- | Treasury withdrawals that sum up to zero are not allowed
     ZeroTreasuryWithdrawals (GovAction era)
+  | -- | Proposals that have an invalid reward account for returns of the deposit
+    ProposalReturnAccountDoesNotExist (RewardAccount (EraCrypto era))
+  | -- | Treasury withdrawal proposals to an invalid reward account
+    TreasuryWithdrawalReturnAccountsDoNotExist (NonEmpty (RewardAccount (EraCrypto era)))
   deriving (Eq, Show, Generic)
 
 type instance EraRuleFailure "GOV" (ConwayEra c) = ConwayGovPredFailure (ConwayEra c)
@@ -226,6 +235,8 @@ instance EraPParams era => DecCBOR (ConwayGovPredFailure era) where
     13 -> SumD DisallowedVotesDuringBootstrap <! From
     14 -> SumD VotersDoNotExist <! From
     15 -> SumD ZeroTreasuryWithdrawals <! From
+    16 -> SumD ProposalReturnAccountDoesNotExist <! From
+    17 -> SumD TreasuryWithdrawalReturnAccountsDoNotExist <! From
     k -> Invalid k
 
 instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where
@@ -266,6 +277,10 @@ instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where
         Sum VotersDoNotExist 14 !> To voters
       ZeroTreasuryWithdrawals ga ->
         Sum ZeroTreasuryWithdrawals 15 !> To ga
+      ProposalReturnAccountDoesNotExist returnAccount ->
+        Sum ProposalReturnAccountDoesNotExist 16 !> To returnAccount
+      TreasuryWithdrawalReturnAccountsDoNotExist accounts ->
+        Sum TreasuryWithdrawalReturnAccountsDoNotExist 17 !> To accounts
 
 instance EraPParams era => ToCBOR (ConwayGovPredFailure era) where
   toCBOR = toEraCBOR @era
@@ -416,7 +431,7 @@ govTransition ::
   TransitionRule (EraRule "GOV" era)
 govTransition = do
   TRC
-    ( GovEnv txid currentEpoch pp constitutionPolicy CertState {certPState, certVState}
+    ( GovEnv txid currentEpoch pp constitutionPolicy CertState {certDState, certPState, certVState}
       , st
       , GovSignal {gsVotingProcedures, gsProposalProcedures, gsCertificates}
       ) <-
@@ -446,6 +461,19 @@ govTransition = do
         -- PParamsUpdate well-formedness check
         runTest $ actionWellFormed (pp ^. ppProtocolVersionL) pProcGovAction
 
+        unless (HF.bootstrapPhase $ pp ^. ppProtocolVersionL) $ do
+          let refundAddress = proposal ^. pProcReturnAddrL
+              govAction = proposal ^. pProcGovActionL
+          UMap.member' (raCredential refundAddress) (certDState ^. dsUnifiedL)
+            ?! ProposalReturnAccountDoesNotExist refundAddress
+          case govAction of
+            TreasuryWithdrawals withdrawals _ -> do
+              let nonRegisteredAccounts =
+                    flip Map.filterWithKey withdrawals $ \withdrawalAddress _ ->
+                      not $ UMap.member' (raCredential withdrawalAddress) (certDState ^. dsUnifiedL)
+              failOnNonEmpty (Map.keys nonRegisteredAccounts) TreasuryWithdrawalReturnAccountsDoNotExist
+            _ -> pure ()
+
         -- Deposit check
         let expectedDep = pp ^. ppGovActionDepositL
          in pProcDeposit

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/GovSpec.hs

@@ -5,9 +5,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Test.Cardano.Ledger.Conway.Imp.GovSpec (
   spec,
@@ -20,7 +20,7 @@ import Cardano.Ledger.Coin (Coin (Coin))
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Governance
 import Cardano.Ledger.Conway.Rules (ConwayGovPredFailure (..))
-import Cardano.Ledger.Credential (Credential (KeyHashObj), StakeCredential)
+import Cardano.Ledger.Credential (Credential (KeyHashObj))
 import Cardano.Ledger.Plutus.CostModels (updateCostModels)
 import qualified Cardano.Ledger.Shelley.HardForks as HF
 import Cardano.Ledger.Shelley.LedgerState
@@ -31,7 +31,6 @@ import Cardano.Ledger.Shelley.Scripts (
   pattern RequireSignature,
  )
 import Cardano.Ledger.Val (zero, (<->))
-import Control.Monad (forM)
 import Data.Default.Class (Default (..))
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.List.NonEmpty as NE
@@ -486,22 +485,13 @@ proposalsWithVotingSpec =
         fmap (!! 3) getProposalsForest
           `shouldReturn` Node (SJust p116) []
     it "Proposals are stored in the expected order" $ do
-      modifyPParams $
-        ppMaxValSizeL .~ 1_000_000_000
-      returnAddr <- registerRewardAccount
+      modifyPParams $ ppMaxValSizeL .~ 1_000_000_000
       deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
       ens <- getEnactState
-      withdrawals <- do
-        creds <- arbitrary :: ImpTestM era (NonEmpty (StakeCredential (EraCrypto era)))
-        pairs <-
-          forM
-            creds
-            ( \cred -> do
-                Positive n <- arbitrary
-                ac <- getRewardAccountFor cred
-                pure (ac, Coin n)
-            )
-        pure $ Map.fromList (NE.toList pairs)
+      returnAddr <- registerRewardAccount
+      withdrawal <-
+        Map.singleton returnAddr . Coin . getPositive
+          <$> (arbitrary :: ImpTestM era (Positive Integer))
       let
         mkProp name action = do
           ProposalProcedure
@@ -513,7 +503,7 @@ proposalsWithVotingSpec =
         prop0 = mkProp "prop0" InfoAction
         prop1 = mkProp "prop1" $ NoConfidence (ens ^. ensPrevCommitteeL)
         prop2 = mkProp "prop2" InfoAction
-        prop3 = mkProp "prop3" $ TreasuryWithdrawals withdrawals SNothing
+        prop3 = mkProp "prop3" $ TreasuryWithdrawals withdrawal SNothing
       submitProposal_ prop0
       submitProposal_ prop1
       let
@@ -550,8 +540,7 @@ proposalsSpec = do
         [injectFailure $ VotersDoNotExist [StakePoolVoter poolId]]
       dRepCred <- KeyHashObj <$> freshKeyHash
       whenPostBootstrap $ do
-        submitFailingVote (DRepVoter dRepCred) gaId $
-          [injectFailure $ VotersDoNotExist [(DRepVoter dRepCred)]]
+        submitFailingVote (DRepVoter dRepCred) gaId [injectFailure $ VotersDoNotExist [DRepVoter dRepCred]]
     it "DRep votes are removed" $ do
       pp <- getsNES $ nesEsL . curPParamsEpochStateL
       gaId <- submitGovAction InfoAction
@@ -564,6 +553,29 @@ proposalsSpec = do
       gasAfterRemoval <- getGovActionState gaId
       gasDRepVotes gasAfterRemoval `shouldBe` []
   describe "Proposals" $ do
+    it "Predicate failure when proposal deposit has nonexistent return address" $ do
+      protVer <- getProtVer
+      registeredRewardAccount <- registerRewardAccount
+      unregisteredRewardAccount <- freshKeyHash >>= getRewardAccountFor . KeyHashObj
+      deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
+      anchor <- arbitrary
+      let mkProposal rewardAccount =
+            ProposalProcedure
+              { pProcDeposit = deposit
+              , pProcReturnAddr = rewardAccount
+              , pProcGovAction = InfoAction
+              , pProcAnchor = anchor
+              }
+      if HF.bootstrapPhase protVer
+        then do
+          submitProposal_ $ mkProposal registeredRewardAccount
+          submitProposal_ $ mkProposal unregisteredRewardAccount
+        else do
+          submitProposal_ $ mkProposal registeredRewardAccount
+          submitFailingProposal
+            (mkProposal unregisteredRewardAccount)
+            [ injectFailure $ ProposalReturnAccountDoesNotExist unregisteredRewardAccount
+            ]
     describe "Consistency" $ do
       it "Proposals submitted without proper parent fail" $ do
         let mkCorruptGovActionId :: GovActionId c -> GovActionId c
@@ -577,7 +589,7 @@ proposalsSpec = do
               [ Node () []
               ]
         pp <- getsNES $ nesEsL . curPParamsEpochStateL
-        khPropRwd <- freshKeyHash
+        rewardAccount <- registerRewardAccount
         let parameterChangeAction =
               ParameterChange
                 (SJust $ GovPurposeId $ mkCorruptGovActionId p1)
@@ -586,7 +598,7 @@ proposalsSpec = do
             parameterChangeProposal =
               ProposalProcedure
                 { pProcDeposit = pp ^. ppGovActionDepositL
-                , pProcReturnAddr = RewardAccount Testnet (KeyHashObj khPropRwd)
+                , pProcReturnAddr = rewardAccount
                 , pProcGovAction = parameterChangeAction
                 , pProcAnchor = def
                 }
@@ -1130,18 +1142,34 @@ networkIdSpec =
               , raCredential = rewardCredential
               }
       propDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
-      submitFailingProposal
-        ProposalProcedure
-          { pProcReturnAddr = badRewardAccount
-          , pProcGovAction = InfoAction
-          , pProcDeposit = propDeposit
-          , pProcAnchor = def
-          }
-        [ injectFailure $
-            ProposalProcedureNetworkIdMismatch
-              badRewardAccount
-              Testnet
-        ]
+      pv <- getProtVer
+      let proposal =
+            ProposalProcedure
+              { pProcReturnAddr = badRewardAccount
+              , pProcGovAction = InfoAction
+              , pProcDeposit = propDeposit
+              , pProcAnchor = def
+              }
+      if HF.bootstrapPhase pv
+        then
+          submitFailingProposal
+            proposal
+            [ injectFailure $
+                ProposalProcedureNetworkIdMismatch
+                  badRewardAccount
+                  Testnet
+            ]
+        else
+          submitFailingProposal
+            proposal
+            [ injectFailure $
+                ProposalReturnAccountDoesNotExist
+                  badRewardAccount
+            , injectFailure $
+                ProposalProcedureNetworkIdMismatch
+                  badRewardAccount
+                  Testnet
+            ]
 
 withdrawalsSpec ::
   forall era.
@@ -1151,6 +1179,19 @@ withdrawalsSpec ::
   SpecWith (ImpTestState era)
 withdrawalsSpec =
   describe "Withdrawals" $ do
+    it "Fails predicate when treasury withdrawal has nonexistent return address" $ do
+      policy <- getGovPolicy
+      unregisteredRewardAccount <- freshKeyHash >>= getRewardAccountFor . KeyHashObj
+      registeredRewardAccount <- registerRewardAccount
+      let genPositiveCoin = Coin . getPositive <$> arbitrary
+          withdrawalAccountDoesNotExist = TreasuryWithdrawalReturnAccountsDoNotExist [unregisteredRewardAccount]
+      withdrawals <-
+        sequence
+          [ (unregisteredRewardAccount,) <$> genPositiveCoin
+          , (registeredRewardAccount,) <$> genPositiveCoin
+          ]
+      expectPredFailures [withdrawalAccountDoesNotExist] [] $
+        TreasuryWithdrawals (Map.fromList withdrawals) policy
     it "Fails with invalid network ID in withdrawal addresses" $ do
       rewardCredential <- KeyHashObj <$> freshKeyHash
       let badRewardAccount =
@@ -1160,31 +1201,34 @@ withdrawalsSpec =
               }
           wdrls = TreasuryWithdrawals (Map.singleton badRewardAccount $ Coin 100_000_000) SNothing
           idMismatch = TreasuryWithdrawalsNetworkIdMismatch (Set.singleton badRewardAccount) Testnet
-      expectPredFailures [idMismatch] [idMismatch] wdrls
+          returnAddress = TreasuryWithdrawalReturnAccountsDoNotExist [badRewardAccount]
+      expectPredFailures [returnAddress, idMismatch] [idMismatch] wdrls
 
     it "Fails for empty withdrawals" $ do
-      rwdAccount1 <- freshKeyHash >>= getRewardAccountFor . KeyHashObj
-      rwdAccount2 <- freshKeyHash >>= getRewardAccountFor . KeyHashObj
+      rwdAccount1 <- registerRewardAccount
+      rwdAccount2 <- registerRewardAccount
+      let withdrawals = Map.fromList [(rwdAccount1, zero), (rwdAccount2, zero)]
       let wdrls = TreasuryWithdrawals Map.empty SNothing
        in expectPredFailures [ZeroTreasuryWithdrawals wdrls] [] wdrls
 
       let wdrls = TreasuryWithdrawals [(rwdAccount1, zero)] SNothing
        in expectPredFailures [ZeroTreasuryWithdrawals wdrls] [] wdrls
 
-      let wdrls = TreasuryWithdrawals [(rwdAccount1, zero), (rwdAccount2, zero)] SNothing
+      let wdrls = TreasuryWithdrawals withdrawals SNothing
        in expectPredFailures [ZeroTreasuryWithdrawals wdrls] [] wdrls
 
       rwdAccountRegistered <- registerRewardAccount
       let wdrls = TreasuryWithdrawals [(rwdAccountRegistered, zero)] SNothing
        in expectPredFailures [ZeroTreasuryWithdrawals wdrls] [] wdrls
 
       curProtVer <- getProtVer
-      let wdrls = [(rwdAccount1, zero), (rwdAccount2, Coin 100000)]
-          ga = TreasuryWithdrawals (Map.fromList wdrls) SNothing
+      let wdrls = Map.insert rwdAccount2 (Coin 100_000) withdrawals
+          ga = TreasuryWithdrawals wdrls SNothing
        in if HF.bootstrapPhase curProtVer
             then do
               expectPredFailures [] [] ga
-            else void $ submitTreasuryWithdrawals wdrls
+            else
+              submitGovAction_ ga
   where
     expectPredFailures ::
       [ConwayGovPredFailure era] -> [ConwayGovPredFailure era] -> GovAction era -> ImpTestM era ()

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.15.0.0
 
+* Add `member'` function to `UMap` module. #4639
 * Add `credKeyHash` to `Credential`
 * Remove `maxMajorPV` from `Globals`
 * Add `deleteStakingCredential` and `extractStakingCredential` to `UMap` module.

libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs

@@ -82,6 +82,7 @@ module Cardano.Ledger.UMap (
   -- * Set and Map operations on `UView`s
   nullUView,
   member,
+  member',
   notMember,
   delete,
   delete',
@@ -1002,6 +1003,10 @@ DRepUView UMap {umElems, umPtrs} ⋫ dRepSet = UMap (Map.foldlWithKey' accum umE
       _ -> ans
 rngDelete = (⋫)
 
+-- | Checks for membership directly against `umElems` instead of a `UView`.
+member' :: Credential 'Staking c -> UMap c -> Bool
+member' k = Map.member k . umElems
+
 -- | Membership check for a `UView`, just like `Map.member`
 --
 -- Spec: