Merge pull request #4630 from IntersectMBO/td/disallow-empty-withdrawals

Disallow empty withdrawals

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.17.0.0
 
+* Add `ZeroTreasuryWithdrawals` to `ConwayGovPredFailure`
 * Add `ProtVer` argument to `TxInfo` functions:
   * `transTxCert`
   * `transScriptPurpose`

eras/conway/impl/cardano-ledger-conway.cabal

@@ -118,6 +118,7 @@ library testlib
         Test.Cardano.Ledger.Conway.ImpTest
         Test.Cardano.Ledger.Conway.Imp
         Test.Cardano.Ledger.Conway.Imp.BbodySpec
+        Test.Cardano.Ledger.Conway.Imp.CertsSpec
         Test.Cardano.Ledger.Conway.Imp.DelegSpec
         Test.Cardano.Ledger.Conway.Imp.EpochSpec
         Test.Cardano.Ledger.Conway.Imp.EnactSpec

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

@@ -193,6 +193,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)))
+  | -- | Treasury withdrawals that sum up to zero are not allowed
+    ZeroTreasuryWithdrawals (GovAction era)
   deriving (Eq, Show, Generic)
 
 type instance EraRuleFailure "GOV" (ConwayEra c) = ConwayGovPredFailure (ConwayEra c)
@@ -222,6 +224,7 @@ instance EraPParams era => DecCBOR (ConwayGovPredFailure era) where
     12 -> SumD DisallowedProposalDuringBootstrap <! From
     13 -> SumD DisallowedVotesDuringBootstrap <! From
     14 -> SumD VotersDoNotExist <! From
+    15 -> SumD ZeroTreasuryWithdrawals <! From
     k -> Invalid k
 
 instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where
@@ -260,6 +263,8 @@ instance EraPParams era => EncCBOR (ConwayGovPredFailure era) where
         Sum DisallowedVotesDuringBootstrap 13 !> To votes
       VotersDoNotExist voters ->
         Sum VotersDoNotExist 14 !> To voters
+      ZeroTreasuryWithdrawals ga ->
+        Sum ZeroTreasuryWithdrawals 15 !> To ga
 
 instance EraPParams era => ToCBOR (ConwayGovPredFailure era) where
   toCBOR = toEraCBOR @era
@@ -461,6 +466,9 @@ govTransition = do
 
                   -- Policy check
                   runTest $ checkPolicy @era constitutionPolicy proposalPolicy
+
+                  -- The sum of all withdrawals must be positive
+                  F.fold wdrls /= mempty ?! ZeroTreasuryWithdrawals pProcGovAction
           UpdateCommittee _mPrevGovActionId membersToRemove membersToAdd _qrm -> do
             checkConflictingUpdate
             checkExpirationEpoch

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

