{-# 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.Credential
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (ShelleyTickEvent (..))
import Cardano.Ledger.Val (zero, (<->))
import Control.Monad (forM)
import Control.Monad.Writer (listen)
import Control.State.Transition.Extended (STS (..))
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
import Type.Reflection (Typeable)

spec ::
  forall era.
  ( ConwayEraImp era
  , NFData (Event (EraRule "ENACT" era))
  , ToExpr (Event (EraRule "ENACT" era))
  , Eq (Event (EraRule "ENACT" era))
  , Typeable (Event (EraRule "ENACT" era))
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , InjectRuleEvent "TICK" ConwayEpochEvent era
  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era, NFData (Event (EraRule "ENACT" era)),
 ToExpr (Event (EraRule "ENACT" era)),
 Eq (Event (EraRule "ENACT" era)),
 Typeable (Event (EraRule "ENACT" era)),
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeSpec
  forall era.
(ConwayEraImp era, NFData (Event (EraRule "ENACT" era)),
 ToExpr (Event (EraRule "ENACT" era)),
 Eq (Event (EraRule "ENACT" era)),
 Typeable (Event (EraRule "ENACT" era))) =>
SpecWith (ImpInit (LedgerSpec era))
treasuryWithdrawalsSpec
  forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
noConfidenceSpec
  forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationSpec
  forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
constitutionSpec
  forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
actionPrioritySpec
  forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationNoDRepsSpec
  forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
pparamPredictionSpec

treasuryWithdrawalsSpec ::
  forall era.
  ( ConwayEraImp era
  , NFData (Event (EraRule "ENACT" era))
  , ToExpr (Event (EraRule "ENACT" era))
  , Eq (Event (EraRule "ENACT" era))
  , Typeable (Event (EraRule "ENACT" era))
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
treasuryWithdrawalsSpec :: forall era.
(ConwayEraImp era, NFData (Event (EraRule "ENACT" era)),
 ToExpr (Event (EraRule "ENACT" era)),
 Eq (Event (EraRule "ENACT" era)),
 Typeable (Event (EraRule "ENACT" era))) =>
SpecWith (ImpInit (LedgerSpec era))
treasuryWithdrawalsSpec =
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Treasury withdrawals" forall a b. (a -> b) -> a -> b
$ do
    -- Treasury withdrawals are disallowed in bootstrap, so we're running these tests only post-bootstrap
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Modify EnactState as expected" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
      RewardAccount (EraCrypto era)
rewardAcount1 <- forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era (RewardAccount (EraCrypto era))
registerRewardAccount
      GovActionId (EraCrypto era)
govActionId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount (EraCrypto era), Coin)]
-> ImpTestM era (GovActionId (EraCrypto era))
submitTreasuryWithdrawals [(RewardAccount (EraCrypto era)
rewardAcount1, Integer -> Coin
Coin Integer
666)]
      GovActionState era
gas <- forall era.
(HasCallStack, ConwayEraGov era) =>
GovActionId (EraCrypto era) -> ImpTestM era (GovActionState era)
getGovActionState GovActionId (EraCrypto era)
govActionId
      let govAction :: GovAction era
govAction = forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas
      EnactState era
enactStateInit <- forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState
      let signal :: EnactSignal era
signal =
            EnactSignal
              { esGovActionId :: GovActionId (EraCrypto era)
esGovActionId = GovActionId (EraCrypto era)
govActionId
              , esGovAction :: GovAction era
esGovAction = GovAction era
govAction
              }
          enactState :: EnactState era
enactState =
            EnactState era
enactStateInit
              { ensTreasury :: Coin
ensTreasury = Integer -> Coin
Coin Integer
1000
              }
      EnactState era
enactState' <- forall (rule :: Symbol) era.
(HasCallStack, KnownSymbol rule, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 NFData (State (EraRule rule era)),
 NFData (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era)), Eq (Event (EraRule rule era)),
 Typeable (Event (EraRule rule era))) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM era (State (EraRule rule era))
runImpRule @"ENACT" () EnactState era
enactState EnactSignal era
signal
      forall era.
EnactState era -> Map (Credential 'Staking (EraCrypto era)) Coin
ensWithdrawals EnactState era
enactState' forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` [(forall c. RewardAccount c -> Credential 'Staking c
raCredential RewardAccount (EraCrypto era)
rewardAcount1, Integer -> Coin
Coin Integer
666)]

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

      EnactState era
enactState'' <- forall (rule :: Symbol) era.
(HasCallStack, KnownSymbol rule, STS (EraRule rule era),
 BaseM (EraRule rule era) ~ ShelleyBase,
 NFData (State (EraRule rule era)),
 NFData (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era)), Eq (Event (EraRule rule era)),
 Typeable (Event (EraRule rule era))) =>
Environment (EraRule rule era)
-> State (EraRule rule era)
-> Signal (EraRule rule era)
-> ImpTestM era (State (EraRule rule era))
runImpRule @"ENACT" () EnactState era
enactState' EnactSignal era
signal'

      forall era.
