Disallow duplicate VRF keys in stake pool registration starting with v11

teodanciu · teodanciu · commit f119c14de0c3 · 2025-08-22T00:08:11.000+01:00
diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md
@@ -2,6 +2,7 @@
 
 ## 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
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Era.hs b/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
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs
@@ -49,6 +49,7 @@ import Cardano.Ledger.Shelley.Era (
   ShelleyEra,
   ShelleyPOOL,
   hardforkAlonzoValidatePoolRewardAccountNetID,
+  hardforkConwayDisallowDuplicatedVRFKeys,
  )
 import qualified Cardano.Ledger.Shelley.SoftForks as SoftForks
 import Cardano.Ledger.State
@@ -67,6 +68,7 @@ import Control.State.Transition (
 import qualified Data.ByteString as BS
 import Data.Kind (Type)
 import qualified Data.Map as Map
+import qualified Data.Set as Set
 import Data.Word (Word8)
 import GHC.Generics (Generic)
 import Lens.Micro
@@ -213,12 +215,12 @@ poolDelegationTransition ::
 poolDelegationTransition = do
   TRC
     ( PoolEnv cEpoch pp
-      , ps@PState {psStakePools}
+      , ps@PState {psStakePools, psVRFKeyHashes}
       , poolCert
       ) <-
     judgmentContext
   case poolCert of
-    RegPool poolParams@PoolParams {ppId, ppRewardAccount, ppMetadata, ppCost} -> do
+    RegPool poolParams@PoolParams {ppId, ppVrf, ppRewardAccount, ppMetadata, ppCost} -> do
       let pv = pp ^. ppProtocolVersionL
       when (hardforkAlonzoValidatePoolRewardAccountNetID pv) $ do
         actualNetID <- liftSTS $ asks networkId
@@ -247,15 +249,29 @@ poolDelegationTransition = do
               { mismatchSupplied = ppCost
               , mismatchExpected = minPoolCost
               }
-
-      if not (Map.member ppId psStakePools)
-        then do
+      let mbStakePoolState = Map.lookup ppId psStakePools
+      let hasMatchingVRF = ((^. spsVrfL) <$> mbStakePoolState) == Just ppVrf
+      when (hardforkConwayDisallowDuplicatedVRFKeys pv) $ do
+        -- if the VRF key is not associated with this pool (either because the pool is not registered
+        -- or because the VRF key is different from the one registered for this pool),
+        -- then we check that this VRF key is not already in use
+        hasMatchingVRF
+          || Set.notMember ppVrf psVRFKeyHashes
+            ?! VRFKeyHashAlreadyRegistered ppId ppVrf
+      case mbStakePoolState of
+        Nothing -> do
           -- register new, Pool-Reg
           tellEvent $ RegisterPool ppId
           pure $
             payPoolDeposit ppId pp $
-              ps & psStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams)
-        else do
+              ps
+                & psStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams)
+                & psVRFKeyHashesL %~ Set.insert ppVrf
+        Just _ -> do
+          -- re-register Pool
+          let updateVRFs
+                | hasMatchingVRF = id
+                | otherwise = psVRFKeyHashesL %~ Set.insert ppVrf
           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
@@ -270,6 +286,7 @@ poolDelegationTransition = do
             ps
               & psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams)
               & psRetiringL %~ Map.delete ppId
+              & updateVRFs
     RetirePool ppId e -> do
       Map.member ppId psStakePools ?! StakePoolNotRegisteredOnKeyPOOL ppId
       let maxEpoch = pp ^. ppEMaxL
diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs
@@ -145,10 +145,20 @@ poolReapTransition = do
     (retiringDeposits, remainingDeposits) =
       Map.partitionWithKey (\k _ -> Set.member k retired) (psDeposits 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
-    retiredStakePoolAccountsWithRefund :: Map.Map (KeyHash 'StakePool) (RewardAccount, CompactForm Coin)
-    retiredStakePoolAccountsWithRefund = Map.intersectionWith (,) retiredStakePoolAccounts retiringDeposits
+    retiredStakePoolAccountsWithVRFs ::
+      Map.Map (KeyHash 'StakePool) (RewardAccount, VRFVerKeyHash 'StakePoolVRF)
+    retiredStakePoolAccountsWithVRFs =
+      Map.map
+        (\sps -> (spsRewardAccount sps, spsVrf sps))
+        $ Map.restrictKeys (psStakePools ps) retired
+    retiredVRFs = foldMap (Set.singleton . snd) retiredStakePoolAccountsWithVRFs
+    retiredStakePoolAccountsWithRefund ::
+      Map.Map (KeyHash 'StakePool) (RewardAccount, CompactForm Coin)
+    retiredStakePoolAccountsWithRefund =
+      Map.intersectionWith
+        (\(rewardAccount, _) coin -> (rewardAccount, coin))
+        retiredStakePoolAccountsWithVRFs
+        retiringDeposits
     -- collect all of the potential refunds
     accountRefunds :: Map.Map (Credential 'Staking) (CompactForm Coin)
     accountRefunds =
@@ -192,6 +202,7 @@ poolReapTransition = do
           & certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retired)
           & certPStateL . psRetiringL %~ (`Map.withoutKeys` retired)
           & certPStateL . psDepositsCompactL .~ remainingDeposits
+          & certPStateL . psVRFKeyHashesL %~ (`Set.difference` retiredVRFs)
       )
 
 renderPoolReapViolation ::
diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs
@@ -75,21 +75,36 @@ spec = describe "POOL" $ do
             submitFailingTx tx [injectFailure $ PoolMedataHashTooBig kh (fromIntegral tooBigSize)]
 
     it "register a new pool with an already registered VRF" $ do
+      pv <- getsPParams ppProtocolVersionL
       (kh, vrf) <- registerNewPool
       khNew <- freshKeyHash
-      registerPoolTx <$> poolParams khNew vrf >>= submitTx_
-      expectPool khNew (Just vrf)
+      registerPoolTx <$> poolParams khNew vrf >>= \tx ->
+        if pvMajor pv < natVersion @11
+          then do
+            submitTx_ tx
+            expectPool khNew (Just vrf)
+          else do
+            submitFailingTx tx [injectFailure $ VRFKeyHashAlreadyRegistered khNew vrf]
+            expectPool khNew Nothing
       expectPool kh (Just vrf)
 
     it "re-register a pool with an already registered VRF" $ do
+      pv <- getsPParams ppProtocolVersionL
       (kh1, vrf1) <- registerNewPool
       (kh2, vrf2) <- registerNewPool
-      registerPoolTx <$> poolParams kh1 vrf2 >>= submitTx_
-      expectPool kh1 (Just vrf1)
-      expectFuturePool kh1 (Just vrf2)
-      passEpoch
-      expectPool kh1 (Just vrf2)
-      expectPool kh2 (Just vrf2)
+      registerPoolTx <$> poolParams kh1 vrf2 >>= \tx ->
+        if pvMajor pv < natVersion @11
+          then do
+            submitTx_ tx
+            expectPool kh1 (Just vrf1)
+            expectFuturePool kh1 (Just vrf2)
+            passEpoch
+            expectPool kh1 (Just vrf2)
+            expectPool kh2 (Just vrf2)
+          else do
+            submitFailingTx tx [injectFailure $ VRFKeyHashAlreadyRegistered kh1 vrf2]
+            expectPool kh1 (Just vrf1)
+            expectFuturePool kh1 Nothing
 
     it "re-register a pool with its own VRF" $ do
       (kh, vrf) <- registerNewPool
@@ -148,14 +163,22 @@ spec = describe "POOL" $ do
       expectRetiring False kh
 
     it "re-register a retiring pool with an already registered vrf" $ do
+      pv <- getsPParams ppProtocolVersionL
       (kh1, _) <- registerNewPool
       (_, vrf2) <- registerNewPool
       retirePoolTx kh1 (EpochInterval 10) >>= submitTx_
-      registerPoolTx <$> poolParams kh1 vrf2 >>= submitTx_
-      expectRetiring False kh1
-      expectFuturePool kh1 (Just vrf2)
-      passEpoch
-      expectPool kh1 (Just vrf2)
+      registerPoolTx <$> poolParams kh1 vrf2 >>= \tx ->
+        if pvMajor pv < natVersion @11
+          then do
+            submitTx_ tx
+            expectRetiring False kh1
+            expectFuturePool kh1 (Just vrf2)
+            passEpoch
+            expectPool kh1 (Just vrf2)
+          else do
+            submitFailingTx tx [injectFailure $ VRFKeyHashAlreadyRegistered kh1 vrf2]
+            expectRetiring True kh1
+            expectFuturePool kh1 Nothing
 
     it "re-register retiring pool with its own VRF" $ do
       (kh, vrf) <- registerNewPool
@@ -176,15 +199,21 @@ spec = describe "POOL" $ do
       expectPool kh (Just vrfNew)
 
     it "register a pool with the VRF of a retiring pool" $ do
+      pv <- getsPParams ppProtocolVersionL
       (kh, vrf) <- registerNewPool
       let retirement = 1
       retirePoolTx kh (EpochInterval retirement) >>= submitTx_
       khNew <- freshKeyHash
-      registerPoolTx <$> poolParams khNew vrf >>= submitTx_
-      expectPool khNew (Just vrf)
+      registerPoolTx <$> poolParams khNew vrf >>= \tx ->
+        if pvMajor pv < natVersion @11
+          then do
+            submitTx_ tx
+            expectPool khNew (Just vrf)
+          else do
+            submitFailingTx tx [injectFailure $ VRFKeyHashAlreadyRegistered khNew vrf]
+            expectPool khNew Nothing
       expectRetiring True kh
       passNEpochs (fromIntegral retirement)
-      expectPool khNew (Just vrf)
       expectRetiring False khNew
       expectPool kh Nothing
 
@@ -197,6 +226,7 @@ spec = describe "POOL" $ do
       expectPool kh Nothing
       registerPoolTx <$> poolParams kh vrf >>= submitTx_
       expectPool kh (Just vrf)
+      expectVRFs [vrf]
 
     it "register a pool with the VRF of a retired pool" $ do
       (kh, vrf) <- registerNewPool
@@ -209,6 +239,7 @@ spec = describe "POOL" $ do
       registerPoolTx <$> poolParams khNew vrf >>= submitTx_
       expectPool khNew (Just vrf)
       expectRetiring False khNew
+      expectVRFs [vrf]
   where
     registerNewPool = do
       (kh, vrf) <- (,) <$> freshKeyHash <*> freshKeyHashVRF
@@ -235,6 +266,8 @@ spec = describe "POOL" $ do
       assertBool
         ("Expected 'retiring' status of: " <> show poolKh <> " to be: " <> show isRetiring)
         $ Map.member poolKh retiring == isRetiring
+    expectVRFs vrfs = do
+      (^. psVRFKeyHashesL) <$> getPState `shouldReturn` vrfs
     poolParams kh vrf = do
       pps <- registerRewardAccount >>= freshPoolParams kh
       pure $ pps & ppVrfL .~ vrf