@@ -20,6 +20,7 @@ import Cardano.Ledger.BaseTypes (Inject, natVersion)
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Rules (
   ConwayBbodyPredFailure,
+  ConwayCertsPredFailure,
   ConwayDelegPredFailure,
   ConwayEpochEvent,
   ConwayGovCertPredFailure,
@@ -33,6 +34,7 @@ import Data.Typeable (Typeable)
 import qualified Test.Cardano.Ledger.Babbage.Imp as BabbageImp
 import Test.Cardano.Ledger.Common
 import qualified Test.Cardano.Ledger.Conway.Imp.BbodySpec as Bbody
+import qualified Test.Cardano.Ledger.Conway.Imp.CertsSpec as Certs
 import qualified Test.Cardano.Ledger.Conway.Imp.DelegSpec as Deleg
 import qualified Test.Cardano.Ledger.Conway.Imp.EnactSpec as Enact
 import qualified Test.Cardano.Ledger.Conway.Imp.EpochSpec as Epoch
@@ -50,6 +52,7 @@ spec ::
   , ConwayEraImp era
   , EraSegWits era
   , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era
   , Inject (BabbageContextError era) (ContextError era)
   , Inject (ConwayContextError era) (ContextError era)
   , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
@@ -89,6 +92,7 @@ spec = do
   describe "ConwayImpSpec - bootstrap phase (protocol version 9)" $
     withImpState @era $ do
       describe "BBODY" $ Bbody.spec @era
+      describe "CERTS" $ Certs.spec @era
       describe "DELEG" $ Deleg.spec @era
       describe "ENACT" $ Enact.relevantDuringBootstrapSpec @era
       describe "EPOCH" $ Epoch.relevantDuringBootstrapSpec @era

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

@@ -0,0 +1,85 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Test.Cardano.Ledger.Conway.Imp.CertsSpec (spec) where
+
+import Cardano.Ledger.BaseTypes (EpochInterval (..))
+import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Conway.Core
+import Cardano.Ledger.Conway.Rules (ConwayCertsPredFailure (..))
+import Cardano.Ledger.Credential (Credential (..))
+import Cardano.Ledger.Val (Val (..))
+import Lens.Micro ((&), (.~))
+import Test.Cardano.Ledger.Conway.Arbitrary ()
+import Test.Cardano.Ledger.Conway.ImpTest
+import Test.Cardano.Ledger.Imp.Common
+
+spec ::
+  forall era.
+  ( ConwayEraImp era
+  , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era
+  ) =>
+  SpecWith (ImpTestState era)
+spec = do
+  describe "Withdrawals" $ do
+    it "Withdrawing from an unregistered reward account" $ do
+      modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
+
+      rwdAccount <- KeyHashObj <$> freshKeyHash >>= getRewardAccountFor
+      submitFailingTx
+        ( mkBasicTx $
+            mkBasicTxBody
+              & withdrawalsTxBodyL
+                .~ Withdrawals
+                  [(rwdAccount, Coin 20)]
+        )
+        [injectFailure $ WithdrawalsNotInRewardsCERTS [(rwdAccount, Coin 20)]]
+
+      (registeredRwdAccount, reward) <- setupRewardAccount
+      submitFailingTx
+        ( mkBasicTx $
+            mkBasicTxBody
+              & withdrawalsTxBodyL
+                .~ Withdrawals
+                  [(rwdAccount, zero), (registeredRwdAccount, reward)]
+        )
+        [injectFailure $ WithdrawalsNotInRewardsCERTS [(rwdAccount, zero)]]
+
+    it "Withdrawing the wrong amount" $ do
+      modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
+
+      (rwdAccount1, reward1) <- setupRewardAccount
+      (rwdAccount2, reward2) <- setupRewardAccount
+      submitFailingTx
+        ( mkBasicTx $
+            mkBasicTxBody
+              & withdrawalsTxBodyL
+                .~ Withdrawals
+                  [ (rwdAccount1, reward1 <+> Coin 1)
+                  , (rwdAccount2, reward2)
+                  ]
+        )
+        [injectFailure $ WithdrawalsNotInRewardsCERTS [(rwdAccount1, reward1 <+> Coin 1)]]
+
+      submitFailingTx
+        ( mkBasicTx $
+            mkBasicTxBody
+              & withdrawalsTxBodyL
+                .~ Withdrawals
+                  [(rwdAccount1, zero)]
+        )
+        [injectFailure $ WithdrawalsNotInRewardsCERTS [(rwdAccount1, zero)]]
+  where
+    setupRewardAccount = do
+      cred <- KeyHashObj <$> freshKeyHash
+      ra <- registerStakeCredential cred
+      submitAndExpireProposalToMakeReward cred
+      rw <- lookupReward cred
+      pure (ra, rw)

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

@@ -148,6 +148,7 @@ treasuryWithdrawalsSpec =
     it "Withdrawals exceeding treasury submitted in several proposals within the same epoch" $ do
       committeeCs <- registerInitialCommittee
       (drepC, _, _) <- setupSingleDRep 1_000_000
+      donateToTreasury $ Coin 5_000_000
       initialTreasury <- getTreasury
       numWithdrawals <- choose (1, 10)
       withdrawals <- genWithdrawalsExceeding initialTreasury numWithdrawals

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

@@ -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))
+import Cardano.Ledger.Credential (Credential (KeyHashObj), StakeCredential)
 import Cardano.Ledger.Plutus.CostModels (updateCostModels)
 import qualified Cardano.Ledger.Shelley.HardForks as HF
 import Cardano.Ledger.Shelley.LedgerState
