Merge pull request #4652 from IntersectMBO/lehins/ensure-dreps-exist-…

…prior-to-delegation

Ensure dreps exist prior to delegation

Fixes #4598

eras/conway/impl/CHANGELOG.md

@@ -7,7 +7,7 @@
 * 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
-  * `ProposalReturnAddressDoesNotExist`, and 
+  * `ProposalReturnAddressDoesNotExist`, and
   * `TreasuryWithdrawalReturnAddressDoesNotExist`.
 * Add `refScriptCostStride` and `refScriptCostMultiplier`
 * Added protocol version argument to `ppuWellFormed`
@@ -36,6 +36,9 @@
 * Add a new field to `GovInfoEvent` and change "unclaimed" field from `Set` to a `Map`.
 * Changed return type of `proposalsShowDebug`
 * Added `gen-golden` executable needed for golden tests: #4629
+* Change `State` for `CERT` and `GOVCERT` to `CertState`
+* Add `DelegateeDRepNotRegisteredDELEG` predicate failure
+* Rename `DelegateeNotRegisteredDELEG` to `DelegateeStakePoolNotRegisteredDELEG`
 
 ### `testlib`
 
@@ -47,6 +50,7 @@
 * Added Test.Cardano.Ledger.Conway.CDDL with CDDL definitions in Conway.
 * Change `ImpException` to contain `Doc`
 * Add `impAnnDoc`
+* Add `ifBootstrap`
 
 ## 1.16.1.0
 

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

@@ -285,7 +285,7 @@ govStatePrevGovActionIds = view $ proposalsGovStateL . pRootsL . to toPrevGovAct
 
 conwayGovStateDRepDistrG ::
   SimpleGetter (ConwayGovState era) (Map (DRep (EraCrypto era)) (CompactForm Coin))
-conwayGovStateDRepDistrG = to (\govst -> (psDRepDistr . fst) $ finishDRepPulser (cgsDRepPulsingState govst))
+conwayGovStateDRepDistrG = to (psDRepDistr . fst . finishDRepPulser . cgsDRepPulsingState)
 
 getRatifyState :: ConwayGovState era -> RatifyState era
 getRatifyState (ConwayGovState {cgsDRepPulsingState}) = snd $ finishDRepPulser cgsDRepPulsingState

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

@@ -13,9 +13,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuantifiedConstraints #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 

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

@@ -54,10 +54,8 @@ import Cardano.Ledger.Conway.TxCert (
  )
 import Cardano.Ledger.Shelley.API (
   CertState (..),
-  DState,
   PState (..),
   PoolEnv (PoolEnv),
-  VState,
  )
 import Cardano.Ledger.Shelley.Rules (PoolEvent, ShelleyPOOL, ShelleyPoolPredFailure)
 import Control.DeepSeq (NFData)
