{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Test.Cardano.Ledger.Conway.Imp.SnapSpec (spec, conwayOnlySpec) where

import Cardano.Ledger.BaseTypes (EpochInterval (..))
import Cardano.Ledger.Coin
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Governance
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Val ((<->))
import qualified Data.Map.Strict as Map
import Lens.Micro ((&), (.~))
import Test.Cardano.Ledger.Conway.ImpTest
import Test.Cardano.Ledger.Imp.Common

spec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
spec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SNAP" (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 getSpoVotingStake :: KeyHash StakePool -> ImpTestM era Coin
      getSpoVotingStake :: KeyHash StakePool -> ImpTestM era Coin
getSpoVotingStake KeyHash StakePool
pool = do
        poolDistr <- PulsingSnapshot era -> Map (KeyHash StakePool) (CompactForm Coin)
forall era.
PulsingSnapshot era -> Map (KeyHash StakePool) (CompactForm Coin)
psPoolDistr (PulsingSnapshot era -> Map (KeyHash StakePool) (CompactForm Coin))
-> (DRepPulsingState era -> PulsingSnapshot era)
-> DRepPulsingState era
-> Map (KeyHash StakePool) (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PulsingSnapshot era, RatifyState era) -> PulsingSnapshot era
forall a b. (a, b) -> a
fst ((PulsingSnapshot era, RatifyState era) -> PulsingSnapshot era)
-> (DRepPulsingState era -> (PulsingSnapshot era, RatifyState era))
-> DRepPulsingState era
-> PulsingSnapshot era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
forall era.
(EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser (DRepPulsingState era
 -> Map (KeyHash StakePool) (CompactForm Coin))
-> ImpM (LedgerSpec era) (DRepPulsingState era)
-> ImpM
     (LedgerSpec era) (Map (KeyHash StakePool) (CompactForm Coin))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) (DRepPulsingState era)
-> ImpM (LedgerSpec era) (DRepPulsingState era)
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))
-> ((DRepPulsingState era -> Const r (DRepPulsingState era))
    -> EpochState era -> Const r (EpochState era))
-> (DRepPulsingState era -> Const r (DRepPulsingState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DRepPulsingState era -> Const r (DRepPulsingState era))
-> EpochState era -> Const r (EpochState era)
forall era.
ConwayEraGov era =>
Lens' (EpochState era) (DRepPulsingState era)
Lens' (EpochState era) (DRepPulsingState era)
epochStateDRepPulsingStateL)
        pure $ fromCompact $ poolDistr Map.! pool
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPO voting stake exceeds leader election stake by the active proposal deposit" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \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
10
        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, HasCallStack) =>
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
    govActionDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((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.
(ConwayEraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL

    (pool, _paymentCred, stakingCred) <- setupPoolWithStake (Coin 500_000_000)
    returnAddr <- getAccountAddressFor stakingCred
    _govActionId <- submitProposal =<< mkProposalWithAccountAddress InfoAction returnAddr

    passEpoch
    spoVotingStakeThisEpoch <- getSpoVotingStake pool
    passEpoch
    leaderElectionStakeNextEpoch <-
      fromCompact . individualTotalPoolStake . (Map.! pool) . unPoolDistr <$> getsNES nesPdL
    (spoVotingStakeThisEpoch <-> leaderElectionStakeNextEpoch) `shouldBe` govActionDeposit

conwayOnlySpec ::
  forall era.
  ConwayEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
conwayOnlySpec :: forall era. ConwayEraImp era => SpecWith (ImpInit (LedgerSpec era))
conwayOnlySpec = String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"SNAP" (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 getSpoVotingStake :: KeyHash StakePool -> ImpTestM era Coin
      getSpoVotingStake :: KeyHash StakePool -> ImpTestM era Coin
getSpoVotingStake KeyHash StakePool
pool = do
        poolDistr <- PulsingSnapshot era -> Map (KeyHash StakePool) (CompactForm Coin)
forall era.
PulsingSnapshot era -> Map (KeyHash StakePool) (CompactForm Coin)
psPoolDistr (PulsingSnapshot era -> Map (KeyHash StakePool) (CompactForm Coin))
-> (DRepPulsingState era -> PulsingSnapshot era)
-> DRepPulsingState era
-> Map (KeyHash StakePool) (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PulsingSnapshot era, RatifyState era) -> PulsingSnapshot era
forall a b. (a, b) -> a
fst ((PulsingSnapshot era, RatifyState era) -> PulsingSnapshot era)
-> (DRepPulsingState era -> (PulsingSnapshot era, RatifyState era))
-> DRepPulsingState era
-> PulsingSnapshot era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
forall era.
(EraStake era, ConwayEraAccounts era) =>
DRepPulsingState era -> (PulsingSnapshot era, RatifyState era)
finishDRepPulser (DRepPulsingState era
 -> Map (KeyHash StakePool) (CompactForm Coin))
-> ImpM (LedgerSpec era) (DRepPulsingState era)
-> ImpM
     (LedgerSpec era) (Map (KeyHash StakePool) (CompactForm Coin))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) (DRepPulsingState era)
-> ImpM (LedgerSpec era) (DRepPulsingState era)
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))
-> ((DRepPulsingState era -> Const r (DRepPulsingState era))
    -> EpochState era -> Const r (EpochState era))
-> (DRepPulsingState era -> Const r (DRepPulsingState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DRepPulsingState era -> Const r (DRepPulsingState era))
-> EpochState era -> Const r (EpochState era)
forall era.
ConwayEraGov era =>
Lens' (EpochState era) (DRepPulsingState era)
Lens' (EpochState era) (DRepPulsingState era)
epochStateDRepPulsingStateL)
        pure $ fromCompact $ poolDistr Map.! pool
      getDRepVotingStake :: Credential DRepRole -> ImpTestM era Coin
      getDRepVotingStake :: Credential DRepRole -> ImpTestM era Coin
getDRepVotingStake Credential DRepRole
drep = do
        drepDistr <- SimpleGetter (NewEpochState era) (Map DRep (CompactForm Coin))
-> ImpTestM era (Map DRep (CompactForm Coin))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (Map DRep (CompactForm Coin))
 -> ImpTestM era (Map DRep (CompactForm Coin)))
