Add proposal deposits to DRep active voting stake.

Also add imptests.

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
@@ -7,7 +8,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
@@ -38,6 +38,7 @@ module Cardano.Ledger.Conway.Governance.DRepPulser (
   RunConwayRatify (..),
 ) where
 
+import Cardano.Ledger.Address
 import Cardano.Ledger.BaseTypes (EpochNo (..), Globals (..))
 import Cardano.Ledger.Binary (
   DecCBOR (..),
@@ -58,7 +59,7 @@ import Cardano.Ledger.CertState (CommitteeState)
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.Era (ConwayRATIFY)
 import Cardano.Ledger.Conway.Governance.Internal
-import Cardano.Ledger.Conway.Governance.Procedures (GovActionState)
+import Cardano.Ledger.Conway.Governance.Procedures (GovActionState, gasDepositL, gasReturnAddrL)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep (DRep (..), DRepState (..))
@@ -71,7 +72,7 @@ import Control.Monad.Trans.Reader (Reader, runReader)
 import Control.State.Transition.Extended
 import Data.Aeson (KeyValue, ToJSON (..), object, pairs, (.=))
 import Data.Default.Class (Default (..))
-import Data.Foldable (toList)
+import Data.Foldable (foldl', toList)
 import Data.Functor.Identity (Identity)
 import Data.Kind (Type)
 import Data.Map.Strict (Map)
@@ -173,25 +174,42 @@ instance EraPParams era => FromCBOR (PulsingSnapshot era) where
 --   (b) is the size of the StakeDistr, and
 --   (c) is the size of the DRepDistr, this grows as the accumulator
 computeDRepDistr ::
-  forall c.
-  Map (Credential 'Staking c) (CompactForm Coin) ->
-  Map (Credential 'DRepRole c) (DRepState c) ->
-  Map (DRep c) (CompactForm Coin) ->
-  Map (Credential 'Staking c) (UMElem c) ->
-  Map (DRep c) (CompactForm Coin)
-computeDRepDistr stakeDistr regDReps dRepDistr uMapChunk =
+  forall era.
+  Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin) ->
+  Map (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)) ->
+  StrictSeq (GovActionState era) ->
+  Map (DRep (EraCrypto era)) (CompactForm Coin) ->
+  Map (Credential 'Staking (EraCrypto era)) (UMElem (EraCrypto era)) ->
+  Map (DRep (EraCrypto era)) (CompactForm Coin)
+computeDRepDistr stakeDistr regDReps gass dRepDistr uMapChunk =
   Map.foldlWithKey' go dRepDistr uMapChunk
   where
+    -- QUESTION: Can I memoize this as a field in DRepPulsar? That causes a
+    -- type-error, though that does _not_ get resolved even with AllowAmbiguousTypes
+    -- as `EraCrypto era` is a non-injective type-family
+    proposalDeposits =
+      foldl'
+        ( \gasMap gas ->
+            Map.insertWith
+              addCompact
+              (gas ^. gasReturnAddrL . rewardAccountCredentialL)
+              (fromMaybe (CompactCoin 0) $ toCompact $ gas ^. gasDepositL)
+              gasMap
+        )
+        mempty
+        gass
     go accum stakeCred umElem =
       let stake = fromMaybe (CompactCoin 0) $ Map.lookup stakeCred stakeDistr
+          proposalDeposit = fromMaybe (CompactCoin 0) $ Map.lookup stakeCred proposalDeposits
+          stakeAndDeposits = addCompact stake proposalDeposit
        in case umElemDRepDelegatedReward umElem of
             Just (r, drep@DRepAlwaysAbstain) ->
-              Map.insertWith addCompact drep (addCompact stake r) accum
+              Map.insertWith addCompact drep (addCompact stakeAndDeposits r) accum
             Just (r, drep@DRepAlwaysNoConfidence) ->
-              Map.insertWith addCompact drep (addCompact stake r) accum
+              Map.insertWith addCompact drep (addCompact stakeAndDeposits r) accum
             Just (r, drep@(DRepCredential drepCred))
               | Map.member drepCred regDReps ->
-                  Map.insertWith addCompact drep (addCompact stake r) accum
+                  Map.insertWith addCompact drep (addCompact stakeAndDeposits r) accum
               | otherwise -> accum
             Nothing -> accum
 
@@ -244,7 +262,7 @@ instance Pulsable (DRepPulser era) where
     | done pulser = pure pulser {dpIndex = 0}
     | otherwise =
         let !chunk = Map.take dpPulseSize $ Map.drop dpIndex $ UMap.umElems dpUMap
-            dRepDistr = computeDRepDistr dpStakeDistr dpDRepState dpDRepDistr chunk
+            dRepDistr = computeDRepDistr dpStakeDistr dpDRepState dpProposals dpDRepDistr chunk
          in pure (pulser {dpIndex = dpIndex + dpPulseSize, dpDRepDistr = dRepDistr})
 
   completeM x@(DRepPulser {}) = pure (snd $ finishDRepPulser @era (DRPulsing x))
@@ -298,20 +316,31 @@ class
   runConwayRatify globals ratifyEnv ratifyState (RatifySignal ratifySig) =
     let ratifyResult =
           runReader
-            ( applySTS @(ConwayRATIFY era) (TRC (ratifyEnv, ratifyState, RatifySignal $ reorderActions ratifySig))
+            ( applySTS @(ConwayRATIFY era) $
+                TRC (ratifyEnv, ratifyState, RatifySignal $ reorderActions ratifySig)
             )
             globals
      in case ratifyResult of
           Left ps ->
-            error (unlines ("Impossible: RATIFY rule never fails, but it did:" : map show (toList ps)))
+            error $
+              unlines $
+                "Impossible: RATIFY rule never fails, but it did:"
+                  : map show (toList ps)
           Right ratifyState' -> ratifyState'
 
 finishDRepPulser :: DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
 finishDRepPulser (DRComplete snap ratifyState) = (snap, ratifyState)
 finishDRepPulser (DRPulsing (DRepPulser {..})) =
   (PulsingSnapshot dpProposals finalDRepDistr dpDRepState, ratifyState')
   where
-    !finalDRepDistr = computeDRepDistr dpStakeDistr dpDRepState dpDRepDistr $ Map.drop dpIndex $ umElems dpUMap
+    !finalDRepDistr =
+      computeDRepDistr
+        dpStakeDistr
+        dpDRepState
+        dpProposals
+        dpDRepDistr
+        $ Map.drop dpIndex
+        $ umElems dpUMap
     !ratifyEnv =
       RatifyEnv
         { reStakeDistr = dpStakeDistr

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

@@ -16,7 +16,9 @@ import Cardano.Ledger.Coin
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Governance
 import Cardano.Ledger.Conway.PParams
+import Cardano.Ledger.Conway.TxCert
 import Cardano.Ledger.Credential
+import Cardano.Ledger.DRep
 import Cardano.Ledger.Keys
 import Cardano.Ledger.Shelley.LedgerState
 import qualified Cardano.Ledger.UMap as UM
@@ -25,6 +27,7 @@ import Data.Default.Class (def)
 import Data.Foldable
 import Data.List.NonEmpty (NonEmpty (..))
 import qualified Data.Map.Strict as Map
+import qualified Data.Sequence.Strict as SSeq
 import qualified Data.Set as Set
 import Lens.Micro
 import Test.Cardano.Ledger.Conway.ImpTest
@@ -624,6 +627,117 @@ votingSpec =
           -- The same vote should now successfully ratify the proposal
           passEpoch
           getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
+        describe "Proposal deposits contribute to active voting stake" $ do
+          it "Directly" $ do
+            -- Only modify the applicable thresholds
+            modifyPParams $ \pp ->
+              pp
+                & ppDRepVotingThresholdsL
+                  .~ def
+                    { dvtCommitteeNormal = 51 %! 100
+                    , dvtCommitteeNoConfidence = 51 %! 100
+                    }
+                & ppCommitteeMaxTermLengthL .~ EpochInterval 20
+                & ppGovActionDepositL .~ Coin 600_000
+            -- Setup DRep delegation without stake #1
+            (drepKH1, stakingKH1) <- setupDRepWithoutStake
+            -- Setup DRep delegation #2
+            (_drepKH2, _stakingKH2, _paymentKP2) <- setupSingleDRep 1_000_000
+            -- Make a note of the reward account for the delegator to DRep #1
+            dRepRewardAccount <- getRewardAccountFor $ KeyHashObj stakingKH1
+            -- Submit the first committee proposal, the one we will test active voting stake against.
+            -- The proposal deposit comes from the root UTxO
+            cc <- KeyHashObj <$> freshKeyHash
+            let addCCAction = UpdateCommittee SNothing mempty (Map.singleton cc 10) (75 %! 100)
+            addCCGaid <-
+              submitProposal $
+                ProposalProcedure
+                  { pProcDeposit = Coin 600_000
+                  , pProcReturnAddr = dRepRewardAccount
+                  , pProcGovAction = addCCAction
+                  , pProcAnchor = def
+                  }
+            -- Submit the vote from DRep #1
+            submitVote_ VoteYes (DRepVoter $ KeyHashObj drepKH1) addCCGaid
+            passNEpochs 2
+            -- The vote should not result in a ratification
+            isDRepAccepted addCCGaid `shouldReturn` False
+            getLastEnactedCommittee `shouldReturn` SNothing
+            -- Submit another proposal to bump up the active voting stake
+            anotherCC <- KeyHashObj <$> freshKeyHash
+            let anotherAddCCAction = UpdateCommittee SNothing mempty (Map.singleton anotherCC 10) (75 %! 100)
+            _anotherAddCCGaid <-
+              submitProposal $
+                ProposalProcedure
+                  { pProcDeposit = Coin 600_000
+                  , pProcReturnAddr = dRepRewardAccount
+                  , pProcGovAction = anotherAddCCAction
+                  , pProcAnchor = def
+                  }
+            passNEpochs 2
+            -- The same vote should now successfully ratify the proposal
+            getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
+          it "After switching delegations" $ do
+            -- Only modify the applicable thresholds
+            modifyPParams $ \pp ->
+              pp
+                & ppDRepVotingThresholdsL
+                  .~ def
+                    { dvtCommitteeNormal = 51 %! 100
+                    , dvtCommitteeNoConfidence = 51 %! 100
+                    }
+                & ppCommitteeMaxTermLengthL .~ EpochInterval 20
+                & ppGovActionDepositL .~ Coin 1_000_000
+            -- Setup DRep delegation without stake #1
+            (drepKH1, stakingKH1) <- setupDRepWithoutStake
+            -- Setup DRep delegation #2
+            (_drepKH2, _stakingKH2, _paymentKP2) <- setupSingleDRep 1_000_000
+            -- Setup DRep delegation #3
+            (_drepKH3, stakingKH3) <- setupDRepWithoutStake
+            -- Make a note of the reward accounts for the delegators to DReps #1 and #3
+            dRepRewardAccount1 <- getRewardAccountFor $ KeyHashObj stakingKH1
+            dRepRewardAccount3 <- getRewardAccountFor $ KeyHashObj stakingKH3
+            -- Submit committee proposals
+            -- The proposal deposits comes from the root UTxO
+            -- After this both stakingKH1 and stakingKH3 are expected to have 1_000_000 ADA of stake, each
+            cc <- KeyHashObj <$> freshKeyHash
+            let addCCAction = UpdateCommittee SNothing mempty (Map.singleton cc 10) (75 %! 100)
+            addCCGaid <-
+              submitProposal $
+                ProposalProcedure
+                  { pProcDeposit = Coin 1_000_000
+                  , pProcReturnAddr = dRepRewardAccount1
+                  , pProcGovAction = addCCAction
+                  , pProcAnchor = def
+                  }
+            anotherCC <- KeyHashObj <$> freshKeyHash
+            let anotherAddCCAction = UpdateCommittee SNothing mempty (Map.singleton anotherCC 10) (75 %! 100)
+            _anotherAddCCGaid <-
+              submitProposal $
+                ProposalProcedure
+                  { pProcDeposit = Coin 1_000_000
+                  , pProcReturnAddr = dRepRewardAccount3
+                  , pProcGovAction = anotherAddCCAction
+                  , pProcAnchor = def
+                  }
+            -- Submit the vote from DRep #1
+            submitVote_ VoteYes (DRepVoter $ KeyHashObj drepKH1) addCCGaid
+            passNEpochs 2
+            -- The vote should not result in a ratification
+            isDRepAccepted addCCGaid `shouldReturn` False
+            getLastEnactedCommittee `shouldReturn` SNothing
+            -- Switch the delegation from DRep #3 to DRep #1
+            submitTxAnn_ "Switch the delegation from DRep #3 to DRep #1" $
+              mkBasicTx mkBasicTxBody
+                & bodyTxL . certsTxBodyL
+                  .~ SSeq.fromList
+                    [ mkDelegTxCert
+                        (KeyHashObj stakingKH3)
+                        (DelegVote (DRepCredential $ KeyHashObj drepKH1))
+                    ]
+            passNEpochs 2
+            -- The same vote should now successfully ratify the proposal
+            getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
       describe "StakePool" $ do
         it "UTxOs contribute to active voting stake" $ do
           -- Only modify the applicable thresholds

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

@@ -42,6 +42,7 @@ module Test.Cardano.Ledger.Conway.ImpTest (
   trySubmitVote,
   registerDRep,
   setupSingleDRep,
+  setupDRepWithoutStake,
   setupPoolWithStake,
   setupPoolWithoutStake,
   conwayModifyPParams,
@@ -102,7 +103,6 @@ module Test.Cardano.Ledger.Conway.ImpTest (
   cantFollow,
   getsPParams,
   currentProposalsShouldContain,
-  setupDRepWithoutStake,
   withImpStateWithProtVer,
   whenPostBootstrap,
 ) where

libs/cardano-ledger-core/src/Cardano/Ledger/Address.hs

@@ -64,6 +64,8 @@ module Cardano.Ledger.Address (
   putRewardAcnt,
   decodeRewardAcnt,
   fromCborRewardAcnt,
+  rewardAccountCredentialL,
+  rewardAccountNetworkL,
 )
 where
 
@@ -129,6 +131,7 @@ import Data.Word (Word16, Word32, Word64, Word8)
 import GHC.Generics (Generic)
 import GHC.Show (intToDigit)
 import GHC.Stack (HasCallStack)
+import Lens.Micro
 import NoThunks.Class (NoThunks (..))
 import Numeric (showIntAtBase)
 import Quiet (Quiet (Quiet))
@@ -220,6 +223,12 @@ data RewardAccount c = RewardAccount
   }
   deriving (Show, Eq, Generic, Ord, NFData, ToJSONKey, FromJSONKey)
 
+rewardAccountCredentialL :: Lens' (RewardAccount c) (Credential 'Staking c)
+rewardAccountCredentialL = lens raCredential $ \x y -> x {raCredential = y}
+
+rewardAccountNetworkL :: Lens' (RewardAccount c) Network
+rewardAccountNetworkL = lens raNetwork $ \x y -> x {raNetwork = y}
+
 pattern RewardAcnt :: Network -> Credential 'Staking c -> RewardAccount c
 pattern RewardAcnt {getRwdNetwork, getRwdCred} = RewardAccount getRwdNetwork getRwdCred
 

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

@@ -2,7 +2,6 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
 
 -- | Generate a Simple Tx with 1 inout, 1 output, and 1 DRep related Cert
 module Test.Cardano.Ledger.Constrained.Trace.DrepCertTx where
@@ -19,6 +18,7 @@ import Cardano.Ledger.Conway.Governance (
   curPParamsGovStateL,
   finishDRepPulser,
   newEpochStateDRepPulsingStateL,
+  proposalsActions,
   proposalsActionsMap,
   proposalsGovStateL,
  )
@@ -215,10 +215,12 @@ pulserWorks mcsfirst mcslast =
     )
     (bruteForceDRepDistr (mcsTickNes mcsfirst) === extractPulsingDRepDistr (mcsNes mcslast))
 
-bruteForceDRepDistr :: NewEpochState era -> Map.Map (DRep (EraCrypto era)) (CompactForm Coin)
-bruteForceDRepDistr nes = computeDRepDistr incstk dreps Map.empty $ UMap.umElems umap
+bruteForceDRepDistr ::
+  ConwayEraGov era => NewEpochState era -> Map.Map (DRep (EraCrypto era)) (CompactForm Coin)
+bruteForceDRepDistr nes = computeDRepDistr incstk dreps props Map.empty $ UMap.umElems umap
   where
     ls = esLState (nesEs nes)
+    props = proposalsActions $ ls ^. lsUTxOStateL . utxosGovStateL . proposalsGovStateL
     cs = lsCertState ls
     IStake incstk _ = utxosStakeDistr (lsUTxOState ls)
     umap = dsUnified (certDState cs)