diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs index a29ebaec0ea..551cdd2d626 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs +++ b/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 SumD ConwayTreasuryValueMismatch SumD ConwayTxRefScriptsSizeTooBig SumD ConwayReturnAddressDoesNotExist 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 diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs index 157dc51d42a..40b465d056f 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/LedgerSpec.hs +++ b/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 + ] diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs index e844b7a5ecf..09b6639309a 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/UMap.hs +++ b/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: diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs index 2ba5731066a..82d3c15575f 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/PrettyCore.hs +++ b/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