From 027d90bb00f3851886d639683eff3046c11f3918 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 12 Aug 2025 11:40:23 +0100 Subject: [PATCH 01/11] Add some lenses for `PoolParams` and `StakePoolState` fields --- libs/cardano-ledger-core/CHANGELOG.md | 1 + .../src/Cardano/Ledger/State/StakePool.hs | 17 +++++++++++++++++ 2 files changed, 18 insertions(+) diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index ead0e468aca..8967f850f99 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -5,6 +5,7 @@ * Deprecate `costModelParamsCount` in favor of `costModelInitParamCount` * Add `costModelInitParamNames`, `costModelInitParamCount`, `parseCostModelAsArray` and `parseCostModelAsMap` * Export `credToDRep` and `dRepToCred` +* Add `ppVrfL`, `ppCostL`, `ppMetadataL`, `spsVrfL` to `StakePool` module * Deprecate `PoolParams` in favor of `StakePoolState`. #5196 * Move the `PoolParams` module to `Cardano.Ledger.State.StakePool` and export from there. * Add the `StakePoolState` data type to the new module. diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs index 5872710a442..74b33bcada5 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/StakePool.hs @@ -40,6 +40,10 @@ module Cardano.Ledger.State.StakePool ( StakePoolRelay (..), SizeOfPoolRelays (..), SizeOfPoolOwners (..), + ppCostL, + ppMetadataL, + ppVrfL, + spsVrfL, ) where import Cardano.Ledger.Address (RewardAccount) @@ -97,6 +101,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Word (Word8) import GHC.Generics (Generic) +import Lens.Micro import NoThunks.Class (NoThunks (..)) -- | State representation of a stake pool. This type contains all the same @@ -122,6 +127,9 @@ data StakePoolState = StakePoolState } deriving (Show, Generic, Eq, Ord) +spsVrfL :: Lens' StakePoolState (VRFVerKeyHash 'StakePoolVRF) +spsVrfL = lens spsVrf (\sps u -> sps {spsVrf = u}) + deriving instance NoThunks StakePoolState deriving instance NFData StakePoolState @@ -348,6 +356,15 @@ data PoolParams = PoolParams deriving (EncCBOR) via CBORGroup PoolParams deriving (DecCBOR) via CBORGroup PoolParams +ppVrfL :: Lens' PoolParams (VRFVerKeyHash 'StakePoolVRF) +ppVrfL = lens ppVrf (\pp u -> pp {ppVrf = u}) + +ppCostL :: Lens' PoolParams Coin +ppCostL = lens ppCost (\pp u -> pp {ppCost = u}) + +ppMetadataL :: Lens' PoolParams (StrictMaybe PoolMetadata) +ppMetadataL = lens ppMetadata (\pp u -> pp {ppMetadata = u}) + instance Default PoolParams where def = PoolParams def def (Coin 0) (Coin 0) def def def def def From e8edba88506137ebf39a0a12a2e22062b7248d45 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Mon, 11 Aug 2025 13:32:39 +0100 Subject: [PATCH 02/11] Add Imp spec to test pool (re)registration and retiring --- .../Test/Cardano/Ledger/Allegra/Imp.hs | 7 +- .../testlib/Test/Cardano/Ledger/Alonzo/Imp.hs | 2 + .../Test/Cardano/Ledger/Babbage/Imp.hs | 2 + .../testlib/Test/Cardano/Ledger/Conway/Imp.hs | 2 + .../Test/Cardano/Ledger/Conway/Spec.hs | 2 + .../testlib/Test/Cardano/Ledger/Mary/Imp.hs | 7 +- .../shelley/impl/cardano-ledger-shelley.cabal | 1 + .../Test/Cardano/Ledger/Shelley/Imp.hs | 11 +- .../Cardano/Ledger/Shelley/Imp/PoolSpec.hs | 241 ++++++++++++++++++ 9 files changed, 271 insertions(+), 4 deletions(-) create mode 100644 eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs diff --git a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs b/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs index c9814b4c05f..13f4c2f8100 100644 --- a/eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs +++ b/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 ) => diff --git a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs b/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs index bfc64400736..9ffc8b1eb62 100644 --- a/eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs +++ b/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 diff --git a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs b/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs index 418c76ed171..6bceca0ce84 100644 --- a/eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs +++ b/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 diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs index 1cc4e194d03..19c5c347257 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs +++ b/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, ) @@ -75,6 +76,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 diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Spec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Spec.hs index ad89fa41251..6477b4e2eb8 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Spec.hs +++ b/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 diff --git a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs b/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs index 921572c7ada..67db4a9e6fe 100644 --- a/eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs +++ b/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 diff --git a/eras/shelley/impl/cardano-ledger-shelley.cabal b/eras/shelley/impl/cardano-ledger-shelley.cabal index 927d8dda129..9f266e7f945 100644 --- a/eras/shelley/impl/cardano-ledger-shelley.cabal +++ b/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 diff --git a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs index b23d258004f..dd7406e0430 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs @@ -7,10 +7,15 @@ module Test.Cardano.Ledger.Shelley.Imp (spec) where import Cardano.Ledger.Core -import Cardano.Ledger.Shelley.Rules (ShelleyUtxoPredFailure, ShelleyUtxowPredFailure) +import Cardano.Ledger.Shelley.Rules ( + ShelleyPoolPredFailure, + ShelleyUtxoPredFailure, + ShelleyUtxowPredFailure, + ) import Test.Cardano.Ledger.Imp.Common import qualified Test.Cardano.Ledger.Shelley.Imp.EpochSpec as Epoch import qualified Test.Cardano.Ledger.Shelley.Imp.LedgerSpec as Ledger +import qualified Test.Cardano.Ledger.Shelley.Imp.PoolSpec as Pool import qualified Test.Cardano.Ledger.Shelley.Imp.UtxoSpec as Utxo import qualified Test.Cardano.Ledger.Shelley.Imp.UtxowSpec as Utxow import Test.Cardano.Ledger.Shelley.ImpTest @@ -21,12 +26,14 @@ spec :: ( ShelleyEraImp era , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era + , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era ) => Spec spec = do describe "ShelleyImpSpec" $ withEachEraVersion @era $ do - Ledger.spec Epoch.spec + Ledger.spec + Pool.spec Utxow.spec Utxo.spec describe "ShelleyPureTests" $ do 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 new file mode 100644 index 00000000000..c7d0104b768 --- /dev/null +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +module Test.Cardano.Ledger.Shelley.Imp.PoolSpec (spec) where + +import Cardano.Crypto.Hash.Class (sizeHash) +import Cardano.Ledger.Address (RewardAccount (..)) +import Cardano.Ledger.BaseTypes +import Cardano.Ledger.Coin +import Cardano.Ledger.Core +import Cardano.Ledger.Credential (Credential (..)) +import Cardano.Ledger.Shelley.LedgerState +import Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure (..)) +import Cardano.Ledger.State (PoolMetadata (..), ppCostL, ppMetadataL, ppVrfL, spsVrf) +import qualified Data.Map.Strict as Map +import Data.Proxy +import Lens.Micro +import Test.Cardano.Ledger.Binary.Arbitrary (genByteString) +import Test.Cardano.Ledger.Imp.Common +import Test.Cardano.Ledger.Shelley.ImpTest + +spec :: + forall era. + ( ShelleyEraImp era + , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era + ) => + SpecWith (ImpInit (LedgerSpec era)) +spec = describe "POOL" $ do + describe "Register and re-register pools" $ do + it "register a pool with too low cost" $ do + (kh, vrf) <- (,) <$> freshKeyHash <*> freshKeyHashVRF + minPoolCost <- getsPParams ppMinPoolCostL + tooLowCost <- Coin <$> choose (0, unCoin minPoolCost) + let pps = (\p -> p & ppCostL .~ tooLowCost) <$> poolParams kh vrf + registerPoolTx <$> pps >>= \tx -> + submitFailingTx + tx + [injectFailure $ StakePoolCostTooLowPOOL $ Mismatch tooLowCost minPoolCost] + + it "register a pool with a reward account having the wrong network id" $ do + pv <- getsPParams ppProtocolVersionL + rewardCredential <- KeyHashObj <$> freshKeyHash + let badRewardAccount = + RewardAccount + { raNetwork = Mainnet + , raCredential = rewardCredential + } + kh <- freshKeyHash + let pps = freshPoolParams kh badRewardAccount + registerPoolTx <$> pps >>= \tx -> + if pvMajor pv < natVersion @5 + then + submitTx_ tx + else + submitFailingTx tx [injectFailure $ WrongNetworkPOOL (Mismatch Mainnet Testnet) kh] + + it "register a pool with too big metadata" $ do + pv <- getsPParams ppProtocolVersionL + let maxMetadataSize = sizeHash (Proxy :: Proxy HASH) + tooBigSize <- choose (maxMetadataSize + 1, maxMetadataSize + 50) + metadataHash <- liftGen $ genByteString $ fromIntegral tooBigSize + url <- arbitrary + let metadata = PoolMetadata url metadataHash + (kh, vrf) <- (,) <$> freshKeyHash <*> freshKeyHashVRF + let pps = (\p -> p & ppMetadataL .~ SJust metadata) <$> poolParams kh vrf + registerPoolTx <$> pps >>= \tx -> + if pvMajor pv < natVersion @5 + then + submitTx_ tx + else + submitFailingTx tx [injectFailure $ PoolMedataHashTooBig kh (fromIntegral tooBigSize)] + + it "register a new pool with an already registered VRF" $ do + (kh, vrf) <- registerNewPool + khNew <- freshKeyHash + registerPoolTx <$> poolParams khNew vrf >>= submitTx_ + expectPool khNew (Just vrf) + expectPool kh (Just vrf) + + it "re-register a pool with an already registered VRF" $ do + (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) + + it "re-register a pool with its own VRF" $ do + (kh, vrf) <- registerNewPool + registerPoolTx <$> poolParams kh vrf >>= submitTx_ + expectPool kh (Just vrf) + expectFuturePool kh (Just vrf) + passEpoch + expectPool kh (Just vrf) + expectFuturePool kh Nothing + + it "re-register a pool with a fresh VRF" $ do + (kh, vrf) <- registerNewPool + vrfNew <- freshKeyHashVRF + registerPoolTx <$> poolParams kh vrfNew >>= submitTx_ + expectPool kh (Just vrf) + expectFuturePool kh (Just vrfNew) + passEpoch + expectPool kh (Just vrfNew) + + describe "Retiring pools" $ do + it "retire an unregistered pool" $ do + khNew <- freshKeyHash + retirePoolTx khNew (EpochInterval 10) >>= \tx -> + submitFailingTx tx [injectFailure $ StakePoolNotRegisteredOnKeyPOOL khNew] + + it "retire a pool with too high a retirement epoch" $ do + (kh, _) <- registerNewPool + maxRetireInterval <- getsPParams ppEMaxL + curEpochNo <- getsNES nesELL + let maxRetireIntervalPlus = + EpochInterval $ fromIntegral $ unEpochInterval maxRetireInterval + 1 + let supplied = addEpochInterval curEpochNo maxRetireIntervalPlus + + retirePoolTx kh maxRetireIntervalPlus >>= \tx -> + submitFailingTx + tx + [ injectFailure $ + StakePoolRetirementWrongEpochPOOL + (Mismatch supplied curEpochNo) + (Mismatch supplied (addEpochInterval curEpochNo maxRetireInterval)) + ] + expectRetiring False kh + + it "retire a pool with too low a retirement epoch" $ do + (kh, _) <- registerNewPool + curEpochNo <- getsNES nesELL + maxRetireInterval <- getsPParams ppEMaxL + retirePoolTx kh (EpochInterval 0) >>= \tx -> + submitFailingTx + tx + [ injectFailure $ + StakePoolRetirementWrongEpochPOOL + (Mismatch curEpochNo curEpochNo) + (Mismatch curEpochNo (addEpochInterval curEpochNo maxRetireInterval)) + ] + expectRetiring False kh + + it "re-register a retiring pool with an already registered vrf" $ do + (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) + + it "re-register retiring pool with its own VRF" $ do + (kh, vrf) <- registerNewPool + retirePoolTx kh (EpochInterval 10) >>= submitTx_ + expectRetiring True kh + registerPoolTx <$> poolParams kh vrf >>= submitTx_ + expectPool kh (Just vrf) + expectRetiring False kh + + it "re-register a retiring pool with a fresh VRF" $ do + (kh, _) <- registerNewPool + retirePoolTx kh (EpochInterval 10) >>= submitTx_ + vrfNew <- freshKeyHashVRF + registerPoolTx <$> poolParams kh vrfNew >>= submitTx_ + expectRetiring False kh + expectFuturePool kh (Just vrfNew) + passEpoch + expectPool kh (Just vrfNew) + + it "register a pool with the VRF of a retiring pool" $ do + (kh, vrf) <- registerNewPool + let retirement = 1 + retirePoolTx kh (EpochInterval retirement) >>= submitTx_ + khNew <- freshKeyHash + registerPoolTx <$> poolParams khNew vrf >>= submitTx_ + expectPool khNew (Just vrf) + expectRetiring True kh + passNEpochs (fromIntegral retirement) + expectPool khNew (Just vrf) + expectRetiring False khNew + expectPool kh Nothing + + describe "Retired pools" $ do + it "re-register a pool with the same keyhash and VRF " $ do + (kh, vrf) <- registerNewPool + let retirement = 1 + retirePoolTx kh (EpochInterval retirement) >>= submitTx_ + passNEpochs (fromIntegral retirement) + expectPool kh Nothing + registerPoolTx <$> poolParams kh vrf >>= submitTx_ + expectPool kh (Just vrf) + + it "register a pool with the VRF of a retired pool" $ do + (kh, vrf) <- registerNewPool + let retirement = 1 + retirePoolTx kh (EpochInterval retirement) >>= submitTx_ + expectRetiring True kh + passNEpochs (fromIntegral retirement) + expectRetiring False kh + khNew <- freshKeyHash + registerPoolTx <$> poolParams khNew vrf >>= submitTx_ + expectPool khNew (Just vrf) + expectRetiring False khNew + where + registerNewPool = do + (kh, vrf) <- (,) <$> freshKeyHash <*> freshKeyHashVRF + registerPoolTx <$> poolParams kh vrf >>= submitTx_ + expectPool kh (Just vrf) + pure (kh, vrf) + registerPoolTx pps = + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL .~ [RegPoolTxCert pps] + retirePoolTx kh retirementInterval = do + curEpochNo <- getsNES nesELL + let retirement = addEpochInterval curEpochNo retirementInterval + pure $ + mkBasicTx mkBasicTxBody + & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert kh retirement] + expectPool poolKh mbVrf = do + pps <- psStakePools <$> getPState + spsVrf <$> Map.lookup poolKh pps `shouldBe` mbVrf + expectFuturePool poolKh mbVrf = do + fps <- psFutureStakePools <$> getPState + spsVrf <$> Map.lookup poolKh fps `shouldBe` mbVrf + expectRetiring isRetiring poolKh = do + retiring <- psRetiring <$> getPState + assertBool + ("Expected 'retiring' status of: " <> show poolKh <> " to be: " <> show isRetiring) + $ Map.member poolKh retiring == isRetiring + poolParams kh vrf = do + pps <- registerRewardAccount >>= freshPoolParams kh + pure $ pps & ppVrfL .~ vrf + getPState = getsNES @era $ nesEsL . esLStateL . lsCertStateL . certPStateL From 7dcfc838fbffa0323778e44f89ed7305d3d5d89a Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 12 Aug 2025 12:22:58 +0100 Subject: [PATCH 03/11] Add VRF keyhashes to `PState` --- .../src/Cardano/Ledger/Shelley/LedgerState.hs | 1 + .../Ledger/Shelley/Examples/Combinators.hs | 1 + .../Shelley/Serialisation/Golden/Encoding.hs | 2 +- libs/cardano-ledger-core/CHANGELOG.md | 2 ++ .../src/Cardano/Ledger/State/CertState.hs | 31 ++++++++++++------- .../Test/Cardano/Ledger/Core/Arbitrary.hs | 2 +- .../Constrained/Conway/LedgerTypes/Specs.hs | 2 +- .../Cardano/Ledger/Constrained/Conway/Pool.hs | 2 +- .../Test/Cardano/Ledger/Generic/GenState.hs | 3 +- .../Test/Cardano/Ledger/Generic/ModelState.hs | 5 ++- 10 files changed, 34 insertions(+), 17 deletions(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs index 9abb6b86dbc..7c68f5d802f 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs +++ b/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, diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs index 191e2fe5c6f..f4bbe20035b 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Examples/Combinators.hs @@ -376,6 +376,7 @@ reapPool pool cs = cs {chainNes = nes'} { psRetiring = Map.delete poolId (psRetiring ps) , psStakePools = Map.delete poolId (psStakePools ps) , psDeposits = Map.delete poolId (psDeposits ps) + , psVRFKeyHashes = Set.delete (ppVrf pool) (psVRFKeyHashes ps) } pp = es ^. curPParamsEpochStateL ds = dps ^. certDStateL diff --git a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs index 694df27d3dc..6ca3d8e2268 100644 --- a/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs +++ b/eras/shelley/test-suite/test/Test/Cardano/Ledger/Shelley/Serialisation/Golden/Encoding.hs @@ -1086,7 +1086,7 @@ tests = mconcat [ "8700a1581ce0a714319812c3f773ba04ec5d6b3ffcd5aad85006805b047b0825410aa158" , "1ca646474b8f5431261506b6c273d307c7569a4eb6c96b42dd4a29520a03848219271019" - , "03e8828284a0a0a0a08482a0a0a0a084a0a0000086a15822ee155ace9c40292074cb6aff" + , "03e882828580a0a0a0a08482a0a0a0a084a0a0000086a15822ee155ace9c40292074cb6aff" , "8c9ccdd273c81648ff1149ef36bcea6ebb8a3e250000583d003900cb9358529df4729c32" , "46a2a033cb9821abbfd16de4888005904abc410d6a577e9441ad8ed9663931906e4d43ec" , "e8f82c712b1d0235affb06000a1903e80185a0a091000000190800000000001864d81e82" diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md index 8967f850f99..61939fa69dc 100644 --- a/libs/cardano-ledger-core/CHANGELOG.md +++ b/libs/cardano-ledger-core/CHANGELOG.md @@ -2,6 +2,8 @@ ## 1.18.0.0 +* Add `psVRFKeyHashes` to `PState` +* Add `psVRFKeyHashesL` * Deprecate `costModelParamsCount` in favor of `costModelInitParamCount` * Add `costModelInitParamNames`, `costModelInitParamCount`, `parseCostModelAsArray` and `parseCostModelAsMap` * Export `credToDRep` and `dRepToCred` diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs index 6b0ebccaa91..c96a021df9a 100644 --- a/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/State/CertState.hs @@ -45,6 +45,7 @@ module Cardano.Ledger.State.CertState ( psRetiringL, psDepositsL, psDepositsCompactL, + psVRFKeyHashesL, ) where import Cardano.Ledger.BaseTypes ( @@ -87,6 +88,7 @@ import qualified Data.Foldable as F import Data.Kind (Type) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map +import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) import Lens.Micro (Lens', lens, (^.), _1) @@ -225,7 +227,9 @@ lookupRewardDState DState {dsAccounts} cred = do -- | The state used by the POOL rule, which tracks stake pool information. data PState era = PState - { psStakePools :: !(Map (KeyHash 'StakePool) StakePoolState) + { psVRFKeyHashes :: !(Set (VRFVerKeyHash 'StakePoolVRF)) + -- ^ VRF key hashes that have been registered via PoolParams + , psStakePools :: !(Map (KeyHash 'StakePool) StakePoolState) -- ^ The state of current stake pools. , psFutureStakePools :: !(Map (KeyHash 'StakePool) StakePoolState) -- ^ The state of future stake pools. @@ -246,24 +250,26 @@ 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 d e) = + encodeListLen 5 <> encCBOR a <> encCBOR b <> encCBOR c <> encCBOR d <> encCBOR e instance DecShareCBOR (PState era) where type Share (PState era) = Interns (KeyHash 'StakePool) - decSharePlusCBOR = decodeRecordNamedT "PState" (const 4) $ do + decSharePlusCBOR = decodeRecordNamedT "PState" (const 5) $ do + psVRFKeyHashes <- lift decCBOR 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 {psVRFKeyHashes, psStakePools, psFutureStakePools, psRetiring, psDeposits} instance (Era era, DecShareCBOR (PState era)) => DecCBOR (PState era) where decCBOR = decNoShareCBOR instance ToKeyValuePairs (PState era) where toKeyValuePairs PState {..} = - [ "stakePools" .= psStakePools + [ "vrfKeyHashes" .= psVRFKeyHashes + , "stakePools" .= psStakePools , "futureStakePools" .= psFutureStakePools , "retiring" .= psRetiring , "deposits" .= psDeposits @@ -396,7 +402,7 @@ instance Default (Accounts era) => Default (DState era) where instance Default (PState era) where def = - PState Map.empty Map.empty Map.empty Map.empty + PState Set.empty Map.empty Map.empty Map.empty Map.empty -- ========================================================== -- Functions that handle Deposits @@ -482,16 +488,19 @@ 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}) +psStakePoolsL = lens psStakePools (\ps u -> ps {psStakePools = u}) psFutureStakePoolsL :: Lens' (PState era) (Map (KeyHash 'StakePool) StakePoolState) -psFutureStakePoolsL = lens psFutureStakePools (\ds u -> ds {psFutureStakePools = u}) +psFutureStakePoolsL = lens psFutureStakePools (\ps u -> ps {psFutureStakePools = u}) psRetiringL :: Lens' (PState era) (Map (KeyHash 'StakePool) EpochNo) -psRetiringL = lens psRetiring (\ds u -> ds {psRetiring = u}) +psRetiringL = lens psRetiring (\ps u -> ps {psRetiring = u}) 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 psDeposits (\ps u -> ps {psDeposits = u}) + +psVRFKeyHashesL :: Lens' (PState era) (Set (VRFVerKeyHash 'StakePoolVRF)) +psVRFKeyHashesL = lens psVRFKeyHashes (\ps u -> ps {psVRFKeyHashes = u}) diff --git a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs index 39457132527..922982259f3 100644 --- a/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs +++ b/libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Arbitrary.hs @@ -782,7 +782,7 @@ instance (Era era, Arbitrary (Accounts era)) => Arbitrary (DState era) where arbitrary = DState <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary (PState era) where - arbitrary = PState <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + arbitrary = PState <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary instance Arbitrary Anchor where arbitrary = Anchor <$> arbitrary <*> arbitrary diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Specs.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Specs.hs index 57dba161ce9..d108edc1e80 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Specs.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/LedgerTypes/Specs.hs @@ -371,7 +371,7 @@ pStateSpec :: Term EpochNo -> Specification (PState era) pStateSpec univ currepoch = constrained $ \ [var|pState|] -> - match pState $ \ [var|stakePoolParams|] [var|futureStakePoolParams|] [var|retiring|] [var|pooldeposits|] -> + match pState $ \_ [var|stakePoolParams|] [var|futureStakePoolParams|] [var|retiring|] [var|pooldeposits|] -> [ witness univ (dom_ stakePoolParams) , witness univ (rng_ stakePoolParams) , witness univ (dom_ futureStakePoolParams) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Pool.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Pool.hs index 8c21e40635a..87c3f7b302e 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Pool.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Conway/Pool.hs @@ -44,7 +44,7 @@ pStateSpec :: WitUniv era -> Specification (PState era) pStateSpec univ = constrained $ \ps -> - match ps $ \stakePoolParams futureStakePoolParams retiring deposits -> + match ps $ \_ stakePoolParams futureStakePoolParams retiring deposits -> [ witness univ (dom_ stakePoolParams) , witness univ (rng_ stakePoolParams) , witness univ (dom_ futureStakePoolParams) diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs index 4273093375b..d0156f393dc 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/GenState.hs @@ -672,7 +672,8 @@ initialLedgerState gstate = LedgerState utxostate dpstate Map.empty genDelegsZero instantaneousRewardsZero - pstate = PState (mkStakePoolState <$> pools) Map.empty Map.empty (fmap (const poolDeposit) pools) + pstate = + PState Set.empty (mkStakePoolState <$> pools) Map.empty Map.empty (fmap (const poolDeposit) pools) -- In a wellformed LedgerState the deposited equals the obligation deposited = totalObligation dpstate (utxostate ^. utxosGovStateL) pools = gsInitialPoolParams gstate diff --git a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs index 4ac6c15fb48..401a2c086ee 100644 --- a/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs +++ b/libs/cardano-ledger-test/src/Test/Cardano/Ledger/Generic/ModelState.hs @@ -61,6 +61,7 @@ import Data.Default (Default (def)) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe.Strict (StrictMaybe (..)) +import qualified Data.Set as Set import Data.TreeDiff (Expr, ToExpr (toExpr)) import GHC.Generics (Generic) import GHC.Natural (Natural) @@ -161,7 +162,8 @@ dStateZero = pStateZero :: PState era pStateZero = PState - { psStakePools = Map.empty + { psVRFKeyHashes = Set.empty + , psStakePools = Map.empty , psFutureStakePools = Map.empty , psRetiring = Map.empty , psDeposits = Map.empty @@ -265,6 +267,7 @@ instance Extract (DState era) era where instance Extract (PState era) era where extract x = PState + Set.empty (mkStakePoolState <$> mPoolParams x) (mkStakePoolState <$> mFPoolParams x) (mRetiring x) From 05e2559ea4bb2c6df10ec97f459ee5795dbe60cf Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 7 Aug 2025 12:24:53 +0100 Subject: [PATCH 04/11] Add `ShelleyPoolPredFailure` for duplicate VRF keys --- eras/shelley/impl/CHANGELOG.md | 1 + .../src/Cardano/Ledger/Shelley/Rules/Pool.hs | 23 +++++++++++++++---- 2 files changed, 20 insertions(+), 4 deletions(-) diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 52ddd3b4070..4242bc2ee9d 100644 --- a/eras/shelley/impl/CHANGELOG.md +++ b/eras/shelley/impl/CHANGELOG.md @@ -2,6 +2,7 @@ ## 1.17.0.0 +* 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`. diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs index 7b5c5252e83..095d327d653 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -91,7 +91,8 @@ instance NFData (PParams era) => NFData (PoolEnv era) data ShelleyPoolPredFailure era = StakePoolNotRegisteredOnKeyPOOL - (KeyHash 'StakePool) -- KeyHash which cannot be retired since it is not registered + -- | KeyHash which cannot be retired since it is not registered + (KeyHash 'StakePool) | StakePoolRetirementWrongEpochPOOL (Mismatch 'RelGT EpochNo) (Mismatch 'RelLTEQ EpochNo) @@ -99,10 +100,18 @@ data ShelleyPoolPredFailure era (Mismatch 'RelGTEQ Coin) | WrongNetworkPOOL (Mismatch 'RelEQ Network) - (KeyHash 'StakePool) -- Stake Pool ID + -- | Stake Pool ID + (KeyHash 'StakePool) | PoolMedataHashTooBig - (KeyHash 'StakePool) -- Stake Pool ID - Int -- Size of the metadata hash + -- | Stake Pool ID + (KeyHash 'StakePool) + -- | Size of the metadata hash + Int + | VRFKeyHashAlreadyRegistered + -- | Stake Pool ID + (KeyHash 'StakePool) + -- | VRF key attempted to use, that has already been registered + (VRFVerKeyHash 'StakePoolVRF) deriving (Eq, Show, Generic) type instance EraRuleFailure "POOL" ShelleyEra = ShelleyPoolPredFailure ShelleyEra @@ -149,6 +158,8 @@ instance Era era => EncCBOR (ShelleyPoolPredFailure era) where encodeListLen 4 <> encCBOR (4 :: Word8) <> encCBOR expected <> encCBOR supplied <> encCBOR c PoolMedataHashTooBig a b -> encodeListLen 3 <> encCBOR (5 :: Word8) <> encCBOR a <> encCBOR b + VRFKeyHashAlreadyRegistered a b -> + encodeListLen 3 <> encCBOR (6 :: Word8) <> encCBOR a <> encCBOR b -- `ShelleyPoolPredFailure` is used in Conway POOL rule, so we need to keep the serialization unchanged instance Era era => DecCBOR (ShelleyPoolPredFailure era) where @@ -181,6 +192,10 @@ instance Era era => DecCBOR (ShelleyPoolPredFailure era) where poolID <- decCBOR s <- decCBOR pure (3, PoolMedataHashTooBig poolID s) + 6 -> do + poolID <- decCBOR + vrfKeyHash <- decCBOR + pure (3, VRFKeyHashAlreadyRegistered poolID vrfKeyHash) k -> invalidKey k poolDelegationTransition :: From f119c14de0c3554040be8a15c06398ab0002c09c Mon Sep 17 00:00:00 2001 From: teodanciu Date: Tue, 12 Aug 2025 18:55:04 +0100 Subject: [PATCH 05/11] Disallow duplicate VRF keys in stake pool registration starting with v11 --- eras/shelley/impl/CHANGELOG.md | 1 + .../impl/src/Cardano/Ledger/Shelley/Era.hs | 6 ++ .../src/Cardano/Ledger/Shelley/Rules/Pool.hs | 31 +++++++-- .../Cardano/Ledger/Shelley/Rules/PoolReap.hs | 19 ++++-- .../Cardano/Ledger/Shelley/Imp/PoolSpec.hs | 65 ++++++++++++++----- 5 files changed, 95 insertions(+), 27 deletions(-) diff --git a/eras/shelley/impl/CHANGELOG.md b/eras/shelley/impl/CHANGELOG.md index 4242bc2ee9d..9b1c2ec4175 100644 --- 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 index 35c65d4f120..42fc1b91a13 100644 --- 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 index 095d327d653..e97111a5fb5 100644 --- 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 index 3439987d9b6..e422b7e5520 100644 --- 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 index c7d0104b768..610c179dede 100644 --- 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 From 553efb09ce6be797f9339d6170774297d7ddd601 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 13 Aug 2025 12:45:46 +0100 Subject: [PATCH 06/11] Add more test cases for reusing VRF keys --- .../Cardano/Ledger/Shelley/Imp/PoolSpec.hs | 78 ++++++++++++++++++- 1 file changed, 77 insertions(+), 1 deletion(-) 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 index 610c179dede..d97cb6043fc 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs @@ -123,6 +123,78 @@ spec = describe "POOL" $ do expectFuturePool kh (Just vrfNew) passEpoch expectPool kh (Just vrfNew) + expectVRFs [vrfNew] + -- now the original VRF can be reused + khNew <- freshKeyHash + registerPoolTx <$> poolParams khNew vrf >>= submitTx_ + expectVRFs [vrf, vrfNew] + + it "register a new pool with the VRF of a re-registered pool " $ do + pv <- getsPParams ppProtocolVersionL + (kh, _) <- registerNewPool + vrfNew <- freshKeyHashVRF + -- re-register pool with a new vrf + registerPoolTx <$> poolParams kh vrfNew >>= submitTx_ + passEpoch + -- try to register a new pool with the new vrf + khNew <- freshKeyHash + registerPoolTx <$> poolParams khNew vrfNew >>= \tx -> + if pvMajor pv < natVersion @11 + then do + submitTx_ tx + expectPool kh (Just vrfNew) + expectPool khNew (Just vrfNew) + else + submitFailingTx tx [injectFailure $ VRFKeyHashAlreadyRegistered khNew vrfNew] + + it "after the epoch changes, reuse VRFs that get overwritten" $ do + (kh, vrf) <- registerNewPool + vrf1 <- freshKeyHashVRF + registerPoolTx <$> poolParams kh vrf1 >>= submitTx_ + expectVRFs [vrf, vrf1] + vrf2 <- freshKeyHashVRF + registerPoolTx <$> poolParams kh vrf2 >>= submitTx_ + expectVRFs [vrf, vrf2] + vrf3 <- freshKeyHashVRF + registerPoolTx <$> poolParams kh vrf3 >>= submitTx_ + expectVRFs [vrf, vrf3] + passEpoch + expectPool kh (Just vrf3) + expectVRFs [vrf3] + -- reuse VRFs that didn't get used + khNew <- freshKeyHash + registerPoolTx <$> poolParams khNew vrf1 >>= submitTx_ + expectPool khNew (Just vrf1) + expectVRFs [vrf1, vrf3] + -- the original pool can be re-registered with one of the discarded VRFs too + registerPoolTx <$> poolParams kh vrf2 >>= submitTx_ + expectVRFs [vrf1, vrf2, vrf3] + passEpoch + expectVRFs [vrf1, vrf2] + -- the original pool can be re-registered with the original VRF too + registerPoolTx <$> poolParams kh vrf >>= submitTx_ + expectVRFs [vrf, vrf1, vrf2] + passEpoch + expectVRFs [vrf, vrf1] + + it "before the epoch changes, try to reuse VRFs that get overwritten" $ do + pv <- getsPParams ppProtocolVersionL + (kh, vrf) <- registerNewPool + vrfNew <- freshKeyHashVRF + registerPoolTx <$> poolParams kh vrfNew >>= submitTx_ + -- try to register a pool with the original VRF that got overwritten + khNew <- freshKeyHash + registerPoolTx <$> poolParams khNew vrf >>= \tx -> + if pvMajor pv < natVersion @11 + then do + submitTx_ tx + expectPool kh (Just vrf) + expectPool khNew (Just vrf) + passEpoch + expectPool kh (Just vrfNew) + expectPool khNew (Just vrf) + else do + submitFailingTx tx [injectFailure $ VRFKeyHashAlreadyRegistered khNew vrf] describe "Retiring pools" $ do it "retire an unregistered pool" $ do @@ -189,7 +261,7 @@ spec = describe "POOL" $ do expectRetiring False kh it "re-register a retiring pool with a fresh VRF" $ do - (kh, _) <- registerNewPool + (kh, vrf) <- registerNewPool retirePoolTx kh (EpochInterval 10) >>= submitTx_ vrfNew <- freshKeyHashVRF registerPoolTx <$> poolParams kh vrfNew >>= submitTx_ @@ -197,6 +269,10 @@ spec = describe "POOL" $ do expectFuturePool kh (Just vrfNew) passEpoch expectPool kh (Just vrfNew) + expectVRFs [vrfNew] + -- now the original VRF can be reused + khNew <- freshKeyHash + registerPoolTx <$> poolParams khNew vrf >>= submitTx_ it "register a pool with the VRF of a retiring pool" $ do pv <- getsPParams ppProtocolVersionL From ab60e1588b1877399249f1add07e9902b789f128 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 13 Aug 2025 21:36:12 +0100 Subject: [PATCH 07/11] Remove future VRFS from set of known VRFs on pool re-registration --- .../impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs index e97111a5fb5..7eaf2a3d5c4 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -215,7 +215,7 @@ poolDelegationTransition :: poolDelegationTransition = do TRC ( PoolEnv cEpoch pp - , ps@PState {psStakePools, psVRFKeyHashes} + , ps@PState {psStakePools, psFutureStakePools, psVRFKeyHashes} , poolCert ) <- judgmentContext @@ -269,9 +269,17 @@ poolDelegationTransition = do & psVRFKeyHashesL %~ Set.insert ppVrf Just _ -> do -- re-register Pool + + -- If a pool re-registers with a fresh VRF, we have to add it to the list, + -- but also remove the previous VRFHashKey potentially stored in previous re-registration within the same epoch, + -- which we can retrieve from futureStakePools. We first delete and then insert the new one, + -- so in case they are the same, it will still end up in the set. let updateVRFs | hasMatchingVRF = id - | otherwise = psVRFKeyHashesL %~ Set.insert ppVrf + | otherwise = psVRFKeyHashesL %~ (Set.insert ppVrf . withoutFutureVrf) + where + withoutFutureVrf s = maybe s (`Set.delete` s) futureVrf + futureVrf = (^. spsVrfL) <$> Map.lookup ppId psFutureStakePools 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 From 3804cae42f66d677ecf703e9b55fc92bc88d557a Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 13 Aug 2025 21:37:10 +0100 Subject: [PATCH 08/11] Remove dangling VRFs from set of known VRFs in `PoolReap` --- .../Cardano/Ledger/Shelley/Rules/PoolReap.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs index e422b7e5520..3c1bd557a9e 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/PoolReap.hs @@ -48,6 +48,7 @@ import Control.State.Transition ( ) import Data.Default (Default, def) import Data.Foldable (fold) +import qualified Data.Map.Merge.Strict as Map import qualified Data.Map.Strict as Map import Data.Set (Set) import qualified Data.Set as Set @@ -128,6 +129,20 @@ poolReapTransition = do TRC (_, PoolreapState us a cs0, e) <- judgmentContext let ps0 = cs0 ^. certPStateL + -- find the set of VRF key hashes that are no longer relevant, since they have been overwritten + -- via pool re-registration + danglingVrfKeyHashes = + Set.fromList $ + Map.elems $ + Map.merge + Map.dropMissing + Map.dropMissing + ( Map.zipWithMaybeMatched $ \_ sps spsF -> + if sps ^. spsVrfL /= spsF ^. spsVrfL then Just (sps ^. spsVrfL) else Nothing + ) + (ps0 ^. psStakePoolsL) + (ps0 ^. psFutureStakePoolsL) + -- activate future stakePools ps = ps0 @@ -202,7 +217,8 @@ poolReapTransition = do & certPStateL . psStakePoolsL %~ (`Map.withoutKeys` retired) & certPStateL . psRetiringL %~ (`Map.withoutKeys` retired) & certPStateL . psDepositsCompactL .~ remainingDeposits - & certPStateL . psVRFKeyHashesL %~ (`Set.difference` retiredVRFs) + & certPStateL . psVRFKeyHashesL + %~ ((`Set.difference` retiredVRFs) . (`Set.difference` danglingVrfKeyHashes)) ) renderPoolReapViolation :: From a5e8010d17c8388c30f8dbd383a596002605b086 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 20 Aug 2025 13:08:53 +0100 Subject: [PATCH 09/11] Implement suggested changes for predicate failure and state update --- .../src/Cardano/Ledger/Shelley/Rules/Pool.hs | 52 +++++++++---------- .../Cardano/Ledger/Shelley/Imp/PoolSpec.hs | 3 +- 2 files changed, 28 insertions(+), 27 deletions(-) diff --git a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs index 7eaf2a3d5c4..fca00d9c308 100644 --- a/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs +++ b/eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Pool.hs @@ -249,37 +249,37 @@ poolDelegationTransition = do { mismatchSupplied = ppCost , mismatchExpected = minPoolCost } - 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 + case Map.lookup ppId psStakePools of + -- register new, Pool-Reg Nothing -> do - -- register new, Pool-Reg + when (hardforkConwayDisallowDuplicatedVRFKeys pv) $ do + Set.notMember ppVrf psVRFKeyHashes ?! VRFKeyHashAlreadyRegistered ppId ppVrf + let updateVRFKeyHash + | hardforkConwayDisallowDuplicatedVRFKeys pv = Set.insert ppVrf + | otherwise = id tellEvent $ RegisterPool ppId pure $ payPoolDeposit ppId pp $ ps & psStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams) - & psVRFKeyHashesL %~ Set.insert ppVrf - Just _ -> do - -- re-register Pool - - -- If a pool re-registers with a fresh VRF, we have to add it to the list, - -- but also remove the previous VRFHashKey potentially stored in previous re-registration within the same epoch, - -- which we can retrieve from futureStakePools. We first delete and then insert the new one, - -- so in case they are the same, it will still end up in the set. - let updateVRFs - | hasMatchingVRF = id - | otherwise = psVRFKeyHashesL %~ (Set.insert ppVrf . withoutFutureVrf) - where - withoutFutureVrf s = maybe s (`Set.delete` s) futureVrf - futureVrf = (^. spsVrfL) <$> Map.lookup ppId psFutureStakePools + & psVRFKeyHashesL %~ updateVRFKeyHash + -- re-register Pool + Just stakePoolState -> do + when (hardforkConwayDisallowDuplicatedVRFKeys pv) $ do + ppVrf == stakePoolState ^. spsVrfL + || Set.notMember ppVrf psVRFKeyHashes ?! VRFKeyHashAlreadyRegistered ppId ppVrf + let updateFutureVRFKeyHash + | hardforkConwayDisallowDuplicatedVRFKeys pv = + -- If a pool re-registers with a fresh VRF, we have to add it to the list, + -- but also remove the previous VRFHashKey potentially stored in previous re-registration within the same epoch, + -- which we retrieve from futureStakePools. + case Map.lookup ppId psFutureStakePools of + Nothing -> Set.insert ppVrf + Just futureStakePoolState + | futureStakePoolState ^. spsVrfL /= ppVrf -> + Set.insert ppVrf . Set.delete (futureStakePoolState ^. spsVrfL) + | otherwise -> id + | otherwise = id 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 @@ -294,7 +294,7 @@ poolDelegationTransition = do ps & psFutureStakePoolsL %~ Map.insert ppId (mkStakePoolState poolParams) & psRetiringL %~ Map.delete ppId - & updateVRFs + & psVRFKeyHashesL %~ updateFutureVRFKeyHash RetirePool ppId e -> do Map.member ppId psStakePools ?! StakePoolNotRegisteredOnKeyPOOL ppId let maxEpoch = pp ^. ppEMaxL 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 index d97cb6043fc..7de07d2d026 100644 --- a/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs +++ b/eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs @@ -343,7 +343,8 @@ spec = describe "POOL" $ do ("Expected 'retiring' status of: " <> show poolKh <> " to be: " <> show isRetiring) $ Map.member poolKh retiring == isRetiring expectVRFs vrfs = do - (^. psVRFKeyHashesL) <$> getPState `shouldReturn` vrfs + whenMajorVersionAtLeast @11 $ + psVRFKeyHashes <$> getPState `shouldReturn` vrfs poolParams kh vrf = do pps <- registerRewardAccount >>= freshPoolParams kh pure $ pps & ppVrfL .~ vrf From 505717ddfa8f31554b1436233e236ecbd3a7ee12 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 20 Aug 2025 17:30:05 +0100 Subject: [PATCH 10/11] Extract drep delegation in HardFork rule in a separate function to make it easier to add branches --- .../Cardano/Ledger/Conway/Rules/HardFork.hs | 58 ++++++++++--------- 1 file changed, 30 insertions(+), 28 deletions(-) diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs index d7ad8a89698..ec39d9f42cc 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs @@ -67,31 +67,33 @@ 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 + | 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 From a5543c165d850d40679a6d1cb04f5dd16c0663e0 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 20 Aug 2025 23:39:21 +0100 Subject: [PATCH 11/11] Update HardFork rule to populate VRF key hashes --- eras/conway/impl/cardano-ledger-conway.cabal | 1 + .../Cardano/Ledger/Conway/Rules/HardFork.hs | 10 +++ .../testlib/Test/Cardano/Ledger/Conway/Imp.hs | 2 + .../Cardano/Ledger/Conway/Imp/HardForkSpec.hs | 77 +++++++++++++++++++ 4 files changed, 90 insertions(+) create mode 100644 eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/HardForkSpec.hs diff --git a/eras/conway/impl/cardano-ledger-conway.cabal b/eras/conway/impl/cardano-ledger-conway.cabal index 5dd46fa8a97..6dcaa88f502 100644 --- a/eras/conway/impl/cardano-ledger-conway.cabal +++ b/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 diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs index ec39d9f42cc..5bda4c996fd 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/HardFork.hs @@ -70,6 +70,8 @@ hardforkTransition = do let update | pvMajor newPv == natVersion @10 = esLStateL . lsCertStateL %~ updateDRepDelegations + | pvMajor newPv == natVersion @11 = + esLStateL . lsCertStateL . certPStateL %~ populateVRFKeyHashes | otherwise = id pure $ update epochState @@ -97,3 +99,11 @@ updateDRepDelegations certState = & 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 diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs index 19c5c347257..7c5a7c94c4d 100644 --- a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs +++ b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs @@ -53,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 @@ -139,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 diff --git a/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/HardForkSpec.hs b/eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp/HardForkSpec.hs new file mode 100644 index 00000000000..520b25a5ea9 --- /dev/null +++ b/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