Apply enacted treasury withdrawals. (#3748)

Also, add lenses ensWithdrawalsL, ensTreasuryL and epochStateTreasuryL.

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.9.0.0
 
+* Apply enacted `TreasuryWithdrawals` in `ConwayEPOCH` #3748
+  * Add lenses `ensWithdrawalsL` and `ensTreasuryL`
 * Add PredicateFailure for current treasury value mismatch in tx body in LEDGER #3749
 * Change `To/FromJSON` format for `ConwayGenesis`
 * Add `EraTransition` instance and `toConwayTransitionConfigPairs`.

eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs

@@ -65,6 +65,8 @@ module Cardano.Ledger.Conway.Governance (
   ensConstitutionL,
   ensCurPParamsL,
   ensPrevPParamsL,
+  ensWithdrawalsL,
+  ensTreasuryL,
   ensPrevGovActionIdsL,
   ensPrevPParamUpdateL,
   ensPrevHardForkL,
@@ -373,6 +375,12 @@ ensCurPParamsL = lens ensPParams (\es x -> es {ensPParams = x})
 ensPrevPParamsL :: Lens' (EnactState era) (PParams era)
 ensPrevPParamsL = lens ensPrevPParams (\es x -> es {ensPrevPParams = x})
 
+ensTreasuryL :: Lens' (EnactState era) Coin
+ensTreasuryL = lens ensTreasury $ \es x -> es {ensTreasury = x}
+
+ensWithdrawalsL :: Lens' (EnactState era) (Map (Credential 'Staking (EraCrypto era)) Coin)
+ensWithdrawalsL = lens ensWithdrawals $ \es x -> es {ensWithdrawals = x}
+
 ensPrevGovActionIdsL :: Lens' (EnactState era) (PrevGovActionIds era)
 ensPrevGovActionIdsL = lens ensPrevGovActionIds (\es x -> es {ensPrevGovActionIds = x})
 

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

@@ -33,21 +33,24 @@ import Cardano.Ledger.CertState (
   vsDRepsL,
   vsNumDormantEpochsL,
  )
