{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Test.Cardano.Ledger.Conway.Imp.EnactSpec (spec) where

import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams
import Cardano.Ledger.Conway.Rules
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Credential
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..))
import Cardano.Ledger.Val (zero, (<->))
import Control.Monad (forM)
import Control.Monad.Writer (listen)
import Data.Default (def)
import Data.Foldable as F (foldl', traverse_)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Typeable (cast)
import Data.Word (Word64)
import Lens.Micro
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Arbitrary (uniformSubSet)
import Test.Cardano.Ledger.Core.Rational
import Test.Cardano.Ledger.Imp.Common

spec ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
committeeSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
treasuryWithdrawalsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
noConfidenceSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
constitutionSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
actionPrioritySpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationNoDRepsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
pparamPredictionSpec

treasuryWithdrawalsSpec ::
  forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
treasuryWithdrawalsSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
treasuryWithdrawalsSpec =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Treasury withdrawals" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    -- Treasury withdrawals are disallowed in bootstrap, so we're running these tests only post-bootstrap
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Modify EnactState as expected" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      rewardAcount1 <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
      govActionId <- submitTreasuryWithdrawals [(rewardAcount1, Coin 666)]
      gas <- getGovActionState govActionId
      let govAction = GovActionState era -> GovAction era
forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas
      enactStateInit <- getEnactState
      let signal =
            EnactSignal
              { esGovActionId :: GovActionId
esGovActionId = GovActionId
govActionId
              , esGovAction :: GovAction era
esGovAction = GovAction era
govAction
              }
          enactState =
            EnactState era
enactStateInit
              { ensTreasury = Coin 1000
              }
      enactState' <- runImpRule @"ENACT" () enactState signal
      ensWithdrawals enactState' `shouldBe` [(raCredential rewardAcount1, Coin 666)]

      rewardAcount2 <- registerRewardAccount
      let withdrawals' =
            [ (RewardAccount
rewardAcount1, Integer -> Coin
Coin Integer
111)
            , (RewardAccount
rewardAcount2, Integer -> Coin
Coin Integer
222)
            ]
      govActionId' <- submitTreasuryWithdrawals withdrawals'
      gas' <- getGovActionState govActionId'
      let govAction' = GovActionState era -> GovAction era
forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas'
      let signal' =
            EnactSignal
              { esGovActionId :: GovActionId
esGovActionId = GovActionId
govActionId'
              , esGovAction :: GovAction era
esGovAction = GovAction era
govAction'
              }

      enactState'' <- runImpRule @"ENACT" () enactState' signal'

      ensWithdrawals enactState''
        `shouldBe` [ (raCredential rewardAcount1, Coin 777)
                   , (raCredential rewardAcount2, Coin 222)
                   ]
      ensTreasury enactState'' `shouldBe` Coin 1

    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals exceeding treasury submitted in a single proposal" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
      committeeCs <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
      (drepC, _, _) <- setupSingleDRep 1_000_000
      initialTreasury <- getsNES treasuryL
      numWithdrawals <- choose (1, 10)
      withdrawals <- genWithdrawalsExceeding initialTreasury numWithdrawals

      void $ enactTreasuryWithdrawals withdrawals drepC committeeCs
      checkNoWithdrawal initialTreasury withdrawals

      let sumRequested = ((RewardAccount, Coin) -> Coin) -> [(RewardAccount, Coin)] -> Coin
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (RewardAccount, Coin) -> Coin
forall a b. (a, b) -> b
snd [(RewardAccount, Coin)]
withdrawals

      impAnn "Submit a treasury donation that can cover the withdrawals" $ do
        let tx =
              TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
                Tx TopTx era -> (Tx TopTx era -> Tx TopTx era) -> Tx TopTx era
forall a b. a -> (a -> b) -> b
& (TxBody TopTx era -> Identity (TxBody TopTx era))
-> Tx TopTx era -> Identity (Tx TopTx era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody TopTx era -> Identity (TxBody TopTx era))
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> ((Coin -> Identity Coin)
    -> TxBody TopTx era -> Identity (TxBody TopTx era))
-> (Coin -> Identity Coin)
-> Tx TopTx era
-> Identity (Tx TopTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> TxBody TopTx era -> Identity (TxBody TopTx era)
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) Coin
forall (l :: TxLevel). Lens' (TxBody l era) Coin
treasuryDonationTxBodyL ((Coin -> Identity Coin)
 -> Tx TopTx era -> Identity (Tx TopTx era))
-> Coin -> Tx TopTx era -> Tx TopTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Coin
sumRequested Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
initialTreasury)
        submitTx_ tx
      passNEpochs 2
      getsNES treasuryL `shouldReturn` zero
      sumRewardAccounts withdrawals `shouldReturn` sumRequested

    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals exceeding maxBound Word64 submitted in a single proposal" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
      committeeCs <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
      (drepC, _, _) <- setupSingleDRep 1_000_000
      initialTreasury <- getsNES treasuryL
      numWithdrawals <- choose (1, 10)
      withdrawals <- genWithdrawalsExceeding (Coin (fromIntegral (maxBound :: Word64))) numWithdrawals
      void $ enactTreasuryWithdrawals withdrawals drepC committeeCs
      checkNoWithdrawal initialTreasury withdrawals

    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals exceeding treasury submitted in several proposals within the same epoch" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$
      ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
        do
          ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
          committeeCs <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
          (drepC, _, _) <- setupSingleDRep 1_000_000
          donateToTreasury $ Coin 5_000_000
          initialTreasury <- getsNES treasuryL
          numWithdrawals <- choose (1, 10)
          withdrawals <- genWithdrawalsExceeding initialTreasury numWithdrawals

          impAnn "submit in individual proposals in the same epoch" $ do
            traverse_
              ( \(RewardAccount, Coin)
w -> do
                  gaId <- forall era.
ConwayEraImp era =>
[(RewardAccount, Coin)] -> ImpTestM era GovActionId
submitTreasuryWithdrawals @era [(RewardAccount, Coin)
Item [(RewardAccount, Coin)]
w]
                  submitYesVote_ (DRepVoter drepC) gaId
                  submitYesVoteCCs_ committeeCs gaId
              )
              withdrawals
            passNEpochs 2

            let expectedTreasury =
                  (Coin -> (RewardAccount, Coin) -> Coin)
