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

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

import Cardano.Ledger.BaseTypes (EpochInterval (..), EpochNo (..), EpochSize (..), Globals (..))
import Cardano.Ledger.Dijkstra.Rules (maxKeyAgeEpochs)
import Cardano.Ledger.Val ((<->))
import Cardano.Slotting.EpochInfo (fixedEpochInfo)
import Cardano.Slotting.Time (mkSlotLength)
import Control.Monad (forM)
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
"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 <- ImpTestM 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 <- ImpTestM 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