EnactState era -> Map (Credential 'Staking (EraCrypto era)) Coin
ensWithdrawals EnactState era
enactState''
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` [ (forall c. RewardAccount c -> Credential 'Staking c
raCredential RewardAccount (EraCrypto era)
rewardAcount1, Integer -> Coin
Coin Integer
777)
                   , (forall c. RewardAccount c -> Credential 'Staking c
raCredential RewardAccount (EraCrypto era)
rewardAcount2, Integer -> Coin
Coin Integer
222)
                   ]
      forall era. EnactState era -> Coin
ensTreasury EnactState era
enactState'' forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Integer -> Coin
Coin Integer
1

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals exceeding treasury submitted in a single proposal" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
      forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
      NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
      (Credential 'DRepRole (EraCrypto era)
drepC, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
      Coin
initialTreasury <- forall {era}. ImpTestM era Coin
getTreasury
      Int
numWithdrawals <- forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, Int
10)
      [(RewardAccount (EraCrypto era), Coin)]
withdrawals <- forall {era}.
ShelleyEraImp era =>
Coin
-> Int
-> ImpM (LedgerSpec era) [(RewardAccount (EraCrypto era), Coin)]
genWithdrawalsExceeding Coin
initialTreasury Int
numWithdrawals

      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraImp era =>
[(RewardAccount (EraCrypto era), Coin)]
-> Credential 'DRepRole (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactTreasuryWithdrawals [(RewardAccount (EraCrypto era), Coin)]
withdrawals Credential 'DRepRole (EraCrypto era)
drepC NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs
      forall {era} {b}.
Coin
-> [(RewardAccount (EraCrypto era), b)] -> ImpM (LedgerSpec era) ()
checkNoWithdrawal Coin
initialTreasury [(RewardAccount (EraCrypto era), Coin)]
withdrawals

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

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Submit a treasury donation that can cover the withdrawals" forall a b. (a -> b) -> a -> b
$ do
        let tx :: Tx era
tx =
              forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
                forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. ConwayEraTxBody era => Lens' (TxBody era) Coin
treasuryDonationTxBodyL forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Coin
sumRequested forall t. Val t => t -> t -> t
<-> Coin
initialTreasury)
        forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ Tx era
tx
      forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      forall {era}. ImpTestM era Coin
getTreasury forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` forall t. Val t => t
zero
      forall {era} {b}.
[(RewardAccount (EraCrypto era), b)] -> ImpM (LedgerSpec era) Coin
sumRewardAccounts [(RewardAccount (EraCrypto era), Coin)]
withdrawals forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
sumRequested

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals exceeding maxBound Word64 submitted in a single proposal" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
      forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
      NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
      (Credential 'DRepRole (EraCrypto era)
drepC, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
      Coin
initialTreasury <- forall {era}. ImpTestM era Coin
getTreasury
      Int
numWithdrawals <- forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, Int
10)
      [(RewardAccount (EraCrypto era), Coin)]
withdrawals <- forall {era}.
ShelleyEraImp era =>
Coin
-> Int
-> ImpM (LedgerSpec era) [(RewardAccount (EraCrypto era), Coin)]
genWithdrawalsExceeding (Integer -> Coin
Coin (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. Bounded a => a
maxBound :: Word64))) Int
numWithdrawals
      forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraImp era =>
[(RewardAccount (EraCrypto era), Coin)]
-> Credential 'DRepRole (EraCrypto era)
-> NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
-> ImpTestM era (GovActionId (EraCrypto era))
enactTreasuryWithdrawals [(RewardAccount (EraCrypto era), Coin)]
withdrawals Credential 'DRepRole (EraCrypto era)
drepC NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs
      forall {era} {b}.
Coin
-> [(RewardAccount (EraCrypto era), b)] -> ImpM (LedgerSpec era) ()
checkNoWithdrawal Coin
initialTreasury [(RewardAccount (EraCrypto era), Coin)]
withdrawals

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Withdrawals exceeding treasury submitted in several proposals within the same epoch" forall a b. (a -> b) -> a -> b
$
      forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
        forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
        NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
        (Credential 'DRepRole (EraCrypto era)
drepC, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
        forall era. ConwayEraImp era => Coin -> ImpTestM era ()
donateToTreasury forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5_000_000
        Coin
initialTreasury <- forall {era}. ImpTestM era Coin
getTreasury
        Int
numWithdrawals <- forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Int
1, Int
10)
        [(RewardAccount (EraCrypto era), Coin)]
withdrawals <- forall {era}.
ShelleyEraImp era =>
Coin
-> Int
-> ImpM (LedgerSpec era) [(RewardAccount (EraCrypto era), Coin)]
genWithdrawalsExceeding Coin
initialTreasury Int
numWithdrawals

        forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"submit in individual proposals in the same epoch" forall a b. (a -> b) -> a -> b
$ do
          forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
            ( \(RewardAccount (EraCrypto era), Coin)
w -> do
                GovActionId (EraCrypto era)
gaId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, ConwayEraGov era) =>
[(RewardAccount (EraCrypto era), Coin)]
-> ImpTestM era (GovActionId (EraCrypto era))
submitTreasuryWithdrawals @era [(RewardAccount (EraCrypto era), Coin)
w]
                forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drepC) GovActionId (EraCrypto era)
gaId
                forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs GovActionId (EraCrypto era)
gaId
            )
            [(RewardAccount (EraCrypto era), Coin)]
withdrawals
          forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2

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

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

hardForkInitiationSpec ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , InjectRuleEvent "TICK" ConwayEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationSpec :: forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationSpec =
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HardForkInitiation" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
    NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DRepVotingThresholds UnitInterval
dvtHardForkInitiationL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
2 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PoolVotingThresholds UnitInterval
pvtHardForkInitiationL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
2 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
    (KeyHash 'StakePool (EraCrypto era),
 Credential 'Payment (EraCrypto era),
 Credential 'Staking (EraCrypto era))
_ <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool (EraCrypto era)
stakePoolId1, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool (EraCrypto era)
stakePoolId2, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (Credential 'DRepRole (EraCrypto era)
dRep1, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
11_000_000
    (Credential 'DRepRole (EraCrypto era)
dRep2, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
11_000_000
    ProtVer
curProtVer <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    Version
nextMajorVersion <- forall (m :: * -> *). MonadFail m => Version -> m Version
succVersion forall a b. (a -> b) -> a -> b
$ ProtVer -> Version
pvMajor ProtVer
curProtVer
    let nextProtVer :: ProtVer
nextProtVer = ProtVer
curProtVer {pvMajor :: Version
pvMajor = Version
nextMajorVersion}
    GovActionId (EraCrypto era)
govActionId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
HardForkInitiation forall a. StrictMaybe a
SNothing ProtVer
nextProtVer
    forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers' GovActionId (EraCrypto era)
govActionId
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
dRep1) GovActionId (EraCrypto era)
govActionId
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
stakePoolId1) GovActionId (EraCrypto era)
govActionId
    forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      forall a b. a -> (a -> b) -> b
& forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    forall era. EraGov era => ImpTestM era ProtVer
getProtVer forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
curProtVer
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
dRep2) GovActionId (EraCrypto era)
govActionId
    forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      forall a b. a -> (a -> b) -> b
& forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    forall era. EraGov era => ImpTestM era ProtVer
getProtVer forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
curProtVer
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
stakePoolId2) GovActionId (EraCrypto era)
govActionId
    forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      forall a b. a -> (a -> b) -> b
& forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ forall era (rule :: Symbol).
(Typeable (Event (EraRule rule era)),
 Eq (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era))) =>
Event (EraRule rule era) -> SomeSTSEvent era
SomeSTSEvent @era @"TICK" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent forall a b. (a -> b) -> a -> b
$
              forall era. Event (EraRule "HARDFORK" era) -> ConwayEpochEvent era
HardForkEvent (forall era. ProtVer -> ConwayHardForkEvent era
ConwayHardForkEvent ProtVer
nextProtVer)
          ]

    forall era. EraGov era => ImpTestM era ProtVer
getProtVer forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
nextProtVer

hardForkInitiationNoDRepsSpec ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  , InjectRuleEvent "TICK" ConwayEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationNoDRepsSpec :: forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era,
 InjectRuleEvent "TICK" ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
hardForkInitiationNoDRepsSpec =
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HardForkInitiation without DRep voting" forall a b. (a -> b) -> a -> b
$ do
    NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PoolVotingThresholds UnitInterval
pvtHardForkInitiationL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
2 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
    forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DRepVotingThresholds UnitInterval
dvtHardForkInitiationL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Default a => a
def)
    (KeyHash 'StakePool (EraCrypto era),
 Credential 'Payment (EraCrypto era),
 Credential 'Staking (EraCrypto era))
_ <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool (EraCrypto era)
stakePoolId1, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool (EraCrypto era)
stakePoolId2, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    ProtVer
curProtVer <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    Version
nextMajorVersion <- forall (m :: * -> *). MonadFail m => Version -> m Version
succVersion forall a b. (a -> b) -> a -> b
$ ProtVer -> Version
pvMajor ProtVer
curProtVer
    let nextProtVer :: ProtVer
nextProtVer = ProtVer
curProtVer {pvMajor :: Version
pvMajor = Version
nextMajorVersion}
    GovActionId (EraCrypto era)
govActionId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
HardForkInitiation forall a. StrictMaybe a
SNothing ProtVer
nextProtVer
    forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers' GovActionId (EraCrypto era)
govActionId
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
stakePoolId1) GovActionId (EraCrypto era)
govActionId
    forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      forall a b. a -> (a -> b) -> b
& forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    forall era. EraGov era => ImpTestM era ProtVer
getProtVer forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
curProtVer
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
stakePoolId2) GovActionId (EraCrypto era)
govActionId
    forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      forall a b. a -> (a -> b) -> b
& forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen
      forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure
          [ forall era (rule :: Symbol).
(Typeable (Event (EraRule rule era)),
 Eq (Event (EraRule rule era)),
 ToExpr (Event (EraRule rule era))) =>
Event (EraRule rule era) -> SomeSTSEvent era
SomeSTSEvent @era @"TICK" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleEvent rule t era =>
t era -> EraRuleEvent rule era
injectEvent forall a b. (a -> b) -> a -> b
$
              forall era. Event (EraRule "HARDFORK" era) -> ConwayEpochEvent era
HardForkEvent (forall era. ProtVer -> ConwayHardForkEvent era
ConwayHardForkEvent ProtVer
nextProtVer)
          ]
    forall era. EraGov era => ImpTestM era ProtVer
getProtVer forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
nextProtVer

pparamPredictionSpec :: ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
pparamPredictionSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
pparamPredictionSpec =
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"futurePParams" forall a b. (a -> b) -> a -> b
$ do
    NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers' <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PoolVotingThresholds UnitInterval
pvtHardForkInitiationL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
2 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3
    forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DRepVotingThresholds UnitInterval
dvtHardForkInitiationL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Default a => a
def)
    (KeyHash 'StakePool (EraCrypto era),
 Credential 'Payment (EraCrypto era),
 Credential 'Staking (EraCrypto era))
_ <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool (EraCrypto era)
stakePoolId1, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    (KeyHash 'StakePool (EraCrypto era)
stakePoolId2, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
22_000_000
    ProtVer
curProtVer <- forall era. EraGov era => ImpTestM era ProtVer
getProtVer
    Version
nextMajorVersion <- forall (m :: * -> *). MonadFail m => Version -> m Version
succVersion forall a b. (a -> b) -> a -> b
$ ProtVer -> Version
pvMajor ProtVer
curProtVer
    let nextProtVer :: ProtVer
nextProtVer = ProtVer
curProtVer {pvMajor :: Version
pvMajor = Version
nextMajorVersion}
    GovActionId (EraCrypto era)
govActionId <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'HardForkPurpose era)
-> ProtVer -> GovAction era
HardForkInitiation forall a. StrictMaybe a
SNothing ProtVer
nextProtVer
    forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeMembers' GovActionId (EraCrypto era)
govActionId
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
stakePoolId1) GovActionId (EraCrypto era)
govActionId
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
stakePoolId2) GovActionId (EraCrypto era)
govActionId
    forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    forall era. ImpTestM era ()
advanceToPointOfNoReturn
    forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    forall era. EraGov era => ImpTestM era ProtVer