-> Coin -> [(RewardAccount, Coin)] -> Coin
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
F.foldl'
                    ( \Coin
acc (RewardAccount
_, Coin
x) ->
                        if Coin
acc Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
>= Coin
x
                          then Coin
acc Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
x
                          else Coin
acc
                    )
                    Coin
initialTreasury
                    [(RewardAccount, Coin)]
withdrawals

            getsNES treasuryL `shouldReturn` expectedTreasury
            -- check that the sum of the rewards matches what was spent from the treasury
            sumRewardAccounts withdrawals `shouldReturn` (initialTreasury <-> expectedTreasury)
  where
    sumRewardAccounts :: [(RewardAccount, b)] -> ImpM (LedgerSpec era) Coin
sumRewardAccounts [(RewardAccount, b)]
withdrawals = [Coin] -> Coin
forall a. Monoid a => [a] -> a
mconcat ([Coin] -> Coin)
-> ImpM (LedgerSpec era) [Coin] -> ImpM (LedgerSpec era) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((RewardAccount, b) -> ImpM (LedgerSpec era) Coin)
-> [(RewardAccount, b)] -> ImpM (LedgerSpec era) [Coin]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (RewardAccount -> ImpM (LedgerSpec era) Coin
forall era.
(HasCallStack, EraCertState era) =>
RewardAccount -> ImpTestM era Coin
getAccountBalance (RewardAccount -> ImpM (LedgerSpec era) Coin)
-> ((RewardAccount, b) -> RewardAccount)
-> (RewardAccount, b)
-> ImpM (LedgerSpec era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RewardAccount, b) -> RewardAccount
forall a b. (a, b) -> a
fst) [(RewardAccount, b)]
withdrawals
    genWithdrawalsExceeding :: Coin -> Int -> ImpM (LedgerSpec era) [(RewardAccount, Coin)]
genWithdrawalsExceeding (Coin Integer
val) Int
n = do
      vals <- Integer -> Int -> ImpM (LedgerSpec era) [Integer]
forall {m :: * -> *} {a}.
(MonadGen m, Random a, Integral a) =>
a -> Int -> m [a]
genValuesExceeding Integer
val Int
n
      forM (Coin <$> vals) $ \Coin
coin -> (,Coin
coin) (RewardAccount -> (RewardAccount, Coin))
-> ImpM (LedgerSpec era) RewardAccount
-> ImpM (LedgerSpec era) (RewardAccount, Coin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
    checkNoWithdrawal :: Coin -> [(RewardAccount, b)] -> ImpM (LedgerSpec era) ()
checkNoWithdrawal Coin
initialTreasury [(RewardAccount, b)]
withdrawals = do
      SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (Coin -> Const r Coin)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) Coin
