{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Conway (
  hardforkConwayBootstrapPhase,
  hardforkConwayDisallowUnelectedCommitteeFromVoting,
 )
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Conway.TxCert
import Cardano.Ledger.Credential
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Val (zero, (<->))
import Data.Default (def)
import Data.Foldable
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Lens.Micro
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.KeyPair
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Imp.Common

spec ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
votingSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
delayingActionsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeMinSizeAffectsInFlightProposalsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
paramChangeAffectsProposalsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeExpiryResignationDiscountSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeMaxTermLengthSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
spoVotesForHardForkInitiation
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
initiateHardForkWithLessThanMinimalCommitteeSize
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
spoAndCCVotingSpec
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Many CC Cold Credentials map to the same Hot Credential act as many votes" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    hotCred NE.:| _ <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
    (dRep, _, _) <- setupSingleDRep =<< uniformRM (10_000_000, 1_000_000_000)
    deposit <- uniformRM (1_000_000, 100_000_000_000)
    gaId <- submitParameterChange SNothing $ def & ppuDRepDepositL .~ SJust (Coin deposit)
    submitYesVote_ (CommitteeVoter hotCred) gaId
    whenPostBootstrap $ submitYesVote_ (DRepVoter dRep) gaId
    passNEpochs 2
    logAcceptedRatio gaId
    getLastEnactedParameterChange `shouldReturn` SNothing
    -- Make sure all committee members authorize the same hot credential that just voted:
    committeeMembers' <- Set.toList <$> getCommitteeMembers
    case committeeMembers' of
      Credential ColdCommitteeRole
x : [Credential ColdCommitteeRole]
xs -> ImpTestM era (NonEmpty (Credential HotCommitteeRole))
-> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ImpTestM era (NonEmpty (Credential HotCommitteeRole))
 -> ImpM (LedgerSpec era) ())
-> ImpTestM era (NonEmpty (Credential HotCommitteeRole))
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ ImpTestM era (Credential HotCommitteeRole)
-> NonEmpty (Credential ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(ShelleyEraImp era, ConwayEraTxCert era) =>
ImpTestM era (Credential HotCommitteeRole)
-> NonEmpty (Credential ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerCommitteeHotKeys (Credential HotCommitteeRole
-> ImpTestM era (Credential HotCommitteeRole)
forall a. a -> ImpM (LedgerSpec era) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Credential HotCommitteeRole
hotCred) (NonEmpty (Credential ColdCommitteeRole)
 -> ImpTestM era (NonEmpty (Credential HotCommitteeRole)))
-> NonEmpty (Credential ColdCommitteeRole)
-> ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall a b. (a -> b) -> a -> b
$ Credential ColdCommitteeRole
x Credential ColdCommitteeRole
-> [Credential ColdCommitteeRole]
-> NonEmpty (Credential ColdCommitteeRole)
forall a. a -> [a] -> NonEmpty a
NE.:| [Credential ColdCommitteeRole]
xs
      [Credential ColdCommitteeRole]
_ -> String -> ImpM (LedgerSpec era) ()
forall a. HasCallStack => String -> a
error String
"Expected an initial committee"
    passNEpochs 2
    getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId gaId)

initiateHardForkWithLessThanMinimalCommitteeSize ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
initiateHardForkWithLessThanMinimalCommitteeSize :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
initiateHardForkWithLessThanMinimalCommitteeSize =
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Hard Fork can still be initiated with less than minimal committee size" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    hotCs <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
    (spoK1, _, _) <- setupPoolWithStake $ Coin 3_000_000_000
    passEpoch
    modifyPParams $ ppCommitteeMinSizeL .~ 2
    committeeMembers' <- Set.toList <$> getCommitteeMembers
    committeeMember <- elements committeeMembers'
    anchor <- arbitrary
    mHotCred <- resignCommitteeColdKey committeeMember anchor
    protVer <- getProtVer
    gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer)
    submitYesVoteCCs_ (maybe NE.toList (\Credential HotCommitteeRole
hotCred -> (Credential HotCommitteeRole -> Bool)
-> NonEmpty (Credential HotCommitteeRole)
-> [Credential HotCommitteeRole]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (Credential HotCommitteeRole -> Credential HotCommitteeRole -> Bool
forall a. Eq a => a -> a -> Bool
/= Credential HotCommitteeRole
hotCred)) mHotCred hotCs) gai
    submitYesVote_ (StakePoolVoter spoK1) gai
    if hardforkConwayBootstrapPhase protVer
      then do
        isCommitteeAccepted gai `shouldReturn` True
        passNEpochs 2
        getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gai)
      else do
        isCommitteeAccepted gai `shouldReturn` False
        passNEpochs 2
        getLastEnactedHardForkInitiation `shouldReturn` SNothing

spoAndCCVotingSpec ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
spoAndCCVotingSpec :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
spoAndCCVotingSpec = do
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"When CC expired" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let expireCommitteeMembers :: ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
expireCommitteeMembers = do
          hotCs <- ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
          -- TODO: change the maxtermlength to make the test faster
          EpochInterval committeeMaxTermLength <-
            getsNES $
              nesEsL . curPParamsEpochStateL . ppCommitteeMaxTermLengthL
          passNEpochs $ fromIntegral committeeMaxTermLength
          ms <- getCommitteeMembers
          -- Make sure that committee expired
          forM_ ms ccShouldBeExpired
          pure hotCs
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPOs alone can't enact hard-fork" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      hotCs <- ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
expireCommitteeMembers
      (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000_000
      protVer <- getProtVer

      gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer)

      submitYesVote_ (StakePoolVoter spoC) gai
      -- CC members expired so their votes don't count - we are stuck!
      submitYesVoteCCs_ hotCs gai

      passNEpochs 2

      getLastEnactedHardForkInitiation `shouldReturn` SNothing
      getProtVer `shouldReturn` protVer
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPOs alone can't enact security group parameter change" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
-> ImpM (LedgerSpec era) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ImpM (LedgerSpec era) (NonEmpty (Credential HotCommitteeRole))
expireCommitteeMembers
      (spoC, _, _) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
      initialRefScriptBaseFee <- getsPParams ppMinFeeRefScriptCostPerByteL

      gid <-
        submitParameterChange SNothing $
          emptyPParamsUpdate
            & ppuMinFeeRefScriptCostPerByteL .~ SJust (25 %! 2)

      submitYesVote_ (StakePoolVoter spoC) gid

      passNEpochs 2

      getLastEnactedParameterChange `shouldReturn` SNothing
      getsPParams ppMinFeeRefScriptCostPerByteL `shouldReturn` initialRefScriptBaseFee
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"When CC threshold is 0" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    -- During the bootstrap phase, proposals that modify the committee are not allowed,
    -- hence we need to directly set the threshold for the initial members
    let
      modifyCommittee :: (StrictMaybe (Committee era) -> StrictMaybe (Committee era))
