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

module Test.Cardano.Ledger.Shelley.Imp.EpochSpec (
  spec,
) where

import Cardano.Ledger.BaseTypes (EpochInterval (..), addEpochInterval, epochInfoPure, unNonZero)
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Shelley.API.Forecast (futureForecast, poolDistrForecastL)
import Cardano.Ledger.Shelley.LedgerState (
  esLStateL,
  esSnapshotsL,
  gsSnapShotL,
  lsCertStateL,
  lsUTxOStateL,
  msSnapShotL,
  nesELL,
  nesEsL,
  nesStakePoolDistrG,
  ssSnapShotL,
  ssStakeGoL,
  ssStakeMarkL,
  ssStakeSetL,
  totalObligation,
  utxosDepositedL,
  utxosGovStateL,
 )
import Cardano.Ledger.Slot (epochInfoFirst)
import Cardano.Ledger.State (
  PoolDistr (..),
  SnapShot (..),
  StakePoolSnapShot (..),
 )
import Cardano.Ledger.Val (Val (..))
import Data.Foldable (fold)
import qualified Data.Map.Strict as Map
import qualified Data.VMap as VMap
import Lens.Micro ((^.))
import Lens.Micro.Mtl (use)
import Test.Cardano.Ledger.Imp.Common
import Test.Cardano.Ledger.Shelley.ImpTest

spec ::
  forall era.
  ShelleyEraImp era =>
  SpecWith (ImpInit (LedgerSpec era))
spec :: forall era.
ShelleyEraImp 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
"EPOCH" (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
"Runs basic transaction" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    do
      certState <- SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter (NewEpochState era) (CertState era)
 -> ImpTestM era (CertState era))
-> SimpleGetter (NewEpochState era) (CertState era)
-> ImpTestM era (CertState era)
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))
-> ((CertState era -> Const r (CertState era))
    -> EpochState era -> Const r (EpochState era))
-> (CertState era -> Const r (CertState era))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((CertState era -> Const r (CertState era))
    -> LedgerState era -> Const r (LedgerState era))
-> (CertState era -> Const r (CertState era))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL
      govState <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL
      totalObligation certState govState `shouldBe` zero
    do
      deposited <- 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
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Coin -> Const r Coin)
    -> LedgerState era -> Const r (LedgerState era))
-> (Coin -> Const r Coin)
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTxOState era -> Const r (UTxOState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(UTxOState era -> f (UTxOState era))
-> LedgerState era -> f (LedgerState era)
lsUTxOStateL ((UTxOState era -> Const r (UTxOState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Coin -> Const r Coin)
    -> UTxOState era -> Const r (UTxOState era))
-> (Coin -> Const r Coin)
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const r Coin) -> UTxOState era -> Const r (UTxOState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> UTxOState era -> f (UTxOState era)
utxosDepositedL
      deposited `shouldBe` zero
    String -> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
String -> Tx TopTx era -> ImpTestM era ()
submitTxAnn_ String
"simple transaction" (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> Tx TopTx era -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ TxBody TopTx era -> Tx TopTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody TopTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
    ImpM (LedgerSpec era) ()
forall era. (ShelleyEraImp era, HasCallStack) => ImpTestM era ()
passEpoch

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Crosses epoch boundaries" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    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
    Positive n <- arbitrary
    passNEpochs $ fromIntegral n
    getsNES nesELL `shouldReturn` addEpochInterval startEpochNo (EpochInterval n)

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Forecast across the epoch boundary agrees with 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
    -- Delegate stake to a fresh pool and cross a boundary, so that the mark snapshot holds that
    -- stake while the set snapshot does not
    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
    markSnapShot <- getsNES $ nesEsL . esSnapshotsL . ssStakeMarkL . msSnapShotL
    setSnapShot <- getsNES $ nesEsL . esSnapshotsL . ssStakeSetL . ssSnapShotL
    markSnapShot `shouldNotBe` setSnapShot

    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))
        forecastPoolDistr = Globals -> SlotNo -> NewEpochState era -> Forecast Future era
forall era.
EraForecast era =>
Globals -> SlotNo -> NewEpochState era -> Forecast Future era
futureForecast Globals
globals SlotNo
nextEpochFirstSlot NewEpochState era
nes Forecast Future era
-> Getting PoolDistr (Forecast Future era) PoolDistr -> PoolDistr
forall s a. s -> Getting a s a -> a
^. Getting PoolDistr (Forecast Future era) PoolDistr
forall era (t :: Timeline).
EraForecast era =>
Lens' (Forecast t era) PoolDistr
forall (t :: Timeline). Lens' (Forecast t era) PoolDistr
poolDistrForecastL
    forecastPoolDistr `shouldNotBe` (nes ^. nesStakePoolDistrG)

    passEpoch
    getsNES nesStakePoolDistrG `shouldReturn` forecastPoolDistr

  String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Genesis staking seeds the mark, set and go snapshots" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
    poolStake <- Int -> ImpTestM era (Map (KeyHash StakePool) Coin)
forall era.
ShelleyEraImp era =>
Int -> ImpTestM era (Map (KeyHash StakePool) Coin)
injectFreshGenesisStakePools Int
3
    snapShots <- getsNES $ nesEsL . esSnapshotsL
    let markSnapShot = SnapShots era
snapShots SnapShots era
-> Getting SnapShot (SnapShots era) SnapShot -> SnapShot
forall s a. s -> Getting a s a -> a
^. (MarkSnapShot -> Const SnapShot MarkSnapShot)
-> SnapShots era -> Const SnapShot (SnapShots era)
forall era (f :: * -> *).
Functor f =>
(MarkSnapShot -> f MarkSnapShot)
-> SnapShots era -> f (SnapShots era)
ssStakeMarkL ((MarkSnapShot -> Const SnapShot MarkSnapShot)
 -> SnapShots era -> Const SnapShot (SnapShots era))
-> ((SnapShot -> Const SnapShot SnapShot)
    -> MarkSnapShot -> Const SnapShot MarkSnapShot)
-> Getting SnapShot (SnapShots era) SnapShot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapShot -> Const SnapShot SnapShot)
-> MarkSnapShot -> Const SnapShot MarkSnapShot
Lens' MarkSnapShot SnapShot
msSnapShotL
    -- SNAP rotates the snapshots, but at genesis there is nothing to rotate yet, so all of
    -- them are seeded with the same stake distribution
    snapShots ^. ssStakeSetL . ssSnapShotL `shouldBe` markSnapShot
    snapShots ^. ssStakeGoL . gsSnapShotL `shouldBe` markSnapShot
    -- the total active stake agrees with the sum of the delegated stake pools (#5788)
    fromCompact . spssStake
      <$> VMap.toMap (ssStakePoolsSnapShot markSnapShot)
        `shouldBe` poolStake
    unNonZero (ssTotalActiveStake markSnapShot) `shouldBe` fold poolStake
    -- every genesis pool is in the stake distribution that leader election uses right away
    poolDistr <- getsNES nesStakePoolDistrG
    Map.keysSet (unPoolDistr poolDistr) `shouldBe` Map.keysSet poolStake