Move pool deposits into StakePoolState

Author: aniketd

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

@@ -42,8 +42,9 @@ module Cardano.Ledger.Shelley.LedgerState (
   produced,
 
   -- * DelegationState
-  payPoolDeposit,
-  refundPoolDeposit,
+
+  -- payPoolDeposit,
+  -- refundPoolDeposit,
   totalObligation,
   allObligations,
 
@@ -102,7 +103,7 @@ module Cardano.Ledger.Shelley.LedgerState (
   utxosDonationL,
   epochStateGovStateL,
   epochStateStakeDistrL,
-  epochStatePoolParamsL,
+  epochStatePoolParamsG,
   epochStateStakePoolsL,
   epochStateDonationL,
   newEpochStateGovStateL,

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

@@ -698,11 +698,13 @@ 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`" #-}
+-- | We cannot have a full Lens' here since we loose information that is
+-- unrecoverable in the opposite direction, namely the pool deposit.
+epochStatePoolParamsG ::
+  EraCertState era => SimpleGetter (EpochState era) (Map (KeyHash 'StakePool) PoolParams)
+epochStatePoolParamsG =
+  esLStateL . lsCertStateL . certPStateL . psStakePoolsL . to (mapWithKey stakePoolStateToPoolParams)
+{-# DEPRECATED epochStatePoolParamsG "In favor of `epochStateStakePoolsL`" #-}
 
 epochStateStakeDistrL ::
   Lens' (EpochState era) (VMap VB VP (Credential 'Staking) (CompactForm Coin))

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

@@ -212,7 +212,7 @@ epochTransition = do
   ss' <-
     trans @(EraRule "SNAP" era) $ TRC (SnapEnv ls pp, ss, ())
 
-  let PState stakePools futureStakePools _ _ = pstate
+  let PState stakePools futureStakePools _ = pstate
       ppp = eval (stakePools ⨃ futureStakePools)
       pstate' =
         pstate

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

@@ -50,9 +50,15 @@ import Cardano.Ledger.Shelley.Era (
   ShelleyPOOL,
   hardforkAlonzoValidatePoolRewardAccountNetID,
  )
-import Cardano.Ledger.Shelley.LedgerState (PState (..), payPoolDeposit)
 import qualified Cardano.Ledger.Shelley.SoftForks as SoftForks
-import Cardano.Ledger.State (PoolMetadata (..), PoolParams (..), mkStakePoolState)
+import Cardano.Ledger.State (
+  PState (..),
+  PoolMetadata (..),
+  PoolParams (..),
+  StakePoolState (..),
+  mkStakePoolState,
+  psStakePoolsL,
+ )
 import Control.DeepSeq
 import Control.Monad (forM_, when)
 import Control.Monad.Trans.Reader (asks)
@@ -68,9 +74,10 @@ import Control.State.Transition (
  )
 import qualified Data.ByteString as BS
 import Data.Kind (Type)
+import Data.Map.Strict ((!))
 import Data.Word (Word8)
 import GHC.Generics (Generic)
-import Lens.Micro ((^.))
+import Lens.Micro ((%~), (&), (^.))
 import NoThunks.Class (NoThunks (..))
 
 data PoolEnv era
@@ -239,8 +246,9 @@ poolDelegationTransition = do
           -- register new, Pool-Reg
           tellEvent $ RegisterPool ppId
           pure $
-            payPoolDeposit ppId pp $
-              ps {psStakePools = eval (psStakePools ⨃ singleton ppId (mkStakePoolState poolParams))}
+            ps
+              & psStakePoolsL %~ \stakePools ->
+                eval (stakePools ⨃ singleton ppId (mkStakePoolState (pp ^. ppPoolDepositCompactL) poolParams))
         else do
           tellEvent $ ReregisterPool ppId
           -- hk is already registered, so we want to reregister it. That means adding it
@@ -251,11 +259,12 @@ poolDelegationTransition = do
           -- (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.
+          -- the if statement. And so the use of (!) is also justified here.
+          let existingDeposit = spsDeposit $ psStakePools ! ppId
           pure $
             ps
               { psFutureStakePools =
-                  eval (psFutureStakePools ⨃ singleton ppId (mkStakePoolState poolParams))
+                  eval (psFutureStakePools ⨃ singleton ppId (mkStakePoolState existingDeposit poolParams))
               , psRetiring = eval (setSingleton ppId ⋪ psRetiring)
               }
     RetirePool hk e -> do

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

@@ -137,7 +137,7 @@ poolReapTransition = do
     -- 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)
+      Map.partitionWithKey (\k _ -> Set.member k retired) (spsDeposit <$> psStakePools ps)
     -- collect all accounts for stake pools that will retire
     retiredStakePoolAccounts :: Map.Map (KeyHash 'StakePool) RewardAccount
     retiredStakePoolAccounts = Map.map spsRewardAccount $ eval (retired ◁ psStakePools ps)

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

@@ -386,6 +386,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 =>
@@ -395,7 +407,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))
 

libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs

@@ -78,22 +78,21 @@ import Cardano.Ledger.DRep (DRep (..), DRepState (..))
 import Cardano.Ledger.Hashes (GenDelegPair (..), GenDelegs (..))
 import Cardano.Ledger.Slot (EpochNo (..), SlotNo (..))
 import Cardano.Ledger.State.Account
-import Cardano.Ledger.State.StakePool (StakePoolState)
+import Cardano.Ledger.State.StakePool (StakePoolState (..), spsDepositL)
 import Control.DeepSeq (NFData (..))
 import Control.Monad.Trans
 import Data.Aeson (ToJSON (..), object, (.=))
 import Data.Default (Default (def))
 import qualified Data.Foldable as F
 import Data.Kind (Type)
+import qualified Data.Map.Merge.Strict as Map
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import GHC.Generics (Generic)
-import Lens.Micro (Lens', lens, (^.), _1)
+import Lens.Micro
 import NoThunks.Class (NoThunks (..))
 
--- ======================================
-
 data FutureGenDeleg = FutureGenDeleg
   { fGenDelegSlot :: !SlotNo
   , fGenDelegGenKeyHash :: !(KeyHash 'Genesis)
@@ -235,8 +234,6 @@ data PState era = PState
   -- of the Shelley Ledger Specification for a sequence diagram.
   , psRetiring :: !(Map (KeyHash 'StakePool) EpochNo)
   -- ^ A map of retiring stake pools to the epoch when they retire.
-  , psDeposits :: !(Map (KeyHash 'StakePool) (CompactForm Coin))
-  -- ^ A map of the deposits for each pool
   }
   deriving (Show, Eq, Generic)
   deriving (ToJSON) via KeyValuePairs (PState era)
@@ -246,17 +243,16 @@ instance NoThunks (PState era)
 instance NFData (PState era)
 
 instance Era era => EncCBOR (PState era) where
-  encCBOR (PState a b c d) =
-    encodeListLen 4 <> encCBOR a <> encCBOR b <> encCBOR c <> encCBOR d
+  encCBOR (PState a b c) =
+    encodeListLen 3 <> encCBOR a <> encCBOR b <> encCBOR c
 
 instance DecShareCBOR (PState era) where
   type Share (PState era) = Interns (KeyHash 'StakePool)
   decSharePlusCBOR = decodeRecordNamedT "PState" (const 4) $ do
     psStakePools <- decSharePlusLensCBOR (toMemptyLens _1 id)
     psFutureStakePools <- decSharePlusLensCBOR (toMemptyLens _1 id)
     psRetiring <- decSharePlusLensCBOR (toMemptyLens _1 id)
-    psDeposits <- decSharePlusLensCBOR (toMemptyLens _1 id)
-    pure PState {psStakePools, psFutureStakePools, psRetiring, psDeposits}
+    pure PState {psStakePools, psFutureStakePools, psRetiring}
 
 instance (Era era, DecShareCBOR (PState era)) => DecCBOR (PState era) where
   decCBOR = decNoShareCBOR
@@ -266,7 +262,6 @@ instance ToKeyValuePairs (PState era) where
     [ "stakePools" .= psStakePools
     , "futureStakePools" .= psFutureStakePools
     , "retiring" .= psRetiring
-    , "deposits" .= psDeposits
     ]
 
 data CommitteeAuthorization
@@ -396,35 +391,27 @@ instance Default (Accounts era) => Default (DState era) where
 
 instance Default (PState era) where
   def =
-    PState Map.empty Map.empty Map.empty Map.empty
-
--- ==========================================================
--- Functions that handle Deposits
-
--- | One only pays a deposit on the initial pool registration. So return the
---   the Deposits unchanged if the keyhash already exists. There are legal
---   situations where a pool may be registered multiple times.
-payPoolDeposit ::
-  EraPParams era =>
-  KeyHash 'StakePool ->
-  PParams era ->
-  PState era ->
-  PState era
-payPoolDeposit keyhash pp pstate = pstate {psDeposits = newpool}
+    PState Map.empty Map.empty Map.empty
+
+-- | One only pays a deposit on the initial pool registration. So we return the
+-- StakePoolState unchanged if the deposit is already non-zero.
+--
+-- NOTE: There are legal situations where a pool may be registered multiple times.
+payPoolDeposit :: EraPParams era => KeyHash 'StakePool -> PParams era -> PState era -> PState era
+payPoolDeposit keyhash pp pstate = pstate & psStakePoolsL %~ Map.adjust payDeposit keyhash
   where
-    pool = psDeposits pstate
     !deposit = pp ^. ppPoolDepositCompactL
-    newpool
-      | Map.notMember keyhash pool = Map.insert keyhash deposit pool
-      | otherwise = pool
+    payDeposit sps
+      | sps ^. spsDepositL <= mempty = sps & spsDepositL .~ deposit
+      | otherwise = sps
 
 refundPoolDeposit :: KeyHash 'StakePool -> PState era -> (CompactForm Coin, PState era)
-refundPoolDeposit keyhash pstate = (coin, pstate {psDeposits = newpool})
-  where
-    pool = psDeposits pstate
-    (coin, newpool) = case Map.lookup keyhash pool of
-      Just c -> (c, Map.delete keyhash pool)
-      Nothing -> (mempty, pool)
+refundPoolDeposit keyhash pstate =
+  ( -- The actual deposit or mempty
+    maybe mempty spsDeposit $ Map.lookup keyhash $ pstate ^. psStakePoolsL
+  , -- The PState, updated with the deposit set to mempty
+    pstate & psStakePoolsL %~ Map.adjust (spsDepositL .~ mempty) keyhash
+  )
 
 -- | A composite of all the Deposits the system is obligated to eventually pay back.
 data Obligations = Obligations
@@ -462,12 +449,6 @@ instance Show Obligations where
       , "   Proposal deposits = " ++ show (oblProposal x)
       ]
 
--- =======================================================
--- Lenses for CertState and its subsidiary types
-
--- ===================================
--- DState
-
 dsGenDelegsL :: Lens' (DState era) GenDelegs
 dsGenDelegsL = lens dsGenDelegs (\ds u -> ds {dsGenDelegs = u})
 
@@ -478,9 +459,6 @@ dsFutureGenDelegsL ::
   Lens' (DState era) (Map FutureGenDeleg GenDelegPair)
 dsFutureGenDelegsL = lens dsFutureGenDelegs (\ds u -> ds {dsFutureGenDelegs = u})
 
--- ===================================
--- PState
-
 psStakePoolsL :: Lens' (PState era) (Map (KeyHash 'StakePool) StakePoolState)
 psStakePoolsL = lens psStakePools (\ds u -> ds {psStakePools = u})
 
@@ -494,4 +472,15 @@ psDepositsL :: Lens' (PState era) (Map (KeyHash 'StakePool) Coin)
 psDepositsL = psDepositsCompactL . lens (fmap fromCompact) (\_ -> fmap compactCoinOrError)
 
 psDepositsCompactL :: Lens' (PState era) (Map (KeyHash 'StakePool) (CompactForm Coin))
-psDepositsCompactL = lens psDeposits (\ds u -> ds {psDeposits = u})
+psDepositsCompactL =
+  lens
+    (fmap spsDeposit . psStakePools)
+    ( \pstate deposits ->
+        pstate
+          & psStakePoolsL
+            %~ Map.merge
+              Map.dropMissing
+              Map.preserveMissing
+              (Map.zipWithMatched (\_key deposit sps -> sps {spsDeposit = deposit}))
+              deposits
+    )