-> ImpTestM era ()
modifyCommittee StrictMaybe (Committee era) -> StrictMaybe (Committee era)
f = (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES ((NewEpochState era -> NewEpochState era) -> ImpTestM era ())
-> (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \NewEpochState era
nes ->
        NewEpochState era
nes
          NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (GovState era -> Identity (GovState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((GovState era -> Identity (GovState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((StrictMaybe (Committee era)
     -> Identity (StrictMaybe (Committee era)))
    -> GovState era -> Identity (GovState era))
-> (StrictMaybe (Committee era)
    -> Identity (StrictMaybe (Committee era)))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Identity (StrictMaybe (Committee era)))
-> GovState era -> Identity (GovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (StrictMaybe (Committee era))
Lens' (GovState era) (StrictMaybe (Committee era))
committeeGovStateL ((StrictMaybe (Committee era)
  -> Identity (StrictMaybe (Committee era)))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (StrictMaybe (Committee era) -> StrictMaybe (Committee era))
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ StrictMaybe (Committee era) -> StrictMaybe (Committee era)
f
          NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (DRepPulsingState era -> Identity (DRepPulsingState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era.
ConwayEraGov era =>
Lens' (NewEpochState era) (DRepPulsingState era)
Lens' (NewEpochState era) (DRepPulsingState era)
newEpochStateDRepPulsingStateL ((DRepPulsingState era -> Identity (DRepPulsingState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> (DRepPulsingState era -> DRepPulsingState era)
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ DRepPulsingState era -> DRepPulsingState era
modifyDRepPulser
        where
          modifyDRepPulser :: DRepPulsingState era -> DRepPulsingState era
modifyDRepPulser DRepPulsingState era
pulser =
            case DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
forall era.
(EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser DRepPulsingState era
pulser of
              (PulsingSnapshot era
snapshot, RatifyState era
rState) -> PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
forall era.
PulsingSnapshot era -> RatifyState era -> DRepPulsingState era
DRComplete PulsingSnapshot era
snapshot (RatifyState era
rState RatifyState era
-> (RatifyState era -> RatifyState era) -> RatifyState era
forall a b. a -> (a -> b) -> b
& (EnactState era -> Identity (EnactState era))
-> RatifyState era -> Identity (RatifyState era)
forall era (f :: * -> *).
Functor f =>
(EnactState era -> f (EnactState era))
-> RatifyState era -> f (RatifyState era)
rsEnactStateL ((EnactState era -> Identity (EnactState era))
 -> RatifyState era -> Identity (RatifyState era))
-> ((StrictMaybe (Committee era)
     -> Identity (StrictMaybe (Committee era)))
    -> EnactState era -> Identity (EnactState era))
-> (StrictMaybe (Committee era)
    -> Identity (StrictMaybe (Committee era)))
-> RatifyState era
-> Identity (RatifyState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Identity (StrictMaybe (Committee era)))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (Committee era) -> f (StrictMaybe (Committee era)))
-> EnactState era -> f (EnactState era)
ensCommitteeL ((StrictMaybe (Committee era)
  -> Identity (StrictMaybe (Committee era)))
 -> RatifyState era -> Identity (RatifyState era))
-> (StrictMaybe (Committee era) -> StrictMaybe (Committee era))
-> RatifyState era
-> RatifyState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ StrictMaybe (Committee era) -> StrictMaybe (Committee era)
f)
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPOs alone can enact hard-fork during bootstrap" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (spoC, _, _) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
      protVer <- getProtVer
      nextMajorVersion <- succVersion $ pvMajor protVer
      let nextProtVer = ProtVer
protVer {pvMajor = nextMajorVersion}
      modifyCommittee $ fmap (committeeThresholdL .~ 0 %! 1)

      gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer)

      submitYesVote_ (StakePoolVoter spoC) gai

      passNEpochs 2

      if hardforkConwayBootstrapPhase protVer
        then do
          getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gai)
          getProtVer `shouldReturn` nextProtVer
        else do
          getLastEnactedHardForkInitiation `shouldReturn` SNothing
          getProtVer `shouldReturn` protVer
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPOs alone can enact security group parameter change during bootstrap" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (spoC, _, _) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
      protVer <- getProtVer
      initialRefScriptBaseFee <- getsPParams ppMinFeeRefScriptCostPerByteL
      modifyCommittee $ fmap (committeeThresholdL .~ 0 %! 1)

      gai <-
        submitParameterChange SNothing $
          emptyPParamsUpdate
            & ppuMinFeeRefScriptCostPerByteL .~ SJust (25 %! 2)

      submitYesVote_ (StakePoolVoter spoC) gai

      passNEpochs 2

      newRefScriptBaseFee <- getsPParams ppMinFeeRefScriptCostPerByteL
      if hardforkConwayBootstrapPhase protVer
        then do
          getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId gai)
          newRefScriptBaseFee `shouldBe` (25 %! 2)
        else do
          getLastEnactedParameterChange `shouldReturn` SNothing
          newRefScriptBaseFee `shouldBe` initialRefScriptBaseFee
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Constitution cannot be changed if active committee size is below min size"
      (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
-> SpecWith (ImpInit (LedgerSpec era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap
      (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
          PParams era
pp
            PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtUpdateToConstitutionL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1)
            PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Natural -> Identity Natural)
-> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Natural
Lens' (PParams era) Natural
ppCommitteeMinSizeL ((Natural -> Identity Natural)
 -> PParams era -> Identity (PParams era))
-> Natural -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
2
            PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
50
        coldCommitteeActive <- KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
        coldCommitteeInactive <- KeyHashObj <$> freshKeyHash
        startingEpoch <- getsNES nesELL
        maxTermLength <- getsPParams ppCommitteeMaxTermLengthL
        (dRep, _, _) <- setupSingleDRep 1_000_000_000
        (spo, _, _) <- setupPoolWithStake $ Coin 1_000_000_000
        let
          committeeMap =
            [ (Credential ColdCommitteeRole
coldCommitteeActive, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startingEpoch EpochInterval
maxTermLength)
            , (Credential ColdCommitteeRole
coldCommitteeInactive, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startingEpoch (EpochInterval -> EpochNo) -> EpochInterval -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval Word32
5)
            ]
        initialCommittee <- getCommitteeMembers
        committeeActionId <-
          impAnn "Submit committee update"
            . submitGovAction
            $ UpdateCommittee
              SNothing
              initialCommittee
              committeeMap
              (0 %! 1)
        submitYesVote_ (DRepVoter dRep) committeeActionId
        submitYesVote_ (StakePoolVoter spo) committeeActionId
        passNEpochs 2
        getCommitteeMembers `shouldReturn` Map.keysSet committeeMap
        passNEpochs 3
        newConstitution <- arbitrary
        constitutionActionId <- submitGovAction $ NewConstitution SNothing newConstitution
        logRatificationChecks constitutionActionId
        passNEpochs 2
        getConstitution `shouldNotReturn` newConstitution
  -- https://github.com/IntersectMBO/cardano-ledger/issues/5418
  -- TODO: Re-enable after issue is resolved, by removing this override
  String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Committee proposals pass with inactive committee" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
    ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
      (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
        PParams era
pp
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Natural -> Identity Natural)
-> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Natural
Lens' (PParams era) Natural
ppCommitteeMinSizeL ((Natural -> Identity Natural)
 -> PParams era -> Identity (PParams era))
-> Natural -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
2
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
50
      coldCommitteeActive <- KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      coldCommitteeInactive <- KeyHashObj <$> freshKeyHash
      startingEpoch <- getsNES nesELL
      maxTermLength <- getsPParams ppCommitteeMaxTermLengthL
      (drep, _, _) <- setupSingleDRep 1_000_000_000
      (spo, _, _) <- setupPoolWithStake $ Coin 1_000_000_000
      let
        committeeMap =
          [ (Credential ColdCommitteeRole
coldCommitteeActive, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startingEpoch EpochInterval
maxTermLength)
          , (Credential ColdCommitteeRole
coldCommitteeInactive, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startingEpoch (EpochInterval -> EpochNo) -> EpochInterval -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval Word32
5)
          ]
      initialCommittee <- getCommitteeMembers
      committeeActionId <-
        impAnn "Submit committee update"
          . submitGovAction
          $ UpdateCommittee
            SNothing
            initialCommittee
            committeeMap
            (0 %! 1)
      submitYesVote_ (DRepVoter drep) committeeActionId
      submitYesVote_ (StakePoolVoter spo) committeeActionId
      passNEpochs 5
      getCommitteeMembers `shouldReturn` Map.keysSet committeeMap
      committeeProposal <-
        elements
          [ NoConfidence (SJust (GovPurposeId committeeActionId))
          , UpdateCommittee (SJust (GovPurposeId committeeActionId)) Set.empty [] (0 %! 1)
          ]
      committeeActionId2 <- submitGovAction committeeProposal
      submitYesVote_ (DRepVoter drep) committeeActionId2
      submitYesVote_ (StakePoolVoter spo) committeeActionId2
      passNEpochs 2
      getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId committeeActionId2)

committeeExpiryResignationDiscountSpec ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
committeeExpiryResignationDiscountSpec :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeExpiryResignationDiscountSpec =
  -- Committee-update proposals are disallowed during bootstrap, so we can only run these tests post-bootstrap
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Expired and resigned committee members are discounted from quorum" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Expired" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (Natural -> Identity Natural)
-> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Natural
Lens' (PParams era) Natural
ppCommitteeMinSizeL ((Natural -> Identity Natural)
 -> PParams era -> Identity (PParams era))
-> Natural -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
2
      (drep, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
      (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
      -- Elect a committee of 2 members
      committeeColdC1 <- KeyHashObj <$> freshKeyHash
      committeeColdC2 <- KeyHashObj <$> freshKeyHash
      gaiCC <-
        submitUpdateCommittee
          Nothing
          mempty
          [ (committeeColdC1, EpochInterval 10)
          , (committeeColdC2, EpochInterval 2)
          ]
          (1 %! 2)
      submitYesVote_ (DRepVoter drep) gaiCC
      submitYesVote_ (StakePoolVoter spoC) gaiCC
      passNEpochs 2
      getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiCC)
      committeeHotC1 <- registerCommitteeHotKey committeeColdC1
      _committeeHotC2 <- registerCommitteeHotKey committeeColdC2
      -- Submit a constitution with a CC vote
      gaiConstitution <- submitConstitution SNothing
      submitYesVote_ (CommitteeVoter committeeHotC1) gaiConstitution
      -- Check for CC acceptance
      ccShouldNotBeExpired committeeColdC2
      isCommitteeAccepted gaiConstitution `shouldReturn` True
      -- expire the second CC
      passNEpochs 2
      -- Check for CC acceptance should fail
      ccShouldBeExpired committeeColdC2
      isCommitteeAccepted gaiConstitution `shouldReturn` False
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Resigned" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (Natural -> Identity Natural)
-> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Natural
Lens' (PParams era) Natural
ppCommitteeMinSizeL ((Natural -> Identity Natural)
 -> PParams era -> Identity (PParams era))
-> Natural -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
2
      (drep, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
      (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
      -- Elect a committee of 2 members
      committeeColdC1 <- KeyHashObj <$> freshKeyHash
      committeeColdC2 <- KeyHashObj <$> freshKeyHash
      gaiCC <-
        submitUpdateCommittee
          Nothing
          mempty
          [ (committeeColdC1, EpochInterval 10)
          , (committeeColdC2, EpochInterval 10)
          ]
          (1 %! 2)
      submitYesVote_ (DRepVoter drep) gaiCC
      submitYesVote_ (StakePoolVoter spoC) gaiCC
      passNEpochs 2
      getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiCC)
      committeeHotC1 <- registerCommitteeHotKey committeeColdC1
      _committeeHotC2 <- registerCommitteeHotKey committeeColdC2
      -- Submit a constitution with a CC vote
      gaiConstitution <- submitConstitution SNothing
      submitYesVote_ (CommitteeVoter committeeHotC1) gaiConstitution
      -- Check for CC acceptance
      ccShouldNotBeResigned committeeColdC2
      isCommitteeAccepted gaiConstitution `shouldReturn` True
      -- Resign the second CC
      _ <- resignCommitteeColdKey committeeColdC2 SNothing
      -- Check for CC acceptance should fail
      ccShouldBeResigned committeeColdC2
      isCommitteeAccepted gaiConstitution `shouldReturn` False

paramChangeAffectsProposalsSpec ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
paramChangeAffectsProposalsSpec :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
paramChangeAffectsProposalsSpec =
  -- These tests rely on submitting committee-update proposals and on drep votes, which are disallowed during bootstrap,
  -- so we can only run them post-bootstrap
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"ParameterChange affects existing proposals" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let submitTwoExampleProposalsAndVoteOnTheChild ::
          [(KeyHash StakePool, Vote)] ->
          [(Credential DRepRole, Vote)] ->
          ImpTestM era (GovActionId, GovActionId)
        submitTwoExampleProposalsAndVoteOnTheChild :: [(KeyHash StakePool, Vote)]
-> [(Credential DRepRole, Vote)]
-> ImpTestM era (GovActionId, GovActionId)
submitTwoExampleProposalsAndVoteOnTheChild [(KeyHash StakePool, Vote)]
spos [(Credential DRepRole, Vote)]
dreps = do
          committeeC <- KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
          gaiParent <- submitUpdateCommittee Nothing mempty [(committeeC, EpochInterval 5)] (75 %! 100)
          -- We submit a descendent proposal so that even though it is sufficiently
          -- voted on, it cannot be ratified before the ParameterChange proposal
          -- is enacted.
          gaiChild <-
            submitUpdateCommittee
              (Just (SJust (GovPurposeId gaiParent)))
              mempty
              [(committeeC, EpochInterval 5)]
              (75 %! 100)
          forM_ spos $ \(KeyHash StakePool
spo, Vote
vote) -> Vote -> Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote -> Voter -> GovActionId -> ImpTestM era ()
submitVote_ Vote
vote (KeyHash StakePool -> Voter
StakePoolVoter KeyHash StakePool
spo) GovActionId
gaiChild
          forM_ dreps $ \(Credential DRepRole
drep, Vote
vote) -> Vote -> Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Vote -> Voter -> GovActionId -> ImpTestM era ()
submitVote_ Vote
vote (Credential DRepRole -> Voter
DRepVoter Credential DRepRole
drep) GovActionId
gaiChild
          passEpoch -- Make the votes count
          pure (gaiParent, gaiChild)
    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DRep" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      let setCommitteeUpdateThreshold :: UnitInterval -> ImpTestM era ()
setCommitteeUpdateThreshold UnitInterval
threshold =
            (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtCommitteeNormalL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
threshold
          getDrepVotingThresholds :: ImpTestM era DRepVotingThresholds
getDrepVotingThresholds = Lens' (PParams era) DRepVotingThresholds
-> ImpTestM era DRepVotingThresholds
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (DRepVotingThresholds -> f DRepVotingThresholds)
-> PParams era -> f (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL
          enactCommitteeUpdateThreshold :: UnitInterval
-> t (Credential DRepRole)
-> Credential HotCommitteeRole
-> ImpTestM era ()
enactCommitteeUpdateThreshold UnitInterval
threshold t (Credential DRepRole)
dreps Credential HotCommitteeRole
hotCommitteeC = do
            drepVotingThresholds <- ImpTestM era DRepVotingThresholds
getDrepVotingThresholds
            paramChange <-
              mkParameterChangeGovAction
                SNothing
                ( emptyPParamsUpdate
                    & ppuDRepVotingThresholdsL
                      .~ SJust (drepVotingThresholds & dvtCommitteeNormalL .~ threshold)
                )
            pcGai <- submitGovAction paramChange
            forM_ dreps $ \Credential DRepRole
drep -> Voter -> GovActionId -> ImpTestM era ()
forall era.
(ShelleyEraImp era, ConwayEraTxBody era, HasCallStack) =>
Voter -> GovActionId -> ImpTestM era ()
submitYesVote_ (Credential DRepRole -> Voter
DRepVoter Credential DRepRole
drep) GovActionId
pcGai
            submitYesVote_ (CommitteeVoter hotCommitteeC) pcGai
            isDRepAccepted pcGai `shouldReturn` True
            passNEpochs 2
            (^. dvtCommitteeNormalL) <$> getDrepVotingThresholds `shouldReturn` threshold

      String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Increasing the threshold prevents a hitherto-ratifiable proposal from being ratified" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        (drepC, hotCommitteeC, _) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
        setCommitteeUpdateThreshold $ 1 %! 2 -- small threshold
        (drep, _, _) <- setupSingleDRep 1_000_000
        (_gaiParent, gaiChild) <- submitTwoExampleProposalsAndVoteOnTheChild [] [(drep, VoteYes)]
        isDRepAccepted gaiChild `shouldReturn` True
        enactCommitteeUpdateThreshold
          (65 %! 100)
          ([drepC, drep] :: [Credential DRepRole])
          hotCommitteeC
        isDRepAccepted gaiChild `shouldReturn` False
      String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Decreasing the threshold ratifies a hitherto-unratifiable proposal" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        -- This sets up a stake pool with 1_000_000 Coin
        (drepC, hotCommitteeC, _) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
        setCommitteeUpdateThreshold $ 1 %! 1 -- too large threshold
        (drep, _, _) <- setupSingleDRep 3_000_000
        (spoC, _, _) <- setupPoolWithStake $ Coin 3_000_000
        (gaiParent, gaiChild) <-
          submitTwoExampleProposalsAndVoteOnTheChild [(spoC, VoteYes)] [(drep, VoteYes)]
        logAcceptedRatio gaiChild
        isDRepAccepted gaiChild `shouldReturn` False
        enactCommitteeUpdateThreshold
          (65 %! 100)
          ([drepC, drep] :: [Credential DRepRole])
          hotCommitteeC
        isDRepAccepted gaiChild `shouldReturn` True
        -- Not vote on the parent too to make sure both get enacted
        submitYesVote_ (DRepVoter drep) gaiParent
        -- bootstrap: 3 % 4 stake yes; 1 % 4 stake abstain; yes / stake - abstain > 1 % 2
        -- post-bootstrap: 3 % 4 stake yes; 1 % 4 stake no
        submitYesVote_ (StakePoolVoter spoC) gaiParent
        passNEpochs 2
        getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiParent)
        passEpoch -- UpdateCommittee is a delaying action
        getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiChild)
    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SPO" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      let setCommitteeUpdateThreshold :: UnitInterval -> ImpTestM era ()
          setCommitteeUpdateThreshold :: UnitInterval -> ImpTestM era ()
setCommitteeUpdateThreshold UnitInterval
threshold =
            (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtCommitteeNormalL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
threshold
          enactCommitteeUpdateThreshold :: UnitInterval
-> Credential DRepRole
-> Credential HotCommitteeRole
-> ImpM (LedgerSpec era) ()
enactCommitteeUpdateThreshold UnitInterval
threshold Credential DRepRole
drepC Credential HotCommitteeRole
hotCommitteeC = do
            poolVotingThresholds <- Lens' (PParams era) PoolVotingThresholds
-> ImpTestM era PoolVotingThresholds
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PoolVotingThresholds -> f PoolVotingThresholds)
-> PParams era -> f (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL
            paramChange <-
              mkParameterChangeGovAction
                SNothing
                ( emptyPParamsUpdate
                    & ppuPoolVotingThresholdsL
                      .~ SJust (poolVotingThresholds & pvtCommitteeNormalL .~ threshold)
                )
            pcGai <- submitGovAction paramChange
            submitYesVote_ (DRepVoter drepC) pcGai
            submitYesVote_ (CommitteeVoter hotCommitteeC) pcGai
            passNEpochs 2
            (^. pvtCommitteeNormalL) <$> getsPParams ppPoolVotingThresholdsL `shouldReturn` threshold

      String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Increasing the threshold prevents a hitherto-ratifiable proposal from being ratified" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        -- This sets up a stake pool with 1_000_000 Coin
        (drepC, hotCommitteeC, _) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
        setCommitteeUpdateThreshold $ 1 %! 2
        (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 2_000_000
        (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000
        passEpoch -- Make the new pool distribution count
        -- bootstrap: 1 % 2 stake yes (2_000_000); 1 % 2 stake abstain; yes / stake - abstain == 1 % 2
        -- post-bootstrap: 1 % 2 stake yes (2_000_000); 1 % 4 stake didn't vote; 1 % 4 stake no
        (_gaiParent, gaiChild) <-
          submitTwoExampleProposalsAndVoteOnTheChild
            [(poolKH1, VoteYes), (poolKH2, VoteNo)]
            [(drepC, VoteYes)]
        isSpoAccepted gaiChild `shouldReturn` True
        enactCommitteeUpdateThreshold (65 %! 100) drepC hotCommitteeC
        isSpoAccepted gaiChild `shouldReturn` False
      String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Decreasing the threshold ratifies a hitherto-unratifiable proposal" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        -- This sets up a stake pool with 1_000_000 Coin
        (drepC, hotCommitteeC, _) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
        setCommitteeUpdateThreshold $ 1 %! 1 -- too large threshold
        (poolKH1, _paymentC1, _stakingC1) <- setupPoolWithStake $ Coin 4_000_000
        (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000
        -- bootstrap: 1 % 2 stake yes (2_000_000); 1 % 2 stake abstain; yes / stake - abstain == 1 % 2
        -- post-bootstrap: 1 % 2 stake yes (2_000_000); 1 % 4 stake didn't vote; 1 % 4 stake no
        (gaiParent, gaiChild) <-
          submitTwoExampleProposalsAndVoteOnTheChild
            [(poolKH1, VoteYes), (poolKH2, VoteNo)]
            [(drepC, VoteYes)]
        isSpoAccepted gaiChild `shouldReturn` False
        enactCommitteeUpdateThreshold (65 %! 100) drepC hotCommitteeC -- smaller threshold
        isSpoAccepted gaiChild `shouldReturn` True
        -- Not vote on the parent too to make sure both get enacted
        submitYesVote_ (DRepVoter drepC) gaiParent
        submitYesVote_ (StakePoolVoter poolKH1) gaiParent
        logRatificationChecks gaiParent
        logRatificationChecks gaiChild
        passNEpochs 2
        getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiParent)
        passEpoch -- UpdateCommittee is a delaying action
        getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId gaiChild)
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A parent ParameterChange proposal can prevent its child from being enacted" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      hotCommitteeCs <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
      (drepC, _, _) <- setupSingleDRep 1_000_000
      -- Setup one other DRep with equal stake
      _ <- setupSingleDRep 1_000_000
      -- Set a smaller DRep threshold
      drepVotingThresholds <- getsPParams ppDRepVotingThresholdsL
      modifyPParams $
        ppDRepVotingThresholdsL
          .~ (drepVotingThresholds & dvtPPGovGroupL .~ 1 %! 2)
      -- Submit a parent-child sequence of ParameterChange proposals and vote on
      -- both equally, so that both may be ratified. But, the parent increases
      -- the threshold, and it should prevent the child from being ratified.
      let paramChange StrictMaybe GovActionId
parent UnitInterval
threshold =
            StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era (GovAction era)
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId
-> PParamsUpdate era -> ImpTestM era (GovAction era)
mkParameterChangeGovAction
              StrictMaybe GovActionId
parent
              ( PParamsUpdate era
forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate
                  PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe DRepVotingThresholds
 -> Identity (StrictMaybe DRepVotingThresholds))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe DRepVotingThresholds)
Lens' (PParamsUpdate era) (StrictMaybe DRepVotingThresholds)
ppuDRepVotingThresholdsL
                    ((StrictMaybe DRepVotingThresholds
  -> Identity (StrictMaybe DRepVotingThresholds))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe DRepVotingThresholds
-> PParamsUpdate era
-> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DRepVotingThresholds -> StrictMaybe DRepVotingThresholds
forall a. a -> StrictMaybe a
SJust (DRepVotingThresholds
drepVotingThresholds DRepVotingThresholds
-> (DRepVotingThresholds -> DRepVotingThresholds)
-> DRepVotingThresholds
forall a b. a -> (a -> b) -> b
& (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtPPGovGroupL ((UnitInterval -> Identity UnitInterval)
 -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> UnitInterval -> DRepVotingThresholds -> DRepVotingThresholds
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
threshold)
              )
      parentGai <- paramChange SNothing (90 %! 100) >>= submitGovAction
      childGai <- paramChange (SJust parentGai) (75 %! 100) >>= submitGovAction
      submitYesVote_ (DRepVoter drepC) parentGai
      submitYesVoteCCs_ hotCommitteeCs parentGai
      submitYesVote_ (DRepVoter drepC) childGai
      submitYesVoteCCs_ hotCommitteeCs childGai
      passEpoch
      logRatificationChecks parentGai
      logRatificationChecks childGai
      isDRepAccepted parentGai `shouldReturn` True
      isDRepAccepted childGai `shouldReturn` True
      passEpoch
      getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId parentGai)
      Map.member (GovPurposeId childGai) <$> getParameterChangeProposals `shouldReturn` True
      isDRepAccepted childGai `shouldReturn` False

committeeMinSizeAffectsInFlightProposalsSpec ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
committeeMinSizeAffectsInFlightProposalsSpec :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeMinSizeAffectsInFlightProposalsSpec =
  -- Treasury withdrawals are disallowed during bootstrap, so we can only run these tests post-bootstrap
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CommitteeMinSize affects in-flight proposals" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let setCommitteeMinSize :: Natural -> ImpTestM era ()
setCommitteeMinSize Natural
n = (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (Natural -> Identity Natural)
-> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Natural
Lens' (PParams era) Natural
ppCommitteeMinSizeL ((Natural -> Identity Natural)
 -> PParams era -> Identity (PParams era))
-> Natural -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Natural
n
        submitTreasuryWithdrawal :: Coin -> ImpM (LedgerSpec era) GovActionId
submitTreasuryWithdrawal Coin
amount = do
          rewardAccount <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
          submitTreasuryWithdrawals [(rewardAccount, amount)]
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"TreasuryWithdrawal fails to ratify due to an increase in CommitteeMinSize" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
      amount <- (Coin, Coin) -> ImpM (LedgerSpec era) Coin
forall g (m :: * -> *) a.
(HasStatefulGen g m, UniformRange a) =>
(a, a) -> m a
uniformRM (Integer -> Coin
Coin Integer
1, Integer -> Coin
Coin Integer
100_000_000)
      -- Ensure sufficient amount in the treasury
      submitTx_ $ mkBasicTx (mkBasicTxBody & treasuryDonationTxBodyL .~ amount)
      hotCommitteeCs <- registerInitialCommittee
      (drepC, _, _) <- setupSingleDRep 1_000_000
      passEpoch
      setCommitteeMinSize 2
      gaiTW <- submitTreasuryWithdrawal amount
      submitYesVoteCCs_ hotCommitteeCs gaiTW
      submitYesVote_ (DRepVoter drepC) gaiTW
      isCommitteeAccepted gaiTW `shouldReturn` True
      gaiPC <-
        submitParameterChange SNothing $
          emptyPParamsUpdate
            & ppuCommitteeMinSizeL .~ SJust 3
      submitYesVoteCCs_ hotCommitteeCs gaiPC
      submitYesVote_ (DRepVoter drepC) gaiPC
      treasury <- getsNES treasuryL
      passNEpochs 2
      -- The ParameterChange prevents the TreasuryWithdrawal from being enacted,
      -- because it has higher priority.
      getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId gaiPC)
      isCommitteeAccepted gaiTW `shouldReturn` False
      currentProposalsShouldContain gaiTW
      getsNES treasuryL `shouldReturn` treasury
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"TreasuryWithdrawal ratifies due to a decrease in CommitteeMinSize" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
      (drepC, hotCommitteeC, _) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
      (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
      amount <- uniformRM (Coin 1, Coin 100_000_000)
      -- Ensure sufficient amount in the treasury
      submitTx_ $ mkBasicTx (mkBasicTxBody & treasuryDonationTxBodyL .~ amount)
      passEpoch
      treasury <- getsNES treasuryL
      gaiTW <- submitTreasuryWithdrawal amount
      submitYesVote_ (CommitteeVoter hotCommitteeC) gaiTW
      submitYesVote_ (DRepVoter drepC) gaiTW
      setCommitteeMinSize 2
      isCommitteeAccepted gaiTW `shouldReturn` False
      passNEpochs 2
      getsNES treasuryL `shouldReturn` treasury
      -- We do not enact the ParameterChange here because that does not pass
      -- ratification as the CC size is smaller than MinSize.
      -- We instead just add another Committee member to reach the CommitteeMinSize.
      coldCommitteeCred <- KeyHashObj <$> freshKeyHash
      gaiCC <- submitUpdateCommittee Nothing mempty [(coldCommitteeCred, EpochInterval 10)] (1 %! 2)
      submitYesVote_ (DRepVoter drepC) gaiCC
      submitYesVote_ (StakePoolVoter spoC) gaiCC
      passNEpochs 2
      _hotCommitteeC' <- registerCommitteeHotKey coldCommitteeCred
      isCommitteeAccepted gaiTW `shouldReturn` True
      passNEpochs 2
      getsNES treasuryL `shouldReturn` (treasury <-> amount)

spoVotesForHardForkInitiation ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
spoVotesForHardForkInitiation :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
spoVotesForHardForkInitiation =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Counting of SPO votes" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HardForkInitiation" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtHardForkInitiationL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ UnitInterval
forall a. Default a => a
def)
      hotCCs <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
      (spoK1, _, _) <- setupPoolWithStake $ Coin 100_000_000
      (spoK2, _, _) <- setupPoolWithStake $ Coin 100_000_000
      _ <- setupPoolWithStake $ Coin 100_000_000
      _ <- setupPoolWithStake $ Coin 100_000_000
      modifyPParams $ ppPoolVotingThresholdsL . pvtHardForkInitiationL .~ 1 %! 2
      protVer <- getProtVer
      gai <- submitGovAction $ HardForkInitiation SNothing (majorFollow protVer)
      impAnn "Submit CC yes vote" $ submitYesVoteCCs_ hotCCs gai
      logString $ "Committee: " <> showExpr hotCCs
      GovActionState {gasCommitteeVotes} <- getGovActionState gai
      logString $ "CC Votes: " <> showExpr gasCommitteeVotes
      minSize <- getsPParams ppCommitteeMinSizeL
      committee <- getCommittee
      logString $ "Min committee size: " <> show minSize
      logString $ "Committee: " <> showExpr committee
      logString . show =<< getsNES nesELL
      impAnn "Accepted by committee" $ isCommitteeAccepted gai `shouldReturn` True
      -- 1 % 4 stake yes; 3 % 4 stake no; yes / stake - abstain < 1 % 2
      impAnn "Submit SPO1 yes vote" $ submitYesVote_ (StakePoolVoter spoK1) gai
      passNEpochs 2
      logRatificationChecks gai
      isSpoAccepted gai `shouldReturn` False
      getLastEnactedHardForkInitiation `shouldReturn` SNothing
      -- 1 % 2 stake yes; 1 % 2 stake no; yes / stake - abstain = 1 % 2
      impAnn "Submit SPO2 yes vote" $ submitYesVote_ (StakePoolVoter spoK2) gai
      isSpoAccepted gai `shouldReturn` True
      passNEpochs 2
      getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gai)

votingSpec ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
votingSpec :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
votingSpec =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Voting" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    -- These tests involve DRep voting, which is not possible in bootstrap,
    -- so we have to run them only post-bootstrap
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPO needs to vote on security-relevant parameter changes" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      ccCreds <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
      (drep, _, _) <- setupSingleDRep 1_000_000
      (khPool, _, _) <- setupPoolWithStake $ Coin 42_000_000
      initMinFeeA <- getsNES $ nesEsL . curPParamsEpochStateL . ppMinFeeAL
      gaidThreshold <- impAnn "Update StakePool thresholds" $ do
        pp <- getsNES $ nesEsL . curPParamsEpochStateL
        (pp ^. ppPoolVotingThresholdsL . pvtPPSecurityGroupL) `shouldBe` (51 %! 100)
        let ppu =
              PParamsUpdate era
forall era. EraPParams era => PParamsUpdate era
emptyPParamsUpdate
                PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe PoolVotingThresholds
 -> Identity (StrictMaybe PoolVotingThresholds))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe PoolVotingThresholds)
Lens' (PParamsUpdate era) (StrictMaybe PoolVotingThresholds)
ppuPoolVotingThresholdsL
                  ((StrictMaybe PoolVotingThresholds
  -> Identity (StrictMaybe PoolVotingThresholds))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe PoolVotingThresholds
-> PParamsUpdate era
-> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolVotingThresholds -> StrictMaybe PoolVotingThresholds
forall a. a -> StrictMaybe a
SJust
                    PoolVotingThresholds
                      { pvtPPSecurityGroup :: UnitInterval
pvtPPSecurityGroup = Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
2
                      , pvtMotionNoConfidence :: UnitInterval
pvtMotionNoConfidence = Integer
51 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                      , pvtHardForkInitiation :: UnitInterval
pvtHardForkInitiation = Integer
51 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                      , pvtCommitteeNormal :: UnitInterval
pvtCommitteeNormal = Integer
65 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                      , pvtCommitteeNoConfidence :: UnitInterval
pvtCommitteeNoConfidence = Integer
65 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
100
                      }
                PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe EpochInterval -> Identity (StrictMaybe EpochInterval))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
ConwayEraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe EpochInterval)
Lens' (PParamsUpdate era) (StrictMaybe EpochInterval)
ppuGovActionLifetimeL ((StrictMaybe EpochInterval
  -> Identity (StrictMaybe EpochInterval))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe EpochInterval
-> PParamsUpdate era
-> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochInterval -> StrictMaybe EpochInterval
forall a. a -> StrictMaybe a
SJust (Word32 -> EpochInterval
EpochInterval Word32
15)
        ppUpdateGa <- mkParameterChangeGovAction SNothing ppu
        gaidThreshold <- mkProposal ppUpdateGa >>= submitProposal
        submitYesVote_ (DRepVoter drep) gaidThreshold
        submitYesVoteCCs_ ccCreds gaidThreshold
        logAcceptedRatio gaidThreshold
        pure gaidThreshold
      passEpoch
      logAcceptedRatio gaidThreshold
      passEpoch
      let newMinFeeA = Integer -> Coin
Coin Integer
1000
      gaidMinFee <- do
        pp <- getsNES $ nesEsL . curPParamsEpochStateL
        impAnn "Security group threshold should be 1/2" $
          (pp ^. ppPoolVotingThresholdsL . pvtPPSecurityGroupL) `shouldBe` (1 %! 2)
        ga <-
          mkParameterChangeGovAction
            (SJust gaidThreshold)
            (emptyPParamsUpdate & ppuMinFeeAL .~ SJust newMinFeeA)
        gaidMinFee <- mkProposal ga >>= submitProposal
        submitYesVote_ (DRepVoter drep) gaidMinFee
        submitYesVoteCCs_ ccCreds gaidMinFee
        pure gaidMinFee
      passEpoch
      logAcceptedRatio gaidMinFee
      passEpoch
      do
        pp <- getsNES $ nesEsL . curPParamsEpochStateL
        (pp ^. ppMinFeeAL) `shouldBe` initMinFeeA
        submitYesVote_ (StakePoolVoter khPool) gaidMinFee
      passEpoch
      logInstantStake
      logAcceptedRatio gaidMinFee
      logRatificationChecks gaidMinFee
      passEpoch
      pp <- getsNES $ nesEsL . curPParamsEpochStateL
      (pp ^. ppMinFeeAL) `shouldBe` newMinFeeA
    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Active voting stake" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"DRep" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"UTxOs contribute to active voting stake" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          -- Setup DRep delegation #1
          (drep1, KeyHashObj stakingKH1, paymentKP1) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000_000
          -- Setup DRep delegation #2
          _ <- setupSingleDRep 1_000_000_000
          (spoC, _, _) <- setupPoolWithStake mempty
          -- Submit a committee proposal
          cc <- KeyHashObj <$> freshKeyHash
          addCCGaid <- submitUpdateCommittee Nothing mempty [(cc, EpochInterval 10)] (75 %! 100)
          -- Submit the vote
          submitYesVote_ (DRepVoter drep1) addCCGaid
          submitYesVote_ (StakePoolVoter spoC) addCCGaid
          passNEpochs 2
          -- The vote should not result in a ratification
          isDRepAccepted addCCGaid `shouldReturn` False
          getLastEnactedCommittee `shouldReturn` SNothing
          -- Bump up the UTxO delegated
          -- to barely make the threshold (65 %! 100)
          stakingKP1 <- getKeyPair stakingKH1
          sendCoinTo_ (mkAddr paymentKP1 stakingKP1) (inject $ Coin 857_142_858)
          passNEpochs 2
          -- The same vote should now successfully ratify the proposal
          getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Rewards contribute to active voting stake" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          -- Setup DRep delegation #1
          (drep1, staking1, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000_000
          -- Setup DRep delegation #2
          _ <- setupSingleDRep 1_000_000_000
          (spoC, _, _) <- setupPoolWithStake mempty
          -- Submit a committee proposal
          cc <- KeyHashObj <$> freshKeyHash
          addCCGaid <- submitUpdateCommittee Nothing mempty [(cc, EpochInterval 10)] (75 %! 100)
          -- Submit the vote
          submitYesVote_ (DRepVoter drep1) addCCGaid
          submitYesVote_ (StakePoolVoter spoC) addCCGaid
          passNEpochs 2
          -- The vote should not result in a ratification
          isDRepAccepted addCCGaid `shouldReturn` False
          getLastEnactedCommittee `shouldReturn` SNothing
          -- Add to the rewards of the delegator to this DRep
          -- to barely make the `dvtCommitteeNormal` threshold (65 %! 100)
          modifyNES $
            nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
              %~ addToBalanceAccounts (Map.singleton staking1 (CompactCoin 857_142_858))
          passNEpochs 2
          -- The same vote should now successfully ratify the proposal
          getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
        -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/926
        -- TODO: Re-enable after issue is resolved, by removing this override
        String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Rewards contribute to active voting stake even in the absence of StakeDistr" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          let govActionLifetime :: Word32
govActionLifetime = Word32
5
              govActionDeposit :: Coin
govActionDeposit = Integer -> Coin
Coin Integer
1_000_000
              poolDeposit :: Coin
poolDeposit = Integer -> Coin
Coin Integer
858_000
          -- Only modify the applicable thresholds
          (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
            PParams era
pp
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
govActionDeposit
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
poolDeposit
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppEMaxL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
govActionLifetime
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
govActionLifetime
          -- Setup DRep delegation #1
          (drepKH1, stakingKH1) <- ImpTestM era (KeyHash DRepRole, KeyHash Staking)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash DRepRole, KeyHash Staking)
setupDRepWithoutStake
          -- Add rewards to delegation #1
          submitAndExpireProposalToMakeReward $ KeyHashObj stakingKH1
          getBalance (KeyHashObj stakingKH1) `shouldReturn` govActionDeposit
          -- Setup DRep delegation #2
          (_drepKH2, stakingKH2) <- setupDRepWithoutStake
          (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
          -- Add rewards to delegation #2
          submitAndExpireProposalToMakeReward $ KeyHashObj stakingKH2
          getBalance (KeyHashObj stakingKH2) `shouldReturn` govActionDeposit
          -- Submit a committee proposal
          cc <- KeyHashObj <$> freshKeyHash
          Positive extra <- arbitrary
          let lifetime = Word32 -> EpochInterval
EpochInterval (Word32
extra Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
2 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
* Word32
govActionLifetime)
          addCCGaid <- submitUpdateCommittee Nothing mempty [(cc, lifetime)] (75 %! 100)
          -- Submit the vote
          submitVote_ VoteYes (DRepVoter $ KeyHashObj drepKH1) addCCGaid
          submitYesVote_ (StakePoolVoter spoC) addCCGaid
          passNEpochs 2
          -- The vote should not result in a ratification
          isDRepAccepted addCCGaid `shouldReturn` False
          getLastEnactedCommittee `shouldReturn` SNothing
          -- Increase the rewards of the delegator to this DRep
          -- to barely make the threshold (65 %! 100)
          registerAndRetirePoolToMakeReward $ KeyHashObj stakingKH1
          getBalance (KeyHashObj stakingKH1) `shouldReturn` poolDeposit <> govActionDeposit
          isDRepAccepted addCCGaid `shouldReturn` True
          -- The same vote should now successfully ratify the proposal
          passEpoch
          getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
        String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Proposal deposits contribute to active voting stake" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Directly" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
            -- Only modify the applicable thresholds
            (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1_000_000
            -- Setup DRep delegation without stake #1
            (drepKH1, stakingKH1) <- ImpTestM era (KeyHash DRepRole, KeyHash Staking)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash DRepRole, KeyHash Staking)
setupDRepWithoutStake
            -- Setup DRep delegation #2
            (_drepKH2, _stakingKH2, _paymentKP2) <- setupSingleDRep 1_000_000
            (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
            -- Make a note of the reward account for the delegator to DRep #1
            dRepRewardAccount <- getRewardAccountFor $ KeyHashObj stakingKH1
            -- Submit the first committee proposal, the one we will test active voting stake against.
            -- The proposal deposit comes from the root UTxO
            cc <- KeyHashObj <$> freshKeyHash
            curEpochNo <- getsNES nesELL
            let
              newCommitteMembers = Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential ColdCommitteeRole
cc (EpochNo -> Map (Credential ColdCommitteeRole) EpochNo)
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)
            addCCGaid <-
              mkProposalWithRewardAccount
                (UpdateCommittee SNothing mempty newCommitteMembers (75 %! 100))
                dRepRewardAccount
                >>= submitProposal
            -- Submit the vote from DRep #1
            submitVote_ VoteYes (DRepVoter $ KeyHashObj drepKH1) addCCGaid
            submitYesVote_ (StakePoolVoter spoC) addCCGaid
            passNEpochs 2
            -- The vote should not result in a ratification
            isDRepAccepted addCCGaid `shouldReturn` False
            getLastEnactedCommittee `shouldReturn` SNothing
            -- Submit another proposal to bump up the active voting stake
            cc' <- KeyHashObj <$> freshKeyHash
            let
              newCommitteMembers' = Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential ColdCommitteeRole
cc' (EpochNo -> Map (Credential ColdCommitteeRole) EpochNo)
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)
            mkProposalWithRewardAccount
              (UpdateCommittee SNothing mempty newCommitteMembers' (75 %! 100))
              dRepRewardAccount
              >>= submitProposal_
            passNEpochs 2
            -- The same vote should now successfully ratify the proposal
            getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
          String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"After switching delegations" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
            -- Only modify the applicable thresholds
            (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1_000_000
            -- Setup DRep delegation without stake #1
            (drepKH1, stakingKH1) <- ImpTestM era (KeyHash DRepRole, KeyHash Staking)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash DRepRole, KeyHash Staking)
setupDRepWithoutStake
            -- Setup DRep delegation #2
            (_drepKH2, _stakingKH2, _paymentKP2) <- setupSingleDRep 1_000_000
            -- Setup DRep delegation #3
            (_drepKH3, stakingKH3) <- setupDRepWithoutStake
            (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
            -- Make a note of the reward accounts for the delegators to DReps #1 and #3
            dRepRewardAccount1 <- getRewardAccountFor $ KeyHashObj stakingKH1
            dRepRewardAccount3 <- getRewardAccountFor $ KeyHashObj stakingKH3
            -- Submit committee proposals
            -- The proposal deposits comes from the root UTxO
            -- After this both stakingKH1 and stakingKH3 are expected to have 1_000_000 ADA of stake, each
            cc <- KeyHashObj <$> freshKeyHash
            curEpochNo <- getsNES nesELL
            let
              newCommitteMembers = Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential ColdCommitteeRole
cc (EpochNo -> Map (Credential ColdCommitteeRole) EpochNo)
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)
            addCCGaid <-
              mkProposalWithRewardAccount
                (UpdateCommittee SNothing mempty newCommitteMembers (75 %! 100))
                dRepRewardAccount1
                >>= submitProposal
            cc' <- KeyHashObj <$> freshKeyHash
            let
              newCommitteMembers' = Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential ColdCommitteeRole
cc' (EpochNo -> Map (Credential ColdCommitteeRole) EpochNo)
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)
            mkProposalWithRewardAccount
              (UpdateCommittee SNothing mempty newCommitteMembers' (75 %! 100))
              dRepRewardAccount3
              >>= submitProposal_
            -- Submit the vote from DRep #1
            submitVote_ VoteYes (DRepVoter $ KeyHashObj drepKH1) addCCGaid
            submitYesVote_ (StakePoolVoter spoC) addCCGaid
            passNEpochs 2
            -- The vote should not result in a ratification
            isDRepAccepted addCCGaid `shouldReturn` False
            getLastEnactedCommittee `shouldReturn` SNothing
            -- Switch the delegation from DRep #3 to DRep #1
            submitTxAnn_ "Switch the delegation from DRep #3 to DRep #1" $
              mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL
                  .~ SSeq.fromList
                    [ DelegTxCert
                        (KeyHashObj stakingKH3)
                        (DelegVote (DRepCredential $ KeyHashObj drepKH1))
                    ]
            passNEpochs 2
            -- The same vote should now successfully ratify the proposal
            getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
      String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Predefined DReps" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"acceptedRatio with default DReps" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          (drep1, _, committeeGovId) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
          (_, drep2Staking, _) <- setupSingleDRep 1_000_000

          paramChangeGovId <- submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 1000)
          submitYesVote_ (DRepVoter drep1) paramChangeGovId

          passEpoch
          calculateDRepAcceptedRatio paramChangeGovId `shouldReturn` 1 % 2

          kh <- freshKeyHash
          _ <- registerStakeCredential (KeyHashObj kh)
          _ <- delegateToDRep (KeyHashObj kh) (Coin 1_000_000) DRepAlwaysNoConfidence
          passEpoch
          -- AlwaysNoConfidence vote acts like a 'No' vote for actions other than NoConfidence
          calculateDRepAcceptedRatio paramChangeGovId `shouldReturn` 1 % 3

          _ <- delegateToDRep drep2Staking zero DRepAlwaysAbstain
          passEpoch
          -- AlwaysAbstain vote acts like 'Abstain' vote
          calculateDRepAcceptedRatio paramChangeGovId `shouldReturn` 1 % 2

          noConfidenceGovId <- submitGovAction $ NoConfidence (SJust committeeGovId)
          submitYesVote_ (DRepVoter drep1) noConfidenceGovId
          passEpoch
          -- AlwaysNoConfidence vote acts like 'Yes' for NoConfidence actions
          calculateDRepAcceptedRatio noConfidenceGovId `shouldReturn` 2 % 2

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"AlwaysNoConfidence" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          (drep1, _, committeeGovId) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
          initialMembers <- getCommitteeMembers

          -- drep2 won't explicitly vote, but eventually delegate to AlwaysNoConfidence
          (drep2, drep2Staking, _) <- setupSingleDRep 1_000_000

          -- we register another drep with the same stake as drep1, which will vote No -
          -- in order to make it necessary to redelegate to AlwaysNoConfidence,
          -- rather than just unregister
          (drep3, _, _) <- setupSingleDRep 1_000_000
          (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000

          noConfidenceGovId <- submitGovAction $ NoConfidence (SJust committeeGovId)
          submitYesVote_ (DRepVoter drep1) noConfidenceGovId
          submitVote_ VoteNo (DRepVoter drep3) noConfidenceGovId
          submitYesVote_ (StakePoolVoter spoC) noConfidenceGovId
          passEpoch
          -- drep1 doesn't have enough stake to enact NoConfidence
          isDRepAccepted noConfidenceGovId `shouldReturn` False
          passEpoch
          getCommitteeMembers `shouldReturn` initialMembers

          -- drep2 unregisters, but NoConfidence still doesn't pass, because there's a tie between drep1 and drep3
          unRegisterDRep drep2
          passEpoch
          isDRepAccepted noConfidenceGovId `shouldReturn` False

          _ <- delegateToDRep drep2Staking zero DRepAlwaysNoConfidence
          passEpoch
          isDRepAccepted noConfidenceGovId `shouldReturn` True
          passEpoch
          getCommitteeMembers `shouldReturn` mempty
        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"AlwaysAbstain" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          let getTreasury :: ImpTestM era Coin
getTreasury = SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (Coin -> Const r Coin)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) Coin
Lens' (NewEpochState era) Coin
forall (t :: * -> *) era.
CanSetChainAccountState t =>
Lens' (t era) Coin
treasuryL

          ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
          Coin -> ImpTestM era ()
forall era. ConwayEraImp era => Coin -> ImpTestM era ()
donateToTreasury (Coin -> ImpTestM era ()) -> Coin -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
5_000_000

          (drep1, comMember, _) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
          initialTreasury <- getTreasury

          (drep2, drep2Staking, _) <- setupSingleDRep 1_000_000

          rewardAccount <- registerRewardAccount
          govId <- submitTreasuryWithdrawals [(rewardAccount, initialTreasury)]

          submitYesVote_ (CommitteeVoter comMember) govId
          submitYesVote_ (DRepVoter drep1) govId
          submitVote_ VoteNo (DRepVoter drep2) govId
          passEpoch
          -- drep1 doesn't have enough stake to enact the withdrawals
          isDRepAccepted govId `shouldReturn` False
          passEpoch
          getTreasury `shouldReturn` initialTreasury

          _ <- delegateToDRep drep2Staking zero DRepAlwaysAbstain

          passEpoch
          -- the delegation turns the No vote into an Abstain, enough to pass the action
          isDRepAccepted govId `shouldReturn` True
          passEpoch
          getTreasury `shouldReturn` zero

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DRepAlwaysNoConfidence is sufficient to pass NoConfidence" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
            PParams era
pp
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtMotionNoConfidenceL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtMotionNoConfidenceL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (CoinPerByte -> Identity CoinPerByte)
-> PParams era -> Identity (PParams era)
forall era.
BabbageEraPParams era =>
Lens' (PParams era) CoinPerByte
Lens' (PParams era) CoinPerByte
ppCoinsPerUTxOByteL ((CoinPerByte -> Identity CoinPerByte)
 -> PParams era -> Identity (PParams era))
-> CoinPerByte -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> CoinPerByte
CoinPerByte (Integer -> Coin
Coin Integer
1)
          (drep, _, committeeId) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
          cred <- KeyHashObj <$> freshKeyHash
          _ <- registerStakeCredential cred
          _ <- delegateToDRep cred (Coin 300) DRepAlwaysNoConfidence
          noConfidence <- submitGovAction (NoConfidence (SJust committeeId))
          submitYesVote_ (DRepVoter drep) noConfidence
          logAcceptedRatio noConfidence
          passNEpochs 2
          getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId noConfidence)

      String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"StakePool" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"UTxOs contribute to active voting stake" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          -- Only modify the applicable thresholds
          (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
            (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL
              ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> PoolVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolVotingThresholds
forall a. Default a => a
def
                { pvtCommitteeNormal = 51 %! 100
                , pvtCommitteeNoConfidence = 51 %! 100
                }
          ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> DRepVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DRepVotingThresholds
forall a. Default a => a
def)
          -- Setup Pool delegation #1
          (poolKH1, delegatorCPayment1, delegatorCStaking1) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
          -- Setup Pool delegation #2
          (poolKH2, _, _) <- setupPoolWithStake $ Coin 1_000_000_000
          passEpoch
          -- Submit a committee proposal
          cc <- KeyHashObj <$> freshKeyHash
          addCCGaid <- submitUpdateCommittee Nothing mempty [(cc, EpochInterval 10)] (75 %! 100)
          -- Submit the vote
          submitVote_ VoteYes (StakePoolVoter poolKH1) addCCGaid
          submitVote_ VoteNo (StakePoolVoter poolKH2) addCCGaid
          passNEpochs 2
          -- The vote should not result in a ratification
          logRatificationChecks addCCGaid
          isSpoAccepted addCCGaid `shouldReturn` False
          getLastEnactedCommittee `shouldReturn` SNothing
          -- Bump up the UTxO delegated
          -- to barely make the threshold (51 %! 100)
          sendCoinTo_ (mkAddr delegatorCPayment1 delegatorCStaking1) (Coin 40_900_000)
          passNEpochs 2
          -- The same vote should now successfully ratify the proposal
          getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Rewards contribute to active voting stake" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          -- Only modify the applicable thresholds
          (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$
            (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL
              ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> PoolVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolVotingThresholds
forall a. Default a => a
def
                { pvtCommitteeNormal = 51 %! 100
                , pvtCommitteeNoConfidence = 51 %! 100
                }
          ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> DRepVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DRepVotingThresholds
forall a. Default a => a
def)

          -- Setup Pool delegation #1
          (poolKH1, _, delegatorCStaking1) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000_000
          -- Setup Pool delegation #2
          (poolKH2, _, _) <- setupPoolWithStake $ Coin 1_000_000_000
          passEpoch
          -- Submit a committee proposal
          cc <- KeyHashObj <$> freshKeyHash
          addCCGaid <- submitUpdateCommittee Nothing mempty [(cc, EpochInterval 10)] (75 %! 100)
          -- Submit the vote
          submitVote_ VoteYes (StakePoolVoter poolKH1) addCCGaid
          submitVote_ VoteNo (StakePoolVoter poolKH2) addCCGaid
          passNEpochs 2
          -- The vote should not result in a ratification
          isSpoAccepted addCCGaid `shouldReturn` False
          getLastEnactedCommittee `shouldReturn` SNothing
          -- Add to the rewards of the delegator to this SPO
          -- to barely make the threshold (51 %! 100)
          modifyNES $
            nesEsL . esLStateL . lsCertStateL . certDStateL . accountsL
              %~ addToBalanceAccounts (Map.singleton delegatorCStaking1 (CompactCoin 200_000_000))
          passNEpochs 2
          -- The same vote should now successfully ratify the proposal
          getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
        -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/926
        -- TODO: Re-enable after issue is resolved, by removing this override
        String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Rewards contribute to active voting stake even in the absence of StakeDistr" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$
          ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
            let govActionLifetime :: Word32
govActionLifetime = Word32
5
                govActionDeposit :: Coin
govActionDeposit = Integer -> Coin
Coin Integer
1_000_000
                poolDeposit :: Coin
poolDeposit = Integer -> Coin
Coin Integer
200_000
            -- Only modify the applicable thresholds
            (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
              PParams era
pp
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL
                  ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> PoolVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolVotingThresholds
forall a. Default a => a
def
                    { pvtCommitteeNormal = 51 %! 100
                    , pvtCommitteeNoConfidence = 51 %! 100
                    }
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
govActionDeposit
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
poolDeposit
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era. EraPParams era => Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppEMaxL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
5
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppGovActionLifetimeL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word32 -> EpochInterval
EpochInterval Word32
govActionLifetime
            ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap ((PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> DRepVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DRepVotingThresholds
forall a. Default a => a
def)

            -- Setup Pool delegation #1
            (poolKH1, delegatorCStaking1) <- ImpTestM era (KeyHash StakePool, Credential Staking)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential Staking)
setupPoolWithoutStake
            -- Add rewards to delegation #1
            submitAndExpireProposalToMakeReward delegatorCStaking1
            getBalance delegatorCStaking1 `shouldReturn` govActionDeposit
            -- Setup Pool delegation #2
            (poolKH2, delegatorCStaking2) <- setupPoolWithoutStake
            -- Add rewards to delegation #2
            submitAndExpireProposalToMakeReward delegatorCStaking2
            getBalance delegatorCStaking2 `shouldReturn` govActionDeposit
            -- Submit a committee proposal
            Positive extra <- arbitrary
            cc <- KeyHashObj <$> freshKeyHash
            addCCGaid <-
              submitUpdateCommittee
                Nothing
                mempty
                [(cc, EpochInterval (extra + 2 * govActionLifetime))]
                (75 %! 100)
            -- Submit the vote
            submitVote_ VoteYes (StakePoolVoter poolKH1) addCCGaid
            submitVote_ VoteNo (StakePoolVoter poolKH2) addCCGaid
            passNEpochs 2
            -- The vote should not result in a ratification
            isSpoAccepted addCCGaid `shouldReturn` False
            getLastEnactedCommittee `shouldReturn` SNothing
            logRatificationChecks addCCGaid
            -- Add to the rewards of the delegator to this SPO
            -- to barely make the threshold (51 %! 100)
            registerAndRetirePoolToMakeReward delegatorCStaking1
            getBalance delegatorCStaking1 `shouldReturn` poolDeposit <> govActionDeposit
            -- The same vote should now successfully ratify the proposal
            -- NOTE: It takes 2 epochs for SPO votes as opposed to 1 epoch
            -- for DRep votes to ratify a proposal.
            passNEpochs 2
            getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
        String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Proposal deposits contribute to active voting stake" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
          String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Directly" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
            -- Only modify the applicable thresholds
            (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
              PParams era
pp
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL
                  ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> PoolVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolVotingThresholds
forall a. Default a => a
def
                    { pvtCommitteeNormal = 51 %! 100
                    , pvtCommitteeNoConfidence = 51 %! 100
                    }
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL
                  ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> DRepVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DRepVotingThresholds
forall a. Default a => a
def
                    { dvtCommitteeNormal = 0 %! 1
                    , dvtCommitteeNoConfidence = 0 %! 1
                    }
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
600_000
            -- Setup Pool delegation #1
            (poolKH1, stakingC1) <- ImpTestM era (KeyHash StakePool, Credential Staking)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential Staking)
setupPoolWithoutStake
            -- Setup Pool delegation #2
            (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000
            -- Make a note of the reward account for the delegator to SPO #1
            spoRewardAccount <- getRewardAccountFor stakingC1
            -- Submit the first committee proposal, the one we will test active voting stake against.
            -- The proposal deposit comes from the root UTxO
            cc <- KeyHashObj <$> freshKeyHash
            curEpochNo <- getsNES nesELL
            let
              newCommitteMembers = Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential ColdCommitteeRole
cc (EpochNo -> Map (Credential ColdCommitteeRole) EpochNo)
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)
            addCCGaid <-
              mkProposalWithRewardAccount
                (UpdateCommittee SNothing mempty newCommitteMembers (75 %! 100))
                spoRewardAccount
                >>= submitProposal

            -- Submit a yes vote from SPO #1 and a no vote from SPO #2
            submitVote_ VoteYes (StakePoolVoter poolKH1) addCCGaid
            submitVote_ VoteNo (StakePoolVoter poolKH2) addCCGaid
            passNEpochs 2
            -- The vote should not result in a ratification
            getLastEnactedCommittee `shouldReturn` SNothing
            -- Submit another proposal to bump up the active voting stake of SPO #1
            cc' <- KeyHashObj <$> freshKeyHash
            let
              newCommitteMembers' = Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential ColdCommitteeRole
cc' (EpochNo -> Map (Credential ColdCommitteeRole) EpochNo)
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)
            mkProposalWithRewardAccount
              (UpdateCommittee SNothing mempty newCommitteMembers' (75 %! 100))
              spoRewardAccount
              >>= submitProposal_
            passNEpochs 2
            -- The same vote should now successfully ratify the proposal
            getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
          String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"After switching delegations" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
            -- Only modify the applicable thresholds
            (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
              PParams era
pp
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL
                  ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> PoolVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolVotingThresholds
forall a. Default a => a
def
                    { pvtCommitteeNormal = 51 %! 100
                    , pvtCommitteeNoConfidence = 51 %! 100
                    }
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL
                  ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> DRepVotingThresholds -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ DRepVotingThresholds
forall a. Default a => a
def
                    { dvtCommitteeNormal = 0 %! 1
                    , dvtCommitteeNoConfidence = 0 %! 1
                    }
                PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (Coin -> Identity Coin) -> PParams era -> Identity (PParams era)
forall era. ConwayEraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL ((Coin -> Identity Coin) -> PParams era -> Identity (PParams era))
-> Coin -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
1_000_000
            -- Setup Pool delegation #1
            (poolKH1, stakingC1) <- ImpTestM era (KeyHash StakePool, Credential Staking)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential Staking)
setupPoolWithoutStake
            -- Setup Pool delegation #2
            (poolKH2, _paymentC2, _stakingC2) <- setupPoolWithStake $ Coin 1_000_000
            -- Setup Pool delegation #3
            (_poolKH3, stakingC3) <- setupPoolWithoutStake
            -- Make a note of the reward accounts for the delegators to SPOs #1 and #3
            spoRewardAccount1 <- getRewardAccountFor stakingC1
            spoRewardAccount3 <- getRewardAccountFor stakingC3
            -- Submit committee proposals
            -- The proposal deposits come from the root UTxO
            -- After this both stakingC1 and stakingC3 are expected to have 1_000_000 ADA of stake, each
            cc <- KeyHashObj <$> freshKeyHash
            curEpochNo <- getsNES nesELL
            let
              newCommitteMembers = Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential ColdCommitteeRole
cc (EpochNo -> Map (Credential ColdCommitteeRole) EpochNo)
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)
            addCCGaid <-
              mkProposalWithRewardAccount
                (UpdateCommittee SNothing mempty newCommitteMembers (75 %! 100))
                spoRewardAccount1
                >>= submitProposal
            cc' <- KeyHashObj <$> freshKeyHash
            let
              newCommitteMembers' = Credential ColdCommitteeRole
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall k a. k -> a -> Map k a
Map.singleton Credential ColdCommitteeRole
cc' (EpochNo -> Map (Credential ColdCommitteeRole) EpochNo)
-> EpochNo -> Map (Credential ColdCommitteeRole) EpochNo
forall a b. (a -> b) -> a -> b
$ EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
curEpochNo (Word32 -> EpochInterval
EpochInterval Word32
10)
            mkProposalWithRewardAccount
              (UpdateCommittee SNothing mempty newCommitteMembers' (75 %! 100))
              spoRewardAccount3
              >>= submitProposal_
            -- Submit a yes vote from SPO #1 and a no vote from SPO #2
            submitVote_ VoteYes (StakePoolVoter poolKH1) addCCGaid
            submitVote_ VoteNo (StakePoolVoter poolKH2) addCCGaid
            passNEpochs 2
            -- The vote should not result in a ratification
            getLastEnactedCommittee `shouldReturn` SNothing
            submitTxAnn_ "Switch the delegation from SPO #3 to SPO #1" $
              mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL .~ SSeq.fromList [mkDelegTxCert stakingC3 (DelegStake poolKH1)]
            passNEpochs 2
            -- The same vote should now successfully ratify the proposal
            getLastEnactedCommittee `shouldReturn` SJust (GovPurposeId addCCGaid)
    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Interaction between governing bodies" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Motion of no-confidence" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        (drep, _, committeeGovId) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
        (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000
        initialMembers <- getCommitteeMembers
        noConfidenceGovId <- submitGovAction $ NoConfidence (SJust committeeGovId)

        submitYesVote_ (DRepVoter drep) noConfidenceGovId
        submitVote_ VoteNo (StakePoolVoter spoC) noConfidenceGovId
        passNEpochs 2

        -- DReps accepted the proposal
        isDRepAccepted noConfidenceGovId `shouldReturn` True
        -- SPOs voted no, so NoConfidence won't be ratified, thus committee remains the same
        isSpoAccepted noConfidenceGovId `shouldReturn` False
        getCommitteeMembers `shouldReturn` initialMembers
      String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Update committee - normal state" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        (drep, _, committeeGovId) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
        (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000
        SJust initialCommittee <- getsNES $ newEpochStateGovStateL . committeeGovStateL
        let initialThreshold = Committee era
initialCommittee Committee era
-> Getting UnitInterval (Committee era) UnitInterval
-> UnitInterval
forall s a. s -> Getting a s a -> a
^. Getting UnitInterval (Committee era) UnitInterval
forall era (f :: * -> *).
Functor f =>
(UnitInterval -> f UnitInterval)
-> Committee era -> f (Committee era)
committeeThresholdL
        gid <- submitGovAction $ UpdateCommittee (SJust committeeGovId) mempty mempty (1 %! 100)

        submitYesVote_ (DRepVoter drep) gid
        submitVote_ VoteNo (StakePoolVoter spoC) gid
        passNEpochs 2

        -- DReps accepted the proposal
        isDRepAccepted gid `shouldReturn` True
        -- SPOs voted no, so committee won't be updated
        isSpoAccepted gid `shouldReturn` False
        getLastEnactedCommittee `shouldReturn` SJust committeeGovId
        SJust currentCommittee <- getsNES $ newEpochStateGovStateL . committeeGovStateL
        currentCommittee ^. committeeThresholdL `shouldBe` initialThreshold
      String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Hard-fork initiation" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        ccMembers <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
        (drep, _, _) <- setupSingleDRep 1_000_000
        (spoC, _, _) <- setupPoolWithStake $ Coin 1_000_000
        curProtVer <- getProtVer
        nextMajorVersion <- succVersion $ pvMajor curProtVer
        let nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}
        gid <- submitGovAction $ HardForkInitiation SNothing nextProtVer

        submitYesVoteCCs_ ccMembers gid
        submitYesVote_ (StakePoolVoter spoC) gid
        passNEpochs 2

        -- No changes so far, since DReps haven't voted yet
        getProtVer `shouldReturn` curProtVer
        submitYesVote_ (DRepVoter drep) gid
        passNEpochs 2
        -- DReps voted yes too for the hard-fork, so protocol version is incremented
        getProtVer `shouldReturn` nextProtVer
      String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
        String
"A governance action is automatically ratified if threshold is set to 0 for all related governance bodies"
        (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap
        (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
            PParams era
pp
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (PoolVotingThresholds -> Identity PoolVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) PoolVotingThresholds
Lens' (PParams era) PoolVotingThresholds
ppPoolVotingThresholdsL ((PoolVotingThresholds -> Identity PoolVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> PoolVotingThresholds -> Identity PoolVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> PoolVotingThresholds -> Identity PoolVotingThresholds
Lens' PoolVotingThresholds UnitInterval
pvtMotionNoConfidenceL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
              PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtMotionNoConfidenceL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
0 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
          (_drep, _, committeeGovId) <- ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM
  era
  (Credential DRepRole, Credential HotCommitteeRole,
   GovPurposeId 'CommitteePurpose)
electBasicCommittee
          _ <- setupPoolWithStake $ Coin 1_000_000

          -- There is a committee initially
          getCommitteeMembers `shouldNotReturn` mempty

          noConfidenceGovId <- submitGovAction $ NoConfidence (SJust committeeGovId)

          -- No votes were made but due to the 0 thresholds, every governance body accepted the gov action by default...
          isDRepAccepted noConfidenceGovId `shouldReturn` True
          isSpoAccepted noConfidenceGovId `shouldReturn` True
          -- ...even the committee which is not allowed to vote on `NoConfidence` action
          isCommitteeAccepted noConfidenceGovId `shouldReturn` True
          passNEpochs 2
          -- `NoConfidence` is ratified -> the committee is no more
          getCommitteeMembers `shouldReturn` mempty

    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SPO default votes" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"During bootstrap phase" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Default vote is Abstain in general" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          (spoC1, _payment, _staking) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000
          (spoC2, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000
          (spoC3, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000

          gid <-
            submitParameterChange SNothing $
              emptyPParamsUpdate
                & ppuMinFeeRefScriptCostPerByteL .~ SJust (25 %! 2)

          impAnn
            ( "No SPO has voted so far and the default vote is abstain:\n"
                <> "YES: 0; ABSTAIN (default): 3; NO: 0 -> YES / total - ABSTAIN == 0 % 0"
            )
            $ calculatePoolAcceptedRatio gid `shouldReturn` 0

          passNEpochs 2

          impAnn
            ( "One SPO voted yes and the default vote is abstain:\n"
                <> "YES: 1; ABSTAIN (default): 2; NO: 0 -> YES / total - ABSTAIN == 1 % 1"
            )
            $ do
              submitYesVote_ (StakePoolVoter spoC1) gid
              calculatePoolAcceptedRatio gid `shouldReturn` 1

          impAnn
            ( "One SPO voted yes, another voted no and the default vote is abstain:\n"
                <> "YES: 1; ABSTAIN (default): 1; NO: 1 -> YES / total - ABSTAIN == 1 % 2"
            )
            $ do
              submitVote_ VoteNo (StakePoolVoter spoC2) gid
              calculatePoolAcceptedRatio gid `shouldReturn` (1 % 2)

          impAnn
            ( "Two SPOs voted yes, another voted no and the default vote is abstain:\n"
                <> "YES: 2; ABSTAIN (default): 0; NO: 1 -> YES / total - ABSTAIN == 2 % 3"
            )
            $ do
              submitYesVote_ (StakePoolVoter spoC3) gid
              calculatePoolAcceptedRatio gid `shouldReturn` (2 % 3)

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HardForkInitiation - default vote is No" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          curProtVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
          nextMajorVersion <- succVersion $ pvMajor curProtVer
          let nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}

          (spoC1, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000
          (spoC2, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000
          (_spoC3, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000

          gid <- submitGovAction $ HardForkInitiation SNothing nextProtVer

          impAnn
            ( "No SPO has voted so far and the default vote is no:\n"
                <> "YES: 0; ABSTAIN: 0; NO (default): 3 -> YES / total - ABSTAIN == 0 % 3"
            )
            $ calculatePoolAcceptedRatio gid `shouldReturn` 0

          passNEpochs 2

          impAnn
            ( "One SPO voted yes and the default vote is no:\n"
                <> "YES: 1; ABSTAIN: 0; NO (default): 2 -> YES / total - ABSTAIN == 1 % 3"
            )
            $ do
              submitYesVote_ (StakePoolVoter spoC1) gid
              calculatePoolAcceptedRatio gid `shouldReturn` (1 %! 3)

          impAnn
            ( "One SPO voted yes, another abstained and the default vote is no:\n"
                <> "YES: 1; ABSTAIN: 1; NO (default): 2 -> YES / total - ABSTAIN == 1 % 2"
            )
            $ do
              submitVote_ Abstain (StakePoolVoter spoC2) gid
              calculatePoolAcceptedRatio gid `shouldReturn` (1 %! 2)

      String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"After bootstrap phase" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Default vote is No in general" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          (spoC1, _payment, _staking) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000
          (spoC2, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000
          (_spoC3, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000

          cc <- KeyHashObj <$> freshKeyHash
          gid <- submitUpdateCommittee Nothing mempty [(cc, EpochInterval 5)] (1 %! 2)

          impAnn
            ( "No SPO has voted so far and the default vote is no:\n"
                <> "YES: 0; ABSTAIN: 0; NO (default): 3 -> YES / total - ABSTAIN == 0 % 3"
            )
            $ calculatePoolAcceptedRatio gid `shouldReturn` 0

          passNEpochs 2

          impAnn
            ( "One SPO voted yes and the default vote is no:\n"
                <> "YES: 1; ABSTAIN: 0; NO (default): 2 -> YES / total - ABSTAIN == 1 % 3"
            )
            $ do
              submitYesVote_ (StakePoolVoter spoC1) gid
              calculatePoolAcceptedRatio gid `shouldReturn` (1 %! 3)

          impAnn
            ( "One SPO voted yes, another abstained and the default vote is no:\n"
                <> "YES: 1; ABSTAIN: 1; NO (default): 1 -> YES / total - ABSTAIN == 1 % 2"
            )
            $ do
              submitVote_ Abstain (StakePoolVoter spoC2) gid
              calculatePoolAcceptedRatio gid `shouldReturn` (1 %! 2)

          getLastEnactedCommittee `shouldReturn` SNothing

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"HardForkInitiation - default vote is No" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          curProtVer <- ImpTestM era ProtVer
forall era. EraGov era => ImpTestM era ProtVer
getProtVer
          nextMajorVersion <- succVersion $ pvMajor curProtVer
          let nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}

          (spoC1, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000
          (spoC2, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000
          hotCs <- registerInitialCommittee
          (drep, _, _) <- setupSingleDRep 1_000_000

          gid <- submitGovAction $ HardForkInitiation SNothing nextProtVer

          impAnn
            ( "No SPO has voted so far and the default vote is no:\n"
                <> "YES: 0; ABSTAIN: 0; NO (default): 2 -> YES / total - ABSTAIN == 0 % 2"
            )
            $ calculatePoolAcceptedRatio gid `shouldReturn` 0

          submitYesVoteCCs_ hotCs gid
          submitYesVote_ (DRepVoter drep) gid

          passNEpochs 2

          getLastEnactedHardForkInitiation `shouldReturn` SNothing

          impAnn
            ( "One SPO voted yes and the default vote is no:\n"
                <> "YES: 1; ABSTAIN: 0; NO (default): 1 -> YES / total - ABSTAIN == 1 % 2"
            )
            $ do
              submitVote_ VoteYes (StakePoolVoter spoC2) gid
              calculatePoolAcceptedRatio gid `shouldReturn` (1 %! 2)

          impAnn
            ( "Although the other SPO delegated its reward account to an AlwaysAbstain DRep,\n"
                <> "since this is a HardForkInitiation action, their default vote remains no regardless:\n"
                <> "YES: 1; ABSTAIN: 0; NO (default): 1 -> YES / total - ABSTAIN == 1 % 2"
            )
            $ do
              delegateSPORewardAddressToDRep_ spoC1 (Coin 1_000_000) DRepAlwaysAbstain
              calculatePoolAcceptedRatio gid `shouldReturn` (1 %! 2)

          impAnn
            ( "One SPO voted yes, the other explicitly abstained and the default vote is no:\n"
                <> "YES: 1; ABSTAIN: 1; NO (default): 0 -> YES / total - ABSTAIN == 1 % 1"
            )
            $ do
              submitVote_ Abstain (StakePoolVoter spoC1) gid
              calculatePoolAcceptedRatio gid `shouldReturn` 1

          passNEpochs 2

          getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gid)

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Reward account delegated to AlwaysNoConfidence" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          (spoC, _payment, _staking) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000
          (drep, _, _) <- setupSingleDRep 1_000_000

          gid <- submitGovAction $ NoConfidence SNothing

          impAnn
            ( "No SPO has voted so far and the default vote is no:\n"
                <> "YES: 0; ABSTAIN: 0; NO (default): 1 -> YES / total - ABSTAIN == 0 % 1"
            )
            $ calculatePoolAcceptedRatio gid `shouldReturn` 0

          submitYesVote_ (DRepVoter drep) gid

          passNEpochs 2

          impAnn "Only the DReps accepted the proposal so far, so it should not be enacted yet" $
            getCommitteeMembers `shouldNotReturn` mempty

          impAnn
            ( "The SPO delegated its reward account to an AlwaysNoConfidence DRep,\n"
                <> "since this is a NoConfidence action, their default vote will now count as a yes:\n"
                <> "YES: 1; ABSTAIN: 0; NO (default): 0 -> YES / total - ABSTAIN == 1 % 1"
            )
            $ do
              delegateSPORewardAddressToDRep_ spoC (Coin 1_000_000) DRepAlwaysNoConfidence
              calculatePoolAcceptedRatio gid `shouldReturn` 1

          passNEpochs 2

          getCommitteeMembers `shouldReturn` mempty

        String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Reward account delegated to AlwaysAbstain" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
          (spoC1, _payment, _staking) <- Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall era.
ConwayEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
setupPoolWithStake (Coin
 -> ImpTestM
      era (KeyHash StakePool, Credential Payment, Credential Staking))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, Credential Payment, Credential Staking)
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
1_000_000
          (spoC2, _payment, _staking) <- setupPoolWithStake $ Coin 1_000_000
          (drep, _, _) <- setupSingleDRep 1_000_000

          gid <- submitGovAction $ NoConfidence SNothing

          impAnn
            ( "No SPO has voted so far and the default vote is no:\n"
                <> "YES: 0; ABSTAIN: 0; NO (default): 2 -> YES / total - ABSTAIN == 0 % 2"
            )
            $ calculatePoolAcceptedRatio gid `shouldReturn` 0

          submitYesVote_ (DRepVoter drep) gid

          passNEpochs 2

          impAnn "Only the DReps accepted the proposal so far, so it should not be enacted yet" $
            getCommitteeMembers `shouldNotReturn` mempty

          impAnn
            ( "One SPO voted yes and the default vote is no:\n"
                <> "YES: 1; ABSTAIN: 0; NO (default): 1 -> YES / total - ABSTAIN == 1 % 2"
            )
            $ do
              submitYesVote_ (StakePoolVoter spoC2) gid
              calculatePoolAcceptedRatio gid `shouldReturn` (1 %! 2)

          impAnn
            ( "One SPO voted yes and the other SPO delegated its reward account to an AlwaysAbstain DRep:\n"
                <> "YES: 1; ABSTAIN: 1; NO (default): 0 -> YES / total - ABSTAIN == 1 % 1"
            )
            $ do
              delegateSPORewardAddressToDRep_ spoC1 (Coin 1_000_000) DRepAlwaysAbstain
              calculatePoolAcceptedRatio gid `shouldReturn` 1

          passNEpochs 2

          getCommitteeMembers `shouldReturn` mempty

delayingActionsSpec ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
delayingActionsSpec :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
delayingActionsSpec =
  -- All tests below are relying on submitting constitution of committe-update proposals, which are disallowed during bootstrap,
  -- so we can only run them post-bootstrap.
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Delaying actions" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
      String
"A delaying action delays its child even when both ere proposed and ratified in the same epoch"
      (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap
      (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
        (dRep, _, _) <- setupSingleDRep 1_000_000
        gai0 <- submitConstitution SNothing
        gai1 <- submitConstitution $ SJust (GovPurposeId gai0)
        gai2 <- submitConstitution $ SJust (GovPurposeId gai1)
        gai3 <- submitConstitution $ SJust (GovPurposeId gai2)
        submitYesVote_ (DRepVoter dRep) gai0
        submitYesVoteCCs_ committeeMembers' gai0
        submitYesVote_ (DRepVoter dRep) gai1
        submitYesVoteCCs_ committeeMembers' gai1
        submitYesVote_ (DRepVoter dRep) gai2
        submitYesVoteCCs_ committeeMembers' gai2
        submitYesVote_ (DRepVoter dRep) gai3
        submitYesVoteCCs_ committeeMembers' gai3
        passNEpochs 2
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai0)
        passEpoch
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai1)
        passEpoch
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai2)
        passEpoch
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai3)
        getConstitutionProposals `shouldReturn` Map.empty
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
      String
"A delaying action delays all other actions even when all of them may be ratified in the same epoch"
      (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap
      (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
        (dRep, _, _) <- setupSingleDRep 1_000_000
        pGai0 <-
          submitParameterChange
            SNothing
            $ def & ppuDRepDepositL .~ SJust (Coin 1_000_000)
        pGai1 <-
          submitParameterChange
            (SJust pGai0)
            $ def & ppuDRepDepositL .~ SJust (Coin 1_000_001)
        pGai2 <-
          submitParameterChange
            (SJust pGai1)
            $ def & ppuDRepDepositL .~ SJust (Coin 1_000_002)
        cGai0 <- submitConstitution SNothing
        cGai1 <- submitConstitution $ SJust (GovPurposeId cGai0)
        submitYesVote_ (DRepVoter dRep) cGai0
        submitYesVoteCCs_ committeeMembers' cGai0
        submitYesVote_ (DRepVoter dRep) cGai1
        submitYesVoteCCs_ committeeMembers' cGai1
        submitYesVote_ (DRepVoter dRep) pGai0
        submitYesVoteCCs_ committeeMembers' pGai0
        submitYesVote_ (DRepVoter dRep) pGai1
        submitYesVoteCCs_ committeeMembers' pGai1
        submitYesVote_ (DRepVoter dRep) pGai2
        submitYesVoteCCs_ committeeMembers' pGai2
        passNEpochs 2
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai0)
        getLastEnactedParameterChange `shouldReturn` SNothing
        passEpoch
        -- here 'ParameterChange' action does not get enacted even though
        -- it is not related, since its priority is 4 while the priority
        -- for 'NewConstitution' is 2, so it gets delayed a second time
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai1)
        getConstitutionProposals `shouldReturn` Map.empty
        getLastEnactedParameterChange `shouldReturn` SNothing
        passEpoch
        -- all three actions, pGai0, pGai1 and pGai2, are enacted one
        -- after the other in the same epoch
        getLastEnactedParameterChange `shouldReturn` SJust (GovPurposeId pGai2)
        getParameterChangeProposals `shouldReturn` Map.empty
    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"An action expires when delayed enough even after being ratified" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/923
      -- TODO: Re-enable after issue is resolved, by removing this override
      String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Same lineage" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
        (dRep, _, _) <- setupSingleDRep 1_000_000
        modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
        gai0 <- submitConstitution SNothing
        gai1 <- submitConstitution $ SJust (GovPurposeId gai0)
        gai2 <- submitConstitution $ SJust (GovPurposeId gai1)
        gai3 <- submitConstitution $ SJust (GovPurposeId gai2)
        submitYesVote_ (DRepVoter dRep) gai0
        submitYesVoteCCs_ committeeMembers' gai0
        submitYesVote_ (DRepVoter dRep) gai1
        submitYesVoteCCs_ committeeMembers' gai1
        submitYesVote_ (DRepVoter dRep) gai2
        submitYesVoteCCs_ committeeMembers' gai2
        submitYesVote_ (DRepVoter dRep) gai3
        submitYesVoteCCs_ committeeMembers' gai3
        passNEpochs 2
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai0)
        passEpoch
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai1)
        passEpoch
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai2)
        getConstitutionProposals `shouldReturn` Map.empty
        passEpoch
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId gai2)
      -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/923
      -- TODO: Re-enable after issue is resolved, by removing this override
      String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Other lineage" (ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        committeeMembers' <- ImpTestM era (NonEmpty (Credential HotCommitteeRole))
forall era.
(HasCallStack, ConwayEraImp era) =>
ImpTestM era (NonEmpty (Credential HotCommitteeRole))
registerInitialCommittee
        (dRep, _, _) <- setupSingleDRep 1_000_000
        modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
        pGai0 <-
          submitParameterChange
            SNothing
            $ def & ppuDRepDepositL .~ SJust (Coin 1_000_000)
        pGai1 <-
          submitParameterChange
            (SJust pGai0)
            $ def & ppuDRepDepositL .~ SJust (Coin 1_000_001)
        pGai2 <-
          submitParameterChange
            (SJust pGai1)
            $ def & ppuDRepDepositL .~ SJust (Coin 1_000_002)
        cGai0 <- submitConstitution SNothing
        cGai1 <- submitConstitution $ SJust (GovPurposeId cGai0)
        cGai2 <- submitConstitution $ SJust (GovPurposeId cGai1)
        submitYesVote_ (DRepVoter dRep) cGai0
        submitYesVoteCCs_ committeeMembers' cGai0
        submitYesVote_ (DRepVoter dRep) cGai1
        submitYesVoteCCs_ committeeMembers' cGai1
        submitYesVote_ (DRepVoter dRep) cGai2
        submitYesVoteCCs_ committeeMembers' cGai2
        submitYesVote_ (DRepVoter dRep) pGai0
        submitYesVoteCCs_ committeeMembers' pGai0
        submitYesVote_ (DRepVoter dRep) pGai1
        submitYesVoteCCs_ committeeMembers' pGai1
        submitYesVote_ (DRepVoter dRep) pGai2
        submitYesVoteCCs_ committeeMembers' pGai2
        passNEpochs 2
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai0)
        getLastEnactedParameterChange `shouldReturn` SNothing
        passEpoch
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai1)
        getLastEnactedParameterChange `shouldReturn` SNothing
        passEpoch
        getLastEnactedConstitution `shouldReturn` SJust (GovPurposeId cGai2)
        getConstitutionProposals `shouldReturn` Map.empty
        getLastEnactedParameterChange `shouldReturn` SNothing
        passEpoch
        -- all three actions, pGai0, pGai1 and pGai2, are expired here
        -- and nothing gets enacted
        getLastEnactedParameterChange `shouldReturn` SNothing
        getParameterChangeProposals `shouldReturn` Map.empty
      String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"proposals to update the committee get delayed if the expiration exceeds the max term" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        (drep, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
        (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
        maxTermLength <- getsNES $ nesEsL . curPParamsEpochStateL . ppCommitteeMaxTermLengthL

        hks <- registerInitialCommittee
        initialMembers <- getCommitteeMembers

        (membersExceedingExpiry, exceedingExpiry) <-
          impAnn "Committee with members exceeding the maxTerm is not enacted" $ do
            -- submit a proposal for adding two members to the committee,
            -- one of which has a max term exceeding the maximum
            c3 <- freshKeyHash
            c4 <- freshKeyHash
            currentEpoch <- getsNES nesELL
            let exceedingExpiry = EpochNo -> EpochInterval -> EpochNo
addEpochInterval (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
currentEpoch EpochInterval
maxTermLength) (Word32 -> EpochInterval
EpochInterval Word32
7)
                membersExceedingExpiry = [(KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash ColdCommitteeRole
c3, EpochNo
exceedingExpiry), (KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash ColdCommitteeRole
c4, EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
currentEpoch EpochInterval
maxTermLength)]
            GovPurposeId gaid <-
              submitCommitteeElection
                SNothing
                drep
                Set.empty
                membersExceedingExpiry
            submitYesVote_ (StakePoolVoter spoC) gaid
            passNEpochs 2
            -- the new committee has not been enacted
            expectMembers initialMembers
            pure (Map.keysSet membersExceedingExpiry, exceedingExpiry)

        -- other actions get ratified and enacted
        govIdConst1 <- impAnn "Other actions are ratified and enacted" $ do
          (proposal, constitution) <- mkConstitutionProposal SNothing
          govIdConst1 <- submitProposal proposal
          submitYesVote_ (DRepVoter drep) govIdConst1
          submitYesVoteCCs_ hks govIdConst1

          passNEpochs 2
          curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL
          curConstitution `shouldBe` constitution
          pure govIdConst1

        -- after enough epochs pass, the expiration of the new members becomes acceptable
        -- and the new committee is enacted
        impAnn "New committee is enacted" $ do
          currentEpoch <- getsNES nesELL
          let delta =
                Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EpochNo -> Word64
unEpochNo EpochNo
exceedingExpiry)
                  Int -> Int -> Int
forall a. Num a => a -> a -> a
- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (EpochNo -> Word64
unEpochNo (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
currentEpoch EpochInterval
maxTermLength))
          replicateM_ delta passEpoch

          -- pass one more epoch after ratification, in order to be enacted
          passEpoch
          expectMembers $ initialMembers <> membersExceedingExpiry

        impAnn "New committee can vote" $ do
          (proposal, constitution) <- mkConstitutionProposal $ SJust (GovPurposeId govIdConst1)
          govIdConst2 <- submitProposal proposal
          submitYesVote_ (DRepVoter drep) govIdConst2
          hks' <- traverse registerCommitteeHotKey (Set.toList membersExceedingExpiry)
          submitYesVoteCCs_ hks' govIdConst2

          passNEpochs 2
          curConstitution <- getsNES $ newEpochStateGovStateL . constitutionGovStateL
          curConstitution `shouldBe` constitution

committeeMaxTermLengthSpec ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  SpecWith (ImpInit (LedgerSpec era))
committeeMaxTermLengthSpec :: forall era.
(HasCallStack, ConwayEraImp era) =>
SpecWith (ImpInit (LedgerSpec era))
committeeMaxTermLengthSpec =
  -- Committee-update proposals are disallowed during bootstrap, so we can only run these tests post-bootstrap
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Committee members can serve full `CommitteeMaxTermLength`" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    let
      electMembersWithMaxTermLength ::
        KeyHash StakePool ->
        Credential DRepRole ->
        ImpTestM era [Credential ColdCommitteeRole]
      electMembersWithMaxTermLength :: KeyHash StakePool
-> Credential DRepRole
-> ImpTestM era [Credential ColdCommitteeRole]
electMembersWithMaxTermLength KeyHash StakePool
spoC Credential DRepRole
drep = do
        m1 <- KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj (KeyHash ColdCommitteeRole -> Credential ColdCommitteeRole)
-> ImpM (LedgerSpec era) (KeyHash ColdCommitteeRole)
-> ImpM (LedgerSpec era) (Credential ColdCommitteeRole)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash ColdCommitteeRole)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
        m2 <- KeyHashObj <$> freshKeyHash
        currentEpoch <- getsNES nesELL
        maxTermLength <-
          getsNES $
            nesEsL . curPParamsEpochStateL . ppCommitteeMaxTermLengthL
        let expiry = EpochNo -> EpochInterval -> EpochNo
addEpochInterval (EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
currentEpoch (EpochInterval -> EpochNo) -> EpochInterval -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval Word32
1) EpochInterval
maxTermLength
            members = [(Credential ColdCommitteeRole
m1, EpochNo
expiry), (Credential ColdCommitteeRole
m2, EpochNo
expiry)]
        GovPurposeId gaid <-
          submitCommitteeElection
            SNothing
            drep
            Set.empty
            members
        submitYesVote_ (StakePoolVoter spoC) gaid
        pure [m1, m2]
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"maxTermLength = 0" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      -- ======== EPOCH e ========

      let termLength :: EpochInterval
termLength = Word32 -> EpochInterval
EpochInterval Word32
0
      (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
        PParams era
pp
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochInterval
termLength

      (drep, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
      (spoC, _, _) <- setupPoolWithStake $ Coin 10_000_000
      initialMembers <- getCommitteeMembers

      -- Setup new committee members with max term length of 0 epoch
      newMembers <- electMembersWithMaxTermLength spoC drep

      curProtVer <- getProtVer
      nextMajorVersion <- succVersion $ pvMajor curProtVer
      let nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}

      -- Create a proposal for a hard-fork initiation
      gid <- submitGovAction $ HardForkInitiation SNothing nextProtVer

      -- Accept the proposal with all the governing bodies except for the CC
      submitYesVote_ (StakePoolVoter spoC) gid
      submitYesVote_ (DRepVoter drep) gid

      passEpoch
      -- ======== EPOCH e+1 ========

      hotCs <- mapM registerCommitteeHotKey newMembers

      -- Upto protocol version 10, CC members can vote for the hard-fork
      -- although their election hasn't been enacted yet. We need to pass
      -- another epoch to have their enactment.
      when (hardforkConwayDisallowUnelectedCommitteeFromVoting curProtVer) passEpoch
      submitYesVoteCCs_ hotCs gid

      unless (hardforkConwayDisallowUnelectedCommitteeFromVoting curProtVer) $ do
        -- Although elected, new CC members are not yet active at this point
        -- since it takes two epochs for their election to take effect, hence
        -- the check fails
        isCommitteeAccepted gid `shouldReturn` False
        mapM_ expectCommitteeMemberAbsence newMembers

      passEpoch
      -- ======== EPOCH e+(2 or 3) ========

      -- Two (or three) epochs passed since the proposal and all the governing
      -- bodies except the CC have voted 'Yes' for the hard-fork immediately.
      -- However, since the CC could only vote in the next epoch, the hard-fork
      -- is not yet enacted...
      getLastEnactedHardForkInitiation `shouldReturn` SNothing
      -- ...but now, until PV 10, we can see that the CC accepted the proposal...
      unless (hardforkConwayDisallowUnelectedCommitteeFromVoting curProtVer) $
        isCommitteeAccepted gid `shouldReturn` True
      -- ...and that they are elected members now, albeit already expired ones
      expectMembers $ initialMembers <> Set.fromList newMembers
      mapM_ ccShouldBeExpired newMembers

      passEpoch
      -- ======== EPOCH e+(3 or 4) ========

      -- Three (or four) epochs passed since the CCs also accepted the
      -- hard-fork, however it didn't get enacted because the CCs expired by now
      -- and thus their votes don't count
      getLastEnactedHardForkInitiation `shouldReturn` SNothing
      getProtVer `shouldReturn` curProtVer
      isCommitteeAccepted gid `shouldReturn` False
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"maxTermLength = 1" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      -- ======== EPOCH e ========

      let termLength :: EpochInterval
termLength = Word32 -> EpochInterval
EpochInterval Word32
1
      (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
        PParams era
pp
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochInterval
termLength

      (drep, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
      (spoC, _, _) <- setupPoolWithStake $ Coin 10_000_000
      initialMembers <- getCommitteeMembers

      -- Setup new committee members with max term length of 0 epoch
      newMembers <- electMembersWithMaxTermLength spoC drep

      curProtVer <- getProtVer
      nextMajorVersion <- succVersion $ pvMajor curProtVer
      let nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}

      -- Create a proposal for a hard-fork initiation
      gid <- submitGovAction $ HardForkInitiation SNothing nextProtVer

      -- Accept the proposal with all the governing bodies except for the CC
      submitYesVote_ (StakePoolVoter spoC) gid
      submitYesVote_ (DRepVoter drep) gid

      passNEpochs 2
      -- ======== EPOCH e+2 ========

      hotCs <- mapM registerCommitteeHotKey newMembers
      -- CC members can now vote for the hard-fork
      submitYesVoteCCs_ hotCs gid

      -- Two epochs passed since the proposal and all the governing bodies except the
      -- CC have voted 'Yes' for the hard-fork immediately. However, since the CC could only
      -- vote in the next epoch, the hard-fork is not yet enacted...
      getLastEnactedHardForkInitiation `shouldReturn` SNothing
      -- ...but now we can see that the CC accepted the proposal...
      isCommitteeAccepted gid `shouldReturn` True
      -- ...and that they are elected members now, albeit already expired ones
      expectMembers $ initialMembers <> Set.fromList newMembers
      mapM_ ccShouldNotBeExpired newMembers

      passNEpochs 2
      -- ======== EPOCH e+4 ========
      mapM_ ccShouldBeExpired newMembers

      -- Two epochs passed since the CCs also accepted the hard-fork, however
      -- it didn't get enacted because the CCs expired by now and thus
      -- their votes don't count
      getLastEnactedHardForkInitiation `shouldReturn` SNothing
      getProtVer `shouldReturn` curProtVer
      isCommitteeAccepted gid `shouldReturn` False
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"maxTermLength = 2" (ImpTestM era () -> SpecWith (Arg (ImpTestM era ())))
-> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a b. (a -> b) -> a -> b
$ ImpTestM era () -> ImpTestM era ()
forall era. EraGov era => ImpTestM era () -> ImpTestM era ()
whenPostBootstrap (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
      -- ======== EPOCH e ========

      let termLength :: EpochInterval
termLength = Word32 -> EpochInterval
EpochInterval Word32
2
      (PParams era -> PParams era) -> ImpTestM era ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpTestM era ())
-> (PParams era -> PParams era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ \PParams era
pp ->
        PParams era
pp
          PParams era -> (PParams era -> PParams era) -> PParams era
forall a b. a -> (a -> b) -> b
& (EpochInterval -> Identity EpochInterval)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL ((EpochInterval -> Identity EpochInterval)
 -> PParams era -> Identity (PParams era))
-> EpochInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EpochInterval
termLength

      (drep, _, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep Integer
1_000_000
      (spoC, _, _) <- setupPoolWithStake $ Coin 10_000_000
      initialMembers <- getCommitteeMembers

      -- Setup new committee members with max term length of 2 epoch
      newMembers <- electMembersWithMaxTermLength spoC drep

      curProtVer <- getProtVer
      nextMajorVersion <- succVersion $ pvMajor curProtVer
      let nextProtVer = ProtVer
curProtVer {pvMajor = nextMajorVersion}

      -- Create a proposal for a hard-fork initiation
      gid <- submitGovAction $ HardForkInitiation SNothing nextProtVer

      -- Accept the proposal with all the governing bodies except for the CC
      submitYesVote_ (StakePoolVoter spoC) gid
      submitYesVote_ (DRepVoter drep) gid

      passNEpochs 2
      -- ======== EPOCH e+2 ========

      hotCs <- mapM registerCommitteeHotKey newMembers
      -- CC members can now vote for the hard-fork
      submitYesVoteCCs_ hotCs gid

      -- Two epochs passed since the proposal and all the governing bodies except the
      -- CC have voted 'Yes' for the hard-fork immediately. However, since the CC could only
      -- vote in the next epoch, the hard-fork is not yet enacted...
      getLastEnactedHardForkInitiation `shouldReturn` SNothing
      -- ...but now we can see that the CC accepted the proposal...
      isCommitteeAccepted gid `shouldReturn` True
      -- ...and that they are active elected members now
      expectMembers $ initialMembers <> Set.fromList newMembers
      mapM_ ccShouldNotBeExpired newMembers

      passNEpochs 2
      -- ======== EPOCH e+4 ========
      mapM_ ccShouldBeExpired newMembers

      -- Two epochs passed since the CCs also accepted the hard-fork, which
      -- is now enacted since the CCs were active during the check
      getLastEnactedHardForkInitiation `shouldReturn` SJust (GovPurposeId gid)
      getProtVer `shouldReturn` nextProtVer