Move pool deposits into StakePoolState

eras/shelley/impl/CHANGELOG.md

@@ -2,6 +2,11 @@
 
 ## 1.17.0.0
 
+* Refactor pool deposits to use `StakePoolState`. #5234
+  * Update `Pool` rule to store deposits in individual `StakePoolState` records
+  * Add and export `prUTxOStateL`, `prChainAccountStateL`, and `prCertStateL` lenses for `ShelleyPoolreapState`
+  * Update genesis stake pool registration to use `mempty` deposits for initial pools per specification
+  * Remove `epochStatePoolParamsL` lens.
 * Add `hardforkConwayDisallowDuplicatedVRFKeys`
 * Add `VRFKeyHashAlreadyRegistered` to `ShelleyPoolPredFailure` type
 * Add `NFData` for `NominalDiffTimeMicro`, `ShelleyGenesisStaking` and `ShelleyGenesis`

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

@@ -42,8 +42,6 @@ module Cardano.Ledger.Shelley.LedgerState (
   produced,
 
   -- * DelegationState
-  payPoolDeposit,
-  refundPoolDeposit,
   totalObligation,
   allObligations,
 
@@ -102,7 +100,6 @@ module Cardano.Ledger.Shelley.LedgerState (
   utxosDonationL,
   epochStateGovStateL,
   epochStateStakeDistrL,
-  epochStatePoolParamsL,
   epochStateStakePoolsL,
   epochStateDonationL,
   newEpochStateGovStateL,
@@ -115,7 +112,7 @@ module Cardano.Ledger.Shelley.LedgerState (
   psStakePoolsL,
   psFutureStakePoolsL,
   psRetiringL,
-  psDepositsL,
+  psDepositsG,
   psVRFKeyHashesL,
 
   -- * Lenses from SnapShot(s)

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

@@ -55,7 +55,7 @@ import Control.Monad.State.Strict (evalStateT)
 import Control.Monad.Trans (MonadTrans (lift))
 import Data.Aeson (ToJSON (..), (.=))
 import Data.Default (Default, def)
-import Data.Map.Strict (Map, mapWithKey)
+import Data.Map.Strict (Map)
 import Data.VMap (VB, VMap, VP)
 import GHC.Generics (Generic)
 import Lens.Micro
@@ -698,12 +698,6 @@ epochStateStakePoolsL ::
   EraCertState era => Lens' (EpochState era) (Map (KeyHash 'StakePool) StakePoolState)
 epochStateStakePoolsL = esLStateL . lsCertStateL . certPStateL . psStakePoolsL
 
-epochStatePoolParamsL ::
-  EraCertState era => Lens' (EpochState era) (Map (KeyHash 'StakePool) PoolParams)
-epochStatePoolParamsL =
-  epochStateStakePoolsL . lens (mapWithKey stakePoolStateToPoolParams) (const $ fmap mkStakePoolState)
-{-# DEPRECATED epochStatePoolParamsL "In favor of `epochStateStakePoolsL`" #-}
-
 epochStateStakeDistrL ::
   Lens' (EpochState era) (VMap VB VP (Credential 'Staking) (CompactForm Coin))
 epochStateStakeDistrL = esSnapshotsL . ssStakeMarkL . ssStakeDistrL

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

@@ -259,10 +259,9 @@ poolDelegationTransition = do
                 | otherwise = id
           tellEvent $ RegisterPool ppId
           pure $
-            payPoolDeposit ppId pp $
-              ps
-                & psStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams)
-                & psVRFKeyHashesL %~ updateVRFKeyHash
+            ps
+              & psStakePoolsL %~ Map.insert ppId (mkStakePoolState (pp ^. ppPoolDepositCompactL) poolParams)
+              & psVRFKeyHashesL %~ updateVRFKeyHash
         -- re-register Pool
         Just stakePoolState -> do
           when (hardforkConwayDisallowDuplicatedVRFKeys pv) $ do
@@ -281,18 +280,21 @@ poolDelegationTransition = do
                         | otherwise -> id
                 | otherwise = id
           tellEvent $ ReregisterPool ppId