Lens' (NewEpochState era) Coin
forall (t :: * -> *) era.
CanSetChainAccountState t =>
Lens' (t era) Coin
treasuryL ImpTestM era Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
initialTreasury
      [(RewardAccount, b)] -> ImpTestM era Coin
forall {era} {b}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraCertState era) =>
[(RewardAccount, b)] -> ImpM (LedgerSpec era) Coin
sumRewardAccounts [(RewardAccount, b)]
withdrawals ImpTestM era Coin -> Coin -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
forall t. Val t => t
zero
    genValuesExceeding :: a -> Int -> m [a]
genValuesExceeding a
val Int
n = do
      pcts <- Int -> m a -> m [a]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (m a -> m [a]) -> m a -> m [a]
forall a b. (a -> b) -> a -> b
$ (a, a) -> m a
forall a. Random a => (a, a) -> m a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (a
1, a
100)
      let tot = [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
pcts
      let amounts = (a -> a) -> [a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> Ratio a -> a
forall b. Integral b => Ratio a -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling ((a
x a -> a -> a
forall a. Num a => a -> a -> a
* a
val) a -> a -> Ratio a
forall a. Integral a => a -> a -> Ratio a
% a
tot)) [a]
pcts
      let minNeeded = a -> a -> a
forall a. Ord a => a -> a -> a
max a
0 (a
val a -> a -> a
forall a. Num a => a -> a -> a
- [a] -> a
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [a]
amounts a -> a -> a
forall a. Num a => a -> a -> a
+ a
1)
      excess <- choose (minNeeded, val + 1)
      pure $ excess : amounts

hardForkInitiationSpec ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationSpec :: forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationSpec =
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HardForkInitiation" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
    committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
    modifyPParams $ \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
2 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
        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
2 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
    _ <- setupPoolWithStake $ Coin 22_000_000
    (stakePoolId1, _, _) <- setupPoolWithStake $ Coin 22_000_000
    (stakePoolId2, _, _) <- setupPoolWithStake $ Coin 22_000_000
    (dRep1, _, _) <- setupSingleDRep 11_000_000
    (dRep2, _, _) <- setupSingleDRep 11_000_000
    curProtVer <- getProtVer
    nextMajorVersion <- succVersion $ pvMajor curProtVer
    let nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}
    govActionId <- submitGovAction $ HardForkInitiation SNothing nextProtVer
    submitYesVoteCCs_ committeeMembers' govActionId
    submitYesVote_ (DRepVoter dRep1) govActionId
    submitYesVote_ (StakePoolVoter stakePoolId1) govActionId
    passNEpochs 2
      & listen
      >>= expectHardForkEvents . snd <*> pure []
    getProtVer `shouldReturn` curProtVer
    submitYesVote_ (DRepVoter dRep2) govActionId
    passNEpochs 2
      & listen
      >>= expectHardForkEvents . snd <*> pure []
    getProtVer `shouldReturn` curProtVer
    submitYesVote_ (StakePoolVoter stakePoolId2) govActionId
    passNEpochs 2
      & listen
      >>= expectHardForkEvents . snd
        <*> pure
          [ SomeSTSEvent @era @"TICK" . injectEvent $ ConwayHardForkEvent nextProtVer
          ]

    getProtVer `shouldReturn` nextProtVer

hardForkInitiationNoDRepsSpec ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationNoDRepsSpec :: forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationNoDRepsSpec =
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HardForkInitiation without DRep voting" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
    modifyPParams $ ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 2 %! 3
    whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL . dvtHardForkInitiationL .~ def)
    _ <- setupPoolWithStake $ Coin 22_000_000
    (stakePoolId1, _, _) <- setupPoolWithStake $ Coin 22_000_000
    (stakePoolId2, _, _) <- setupPoolWithStake $ Coin 22_000_000
    curProtVer <- getProtVer
    nextMajorVersion <- succVersion $ pvMajor curProtVer
    let nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}
    govActionId <- submitGovAction $ HardForkInitiation SNothing nextProtVer
    submitYesVoteCCs_ committeeMembers' govActionId
    submitYesVote_ (StakePoolVoter stakePoolId1) govActionId
    passNEpochs 2
      & listen
      >>= expectHardForkEvents . snd <*> pure []
    getProtVer `shouldReturn` curProtVer
    submitYesVote_ (StakePoolVoter stakePoolId2) govActionId
    passNEpochs 2
      & listen
      >>= expectHardForkEvents . snd
        <*> pure
          [ SomeSTSEvent @era @"TICK" . injectEvent $ ConwayHardForkEvent nextProtVer
          ]
    getProtVer `shouldReturn` nextProtVer

