|
| 1 | +{-# LANGUAGE BangPatterns #-} |
| 2 | +{-# LANGUAGE DataKinds #-} |
| 3 | +{-# LANGUAGE FlexibleContexts #-} |
| 4 | +{-# LANGUAGE OverloadedLists #-} |
| 5 | +{-# LANGUAGE ScopedTypeVariables #-} |
| 6 | +{-# LANGUAGE TypeApplications #-} |
| 7 | +{-# LANGUAGE TypeFamilies #-} |
| 8 | + |
| 9 | +module Test.Cardano.Ledger.Conway.Imp.HardForkSpec (spec) where |
| 10 | + |
| 11 | +import Cardano.Ledger.BaseTypes |
| 12 | +import Cardano.Ledger.Conway.Core |
| 13 | +import Cardano.Ledger.Conway.Governance |
| 14 | +import Cardano.Ledger.Conway.PParams |
| 15 | +import Cardano.Ledger.Conway.State |
| 16 | +import Cardano.Ledger.Shelley.LedgerState |
| 17 | +import qualified Data.Set as Set |
| 18 | +import Lens.Micro |
| 19 | +import Test.Cardano.Ledger.Conway.ImpTest |
| 20 | +import Test.Cardano.Ledger.Core.Rational |
| 21 | +import Test.Cardano.Ledger.Imp.Common |
| 22 | + |
| 23 | +spec :: |
| 24 | + forall era. |
| 25 | + ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era)) |
| 26 | +spec = do |
| 27 | + it "VRF Keyhashes get populated at v11 HardFork" $ do |
| 28 | + pv <- getProtVer |
| 29 | + -- Since we're testing the HardFork to 11, the test only makes sense for protocol version 10 |
| 30 | + when (pvMajor pv == natVersion @10) $ do |
| 31 | + (kh1, vrf1) <- (,) <$> freshKeyHash <*> freshKeyHashVRF |
| 32 | + registerStakePool kh1 vrf1 |
| 33 | + (kh2, vrf2) <- (,) <$> freshKeyHash <*> freshKeyHashVRF |
| 34 | + registerStakePool kh2 vrf2 |
| 35 | + vrf3 <- freshKeyHashVRF |
| 36 | + -- re-register with a new key, so vrf1 should not be present after the hard fork |
| 37 | + registerStakePool kh1 vrf3 |
| 38 | + -- register a new pool with an existing vrf |
| 39 | + kh3 <- freshKeyHash |
| 40 | + registerStakePool kh3 vrf2 |
| 41 | + -- register and retire a pool before the hard fork, so vrf4 should not be present after the hard fork |
| 42 | + (kh4, vrf4) <- (,) <$> freshKeyHash <*> freshKeyHashVRF |
| 43 | + registerStakePool kh4 vrf4 |
| 44 | + retireStakePool kh4 (EpochInterval 1) |
| 45 | + -- register and schedule retirement for after the hard fork, so vrf5 should be present after the hard fork |
| 46 | + (kh5, vrf5) <- (,) <$> freshKeyHash <*> freshKeyHashVRF |
| 47 | + registerStakePool kh5 vrf5 |
| 48 | + retireStakePool kh5 (EpochInterval 5) |
| 49 | + |
| 50 | + expectVRFs [] -- VRF keyhashes in PState is not yet populated |
| 51 | + enactHardForkV11 |
| 52 | + expectVRFs [vrf2, vrf3, vrf5] |
| 53 | + where |
| 54 | + enactHardForkV11 = do |
| 55 | + modifyPParams $ \pp -> |
| 56 | + pp |
| 57 | + & ppDRepVotingThresholdsL . dvtHardForkInitiationL .~ 0 %! 1 |
| 58 | + & ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 0 %! 1 |
| 59 | + let pv11 = ProtVer (natVersion @11) 0 |
| 60 | + committee <- registerInitialCommittee |
| 61 | + govActionId <- submitGovAction $ HardForkInitiation SNothing pv11 |
| 62 | + submitYesVoteCCs_ committee govActionId |
| 63 | + passNEpochs 2 |
| 64 | + getProtVer `shouldReturn` pv11 |
| 65 | + registerStakePool kh vrf = do |
| 66 | + pps <- registerRewardAccount >>= freshPoolParams kh |
| 67 | + submitTx_ $ |
| 68 | + mkBasicTx mkBasicTxBody |
| 69 | + & bodyTxL . certsTxBodyL .~ [RegPoolTxCert $ pps & ppVrfL .~ vrf] |
| 70 | + retireStakePool kh retirementInterval = do |
| 71 | + curEpochNo <- getsNES nesELL |
| 72 | + let retirement = addEpochInterval curEpochNo retirementInterval |
| 73 | + submitTx_ $ |
| 74 | + mkBasicTx mkBasicTxBody |
| 75 | + & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert kh retirement] |
| 76 | + expectVRFs vrfs = |
| 77 | + (^. psVRFKeyHashesL) <$> getPState `shouldReturn` Set.fromList vrfs |
| 78 | + getPState = getsNES @era $ nesEsL . esLStateL . lsCertStateL . certPStateL |
0 commit comments