Change how SPO votes are counted

eras/conway/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.17.0.0
 
+* Added `reDelegatees` and `rePoolParams` to `RatifyEnv` for updated SPO vote calculation #4645
+* Added `dpPoolParams` to `DRepPulser` to track the parameters of each stake pool
 * Add `HardForkEvent` constructor to `ConwayEpochEvent`
 * Add `HardFork` module, `ConwayHARDFORK` and `ConwayHardForkEvent`
 * Add predicate failures to guard against invalid reward accounts (return addresses) in proposals and treasury withdrawals. #4639

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

@@ -211,6 +211,7 @@ import Cardano.Ledger.Shelley.LedgerState (
   credMap,
   dsUnified,
   epochStateGovStateL,
+  epochStatePoolParamsL,
   epochStateTreasuryL,
   esLStateL,
   lsCertState,
@@ -492,6 +493,7 @@ setFreshDRepPulsingState epochNo stakePoolDistr epochState = do
                     , dpProposals = proposalsActions props
                     , dpProposalDeposits = proposalsDeposits props
                     , dpGlobals = globals
+                    , dpPoolParams = epochState ^. epochStatePoolParamsL
                     }
                 )
   pure $ epochState & epochStateGovStateL .~ govState'

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

@@ -63,6 +63,7 @@ import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep (DRep (..), DRepState (..))
 import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
 import Cardano.Ledger.PoolDistr
+import Cardano.Ledger.PoolParams (PoolParams)
 import Cardano.Ledger.UMap
 import qualified Cardano.Ledger.UMap as UMap
 import Control.DeepSeq (NFData (..), deepseq)