-import Cardano.Ledger.Coin (Coin)
+import Cardano.Ledger.Coin (Coin, compactCoinOrError)
 import Cardano.Ledger.Compactible (Compactible (..))
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Era (ConwayEPOCH, ConwayRATIFY)
 import Cardano.Ledger.Conway.Governance (
   Committee,
   ConwayEraGov,
   ConwayGovState (..),
+  EnactState,
   GovActionState (..),
   GovSnapshots (..),
   RatifyState (..),
   cgEnactStateL,
   cgGovSnapshotsL,
   curGovSnapshotsL,
   ensCommitteeL,
+  ensTreasuryL,
+  ensWithdrawalsL,
   epochStateDRepDistrL,
   prevGovSnapshotsL,
   snapshotActions,
@@ -68,6 +71,8 @@ import Cardano.Ledger.Shelley.LedgerState (
   UTxOState (..),
   asTreasuryL,
   curPParamsEpochStateL,
+  epochStateTreasuryL,
+  epochStateUMapL,
   esAccountState,
   esAccountStateL,
   esLState,
@@ -99,7 +104,8 @@ import Cardano.Ledger.Shelley.Rules (
  )
 import qualified Cardano.Ledger.Shelley.Rules as Shelley
 import Cardano.Ledger.Slot (EpochNo)
-import Cardano.Ledger.UMap (UMap, UView (..), unionKeyDeposits)
+import Cardano.Ledger.UMap (UMap, UView (..), unionKeyDeposits, (∪+), (◁))
+import Cardano.Ledger.Val ((<->))
 import Control.SetAlgebra (eval, (⨃))
 import Control.State.Transition (
   Embed (..),
@@ -187,6 +193,33 @@ updateNumDormantEpochs ls =
         then ls & lsCertStateL . certVStateL . vsNumDormantEpochsL +~ 1
         else ls
 
+-- | Apply TreasuryWithdrawals to the EpochState
+--
+--   acnt' = record acnt { treasury = treasury + UTxOState.fees utxoSt
+--                                  + getCoin unclaimed + donations ∸ totWithdrawals }
+--
+-- The utxo fees and donations are applied in the remaining body of EPOCH transition
+applyEnactedWithdrawals :: EpochState era -> EnactState era -> (EpochState era, EnactState era)
+applyEnactedWithdrawals epochState enactedState =
+  let enactedWithdrawals = enactedState ^. ensWithdrawalsL
+      rewardsUView = RewDepUView $ epochState ^. epochStateUMapL
+      successfulRefunds = rewardsUView ◁ enactedWithdrawals
+      epochStateRewardsApplied =
+        epochState
+          -- Subtract `successfulRefunds` from the treasury, and add them to the rewards UMap
+          -- `unclaimed` refunds remain in the treasury.
+          -- Compared to the spec, instead of adding `unclaimed` and subtracting `totWithdrawals`
+          --   + unclaimed - totWithdrawals
+          -- we just subtract the `refunds`
+          --   - refunds
+          & epochStateTreasuryL %~ (<-> fold successfulRefunds)
+          -- The use of the partial function `compactCoinOrError` is justified here because
+          -- 1. the decoder for coin at the proposal-submission boundary has already confirmed we have a compactible value
+          -- 2. the refunds and unsuccessful refunds together do not exceed the current treasury value, as enforced by the `ENACT` rule.
+          & epochStateUMapL .~ (rewardsUView ∪+ (compactCoinOrError <$> successfulRefunds))
+      enactedStateWithdrawalsReset = enactedState & ensWithdrawalsL .~ Map.empty -- reset enacted withdrawals
+   in (epochStateRewardsApplied, enactedStateWithdrawalsReset)
+
 epochTransition ::
   forall era.
   ( Embed (EraRule "SNAP" era) (ConwayEPOCH era)
@@ -268,18 +301,19 @@ epochTransition = do
         , reDRepState = vstate ^. vsDRepsL
         }
     ratSig = RatifySignal . snapshotActions . prevGovSnapshots $ cgGovSnapshots govSt
-  RatifyState {rsRemoved, rsEnactState} <-
+  RatifyState {rsRemoved, rsEnactState = rsEnactState'} <-
     trans @(EraRule "RATIFY" era) $
       TRC
         ( ratEnv
         , RatifyState
             { rsRemoved = mempty
-            , rsEnactState = govSt ^. cgEnactStateL
+            , rsEnactState = (govSt ^. cgEnactStateL) & ensTreasuryL .~ (es' ^. epochStateTreasuryL)
             , rsDelayed = False
             }
         , ratSig
         )
   let
+    (epochState', rsEnactState) = applyEnactedWithdrawals es' rsEnactState'
     curSnaps = curGovSnapshots $ cgGovSnapshots govSt
     lookupAction m gId =
       case snapshotLookupId gId curSnaps of
@@ -288,11 +322,10 @@ epochTransition = do
     removedProps =
       foldl' lookupAction mempty $
         Seq.fromList (Set.toList rsRemoved)
-    lState = returnProposalDeposits removedProps $ esLState es'
+    lState = returnProposalDeposits removedProps $ esLState epochState'
     es'' =
-      es'
-        { esAccountState = acnt'
-        , esLState = lState {lsUTxOState = utxoSt''}
+      epochState'
+        { esLState = lState {lsUTxOState = utxoSt''}
         }
         & prevPParamsEpochStateL .~ pp
         & curPParamsEpochStateL .~ pp

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

@@ -36,6 +36,8 @@ import Cardano.Ledger.Conway.Governance (
   PrevGovActionIds (..),
   RatifyState (..),
   Vote (..),
+  ensTreasuryL,
+  rsEnactStateL,
   votingDRepThreshold,
   votingStakePoolThreshold,
  )
@@ -71,7 +73,7 @@ import qualified Data.Sequence.Strict as Seq
 import qualified Data.Set as Set
 import Data.Void (Void, absurd)
 import Data.Word (Word64)
-import Lens.Micro ((^.))
+import Lens.Micro ((&), (.~), (^.))
 
 data RatifyEnv era = RatifyEnv
   { reStakeDistr :: !(Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin))
@@ -280,7 +282,7 @@ ratifyTransition = do
           if gasExpiresAfter < reCurrentEpoch
             then pure st' {rsRemoved = Set.insert gasId rsRemoved} -- Action expires after current Epoch. Remove it.
             else pure st'
-    Empty -> pure st
+    Empty -> pure $ st & rsEnactStateL . ensTreasuryL .~ Coin 0
 
 -- | Check that the previous governance action id specified in the proposal
 --   does match the last one of the same purpose that was enacted.

eras/shelley/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.6.1.0
 
+* Add lens `epochStateTreasuryL` #3748
 * Introduce `Cardano.Ledger.Shelley.Transition` module with `EraTransition` interface.
 * Deprecated `CanStartFromGenesis` interface in favor of `EraTransition`
 * Add `Semigroup` and `Monoid` instances for `ShelleyGenesisStaking`

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

@@ -120,6 +120,7 @@ module Cardano.Ledger.Shelley.LedgerState (
   epochStateRegDrepL,
   epochStateIncrStakeDistrL,
   newEpochStateGovStateL,
+  epochStateTreasuryL,
 
   -- * Lenses from CertState
   certDStateL,

eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs

@@ -713,6 +713,9 @@ ptrMapL = lens ptrMap (\x y -> x {ptrMap = y})
 newEpochStateGovStateL :: Lens' (NewEpochState era) (GovState era)
 newEpochStateGovStateL = nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL
 
+epochStateTreasuryL :: Lens' (EpochState era) Coin
+epochStateTreasuryL = esAccountStateL . asTreasuryL
+
 epochStateIncrStakeDistrL ::
   Lens'
     (EpochState era)

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs

@@ -21,7 +21,7 @@ import Cardano.Ledger.BaseTypes (BlocksMade (..), EpochNo, Network (..), ProtVer
 import qualified Cardano.Ledger.BaseTypes as Base (Globals (..))
 import Cardano.Ledger.CertState (CommitteeState (..), csCommitteeCredsL, vsNumDormantEpochsL)
 import Cardano.Ledger.Coin (Coin (..), DeltaCoin)
-import Cardano.Ledger.Conway.Governance hiding (GovState)
+import Cardano.Ledger.Conway.Governance hiding (GovState, ensTreasuryL, ensWithdrawalsL)
 import Cardano.Ledger.Core (
   EraPParams,
   PParams,