getProtVer forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` ProtVer
nextProtVer

noConfidenceSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
noConfidenceSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
noConfidenceSpec =
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"NoConfidence" forall a b. (a -> b) -> a -> b
$ forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap forall a b. (a -> b) -> a -> b
$ do
    forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
      PParams era
pp
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DRepVotingThresholds UnitInterval
dvtCommitteeNoConfidenceL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PoolVotingThresholds UnitInterval
pvtCommitteeNoConfidenceL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2
        forall a b. a -> (a -> b) -> b
& forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
200
    let
      getCommittee :: ImpTestM era (StrictMaybe (Committee era))
getCommittee =
        forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$
          forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
      assertNoCommittee :: HasCallStack => ImpTestM era ()
      assertNoCommittee :: HasCallStack => ImpTestM era ()
assertNoCommittee =
        do
          StrictMaybe (Committee era)
committee <- ImpTestM era (StrictMaybe (Committee era))
getCommittee
          forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"There should not be a committee" forall a b. (a -> b) -> a -> b
$ StrictMaybe (Committee era)
committee forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. StrictMaybe a
SNothing
    KeyHash 'ColdCommitteeRole (EraCrypto era)
khCC <- forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
    Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommitteeMembers <- forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole (EraCrypto era)))
getCommitteeMembers

    (Credential 'DRepRole (EraCrypto era)
drep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
    EpochNo
startEpochNo <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era. Lens' (NewEpochState era) EpochNo
nesELL
    let committeeMap :: Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMap =
          forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
            [ (forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj KeyHash 'ColdCommitteeRole (EraCrypto era)
khCC, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startEpochNo (Word32 -> EpochInterval
EpochInterval Word32
50))
            ]
    prevGaidCommittee :: GovPurposeId 'CommitteePurpose era
prevGaidCommittee@(GovPurposeId GovActionId (EraCrypto era)
gaidCommittee) <-
      forall era.
(HasCallStack, ConwayEraImp era) =>
StrictMaybe (GovPurposeId 'CommitteePurpose era)
-> Credential 'DRepRole (EraCrypto era)
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> ImpTestM era (GovPurposeId 'CommitteePurpose era)
electCommittee
        forall a. StrictMaybe a
SNothing
        Credential 'DRepRole (EraCrypto era)
drep
        Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommitteeMembers
        Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMap
    (KeyHash 'StakePool (EraCrypto era)
khSPO, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
    forall era. HasCallStack => ImpTestM era ()
logStakeDistr
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
khSPO) GovActionId (EraCrypto era)
gaidCommittee
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
4 forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Committee should be elected" forall a b. (a -> b) -> a -> b
$ do
      StrictMaybe (Committee era)
committee <- ImpTestM era (StrictMaybe (Committee era))
getCommittee
      StrictMaybe (Committee era)
committee forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. a -> StrictMaybe a
SJust (forall era.
Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> UnitInterval -> Committee era
Committee Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMap forall a b. (a -> b) -> a -> b
$ Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
    GovActionId (EraCrypto era)
gaidNoConf <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era) =>
GovAction era -> ImpTestM era (ProposalProcedure era)
mkProposal (forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era) -> GovAction era
NoConfidence (forall a. a -> StrictMaybe a
SJust GovPurposeId 'CommitteePurpose era
prevGaidCommittee)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
ProposalProcedure era -> ImpTestM era (GovActionId (EraCrypto era))
submitProposal
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
khSPO) GovActionId (EraCrypto era)
gaidNoConf
    forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drep) GovActionId (EraCrypto era)
gaidNoConf
    forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
4 forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
    HasCallStack => ImpTestM era ()
assertNoCommittee

constitutionSpec ::
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
constitutionSpec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
constitutionSpec =
  forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Constitution" forall a b. (a -> b) -> a -> b
$ do
    (Credential 'HotCommitteeRole (EraCrypto era)
committeeMember1 :| [Item [Credential 'HotCommitteeRole (EraCrypto era)]
committeeMember2]) <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
    (Credential 'DRepRole (EraCrypto era)
dRep, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
    Constitution era
initialConstitution <- forall era. ConwayEraImp era => ImpTestM era (Constitution era)
getConstitution
    (ProposalProcedure era
proposal, Constitution era
constitution) <- forall era.
ConwayEraImp era =>
StrictMaybe (GovPurposeId 'ConstitutionPurpose era)
-> ImpTestM era (ProposalProcedure era, Constitution era)
mkConstitutionProposal forall a. StrictMaybe a
SNothing
    Maybe (GovActionId (EraCrypto era))
mbGovActionId <-
      forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era
-> ImpTestM era (Maybe (GovActionId (EraCrypto era)))
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal forall a b. (a -> b) -> a -> b
$
        forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal)]
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (GovActionId (EraCrypto era))
mbGovActionId forall a b. (a -> b) -> a -> b
$ \GovActionId (EraCrypto era)
govActionId -> do
      Proposals era
proposalsBeforeVotes <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
proposalsGovStateL
      DRepPulsingState era
pulserBeforeVotes <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL

      forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
dRep) GovActionId (EraCrypto era)
govActionId
      forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'HotCommitteeRole c -> Voter c
CommitteeVoter Credential 'HotCommitteeRole (EraCrypto era)
committeeMember1) GovActionId (EraCrypto era)
govActionId
      forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'HotCommitteeRole c -> Voter c
CommitteeVoter Item [Credential 'HotCommitteeRole (EraCrypto era)]
committeeMember2) GovActionId (EraCrypto era)
govActionId

      Proposals era
proposalsAfterVotes <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
proposalsGovStateL
      DRepPulsingState era
pulserAfterVotes <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Votes are recorded in the proposals" forall a b. (a -> b) -> a -> b
$ do
        let proposalsWithVotes :: Proposals era
proposalsWithVotes =
              forall era.
Voter (EraCrypto era)
-> Vote
-> GovActionId (EraCrypto era)
-> Proposals era
-> Proposals era
proposalsAddVote
                (forall c. Credential 'HotCommitteeRole c -> Voter c
CommitteeVoter Credential 'HotCommitteeRole (EraCrypto era)
committeeMember1)
                Vote
VoteYes
                GovActionId (EraCrypto era)
govActionId
                ( forall era.
Voter (EraCrypto era)
-> Vote
-> GovActionId (EraCrypto era)
-> Proposals era
-> Proposals era
proposalsAddVote
                    (forall c. Credential 'HotCommitteeRole c -> Voter c
CommitteeVoter Item [Credential 'HotCommitteeRole (EraCrypto era)]
committeeMember2)
                    Vote
VoteYes
                    GovActionId (EraCrypto era)
govActionId
                    ( forall era.
Voter (EraCrypto era)
-> Vote
-> GovActionId (EraCrypto era)
-> Proposals era
-> Proposals era
proposalsAddVote
                        (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
dRep)
                        Vote
VoteYes
                        GovActionId (EraCrypto era)
govActionId
                        Proposals era
proposalsBeforeVotes
                    )
                )
        Proposals era
proposalsAfterVotes forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Proposals era
proposalsWithVotes

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Pulser has not changed" forall a b. (a -> b) -> a -> b
$
        DRepPulsingState era
pulserAfterVotes forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` DRepPulsingState era
pulserBeforeVotes

      forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"New constitution is not enacted after one epoch" forall a b. (a -> b) -> a -> b
