Disallow duplicate VRF keys for pool registration

eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs

@@ -8,7 +8,11 @@
 module Test.Cardano.Ledger.Allegra.Imp (spec) where
 
 import Cardano.Ledger.Core
-import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure)
+import Cardano.Ledger.Shelley.Rules (
+  ShelleyPoolPredFailure,
+  ShelleyUtxoPredFailure,
+  ShelleyUtxowPredFailure,
+ )
 import qualified Test.Cardano.Ledger.Allegra.Imp.UtxowSpec as UtxowSpec
 import Test.Cardano.Ledger.Imp.Common
 import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp
@@ -17,6 +21,7 @@ import Test.Cardano.Ledger.Shelley.ImpTest
 spec ::
   forall era.
   ( ShelleyEraImp era
+  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
   ) =>

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs

@@ -15,6 +15,7 @@ import Cardano.Ledger.Alonzo.Rules (
  )
 import Cardano.Ledger.Shelley.Rules (
   ShelleyDelegPredFailure,
+  ShelleyPoolPredFailure,
   ShelleyUtxoPredFailure,
   ShelleyUtxowPredFailure,
  )
@@ -29,6 +30,7 @@ spec ::
   forall era.
   ( AlonzoEraImp era
   , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs

@@ -19,6 +19,7 @@ import Cardano.Ledger.Babbage.TxInfo (BabbageContextError)
 import Cardano.Ledger.BaseTypes (Inject)
 import Cardano.Ledger.Shelley.Rules (
   ShelleyDelegPredFailure,
+  ShelleyPoolPredFailure,
   ShelleyUtxoPredFailure,
   ShelleyUtxowPredFailure,
  )
@@ -34,6 +35,7 @@ spec ::
   ( AlonzoEraImp era
   , BabbageEraTxBody era
   , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era

eras/conway/impl/cardano-ledger-conway.cabal

@@ -146,6 +146,7 @@ library testlib
     Test.Cardano.Ledger.Conway.Imp.EpochSpec
     Test.Cardano.Ledger.Conway.Imp.GovCertSpec
     Test.Cardano.Ledger.Conway.Imp.GovSpec
+    Test.Cardano.Ledger.Conway.Imp.HardForkSpec
     Test.Cardano.Ledger.Conway.Imp.LedgerSpec
     Test.Cardano.Ledger.Conway.Imp.RatifySpec
     Test.Cardano.Ledger.Conway.Imp.UtxoSpec

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

@@ -67,31 +67,43 @@ hardforkTransition = do
   TRC (_, epochState, newPv) <-
     judgmentContext
   tellEvent $ ConwayHardForkEvent newPv
-  if pvMajor newPv == natVersion @10
-    then
-      pure $
-        epochState
-          & esLStateL . lsCertStateL %~ \certState ->
-            let accountsMap = certState ^. certDStateL . accountsL . accountsMapL
-                dReps =
-                  -- Reset all delegations in order to remove any inconsistencies
-                  -- Delegations will be reset accordingly below.
-                  Map.map (\dRepState -> dRepState {drepDelegs = Set.empty}) $
-                    certState ^. certVStateL . vsDRepsL
-                (dRepsWithDelegations, accountsWithoutUnknownDRepDelegations) =
-                  Map.mapAccumWithKey adjustDelegations dReps accountsMap
-                adjustDelegations ds stakeCred accountState =
-                  case accountState ^. dRepDelegationAccountStateL of
-                    Just (DRepCredential dRep) ->
-                      let addDelegation _ dRepState =
-                            Just $ dRepState {drepDelegs = Set.insert stakeCred (drepDelegs dRepState)}
-                       in case Map.updateLookupWithKey addDelegation dRep ds of
-                            (Nothing, _) -> (ds, accountState & dRepDelegationAccountStateL .~ Nothing)
-                            (Just _, ds') -> (ds', accountState)
-                    _ -> (ds, accountState)
-             in certState
-                  -- Remove dangling delegations to non-existent DReps:
-                  & certDStateL . accountsL . accountsMapL .~ accountsWithoutUnknownDRepDelegations
-                  -- Populate DRep delegations with delegatees
-                  & certVStateL . vsDRepsL .~ dRepsWithDelegations
-    else pure epochState
+  let update
+        | pvMajor newPv == natVersion @10 =
+            esLStateL . lsCertStateL %~ updateDRepDelegations
+        | pvMajor newPv == natVersion @11 =
+            esLStateL . lsCertStateL . certPStateL %~ populateVRFKeyHashes
+        | otherwise = id
+  pure $ update epochState
+
+updateDRepDelegations :: ConwayEraCertState era => CertState era -> CertState era
+updateDRepDelegations certState =
+  let accountsMap = certState ^. certDStateL . accountsL . accountsMapL
+      dReps =
+        -- Reset all delegations in order to remove any inconsistencies
+        -- Delegations will be reset accordingly below.
+        Map.map (\dRepState -> dRepState {drepDelegs = Set.empty}) $
+          certState ^. certVStateL . vsDRepsL
+      (dRepsWithDelegations, accountsWithoutUnknownDRepDelegations) =
+        Map.mapAccumWithKey adjustDelegations dReps accountsMap
+      adjustDelegations ds stakeCred accountState =
+        case accountState ^. dRepDelegationAccountStateL of
+          Just (DRepCredential dRep) ->
+            let addDelegation _ dRepState =
+                  Just $ dRepState {drepDelegs = Set.insert stakeCred (drepDelegs dRepState)}
+             in case Map.updateLookupWithKey addDelegation dRep ds of
+                  (Nothing, _) -> (ds, accountState & dRepDelegationAccountStateL .~ Nothing)
+                  (Just _, ds') -> (ds', accountState)
+          _ -> (ds, accountState)
+   in certState
+        -- Remove dangling delegations to non-existent DReps:
+        & certDStateL . accountsL . accountsMapL .~ accountsWithoutUnknownDRepDelegations
+        -- Populate DRep delegations with delegatees
+        & certVStateL . vsDRepsL .~ dRepsWithDelegations
+
+populateVRFKeyHashes :: PState era -> PState era
+populateVRFKeyHashes pState =
+  let allVRFKeyHashes =
+        spsVrf
+          <$> Map.elems (pState ^. psStakePoolsL)
+            <> Map.elems (pState ^. psFutureStakePoolsL)
+   in pState & psVRFKeyHashesL .~ Set.fromList allVRFKeyHashes

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

@@ -39,6 +39,7 @@ import Cardano.Ledger.Plutus (Language (..))
 import Cardano.Ledger.Shelley.API.Mempool (ApplyTx (..))
 import Cardano.Ledger.Shelley.Rules (
   ShelleyDelegPredFailure,
+  ShelleyPoolPredFailure,
   ShelleyUtxoPredFailure,
   ShelleyUtxowPredFailure,
  )
@@ -52,6 +53,7 @@ import qualified Test.Cardano.Ledger.Conway.Imp.EnactSpec as Enact
 import qualified Test.Cardano.Ledger.Conway.Imp.EpochSpec as Epoch
 import qualified Test.Cardano.Ledger.Conway.Imp.GovCertSpec as GovCert
 import qualified Test.Cardano.Ledger.Conway.Imp.GovSpec as Gov
+import qualified Test.Cardano.Ledger.Conway.Imp.HardForkSpec as HardFork
 import qualified Test.Cardano.Ledger.Conway.Imp.LedgerSpec as Ledger
 import qualified Test.Cardano.Ledger.Conway.Imp.RatifySpec as Ratify
 import qualified Test.Cardano.Ledger.Conway.Imp.UtxoSpec as Utxo
@@ -75,6 +77,7 @@ spec ::
   , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era
   , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era
   , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
@@ -137,6 +140,7 @@ conwaySpec = do
   describe "GOV" Gov.spec
   describe "GOVCERT" GovCert.spec
   describe "LEDGER" Ledger.spec
+  describe "HARDFORK" HardFork.spec
   describe "RATIFY" Ratify.spec
   describe "UTXO" Utxo.spec
   describe "UTXOS" Utxos.spec

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

@@ -0,0 +1,77 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Test.Cardano.Ledger.Conway.Imp.HardForkSpec (spec) where
+
+import Cardano.Ledger.BaseTypes
+import Cardano.Ledger.Conway.Core
+import Cardano.Ledger.Conway.Governance
+import Cardano.Ledger.Conway.PParams
+import Cardano.Ledger.Conway.State
+import Cardano.Ledger.Shelley.LedgerState
+import qualified Data.Set as Set
+import Lens.Micro
+import Test.Cardano.Ledger.Conway.ImpTest
+import Test.Cardano.Ledger.Core.Rational
+import Test.Cardano.Ledger.Imp.Common
+
+spec ::
+  forall era.
+  ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
+spec = do
+  it "VRF Keyhashes get populated at v11 HardFork" $ do
+    -- Since we're testing the HardFork to 11, the test only makes sense for protocol version 10
+    whenMajorVersion @10 $ do
+      (kh1, vrf1) <- (,) <$> freshKeyHash <*> freshKeyHashVRF
+      registerStakePool kh1 vrf1
+      (kh2, vrf2) <- (,) <$> freshKeyHash <*> freshKeyHashVRF
+      registerStakePool kh2 vrf2
+      vrf3 <- freshKeyHashVRF
+      -- re-register with a new key, so vrf1 should not be present after the hard fork
+      registerStakePool kh1 vrf3
+      -- register a new pool with an existing vrf
+      kh3 <- freshKeyHash
+      registerStakePool kh3 vrf2
+      -- register and retire a pool before the hard fork, so vrf4 should not be present after the hard fork
+      (kh4, vrf4) <- (,) <$> freshKeyHash <*> freshKeyHashVRF
+      registerStakePool kh4 vrf4
+      retireStakePool kh4 (EpochInterval 1)
+      -- register and schedule retirement for after the hard fork, so vrf5 should be present after the hard fork
+      (kh5, vrf5) <- (,) <$> freshKeyHash <*> freshKeyHashVRF
+      registerStakePool kh5 vrf5
+      retireStakePool kh5 (EpochInterval 5)
+
+      expectVRFs [] -- VRF keyhashes in PState is not yet populated
+      enactHardForkV11
+      expectVRFs [vrf2, vrf3, vrf5]
+  where
+    enactHardForkV11 = do
+      modifyPParams $ \pp ->
+        pp
+          & ppDRepVotingThresholdsL . dvtHardForkInitiationL .~ 0 %! 1
+          & ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 0 %! 1
+      let pv11 = ProtVer (natVersion @11) 0
+      committee <- registerInitialCommittee
+      govActionId <- submitGovAction $ HardForkInitiation SNothing pv11
+      submitYesVoteCCs_ committee govActionId
+      passNEpochs 2
+      getProtVer `shouldReturn` pv11
+    registerStakePool kh vrf = do
+      pps <- registerRewardAccount >>= freshPoolParams kh
+      submitTx_ $
+        mkBasicTx mkBasicTxBody
+          & bodyTxL . certsTxBodyL .~ [RegPoolTxCert $ pps & ppVrfL .~ vrf]
+    retireStakePool kh retirementInterval = do
+      curEpochNo <- getsNES nesELL
+      let retirement = addEpochInterval curEpochNo retirementInterval
+      submitTx_ $
+        mkBasicTx mkBasicTxBody
+          & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert kh retirement]
+    expectVRFs vrfs =
+      psVRFKeyHashes <$> getPState `shouldReturn` Set.fromList vrfs
+    getPState = getsNES @era $ nesEsL . esLStateL . lsCertStateL . certPStateL

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

@@ -51,6 +51,7 @@ import Cardano.Ledger.Shelley.API (ApplyTx)
 import Cardano.Ledger.Shelley.LedgerState (StashedAVVMAddresses)
 import Cardano.Ledger.Shelley.Rules (
   ShelleyDelegPredFailure,
+  ShelleyPoolPredFailure,
   ShelleyUtxoPredFailure,
   ShelleyUtxowPredFailure,
  )
@@ -102,6 +103,7 @@ spec ::
   , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era
   , InjectRuleFailure "LEDGER" ConwayGovCertPredFailure era
   , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era

eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs

@@ -8,7 +8,11 @@
 module Test.Cardano.Ledger.Mary.Imp (spec) where
 
 import Cardano.Ledger.Mary.Core
-import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure)
+import Cardano.Ledger.Shelley.Rules (
+  ShelleyPoolPredFailure,
+  ShelleyUtxoPredFailure,
+  ShelleyUtxowPredFailure,
+ )
 import qualified Test.Cardano.Ledger.Allegra.Imp as AllegraImp
 import Test.Cardano.Ledger.Imp.Common
 import qualified Test.Cardano.Ledger.Mary.Imp.UtxoSpec as Utxo