@@ -278,6 +279,9 @@ data DRepPulser era (m :: Type -> Type) ans where
     , dpProposalDeposits :: !(Map (Credential 'Staking (EraCrypto era)) (CompactForm Coin))
     -- ^ Snapshot of the proposal-deposits per reward-account-staking-credential
     , dpGlobals :: !Globals
+    , dpPoolParams :: !(Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
+    -- ^ Snapshot of the parameters of stake pools -
+    --   this is needed to get the reward account for SPO vote calculation
     } ->
     DRepPulser era m ans
 
@@ -308,7 +312,7 @@ deriving instance (EraPParams era, Show ans) => Show (DRepPulser era m ans)
 
 instance EraPParams era => NoThunks (DRepPulser era Identity (RatifyState era)) where
   showTypeOf _ = "DRepPulser"
-  wNoThunks ctxt drp@(DRepPulser _ _ _ _ _ _ _ _ _ _ _ _ _) =
+  wNoThunks ctxt drp@(DRepPulser _ _ _ _ _ _ _ _ _ _ _ _ _ _) =
     allNoThunks
       [ noThunks ctxt (dpPulseSize drp)
       , noThunks ctxt (dpUMap drp)
@@ -323,10 +327,11 @@ instance EraPParams era => NoThunks (DRepPulser era Identity (RatifyState era))
       , noThunks ctxt (dpProposals drp)
       , noThunks ctxt (dpProposalDeposits drp)
       , noThunks ctxt (dpGlobals drp)
+      , noThunks ctxt (dpPoolParams drp)
       ]
 
 instance EraPParams era => NFData (DRepPulser era Identity (RatifyState era)) where
-  rnf (DRepPulser n um bal stake pool drep dstate ep cs es as pds gs) =
+  rnf (DRepPulser n um bal stake pool drep dstate ep cs es as pds gs poolps) =
     n `deepseq`
       um `deepseq`
         bal `deepseq`
@@ -339,7 +344,8 @@ instance EraPParams era => NFData (DRepPulser era Identity (RatifyState era)) wh
                       es `deepseq`
                         as `deepseq`
                           pds `deepseq`
-                            rnf gs
+                            gs `deepseq`
+                              rnf poolps
 
 class
   ( STS (ConwayRATIFY era)
@@ -386,6 +392,8 @@ finishDRepPulser (DRPulsing (DRepPulser {..})) =
         , reDRepState = dpDRepState
         , reCurrentEpoch = dpCurrentEpoch
         , reCommitteeState = dpCommitteeState
+        , reDelegatees = dRepMap dpUMap
+        , rePoolParams = dpPoolParams
         }
     !ratifySig = RatifySignal dpProposals
     !ratifyState =

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

@@ -115,8 +115,9 @@ import Cardano.Ledger.Core (
  )
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep (DRep (..), DRepState (..))
-import Cardano.Ledger.Keys (KeyRole (..))
+import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
 import Cardano.Ledger.PoolDistr (PoolDistr (..))
+import Cardano.Ledger.PoolParams (PoolParams)
 import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
 import Cardano.Ledger.Shelley.LedgerState (
   epochStateIncrStakeDistrL,
@@ -558,6 +559,8 @@ data RatifyEnv era = RatifyEnv
   , reDRepState :: !(Map (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era)))
   , reCurrentEpoch :: !EpochNo
   , reCommitteeState :: !(CommitteeState era)
+  , reDelegatees :: !(Map (Credential 'Staking (EraCrypto era)) (DRep (EraCrypto era)))
+  , rePoolParams :: !(Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era)))
   }
   deriving (Generic)
 
@@ -585,31 +588,44 @@ deriving instance Show (RatifyEnv era)
 deriving instance Eq (RatifyEnv era)
 
 instance Default (RatifyEnv era) where
-  def = RatifyEnv Map.empty (PoolDistr Map.empty mempty) Map.empty Map.empty (EpochNo 0) def
+  def =
+    RatifyEnv
+      Map.empty
+      (PoolDistr Map.empty mempty)
+      Map.empty
+      Map.empty
+      (EpochNo 0)
+      def
+      Map.empty
+      Map.empty
 
 instance Typeable era => NoThunks (RatifyEnv era) where
   showTypeOf _ = "RatifyEnv"
-  wNoThunks ctxt (RatifyEnv stake pool drep dstate ep cs) =
+  wNoThunks ctxt (RatifyEnv stake pool drep dstate ep cs delegatees poolps) =
     allNoThunks
       [ noThunks ctxt stake
       , noThunks ctxt pool
       , noThunks ctxt drep
       , noThunks ctxt dstate
       , noThunks ctxt ep
       , noThunks ctxt cs
+      , noThunks ctxt delegatees
+      , noThunks ctxt poolps
       ]
 
 instance Era era => NFData (RatifyEnv era) where
-  rnf (RatifyEnv stake pool drep dstate ep cs) =
+  rnf (RatifyEnv stake pool drep dstate ep cs delegatees poolps) =
     stake `deepseq`
       pool `deepseq`
         drep `deepseq`
           dstate `deepseq`
             ep `deepseq`
-              rnf cs
+              cs `deepseq`
+                delegatees `deepseq`
+                  rnf poolps
 
 instance Era era => EncCBOR (RatifyEnv era) where
-  encCBOR env@(RatifyEnv _ _ _ _ _ _) =
+  encCBOR env@(RatifyEnv _ _ _ _ _ _ _ _) =
     let RatifyEnv {..} = env
      in encode $
           Rec (RatifyEnv @era)
@@ -619,6 +635,8 @@ instance Era era => EncCBOR (RatifyEnv era) where
             !> To reDRepState
             !> To reCurrentEpoch
             !> To reCommitteeState
+            !> To reDelegatees
+            !> To rePoolParams
 
 instance Era era => DecCBOR (RatifyEnv era) where
   decCBOR =
@@ -630,6 +648,8 @@ instance Era era => DecCBOR (RatifyEnv era) where
         <! From
         <! From
         <! From
+        <! From
+        <! From
 
 instance EraPParams era => EncCBOR (RatifyState era) where
   encCBOR (RatifyState es enacted expired delayed) =

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

@@ -27,8 +27,10 @@ module Cardano.Ledger.Conway.Rules.Ratify (
   withdrawalCanWithdraw,
 ) where
 
+import Cardano.Ledger.Address (RewardAccount (..))
 import Cardano.Ledger.BaseTypes (
   BoundedRational (..),
+  ProtVer,
   ShelleyBase,
   StrictMaybe (..),
   addEpochInterval,
@@ -53,6 +55,7 @@ import Cardano.Ledger.Conway.Governance (
   RatifyState (..),
   Vote (..),
   ensCommitteeL,
+  ensProtVerL,
   ensTreasuryL,
   gasAction,
   rsDelayedL,
@@ -73,6 +76,8 @@ import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.DRep (DRep (..), DRepState (..))
 import Cardano.Ledger.Keys (KeyRole (..))
 import Cardano.Ledger.PoolDistr (PoolDistr (..), individualTotalPoolStake)
+import Cardano.Ledger.PoolParams (PoolParams (..))
+import Cardano.Ledger.Shelley.HardForks (bootstrapPhase)
 import Cardano.Ledger.Slot (EpochNo (..))
 import Cardano.Ledger.Val (Val (..), (<+>))
 import Control.State.Transition.Extended (
@@ -173,10 +178,12 @@ spoAccepted ::
 spoAccepted re rs gas =
   case votingStakePoolThreshold rs (gasAction gas) of
     -- Short circuit on zero threshold in order to avoid redundant computation.
-    SJust r -> r == minBound || spoAcceptedRatio re gas >= unboundRational r
+    SJust r ->
+      r == minBound || spoAcceptedRatio re gas (rs ^. rsEnactStateL . ensProtVerL) >= unboundRational r
     SNothing -> False
 
--- | Final ratio for `totalAcceptedStakePoolsRatio` we want is: t = y \/ (s - a)
+-- | Final ratio for `totalAcceptedStakePoolsRatio` we want during the bootstrap period is:
+-- t = y \/ (s - a)
 -- Where:
 --  * `y` - total delegated stake that voted Yes
 --  * `a` - total delegated stake that voted Abstain
@@ -187,24 +194,42 @@ spoAccepted re rs gas =
 -- vote are considered as `Abstain` votes.
 --
 -- `No` votes are not counted.
-spoAcceptedRatio :: forall era. RatifyEnv era -> GovActionState era -> Rational
+-- After the bootstrap period if an SPO didn't vote, it will be considered as a `No` vote by default.
+-- The only exceptions are when a pool delegated to an `AlwaysNoConfidence` or an `AlwaysAbstain` DRep.
+-- In those cases, behaviour is as expected: vote `Yes` on `NoConfidence` proposals in case of the former and
+-- and vote `Abstain` by default in case of the latter. For `HardForkInitiation`, behaviour is the same as
+-- during the bootstrap period: if an SPO didn't vote, their vote will always count as `No`.
+spoAcceptedRatio :: forall era. RatifyEnv era -> GovActionState era -> ProtVer -> Rational
 spoAcceptedRatio
-  RatifyEnv {reStakePoolDistr = PoolDistr individualPoolStake (CompactCoin totalActiveStake)}
+  RatifyEnv
+    { reStakePoolDistr = PoolDistr individualPoolStake (CompactCoin totalActiveStake)
+    , reDelegatees
+    , rePoolParams
+    }
   GovActionState
     { gasStakePoolVotes
     , gasProposalProcedure = ProposalProcedure {pProcGovAction}
     }
+  pv
     | totalActiveStake == 0 = 0 -- guard against the degenerate case when active stake is zero.
     | totalActiveStake == abstainStake = 0 -- guard against the degenerate case when all abstain.
     | otherwise = toInteger yesStake % toInteger (totalActiveStake - abstainStake)
     where
       accumStake (!yes, !abstain) poolId distr =
         let CompactCoin stake = individualTotalPoolStake distr
             vote = Map.lookup poolId gasStakePoolVotes
+            drep =
+              Map.lookup poolId rePoolParams >>= \d ->
+                Map.lookup (raCredential $ ppRewardAccount d) reDelegatees
          in case vote of
               Nothing
                 | HardForkInitiation {} <- pProcGovAction -> (yes, abstain)
-                | otherwise -> (yes, abstain + stake)
+                | bootstrapPhase pv -> (yes, abstain + stake)
+                | otherwise -> case drep of
+                    Just DRepAlwaysNoConfidence
+                      | NoConfidence {} <- pProcGovAction -> (yes + stake, abstain)
+                    Just DRepAlwaysAbstain -> (yes, abstain + stake)
+                    _ -> (yes, abstain)
               Just Abstain -> (yes, abstain + stake)
               Just VoteNo -> (yes, abstain)
               Just VoteYes -> (yes + stake, abstain)

eras/conway/impl/test/Test/Cardano/Ledger/Conway/DRepRatifySpec.hs

@@ -330,3 +330,5 @@ emptyRatifyEnv =
     Map.empty
     (EpochNo 0)
     (CommitteeState Map.empty)
+    Map.empty
+    Map.empty

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

@@ -198,6 +198,8 @@ instance
       <*> arbitrary
       <*> arbitrary
       <*> arbitrary
+      <*> arbitrary
+      <*> arbitrary
 
   shrink = genericShrink
 

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

@@ -337,17 +337,20 @@ paramChangeAffectsProposalsSpec =
         enactThreshold largerThreshold drepC hotCommitteeC
         isDRepAccepted gaiChild `shouldReturn` False
       it "Decreasing the threshold ratifies a hitherto-unratifiable proposal" $ do
+        -- This sets up a stake pool with 1_000_000 Coin
         (drepC, hotCommitteeC, _) <- electBasicCommittee
         setThreshold largerThreshold
         (drep, _, _) <- setupSingleDRep 1_000_000
-        (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000
+        (spoC, _, _) <- setupPoolWithStake $ Coin 3_000_000
         (gaiParent, gaiChild) <-
           submitTwoExampleProposalsAndVoteOnTheChild [(spoC, VoteYes)] [(drep, VoteYes)]
         isDRepAccepted gaiChild `shouldReturn` False
         enactThreshold smallerThreshold drepC hotCommitteeC
         isDRepAccepted gaiChild `shouldReturn` True
         -- Not vote on the parent too to make sure both get enacted
         submitYesVote_ (DRepVoter drep) gaiParent
+        -- bootstrap: 3 % 4 stake yes; 1 % 4 stake abstain; yes / stake - abstain > 1 % 2
+        -- post-bootstrap: 3 % 4 stake yes; 1 % 4 stake no
         submitYesVote_ (StakePoolVoter spoC) gaiParent
         passNEpochs 2
         getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiParent)
@@ -372,11 +375,14 @@ paramChangeAffectsProposalsSpec =
             submitYesVote_ (CommitteeVoter hotCommitteeC) pcGai
             passNEpochs 2
       it "Increasing the threshold prevents a hitherto-ratifiable proposal from being ratified" $ do
+        -- This sets up a stake pool with 1_000_000 Coin
         (drepC, hotCommitteeC, _) <- electBasicCommittee
         setThreshold smallerThreshold
-        (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 1_000_000
+        (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 2_000_000
         (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000
         passEpoch -- Make the new pool distribution count
+        -- bootstrap: 1 % 2 stake yes (2_000_000); 1 % 2 stake abstain; yes / stake - abstain == 1 % 2
+        -- post-bootstrap: 1 % 2 stake yes (2_000_000); 1 % 4 stake didn't vote; 1 % 4 stake no
         (_gaiParent, gaiChild) <-
           submitTwoExampleProposalsAndVoteOnTheChild
             [(poolKH1, VoteYes), (poolKH2, VoteNo)]
@@ -385,10 +391,13 @@ paramChangeAffectsProposalsSpec =
         enactThreshold largerThreshold drepC hotCommitteeC
         isSpoAccepted gaiChild `shouldReturn` False
       it "Decreasing the threshold ratifies a hitherto-unratifiable proposal" $ do
+        -- This sets up a stake pool with 1_000_000 Coin
         (drepC, hotCommitteeC, _) <- electBasicCommittee
         setThreshold largerThreshold
-        (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 1_000_000
+        (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 2_000_000
         (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000
+        -- bootstrap: 1 % 2 stake yes (2_000_000); 1 % 2 stake abstain; yes / stake - abstain == 1 % 2
+        -- post-bootstrap: 1 % 2 stake yes (2_000_000); 1 % 4 stake didn't vote; 1 % 4 stake no
         (gaiParent, gaiChild) <-
           submitTwoExampleProposalsAndVoteOnTheChild
             [(poolKH1, VoteYes), (poolKH2, VoteNo)]
@@ -521,10 +530,14 @@ spoVotesCommitteeUpdates =
         modifyPParams $ ppPoolVotingThresholdsL . pvtMotionNoConfidenceL .~ 1 %! 2
         whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL .~ def)
         gai <- submitGovAction $ NoConfidence SNothing
-        -- 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2
+        -- bootstrap: 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2
+        -- post-bootstrap: 1 % 4 stake yes; 3 % 4 stake no; yes stake < 1 % 2
         submitYesVote_ (StakePoolVoter spoK1) gai
         passNEpochs 2
-        getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai)
+        pv <- getProtVer
+        if bootstrapPhase pv
+          then getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai)
+          else getLastEnactedCommittee `shouldReturn` SNothing
       it "CommitteeUpdate" $ do
         (spoK1, _, _) <- setupPoolWithStake $ Coin 100_000_000
         _ <- setupPoolWithStake $ Coin 100_000_000
@@ -534,11 +547,14 @@ spoVotesCommitteeUpdates =
         whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL .~ def)
         cc <- KeyHashObj <$> freshKeyHash
         gai <- submitUpdateCommittee Nothing mempty [(cc, EpochInterval 5)] (1 %! 2)
-        -- 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2
+        -- bootstrap: 1 % 4 stake yes; 3 % 4 stake abstain; yes / stake - abstain > 1 % 2
+        -- post-bootstrap: 1 % 4 stake yes; 3 % 4 stake no; yes stake < 1 % 2
         submitYesVote_ (StakePoolVoter spoK1) gai
         passNEpochs 2
-        getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai)
-
+        pv <- getProtVer
+        if bootstrapPhase pv
+          then getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gai)
+          else getLastEnactedCommittee `shouldReturn` SNothing
 spoVotesForHardForkInitiation ::
   forall era.
   ConwayEraImp era =>