Add ConwayReturnAddressDoesNotExist predicate-failure

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

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,18 +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 (forM)
 import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition.Extended (
   STS (..),
@@ -193,6 +199,8 @@ data ConwayGovPredFailure era
       (NonEmpty (Voter (EraCrypto era), GovActionId (EraCrypto era)))
   | -- | Predicate failure for votes by entities that are not present in the ledger state
     VotersDoNotExist (NonEmpty (Voter (EraCrypto era)))
+  | ProposalReturnAddressDoesNotExist (RewardAccount (EraCrypto era))
+  | TreasuryWithdrawalReturnAddressDoesNotExist (RewardAccount (EraCrypto era))
   deriving (Eq, Show, Generic)
 
 type instance EraRuleFailure "GOV" (ConwayEra c) = ConwayGovPredFailure (ConwayEra c)
@@ -222,6 +230,8 @@ instance EraPParams era => DecCBOR (ConwayGovPredFailure era) where
     12 -> SumD DisallowedProposalDuringBootstrap <! From
     13 -> SumD DisallowedVotesDuringBootstrap <! From
     14 -> SumD VotersDoNotExist <! From
+    15 -> SumD ProposalReturnAddressDoesNotExist <! From
+    16 -> SumD TreasuryWithdrawalReturnAddressDoesNotExist <! From
     k -> Invalid k
 
 instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where
@@ -260,6 +270,10 @@ instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where
         Sum DisallowedVotesDuringBootstrap 13 !> To votes
       VotersDoNotExist voters ->
         Sum VotersDoNotExist 14 !> To voters
+      ProposalReturnAddressDoesNotExist returnAddress ->
+        Sum ProposalReturnAddressDoesNotExist 15 !> To returnAddress
+      TreasuryWithdrawalReturnAddressDoesNotExist returnAddress ->
+        Sum TreasuryWithdrawalReturnAddressDoesNotExist 16 !> To returnAddress
 
 instance EraPParams era => ToCBOR (ConwayGovPredFailure era) where
   toCBOR = toEraCBOR @era
@@ -409,7 +423,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}
       ) <-
@@ -439,6 +453,24 @@ govTransition = do
         -- PParamsUpdate well-formedness check
         runTest $ actionWellFormed pProcGovAction
 
+        _ <-
+          if HF.bootstrapPhase (pp ^. ppProtocolVersionL)
+            then pure [()]
+            else 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

@@ -40,6 +40,7 @@ import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set
 import Data.Tree
 import Lens.Micro
+import Lens.Micro.Mtl (use)
 import Test.Cardano.Ledger.Conway.Arbitrary ()
 import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
@@ -250,10 +251,72 @@ pparamUpdateSpec =
 
 proposalsWithVotingSpec ::
   forall era.
-  ConwayEraImp era =>
+  ( ConwayEraImp era
+  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
+  ) =>
   SpecWith (ImpTestState era)
 proposalsWithVotingSpec =
   describe "Proposals" $ do
+    describe "Failures expected after bootstrap phase" $ do
+      it "Fails predicate when treasury withdrawal has nonexistent return address" $ do
+        policy <- getGovPolicy
+        protVer <- getProtVer
+        registeredRewardAccount <- registerRewardAccount
+        netId <- use (impGlobalsL . to networkId)
+        unregisteredRewardAccount <- RewardAccount netId . KeyHashObj <$> freshKeyHash
+        deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
+        anchor <- arbitrary
+        let mkTreasuryWithdrawal rewardAccount =
+              ProposalProcedure
+                { pProcDeposit = deposit
+                , pProcReturnAddr = registeredRewardAccount
+                , pProcGovAction =
+                    TreasuryWithdrawals (Map.singleton rewardAccount $ Coin 1_000) policy
+                , pProcAnchor = anchor
+                }
+            validTreasuryWithdrawal = mkTreasuryWithdrawal registeredRewardAccount
+            invalidTreasuryWithdrawal = mkTreasuryWithdrawal unregisteredRewardAccount
+        if HF.bootstrapPhase protVer
+          then do
+            submitFailingProposal
+              validTreasuryWithdrawal
+              [injectFailure $ DisallowedProposalDuringBootstrap validTreasuryWithdrawal]
+            submitFailingProposal
+              invalidTreasuryWithdrawal
+              [ injectFailure $ DisallowedProposalDuringBootstrap invalidTreasuryWithdrawal
+              , injectFailure $ TreasuryWithdrawalReturnAddressDoesNotExist unregisteredRewardAccount
+              ]
+          else do
+            submitProposal_ validTreasuryWithdrawal
+            submitFailingProposal
+              invalidTreasuryWithdrawal
+              [ injectFailure $ TreasuryWithdrawalReturnAddressDoesNotExist unregisteredRewardAccount
+              ]
+
+      it "Fails predicate when proposal deposit has nonexistent return address" $ do
+        protVer <- getProtVer
+        registeredRewardAccount <- registerRewardAccount
+        netId <- use (impGlobalsL . to networkId)
+        unregisteredRewardAccount <- RewardAccount netId . KeyHashObj <$> freshKeyHash
+        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 "Subtrees are pruned when competing proposals are enacted" $ do
         (dRep, committeeMember, GovPurposeId committeeGovActionId) <- electBasicCommittee
@@ -566,22 +629,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))
@@ -1120,18 +1193,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
+            ]
 
 networkIdWithdrawalsSpec ::
   forall era.
@@ -1161,6 +1253,9 @@ networkIdWithdrawalsSpec =
           , pProcAnchor = def
           }
         [ injectFailure $
+            TreasuryWithdrawalReturnAddressDoesNotExist
+              badRewardAccount
+        , injectFailure $
             TreasuryWithdrawalsNetworkIdMismatch
               (Set.singleton badRewardAccount)
               Testnet

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

@@ -4,20 +4,24 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
 
 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.Rules (ConwayLedgerPredFailure (..), maxRefScriptSizePerTx)
+import Cardano.Ledger.Conway.Rules (
+  ConwayLedgerPredFailure (..),
+  maxRefScriptSizePerTx,
+ )
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep
 import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
 import Cardano.Ledger.SafeHash (originalBytesSize)
 import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
 import qualified Data.Set as Set
-import Lens.Micro ((&), (.~))
+import Lens.Micro
 import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Imp.Common
 import Test.Cardano.Ledger.Plutus.Examples (

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

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