@@ -19,6 +23,7 @@ spec ::
   ( MaryEraImp era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   ) =>
   Spec
 spec = do

eras/shelley/impl/CHANGELOG.md

@@ -2,6 +2,8 @@
 
 ## 1.17.0.0
 
+* Add `hardforkConwayDisallowDuplicatedVRFKeys`
+* Add `VRFKeyHashAlreadyRegistered` to `ShelleyPoolPredFailure` type
 * Add `NFData` for `NominalDiffTimeMicro`, `ShelleyGenesisStaking` and `ShelleyGenesis`
 * Deprecate `PoolParams` in favor of `StakePoolState`. #5196
   * Deprecate the API `getPoolParameters` in favor of `getStakePools`.

eras/shelley/impl/cardano-ledger-shelley.cabal

@@ -147,6 +147,7 @@ library testlib
     Test.Cardano.Ledger.Shelley.Imp
     Test.Cardano.Ledger.Shelley.Imp.EpochSpec
     Test.Cardano.Ledger.Shelley.Imp.LedgerSpec
+    Test.Cardano.Ledger.Shelley.Imp.PoolSpec
     Test.Cardano.Ledger.Shelley.Imp.UtxoSpec
     Test.Cardano.Ledger.Shelley.Imp.UtxowSpec
     Test.Cardano.Ledger.Shelley.ImpTest

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

@@ -33,6 +33,7 @@ module Cardano.Ledger.Shelley.Era (
   hardforkAlonzoAllowMIRTransfer,
   hardforkAlonzoValidatePoolRewardAccountNetID,
   hardforkBabbageForgoRewardPrefilter,
+  hardforkConwayDisallowDuplicatedVRFKeys,
 ) where
 
 import Cardano.Ledger.BaseTypes (ProtVer (pvMajor), natVersion)
@@ -155,3 +156,8 @@ hardforkAlonzoValidatePoolRewardAccountNetID pv = pvMajor pv > natVersion @4
 -- See the Shelley Ledger Errata 17.2.
 hardforkBabbageForgoRewardPrefilter :: ProtVer -> Bool
 hardforkBabbageForgoRewardPrefilter pv = pvMajor pv > natVersion @6
+
+hardforkConwayDisallowDuplicatedVRFKeys ::
+  ProtVer ->
+  Bool
+hardforkConwayDisallowDuplicatedVRFKeys pv = pvMajor pv > natVersion @10

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

@@ -116,6 +116,7 @@ module Cardano.Ledger.Shelley.LedgerState (
   psFutureStakePoolsL,
   psRetiringL,
   psDepositsL,
+  psVRFKeyHashesL,
 
   -- * Lenses from SnapShot(s)
   ssStakeMarkL,