-> SimpleGetter (NewEpochState era) (Map DRep (CompactForm Coin))
-> ImpTestM era (Map DRep (CompactForm Coin))
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Map DRep (CompactForm Coin)
     -> Const r (Map DRep (CompactForm Coin)))
    -> EpochState era -> Const r (EpochState era))
-> (Map DRep (CompactForm Coin)
    -> Const r (Map DRep (CompactForm Coin)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DRepPulsingState era -> Const r (DRepPulsingState era))
-> EpochState era -> Const r (EpochState era)
forall era.
ConwayEraGov era =>
Lens' (EpochState era) (DRepPulsingState era)
Lens' (EpochState era) (DRepPulsingState era)
epochStateDRepPulsingStateL ((DRepPulsingState era -> Const r (DRepPulsingState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map DRep (CompactForm Coin)
     -> Const r (Map DRep (CompactForm Coin)))
    -> DRepPulsingState era -> Const r (DRepPulsingState era))
-> (Map DRep (CompactForm Coin)
    -> Const r (Map DRep (CompactForm Coin)))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map DRep (CompactForm Coin)
 -> Const r (Map DRep (CompactForm Coin)))
-> DRepPulsingState era -> Const r (DRepPulsingState era)
forall era.
(EraStake era, ConwayEraAccounts era) =>
SimpleGetter (DRepPulsingState era) (Map DRep (CompactForm Coin))
SimpleGetter (DRepPulsingState era) (Map DRep (CompactForm Coin))
psDRepDistrG
        pure $ fromCompact $ drepDistr Map.! DRepCredential drep
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Reproduces #5014: SPO voting stake lags DRep voting stake by the refunded deposit" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall era.
ShelleyEraImp era =>
(PParams era -> PParams era) -> ImpTestM era ()
modifyPParams ((PParams era -> PParams era) -> ImpM (LedgerSpec era) ())
-> (PParams era -> PParams era) -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ \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, HasCallStack) =>
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
    govActionDeposit <- SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin)
-> SimpleGetter (NewEpochState era) Coin -> ImpTestM era Coin
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((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.
(ConwayEraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppGovActionDepositL

    (drep, cred, _) <- setupSingleDRep 500_000_000
    pool <- freshKeyHash
    registerPool pool
    delegateStake cred pool
    returnAddr <- getAccountAddressFor cred

    govActionId <- submitProposal =<< mkProposalWithAccountAddress InfoAction returnAddr
    expectPresentGovActionId govActionId
    passNEpochs 3
    expectMissingGovActionId govActionId

    drepVotingStake <- getDRepVotingStake drep
    spoVotingStake <- getSpoVotingStake pool
    impAnn "SPO voting stake is behind by the refunded deposit" $
      (drepVotingStake <-> spoVotingStake) `shouldBe` govActionDeposit

    passEpoch
    spoVotingStakeNextEpoch <- getSpoVotingStake pool
    drepVotingStakeNextEpoch <- getDRepVotingStake drep
    impAnn "SPO voting stake catches up in the next epoch" $
      spoVotingStakeNextEpoch `shouldBe` drepVotingStakeNextEpoch