$ do
        Constitution era
constitutionAfterOneEpoch <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
constitutionGovStateL
        Constitution era
constitutionAfterOneEpoch forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Constitution era
initialConstitution

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Pulser should reflect the constitution to be enacted" forall a b. (a -> b) -> a -> b
$ do
        DRepPulsingState era
pulser <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL
        let ratifyState :: RatifyState era
ratifyState = forall era. DRepPulsingState era -> RatifyState era
extractDRepPulsingState DRepPulsingState era
pulser
        forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. RatifyState era -> Seq (GovActionState era)
rsEnacted RatifyState era
ratifyState forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` GovActionId (EraCrypto era)
govActionId forall a. a -> Seq a -> Seq a
Seq.:<| forall a. Seq a
Seq.Empty
        forall era. RatifyState era -> EnactState era
rsEnactState RatifyState era
ratifyState forall s a. s -> Getting a s a -> a
^. forall era. Lens' (EnactState era) (Constitution era)
ensConstitutionL forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Constitution era
constitution

      forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Constitution is enacted after two epochs" forall a b. (a -> b) -> a -> b
$ do
        Constitution era
curConstitution <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (GovState era)
newEpochStateGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
constitutionGovStateL
        Constitution era
curConstitution forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` Constitution era
constitution

      forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"Pulser is reset" forall a b. (a -> b) -> a -> b
$ do
        DRepPulsingState era
pulser <- forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL
        let pulserRatifyState :: RatifyState era
pulserRatifyState = forall era. DRepPulsingState era -> RatifyState era
extractDRepPulsingState DRepPulsingState era
pulser
        forall era. RatifyState era -> Seq (GovActionState era)
rsEnacted RatifyState era
pulserRatifyState forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. Seq a
Seq.empty
        EnactState era
enactState <- forall era. ConwayEraGov era => ImpTestM era (EnactState era)
getEnactState
        forall era. RatifyState era -> EnactState era
rsEnactState RatifyState era
pulserRatifyState forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` EnactState era
enactState

actionPrioritySpec ::
  forall era.
  ( ConwayEraImp era
  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
actionPrioritySpec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
actionPrioritySpec =
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Competing proposals" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"higher action priority wins" forall a b. (a -> b) -> a -> b
$ do
      (Credential 'DRepRole (EraCrypto era)
drepC, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
      (KeyHash 'StakePool (EraCrypto era)
poolKH, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000
      Credential 'ColdCommitteeRole (EraCrypto era)
cc <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      ProposalProcedure era
proposal <-
        forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal forall a. Maybe a
Nothing forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole (EraCrypto era)
cc, Word32 -> EpochInterval
EpochInterval Word32
30)] (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
3)
      Maybe (GovActionId (EraCrypto era))
mbGai1 <-
        forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era
-> ImpTestM era (Maybe (GovActionId (EraCrypto era)))
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal forall a b. (a -> b) -> a -> b
$
          forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (GovActionId (EraCrypto era))
mbGai1 forall a b. (a -> b) -> a -> b
$ \GovActionId (EraCrypto era)
gai1 -> do
        -- gai2 is the first action of a higher priority
        GovActionId (EraCrypto era)
gai2 <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era) -> GovAction era
NoConfidence forall a. StrictMaybe a
SNothing
        GovActionId (EraCrypto era)
gai3 <- forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
GovAction era -> ImpTestM era (GovActionId (EraCrypto era))
submitGovAction forall a b. (a -> b) -> a -> b
$ forall era.
StrictMaybe (GovPurposeId 'CommitteePurpose era) -> GovAction era
NoConfidence forall a. StrictMaybe a
SNothing
        forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ @[]
          ( \GovActionId (EraCrypto era)
gaid -> do
              forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drepC) GovActionId (EraCrypto era)
gaid
              forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
poolKH) GovActionId (EraCrypto era)
gaid
          )
          [GovActionId (EraCrypto era)
gai1, GovActionId (EraCrypto era)
gai2, GovActionId (EraCrypto era)
gai3]
        forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
        forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'CommitteePurpose era))
getLastEnactedCommittee
          forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` forall a. a -> StrictMaybe a
SJust (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
gai2)
        forall era. (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals

        StrictMaybe (Committee era)
committee <-
          forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$
            forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EpochState era) (LedgerState era)
esLStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (LedgerState era) (UTxOState era)
lsUTxOStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (UTxOState era) (GovState era)
utxosGovStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL
        StrictMaybe (Committee era)
committee forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. StrictMaybe a
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))
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
30, Integer
330)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
330, Integer
660)
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer
660, Integer
1000)
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"proposals of same priority are enacted in order of submission" forall a b. (a -> b) -> a -> b
$ do
      forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PoolVotingThresholds UnitInterval
