wip

Author: aniketd

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Delegs.hs

@@ -7,7 +7,6 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
@@ -31,7 +30,6 @@ import Cardano.Ledger.BaseTypes (
   ShelleyBase,
   TxIx (..),
   invalidKey,
-  networkId,
  )
 import Cardano.Ledger.Binary (
   DecCBOR (..),
@@ -55,16 +53,13 @@ import Cardano.Ledger.Shelley.Rules.Pool (ShelleyPoolPredFailure)
 import Cardano.Ledger.Shelley.State
 import Cardano.Ledger.Slot (SlotNo (..))
 import Control.DeepSeq
-import Control.Monad.Trans.Reader (asks)
 import Control.SetAlgebra (dom, eval, (∈))
 import Control.State.Transition (
   Embed (..),
   STS (..),
   TRC (..),
   TransitionRule,
-  failOnJust,
   judgmentContext,
-  liftSTS,
   trans,
   validateTrans,
  )
@@ -217,21 +212,10 @@ delegsTransition ::
   TransitionRule (ShelleyDELEGS era)
 delegsTransition = do
   TRC
-    (env@(DelegsEnv slot@(SlotNo slot64) epochNo txIx pp tx chainAccountState), certState, certificates) <-
+    (env@(DelegsEnv slot@(SlotNo slot64) epochNo txIx pp _tx chainAccountState), certState, certificates) <-
     judgmentContext
-  network <- liftSTS $ asks networkId
-
   case certificates of
-    Empty -> do
-      let dState = certState ^. certDStateL
-          withdrawals = tx ^. bodyTxL . withdrawalsTxBodyL
-          accounts = dState ^. accountsL
-      failOnJust
-        (withdrawalsThatDoNotDrainAccounts withdrawals network accounts)
-        ( \(invalid, incomplete) ->
-            WithdrawalsNotInRewardsDELEGS $ Withdrawals $ unWithdrawals invalid <> unWithdrawals incomplete
-        )
-      pure $ certState & certDStateL . accountsL %~ drainAccounts withdrawals
+    Empty -> pure certState
     gamma :|> txCert -> do
       certState' <-
         trans @(ShelleyDELEGS era) $ TRC (env, certState, gamma)

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ledger.hs

@@ -33,14 +33,15 @@ module Cardano.Ledger.Shelley.Rules.Ledger (
   shelleyLedgerAssertions,
 ) where
 
-import Cardano.Ledger.BaseTypes (ShelleyBase, TxIx, invalidKey)
+import Cardano.Ledger.BaseTypes (ShelleyBase, TxIx, invalidKey, networkId)
 import Cardano.Ledger.Binary (
   DecCBOR (..),
   EncCBOR (..),
   decodeRecordSum,
   encodeListLen,
  )
 import Cardano.Ledger.Binary.Coders (Encode (..), encode, (!>))
+import Control.Monad.Trans.Reader (asks)
 import Cardano.Ledger.Shelley.AdaPots (consumedTxBody, producedTxBody)
 import Cardano.Ledger.Shelley.Core
 import Cardano.Ledger.Shelley.Era (ShelleyEra, ShelleyLEDGER)
@@ -65,7 +66,7 @@ import Cardano.Ledger.Shelley.Rules.Reports (showTxCerts)
 import Cardano.Ledger.Shelley.Rules.Utxo (ShelleyUtxoPredFailure (..), UtxoEnv (..))
 import Cardano.Ledger.Shelley.Rules.Utxow (ShelleyUTXOW, ShelleyUtxowPredFailure)
 import Cardano.Ledger.Slot (EpochNo (..), SlotNo, epochFromSlot)
-import Cardano.Ledger.State (EraCertState (..))
+import Cardano.Ledger.State (EraCertState (..), withdrawalsThatDoNotDrainAccounts, accountsL, drainAccounts)
 import Control.DeepSeq (NFData (..))
 import Control.State.Transition (
   Assertion (PostCondition),
@@ -77,6 +78,7 @@ import Control.State.Transition (
   judgmentContext,
   liftSTS,
   trans,
+  failOnJust,
  )
 import Data.Sequence (Seq)
 import qualified Data.Sequence.Strict as StrictSeq
@@ -116,6 +118,8 @@ instance EraPParams era => EncCBOR (LedgerEnv era) where
 data ShelleyLedgerPredFailure era
   = UtxowFailure (PredicateFailure (EraRule "UTXOW" era)) -- Subtransition Failures
   | DelegsFailure (PredicateFailure (EraRule "DELEGS" era)) -- Subtransition Failures
+  | ShelleyWithdrawalsMissingAccounts Withdrawals
+  | ShelleyIncompleteWithdrawals Withdrawals
   deriving (Generic)
 
 ledgerSlotNoL :: Lens' (LedgerEnv era) SlotNo
@@ -213,8 +217,10 @@ instance
   EncCBOR (ShelleyLedgerPredFailure era)
   where
   encCBOR = \case
-    (UtxowFailure a) -> encodeListLen 2 <> encCBOR (0 :: Word8) <> encCBOR a
-    (DelegsFailure a) -> encodeListLen 2 <> encCBOR (1 :: Word8) <> encCBOR a
+    UtxowFailure a -> encodeListLen 2 <> encCBOR (0 :: Word8) <> encCBOR a
+    DelegsFailure a -> encodeListLen 2 <> encCBOR (1 :: Word8) <> encCBOR a
+    ShelleyWithdrawalsMissingAccounts w -> encodeListLen 2 <> encCBOR (2 :: Word8) <> encCBOR w
+    ShelleyIncompleteWithdrawals w -> encodeListLen 2 <> encCBOR (3 :: Word8) <> encCBOR w
 
 instance
   ( DecCBOR (PredicateFailure (EraRule "DELEGS" era))
@@ -232,6 +238,12 @@ instance
         1 -> do
           a <- decCBOR
           pure (2, DelegsFailure a)
+        2 -> do
+          w <- decCBOR
+          pure (2, ShelleyWithdrawalsMissingAccounts w)
+        3 -> do
+          w <- decCBOR
+          pure (2, ShelleyIncompleteWithdrawals w)
         k -> invalidKey k
 
 shelleyLedgerAssertions ::
@@ -281,6 +293,7 @@ instance
 ledgerTransition ::
   forall era.
   ( EraTx era
+  , EraCertState era
   , STS (ShelleyLEDGER era)
   , Embed (EraRule "DELEGS" era) (ShelleyLEDGER era)
   , Environment (EraRule "DELEGS" era) ~ DelegsEnv era
@@ -296,11 +309,22 @@ ledgerTransition = do
   TRC (LedgerEnv slot mbCurEpochNo txIx pp account, LedgerState utxoSt certState, tx) <-
     judgmentContext
   curEpochNo <- maybe (liftSTS $ epochFromSlot slot) pure mbCurEpochNo
+  network <- liftSTS $ asks networkId
+  let withdrawals = tx ^. bodyTxL . withdrawalsTxBodyL
+      (invalidWithdrawals, incompleteWithdrawals) =
+        case withdrawalsThatDoNotDrainAccounts withdrawals network $ certState ^. certDStateL . accountsL of
+          Nothing -> (Nothing, Nothing)
+          Just (invalid, incomplete) ->
+            ( if null (unWithdrawals invalid) then Nothing else Just invalid
+            , if null (unWithdrawals incomplete) then Nothing else Just incomplete
+            )
+  failOnJust invalidWithdrawals ShelleyWithdrawalsMissingAccounts
+  failOnJust incompleteWithdrawals ShelleyIncompleteWithdrawals
   certState' <-
     trans @(EraRule "DELEGS" era) $
       TRC
         ( DelegsEnv slot curEpochNo txIx pp tx account
-        , certState
+        , certState & certDStateL . accountsL %~ drainAccounts withdrawals
         , StrictSeq.fromStrict $ tx ^. bodyTxL . certsTxBodyL
         )