diff --git a/eras/conway/impl/CHANGELOG.md b/eras/conway/impl/CHANGELOG.md index 5543187af01..c1b9d06150f 100644 --- a/eras/conway/impl/CHANGELOG.md +++ b/eras/conway/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.20.0.0 +* Add `IncompleteWithdrawalsCERTS` to `ConwayPredFailure`. * Decoupled `ConwayEraTxCert` from `ShelleyEraTxCert`, so added `ShelleyEraTxCert` constraint to: * `DecCBOR ConwayTxCert` * `transTxCert` diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway.hs b/eras/conway/impl/src/Cardano/Ledger/Conway.hs index ee3302914f6..8cbd38f8f6d 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway.hs @@ -11,6 +11,7 @@ module Cardano.Ledger.Conway ( hardforkConwayBootstrapPhase, hardforkConwayDisallowUnelectedCommitteeFromVoting, hardforkConwayDELEGIncorrectDepositsAndRefunds, + hardforkConwayCERTSIncompleteWithdrawals, Tx (..), ) where @@ -19,6 +20,7 @@ import Cardano.Ledger.Conway.BlockBody () import Cardano.Ledger.Conway.Era ( ConwayEra, hardforkConwayBootstrapPhase, + hardforkConwayCERTSIncompleteWithdrawals, hardforkConwayDELEGIncorrectDepositsAndRefunds, hardforkConwayDisallowUnelectedCommitteeFromVoting, ) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs index d9b3ff06c64..c3a84c303be 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Era.hs @@ -29,6 +29,7 @@ module Cardano.Ledger.Conway.Era ( hardforkConwayBootstrapPhase, hardforkConwayDisallowUnelectedCommitteeFromVoting, hardforkConwayDELEGIncorrectDepositsAndRefunds, + hardforkConwayCERTSIncompleteWithdrawals, ) where import Cardano.Ledger.BaseTypes (ProtVer (pvMajor), natVersion) @@ -179,3 +180,7 @@ hardforkConwayDisallowUnelectedCommitteeFromVoting pv = pvMajor pv > natVersion -- | Starting with protocol version 11, we report incorrect deposit and refunds better hardforkConwayDELEGIncorrectDepositsAndRefunds :: ProtVer -> Bool hardforkConwayDELEGIncorrectDepositsAndRefunds pv = pvMajor pv > natVersion @10 + +-- | Starting with protocol version 11, we report incomplete withdrawals better +hardforkConwayCERTSIncompleteWithdrawals :: ProtVer -> Bool +hardforkConwayCERTSIncompleteWithdrawals pv = pvMajor pv > natVersion @10 diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs index 5b59fb86590..650441a14a3 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Certs.hs @@ -42,7 +42,12 @@ import Cardano.Ledger.Binary.Coders ( ( Show (CertsEnv era) instance (EraPParams era, NFData (Tx era)) => NFData (CertsEnv era) data ConwayCertsPredFailure era - = -- | Withdrawals that are missing or do not withdraw the entire amount + = -- | Withdrawals that are missing reward accounts. Before PV 11, this was + -- also wrongly used in place of IncompleteWithdrawalsCERTS for withdrawals + -- that didn't match the account balance exactly. WithdrawalsNotInRewardsCERTS Withdrawals | -- | CERT rule subtransition Failures CertFailure (PredicateFailure (EraRule "CERT" era)) + | -- | Withdrawals that do not withdraw the entire amount + IncompleteWithdrawalsCERTS Withdrawals deriving (Generic) type instance EraRuleFailure "CERTS" ConwayEra = ConwayCertsPredFailure ConwayEra @@ -161,6 +171,7 @@ instance encode . \case WithdrawalsNotInRewardsCERTS rs -> Sum (WithdrawalsNotInRewardsCERTS @era) 0 !> To rs CertFailure x -> Sum (CertFailure @era) 1 !> To x + IncompleteWithdrawalsCERTS ws -> Sum (IncompleteWithdrawalsCERTS @era) 2 !> To ws instance ( Era era @@ -171,6 +182,7 @@ instance decCBOR = decode $ Summands "ConwayGovPredFailure" $ \case 0 -> SumD WithdrawalsNotInRewardsCERTS SumD CertFailure SumD IncompleteWithdrawalsCERTS Invalid k instance @@ -252,12 +264,19 @@ conwayCertsTransition = do -- Final CertState with updates to DRep expiry based on new proposals and votes on existing proposals let certStateWithDRepExpiryUpdated = certState' & certVStateL . vsDRepsL %~ updateVSDReps dState = certStateWithDRepExpiryUpdated ^. certDStateL + accounts = dState ^. accountsL withdrawals = tx ^. bodyTxL . withdrawalsTxBodyL - -- Validate withdrawals and rewards and drain withdrawals - failOnJust - (withdrawalsThatDoNotDrainAccounts withdrawals network (dState ^. accountsL)) - WithdrawalsNotInRewardsCERTS + if hardforkConwayCERTSIncompleteWithdrawals (pp ^. ppProtocolVersionL) + then do + let (invalidWithdrawals, incompleteWithdrawals) = + invalidAndIncompleteWithdrawals withdrawals network accounts + null invalidWithdrawals ?! WithdrawalsNotInRewardsCERTS (Withdrawals invalidWithdrawals) + null incompleteWithdrawals ?! IncompleteWithdrawalsCERTS (Withdrawals incompleteWithdrawals) + else do + failOnJust + (withdrawalsThatDoNotDrainAccounts withdrawals network accounts) + WithdrawalsNotInRewardsCERTS pure $ certStateWithDRepExpiryUpdated & certDStateL . accountsL %~ drainAccounts withdrawals gamma :|> txCert -> do diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs index fa2912137d7..eeabcf54c58 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/CertsSpec.hs @@ -12,6 +12,7 @@ module Test.Cardano.Ledger.Conway.Imp.CertsSpec (spec) where import Cardano.Ledger.BaseTypes (EpochInterval (..)) import Cardano.Ledger.Coin (Coin (..)) +import Cardano.Ledger.Conway (hardforkConwayCERTSIncompleteWithdrawals) import Cardano.Ledger.Conway.Core import Cardano.Ledger.Conway.Rules (ConwayCertsPredFailure (..), ConwayLedgerPredFailure (..)) import Cardano.Ledger.Credential (Credential (..)) @@ -83,6 +84,7 @@ spec = do it "Withdrawing the wrong amount" $ do modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2 + pv <- getsPParams @era ppProtocolVersionL (rwdAccount1, reward1, _stakeKey1) <- setupRewardAccount (Coin 1_000_000) DRepAlwaysAbstain (rwdAccount2, reward2, _stakeKey2) <- setupRewardAccount (Coin 1_000_000) DRepAlwaysAbstain @@ -95,9 +97,12 @@ spec = do , (rwdAccount2, reward2) ] ) - [ injectFailure $ - WithdrawalsNotInRewardsCERTS $ - Withdrawals [(rwdAccount1, reward1 <+> Coin 1)] + [ injectFailure + $ ( if hardforkConwayCERTSIncompleteWithdrawals pv + then IncompleteWithdrawalsCERTS @era + else WithdrawalsNotInRewardsCERTS @era + ) + $ Withdrawals [(rwdAccount1, reward1 <+> Coin 1)] ] submitFailingTx @@ -107,7 +112,13 @@ spec = do .~ Withdrawals [(rwdAccount1, zero)] ) - [injectFailure $ WithdrawalsNotInRewardsCERTS $ Withdrawals [(rwdAccount1, zero)]] + [ injectFailure + $ ( if hardforkConwayCERTSIncompleteWithdrawals pv + then IncompleteWithdrawalsCERTS @era + else WithdrawalsNotInRewardsCERTS @era + ) + $ Withdrawals [(rwdAccount1, zero)] + ] where setupRewardAccount stake dRep = do kh <- freshKeyHash diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/State/Account.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/State/Account.hs index c13224baf02..2103444c332 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/Account.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/Account.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} @@ -24,6 +25,7 @@ module Cardano.Ledger.State.Account ( withdrawalsThatDoNotDrainAccounts, drainAccounts, removeStakePoolDelegations, + invalidAndIncompleteWithdrawals, ) where import Cardano.Ledger.Address (RewardAccount (..), Withdrawals (..)) @@ -36,6 +38,7 @@ import Cardano.Ledger.Credential import Control.DeepSeq (NFData) import Control.Exception (assert) import Data.Aeson (ToJSON) +import Data.Bifunctor (Bifunctor (..)) import Data.Default (Default) import Data.Foldable (foldMap') import Data.Kind (Type) @@ -175,6 +178,42 @@ lookupStakePoolDelegation cred accounts = lookupAccountState cred accounts >>= (^. stakePoolDelegationAccountStateL) +-- | This function returns a 2-tuple where the `fst` is withdrawals with missing +-- reward accounts or wrong network, and `snd` is incomplete withdrawals. +invalidAndIncompleteWithdrawals :: + EraAccounts era => + Withdrawals -> + Network -> + Accounts era -> + (Map RewardAccount Coin, Map RewardAccount Coin) +invalidAndIncompleteWithdrawals (Withdrawals givenWithdrawals) networkId accounts = do + -- @givenWithdrawals@ is small and @accounts@ is big, better to traverse the + -- former than the latter. + Map.foldrWithKey collectBadWithdrawals (mempty, mempty) givenWithdrawals + where + -- invalid withdrawal = that which does not have a reward account or is in + -- the wrong network. + -- incomplete withdrawal = that which does not withdraw the exact account + -- balance. + collectBadWithdrawals :: + RewardAccount -> + Coin -> + (Map RewardAccount Coin, Map RewardAccount Coin) -> + (Map RewardAccount Coin, Map RewardAccount Coin) + collectBadWithdrawals + ra@RewardAccount {raCredential, raNetwork} + withdrawalAmount + accum@(!_, !_) = + case Map.lookup raCredential (accounts ^. accountsMapL) of + Nothing -> + first (Map.insert ra withdrawalAmount) accum + Just accountState + | raNetwork /= networkId -> + first (Map.insert ra withdrawalAmount) accum + | fromCompact (accountState ^. balanceAccountStateL) /= withdrawalAmount -> + second (Map.insert ra withdrawalAmount) accum + | otherwise -> accum + -- | This function returns `Nothing` iff all of the accounts that withdrawals are trying to drain are -- indeed registered and all of the amounts in the withdrawals match the respective balances exactly. withdrawalsThatDoNotDrainAccounts ::