Add ConwayReturnAddressDoesNotExist predicate-failure

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

@@ -55,9 +55,12 @@ import Cardano.Ledger.Conway.Era (
 import Cardano.Ledger.Conway.Governance (
   ConwayEraGov (..),
   ConwayGovState,
+  GovAction (TreasuryWithdrawals),
   Proposals,
   constitutionScriptL,
   grCommitteeL,
+  pProcGovActionL,
+  pProcReturnAddrL,
   proposalsGovStateL,
   proposalsWithPurpose,
  )
@@ -89,6 +92,8 @@ import Cardano.Ledger.Shelley.LedgerState (
   LedgerState (..),
   UTxOState (..),
   asTreasuryL,
+  certDStateL,
+  dsUnifiedL,
   utxosGovStateL,
   utxosUtxoL,
  )
@@ -109,7 +114,7 @@ import Cardano.Ledger.UMap (UView (..))
 import qualified Cardano.Ledger.UMap as UMap
 import Cardano.Ledger.UTxO (EraUTxO (..))
 import Control.DeepSeq (NFData)
-import Control.Monad (unless)
+import Control.Monad (forM, forM_, unless)
 import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition.Extended (
   Embed (..),
@@ -122,6 +127,7 @@ import Control.State.Transition.Extended (
   trans,
   (?!),
  )
+import Data.Foldable (toList)
 import Data.Kind (Type)
 import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map.Strict as Map
@@ -147,6 +153,7 @@ data ConwayLedgerPredFailure era
       Int
       -- | Maximum allowed total reference script size
       Int
+  | ConwayReturnAddressDoesNotExist (RewardAccount (EraCrypto era))
   deriving (Generic)
 
 -- | In the next era this will become a proper protocol parameter. For now this is a hard
@@ -262,6 +269,7 @@ instance
       ConwayTreasuryValueMismatch actual submitted ->
         Sum (ConwayTreasuryValueMismatch @era) 5 !> To actual !> To submitted
       ConwayTxRefScriptsSizeTooBig x y -> Sum ConwayTxRefScriptsSizeTooBig 6 !> To x !> To y
+      ConwayReturnAddressDoesNotExist x -> Sum ConwayReturnAddressDoesNotExist 7 !> To x
 
 instance
   ( Era era
@@ -279,6 +287,7 @@ instance
       4 -> SumD ConwayWdrlNotDelegatedToDRep <! From
       5 -> SumD ConwayTreasuryValueMismatch <! From <! From
       6 -> SumD ConwayTxRefScriptsSizeTooBig <! From <! From
+      7 -> SumD ConwayReturnAddressDoesNotExist <! From
       n -> Invalid n
 
 data ConwayLedgerEvent era
@@ -411,6 +420,25 @@ ledgerTransition = do
                 Set.filter (not . (`UMap.member` delegatedAddrs) . KeyHashObj) wdrlsKeyHashes
           failOnNonEmpty nonExistentDelegations ConwayWdrlNotDelegatedToDRep
 
+        let checkReturnAddressOnProposals umap pproc = do
+              let refundAddress = pproc ^. pProcReturnAddrL
+                  govAction = pproc ^. pProcGovActionL
+              UMap.member' (raCredential refundAddress) umap
+                ?! ConwayReturnAddressDoesNotExist refundAddress
+              case govAction of
+                TreasuryWithdrawals wmap _ ->
+                  forM
+                    (Map.keys wmap)
+                    ( \withdrawalAddress ->
+                        UMap.member' (raCredential withdrawalAddress) umap
+                          ?! ConwayReturnAddressDoesNotExist withdrawalAddress
+                    )
+                _ -> pure [()]
+
+        forM_
+          (toList $ txBody ^. proposalProceduresTxBodyL)
+          (checkReturnAddressOnProposals $ certState ^. certDStateL . dsUnifiedL)
+
         -- Votes and proposals from signal tx
         let govSignal =
               GovSignal

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

@@ -4,20 +4,36 @@
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Test.Cardano.Ledger.Conway.Imp.LedgerSpec (spec) where
 
+import Cardano.Ledger.Address (RewardAccount (..))
 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.Governance (
+  GovAction (TreasuryWithdrawals),
+  ProposalProcedure (..),
+ )
+import Cardano.Ledger.Conway.Rules (
+  ConwayGovPredFailure (DisallowedProposalDuringBootstrap),
+  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 Cardano.Ledger.Shelley.LedgerState (
+  curPParamsEpochStateL,
+  nesEsL,
+ )
+import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
-import Lens.Micro ((&), (.~))
+import Lens.Micro
+import Lens.Micro.Mtl (use)
 import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Imp.Common
 import Test.Cardano.Ledger.Plutus.Examples (
@@ -29,6 +45,7 @@ spec ::
   forall era.
   ( ConwayEraImp era
   , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
   ) =>
   SpecWith (ImpTestState era)
 spec = do
@@ -89,3 +106,83 @@ spec = do
     submitTx_ $
       mkBasicTx $
         mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(ra, mempty)]
+
+  it "Fails predicate when treasury withdrawal has nonexistent return address" $ do
+    modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
+    policy <- getGovPolicy
+    protVer <- getProtVer
+    registeredRewardAccount <- registerRewardAccount
+    netId <- use (impGlobalsL . to networkId)
+    unregisteredRewardAccount <- RewardAccount netId . KeyHashObj <$> freshKeyHash
+    deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
+    anchor <- arbitrary
+    let mkProposal govAction rewardAccount =
+          ProposalProcedure
+            { pProcDeposit = deposit
+            , pProcReturnAddr = rewardAccount
+            , pProcGovAction = govAction
+            , pProcAnchor = anchor
+            }
+        mkTreasuryWithdrawal rewardAccount =
+          TreasuryWithdrawals (Map.singleton rewardAccount $ Coin 1_000) policy
+        validTreasuryWithdrawal =
+          mkProposal (mkTreasuryWithdrawal registeredRewardAccount) registeredRewardAccount
+        invalidTreasuryWithdrawal =
+          mkProposal (mkTreasuryWithdrawal unregisteredRewardAccount) registeredRewardAccount
+
+    if HF.bootstrapPhase protVer
+      then do
+        submitFailingProposal
+          validTreasuryWithdrawal
+          [injectFailure $ DisallowedProposalDuringBootstrap validTreasuryWithdrawal]
+        submitFailingProposal
+          invalidTreasuryWithdrawal
+          [ injectFailure $ DisallowedProposalDuringBootstrap invalidTreasuryWithdrawal
+          , injectFailure $ ConwayReturnAddressDoesNotExist unregisteredRewardAccount
+          ]
+      else do
+        submitProposal_ validTreasuryWithdrawal
+        submitFailingProposal
+          invalidTreasuryWithdrawal
+          [ injectFailure $ ConwayReturnAddressDoesNotExist unregisteredRewardAccount
+          ]
+
+  it "Fails predicate when proposal deposit has nonexistent return address" $ do
+    modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
+    policy <- getGovPolicy
+    protVer <- getProtVer
+    registeredRewardAccount <- registerRewardAccount
+    netId <- use (impGlobalsL . to networkId)
+    unregisteredRewardAccount <- RewardAccount netId . KeyHashObj <$> freshKeyHash
+    deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
+    anchor <- arbitrary
+    let mkProposal govAction rewardAccount =
+          ProposalProcedure
+            { pProcDeposit = deposit
+            , pProcReturnAddr = rewardAccount
+            , pProcGovAction = govAction
+            , pProcAnchor = anchor
+            }
+        mkTreasuryWithdrawal rewardAccount =
+          TreasuryWithdrawals (Map.singleton rewardAccount $ Coin 1_000) policy
+        proposalWithValidReturnAddress =
+          mkProposal (mkTreasuryWithdrawal registeredRewardAccount) registeredRewardAccount
+        proposalWithInvalidReturnAddress =
+          mkProposal (mkTreasuryWithdrawal registeredRewardAccount) unregisteredRewardAccount
+
+    if HF.bootstrapPhase protVer
+      then do
+        submitFailingProposal
+          proposalWithValidReturnAddress
+          [injectFailure $ DisallowedProposalDuringBootstrap proposalWithValidReturnAddress]
+        submitFailingProposal
+          proposalWithInvalidReturnAddress
+          [ injectFailure $ DisallowedProposalDuringBootstrap proposalWithInvalidReturnAddress
+          , injectFailure $ ConwayReturnAddressDoesNotExist unregisteredRewardAccount
+          ]
+      else do
+        submitProposal_ proposalWithValidReturnAddress
+        submitFailingProposal
+          proposalWithInvalidReturnAddress
+          [ injectFailure $ ConwayReturnAddressDoesNotExist unregisteredRewardAccount
+          ]

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',
@@ -990,6 +991,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:

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs

@@ -1487,6 +1487,7 @@ ppConwayLedgerPredFailure proof x = case x of
       [ ("Computed sum of reference script size", ppInt s1)
       , ("Maximum allowed total reference script size", ppInt s2)
       ]
+  ConwayReturnAddressDoesNotExist a -> ppSexp "ConwayReturnAddressDoesNotExist" [prettyA a]
 
 instance Reflect era => PrettyA (ConwayLedgerPredFailure era) where
   prettyA = ppConwayLedgerPredFailure reify