@@ -31,8 +31,10 @@ 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
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromJust)
 import qualified Data.OMap.Strict as OMap
@@ -57,7 +59,7 @@ spec = do
   proposalsWithVotingSpec
   votingSpec
   policySpec
-  networkIdWithdrawalsSpec
+  withdrawalsSpec
   predicateFailuresSpec
   unknownCostModelsSpec
 
@@ -489,7 +491,17 @@ proposalsWithVotingSpec =
       returnAddr <- registerRewardAccount
       deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
       ens <- getEnactState
-      withdrawals <- arbitrary
+      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)
       let
         mkProp name action = do
           ProposalProcedure
@@ -1133,14 +1145,14 @@ networkIdSpec =
               Testnet
         ]
 
-networkIdWithdrawalsSpec ::
+withdrawalsSpec ::
   forall era.
   ( ConwayEraImp era
   , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
   ) =>
   SpecWith (ImpTestState era)
-networkIdWithdrawalsSpec =
-  describe "Network ID" $ do
+withdrawalsSpec =
+  describe "Withdrawals" $ do
     it "Fails with invalid network ID in withdrawal addresses" $ do
       rewardAccount <- registerRewardAccount
       rewardCredential <- KeyHashObj <$> freshKeyHash
@@ -1166,6 +1178,32 @@ networkIdWithdrawalsSpec =
               Testnet
         ]
 
+    it "Fails for empty withdrawals" $ do
+      rwdAccount1 <- freshKeyHash >>= getRewardAccountFor . KeyHashObj
+      rwdAccount2 <- freshKeyHash >>= getRewardAccountFor . KeyHashObj
+      let wdrl = TreasuryWithdrawals Map.empty SNothing
+       in submitFailingGovAction
+            wdrl
+            [injectFailure $ ZeroTreasuryWithdrawals wdrl]
+
+      let wdrl = TreasuryWithdrawals [(rwdAccount1, zero)] SNothing
+       in submitFailingGovAction
+            wdrl
+            [injectFailure $ ZeroTreasuryWithdrawals wdrl]
+
+      let wdrl = TreasuryWithdrawals [(rwdAccount1, zero), (rwdAccount2, zero)] SNothing
+       in submitFailingGovAction
+            wdrl
+            [injectFailure $ ZeroTreasuryWithdrawals wdrl]
+
+      rwdAccountRegistered <- registerRewardAccount
+      let wdrl = TreasuryWithdrawals [(rwdAccountRegistered, zero)] SNothing
+       in submitFailingGovAction
+            wdrl
+            [injectFailure $ ZeroTreasuryWithdrawals wdrl]
+
+      void $ submitTreasuryWithdrawals [(rwdAccount1, zero), (rwdAccount2, Coin 100000)]
+
 proposalWithRewardAccount ::
   forall era.
   ConwayEraImp era =>

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

@@ -16,6 +16,7 @@ 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 Data.Default.Class (def)
 import qualified Data.Set as Set
 import Lens.Micro ((&), (.~))
 import Test.Cardano.Ledger.Conway.ImpTest
@@ -73,6 +74,82 @@ spec = do
             .~ Withdrawals
               [(ra, if HF.bootstrapPhase pv then mempty else reward)]
 
