{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

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

import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.BaseTypes (EpochInterval (..), addEpochInterval)
import Cardano.Ledger.Coin
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.PParams
import Cardano.Ledger.Conway.Rules (
  ConwayEpochEvent (GovInfoEvent),
  ConwayNewEpochEvent (..),
 )
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Rules (Event, ShelleyTickEvent (..))
import Cardano.Ledger.Val
import Control.Monad.Writer (listen)
import Data.Default (Default (..))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Tree
import Data.Typeable (cast)
import Lens.Micro
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Core.Rational (IsRatio (..), (%!))
import Test.Cardano.Ledger.Imp.Common

spec ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
(ConwayEraImp era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
spec = do
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
dRepVotingSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
treasurySpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
proposalsSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
dRepSpec
  SpecWith (ImpInit (LedgerSpec era))
forall era.
(ConwayEraImp era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
eventsSpec

proposalsSpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
proposalsSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
proposalsSpec =
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Proposals" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Proposals survive multiple epochs without any activity" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      -- + 2 epochs to pass to get the desired effect
      (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
$ (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
4
      _tree <-
        StrictMaybe GovActionId
-> Tree () -> ImpTestM era (Tree GovActionId)
submitParameterChangeTree StrictMaybe GovActionId
forall a. StrictMaybe a
SNothing (Tree () -> ImpTestM era (Tree GovActionId))
-> Tree () -> ImpTestM era (Tree GovActionId)
forall a b. (a -> b) -> a -> b
$
          () -> [Tree ()] -> Tree ()
forall a. a -> [Tree a] -> Tree a
Node
            ()
            [ () -> [Tree ()] -> Tree ()
forall a. a -> [Tree a] -> Tree a
Node
                ()
                [ () -> [Tree ()] -> Tree ()
forall a. a -> [Tree a] -> Tree a
Node () []
                , () -> [Tree ()] -> Tree ()
forall a. a -> [Tree a] -> Tree a
Node () []
                ]
            , () -> [Tree ()] -> Tree ()
forall a. a -> [Tree a] -> Tree a
Node () []
            ]

      forest <- getProposals
      passNEpochs 5
      forest' <- getProposals
      forest' `shouldBe` forest
      passEpoch
      forest'' <- getProposals
      forest'' `shouldBe` def
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Expired proposal deposit refunded" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      let deposit :: Coin
deposit = Integer -> Coin
Coin Integer
999
      (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
& (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
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
.~ Coin
deposit
      rewardAccount <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount

      initialValue <- getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL)

      parameterChangeAction <- mkMinFeeUpdateGovAction SNothing
      govActionId <-
        mkProposalWithRewardAccount
          parameterChangeAction
          rewardAccount
          >>= submitProposal
      expectPresentGovActionId govActionId
      passNEpochs 3
      expectMissingGovActionId govActionId

      getsNES (nesEsL . curPParamsEpochStateL . ppMinFeeAL) `shouldReturn` initialValue
      getAccountBalance rewardAccount `shouldReturn` deposit

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Proposals are expired and removed as expected" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (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
$ (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
1

      curConstitution <- SimpleGetter (NewEpochState era) (Constitution era)
-> ImpTestM era (Constitution era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Constitution era)
 -> ImpTestM era (Constitution era))
-> SimpleGetter (NewEpochState era) (Constitution era)
-> ImpTestM era (Constitution era)
forall a b. (a -> b) -> a -> b
$ (GovState era -> Const r (GovState era))
-> NewEpochState era -> Const r (NewEpochState era)
(ConwayGovState era -> Const r (ConwayGovState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(GovState era -> f (GovState era))
-> NewEpochState era -> f (NewEpochState era)
newEpochStateGovStateL ((ConwayGovState era -> Const r (ConwayGovState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Constitution era -> Const r (Constitution era))
    -> ConwayGovState era -> Const r (ConwayGovState era))
-> (Constitution era -> Const r (Constitution era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Constitution era -> Const r (Constitution era))
-> GovState era -> Const r (GovState era)
(Constitution era -> Const r (Constitution era))
-> ConwayGovState era -> Const r (ConwayGovState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (Constitution era)
Lens' (GovState era) (Constitution era)
constitutionGovStateL
      initialPulser <- getsNES $ newEpochStateGovStateL . drepPulsingStateGovStateL
      initialEnactState <- getEnactState

      govActionId <- submitConstitution SNothing
      curConstitution' <- getsNES $ newEpochStateGovStateL . constitutionGovStateL
      impAnn "Constitution has not been enacted yet" $
        curConstitution' `shouldBe` curConstitution

      govState <- getsNES newEpochStateGovStateL
      let expectedProposals = GovState era
govState GovState era
-> Getting (Proposals era) (GovState era) (Proposals era)
-> Proposals era
forall s a. s -> Getting a s a -> a
^. Getting (Proposals era) (GovState era) (Proposals era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (Proposals era)
Lens' (GovState era) (Proposals era)
proposalsGovStateL
          expectedPulser = GovState era
govState GovState era
-> Getting
     (DRepPulsingState era) (GovState era) (DRepPulsingState era)
-> DRepPulsingState era
forall s a. s -> Getting a s a -> a
^. Getting
  (DRepPulsingState era) (GovState era) (DRepPulsingState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (DRepPulsingState era)
Lens' (GovState era) (DRepPulsingState era)
drepPulsingStateGovStateL
      expectedEnactState <- getEnactState

      impAnn "EnactState reflects the submitted governance action" $ do
        expectedEnactState `shouldBe` initialEnactState

      impAnn "Proposals contain the submitted proposal" $
        expectedProposals `shouldSatisfy` \Proposals era
props -> GovActionId
govActionId GovActionId -> StrictSeq GovActionId -> Bool
forall a. Eq a => a -> StrictSeq a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Proposals era -> StrictSeq GovActionId
forall era. Proposals era -> StrictSeq GovActionId
proposalsIds Proposals era
props

      impAnn "Pulser has not changed" $
        expectedPulser `shouldBe` initialPulser

      passNEpochs 2
      impAnn "Proposal gets removed after expiry" $ do
        govStateFinal <- getsNES newEpochStateGovStateL
        let ratifyState = DRepPulsingState era -> RatifyState era
forall era.
(EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> RatifyState era
extractDRepPulsingState (GovState era
govStateFinal GovState era
-> Getting
     (DRepPulsingState era) (GovState era) (DRepPulsingState era)
-> DRepPulsingState era
forall s a. s -> Getting a s a -> a
^. Getting
  (DRepPulsingState era) (GovState era) (DRepPulsingState era)
forall era.
ConwayEraGov era =>
Lens' (GovState era) (DRepPulsingState era)
Lens' (GovState era) (DRepPulsingState era)
drepPulsingStateGovStateL)
        rsExpired ratifyState `shouldBe` Set.singleton govActionId
  where
    submitParameterChangeTree :: StrictMaybe GovActionId
-> Tree () -> ImpTestM era (Tree GovActionId)
submitParameterChangeTree = (StrictMaybe GovActionId -> ImpM (LedgerSpec era) GovActionId)
-> StrictMaybe GovActionId
-> Tree ()
-> ImpTestM era (Tree GovActionId)
forall era.
(StrictMaybe GovActionId -> ImpTestM era GovActionId)
-> StrictMaybe GovActionId
-> Tree ()
-> ImpTestM era (Tree GovActionId)
submitGovActionTree ((StrictMaybe GovActionId -> ImpM (LedgerSpec era) GovActionId)
 -> StrictMaybe GovActionId
 -> Tree ()
 -> ImpTestM era (Tree GovActionId))
-> (StrictMaybe GovActionId -> ImpM (LedgerSpec era) GovActionId)
-> StrictMaybe GovActionId
-> Tree ()
-> ImpTestM era (Tree GovActionId)
forall a b. (a -> b) -> a -> b
$ StrictMaybe GovActionId -> ImpTestM era (GovAction era)
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction (StrictMaybe GovActionId -> ImpTestM era (GovAction era))
-> (GovAction era -> ImpM (LedgerSpec era) GovActionId)
-> StrictMaybe GovActionId
-> ImpM (LedgerSpec era) GovActionId
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> GovAction era -> ImpM (LedgerSpec era) GovActionId
forall era.
(ConwayEraImp era, HasCallStack) =>
GovAction era -> ImpTestM era GovActionId
submitGovAction

dRepSpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
dRepSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
dRepSpec =
  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 submitParamChangeProposal :: ImpM (LedgerSpec era) ()
submitParamChangeProposal = StrictMaybe GovActionId -> ImpTestM era (GovAction era)
forall era.
ConwayEraImp era =>
StrictMaybe GovActionId -> ImpTestM era (GovAction era)
mkMinFeeUpdateGovAction StrictMaybe GovActionId
forall a. StrictMaybe a
SNothing ImpTestM era (GovAction era)
-> (GovAction era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) ()
forall a b.
ImpM (LedgerSpec era) a
-> (a -> ImpM (LedgerSpec era) b) -> ImpM (LedgerSpec era) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GovAction era -> ImpM (LedgerSpec era) ()
forall era.
(ConwayEraImp era, HasCallStack) =>
GovAction era -> ImpTestM era ()
submitGovAction_
    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/923
    -- 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
"expiry is updated based on the number of dormant epochs" (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
$ (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
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

      startEpochNo <- getsNES nesELL
      let
        -- compute the epoch number that is an offset from starting epoch number
        offDRepActivity = EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startEpochNo (EpochInterval -> EpochNo)
-> (Word32 -> EpochInterval) -> Word32 -> EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> EpochInterval
EpochInterval
      expectNumDormantEpochs 0

      -- epoch 0: we submit a proposal
      submitParamChangeProposal
      passNEpochsChecking 2 $ do
        expectNumDormantEpochs 0
        expectDRepExpiry drep $ offDRepActivity 100

      passEpoch -- entering epoch 3
      -- proposal has expired
      expectNumDormantEpochs 1
      expectDRepExpiry drep $ offDRepActivity 100

      passEpoch -- entering epoch 4
      expectNumDormantEpochs 2
      expectDRepExpiry drep $ offDRepActivity 100

      passEpoch -- entering epoch 5
      expectNumDormantEpochs 3
      expectDRepExpiry drep $ offDRepActivity 100

      submitParamChangeProposal
      -- number of dormant epochs is added to the drep expiry and reset to 0
      expectNumDormantEpochs 0
      expectDRepExpiry drep $ offDRepActivity 103

      passEpoch -- entering epoch 6
      expectNumDormantEpochs 0
      expectDRepExpiry drep $ offDRepActivity 103
    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/923
    -- 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
"expiry is not updated for inactive DReps" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      let
        drepActivity :: Word32
drepActivity = Word32
2
      (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
& (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
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
ppDRepActivityL ((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
drepActivity
      (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
      startEpochNo <- getsNES nesELL
      let
        -- compute the epoch number that is an offset from starting epoch number plus
        -- the ppDRepActivity parameter
        offDRepActivity Word32
offset =
          EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startEpochNo (EpochInterval -> EpochNo) -> EpochInterval -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval (Word32
drepActivity Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
offset)

      expectNumDormantEpochs 0

      -- epoch 0: we submit a proposal
      submitParamChangeProposal
      passNEpochsChecking 2 $ do
        expectNumDormantEpochs 0
        expectDRepExpiry drep $ offDRepActivity 0

      passEpoch -- entering epoch 3
      -- proposal has expired
      -- drep has expired
      expectNumDormantEpochs 1
      expectDRepExpiry drep $ offDRepActivity 0
      expectActualDRepExpiry drep $ offDRepActivity 1
      isDRepExpired drep `shouldReturn` False -- numDormantEpochs is added to the drep exiry calculation
      passEpoch -- entering epoch 4
      expectNumDormantEpochs 2
      expectDRepExpiry drep $ offDRepActivity 0
      expectActualDRepExpiry drep $ offDRepActivity 2

      passEpoch -- entering epoch 5
      expectNumDormantEpochs 3
      expectDRepExpiry drep $ offDRepActivity 0
      expectActualDRepExpiry drep $ offDRepActivity 3

      submitParamChangeProposal
      -- number of dormant epochs is added to the drep, considering they are not actually expired,
      -- and is reset to 0
      expectNumDormantEpochs 0
      expectDRepExpiry drep $ offDRepActivity 3

      passEpoch -- entering epoch 6
      expectNumDormantEpochs 0
      expectDRepExpiry drep $ offDRepActivity 3
    -- https://github.com/IntersectMBO/formal-ledger-specifications/issues/926
    -- 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
"expiry updates are correct for a mixture of cases" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      let
        drepActivity :: Word32
drepActivity = Word32
4
      (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
& (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
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
ppDRepActivityL ((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
drepActivity
      startEpochNo <- SimpleGetter (NewEpochState era) EpochNo -> ImpTestM era EpochNo
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (EpochNo -> Const r EpochNo)
-> NewEpochState era -> Const r (NewEpochState era)
SimpleGetter (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL
      let
        -- compute the epoch number that is an offset from starting epoch number plus
        -- the ppDRepActivity parameter
        offDRepActivity Word32
offset =
          EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
startEpochNo (EpochInterval -> EpochNo) -> EpochInterval -> EpochNo
forall a b. (a -> b) -> a -> b
$ Word32 -> EpochInterval
EpochInterval (Word32
drepActivity Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
offset)
      (drep1, _, _) <- setupSingleDRep 1_000_000 -- Receives an expiry update transaction certificate
      (drep2, _, _) <- setupSingleDRep 1_000_000 -- Turns inactive due to natural expiry
      (drep3, _, _) <- setupSingleDRep 1_000_000 -- Unregisters and gets deleted
      expectNumDormantEpochs 0

      -- epoch 0: we submit a proposal
      _ <- submitGovAction InfoAction
      passNEpochsChecking 2 $ do
        expectNumDormantEpochs 0
        expectDRepExpiry drep1 $ offDRepActivity 0
        expectDRepExpiry drep2 $ offDRepActivity 0
        expectDRepExpiry drep3 $ offDRepActivity 0

      passEpoch -- entering epoch 3
      -- proposal has expired
      expectCurrentProposals
      expectPulserProposals
      expectNumDormantEpochs 1
      expectDRepExpiry drep1 $ offDRepActivity 0
      expectDRepExpiry drep2 $ offDRepActivity 0
      expectDRepExpiry drep3 $ offDRepActivity 0

      passEpoch -- entering epoch 4
      expectNumDormantEpochs 2
      expectDRepExpiry drep1 $ offDRepActivity 0
      expectDRepExpiry drep2 $ offDRepActivity 0
      expectDRepExpiry drep3 $ offDRepActivity 0

      updateDRep drep1 -- DRep expiry becomes (current epoch (4) + drep activity (4) - dormant epochs (2))
      expectDRepExpiry drep1 $ offDRepActivity 2
      unRegisterDRep drep3
      passEpoch -- entering epoch 5
      -- Updated drep1 shows their new expiry
      -- numDormantEpochs bumps up further
      -- drep3 has unregistered
      -- drep2 has not expired since we now have dormant epochs
      expectNumDormantEpochs 3
      expectDRepExpiry drep1 $ offDRepActivity 2
      expectActualDRepExpiry drep1 $ offDRepActivity 5
      expectDRepExpiry drep2 $ offDRepActivity 0
      expectActualDRepExpiry drep2 $ offDRepActivity 3
      expectDRepNotRegistered drep3

      _ <- submitGovAction InfoAction
      -- number of dormant epochs is added to the dreps expiry, and reset to 0
      expectNumDormantEpochs 0
      expectDRepExpiry drep1 $ offDRepActivity 5 -- 6 + 3
      expectDRepExpiry drep2 $ offDRepActivity 3 -- 4 + 3
      passNEpochsChecking 2 $ do
        expectNumDormantEpochs 0
        expectDRepExpiry drep1 $ offDRepActivity 5
        expectDRepExpiry drep2 $ offDRepActivity 3

      passEpoch
      expectNumDormantEpochs 1
      expectDRepExpiry drep1 $ offDRepActivity 5
      expectActualDRepExpiry drep1 $ offDRepActivity 6
      expectDRepExpiry drep2 $ offDRepActivity 3
      expectActualDRepExpiry drep2 $ offDRepActivity 4

      gai <- submitGovAction InfoAction

      passNEpochsChecking 2 $ do
        expectNumDormantEpochs 0
        expectDRepExpiry drep1 $ offDRepActivity 6
        expectActualDRepExpiry drep1 $ offDRepActivity 6
        expectDRepExpiry drep2 $ offDRepActivity 4
        expectActualDRepExpiry drep2 $ offDRepActivity 4

      submitYesVote_ (DRepVoter drep2) gai

      passEpoch
      expectNumDormantEpochs 1
      expectDRepExpiry drep1 $ offDRepActivity 6
      expectActualDRepExpiry drep1 $ offDRepActivity 7
      expectDRepExpiry drep2 $ offDRepActivity 10
      expectActualDRepExpiry drep2 $ offDRepActivity 11

      passEpoch
      expectNumDormantEpochs 2
      expectDRepExpiry drep1 $ offDRepActivity 6
      expectActualDRepExpiry drep1 $ offDRepActivity 8
      expectDRepExpiry drep2 $ offDRepActivity 10
      expectActualDRepExpiry drep2 $ offDRepActivity 12

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"DRep registration should succeed" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      String -> ImpM (LedgerSpec era) ()
forall t. HasCallStack => String -> ImpM t ()
logString String
"Stake distribution before DRep registration:"
      ImpM (LedgerSpec era) ()
forall era.
(ToExpr (InstantStake era), HasCallStack) =>
ImpTestM era ()
logInstantStake
      _ <- ImpTestM era (KeyHash DRepRole)
forall era. ConwayEraImp era => ImpTestM era (KeyHash DRepRole)
registerDRep
      logString "Stake distribution after DRep registration:"
      logInstantStake
      passEpoch

dRepVotingSpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
dRepVotingSpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
dRepVotingSpec =
  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
    -- DRep voting for anything other than Info is disallowed during bootstrap,
    -- so we can only run this test post-bootstrap
    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"proposal is accepted after two epochs" (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
$ (DRepVotingThresholds -> Identity DRepVotingThresholds)
-> PParams era -> Identity (PParams era)
forall era.
ConwayEraPParams era =>
Lens' (PParams era) DRepVotingThresholds
Lens' (PParams era) DRepVotingThresholds
ppDRepVotingThresholdsL ((DRepVotingThresholds -> Identity DRepVotingThresholds)
 -> PParams era -> Identity (PParams era))
-> ((UnitInterval -> Identity UnitInterval)
    -> DRepVotingThresholds -> Identity DRepVotingThresholds)
-> (UnitInterval -> Identity UnitInterval)
-> PParams era
-> Identity (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UnitInterval -> Identity UnitInterval)
-> DRepVotingThresholds -> Identity DRepVotingThresholds
Lens' DRepVotingThresholds UnitInterval
dvtPPEconomicGroupL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      let getParamValue :: ImpTestM era Coin
getParamValue = SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES ((EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Coin -> Const r Coin)
    -> EpochState era -> Const r (EpochState era))
-> (Coin -> Const r Coin)
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const r (PParams era))
-> EpochState era -> Const r (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const r (PParams era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin) -> PParams era -> Const r (PParams era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> PParams era -> Const r (PParams era)
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppMinFeeAL)
      initialParamValue <- ImpTestM era Coin
getParamValue

      let proposedValue = Coin
initialParamValue Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Integer -> Coin
Coin Integer
300
      let proposedUpdate = PParamsUpdate era
forall a. Default a => a
def PParamsUpdate era
-> (PParamsUpdate era -> PParamsUpdate era) -> PParamsUpdate era
forall a b. a -> (a -> b) -> b
& (StrictMaybe Coin -> Identity (StrictMaybe Coin))
-> PParamsUpdate era -> Identity (PParamsUpdate era)
forall era.
EraPParams era =>
Lens' (PParamsUpdate era) (StrictMaybe Coin)
Lens' (PParamsUpdate era) (StrictMaybe Coin)
ppuMinFeeAL ((StrictMaybe Coin -> Identity (StrictMaybe Coin))
 -> PParamsUpdate era -> Identity (PParamsUpdate era))
-> StrictMaybe Coin -> PParamsUpdate era -> PParamsUpdate era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin -> StrictMaybe Coin
forall a. a -> StrictMaybe a
SJust Coin
proposedValue

      -- Submit NewConstitution proposal two epoch too early to check that the action
      -- doesn't expire prematurely (ppGovActionLifetimeL is set to two epochs)
      logString "Submitting new minFee proposal"
      gid <- submitParameterChange SNothing proposedUpdate

      committeeHotCreds <- registerInitialCommittee
      (dRepCred, _, _) <- setupSingleDRep 1_000_000
      (spoC, _, _) <- setupPoolWithStake $ Coin 42_000_000
      passEpoch
      logRatificationChecks gid
      do
        isAccepted <- isDRepAccepted gid
        assertBool "Gov action should not be accepted" $ not isAccepted
      submitYesVote_ (DRepVoter dRepCred) gid
      submitYesVote_ (StakePoolVoter spoC) gid
      submitYesVoteCCs_ committeeHotCreds gid
      logAcceptedRatio gid
      do
        isAccepted <- isDRepAccepted gid
        assertBool "Gov action should be accepted" isAccepted

      passEpoch
      do
        isAccepted <- isDRepAccepted gid
        assertBool "Gov action should be accepted" isAccepted
      logAcceptedRatio gid
      logRatificationChecks gid
      getParamValue `shouldReturn` initialParamValue
      passEpoch
      getParamValue `shouldReturn` proposedValue

treasurySpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
treasurySpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
treasurySpec =
  -- Treasury withdrawal are disallowed during bootstrap,
  -- so we can run tests that submit such proposal only post-bootstrap.
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Treasury" (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
"TreasuryWithdrawal" (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
      [GovAction era] -> ImpTestM era ()
forall era.
(HasCallStack, ConwayEraImp era) =>
[GovAction era] -> ImpTestM era ()
treasuryWithdrawalExpectation []

    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"TreasuryWithdrawalExtra" (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
      rewardAccount <- ImpTestM era RewardAccount
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era RewardAccount
registerRewardAccount
      rewardAccountOther <- registerRewardAccount
      govPolicy <- getGovPolicy
      treasuryWithdrawalExpectation
        [ TreasuryWithdrawals (Map.singleton rewardAccount (Coin 667)) govPolicy
        , TreasuryWithdrawals (Map.singleton rewardAccountOther (Coin 668)) govPolicy
        ]

    String -> ImpTestM era () -> SpecWith (Arg (ImpTestM era ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it
      String
"deposit is moved to treasury when the reward address is not registered"
      ImpTestM era ()
forall era. ConwayEraImp era => ImpTestM era ()
depositMovesToTreasuryWhenStakingAddressUnregisters

treasuryWithdrawalExpectation ::
  forall era.
  (HasCallStack, ConwayEraImp era) =>
  [GovAction era] ->
  ImpTestM era ()
treasuryWithdrawalExpectation :: forall era.
(HasCallStack, ConwayEraImp era) =>
[GovAction era] -> ImpTestM era ()
treasuryWithdrawalExpectation [GovAction era]
extraWithdrawals = do
  ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
  withdrawalAmount <- (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
1_000_000_000)
  -- Before making a withdrawal, we need to make sure there is enough money in the treasury:
  donateToTreasury withdrawalAmount
  committeeHotCreds <- registerInitialCommittee
  (dRepCred, _, _) <- setupSingleDRep 1_000_000
  treasuryStart <- getsNES treasuryL
  treasuryStart `shouldBe` withdrawalAmount
  rewardAccount <- registerRewardAccount
  govPolicy <- getGovPolicy
  (govActionId NE.:| _) <-
    submitGovActions $
      TreasuryWithdrawals (Map.singleton rewardAccount withdrawalAmount) govPolicy
        NE.:| extraWithdrawals
  submitYesVote_ (DRepVoter dRepCred) govActionId
  submitYesVoteCCs_ committeeHotCreds govActionId
  passEpoch -- 1st epoch crossing starts DRep pulser
  impAnn "Withdrawal should not be received yet" $
    getBalance (raCredential rewardAccount) `shouldReturn` mempty
  passEpoch -- 2nd epoch crossing enacts all the ratified actions
  expectMissingGovActionId govActionId
  treasuryEnd <- getsNES treasuryL
  impAnn "Withdrawal deducted from treasury" $
    treasuryStart <-> treasuryEnd `shouldBe` withdrawalAmount
  impAnn "Withdrawal received by reward account" $
    getBalance (raCredential rewardAccount) `shouldReturn` withdrawalAmount

depositMovesToTreasuryWhenStakingAddressUnregisters ::
  ConwayEraImp era => ImpTestM era ()
depositMovesToTreasuryWhenStakingAddressUnregisters :: forall era. ConwayEraImp era => ImpTestM era ()
depositMovesToTreasuryWhenStakingAddressUnregisters = do
  ImpTestM era ()
forall era. ShelleyEraImp era => ImpTestM era ()
disableTreasuryExpansion
  initialTreasury <- 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
  modifyPParams $ \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
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
8
      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
100
      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
0
  returnAddr <- registerRewardAccount
  govActionDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
  keyDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
  govPolicy <- getGovPolicy
  gaid <-
    mkProposalWithRewardAccount
      ( ParameterChange
          SNothing
          (emptyPParamsUpdate & ppuGovActionDepositL .~ SJust (Coin 1000000))
          govPolicy
      )
      returnAddr
      >>= submitProposal
  expectPresentGovActionId gaid
  replicateM_ 5 passEpoch
  expectTreasury initialTreasury
  expectRegisteredRewardAddress returnAddr
  submitTx_ $
    mkBasicTx mkBasicTxBody
      & bodyTxL . certsTxBodyL
        .~ SSeq.singleton
          (UnRegDepositTxCert (raCredential returnAddr) keyDeposit)
  expectNotRegisteredRewardAddress returnAddr
  replicateM_ 5 passEpoch
  expectMissingGovActionId gaid
  expectTreasury $ initialTreasury <> govActionDeposit

eventsSpec ::
  forall era.
  ( ConwayEraImp era
  , Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era
  , Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era
  ) =>
  SpecWith (ImpInit (LedgerSpec era))
eventsSpec :: forall era.
(ConwayEraImp era,
 Event (EraRule "NEWEPOCH" era) ~ ConwayNewEpochEvent era,
 Event (EraRule "EPOCH" era) ~ ConwayEpochEvent era) =>
SpecWith (ImpInit (LedgerSpec era))
eventsSpec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Events" (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
"emits event" (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
"GovInfoEvent" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec 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
      (spoCred, _, _) <- setupPoolWithStake $ Coin 42_000_000

      let actionLifetime = Word32
10
      modifyPParams $ \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
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
actionLifetime
          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
pvtPPSecurityGroupL ((UnitInterval -> Identity UnitInterval)
 -> PParams era -> Identity (PParams era))
-> UnitInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
1 Integer -> Integer -> UnitInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1
      whenPostBootstrap (modifyPParams $ ppDRepVotingThresholdsL . dvtPPEconomicGroupL .~ def)
      propDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppGovActionDepositL
      keyDeposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
      let
        proposeParameterChange = do
          newVal <- Coin -> CoinPerByte
CoinPerByte (Coin -> CoinPerByte)
-> (Integer -> Coin) -> Integer -> CoinPerByte
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Coin
Coin (Integer -> CoinPerByte)
-> ImpM (LedgerSpec era) Integer
-> ImpM (LedgerSpec era) CoinPerByte
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Integer, Integer) -> ImpM (LedgerSpec era) Integer
forall a. Random a => (a, a) -> ImpM (LedgerSpec era) a
forall (g :: * -> *) a. (MonadGen g, Random a) => (a, a) -> g a
choose (Integer
3000, Integer
6500)
          proposal <- submitParameterChange SNothing $ def & ppuCoinsPerUTxOByteL .~ SJust newVal
          pure
            (proposal, getsNES (nesEsL . curPParamsEpochStateL . ppCoinsPerUTxOByteL) `shouldReturn` newVal)
      (proposalA, checkProposedParameterA) <- proposeParameterChange
      (proposalB, _) <- proposeParameterChange
      rewardAccount@(RewardAccount _ rewardCred) <- registerRewardAccount
      passEpoch -- prevent proposalC expiry and force it's deletion due to conflit.
      proposalC <- impAnn "proposalC" $ do
        newVal <- CoinPerByte . Coin <$> choose (3000, 6500)
        paramChange <- mkParameterChangeGovAction SNothing $ (def & ppuCoinsPerUTxOByteL .~ SJust newVal)
        mkProposalWithRewardAccount
          paramChange
          rewardAccount
          >>= submitProposal
      let
        isGovInfoEvent (SomeSTSEvent Event (EraRule rule era)
ev)
          | Just (TickNewEpochEvent (EpochEvent (GovInfoEvent {})) :: ShelleyTickEvent era) <- Event (EraRule rule era) -> Maybe (ShelleyTickEvent era)
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast Event (EraRule rule era)
ev = Bool
True
        isGovInfoEvent SomeSTSEvent era
_ = Bool
False
        passEpochWithNoDroppedActions = do
          (_, evs) <- ImpM (LedgerSpec era) ()
-> ImpM (LedgerSpec era) ((), [SomeSTSEvent era])
forall a.
ImpM (LedgerSpec era) a
-> ImpM (LedgerSpec era) (a, [SomeSTSEvent era])
forall w (m :: * -> *) a. MonadWriter w m => m a -> m (a, w)
listen ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch
          filter isGovInfoEvent evs
            `shouldBeExpr` [ SomeSTSEvent @era @"TICK" . injectEvent $
                               GovInfoEvent mempty mempty mempty mempty
                           ]
      replicateM_ (fromIntegral actionLifetime - 1) passEpochWithNoDroppedActions
      logAcceptedRatio proposalA
      submitYesVote_ (StakePoolVoter spoCred) proposalA
      submitYesVoteCCs_ ccCreds proposalA
      gasA <- getGovActionState proposalA
      gasB <- getGovActionState proposalB
      gasC <- getGovActionState proposalC
      submitTx_ $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ SSeq.singleton (UnRegDepositTxCert rewardCred keyDeposit)
      passEpochWithNoDroppedActions
      (_, evs) <- listen passEpoch
      checkProposedParameterA
      let
        filteredEvs = (SomeSTSEvent era -> Bool)
-> [SomeSTSEvent era] -> [SomeSTSEvent era]
forall a. (a -> Bool) -> [a] -> [a]
filter SomeSTSEvent era -> Bool
isGovInfoEvent [SomeSTSEvent era]
evs
      filteredEvs
        `shouldBeExpr` [ SomeSTSEvent @era @"TICK" . injectEvent $
                           GovInfoEvent
                             (Set.singleton gasA)
                             (Set.singleton gasC)
                             (Set.singleton gasB)
                             (Map.singleton proposalC propDeposit)
                       ]