pparamPredictionSpec ::
  ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
pparamPredictionSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
pparamPredictionSpec =
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"futurePParams" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
    modifyPParams $ ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 2 %! 3
    whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL . dvtHardForkInitiationL .~ def)
    _ <- setupPoolWithStake $ Coin 22_000_000
    (stakePoolId1, _, _) <- setupPoolWithStake $ Coin 22_000_000
    (stakePoolId2, _, _) <- setupPoolWithStake $ Coin 22_000_000
    curProtVer <- getProtVer
    nextMajorVersion <- succVersion $ pvMajor curProtVer
    let nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}
    govActionId <- submitGovAction $ HardForkInitiation SNothing nextProtVer
    submitYesVoteCCs_ committeeMembers' govActionId
    submitYesVote_ (StakePoolVoter stakePoolId1) govActionId
    submitYesVote_ (StakePoolVoter stakePoolId2) govActionId
    passEpoch
    advanceToPointOfNoReturn
    passEpoch
    getProtVer `shouldReturn` nextProtVer

noConfidenceSpec ::
  forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
noConfidenceSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
noConfidenceSpec =
  String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"NoConfidence" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ 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
dvtCommitteeNoConfidenceL ((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
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2
        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
pvtCommitteeNoConfidenceL ((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
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2
        PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
200
    let
      assertNoCommittee :: HasCallStack => ImpTestM era ()
      assertNoCommittee :: HasCallStack => ImpTestM era ()
assertNoCommittee =
        do
          committee <- ImpTestM era (StrictMaybe (Committee era))
forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (Committee era))
getCommittee
          impAnn "There should not be a committee" $ committee `shouldBe` SNothing
    khCC <- ImpM (LedgerSpec era) (KeyHash ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    initialCommitteeMembers <- getCommitteeMembers

    (drep, _, _) <- setupSingleDRep 1_000_000
    startEpochNo <- getsNES nesELL
    let committeeMap =
          [(Credential ColdCommitteeRole, EpochNo)]
-> Map (Credential ColdCommitteeRole) EpochNo
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash ColdCommitteeRole
khCC, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startEpochNo (Word32 -> EpochInterval
EpochInterval Word32
50))
            ]
    prevGaidCommittee@(GovPurposeId gaidCommittee) <-
      submitCommitteeElection
        SNothing
        drep
        initialCommitteeMembers
        committeeMap
    (khSPO, _, _) <- setupPoolWithStake $ Coin 42_000_000
    logInstantStake
    submitYesVote_ (StakePoolVoter khSPO) gaidCommittee
    replicateM_ 4 passEpoch
    impAnn "Committee should be elected" $ do
      committee <- getCommittee
      committee `shouldBe` SJust (Committee committeeMap $ 1 %! 2)
    gaidNoConf <- mkProposal (NoConfidence (SJust prevGaidCommittee)) >>= submitProposal
    submitYesVote_ (StakePoolVoter khSPO) gaidNoConf
    submitYesVote_ (DRepVoter drep) gaidNoConf
    replicateM_ 4 passEpoch
    assertNoCommittee

constitutionSpec ::
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
constitutionSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
constitutionSpec =
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Constitution" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (committeeMember1 :| [committeeMember2]) <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
    (dRep, _, _) <- setupSingleDRep 1_000_000
    initialConstitution <- getConstitution
    (proposal, constitution) <- mkConstitutionProposal SNothing
    mbGovActionId <-
      submitBootstrapAwareFailingProposal proposal $
        FailBootstrap [injectFailure (DisallowedProposalDuringBootstrap proposal)]
    forM_ mbGovActionId $ \GovActionId
govActionId -> do
      proposalsBeforeVotes <- SimpleGetter (NewEpochState era) (Proposals era)
-> ImpTestM era (Proposals era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Proposals era)
 -> ImpTestM era (Proposals era))
-> SimpleGetter (NewEpochState era) (Proposals era)
-> ImpTestM era (Proposals era)
forall a b. (a -> b) -> a -> b
$ (GovState era -> Const r (GovState era))
-> NewEpochState era -> Const r (NewEpochState era)
(ConwayGovState era -> Const r (ConwayGovState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((ConwayGovState era -> Const r (ConwayGovState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Proposals era -> Const r (Proposals era))
    -> ConwayGovState era -> Const r (ConwayGovState era))
-> (Proposals era -> Const r (Proposals era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proposals era -> Const r (Proposals era))
-> GovState era -> Const r (GovState era)
(Proposals era -> Const r (Proposals era))
-> ConwayGovState era -> Const r (ConwayGovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
Lens' (GovState era) (Proposals era)
proposalsGovStateL
      pulserBeforeVotes <- getsNES newEpochStateDRepPulsingStateL

      submitYesVote_ (DRepVoter dRep) govActionId
      submitYesVote_ (CommitteeVoter committeeMember1) govActionId
      submitYesVote_ (CommitteeVoter committeeMember2) govActionId

      proposalsAfterVotes <- getsNES $ newEpochStateGovStateL . proposalsGovStateL
      pulserAfterVotes <- getsNES newEpochStateDRepPulsingStateL

      impAnn "Votes are recorded in the proposals" $ do
        let proposalsWithVotes =
              Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
forall era.
Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
proposalsAddVote
                (Credential HotCommitteeRole -> Voter
CommitteeVoter Credential HotCommitteeRole
committeeMember1)
                Vote
VoteYes
                GovActionId
govActionId
                ( Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
forall era.
Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
proposalsAddVote
                    (Credential HotCommitteeRole -> Voter
CommitteeVoter Item [Credential HotCommitteeRole]
Credential HotCommitteeRole
committeeMember2)
                    Vote
VoteYes
                    GovActionId
govActionId
                    ( Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
forall era.
Voter -> Vote -> GovActionId -> Proposals era -> Proposals era
proposalsAddVote
                        (Credential DRepRole -> Voter
DRepVoter Credential DRepRole
dRep)
                        Vote
VoteYes
                        GovActionId
govActionId
                        Proposals era
proposalsBeforeVotes
                    )
                )
        proposalsAfterVotes `shouldBe` proposalsWithVotes

      impAnn "Pulser has not changed" $
        pulserAfterVotes `shouldBe` pulserBeforeVotes

      passEpoch

      impAnn "New constitution is not enacted after one epoch" $ do
        constitutionAfterOneEpoch <- getsNES $ newEpochStateGovStateL . constitutionGovStateL
        constitutionAfterOneEpoch `shouldBe` initialConstitution

      impAnn "Pulser should reflect the constitution to be enacted" $ do
        pulser <- getsNES newEpochStateDRepPulsingStateL
        let ratifyState = DRepPulsingState era -> RatifyState era
forall era.
(EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> RatifyState era
extractDRepPulsingState DRepPulsingState era
pulser
        gasId <$> rsEnacted ratifyState `shouldBe` govActionId Seq.:<| Seq.Empty
        rsEnactState ratifyState ^. ensConstitutionL `shouldBe` constitution

      passEpoch

      impAnn "Constitution is enacted after two epochs" $ do
        curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL
        curConstitution `shouldBe` constitution

      impAnn "Pulser is reset" $ do
        pulser <- getsNES newEpochStateDRepPulsingStateL
        let pulserRatifyState = DRepPulsingState era -> RatifyState era
forall era.
(EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> RatifyState era
extractDRepPulsingState DRepPulsingState era
pulser
        rsEnacted pulserRatifyState `shouldBe` Seq.empty
        enactState <- getEnactState
        rsEnactState pulserRatifyState `shouldBe` enactState

actionPrioritySpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
actionPrioritySpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
actionPrioritySpec =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Competing proposals" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"higher action priority wins" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (drepC, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
      (poolKH, _, _) <- setupPoolWithStake $ Coin 1_000_000
      cc <- KeyHashObj <$> freshKeyHash
      proposal <-
        mkUpdateCommitteeProposal Nothing mempty [(cc, EpochInterval 30)] (1 %! 3)
      mbGai1 <-
        submitBootstrapAwareFailingProposal proposal $
          FailBootstrap [injectFailure $ DisallowedProposalDuringBootstrap proposal]
      forM_ mbGai1 $ \GovActionId
gai1 -> do
        -- gai2 is the first action of a higher priority
        gai2 <- GovAction era -> ImpTestM era GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction (GovAction era -> ImpTestM era GovActionId)
-> GovAction era -> ImpTestM era GovActionId
forall a b. (a -> b) -> a -> b
$ StrictMaybe (GovPurposeId 'CommitteePurpose) -> GovAction era
forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose) -> GovAction era
NoConfidence StrictMaybe (GovPurposeId 'CommitteePurpose)
forall a. StrictMaybe a
SNothing
        gai3 <- submitGovAction $ NoConfidence SNothing
        traverse_ @[]
          ( \GovActionId
gaid -> do
              Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential DRepRole -> Voter
DRepVoter Credential DRepRole
drepC) GovActionId
gaid
              Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash StakePool -> Voter
StakePoolVoter KeyHash StakePool
poolKH) GovActionId
gaid
          )
          [gai1, gai2, gai3]
        passNEpochs 2
        getLastEnactedCommittee
          `shouldReturn` SJust (GovPurposeId gai2)
        expectNoCurrentProposals

        committee <-
          getsNES $
            nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . committeeGovStateL
        committee `shouldBe` SNothing

    -- distinct constitutional values for minFee
    let genMinFeeVals :: ImpM (LedgerSpec era) (Coin, Coin, Coin)
genMinFeeVals =
          (\Integer
x Integer
y Integer
z -> (Integer -> Coin
Coin Integer
x, Integer -> Coin
Coin Integer
y, Integer -> Coin
Coin Integer
z))
            (Integer -> Integer -> Integer -> (Coin, Coin, Coin))
-> ImpM (LedgerSpec era) Integer
-> ImpM (LedgerSpec era) (Integer -> Integer -> (Coin, Coin, Coin))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
30, Integer
330)
            ImpM (LedgerSpec era) (Integer -> Integer -> (Coin, Coin, Coin))
-> ImpM (LedgerSpec era) Integer
-> ImpM (LedgerSpec era) (Integer -> (Coin, Coin, Coin))
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
<*> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
330, Integer
660)
            ImpM (LedgerSpec era) (Integer -> (Coin, Coin, Coin))
-> ImpM (LedgerSpec era) Integer
-> ImpM (LedgerSpec era) (Coin, Coin, Coin)
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
<*> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
660, Integer
1000)

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"proposals of same priority are enacted in order of submission" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> 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
pvtPPSecurityGroupL ((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
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> 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
dvtPPEconomicGroupL ((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
.~ UnitInterval
forall a. Default a => a
def)
      (val1, val2, val3) <- ImpM (LedgerSpec era) (Coin, Coin, Coin)
genMinFeeVals

      committeeCs <- registerInitialCommittee
      (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
      pGai0 <-
        submitParameterChange
          SNothing
          $ def & ppuMinFeeAL .~ SJust val1
      pGai1 <-
        submitParameterChange
          (SJust pGai0)
          $ def & ppuMinFeeAL .~ SJust val2
      pGai2 <-
        submitParameterChange
          (SJust pGai1)
          $ def & ppuMinFeeAL .~ SJust val3
      traverse_ @[]
        ( \GovActionId
gaid -> do
            Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash StakePool -> Voter
StakePoolVoter KeyHash StakePool
spoC) GovActionId
gaid
            NonEmpty (Credential HotCommitteeRole)
-> GovActionId -> ImpM (LedgerSpec era) ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential HotCommitteeRole)
committeeCs GovActionId
gaid
        )
        [pGai0, pGai1, pGai2]
      passNEpochs 2
      getLastEnactedParameterChange
        `shouldReturn` SJust (GovPurposeId pGai2)
      expectNoCurrentProposals
      getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL)
        `shouldReturn` val3

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"only the first action of a transaction gets enacted" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> 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
pvtPPSecurityGroupL ((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
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> 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
dvtPPEconomicGroupL ((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
.~ UnitInterval
forall a. Default a => a
def)
      (val1, val2, val3) <- ImpM (LedgerSpec era) (Coin, Coin, Coin)
genMinFeeVals

      committeeCs <- registerInitialCommittee
      (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
      policy <- getGovPolicy
      gaids <-
        submitGovActions $
          NE.fromList
            [ ParameterChange
                SNothing
                (def & ppuMinFeeAL .~ SJust val1)
                policy
            , ParameterChange
                SNothing
                (def & ppuMinFeeAL .~ SJust val2)
                policy
            , ParameterChange
                SNothing
                (def & ppuMinFeeAL .~ SJust val3)
                policy
            ]
      traverse_
        ( \GovActionId
gaid -> do
            Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash StakePool -> Voter
StakePoolVoter KeyHash StakePool
spoC) GovActionId
gaid
            NonEmpty (Credential HotCommitteeRole)
-> GovActionId -> ImpM (LedgerSpec era) ()
forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential HotCommitteeRole) -> GovActionId -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential HotCommitteeRole)
committeeCs GovActionId
gaid
        )
        gaids
      passNEpochs 2
      getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL)
        `shouldReturn` val1
      expectNoCurrentProposals

expectHardForkEvents ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  ) =>
  [SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents :: forall era.
(ConwayEraImp era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents [SomeSTSEvent era]
actual [SomeSTSEvent era]
expected =
  (SomeSTSEvent era -> Bool)
-> [SomeSTSEvent era] -> [SomeSTSEvent era]
forall a. (a -> Bool) -> [a] -> [a]
filter SomeSTSEvent era -> Bool
isHardForkEvent [SomeSTSEvent era]
actual [SomeSTSEvent era]
-> [SomeSTSEvent era] -> ImpM (LedgerSpec era) ()
forall a (m :: * -> *).
(HasCallStack, ToExpr a, Eq a, MonadIO m) =>
a -> a -> m ()
`shouldBeExpr` [SomeSTSEvent era]
expected
  where
    isHardForkEvent :: SomeSTSEvent era -> Bool
isHardForkEvent (SomeSTSEvent Event (EraRule rule era)
ev)
      | Just
          (TickNewEpochEvent (EpochEvent (HardForkEvent (ConwayHardForkEvent ProtVer
_))) :: ShelleyTickEvent era) <-
          Event (EraRule rule era) -> Maybe (ShelleyTickEvent era)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Event (EraRule rule era)
ev =
          Bool
True
      | Bool
otherwise = Bool
False

committeeSpec :: ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
committeeSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
committeeSpec =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Committee enactment" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Enact UpdateCommitee with lengthy lifetime" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      NonNegative n <- ImpM (LedgerSpec era) (NonNegative Nat)
forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      passNEpochs n
      (drepCred, _, _) <- setupSingleDRep 1_000_000
      (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
      cc <- KeyHashObj <$> freshKeyHash
      EpochInterval committeeMaxTermLength <-
        getsNES $ nesEsL . curPParamsEpochStateL . ppCommitteeMaxTermLengthL
      proposal <-
        mkUpdateCommitteeProposal Nothing mempty [(cc, EpochInterval (committeeMaxTermLength + 2))] (1 %! 2)
      mbSecondAddCCGaid <-
        submitBootstrapAwareFailingProposal proposal $
          FailBootstrap [injectFailure $ DisallowedProposalDuringBootstrap proposal]
      forM_ mbSecondAddCCGaid $ \GovActionId
secondAddCCGaid -> do
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential DRepRole -> Voter
DRepVoter Credential DRepRole
drepCred) GovActionId
secondAddCCGaid
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash StakePool -> Voter
StakePoolVoter KeyHash StakePool
spoC) GovActionId
secondAddCCGaid
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        -- Due to longer than allowed lifetime we have to wait an extra epoch for this new action to be enacted
        Credential ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraGov era) =>
Credential ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberAbsence Credential ColdCommitteeRole
cc
        ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
        Credential ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraGov era) =>
Credential ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberPresence Credential ColdCommitteeRole
cc

    -- A CC that has resigned will need to be first voted out and then voted in to be considered active
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"CC re-election" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (drepCred, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
      (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
      passNEpochs 2
      -- Add a fresh CC
      cc <- KeyHashObj <$> freshKeyHash
      proposal <-
        mkUpdateCommitteeProposal Nothing mempty [(cc, EpochInterval 10)] (1 %! 2)
      mbAddCCGaid <-
        submitBootstrapAwareFailingProposal proposal $
          FailBootstrap [injectFailure $ DisallowedProposalDuringBootstrap proposal]
      forM_ mbAddCCGaid $ \GovActionId
addCCGaid -> do
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential DRepRole -> Voter
DRepVoter Credential DRepRole
drepCred) GovActionId
addCCGaid
        Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash StakePool -> Voter
StakePoolVoter KeyHash StakePool
spoC) GovActionId
addCCGaid
        Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
        -- Confirm that they are added
        Credential ColdCommitteeRole -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ConwayEraGov era) =>
Credential ColdCommitteeRole -> ImpTestM era ()
expectCommitteeMemberPresence Credential ColdCommitteeRole
cc
        -- Confirm their hot key registration
        _hotKey <- Credential ColdCommitteeRole
-> ImpTestM era (Credential HotCommitteeRole)
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential ColdCommitteeRole
-> ImpTestM era (Credential HotCommitteeRole)
registerCommitteeHotKey Credential ColdCommitteeRole
cc
        ccShouldNotBeResigned cc
        -- Have them resign
        _ <- resignCommitteeColdKey cc SNothing
        ccShouldBeResigned cc
        -- Re-add the same CC
        reAddCCGaid <- submitUpdateCommittee Nothing mempty [(cc, EpochInterval 20)] (1 %! 2)
        submitYesVote_ (DRepVoter drepCred) reAddCCGaid
        submitYesVote_ (StakePoolVoter spoC) reAddCCGaid
        passNEpochs 2
        -- Confirm that they are still resigned
        ccShouldBeResigned cc
        -- Remove them
        removeCCGaid <-
          submitUpdateCommittee (Just (SJust $ GovPurposeId reAddCCGaid)) (Set.singleton cc) [] (1 %! 2)
        submitYesVote_ (DRepVoter drepCred) removeCCGaid
        submitYesVote_ (StakePoolVoter spoC) removeCCGaid
        passNEpochs 2
        -- Confirm that they have been removed
        expectCommitteeMemberAbsence cc
        secondAddCCGaid <-
          submitUpdateCommittee Nothing mempty [(cc, EpochInterval 20)] (1 %! 2)
        submitYesVote_ (DRepVoter drepCred) secondAddCCGaid
        submitYesVote_ (StakePoolVoter spoC) secondAddCCGaid
        passNEpochs 2
        -- Confirm that they have been added
        expectCommitteeMemberPresence cc
        -- Confirm that after registering a hot key, they are active
        _hotKey <- registerCommitteeHotKey cc
        ccShouldNotBeResigned cc
    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Removing CC with UpdateCommittee" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Non registered" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (drepCred, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
        (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
        passNEpochs 2
        initialCommittee <- getCommitteeMembers
        logToExpr initialCommittee
        initialCommittee `shouldSatisfy` not . Set.null
        proposal <-
          mkUpdateCommitteeProposal Nothing initialCommittee mempty (1 %! 2)
        mbRemoveCCGaid <-
          submitBootstrapAwareFailingProposal proposal $
            FailBootstrap [injectFailure $ DisallowedProposalDuringBootstrap proposal]
        forM_ mbRemoveCCGaid $ \GovActionId
removeCCGaid -> do
          Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential DRepRole -> Voter
DRepVoter Credential DRepRole
drepCred) GovActionId
removeCCGaid
          Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash StakePool -> Voter
StakePoolVoter KeyHash StakePool
spoC) GovActionId
removeCCGaid
          Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
          finalCommittee <- ImpTestM era (Set (Credential ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential ColdCommitteeRole))
getCommitteeMembers
          logToExpr finalCommittee
          finalCommittee `shouldSatisfy` Set.null
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Registered" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (drepCred, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
        (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
        passNEpochs 2
        initialCommittee <- getCommitteeMembers
        logToExpr initialCommittee
        initialCommittee `shouldSatisfy` not . Set.null
        forM_ (Set.toList initialCommittee) $ \Credential ColdCommitteeRole
kh -> do
          ccHotCred <- KeyHash HotCommitteeRole -> Credential HotCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash HotCommitteeRole -> Credential HotCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash HotCommitteeRole)
-> ImpTestM era (Credential HotCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash HotCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
          submitTx_ $
            mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL
                .~ SSeq.singleton (AuthCommitteeHotKeyTxCert kh ccHotCred)
        newCommittee <- arbitrary
        initialSubCommittee <- askStatefulGen >>= uniformSubSet Nothing initialCommittee
        proposal <-
          mkUpdateCommitteeProposal Nothing initialSubCommittee newCommittee (1 %! 2)
        mbRemoveCCGaid <-
          submitBootstrapAwareFailingProposal proposal $
            FailBootstrap [injectFailure $ DisallowedProposalDuringBootstrap proposal]
        forM_ mbRemoveCCGaid $ \GovActionId
removeCCGaid -> do
          Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential DRepRole -> Voter
DRepVoter Credential DRepRole
drepCred) GovActionId
removeCCGaid
          Voter -> GovActionId -> ImpM (LedgerSpec era) ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (KeyHash StakePool -> Voter
StakePoolVoter KeyHash StakePool
spoC) GovActionId
removeCCGaid
          Nat -> ImpM (LedgerSpec era) ()
forall era. ShelleyEraImp era => Nat -> ImpTestM era ()
passNEpochs Nat
2
          finalCommittee <- ImpTestM era (Set (Credential ColdCommitteeRole))
forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential ColdCommitteeRole))
getCommitteeMembers
          logToExpr finalCommittee
          finalCommittee
            `shouldBe` Set.union (initialCommittee Set.\\ initialSubCommittee) (Set.fromList $ fst <$> newCommittee)