+  it "Withdraw from a key delegated to an unregistered DRep" $ do
+    modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
+    kh <- freshKeyHash
+    let cred = KeyHashObj kh
+    ra <- registerStakeCredential cred
+    submitAndExpireProposalToMakeReward cred
+    reward <- lookupReward cred
+
+    (drep, _, _) <- setupSingleDRep 1_000_000
+
+    _ <- delegateToDRep cred (Coin 1_000_000) (DRepCredential drep)
+
+    unRegisterDRep drep
+    expectDRepNotRegistered drep
+
+    submitTx_ $
+      mkBasicTx $
+        mkBasicTxBody
+          & withdrawalsTxBodyL
+            .~ Withdrawals
+              [(ra, reward)]
+
+  it "Withdraw from a key delegated to an expired DRep" $ do
+    modifyPParams $ \pp ->
+      pp
+        & ppGovActionLifetimeL .~ EpochInterval 4
+        & ppDRepActivityL .~ EpochInterval 1
+    kh <- freshKeyHash
+    let cred = KeyHashObj kh
+    ra <- registerStakeCredential cred
+    submitAndExpireProposalToMakeReward cred
+    reward <- lookupReward cred
+
+    (drep, _, _) <- setupSingleDRep 1_000_000
+
+    -- expire the drep before delegation
+    void $ submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000)
+    passNEpochs 4
+    isDRepExpired drep `shouldReturn` True
+
+    _ <- delegateToDRep cred (Coin 1_000_000) (DRepCredential drep)
+
+    submitTx_ $
+      mkBasicTx $
+        mkBasicTxBody
+          & withdrawalsTxBodyL
+            .~ Withdrawals
+              [(ra, reward)]
+
+  it "Withdraw from a key delegated to a DRep that expired after delegation" $ do
+    modifyPParams $ \pp ->
+      pp
+        & ppGovActionLifetimeL .~ EpochInterval 4
+        & ppDRepActivityL .~ EpochInterval 1
+    kh <- freshKeyHash
+    let cred = KeyHashObj kh
+    ra <- registerStakeCredential cred
+    submitAndExpireProposalToMakeReward cred
+    reward <- lookupReward cred
+
+    (drep, _, _) <- setupSingleDRep 1_000_000
+
+    _ <- delegateToDRep cred (Coin 1_000_000) (DRepCredential drep)
+
+    -- expire the drep after  delegation
+    void $ submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000)
+    passNEpochs 4
+    isDRepExpired drep `shouldReturn` True
+
+    submitTx_ $
+      mkBasicTx $
+        mkBasicTxBody
+          & withdrawalsTxBodyL
+            .~ Withdrawals
+              [(ra, reward)]
+
   it "Withdraw from delegated and non-delegated staking script" $ do
     modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
     let scriptHash = hashPlutusScript $ alwaysSucceedsNoDatum SPlutusV3

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

@@ -807,6 +807,8 @@ votingSpec =
         it "AlwaysAbstain" $ do
           let getTreasury = getsNES (nesEsL . esAccountStateL . asTreasuryL)
 
+          donateToTreasury $ Coin 5_000_000
+
           (drep1, comMember, _) <- electBasicCommittee
           initialTreasury <- getTreasury
 

libs/cardano-ledger-api/cardano-ledger-api.cabal

@@ -112,7 +112,6 @@ test-suite cardano-ledger-api-test
         bytestring,
         cardano-ledger-api,
         cardano-ledger-byron,
-        data-default,
         data-default-class,
         testlib,
         cardano-crypto-class,

libs/cardano-ledger-api/test/Test/Cardano/Ledger/Api/State/Imp/QuerySpec.hs

@@ -32,7 +32,7 @@ import Cardano.Ledger.DRep
 import Cardano.Ledger.Keys (KeyRole (..))
 import qualified Cardano.Ledger.Shelley.HardForks as HF
 import Cardano.Ledger.Shelley.LedgerState
-import Data.Default (def)
+import Data.Default.Class (def)
 import Data.Foldable (Foldable (..))
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set