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

module Test.Cardano.Ledger.Dijkstra.Imp.SnapSpec (spec) where

import Cardano.Ledger.BaseTypes (
  EpochInterval (..),
  EpochNo (..),
  EpochSize (..),
  Globals (..),
  epochInfoPure,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Dijkstra (DijkstraEraForecast (..))
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.PParams (ppLeiosCommitteeSizeL)
import Cardano.Ledger.Dijkstra.Rules (maxKeyAgeEpochs)
import Cardano.Ledger.Shelley.API.Forecast (futureForecast)
import Cardano.Ledger.Shelley.LedgerState (NewEpochState, esSnapshotsL, nesELL, nesEsL)
import Cardano.Ledger.Slot (epochInfoFirst)
import Cardano.Ledger.State (
  LeiosCommittee,
  MarkSnapShot (..),
  ssLeiosCommitteeL,
  ssStakeMarkL,
  ssStakeSetL,
 )
import Cardano.Ledger.Val ((<->))
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (mkSlotLength)
import Control.Monad (forM)
import Lens.Micro (Lens', to, (&), (.~), (^.))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Conway.Imp.SnapSpec (
  getActiveProposalDeposits,
  getDRepVotingStake,
  getLeaderElectionStake,
  getSpoVotingStake,
  isPoolInLeaderDistr,
  isPoolInRewardSnapshot,
  setupCombinedScenario,
  setupExpiredRefundScenario,
  setupReapedPoolScenario,
  setupRetiredPoolInLeaderDistr,
  setupWithdrawalScenario,
 )
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common

spec ::
  forall era.
  DijkstraEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
DijkstraEraImp 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
  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"maxKeyAgeEpochs is 21 epochs for mainnet parameters" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    impGlobals <- Getting Globals (ImpTestState era) Globals
-> ImpM (LedgerSpec era) Globals
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting Globals (ImpTestState era) Globals
forall era (f :: * -> *).
Functor f =>
(Globals -> f Globals) -> ImpTestState era -> f (ImpTestState era)
impGlobalsL :: ImpM (LedgerSpec era) Globals
    -- Use mainnet values for the inputs that are relevant for the calculation
    let mainnetGlobals =
          Globals
impGlobals
            { maxKESEvo = 62
            , slotsPerKESPeriod = 129_600
            , epochInfo = fixedEpochInfo (EpochSize 432_000) (mkSlotLength 1)
            }
    -- 62 * 129600 / 432000 = 18.6, rounded up to 19, plus 2 epochs of activation delay.
    maxKeyAgeEpochs mainnetGlobals (EpochNo 0) `shouldBe` EpochInterval 21

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"TICKF across the epoch boundary seats the same Leios committee as TICK" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    -- committee is large enough to seat every pool, so the fresh pool is guaranteed a seat
    (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
& (Word16 -> Identity Word16)
-> PParams era -> Identity (PParams era)
forall era. DijkstraEraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
ppLeiosCommitteeSizeL ((Word16 -> Identity Word16)
 -> PParams era -> Identity (PParams era))
-> Word16 -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Word16
1_000
    -- register a fresh pool with some stake and cross a boundary, so that the committee memoized
    -- in the mark snapshot differs from the one in the set snapshot
    pool <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
    registerPool pool
    stakingCred <- KeyHashObj <$> freshKeyHash
    _ <- registerStakeCredential stakingCred
    delegateStake stakingCred pool
    paymentKeyHash <- freshKeyHash @Payment
    sendCoinTo_ (mkAddr paymentKeyHash stakingCred) (Coin 1_000_000_000)
    passEpoch
    let setCommitteeL :: Lens' (NewEpochState era) LeiosCommittee
        setCommitteeL = (EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> f (EpochState era))
 -> NewEpochState era -> f (NewEpochState era))
-> ((LeiosCommittee -> f LeiosCommittee)
    -> EpochState era -> f (EpochState era))
-> (LeiosCommittee -> f LeiosCommittee)
-> NewEpochState era
-> f (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapShots era -> f (SnapShots era))
-> EpochState era -> f (EpochState era)
forall era (f :: * -> *).
Functor f =>
(SnapShots era -> f (SnapShots era))
-> EpochState era -> f (EpochState era)
esSnapshotsL ((SnapShots era -> f (SnapShots era))
 -> EpochState era -> f (EpochState era))
-> ((LeiosCommittee -> f LeiosCommittee)
    -> SnapShots era -> f (SnapShots era))
-> (LeiosCommittee -> f LeiosCommittee)
-> EpochState era
-> f (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SetSnapShot -> f SetSnapShot)
-> SnapShots era -> f (SnapShots era)
forall era (f :: * -> *).
Functor f =>
(SetSnapShot -> f SetSnapShot)
-> SnapShots era -> f (SnapShots era)
ssStakeSetL ((SetSnapShot -> f SetSnapShot)
 -> SnapShots era -> f (SnapShots era))
-> ((LeiosCommittee -> f LeiosCommittee)
    -> SetSnapShot -> f SetSnapShot)
-> (LeiosCommittee -> f LeiosCommittee)
-> SnapShots era
-> f (SnapShots era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LeiosCommittee -> f LeiosCommittee)
-> SetSnapShot -> f SetSnapShot
Lens' SetSnapShot LeiosCommittee
ssLeiosCommitteeL
    markCommittee <- getsNES $ nesEsL . esSnapshotsL . ssStakeMarkL . to msLeiosCommittee
    getsNES setCommitteeL `shouldNotReturn` markCommittee

    globals <- use impGlobalsL
    nes <- getsNES id
    -- the first slot of the next epoch, where TICKF crosses the boundary
    let nextEpochFirstSlot = HasCallStack => EpochInfo Identity -> EpochNo -> SlotNo
EpochInfo Identity -> EpochNo -> SlotNo
epochInfoFirst (Globals -> EpochInfo Identity
epochInfoPure Globals
globals) (EpochNo -> EpochNo
forall a. Enum a => a -> a
succ (NewEpochState era
nes NewEpochState era
-> Getting EpochNo (NewEpochState era) EpochNo -> EpochNo
forall s a. s -> Getting a s a -> a
^. Getting EpochNo (NewEpochState era) EpochNo
forall era (f :: * -> *).
Functor f =>
(EpochNo -> f EpochNo)
-> NewEpochState era -> f (NewEpochState era)
nesELL))
    ticked <- runImpRule @"TICKF" () nes nextEpochFirstSlot
    -- TICKF rotates the mark snapshot into the set position, carrying its committee along
    (ticked ^. setCommitteeL) `shouldBe` markCommittee
    -- the forecast for that slot exposes the same committee to consensus
    (futureForecast globals nextEpochFirstSlot nes ^. leiosCommitteeForecastL)
      `shouldBe` markCommittee

    passEpoch
    -- TICK performs the same rotation once the next epoch actually starts
    getsNES setCommitteeL `shouldReturn` markCommittee

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPO voting stake no longer 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
    (pool, drep, _) <- ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupExpiredRefundScenario
    drepVotingStake <- getDRepVotingStake drep
    spoVotingStake <- getSpoVotingStake pool
    (drepVotingStake <-> spoVotingStake) `shouldBe` mempty
    activeProposalDeposits <- getActiveProposalDeposits pool
    passEpoch
    leaderElectionStake <- getLeaderElectionStake pool
    (spoVotingStake <-> leaderElectionStake) `shouldBe` activeProposalDeposits

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPO voting stake no longer lags DRep voting stake by a reaped pool's 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
    (poolActive, drep, _) <- ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupReapedPoolScenario
    drepVotingStake <- getDRepVotingStake drep
    spoVotingStake <- getSpoVotingStake poolActive
    (drepVotingStake <-> spoVotingStake) `shouldBe` mempty
    activeProposalDeposits <- getActiveProposalDeposits poolActive
    passEpoch
    leaderElectionStake <- getLeaderElectionStake poolActive
    (spoVotingStake <-> leaderElectionStake) `shouldBe` activeProposalDeposits

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPO voting stake no longer lags DRep voting stake by an enacted treasury withdrawal" (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
      (pool, drep, _) <- ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupWithdrawalScenario
      drepVotingStake <- getDRepVotingStake drep
      spoVotingStake <- getSpoVotingStake pool
      (drepVotingStake <-> spoVotingStake) `shouldBe` mempty
      activeProposalDeposits <- getActiveProposalDeposits pool
      passEpoch
      leaderElectionStake <- getLeaderElectionStake pool
      (spoVotingStake <-> leaderElectionStake) `shouldBe` activeProposalDeposits

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPO voting stake no longer lags DRep voting stake by the combined refunds and withdrawal" (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
      (poolActive, drep, _) <- ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
forall era.
ConwayEraImp era =>
ImpTestM era (KeyHash StakePool, Credential DRepRole, Coin)
setupCombinedScenario
      drepVotingStake <- getDRepVotingStake drep
      spoVotingStake <- getSpoVotingStake poolActive
      (drepVotingStake <-> spoVotingStake) `shouldBe` mempty
      activeProposalDeposits <- getActiveProposalDeposits poolActive
      passEpoch
      leaderElectionStake <- getLeaderElectionStake poolActive
      (spoVotingStake <-> leaderElectionStake) `shouldBe` activeProposalDeposits

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A reaped pool leaves the leader-election distribution one epoch earlier" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    pool <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall era. ConwayEraImp era => ImpTestM era (KeyHash StakePool)
setupRetiredPoolInLeaderDistr
    passEpoch
    isPoolInLeaderDistr pool `shouldReturn` False

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"A reaped pool leaves the reward stake snapshot one epoch earlier" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    pool <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall era. ConwayEraImp era => ImpTestM era (KeyHash StakePool)
setupRetiredPoolInLeaderDistr
    isPoolInRewardSnapshot pool `shouldReturn` True
    passNEpochs 2
    isPoolInRewardSnapshot pool `shouldReturn` False

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"SPO and DRep voting stake agree for every shared delegator" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    pairs <- [Integer]
-> (Integer
    -> ImpM (LedgerSpec era) (KeyHash StakePool, Credential DRepRole))
-> ImpM (LedgerSpec era) [(KeyHash StakePool, Credential DRepRole)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Integer
1 .. Integer
4 :: Integer] ((Integer
  -> ImpM (LedgerSpec era) (KeyHash StakePool, Credential DRepRole))
 -> ImpM
      (LedgerSpec era) [(KeyHash StakePool, Credential DRepRole)])
-> (Integer
    -> ImpM (LedgerSpec era) (KeyHash StakePool, Credential DRepRole))
-> ImpM (LedgerSpec era) [(KeyHash StakePool, Credential DRepRole)]
forall a b. (a -> b) -> a -> b
$ \Integer
i -> do
      (drep, cred, _) <- Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
forall era.
ConwayEraImp era =>
Integer
-> ImpTestM
     era (Credential DRepRole, Credential Staking, KeyPair Payment)
setupSingleDRep (Integer
i Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
100_000_000)
      pool <- freshKeyHash
      registerPool pool
      delegateStake cred pool
      pure (pool, drep)
    passNEpochs 2
    forM_ pairs $ \(KeyHash StakePool
pool, Credential DRepRole
drep) -> do
      spoVotingStake <- KeyHash StakePool -> ImpTestM era Coin
forall era.
ConwayEraImp era =>
KeyHash StakePool -> ImpTestM era Coin
getSpoVotingStake KeyHash StakePool
pool
      drepVotingStake <- getDRepVotingStake drep
      spoVotingStake `shouldBe` drepVotingStake