-          -- hk is already registered, so we want to reregister it. That means adding it
-          -- to the Future pool params (if it is not there already), and overriding the
-          -- range with the new 'poolParam', if it is (using ⨃ ). We must also unretire
-          -- it, if it has been scheduled for retirement.  The deposit does not
-          -- change. One pays the deposit just once. Only if it is fully retired
-          -- (i.e. it's deposit has been refunded, and it has been removed from the
-          -- registered pools).  does it need to pay a new deposit (at the current deposit
-          -- amount). But of course, if that has happened, we cannot be in this branch of
-          -- the if statement.
+          -- NOTE: The `ppId` is already registered, so we want to reregister
+          -- it. That means adding it to the Future Stake Pools (if it is not
+          -- there already), and overriding its range with the new 'poolParams',
+          -- if it is.
+          --
+          -- We must also unretire it, if it has been scheduled for retirement.
+          --
+          -- The deposit does not change. One pays the deposit just once. Only
+          -- if it is fully retired (i.e. it's deposit has been refunded, and it
+          -- has been removed from the registered pools).  does it need to pay a
+          -- new deposit (at the current deposit amount). But of course, if that
+          -- has happened, we cannot be in this branch of the case statement.
           pure $
             ps
-              & psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams)
+              & psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState (stakePoolState ^. spsDepositL) poolParams)
               & psRetiringL %~ Map.delete ppId
               & psVRFKeyHashesL %~ updateFutureVRFKeyHash
     RetirePool ppId e -> do

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

@@ -16,11 +16,14 @@ module Cardano.Ledger.Shelley.Rules.PoolReap (
   ShelleyPOOLREAP,
   ShelleyPoolreapEvent (..),
   ShelleyPoolreapState (..),
+  prCertStateL,
+  prChainAccountStateL,
+  prUTxOStateL,
   PredicateFailure,
   ShelleyPoolreapPredFailure,
 ) where
 
-import Cardano.Ledger.Address (RewardAccount, raCredential)
+import Cardano.Ledger.Address
 import Cardano.Ledger.BaseTypes (ShelleyBase)
 import Cardano.Ledger.Coin (Coin, CompactForm)
 import Cardano.Ledger.Compactible (fromCompact)
@@ -65,6 +68,15 @@ data ShelleyPoolreapState era = PoolreapState
 deriving stock instance
   (Show (UTxOState era), Show (CertState era)) => Show (ShelleyPoolreapState era)
 
+prUTxOStateL :: Lens' (ShelleyPoolreapState era) (UTxOState era)
+prUTxOStateL = lens prUTxOSt $ \sprs x -> sprs {prUTxOSt = x}
+
+prChainAccountStateL :: Lens' (ShelleyPoolreapState era) ChainAccountState
+prChainAccountStateL = lens prChainAccountState $ \sprs x -> sprs {prChainAccountState = x}
+
+prCertStateL :: Lens' (ShelleyPoolreapState era) (CertState era)
+prCertStateL = lens prCertState $ \sprs x -> sprs {prCertState = x}
+
 data ShelleyPoolreapPredFailure era -- No predicate failures
   deriving (Show, Eq, Generic)
 
