{-# 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 Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure (..))
import qualified Data.Map.Strict as Map
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 :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = do
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"VRF Keyhashes get populated at v11 HardFork" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Since we're testing the HardFork to 11, the test only makes sense for protocol version 10
    forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersion @10 (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      (kh1, vrf1) <- (,) (KeyHash StakePool
 -> VRFVerKeyHash StakePoolVRF
 -> (KeyHash StakePool, VRFVerKeyHash StakePoolVRF))
-> ImpM (LedgerSpec era) (KeyHash StakePool)
-> ImpM
     (LedgerSpec era)
     (VRFVerKeyHash StakePoolVRF
      -> (KeyHash StakePool, VRFVerKeyHash StakePoolVRF))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM
  (LedgerSpec era)
  (VRFVerKeyHash StakePoolVRF
   -> (KeyHash StakePool, VRFVerKeyHash StakePoolVRF))
-> ImpM (LedgerSpec era) (VRFVerKeyHash StakePoolVRF)
-> ImpM
     (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImpM (LedgerSpec era) (VRFVerKeyHash StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
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, 2), (vrf3, 1), (vrf5, 1)]

  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Retiring a stake pool with a duplicate VRF Keyhash after v11 HardFork" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ do
    forall (v :: Natural) era.
(EraGov era, KnownNat v, MinVersion <= v, v <= MaxVersion) =>
ImpTestM era () -> ImpTestM era ()
whenMajorVersion @10 (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      -- register two pools with the same vrf keyhash before the hard fork
      (kh1, vrf) <- (,) (KeyHash StakePool
 -> VRFVerKeyHash StakePoolVRF
 -> (KeyHash StakePool, VRFVerKeyHash StakePoolVRF))
-> ImpM (LedgerSpec era) (KeyHash StakePool)
-> ImpM
     (LedgerSpec era)
     (VRFVerKeyHash StakePoolVRF
      -> (KeyHash StakePool, VRFVerKeyHash StakePoolVRF))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM
  (LedgerSpec era)
  (VRFVerKeyHash StakePoolVRF
   -> (KeyHash StakePool, VRFVerKeyHash StakePoolVRF))
-> ImpM (LedgerSpec era) (VRFVerKeyHash StakePoolVRF)
-> ImpM
     (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImpM (LedgerSpec era) (VRFVerKeyHash StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      registerStakePool kh1 vrf
      kh2 <- freshKeyHash
      registerStakePool kh2 vrf
      kh3 <- freshKeyHash
      registerStakePool kh3 vrf

      enactHardForkV11
      expectVRFs [(vrf, 3)]
      -- retire one of the pools after the hard fork
      retireStakePool kh1 (EpochInterval 1)
      retireStakePool kh2 (EpochInterval 1)
      passEpoch
      -- the vrf keyhash should still be present, since another pool is registered with it
      expectVRFs [(vrf, 1)]

      -- registration of the same vrf should be disallowed
      kh4 <- freshKeyHash
      registerStakePoolTx kh4 vrf >>= \Tx TopTx era
tx ->
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx
          Tx TopTx era
tx
          [ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> ShelleyPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ShelleyPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ShelleyPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
kh4 VRFVerKeyHash StakePoolVRF
vrf]

      retireStakePool kh3 (EpochInterval 1)
      passEpoch
      expectVRFs []

      registerStakePool kh4 vrf
      expectVRFs [(vrf, 1)]
  where
    enactHardForkV11 :: ImpTestM era ()
enactHardForkV11 = do
      (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
        PParams era
pp
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      let pv11 :: ProtVer
pv11 = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @11) Natural
0
      committee <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
      govActionId <- submitGovAction $ HardForkInitiation SNothing pv11
      submitYesVoteCCs_ committee govActionId
      passNEpochs 2
      getProtVer `shouldReturn` pv11
    registerStakePoolTx :: KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ImpM (LedgerSpec era) (Tx l era)
registerStakePoolTx KeyHash StakePool
kh VRFVerKeyHash StakePoolVRF
vrf = do
      pps <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount ImpTestM era RewardAccount
-> (RewardAccount -> ImpM (LedgerSpec era) StakePoolParams)
-> ImpM (LedgerSpec era) StakePoolParams
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= KeyHash StakePool
-> RewardAccount -> ImpM (LedgerSpec era) StakePoolParams
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> RewardAccount -> ImpTestM era StakePoolParams
freshPoolParams KeyHash StakePool
kh
      pure $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [RegPoolTxCert $ pps & sppVrfL .~ vrf]
    registerStakePool :: KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ImpM (LedgerSpec era) ()
registerStakePool KeyHash StakePool
kh VRFVerKeyHash StakePoolVRF
vrf =
      KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall {era} {era} {l :: TxLevel}.
(Event (EraRule "TICK" era) ~ EraRuleEvent "TICK" era,
 Event (EraRule "LEDGER" era) ~ EraRuleEvent "LEDGER" era,
 PredicateFailure (EraRule "BBODY" era)
 ~ EraRuleFailure "BBODY" era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ EraRuleFailure "LEDGER" era,
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat MinVersion (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 ShelleyEraImp era, EraTx era,
 EncCBOR (EraRuleFailure "LEDGER" era),
 DecCBOR (EraRuleFailure "LEDGER" era),
 Show (EraRuleFailure "BBODY" era),
 Show (EraRuleFailure "LEDGER" era),
 Eq (EraRuleFailure "BBODY" era), Eq (EraRuleFailure "LEDGER" era),
 NFData (EraRuleFailure "LEDGER" era),
 ToExpr (EraRuleFailure "LEDGER" era), Typeable l) =>
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ImpM (LedgerSpec era) (Tx l era)
registerStakePoolTx KeyHash StakePool
kh VRFVerKeyHash StakePoolVRF
vrf ImpM (LedgerSpec era) (Tx TopTx era)
-> (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_
    retireStakePool :: KeyHash StakePool -> EpochInterval -> ImpM (LedgerSpec era) ()
retireStakePool KeyHash StakePool
kh EpochInterval
retirementInterval = do
      curEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
      let retirement = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo EpochInterval
retirementInterval
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert kh retirement]
    expectVRFs :: [(VRFVerKeyHash StakePoolVRF, Word64)] -> ImpTestM era ()
expectVRFs [(VRFVerKeyHash StakePoolVRF, Word64)]
vrfs =
      PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall era.
PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes
        (PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> ImpM (LedgerSpec era) (PState era)
-> ImpM
     (LedgerSpec era)
     (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (PState era)
getPState
          ImpM
  (LedgerSpec era)
  (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> ImpTestM era ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` [(VRFVerKeyHash StakePoolVRF, NonZero Word64)]
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(VRFVerKeyHash StakePoolVRF
k, Word64 -> NonZero Word64
forall a. a -> NonZero a
unsafeNonZero Word64
v) | (VRFVerKeyHash StakePoolVRF
k, Word64
v) <- [(VRFVerKeyHash StakePoolVRF, Word64)]
vrfs]
    getPState :: ImpM (LedgerSpec era) (PState era)
getPState = forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES @era (SimpleGetter (NewEpochState era) (PState era)
 -> ImpM (LedgerSpec era) (PState era))
-> SimpleGetter (NewEpochState era) (PState era)
-> ImpM (LedgerSpec era) (PState era)
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((PState era -> Const r (PState era))
    -> EpochState era -> Const r (EpochState era))
-> (PState era -> Const r (PState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((PState era -> Const r (PState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (PState era -> Const r (PState era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((PState era -> Const r (PState era))
    -> CertState era -> Const r (CertState era))
-> (PState era -> Const r (PState era))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Const r (PState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL