Predicate-failures for invalid return addresses.

* ProposalReturnAddressDoesNotExist
* TreasuryWithdrawalReturnAddressDoesNotExist

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 `ZeroTreasuryWithdrawals` to `ConwayGovPredFailure`
 * Add `ProtVer` argument to `TxInfo` functions:
   * `transTxCert`

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,19 +96,19 @@ 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 (forM_, unless)
 import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition.Extended (
   STS (..),
@@ -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
+    ProposalReturnAddressDoesNotExist (RewardAccount (EraCrypto era))
+  | -- | Treasury withdrawal proposals to an invalid reward account
+    TreasuryWithdrawalReturnAddressDoesNotExist (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 ProposalReturnAddressDoesNotExist <! From
+    17 -> SumD TreasuryWithdrawalReturnAddressDoesNotExist <! 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
+      ProposalReturnAddressDoesNotExist returnAddress ->
+        Sum ProposalReturnAddressDoesNotExist 16 !> To returnAddress
+      TreasuryWithdrawalReturnAddressDoesNotExist returnAddress ->
+        Sum TreasuryWithdrawalReturnAddressDoesNotExist 17 !> To returnAddress
 
 instance EraPParams era => ToCBOR (ConwayGovPredFailure era) where
   toCBOR = toEraCBOR @era
@@ -415,7 +430,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}
       ) <-
@@ -445,6 +460,18 @@ govTransition = do
         -- PParamsUpdate well-formedness check
         runTest $ actionWellFormed pProcGovAction
 
+        unless (HF.bootstrapPhase $ pp ^. ppProtocolVersionL) $ do
+          let refundAddress = proposal ^. pProcReturnAddrL
+              govAction = proposal ^. pProcGovActionL
+          UMap.member' (raCredential refundAddress) (certDState ^. dsUnifiedL)
+            ?! ProposalReturnAddressDoesNotExist refundAddress
+          case govAction of
+            TreasuryWithdrawals withdrawals _ ->
+              forM_ (Map.keys withdrawals) $ \withdrawalAddress ->
+                UMap.member' (raCredential withdrawalAddress) (certDState ^. dsUnifiedL)
+                  ?! TreasuryWithdrawalReturnAddressDoesNotExist withdrawalAddress
+            _ -> 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
+      modifyPParams $ ppMaxValSizeL .~ 1_000_000_000
       returnAddr <- registerRewardAccount
       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)
+      withdrawals <-
+        Map.fromList . map ((returnAddr,) . Coin . getPositive) . NE.toList
+          <$> (arbitrary :: ImpTestM era (NonEmpty (Positive Integer)))
       let
         mkProp name action = do
           ProposalProcedure
@@ -543,15 +533,18 @@ proposalsSpec = do
       let ProtVer major minor = pp ^. ppProtocolVersionL
       gaId <- submitGovAction $ HardForkInitiation SNothing $ ProtVer major (succ minor)
       hotCred <- KeyHashObj <$> freshKeyHash
-      submitFailingVote (CommitteeVoter hotCred) gaId $
+      submitFailingVote
+        (CommitteeVoter hotCred)
+        gaId
         [injectFailure $ VotersDoNotExist [CommitteeVoter hotCred]]
       poolId <- freshKeyHash
-      submitFailingVote (StakePoolVoter poolId) gaId $
+      submitFailingVote
+        (StakePoolVoter poolId)
+        gaId
         [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 +557,29 @@ proposalsSpec = do
       gasAfterRemoval <- getGovActionState gaId
       gasDRepVotes gasAfterRemoval `shouldBe` []
   describe "Proposals" $ do
+    it "Fails predicate 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 $ ProposalReturnAddressDoesNotExist unregisteredRewardAccount
+            ]
     describe "Consistency" $ do
       it "Proposals submitted without proper parent fail" $ do
         let mkCorruptGovActionId :: GovActionId c -> GovActionId c
@@ -578,22 +594,32 @@ proposalsSpec = do
               ]
         pp <- getsNES $ nesEsL . curPParamsEpochStateL
         khPropRwd <- freshKeyHash
-        let parameterChangeAction =
+        let badRewardAccount = RewardAccount Testnet (KeyHashObj khPropRwd)
+            parameterChangeAction =
               ParameterChange
                 (SJust $ GovPurposeId $ mkCorruptGovActionId p1)
                 (def & ppuMinFeeAL .~ SJust (Coin 3000))
                 SNothing
             parameterChangeProposal =
               ProposalProcedure
                 { pProcDeposit = pp ^. ppGovActionDepositL
-                , pProcReturnAddr = RewardAccount Testnet (KeyHashObj khPropRwd)
+                , pProcReturnAddr = badRewardAccount
                 , pProcGovAction = parameterChangeAction
                 , pProcAnchor = def
                 }