pvtPPSecurityGroupL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DRepVotingThresholds UnitInterval
dvtPPEconomicGroupL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Default a => a
def)
      (Coin
val1, Coin
val2, Coin
val3) <- ImpM (LedgerSpec era) (Coin, Coin, Coin)
genMinFeeVals

      NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
      (KeyHash 'StakePool (EraCrypto era)
spoC, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
      GovActionId (EraCrypto era)
pGai0 <-
        forall era.
ConwayEraImp era =>
StrictMaybe (GovActionId (EraCrypto era))
-> PParamsUpdate era -> ImpTestM era (GovActionId (EraCrypto era))
submitParameterChange
          forall a. StrictMaybe a
SNothing
          forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Coin
val1
      GovActionId (EraCrypto era)
pGai1 <-
        forall era.
ConwayEraImp era =>
StrictMaybe (GovActionId (EraCrypto era))
-> PParamsUpdate era -> ImpTestM era (GovActionId (EraCrypto era))
submitParameterChange
          (forall a. a -> StrictMaybe a
SJust GovActionId (EraCrypto era)
pGai0)
          forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Coin
val2
      GovActionId (EraCrypto era)
pGai2 <-
        forall era.
ConwayEraImp era =>
StrictMaybe (GovActionId (EraCrypto era))
-> PParamsUpdate era -> ImpTestM era (GovActionId (EraCrypto era))
submitParameterChange
          (forall a. a -> StrictMaybe a
SJust GovActionId (EraCrypto era)
pGai1)
          forall a b. (a -> b) -> a -> b
$ forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Coin
val3
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ @[]
        ( \GovActionId (EraCrypto era)
gaid -> do
            forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
gaid
            forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs GovActionId (EraCrypto era)
gaid
        )
        [GovActionId (EraCrypto era)
pGai0, GovActionId (EraCrypto era)
pGai1, GovActionId (EraCrypto era)
pGai2]
      forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (GovPurposeId 'PParamUpdatePurpose era))
getLastEnactedParameterChange
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` forall a. a -> StrictMaybe a
SJust (forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
pGai2)
      forall era. (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals
      forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL)
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
val3

    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"only the first action of a transaction gets enacted" forall a b. (a -> b) -> a -> b
$ do
      forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' PoolVotingThresholds UnitInterval
pvtPPSecurityGroupL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams forall a b. (a -> b) -> a -> b
$ forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' DRepVotingThresholds UnitInterval
dvtPPEconomicGroupL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Default a => a
def)
      (Coin
val1, Coin
val2, Coin
val3) <- ImpM (LedgerSpec era) (Coin, Coin, Coin)
genMinFeeVals

      NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs <- forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era (NonEmpty (Credential 'HotCommitteeRole (EraCrypto era)))
registerInitialCommittee
      (KeyHash 'StakePool (EraCrypto era)
spoC, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
      StrictMaybe (ScriptHash (EraCrypto era))
policy <- forall era.
ConwayEraGov era =>
ImpTestM era (StrictMaybe (ScriptHash (EraCrypto era)))
getGovPolicy
      NonEmpty (GovActionId (EraCrypto era))
gaids <-
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
NonEmpty (GovAction era)
-> ImpTestM era (NonEmpty (GovActionId (EraCrypto era)))
submitGovActions forall a b. (a -> b) -> a -> b
$
          forall a. [a] -> NonEmpty a
NE.fromList
            [ forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era
-> StrictMaybe (ScriptHash (EraCrypto era))
-> GovAction era
ParameterChange
                forall a. StrictMaybe a
SNothing
                (forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Coin
val1)
                StrictMaybe (ScriptHash (EraCrypto era))
policy
            , forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era
-> StrictMaybe (ScriptHash (EraCrypto era))
-> GovAction era
ParameterChange
                forall a. StrictMaybe a
SNothing
                (forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Coin
val2)
                StrictMaybe (ScriptHash (EraCrypto era))
policy
            , forall era.
StrictMaybe (GovPurposeId 'PParamUpdatePurpose era)
-> PParamsUpdate era
-> StrictMaybe (ScriptHash (EraCrypto era))
-> GovAction era
ParameterChange
                forall a. StrictMaybe a
SNothing
                (forall a. Default a => a
def forall a b. a -> (a -> b) -> b
& forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictMaybe a
SJust Coin
val3)
                StrictMaybe (ScriptHash (EraCrypto era))
policy
            ]
      forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_
        ( \GovActionId (EraCrypto era)
gaid -> do
            forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
gaid
            forall era (f :: * -> *).
(ConwayEraImp era, Foldable f) =>
f (Credential 'HotCommitteeRole (EraCrypto era))
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVoteCCs_ NonEmpty (Credential 'HotCommitteeRole (EraCrypto era))
committeeCs GovActionId (EraCrypto era)
gaid
        )
        NonEmpty (GovActionId (EraCrypto era))
gaids
      forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (PParams era) Coin
ppMinFeeAL)
        forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` Coin
val1
      forall era. (HasCallStack, ConwayEraImp era) => ImpTestM era ()
expectNoCurrentProposals

expectHardForkEvents ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  ) =>
  [SomeSTSEvent era] ->
  [SomeSTSEvent era] ->
  ImpTestM era ()
expectHardForkEvents :: forall era.
(ConwayEraImp era,
 Event (EraRule "HARDFORK" era) ~ ConwayHardForkEvent era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
[SomeSTSEvent era] -> [SomeSTSEvent era] -> ImpTestM era ()
expectHardForkEvents [SomeSTSEvent era]
actual [SomeSTSEvent era]
expected =
  forall a. (a -> Bool) -> [a] -> [a]
filter SomeSTSEvent era -> Bool
isHardForkEvent [SomeSTSEvent era]
actual 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) <-
          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
  , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
committeeSpec :: forall era.
(ConwayEraImp era,
 InjectRuleFailure "LEDGER" ConwayGovPredFailure era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeSpec =
  forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Committee enactment" forall a b. (a -> b) -> a -> b
$ do
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Enact UpdateCommitee with lengthy lifetime" forall a b. (a -> b) -> a -> b
$ do
      NonNegative Natural
n <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
      forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
n
      (Credential 'DRepRole (EraCrypto era)
drepCred, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
      (KeyHash 'StakePool (EraCrypto era)
spoC, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
      Credential 'ColdCommitteeRole (EraCrypto era)
cc <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      EpochInterval Word32
committeeMaxTermLength <-
        forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES forall a b. (a -> b) -> a -> b
$ forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL
      ProposalProcedure era
proposal <-
        forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal forall a. Maybe a
Nothing forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole (EraCrypto era)
cc, Word32 -> EpochInterval
EpochInterval (Word32
committeeMaxTermLength forall a. Num a => a -> a -> a
+ Word32
2))] (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
      Maybe (GovActionId (EraCrypto era))
mbSecondAddCCGaid <-
        forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era
-> ImpTestM era (Maybe (GovActionId (EraCrypto era)))
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal forall a b. (a -> b) -> a -> b
$
          forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (GovActionId (EraCrypto era))
mbSecondAddCCGaid forall a b. (a -> b) -> a -> b
$ \GovActionId (EraCrypto era)
secondAddCCGaid -> do
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drepCred) GovActionId (EraCrypto era)
secondAddCCGaid
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
secondAddCCGaid
        forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
        -- Due to longer than allowed lifetime we have to wait an extra epoch for this new action to be enacted
        forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
expectCommitteeMemberAbsence Credential 'ColdCommitteeRole (EraCrypto era)
cc
        forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
        forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
expectCommitteeMemberPresence Credential 'ColdCommitteeRole (EraCrypto era)
cc

    -- A CC that has resigned will need to be first voted out and then voted in to be considered active
    forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"CC re-election" forall a b. (a -> b) -> a -> b
$ do
      (Credential 'DRepRole (EraCrypto era)
drepCred, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
      (KeyHash 'StakePool (EraCrypto era)
spoC, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
      forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
      -- Add a fresh CC
      Credential 'ColdCommitteeRole (EraCrypto era)
cc <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
      ProposalProcedure era
proposal <-
        forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal forall a. Maybe a
Nothing forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole (EraCrypto era)
cc, Word32 -> EpochInterval
EpochInterval Word32
10)] (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
      Maybe (GovActionId (EraCrypto era))
mbAddCCGaid <-
        forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era
-> ImpTestM era (Maybe (GovActionId (EraCrypto era)))
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal forall a b. (a -> b) -> a -> b
$
          forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (GovActionId (EraCrypto era))
mbAddCCGaid forall a b. (a -> b) -> a -> b
$ \GovActionId (EraCrypto era)
addCCGaid -> do
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drepCred) GovActionId (EraCrypto era)
addCCGaid
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
addCCGaid
        forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
        -- Confirm that they are added
        forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
expectCommitteeMemberPresence Credential 'ColdCommitteeRole (EraCrypto era)
cc
        -- Confirm their hot key registration
        Credential 'HotCommitteeRole (EraCrypto era)
_hotKey <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
registerCommitteeHotKey Credential 'ColdCommitteeRole (EraCrypto era)
cc
        forall era.
HasCallStack =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldNotBeResigned Credential 'ColdCommitteeRole (EraCrypto era)
cc
        -- Have them resign
        Maybe (Credential 'HotCommitteeRole (EraCrypto era))
_ <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> StrictMaybe (Anchor (EraCrypto era))
-> ImpTestM
     era (Maybe (Credential 'HotCommitteeRole (EraCrypto era)))
resignCommitteeColdKey Credential 'ColdCommitteeRole (EraCrypto era)
cc forall a. StrictMaybe a
SNothing
        forall era.
HasCallStack =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldBeResigned Credential 'ColdCommitteeRole (EraCrypto era)
cc
        -- Re-add the same CC
        GovActionId (EraCrypto era)
reAddCCGaid <- forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
-> UnitInterval
-> ImpTestM era (GovActionId (EraCrypto era))
submitUpdateCommittee forall a. Maybe a
Nothing forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole (EraCrypto era)
cc, Word32 -> EpochInterval
EpochInterval Word32
20)] (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drepCred) GovActionId (EraCrypto era)
reAddCCGaid
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
reAddCCGaid
        forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
        -- Confirm that they are still resigned
        forall era.
HasCallStack =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldBeResigned Credential 'ColdCommitteeRole (EraCrypto era)
cc
        -- Remove them
        GovActionId (EraCrypto era)
removeCCGaid <-
          forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
-> UnitInterval
-> ImpTestM era (GovActionId (EraCrypto era))
submitUpdateCommittee (forall a. a -> Maybe a
Just (forall a. a -> StrictMaybe a
SJust forall a b. (a -> b) -> a -> b
$ forall (p :: GovActionPurpose) era.
GovActionId (EraCrypto era) -> GovPurposeId p era
GovPurposeId GovActionId (EraCrypto era)
reAddCCGaid)) (forall a. a -> Set a
Set.singleton Credential 'ColdCommitteeRole (EraCrypto era)
cc) [] (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drepCred) GovActionId (EraCrypto era)
removeCCGaid
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
removeCCGaid
        forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
        -- Confirm that they have been removed
        forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
expectCommitteeMemberAbsence Credential 'ColdCommitteeRole (EraCrypto era)
cc
        GovActionId (EraCrypto era)
secondAddCCGaid <-
          forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
-> UnitInterval
-> ImpTestM era (GovActionId (EraCrypto era))
submitUpdateCommittee forall a. Maybe a
Nothing forall a. Monoid a => a
mempty [(Credential 'ColdCommitteeRole (EraCrypto era)
cc, Word32 -> EpochInterval
EpochInterval Word32
20)] (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drepCred) GovActionId (EraCrypto era)
secondAddCCGaid
        forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
secondAddCCGaid
        forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
        -- Confirm that they have been added
        forall era.
(HasCallStack, ConwayEraGov era) =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
expectCommitteeMemberPresence Credential 'ColdCommitteeRole (EraCrypto era)
cc
        -- Confirm that after registering a hot key, they are active
        Credential 'HotCommitteeRole (EraCrypto era)
_hotKey <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> ImpTestM era (Credential 'HotCommitteeRole (EraCrypto era))
registerCommitteeHotKey Credential 'ColdCommitteeRole (EraCrypto era)
cc
        forall era.
HasCallStack =>
Credential 'ColdCommitteeRole (EraCrypto era) -> ImpTestM era ()
ccShouldNotBeResigned Credential 'ColdCommitteeRole (EraCrypto era)
cc
    forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Removing CC with UpdateCommittee" forall a b. (a -> b) -> a -> b
$ do
      forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Non registered" forall a b. (a -> b) -> a -> b
$ do
        (Credential 'DRepRole (EraCrypto era)
drepCred, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
        (KeyHash 'StakePool (EraCrypto era)
spoC, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
        forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
        Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee <- forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole (EraCrypto era)))
getCommitteeMembers
        forall a era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee
        Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null
        ProposalProcedure era
proposal <-
          forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee forall a. Monoid a => a
mempty (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        Maybe (GovActionId (EraCrypto era))
mbRemoveCCGaid <-
          forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era
-> ImpTestM era (Maybe (GovActionId (EraCrypto era)))
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal forall a b. (a -> b) -> a -> b
$
            forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (GovActionId (EraCrypto era))
mbRemoveCCGaid forall a b. (a -> b) -> a -> b
$ \GovActionId (EraCrypto era)
removeCCGaid -> do
          forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drepCred) GovActionId (EraCrypto era)
removeCCGaid
          forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
removeCCGaid
          forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
          Set (Credential 'ColdCommitteeRole (EraCrypto era))
finalCommittee <- forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole (EraCrypto era)))
getCommitteeMembers
          forall a era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr Set (Credential 'ColdCommitteeRole (EraCrypto era))
finalCommittee
          Set (Credential 'ColdCommitteeRole (EraCrypto era))
finalCommittee forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` forall a. Set a -> Bool
Set.null
      forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Registered" forall a b. (a -> b) -> a -> b
$ do
        (Credential 'DRepRole (EraCrypto era)
drepCred, Credential 'Staking (EraCrypto era)
_, KeyPair 'Payment (EraCrypto era)
_) <- forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era
     (Credential 'DRepRole (EraCrypto era),
      Credential 'Staking (EraCrypto era),
      KeyPair 'Payment (EraCrypto era))
setupSingleDRep Integer
1_000_000
        (KeyHash 'StakePool (EraCrypto era)
spoC, Credential 'Payment (EraCrypto era)
_, Credential 'Staking (EraCrypto era)
_) <- forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
Coin
-> ImpTestM
     era
     (KeyHash 'StakePool (EraCrypto era),
      Credential 'Payment (EraCrypto era),
      Credential 'Staking (EraCrypto era))
setupPoolWithStake forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
42_000_000
        forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
        Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee <- forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole (EraCrypto era)))
getCommitteeMembers
        forall a era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee
        Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
a -> (a -> Bool) -> m ()
`shouldSatisfy` Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> Bool
Set.null
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. Set a -> [a]
Set.toList Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee) forall a b. (a -> b) -> a -> b
$ \Credential 'ColdCommitteeRole (EraCrypto era)
kh -> do
          Credential 'HotCommitteeRole (EraCrypto era)
ccHotCred <- forall (kr :: KeyRole) c. KeyHash kr c -> Credential kr c
KeyHashObj forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s c (m :: * -> *) g (r :: KeyRole).
(HasKeyPairs s c, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r c)
freshKeyHash
          forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx era -> ImpTestM era ()
submitTx_ forall a b. (a -> b) -> a -> b
$
            forall era. EraTx era => TxBody era -> Tx era
mkBasicTx forall era. EraTxBody era => TxBody era
mkBasicTxBody
              forall a b. a -> (a -> b) -> b
& forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL
                forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> StrictSeq a
SSeq.singleton (forall era.
ConwayEraTxCert era =>
Credential 'ColdCommitteeRole (EraCrypto era)
-> Credential 'HotCommitteeRole (EraCrypto era) -> TxCert era
AuthCommitteeHotKeyTxCert Credential 'ColdCommitteeRole (EraCrypto era)
kh Credential 'HotCommitteeRole (EraCrypto era)
ccHotCred)
        [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
newCommittee <- forall a (m :: * -> *). (Arbitrary a, MonadGen m) => m a
arbitrary
        Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialSubCommittee <- forall g (m :: * -> *). HasStatefulGen g m => m g
askStatefulGen forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall g (m :: * -> *) k.
(StatefulGen g m, Ord k) =>
Maybe Int -> Set k -> g -> m (Set k)
uniformSubSet forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee
        ProposalProcedure era
proposal <-
          forall era.
ConwayEraImp era =>
Maybe (StrictMaybe (GovPurposeId 'CommitteePurpose era))
-> Set (Credential 'ColdCommitteeRole (EraCrypto era))
-> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
-> UnitInterval
-> ImpTestM era (ProposalProcedure era)
mkUpdateCommitteeProposal forall a. Maybe a
Nothing Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialSubCommittee [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
newCommittee (Integer
1 forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2)
        Maybe (GovActionId (EraCrypto era))
mbRemoveCCGaid <-
          forall era.
ConwayEraImp era =>
ProposalProcedure era
-> SubmitFailureExpectation era
-> ImpTestM era (Maybe (GovActionId (EraCrypto era)))
submitBootstrapAwareFailingProposal ProposalProcedure era
proposal forall a b. (a -> b) -> a -> b
$
            forall era.
NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> SubmitFailureExpectation era
FailBootstrap [forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure forall a b. (a -> b) -> a -> b
$ forall era. ProposalProcedure era -> ConwayGovPredFailure era
DisallowedProposalDuringBootstrap ProposalProcedure era
proposal]
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (GovActionId (EraCrypto era))
mbRemoveCCGaid forall a b. (a -> b) -> a -> b
$ \GovActionId (EraCrypto era)
removeCCGaid -> do
          forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. Credential 'DRepRole c -> Voter c
DRepVoter Credential 'DRepRole (EraCrypto era)
drepCred) GovActionId (EraCrypto era)
removeCCGaid
          forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter (EraCrypto era)
-> GovActionId (EraCrypto era) -> ImpTestM era ()
submitYesVote_ (forall c. KeyHash 'StakePool c -> Voter c
StakePoolVoter KeyHash 'StakePool (EraCrypto era)
spoC) GovActionId (EraCrypto era)
removeCCGaid
          forall era. ShelleyEraImp era => Natural -> ImpTestM era ()
passNEpochs Natural
2
          Set (Credential 'ColdCommitteeRole (EraCrypto era))
finalCommittee <- forall era.
ConwayEraImp era =>
ImpTestM era (Set (Credential 'ColdCommitteeRole (EraCrypto era)))
getCommitteeMembers
          forall a era. (HasCallStack, ToExpr a) => a -> ImpTestM era ()
logToExpr Set (Credential 'ColdCommitteeRole (EraCrypto era))
finalCommittee
          Set (Credential 'ColdCommitteeRole (EraCrypto era))
finalCommittee
            forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
a -> a -> m ()
`shouldBe` forall a. Ord a => Set a -> Set a -> Set a
Set.union (Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialCommittee forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set (Credential 'ColdCommitteeRole (EraCrypto era))
initialSubCommittee) (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Credential 'ColdCommitteeRole (EraCrypto era), EpochInterval)]
newCommittee)