@@ -174,9 +172,9 @@ instance
 instance
   forall era.
   ( Era era
-  , State (EraRule "DELEG" era) ~ DState era
+  , State (EraRule "DELEG" era) ~ CertState era
   , State (EraRule "POOL" era) ~ PState era
-  , State (EraRule "GOVCERT" era) ~ VState era
+  , State (EraRule "GOVCERT" era) ~ CertState era
   , Environment (EraRule "DELEG" era) ~ ConwayDelegEnv era
   , Environment (EraRule "POOL" era) ~ PoolEnv era
   , Environment (EraRule "GOVCERT" era) ~ ConwayGovCertEnv era
@@ -201,9 +199,9 @@ instance
 
 certTransition ::
   forall era.
-  ( State (EraRule "DELEG" era) ~ DState era
+  ( State (EraRule "DELEG" era) ~ CertState era
   , State (EraRule "POOL" era) ~ PState era
-  , State (EraRule "GOVCERT" era) ~ VState era
+  , State (EraRule "GOVCERT" era) ~ CertState era
   , Environment (EraRule "DELEG" era) ~ ConwayDelegEnv era
   , Environment (EraRule "POOL" era) ~ PoolEnv era
   , Environment (EraRule "GOVCERT" era) ~ ConwayGovCertEnv era
@@ -217,22 +215,19 @@ certTransition ::
   ) =>
   TransitionRule (ConwayCERT era)
 certTransition = do
-  TRC (CertEnv slot pp currentEpoch committee committeeProposals, cState, c) <- judgmentContext
+  TRC (CertEnv slot pp currentEpoch committee committeeProposals, certState, c) <- judgmentContext
   let
-    CertState {certDState, certPState, certVState} = cState
+    CertState {certPState} = certState
     pools = psStakePoolParams certPState
   case c of
     ConwayTxCertDeleg delegCert -> do
-      newDState <- trans @(EraRule "DELEG" era) $ TRC (ConwayDelegEnv pp pools, certDState, delegCert)
-      pure $ cState {certDState = newDState}
+      trans @(EraRule "DELEG" era) $ TRC (ConwayDelegEnv pp pools, certState, delegCert)
     ConwayTxCertPool poolCert -> do
       newPState <- trans @(EraRule "POOL" era) $ TRC (PoolEnv slot pp, certPState, poolCert)
-      pure $ cState {certPState = newPState}
+      pure $ certState {certPState = newPState}
     ConwayTxCertGov govCert -> do
-      newVState <-
-        trans @(EraRule "GOVCERT" era) $
-          TRC (ConwayGovCertEnv pp currentEpoch committee committeeProposals, certVState, govCert)
-      pure $ cState {certVState = newVState}
+      trans @(EraRule "GOVCERT" era) $
+        TRC (ConwayGovCertEnv pp currentEpoch committee committeeProposals, certState, govCert)
 
 instance
   ( Era era

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

@@ -31,6 +31,15 @@ import Cardano.Ledger.Binary.Coders (
   (!>),
   (<!),
  )
+import Cardano.Ledger.CertState (
+  CertState (..),
+  DState (..),
+  certDStateL,
+  certVStateL,
+  dsUnifiedL,
+  vsDReps,
+  vsDRepsL,
+ )
 import Cardano.Ledger.Coin (Coin)
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Era (ConwayDELEG, ConwayEra)
@@ -39,12 +48,13 @@ import Cardano.Ledger.Conway.TxCert (
   Delegatee (DelegStake, DelegStakeVote, DelegVote),
  )
 import Cardano.Ledger.Credential (Credential)
+import Cardano.Ledger.DRep (DRep (..), DRepState (..))
 import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
 import Cardano.Ledger.PoolParams (PoolParams)
-import Cardano.Ledger.Shelley.LedgerState (DState (..))
+import qualified Cardano.Ledger.Shelley.HardForks as HF
 import qualified Cardano.Ledger.UMap as UM
 import Control.DeepSeq (NFData)
-import Control.Monad (forM_, guard)
+import Control.Monad (forM_, guard, unless)
 import Control.State.Transition (
   BaseM,
   Environment,
@@ -63,18 +73,15 @@ import Control.State.Transition (
 import Data.Map (Map)
 import qualified Data.Map.Strict as Map
 import Data.Maybe (isJust)
+import Data.Set as Set
 import Data.Void (Void)
 import GHC.Generics (Generic)
-import Lens.Micro ((^.))
+import Lens.Micro ((%~), (&), (.~), (^.))
 import NoThunks.Class (NoThunks)
 
 data ConwayDelegEnv era = ConwayDelegEnv
   { cdePParams :: PParams era
-  , cdePools ::
-      !( Map
-          (KeyHash 'StakePool (EraCrypto era))
-          (PoolParams (EraCrypto era))
-       )
+  , cdePools :: Map (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
   }
   deriving (Generic)
 
@@ -86,18 +93,19 @@ instance EraPParams era => EncCBOR (ConwayDelegEnv era) where
             !> To cdePParams
             !> To cdePools
 
-instance NFData (PParams era) => NFData (ConwayDelegEnv era)
+instance (Era era, NFData (PParams era)) => NFData (ConwayDelegEnv era)
 
 deriving instance Eq (PParams era) => Eq (ConwayDelegEnv era)
 
 deriving instance Show (PParams era) => Show (ConwayDelegEnv era)
 
 data ConwayDelegPredFailure era
-  = IncorrectDepositDELEG !Coin
-  | StakeKeyRegisteredDELEG !(Credential 'Staking (EraCrypto era))
-  | StakeKeyNotRegisteredDELEG !(Credential 'Staking (EraCrypto era))
-  | StakeKeyHasNonZeroRewardAccountBalanceDELEG !Coin
-  | DelegateeNotRegisteredDELEG !(KeyHash 'StakePool (EraCrypto era))
+  = IncorrectDepositDELEG Coin
+  | StakeKeyRegisteredDELEG (Credential 'Staking (EraCrypto era))
+  | StakeKeyNotRegisteredDELEG (Credential 'Staking (EraCrypto era))
+  | StakeKeyHasNonZeroRewardAccountBalanceDELEG Coin
+  | DelegateeDRepNotRegisteredDELEG (Credential 'DRepRole (EraCrypto era))
+  | DelegateeStakePoolNotRegisteredDELEG (KeyHash 'StakePool (EraCrypto era))
   deriving (Show, Eq, Generic)
 
 type instance EraRuleFailure "DELEG" (ConwayEra c) = ConwayDelegPredFailure (ConwayEra c)
@@ -121,28 +129,31 @@ instance Era era => EncCBOR (ConwayDelegPredFailure era) where
         Sum (StakeKeyNotRegisteredDELEG @era) 3 !> To stakeCred
       StakeKeyHasNonZeroRewardAccountBalanceDELEG mCoin ->
         Sum (StakeKeyHasNonZeroRewardAccountBalanceDELEG @era) 4 !> To mCoin
-      DelegateeNotRegisteredDELEG delegatee ->
-        Sum (DelegateeNotRegisteredDELEG @era) 6 !> To delegatee
+      DelegateeDRepNotRegisteredDELEG delegatee ->
+        Sum (DelegateeDRepNotRegisteredDELEG @era) 5 !> To delegatee
+      DelegateeStakePoolNotRegisteredDELEG delegatee ->
+        Sum (DelegateeStakePoolNotRegisteredDELEG @era) 6 !> To delegatee
 
 instance Era era => DecCBOR (ConwayDelegPredFailure era) where
   decCBOR = decode $ Summands "ConwayDelegPredFailure" $ \case
     1 -> SumD IncorrectDepositDELEG <! From
     2 -> SumD StakeKeyRegisteredDELEG <! From
     3 -> SumD StakeKeyNotRegisteredDELEG <! From
     4 -> SumD StakeKeyHasNonZeroRewardAccountBalanceDELEG <! From
-    6 -> SumD DelegateeNotRegisteredDELEG <! From
+    5 -> SumD DelegateeDRepNotRegisteredDELEG <! From
+    6 -> SumD DelegateeStakePoolNotRegisteredDELEG <! From
     n -> Invalid n
 
 instance
   ( EraPParams era
-  , State (EraRule "DELEG" era) ~ DState era
+  , State (EraRule "DELEG" era) ~ CertState era
   , Signal (EraRule "DELEG" era) ~ ConwayDelegCert (EraCrypto era)
   , Environment (EraRule "DELEG" era) ~ ConwayDelegEnv era
   , EraRule "DELEG" era ~ ConwayDELEG era
   ) =>
   STS (ConwayDELEG era)
   where
-  type State (ConwayDELEG era) = DState era
+  type State (ConwayDELEG era) = CertState era
   type Signal (ConwayDELEG era) = ConwayDelegCert (EraCrypto era)
   type Environment (ConwayDELEG era) = ConwayDelegEnv era
   type BaseM (ConwayDELEG era) = ShelleyBase
@@ -155,7 +166,7 @@ conwayDelegTransition :: forall era. EraPParams era => TransitionRule (ConwayDEL
 conwayDelegTransition = do
   TRC
     ( ConwayDelegEnv pp pools
-      , dState@DState {dsUnified}
+      , certState@CertState {certDState = DState {dsUnified}}
       , cert
       ) <-
     judgmentContext
@@ -166,33 +177,74 @@ conwayDelegTransition = do
     registerStakeCredential stakeCred =
       let rdPair = UM.RDPair (UM.CompactCoin 0) (UM.compactCoinOrError ppKeyDeposit)
        in UM.insert stakeCred rdPair $ UM.RewDepUView dsUnified
-    delegStake stakeCred sPool umap =
-      UM.SPoolUView umap UM.⨃ Map.singleton stakeCred sPool
-    delegVote stakeCred dRep umap =
-      UM.DRepUView umap UM.⨃ Map.singleton stakeCred dRep
+    delegStake stakeCred sPool cState =
+      cState
+        & certDStateL . dsUnifiedL %~ \umap ->
+          UM.SPoolUView umap UM.⨃ Map.singleton stakeCred sPool
+    delegVote stakeCred dRep cState =
+      let cState' =
+            cState
+              & certDStateL . dsUnifiedL %~ \umap ->
+                UM.DRepUView umap UM.⨃ Map.singleton stakeCred dRep
+          dReps = vsDReps (certVState cState)
+       in case dRep of
+            DRepCredential targetDRep
+              | Just dRepState <- Map.lookup targetDRep dReps ->
+                  let dRepState' = dRepState {drepDelegs = Set.insert stakeCred (drepDelegs dRepState)}
+                   in cState' & certVStateL . vsDRepsL .~ Map.insert targetDRep dRepState' dReps
+            _ -> cState'
+    unDelegVote stakeCred vState = \case
+      DRepCredential dRepCred ->
+        let removeDelegation dRepState =
+              dRepState {drepDelegs = Set.delete stakeCred (drepDelegs dRepState)}
+         in vState & vsDRepsL %~ Map.adjust removeDelegation dRepCred
+      _ -> vState
     processDelegation stakeCred delegatee =
       case delegatee of
         DelegStake sPool -> delegStake stakeCred sPool
         DelegVote dRep -> delegVote stakeCred dRep
         DelegStakeVote sPool dRep -> delegVote stakeCred dRep . delegStake stakeCred sPool
+    processUnDelegation _ Nothing cState = cState
+    processUnDelegation stakeCred (Just delegatee) cState@(CertState {certVState}) =
+      case delegatee of
+        DelegStake _ -> cState
+        DelegVote dRep -> cState {certVState = unDelegVote stakeCred certVState dRep}
+        DelegStakeVote _sPool dRep -> cState {certVState = unDelegVote stakeCred certVState dRep}
     checkStakeKeyNotRegistered stakeCred =
       UM.notMember stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyRegisteredDELEG stakeCred
-    checkStakeKeyIsRegistered stakeCred =
-      UM.member stakeCred (UM.RewDepUView dsUnified) ?! StakeKeyNotRegisteredDELEG stakeCred
+    checkStakeKeyIsRegistered stakeCred = do
+      let mUMElem = Map.lookup stakeCred (UM.umElems dsUnified)
+      isJust mUMElem ?! StakeKeyNotRegisteredDELEG stakeCred
+      pure $ mUMElem >>= umElemToDelegatee
     checkStakeDelegateeRegistered =
       let checkPoolRegistered targetPool =
-            targetPool `Map.member` pools ?! DelegateeNotRegisteredDELEG targetPool
+            targetPool `Map.member` pools ?! DelegateeStakePoolNotRegisteredDELEG targetPool
+          checkDRepRegistered = \case
+            DRepAlwaysAbstain -> pure ()
+            DRepAlwaysNoConfidence -> pure ()
+            DRepCredential targetDRep -> do
+              let dReps = vsDReps (certVState certState)
+              unless (HF.bootstrapPhase (pp ^. ppProtocolVersionL)) $
+                targetDRep `Map.member` dReps ?! DelegateeDRepNotRegisteredDELEG targetDRep
        in \case
             DelegStake targetPool -> checkPoolRegistered targetPool
-            DelegStakeVote targetPool _ -> checkPoolRegistered targetPool
-            DelegVote _ -> pure ()
+            DelegStakeVote targetPool targetDRep ->
+              checkPoolRegistered targetPool >> checkDRepRegistered targetDRep
+            DelegVote targetDRep -> checkDRepRegistered targetDRep
+    umElemToDelegatee (UM.UMElem _ _ mPool mDRep) =
+      case (mPool, mDRep) of
+        (SNothing, SNothing) -> Nothing
+        (SJust pool, SNothing) -> Just $ DelegStake pool
+        (SNothing, SJust dRep) -> Just $ DelegVote dRep
+        (SJust pool, SJust dRep) -> Just $ DelegStakeVote pool dRep
   case cert of
     ConwayRegCert stakeCred sMayDeposit -> do
       forM_ sMayDeposit checkDepositAgainstPParams
       checkStakeKeyNotRegistered stakeCred
-      pure $ dState {dsUnified = registerStakeCredential stakeCred}
+      pure $ certState & certDStateL . dsUnifiedL .~ registerStakeCredential stakeCred
     ConwayUnRegCert stakeCred sMayRefund -> do
       let (mUMElem, umap) = UM.extractStakingCredential stakeCred dsUnified
+          mCurDelegatee = mUMElem >>= umElemToDelegatee
           checkInvalidRefund = do
             SJust suppliedRefund <- Just sMayRefund
             -- we don't want to report invalid refund when stake credential is not registered:
@@ -207,16 +259,15 @@ conwayDelegTransition = do
       failOnJust checkInvalidRefund IncorrectDepositDELEG
       isJust mUMElem ?! StakeKeyNotRegisteredDELEG stakeCred
       failOnJust checkStakeKeyHasZeroRewardBalance StakeKeyHasNonZeroRewardAccountBalanceDELEG
-      pure $ dState {dsUnified = umap}
+      pure $ processUnDelegation stakeCred mCurDelegatee $ certState & certDStateL . dsUnifiedL .~ umap
     ConwayDelegCert stakeCred delegatee -> do
-      checkStakeKeyIsRegistered stakeCred
+      mCurDelegatee <- checkStakeKeyIsRegistered stakeCred
       checkStakeDelegateeRegistered delegatee
-      pure $ dState {dsUnified = processDelegation stakeCred delegatee dsUnified}
+      pure $ processDelegation stakeCred delegatee $ processUnDelegation stakeCred mCurDelegatee certState
     ConwayRegDelegCert stakeCred delegatee deposit -> do
       checkDepositAgainstPParams deposit
       checkStakeKeyNotRegistered stakeCred
       checkStakeDelegateeRegistered delegatee
       pure $
-        dState
-          { dsUnified = processDelegation stakeCred delegatee $ registerStakeCredential stakeCred
-          }
+        processDelegation stakeCred delegatee $
+          certState & certDStateL . dsUnifiedL .~ registerStakeCredential stakeCred

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

@@ -328,7 +328,7 @@ epochTransition = do
     stakePoolDistr = ssStakeMarkPoolDistr snapshots1
     pulsingState = epochState0 ^. epochStateDRepPulsingStateL
 
-    ratState0@RatifyState {rsEnactState, rsEnacted, rsExpired} =
+    ratifyState@RatifyState {rsEnactState, rsEnacted, rsExpired} =
       extractDRepPulsingState pulsingState
 
     (accountState2, dState2, EnactState {..}) =
@@ -401,7 +401,7 @@ epochTransition = do
         & esAccountStateL .~ accountState3
         & esSnapshotsL .~ snapshots1
         & esLStateL .~ ledgerState1
-  tellEvent $ EpochBoundaryRatifyState ratState0
+  tellEvent $ EpochBoundaryRatifyState ratifyState
   epochState2 <- do
     let curPv = epochState1 ^. curPParamsEpochStateL . ppProtocolVersionL
     if curPv /= epochState1 ^. prevPParamsEpochStateL . ppProtocolVersionL