Move pool deposits into StakePoolState

Author: aniketd

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,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/Pool.hs

@@ -233,28 +233,27 @@ poolDelegationTransition = do
               , mismatchExpected = minPoolCost
               }
 
-      if not (Map.member ppId psStakePools)
-        then do
-          -- register new, Pool-Reg
+      case Map.lookup ppId psStakePools of
+        Nothing -> do
           tellEvent $ RegisterPool ppId
-          pure $
-            payPoolDeposit ppId pp $
-              ps & psStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams)
-        else do
+          pure $ ps & psStakePoolsL %~ Map.insert ppId (mkStakePoolState (pp ^. ppPoolDepositCompactL) poolParams)
+        Just sps -> do
           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.
-          pure $
-            ps
-              & psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams)
-              & psRetiringL %~ Map.delete ppId
+          -- 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 (sps ^. spsDepositL) poolParams)
+            & psRetiringL %~ Map.delete ppId
     RetirePool ppId e -> do
       Map.member ppId psStakePools ?! StakePoolNotRegisteredOnKeyPOOL ppId
       let maxEpoch = pp ^. ppEMaxL

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

@@ -143,7 +143,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 $ Map.restrictKeys (psStakePools ps) retired

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))
 

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
+    )