-        submitFailingProposal
-          parameterChangeProposal
-          [ injectFailure $ InvalidPrevGovActionId parameterChangeProposal
-          ]
+        protVer <- getProtVer
+        if HF.bootstrapPhase protVer
+          then
+            submitFailingProposal
+              parameterChangeProposal
+              [ injectFailure $ InvalidPrevGovActionId parameterChangeProposal
+              ]
+          else
+            submitFailingProposal
+              parameterChangeProposal
+              [ injectFailure $ ProposalReturnAddressDoesNotExist badRewardAccount
+              , injectFailure $ InvalidPrevGovActionId parameterChangeProposal
+              ]
       it "Subtrees are pruned when proposals expire" $ do
         modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 4
         p1 <- submitParameterChange SNothing (def & ppuMinFeeAL .~ SJust (Coin 3000))
@@ -1132,18 +1158,37 @@ networkIdSpec =
               , raCredential = rewardCredential
               }
       propDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
-      submitFailingProposal
-        ProposalProcedure
-          { pProcReturnAddr = badRewardAccount
-          , pProcGovAction = InfoAction
-          , pProcDeposit = propDeposit
-          , pProcAnchor = def
-          }
-        [ injectFailure $
-            ProposalProcedureNetworkIdMismatch
-              badRewardAccount
-              Testnet
-        ]
+      pv <- getProtVer
+      if HF.bootstrapPhase pv
+        then
+          submitFailingProposal
+            ProposalProcedure
+              { pProcReturnAddr = badRewardAccount
+              , pProcGovAction = InfoAction
+              , pProcDeposit = propDeposit
+              , pProcAnchor = def
+              }
+            [ injectFailure $
+                ProposalProcedureNetworkIdMismatch
+                  badRewardAccount
+                  Testnet
+            ]
+        else
+          submitFailingProposal
+            ProposalProcedure
+              { pProcReturnAddr = badRewardAccount
+              , pProcGovAction = InfoAction
+              , pProcDeposit = propDeposit
+              , pProcAnchor = def
+              }
+            [ injectFailure $
+                ProposalReturnAddressDoesNotExist
+                  badRewardAccount
+            , injectFailure $
+                ProposalProcedureNetworkIdMismatch
+                  badRewardAccount
+                  Testnet
+            ]
 
 withdrawalsSpec ::
   forall era.
@@ -1153,6 +1198,12 @@ 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
+      let returnAddressDoesNotExist = TreasuryWithdrawalReturnAddressDoesNotExist unregisteredRewardAccount
+          withdrawals = TreasuryWithdrawals (Map.singleton unregisteredRewardAccount $ Coin 1_000) policy
+      expectPredFailures [returnAddressDoesNotExist] [] withdrawals
     it "Fails with invalid network ID in withdrawal addresses" $ do
       rewardCredential <- KeyHashObj <$> freshKeyHash
       let badRewardAccount =
@@ -1162,31 +1213,47 @@ withdrawalsSpec =
               }
           wdrls = TreasuryWithdrawals (Map.singleton badRewardAccount $ Coin 100_000_000) SNothing
           idMismatch = TreasuryWithdrawalsNetworkIdMismatch (Set.singleton badRewardAccount) Testnet
-      expectPredFailures [idMismatch] [idMismatch] wdrls
+          returnAddress = TreasuryWithdrawalReturnAddressDoesNotExist badRewardAccount
+      expectPredFailures [returnAddress, idMismatch] [idMismatch] wdrls
 
     it "Fails for empty withdrawals" $ do
       rwdAccount1 <- freshKeyHash >>= getRewardAccountFor . KeyHashObj
       rwdAccount2 <- freshKeyHash >>= getRewardAccountFor . KeyHashObj
+      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
+       in expectPredFailures
+            [ TreasuryWithdrawalReturnAddressDoesNotExist rwdAccount1
+            , ZeroTreasuryWithdrawals wdrls
+            ]
+            []
+            wdrls
 
-      let wdrls = TreasuryWithdrawals [(rwdAccount1, zero), (rwdAccount2, zero)] SNothing
-       in expectPredFailures [ZeroTreasuryWithdrawals wdrls] [] wdrls
+      let wdrls = TreasuryWithdrawals withdrawals SNothing
+       in expectPredFailures
+            ( (TreasuryWithdrawalReturnAddressDoesNotExist <$> Map.keys withdrawals)
+                <> [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
+              expectPredFailures
+                (TreasuryWithdrawalReturnAddressDoesNotExist <$> Map.keys wdrls)
+                []
+                ga
   where
     expectPredFailures ::
       [ConwayGovPredFailure era] -> [ConwayGovPredFailure era] -> GovAction era -> ImpTestM era ()