ConwayCERTS: Predicate failure for incomplete withdrawals

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`

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,
  )

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

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

@@ -42,7 +42,12 @@ import Cardano.Ledger.Binary.Coders (
   (<!),
  )
 import Cardano.Ledger.Conway.Core
-import Cardano.Ledger.Conway.Era (ConwayCERT, ConwayCERTS, ConwayEra)
+import Cardano.Ledger.Conway.Era (
+  ConwayCERT,
+  ConwayCERTS,
+  ConwayEra,
+  hardforkConwayCERTSIncompleteWithdrawals,
+ )
 import Cardano.Ledger.Conway.Governance (
   Committee,
   GovActionPurpose (..),
@@ -68,6 +73,7 @@ import Control.State.Transition.Extended (
   judgmentContext,
   liftSTS,
   trans,
+  (?!),
  )
 import qualified Data.Map.Strict as Map
 import qualified Data.OSet.Strict as OSet
@@ -104,10 +110,14 @@ deriving instance (EraPParams era, Show (Tx era)) => 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 <! From
     1 -> SumD CertFailure <! From
+    2 -> SumD IncompleteWithdrawalsCERTS <! From
     k -> 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

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

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 ::