@@ -155,38 +167,37 @@ poolReapTransition = do
     -- The set of pools retiring this epoch
     retired :: Set (KeyHash 'StakePool)
     retired = Set.fromDistinctAscList [k | (k, v) <- Map.toAscList (psRetiring ps), v == e]
-    -- The Map of pools (retiring this epoch) to their deposits
-    retiringDeposits, remainingDeposits :: Map.Map (KeyHash 'StakePool) (CompactForm Coin)
-    (retiringDeposits, remainingDeposits) =
-      Map.partitionWithKey (\k _ -> Set.member k retired) (psDeposits ps)
+    -- The Map of pools retiring this epoch
+    retiringPools :: Map.Map (KeyHash 'StakePool) StakePoolState
+    retiringPools = Map.restrictKeys (psStakePools ps) retired
     -- collect all accounts for stake pools that will retire
     retiredStakePoolAccountsWithVRFs ::
       Map.Map (KeyHash 'StakePool) (RewardAccount, VRFVerKeyHash 'StakePoolVRF)
     retiredStakePoolAccountsWithVRFs =
       Map.map
         (\sps -> (spsRewardAccount sps, spsVrf sps))
-        $ Map.restrictKeys (psStakePools ps) retired
+        retiringPools
     retiredVRFs = foldMap (Set.singleton . snd) retiredStakePoolAccountsWithVRFs
     retiredStakePoolAccountsWithRefund ::
       Map.Map (KeyHash 'StakePool) (RewardAccount, CompactForm Coin)
     retiredStakePoolAccountsWithRefund =
       Map.intersectionWith
-        (\(rewardAccount, _) coin -> (rewardAccount, coin))
+        (\(rewardAccount, _) sps -> (rewardAccount, spsDeposit sps))
         retiredStakePoolAccountsWithVRFs
-        retiringDeposits
+        retiringPools
     -- collect all of the potential refunds
     accountRefunds :: Map.Map (Credential 'Staking) (CompactForm Coin)
     accountRefunds =
       Map.fromListWith (<>) $
         [(raCredential k, v) | (k, v) <- Map.elems retiredStakePoolAccountsWithRefund]
     accounts = ds ^. accountsL
-    -- figure out whcich deposits can be refunded and which ones will be deposited into the treasury
-    -- as unclaimed
+    -- Deposits that can be refunded and those that are unclaimed (to be deposited into the treasury).
     refunds, unclaimedDeposits :: Map.Map (Credential 'Staking) (CompactForm Coin)
     (refunds, unclaimedDeposits) =
       Map.partitionWithKey
         (\stakeCred _ -> isAccountRegistered stakeCred accounts) -- (k ∈ dom (rewards ds))
         accountRefunds
+
     refunded = fold refunds
     unclaimed = fold unclaimedDeposits
 
@@ -216,7 +227,6 @@ poolReapTransition = do
             %~ removeStakePoolDelegations retired . addToBalanceAccounts refunds
           & certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retired)
           & certPStateL . psRetiringL %~ (`Map.withoutKeys` retired)
-          & certPStateL . psDepositsCompactL .~ remainingDeposits
           & certPStateL . psVRFKeyHashesL
             %~ ((`Set.difference` retiredVRFs) . (`Set.difference` danglingVrfKeyHashes))
       )

eras/shelley/impl/src/Cardano/Ledger/Shelley/State/CertState.hs

@@ -30,6 +30,7 @@ import Cardano.Ledger.Binary (
   encodeListLen,
  )
 import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Compactible (fromCompact)
 import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Shelley.Era (ShelleyEra)
@@ -77,7 +78,8 @@ shelleyObligationCertState :: EraCertState era => CertState era -> Obligations
 shelleyObligationCertState certState =
   Obligations
     { oblStake = sumDepositsAccounts (certState ^. certDStateL . accountsL)
-    , oblPool = F.foldl' (<>) (Coin 0) (certState ^. certPStateL . psDepositsL)
+    , oblPool =
+        F.foldl' (<>) (Coin 0) (fromCompact . spsDeposit <$> certState ^. certPStateL . psStakePoolsL)
     , oblDRep = Coin 0
     , oblProposal = Coin 0
     }

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

@@ -385,6 +385,18 @@ createInitialState tc =
     reserves :: Coin
     reserves = word64ToCoin (sgMaxLovelaceSupply sg) <-> sumCoinUTxO initialUtxo
 
+-- | From the haddock for `ShelleyGenesisStaking`:
+--
+-- > `ShelleyGenesisStaking` allows us to configure some initial stake pools and
+-- > delegation to them, in order to test Praos in a static configuration, without
+-- > requiring on-chain registration and delegation.
+--
+-- > For simplicity, pools defined in the genesis staking DO NOT PAY DEPOSITS FOR
+-- > THEIR REGISTRATION
+--
+-- Therefore, we use `mempty` in the convertion below.
+--
+-- QUESTION: @aniketd: Is the assumption that we can use mempty truly harmless?
 registerInitialStakePools ::
   forall era.
   EraCertState era =>
@@ -394,7 +406,7 @@ registerInitialStakePools ::
 registerInitialStakePools ShelleyGenesisStaking {sgsPools} nes =
   nes
     & nesEsL . esLStateL . lsCertStateL . certPStateL . psStakePoolsL
-      .~ (mkStakePoolState <$> ListMap.toMap sgsPools)
+      .~ (mkStakePoolState mempty <$> ListMap.toMap sgsPools)
 
 -- | Register all staking credentials and apply delegations. Make sure StakePools that are bing
 -- delegated to are already registered, which can be done with `registerInitialStakePools`.

eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/UnitTests/InstantStakeTest.hs

@@ -85,7 +85,7 @@ instantStakeIncludesRewards = do
 
     instantStake = addInstantStake utxo1 mempty
     poolparamMap = Map.fromList [(poolId1, pool1), (poolId2, pool2)]
-  pState <- arbitraryLens psStakePoolsL $ mkStakePoolState <$> poolparamMap
+  pState <- arbitraryLens psStakePoolsL $ mkStakePoolState mempty <$> poolparamMap
   let snapShot = snapShotFromInstantStake instantStake dState pState
       computedStakeDistr = VMap.toMap (unStake (ssStake snapShot))
 

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/AdaPreservation.hs

@@ -236,8 +236,8 @@ checkPreservation SourceSignalTarget {source, target, signal} count =
     oldCertState = lsCertState lsOld
     oldRetire = lsOld ^. lsCertStateL . certPStateL . psRetiringL
     newRetire = lsNew ^. lsCertStateL . certPStateL . psRetiringL
-    oldPoolDeposit = lsOld ^. lsCertStateL . certPStateL . psDepositsL
-    newPoolDeposit = lsNew ^. lsCertStateL . certPStateL . psDepositsL
+    oldPoolDeposit = spsDeposit <$> lsOld ^. lsCertStateL . certPStateL . psStakePoolsL
+    newPoolDeposit = spsDeposit <$> lsNew ^. lsCertStateL . certPStateL . psStakePoolsL
 
     proposal = votedFuturePParams (sgsCurProposals . utxosGovState $ lsUTxOState lsOld) currPP 5
     obligationMsgs = case proposal of

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Deposits.hs

@@ -80,15 +80,15 @@ depositInvariant SourceSignalTarget {source = chainSt} =
       pstate = certState ^. certPStateL
       allDeposits = utxosDeposited utxost
       keyDeposits = sumDepositsAccounts (dstate ^. accountsL)
-      poolDeposits = foldMap fromCompact (psDeposits pstate)
+      poolDeposits = foldMap (fromCompact . spsDeposit) (psStakePools pstate)
    in counterexample
         ( ansiDocToString . Pretty.vsep $
             [ "Deposit invariant fails:"
             , Pretty.indent 2 . Pretty.vsep . map Pretty.pretty $
                 [ "All deposits = " ++ show allDeposits
                 , "Key deposits = "
                     ++ show ((^. depositAccountStateL) <$> (dstate ^. accountsL . accountsMapL))
-                , "Pool deposits = " ++ synopsisCoinMap (Just (fromCompact <$> psDeposits pstate))
+                , "Pool deposits = " ++ synopsisCoinMap (Just (fromCompact . spsDeposit <$> psStakePools pstate))
                 ]
             ]
         )

eras/shelley/test-suite/src/Test/Cardano/Ledger/Shelley/Rules/Pool.hs

@@ -25,6 +25,7 @@ import Cardano.Protocol.TPraos.BHeader (bhbody, bheaderSlotNo)
 import Control.SetAlgebra (dom, eval, (∈), (∉))
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
+import Lens.Micro
 import Lens.Micro.Extras (view)
 import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
 import Test.Cardano.Ledger.Shelley.Constants (defaultConstants)
@@ -131,25 +132,27 @@ poolRegistrationProp
     , target = targetSt
     } =
     let hk = ppId poolParams
-        reRegistration = eval (hk ∈ dom (psStakePools sourceSt))
-     in if reRegistration
-          then
+     in case Map.lookup hk $ psStakePools sourceSt of
+          Just sps ->
             conjoin
               [ counterexample
                   "Pre-existing PoolParams must still be registered in pParams"
                   (eval (hk ∈ dom (psStakePools targetSt)) :: Bool)
               , counterexample
                   "New PoolParams are registered in future Params map"
-                  (Map.lookup hk (psFutureStakePools targetSt) === Just (mkStakePoolState poolParams))
+                  ( Map.lookup hk (psFutureStakePools targetSt)
+                      === Just (mkStakePoolState (sps ^. spsDepositL) poolParams)
+                  )
               , counterexample
                   "PoolParams are removed in 'retiring'"
                   (eval (hk ∉ dom (psRetiring targetSt)) :: Bool)
               ]
-          else -- first registration
+          Nothing ->
+            -- first registration
             conjoin
               [ counterexample
                   "New PoolParams are registered in pParams"
-                  (Map.lookup hk (psStakePools targetSt) === Just (mkStakePoolState poolParams))
+                  (Map.lookup hk (psStakePools targetSt) === Just (mkStakePoolState mempty poolParams))
               , counterexample
                   "PoolParams are not present in 'future pool params'"
                   (eval (hk ∉ dom (psFutureStakePools targetSt)) :: Bool)