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

module Test.Cardano.Ledger.Dijkstra.Imp.PoolSpec (spec, dijkstraOnlySpec) where

import Cardano.Ledger.Alonzo
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Dijkstra
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.PParams (ppMaxPledgeLeverageL)
import Cardano.Ledger.Dijkstra.Rules
import Cardano.Ledger.Genesis
import Cardano.Ledger.Shelley
import Cardano.Ledger.Shelley.Genesis
import Cardano.Ledger.Shelley.LedgerState
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.Shelley.Transition
import Cardano.Ledger.State
import Control.Monad.IO.Class
import Data.Coerce (coerce)
import Data.Foldable (fold)
import qualified Data.ListMap as ListMap
import qualified Data.Map.Strict as Map
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Word
import Lens.Micro ((%~), (&), (.~))
import qualified System.FS.Sim.MockFS as MockFS
import System.FS.Sim.STM
import Test.Cardano.Ledger.Core.Rational ((%!))
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common

-- | Slightly less than half of the total supply, leaving the rest in circulation.
reserves :: Coin
reserves :: Coin
reserves = Integer -> Coin
Coin Integer
20_000_000_000_000_000

ownerStake :: Coin
ownerStake :: Coin
ownerStake = Integer -> Coin
Coin Integer
10_000_000_000_000

delegatorStake :: Coin
delegatorStake :: Coin
delegatorStake = Integer -> Coin
Coin Integer
90_000_000_000_000

registerPoolWithPledge ::
  DijkstraEraImp era =>
  Coin ->
  ImpTestM era (KeyHash StakePool, [Credential Staking])
registerPoolWithPledge :: forall era.
DijkstraEraImp era =>
Coin -> ImpTestM era (KeyHash StakePool, [Credential Staking])
registerPoolWithPledge Coin
pledge = do
  poolId <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
  ownerKeyHash <- freshKeyHash
  delegatorKeyHash <- freshKeyHash
  let owner = KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
ownerKeyHash
      delegator = KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
delegatorKeyHash
  -- Give the stake credentials some stake to delegate.
  ownerPayment <- freshKeyHash @Payment
  delegatorPayment <- freshKeyHash @Payment
  sendCoinTo_ (mkAddr ownerPayment owner) ownerStake
  sendCoinTo_ (mkAddr delegatorPayment delegator) delegatorStake
  -- The pool pays its rewards into the account of its owner.
  ownerAccountAddress <- registerStakeCredential owner
  _ <- registerStakeCredential delegator
  minPoolCost <- getsPParams ppMinPoolCostL
  registerPoolWithParams
    ( \StakePoolParams era
poolParams ->
        StakePoolParams era
poolParams
          { sppPledge = pledge
          , sppOwners = Set.singleton ownerKeyHash
          , sppCost = minPoolCost
          , sppMargin = 0 %! 1
          }
    )
    poolId
    ownerAccountAddress
  delegateStake owner poolId
  delegateStake delegator poolId
  pure (poolId, [owner, delegator])

-- | The total rewards that have been paid out to a stake pool and its delegators.
poolRewards :: (HasCallStack, EraCertState era) => [Credential Staking] -> ImpTestM era Coin
poolRewards :: forall era.
(HasCallStack, EraCertState era) =>
[Credential Staking] -> ImpTestM era Coin
poolRewards = ([Coin] -> Coin)
-> ImpM (LedgerSpec era) [Coin] -> ImpM (LedgerSpec era) Coin
forall a b.
(a -> b) -> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Coin] -> Coin
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (ImpM (LedgerSpec era) [Coin] -> ImpM (LedgerSpec era) Coin)
-> ([Credential Staking] -> ImpM (LedgerSpec era) [Coin])
-> [Credential Staking]
-> ImpM (LedgerSpec era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Credential Staking -> ImpM (LedgerSpec era) Coin)
-> [Credential Staking] -> ImpM (LedgerSpec era) [Coin]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Credential Staking -> ImpM (LedgerSpec era) Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential Staking -> ImpTestM era Coin
getBalance

-- | Register two pools that are identical, except that the second one declares a pledge
-- that is a thousandth of the pledge of the first one, then have both of them mint the
-- same number of blocks, and report the rewards that each of them earned.
--
-- The first pool is well pledged: its pledge is a tenth of its stake, which is exactly
-- the leverage that `maxPledgeLeverage` is set to whenever it is set in this spec.
rewardsOfWellAndOverPledgedPools ::
  DijkstraEraImp era =>
  ImpTestM era (Coin, Coin)
rewardsOfWellAndOverPledgedPools :: forall era. DijkstraEraImp era => ImpTestM era (Coin, Coin)
rewardsOfWellAndOverPledgedPools = do
  -- ImpSpec starts out with the whole supply accounted for in the reserves, while at the
  -- same time holding all of it in the initial UTxO, which leaves nothing in circulation.
  -- Rewards are handed out of the reserves and are proportional to the stake of a pool
  -- relative to the ADA in circulation, so both need to be realistic for a pool to earn a
  -- sensible amount of rewards.
  (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall era.
(NewEpochState era -> NewEpochState era) -> ImpTestM era ()
modifyNES ((NewEpochState era -> NewEpochState era) -> ImpTestM era ())
-> (NewEpochState era -> NewEpochState era) -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Coin -> Identity Coin)
    -> EpochState era -> Identity (EpochState era))
-> (Coin -> Identity Coin)
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ChainAccountState -> Identity ChainAccountState)
-> EpochState era -> Identity (EpochState era)
forall era. Lens' (EpochState era) ChainAccountState
forall (t :: * -> *) era.
CanSetChainAccountState t =>
Lens' (t era) ChainAccountState
chainAccountStateL ((ChainAccountState -> Identity ChainAccountState)
 -> EpochState era -> Identity (EpochState era))
-> ((Coin -> Identity Coin)
    -> ChainAccountState -> Identity ChainAccountState)
-> (Coin -> Identity Coin)
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> ChainAccountState -> Identity ChainAccountState
Lens' ChainAccountState Coin
casReservesL ((Coin -> Identity Coin)
 -> NewEpochState era -> Identity (NewEpochState era))
-> Coin -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Coin
reserves
  wellPledged <- Coin -> ImpTestM era (KeyHash StakePool, [Credential Staking])
forall era.
DijkstraEraImp era =>
Coin -> ImpTestM era (KeyHash StakePool, [Credential Staking])
registerPoolWithPledge Coin
ownerStake
  overLeveraged <- registerPoolWithPledge $ Coin (unCoin ownerStake `div` 1_000)
  -- Pay out the pledges and delegations, then let the stake distribution settle into the
  -- snapshot that the rewards for the epoch after the next one are computed from.
  passNEpochs 2
  -- Both pools mint the same number of blocks, so that they have the same apparent
  -- performance. The transactions also fill up the fee pot that is handed out as rewards.
  replicateM_ 3 $
    forM_ ([fst wellPledged, fst overLeveraged] :: [KeyHash StakePool]) $ \KeyHash StakePool
poolId ->
      KeyHash BlockIssuer -> ImpTestM era () -> ImpTestM era ()
forall era a.
(HasCallStack, ShelleyEraImp era) =>
KeyHash BlockIssuer -> ImpTestM era a -> ImpTestM era ()
withIssuerAndTxsInBlock_ (KeyHash StakePool -> KeyHash BlockIssuer
forall a b. Coercible a b => a -> b
coerce KeyHash StakePool
poolId) (ImpTestM era () -> ImpTestM era ())
-> ImpTestM era () -> ImpTestM era ()
forall a b. (a -> b) -> a -> b
$ do
        addr <- ImpM (LedgerSpec era) Addr
forall s (m :: * -> *) g.
(HasKeyPairs s, MonadState s m, HasStatefulGen g m, MonadGen m) =>
m Addr
freshKeyAddr_
        sendCoinTo_ addr $ Coin 1_000_000_000
  -- Rewards for an epoch are only handed out two epoch boundaries later.
  passNEpochs 3
  (,) <$> poolRewards (snd wellPledged) <*> poolRewards (snd overLeveraged)

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
"POOL" (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
"Register and re-register pools" (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
"re-register a pool with its own future VRF" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      vrfNew <- freshKeyHashVRF
      tx <- registerPoolTx <$> poolParams kh vrfNew
      submitTx_ tx
      expectPool kh (Just vrf)
      expectFuturePool kh (Just vrfNew)
      -- re-registering with the VRF already recorded in the pool's own
      -- future params should succeed
      submitTx_ tx
      expectPool kh (Just vrf)
      expectFuturePool kh (Just vrfNew)
      expectVRFs [(vrf, 1), (vrfNew, 1)]
      passEpoch
      expectPool kh (Just vrfNew)
      expectFuturePool kh Nothing
      expectVRFs [(vrfNew, 1)]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"keep tracking the active VRF after re-registering with it and then with a fresh one" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      -- re-register with the pool's own active VRF ...
      registerPoolTx <$> poolParams kh vrf >>= submitTx_
      expectFuturePool kh (Just vrf)
      expectVRFs [(vrf, 1)]
      -- ... and then with a fresh one
      vrfNew <- freshKeyHashVRF
      registerPoolTx <$> poolParams kh vrfNew >>= submitTx_
      -- the pool keeps producing blocks with the original VRF until the
      -- epoch boundary, so it must still be tracked
      expectPool kh (Just vrf)
      expectFuturePool kh (Just vrfNew)
      expectVRFs [(vrf, 1), (vrfNew, 1)]
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrf >>= \Tx TopTx era
tx ->
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx era
tx (EraRuleFailure "LEDGER" era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
EraRuleFailure "LEDGER" era
-> NonEmpty (EraRuleFailure "LEDGER" era)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EraRuleFailure "LEDGER" era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraPoolPredFailure era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
khNew VRFVerKeyHash StakePoolVRF
vrf)
      passEpoch
      expectPool kh (Just vrfNew)
      expectVRFs [(vrfNew, 1)]
      -- after the epoch boundary the original VRF can be taken over ...
      registerPoolTx <$> poolParams khNew vrf >>= submitTx_
      expectPool khNew (Just vrf)
      expectVRFs [(vrf, 1), (vrfNew, 1)]
      -- ... but only by a single pool
      kh3 <- freshKeyHash
      registerPoolTx <$> poolParams kh3 vrf >>= \Tx TopTx era
tx ->
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx era
tx (EraRuleFailure "LEDGER" era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
EraRuleFailure "LEDGER" era
-> NonEmpty (EraRuleFailure "LEDGER" era)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EraRuleFailure "LEDGER" era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraPoolPredFailure era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
kh3 VRFVerKeyHash StakePoolVRF
vrf)

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a pending future VRF cannot be claimed by another pool" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (kh1, vrf1) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      (kh2, vrf2) <- registerNewPool
      vrfNew <- freshKeyHashVRF
      registerPoolTx <$> poolParams kh1 vrfNew >>= submitTx_
      expectPool kh1 (Just vrf1)
      expectFuturePool kh1 (Just vrfNew)
      expectVRFs [(vrf1, 1), (vrf2, 1), (vrfNew, 1)]
      -- a VRF is taken as soon as a re-registration requests it, so neither a new pool ...
      kh3 <- freshKeyHash
      registerPoolTx <$> poolParams kh3 vrfNew >>= \Tx TopTx era
tx ->
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx era
tx (EraRuleFailure "LEDGER" era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
EraRuleFailure "LEDGER" era
-> NonEmpty (EraRuleFailure "LEDGER" era)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EraRuleFailure "LEDGER" era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraPoolPredFailure era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
kh3 VRFVerKeyHash StakePoolVRF
vrfNew)
      -- ... nor another registered pool may claim it
      registerPoolTx <$> poolParams kh2 vrfNew >>= \Tx TopTx era
tx ->
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx era
tx (EraRuleFailure "LEDGER" era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
EraRuleFailure "LEDGER" era
-> NonEmpty (EraRuleFailure "LEDGER" era)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EraRuleFailure "LEDGER" era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraPoolPredFailure era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
kh2 VRFVerKeyHash StakePoolVRF
vrfNew)
      expectFuturePool kh2 Nothing
      expectVRFs [(vrf1, 1), (vrf2, 1), (vrfNew, 1)]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-registering with the active VRF releases the pending future VRF" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      vrfNew <- freshKeyHashVRF
      registerPoolTx <$> poolParams kh vrfNew >>= submitTx_
      expectVRFs [(vrf, 1), (vrfNew, 1)]
      -- going back to the active VRF frees the previously requested one
      registerPoolTx <$> poolParams kh vrf >>= submitTx_
      expectFuturePool kh (Just vrf)
      expectVRFs [(vrf, 1)]
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrfNew >>= submitTx_
      expectPool khNew (Just vrfNew)
      expectVRFs [(vrf, 1), (vrfNew, 1)]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"oscillating between the active and a fresh VRF within an epoch keeps the active one taken" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      (kh, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      vrfNew <- freshKeyHashVRF
      -- switch to a fresh VRF, back to the active one and to the fresh one again
      registerPoolTx <$> poolParams kh vrfNew >>= submitTx_
      expectVRFs [(vrf, 1), (vrfNew, 1)]
      registerPoolTx <$> poolParams kh vrf >>= submitTx_
      expectVRFs [(vrf, 1)]
      registerPoolTx <$> poolParams kh vrfNew >>= submitTx_
      expectPool kh (Just vrf)
      expectFuturePool kh (Just vrfNew)
      -- the active VRF stays in use until the epoch boundary, so it must stay taken
      expectVRFs [(vrf, 1), (vrfNew, 1)]
      khNew <- freshKeyHash
      registerPoolTx <$> poolParams khNew vrf >>= \Tx TopTx era
tx ->
        Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx era
tx (EraRuleFailure "LEDGER" era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
EraRuleFailure "LEDGER" era
-> NonEmpty (EraRuleFailure "LEDGER" era)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EraRuleFailure "LEDGER" era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraPoolPredFailure era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
khNew VRFVerKeyHash StakePoolVRF
vrf)
      passEpoch
      expectPool kh (Just vrfNew)
      expectVRFs [(vrfNew, 1)]
      registerPoolTx <$> poolParams khNew vrf >>= submitTx_
      expectVRFs [(vrf, 1), (vrfNew, 1)]

    String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"a VRF shared by two pools" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      -- GHC 9.14 requires the type signatures of these helpers: without them, type checking
      -- this module does not finish and the build times out.
      let registerTwoPoolsSharingVRF ::
            ImpTestM era (KeyHash StakePool, KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
          registerTwoPoolsSharingVRF :: ImpTestM
  era
  (KeyHash StakePool, KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerTwoPoolsSharingVRF = do
            (kh1, vrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
            kh2 <- registerPoolSharingVRF vrf
            expectVRFs [(vrf, 2)]
            pure (kh1, kh2, vrf)
          switchToFreshVRF :: KeyHash StakePool -> ImpTestM era (VRFVerKeyHash StakePoolVRF)
          switchToFreshVRF :: KeyHash StakePool -> ImpTestM era (VRFVerKeyHash StakePoolVRF)
switchToFreshVRF KeyHash StakePool
kh = do
            vrfNew <- ImpTestM era (VRFVerKeyHash StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
            registerPoolTx <$> poolParams kh vrfNew >>= submitTx_
            pure vrfNew
          expectTaken :: VRFVerKeyHash StakePoolVRF -> ImpTestM era ()
          expectTaken :: VRFVerKeyHash StakePoolVRF -> ImpM (LedgerSpec era) ()
expectTaken VRFVerKeyHash StakePoolVRF
vrf = do
            kh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            registerPoolTx <$> poolParams kh vrf >>= \Tx TopTx era
tx ->
              Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx era
tx (EraRuleFailure "LEDGER" era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
EraRuleFailure "LEDGER" era
-> NonEmpty (EraRuleFailure "LEDGER" era)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EraRuleFailure "LEDGER" era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraPoolPredFailure era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
kh VRFVerKeyHash StakePoolVRF
vrf)
          -- The shared VRF has been released: only the given counts are left, and another
          -- pool can register with it.
          expectReleased ::
            VRFVerKeyHash StakePoolVRF -> [(VRFVerKeyHash StakePoolVRF, Word64)] -> ImpTestM era ()
          expectReleased :: VRFVerKeyHash StakePoolVRF
-> [(VRFVerKeyHash StakePoolVRF, Word64)]
-> ImpM (LedgerSpec era) ()
expectReleased VRFVerKeyHash StakePoolVRF
vrf [(VRFVerKeyHash StakePoolVRF, Word64)]
vrfs = do
            [(VRFVerKeyHash StakePoolVRF, Word64)] -> ImpM (LedgerSpec era) ()
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraCertState era) =>
[(VRFVerKeyHash StakePoolVRF, Word64)] -> ImpM (LedgerSpec era) ()
expectVRFs [(VRFVerKeyHash StakePoolVRF, Word64)]
vrfs
            kh <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
            registerPoolTx <$> poolParams kh vrf >>= submitTx_
            expectPool kh (Just vrf)
            expectVRFs $ (vrf, 1) : vrfs

      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"cannot be kept by a holder that re-registers" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (kh1, _, vrf) <- ImpTestM
  era
  (KeyHash StakePool, KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerTwoPoolsSharingVRF
        -- neither pool may keep the shared VRF when re-registering ...
        registerPoolTx <$> poolParams kh1 vrf >>= \Tx TopTx era
tx ->
          Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
-> ImpTestM era ()
submitFailingTx Tx TopTx era
tx (EraRuleFailure "LEDGER" era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
EraRuleFailure "LEDGER" era
-> NonEmpty (EraRuleFailure "LEDGER" era)
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EraRuleFailure "LEDGER" era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> (DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era)
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DijkstraPoolPredFailure era -> EraRuleFailure "LEDGER" era
forall (rule :: Symbol) (t :: * -> *) era.
InjectRuleFailure rule t era =>
t era -> EraRuleFailure rule era
injectFailure (DijkstraPoolPredFailure era
 -> NonEmpty (PredicateFailure (EraRule "LEDGER" era)))
-> DijkstraPoolPredFailure era
-> NonEmpty (PredicateFailure (EraRule "LEDGER" era))
forall a b. (a -> b) -> a -> b
$ KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
forall era.
KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> DijkstraPoolPredFailure era
VRFKeyHashAlreadyRegistered KeyHash StakePool
kh1 VRFVerKeyHash StakePoolVRF
vrf)
        -- ... but either may switch to a fresh one
        vrfNew <- switchToFreshVRF kh1
        expectFuturePool kh1 (Just vrfNew)
        expectVRFs [(vrf, 2), (vrfNew, 1)]
        -- and the shared VRF stays taken while any pool still uses it
        expectTaken vrf

      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"stays taken across the epoch boundary when one holder moves away" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        -- When one holder switches to a fresh VRF, the other pool's reference to the
        -- shared VRF must survive the epoch boundary.
        (kh1, kh2, vrf) <- ImpTestM
  era
  (KeyHash StakePool, KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerTwoPoolsSharingVRF
        vrfNew1 <- switchToFreshVRF kh1
        expectVRFs [(vrf, 2), (vrfNew1, 1)]
        passEpoch
        expectPool kh1 (Just vrfNew1)
        expectVRFs [(vrf, 1), (vrfNew1, 1)]
        -- the VRF is still in use by the other pool, so it cannot be claimed
        expectTaken vrf
        -- it only becomes available once the last holder moves away as well
        vrfNew2 <- switchToFreshVRF kh2
        passEpoch
        expectReleased vrf [(vrfNew1, 1), (vrfNew2, 1)]

      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"is released once both holders move away in the same epoch" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (kh1, kh2, vrf) <- ImpTestM
  era
  (KeyHash StakePool, KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerTwoPoolsSharingVRF
        vrfNew1 <- switchToFreshVRF kh1
        vrfNew2 <- switchToFreshVRF kh2
        expectVRFs [(vrf, 2), (vrfNew1, 1), (vrfNew2, 1)]
        passEpoch
        expectPool kh1 (Just vrfNew1)
        expectPool kh2 (Just vrfNew2)
        -- no pool holds the shared VRF any more, so it is up for grabs again
        expectReleased vrf [(vrfNew1, 1), (vrfNew2, 1)]

      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"is released once both holders have retired" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (kh1, kh2, vrf) <- ImpTestM
  era
  (KeyHash StakePool, KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerTwoPoolsSharingVRF
        -- retiring one of the two pools leaves the VRF in use by the other one ...
        retirePoolTx kh1 (EpochInterval 1) >>= submitTx_
        passEpoch
        expectPool kh1 Nothing
        expectPool kh2 (Just vrf)
        expectVRFs [(vrf, 1)]
        expectTaken vrf
        -- ... and only once that one has retired as well does the VRF become available
        retirePoolTx kh2 (EpochInterval 1) >>= submitTx_
        passEpoch
        expectPool kh2 Nothing
        expectReleased vrf []

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"maxPledgeLeverage" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    -- The pledge influence factor also rewards a pool for pledging more, which would
    -- make the two pools below earn different rewards for a reason that has nothing to
    -- do with the pledge leverage. Setting it to zero isolates the leverage cap.
    let withoutPledgeInfluence :: ImpM (LedgerSpec era) ()
withoutPledgeInfluence = (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
& (NonNegativeInterval -> Identity NonNegativeInterval)
-> PParams era -> Identity (PParams era)
forall era.
EraPParams era =>
Lens' (PParams era) NonNegativeInterval
Lens' (PParams era) NonNegativeInterval
ppA0L ((NonNegativeInterval -> Identity NonNegativeInterval)
 -> PParams era -> Identity (PParams era))
-> NonNegativeInterval -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer
0 Integer -> Integer -> NonNegativeInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"is not enforced when it is not set" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ImpM (LedgerSpec era) ()
withoutPledgeInfluence
      (wellPledgedRewards, overLeveragedRewards) <- ImpTestM era (Coin, Coin)
forall era. DijkstraEraImp era => ImpTestM era (Coin, Coin)
rewardsOfWellAndOverPledgedPools
      wellPledgedRewards `shouldSatisfy` (> Coin 0)
      overLeveragedRewards `shouldBe` wellPledgedRewards

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"lowers the rewards of a pool that is leveraged beyond it" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      ImpM (LedgerSpec era) ()
withoutPledgeInfluence
      (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
& (MaxPledgeLeverage -> Identity MaxPledgeLeverage)
-> PParams era -> Identity (PParams era)
forall era.
DijkstraEraPParams era =>
Lens' (PParams era) MaxPledgeLeverage
Lens' (PParams era) MaxPledgeLeverage
ppMaxPledgeLeverageL ((MaxPledgeLeverage -> Identity MaxPledgeLeverage)
 -> PParams era -> Identity (PParams era))
-> MaxPledgeLeverage -> PParams era -> PParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe NonNegativeInterval -> MaxPledgeLeverage
MaxPledgeLeverage (NonNegativeInterval -> StrictMaybe NonNegativeInterval
forall a. a -> StrictMaybe a
SJust (Integer
10 Integer -> Integer -> NonNegativeInterval
forall r. (IsRatio r, HasCallStack) => Integer -> Integer -> r
%! Integer
1))
      (wellPledgedRewards, overLeveragedRewards) <- ImpTestM era (Coin, Coin)
forall era. DijkstraEraImp era => ImpTestM era (Coin, Coin)
rewardsOfWellAndOverPledgedPools
      -- The leverage of the well pledged pool is exactly the maximum, so it is rewarded
      -- for all of its stake, just like it would have been without the cap.
      wellPledgedRewards `shouldSatisfy` (> Coin 0)
      -- The over-leveraged pool is only rewarded for ten times its pledge, which is a
      -- thousandth of the stake it actually has, so it earns roughly a thousandth of what
      -- the well pledged pool earns. It is not cut off from the rewards entirely.
      overLeveragedRewards `shouldSatisfy` (> Coin 0)
      Coin (100 * unCoin overLeveragedRewards) `shouldSatisfy` (< wellPledgedRewards)

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"BLS PoolReg" (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
      mkPoolRegTxFromParams :: StakePoolParams era -> Tx l era
mkPoolRegTxFromParams StakePoolParams era
pps =
        TxBody l era -> Tx l era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody l era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
          Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx l era -> Identity (Tx l era))
-> StrictSeq (TxCert era) -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxCert era -> StrictSeq (TxCert era)
forall a. a -> StrictSeq a
SSeq.singleton (StakePoolParams era -> TxCert era
forall era. EraTxCert era => StakePoolParams era -> TxCert era
RegPoolTxCert StakePoolParams era
pps)

      getPools :: ImpTestM era (Map (KeyHash StakePool) StakePoolState)
getPools = SimpleGetter
  (NewEpochState era) (Map (KeyHash StakePool) StakePoolState)
-> ImpTestM era (Map (KeyHash StakePool) StakePoolState)
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter
   (NewEpochState era) (Map (KeyHash StakePool) StakePoolState)
 -> ImpTestM era (Map (KeyHash StakePool) StakePoolState))
-> SimpleGetter
     (NewEpochState era) (Map (KeyHash StakePool) StakePoolState)
-> ImpTestM era (Map (KeyHash StakePool) StakePoolState)
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 (KeyHash StakePool) StakePoolState
     -> Const r (Map (KeyHash StakePool) StakePoolState))
    -> EpochState era -> Const r (EpochState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const r (Map (KeyHash StakePool) StakePoolState))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const r (Map (KeyHash StakePool) StakePoolState))
-> EpochState era -> Const r (EpochState era)
forall era.
EraCertState era =>
Lens' (EpochState era) (Map (KeyHash StakePool) StakePoolState)
Lens' (EpochState era) (Map (KeyHash StakePool) StakePoolState)
epochStateStakePoolsL

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"registers a pool with a valid BLS key and proof of possession" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pps <- ImpM (LedgerSpec era) (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      ownerBlsKey <- freshBlsKey
      let ppsWithBlsKey = StakePoolParams era
pps {sppBlsKey = SJust ownerBlsKey}
      submitTxAnn_ "Registering a new stake pool" $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL .~ SSeq.singleton (RegPoolTxCert ppsWithBlsKey)
      pools <- getPools
      stakePoolState <- expectJust $ Map.lookup (sppId pps) pools
      bksKey <$> spsBlsKey stakePoolState `shouldBe` SJust ownerBlsKey

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails to re-register an existing pool with an invalid BLS proof of possession" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pps <- ImpM (LedgerSpec era) (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      ownerBlsKey <- freshBlsKey
      let ppsWithBlsKey = StakePoolParams era
pps {sppBlsKey = SJust ownerBlsKey}
      submitTxAnn_ "Registering a new stake pool" $
        mkPoolRegTxFromParams ppsWithBlsKey
      pStateBefore <- getPools
      invalidOwnerBlsKey <- BlsKey <$> arbitrary <*> arbitrary
      -- TODO: remove `withDisabledPostSubmitTxHook` once the Agda spec includes BLS
      -- proof of possession validation for pool registration.
      -- See https://github.com/IntersectMBO/formal-ledger-specifications/pull/1300
      withDisabledPostSubmitTxHook $
        submitFailingTx
          (mkPoolRegTxFromParams pps {sppBlsKey = SJust invalidOwnerBlsKey})
          [injectFailure $ BlsKeyInvalidProofOfPossession (sppId pps) invalidOwnerBlsKey]
      passEpoch
      getPools `shouldReturn` pStateBefore

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"fails to register a new pool with an invalid BLS proof of possession" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      pps <- ImpM (LedgerSpec era) (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      invalidOwnerBlsKey <- BlsKey <$> arbitrary <*> arbitrary
      -- TODO: remove `withDisabledPostSubmitTxHook` once the Agda spec includes BLS
      -- proof of possession validation for pool registration.
      -- See https://github.com/IntersectMBO/formal-ledger-specifications/pull/1300
      withDisabledPostSubmitTxHook $
        submitFailingTx
          (mkPoolRegTxFromParams pps {sppBlsKey = SJust invalidOwnerBlsKey})
          [injectFailure $ BlsKeyInvalidProofOfPossession (sppId pps) invalidOwnerBlsKey]
      pools <- getPools
      expectNothing $ Map.lookup (sppId pps) pools
  where
    registerNewPool :: ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool = do
      (kh, vrf) <- (,) (KeyHash StakePool
 -> VRFVerKeyHash StakePoolVRF
 -> (KeyHash StakePool, VRFVerKeyHash StakePoolVRF))
-> ImpM (LedgerSpec era) (KeyHash StakePool)
-> ImpM
     (LedgerSpec era)
     (VRFVerKeyHash StakePoolVRF
      -> (KeyHash StakePool, VRFVerKeyHash StakePoolVRF))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash ImpM
  (LedgerSpec era)
  (VRFVerKeyHash StakePoolVRF
   -> (KeyHash StakePool, VRFVerKeyHash StakePoolVRF))
-> ImpTestM era (VRFVerKeyHash StakePoolVRF)
-> ImpM
     (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ImpTestM era (VRFVerKeyHash StakePoolVRF)
forall era (r :: KeyRoleVRF). ImpTestM era (VRFVerKeyHash r)
freshKeyHashVRF
      submitTx_ . registerPoolTx =<< poolParams kh vrf
      expectPool kh (Just vrf)
      pure (kh, vrf)
    registerPoolTx :: StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps =
      TxBody l era -> Tx l era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody l era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
        Tx l era -> (Tx l era -> Tx l era) -> Tx l era
forall a b. a -> (a -> b) -> b
& (TxBody l era -> Identity (TxBody l era))
-> Tx l era -> Identity (Tx l era)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxBody l era)
forall (l :: TxLevel). Lens' (Tx l era) (TxBody l era)
bodyTxL ((TxBody l era -> Identity (TxBody l era))
 -> Tx l era -> Identity (Tx l era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody l era -> Identity (TxBody l era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx l era
-> Identity (Tx l era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody l era -> Identity (TxBody l era)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxCert era))
forall (l :: TxLevel).
Lens' (TxBody l era) (StrictSeq (TxCert era))
certsTxBodyL ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
 -> Tx l era -> Identity (Tx l era))
-> StrictSeq (TxCert era) -> Tx l era -> Tx l era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ TxCert era -> StrictSeq (TxCert era)
forall a. a -> StrictSeq a
SSeq.singleton (StakePoolParams era -> TxCert era
forall era. EraTxCert era => StakePoolParams era -> TxCert era
RegPoolTxCert StakePoolParams era
pps)
    -- Two pools can only share a VRF if both registered it before VRFs had to be
    -- unique, in which case the hard fork to protocol version 11 recorded the VRF
    -- with a count of two. Registering a pool and then rewriting its VRF puts the
    -- state into the same shape.
    registerPoolSharingVRF :: VRFVerKeyHash StakePoolVRF
-> ImpM (LedgerSpec era) (KeyHash StakePool)
registerPoolSharingVRF VRFVerKeyHash StakePoolVRF
vrf = do
      (kh, ownVrf) <- ImpM
  (LedgerSpec era) (KeyHash StakePool, VRFVerKeyHash StakePoolVRF)
registerNewPool
      modifyNES $
        nesEsL . esLStateL . lsCertStateL . certPStateL %~ \PState era
ps ->
          PState era
ps
            PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (KeyHash StakePool) StakePoolState
 -> Identity (Map (KeyHash StakePool) StakePoolState))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL ((Map (KeyHash StakePool) StakePoolState
  -> Identity (Map (KeyHash StakePool) StakePoolState))
 -> PState era -> Identity (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Map (KeyHash StakePool) StakePoolState)
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (StakePoolState -> StakePoolState)
-> KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((VRFVerKeyHash StakePoolVRF
 -> Identity (VRFVerKeyHash StakePoolVRF))
-> StakePoolState -> Identity StakePoolState
Lens' StakePoolState (VRFVerKeyHash StakePoolVRF)
spsVrfL ((VRFVerKeyHash StakePoolVRF
  -> Identity (VRFVerKeyHash StakePoolVRF))
 -> StakePoolState -> Identity StakePoolState)
-> VRFVerKeyHash StakePoolVRF -> StakePoolState -> StakePoolState
forall s t a b. ASetter s t a b -> b -> s -> t
.~ VRFVerKeyHash StakePoolVRF
vrf) KeyHash StakePool
kh
            PState era -> (PState era -> PState era) -> PState era
forall a b. a -> (a -> b) -> b
& (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> Identity (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> f (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
-> PState era -> f (PState era)
psVRFKeyHashesL ((Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
  -> Identity (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)))
 -> PState era -> Identity (PState era))
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
    -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> PState era
-> PState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
addVRFKeyHashOccurrence VRFVerKeyHash StakePoolVRF
vrf (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
 -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
    -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VRFVerKeyHash StakePoolVRF
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete VRFVerKeyHash StakePoolVRF
ownVrf
      expectPool kh (Just vrf)
      pure kh
    retirePoolTx :: KeyHash StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx l era)
retirePoolTx KeyHash StakePool
kh EpochInterval
retirementInterval = do
      curEpochNo <- 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
      pure $
        mkBasicTx mkBasicTxBody
          & bodyTxL . certsTxBodyL
            .~ SSeq.singleton (RetirePoolTxCert kh (addEpochInterval curEpochNo retirementInterval))
    expectPool :: KeyHash StakePool
-> Maybe (VRFVerKeyHash StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectPool KeyHash StakePool
poolKh Maybe (VRFVerKeyHash StakePoolVRF)
mbVrf = do
      pools <- PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools (PState era -> Map (KeyHash StakePool) StakePoolState)
-> ImpM (LedgerSpec era) (PState era)
-> ImpM (LedgerSpec era) (Map (KeyHash StakePool) StakePoolState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (PState era)
forall era. EraCertState era => ImpTestM era (PState era)
getPState
      spsVrf <$> Map.lookup poolKh pools `shouldBe` mbVrf
    expectFuturePool :: KeyHash StakePool
-> Maybe (VRFVerKeyHash StakePoolVRF) -> ImpM (LedgerSpec era) ()
expectFuturePool KeyHash StakePool
poolKh Maybe (VRFVerKeyHash StakePoolVRF)
mbVrf = do
      fps <- PState era -> Map (KeyHash StakePool) (StakePoolParams era)
forall era.
PState era -> Map (KeyHash StakePool) (StakePoolParams era)
psFutureStakePoolParams (PState era -> Map (KeyHash StakePool) (StakePoolParams era))
-> ImpM (LedgerSpec era) (PState era)
-> ImpM
     (LedgerSpec era) (Map (KeyHash StakePool) (StakePoolParams era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (PState era)
forall era. EraCertState era => ImpTestM era (PState era)
getPState
      sppVrf <$> Map.lookup poolKh fps `shouldBe` mbVrf
    expectVRFs :: [(VRFVerKeyHash StakePoolVRF, Word64)] -> ImpM (LedgerSpec era) ()
expectVRFs [(VRFVerKeyHash StakePoolVRF, Word64)]
vrfs =
      PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall era.
PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
psVRFKeyHashes
        (PState era -> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> ImpM (LedgerSpec era) (PState era)
-> ImpM
     (LedgerSpec era)
     (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ImpM (LedgerSpec era) (PState era)
forall era. EraCertState era => ImpTestM era (PState era)
getPState
          ImpM
  (LedgerSpec era)
  (Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64))
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
-> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` [(VRFVerKeyHash StakePoolVRF, NonZero Word64)]
-> Map (VRFVerKeyHash StakePoolVRF) (NonZero Word64)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(VRFVerKeyHash StakePoolVRF
vrf, Word64 -> NonZero Word64
forall a. a -> NonZero a
unsafeNonZero Word64
n) | (VRFVerKeyHash StakePoolVRF
vrf, Word64
n) <- [(VRFVerKeyHash StakePoolVRF, Word64)]
vrfs]
    poolParams ::
      KeyHash StakePool ->
      VRFVerKeyHash StakePoolVRF ->
      ImpTestM era (StakePoolParams era)
    poolParams :: KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF
-> ImpM (LedgerSpec era) (StakePoolParams era)
poolParams KeyHash StakePool
kh VRFVerKeyHash StakePoolVRF
vrf = do
      pps <- ImpTestM era AccountAddress
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era AccountAddress
registerAccountAddress ImpTestM era AccountAddress
-> (AccountAddress -> ImpM (LedgerSpec era) (StakePoolParams era))
-> ImpM (LedgerSpec era) (StakePoolParams 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
>>= KeyHash StakePool
-> AccountAddress -> ImpM (LedgerSpec era) (StakePoolParams era)
forall era.
ShelleyEraImp era =>
KeyHash StakePool
-> AccountAddress -> ImpTestM era (StakePoolParams era)
freshPoolParams KeyHash StakePool
kh
      pure $ pps & sppVrfL .~ vrf

-- | Tests that need the `TransitionConfig` of Dijkstra, which the era-polymorphic tests
-- above cannot construct.
dijkstraOnlySpec :: SpecWith (ImpInit (LedgerSpec DijkstraEra))
dijkstraOnlySpec :: SpecWith (ImpInit (LedgerSpec DijkstraEra))
dijkstraOnlySpec = String
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"POOL" (SpecWith (ImpInit (LedgerSpec DijkstraEra))
 -> SpecWith (ImpInit (LedgerSpec DijkstraEra)))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
forall a b. (a -> b) -> a -> b
$ do
  String
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Register and re-register pools" (SpecWith (ImpInit (LedgerSpec DijkstraEra))
 -> SpecWith (ImpInit (LedgerSpec DijkstraEra)))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
-> SpecWith (ImpInit (LedgerSpec DijkstraEra))
forall a b. (a -> b) -> a -> b
$ do
    String
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-register a pool from the genesis with its own VRF" (ImpM (LedgerSpec DijkstraEra) ()
 -> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ())))
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a b. (a -> b) -> a -> b
$ do
      stakePoolParams <- ImpTestM DijkstraEra (StakePoolParams DijkstraEra)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      -- set up before the injection, since no transaction can follow it (see `runPool`)
      newStakePoolParams <- freshStakePool
      let vrf = StakePoolParams DijkstraEra -> VRFVerKeyHash StakePoolVRF
forall era. StakePoolParams era -> VRFVerKeyHash StakePoolVRF
sppVrf StakePoolParams DijkstraEra
stakePoolParams
      injectGenesisStakePools [stakePoolParams]
      -- the pool can re-register with the VRF it is already using ...
      runPool (RegPool stakePoolParams) >>= expectRightDeep_
      -- ... because its VRF is tracked just like that of a pool registered through POOL ...
      psVRFKeyHashes <$> getPState `shouldReturn` [(vrf, knownNonZeroBounded @1)]
      -- ... which also keeps any other pool from registering with it
      runPool (RegPool newStakePoolParams {sppVrf = vrf})
        `shouldReturn` Left [VRFKeyHashAlreadyRegistered (sppId newStakePoolParams) vrf]
  where
    -- The deposits of stake pools from the genesis never make it into the deposit pot,
    -- which the assertions of LEDGER reject, so POOL is run on its own.
    runPool :: Signal (EraRule "POOL" era)
-> ImpM
     (LedgerSpec era)
     (Either
        (NonEmpty (PredicateFailure (EraRule "POOL" era)))
        (State (EraRule "POOL" era)))
runPool Signal (EraRule "POOL" era)
poolCert = do
      poolEnv <- EpochNo -> PParams era -> PoolEnv era
forall era. EpochNo -> PParams era -> PoolEnv era
Shelley.PoolEnv (EpochNo -> PParams era -> PoolEnv era)
-> ImpM (LedgerSpec era) EpochNo
-> ImpM (LedgerSpec era) (PParams era -> PoolEnv era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SimpleGetter (NewEpochState era) EpochNo
-> ImpM (LedgerSpec 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 ImpM (LedgerSpec era) (PParams era -> PoolEnv era)
-> ImpM (LedgerSpec era) (PParams era)
-> ImpM (LedgerSpec era) (PoolEnv era)
forall a b.
ImpM (LedgerSpec era) (a -> b)
-> ImpM (LedgerSpec era) a -> ImpM (LedgerSpec era) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Lens' (PParams era) (PParams era)
-> ImpM (LedgerSpec era) (PParams era)
forall era a. EraGov era => Lens' (PParams era) a -> ImpTestM era a
getsPParams (PParams era -> f (PParams era)) -> PParams era -> f (PParams era)
forall a. a -> a
Lens' (PParams era) (PParams era)
id
      pState <- getPState
      fmap fst <$> tryRunImpRule @"POOL" poolEnv pState poolCert
    -- Register the stake pools the way a network that starts in Dijkstra does: by
    -- injecting them from the genesis rather than through POOL.
    injectGenesisStakePools :: [StakePoolParams era] -> ImpM (LedgerSpec DijkstraEra) ()
injectGenesisStakePools [StakePoolParams era]
stakePools = do
      shelleyGenesis <- forall era s (m :: * -> *) g.
(ShelleyEraImp era, HasKeyPairs s, MonadState s m,
 HasStatefulGen g m, MonadFail m) =>
m (Genesis era)
initGenesis @ShelleyEra
      alonzoGenesis <- initGenesis @AlonzoEra
      conwayGenesis <- initGenesis @ConwayEra
      dijkstraGenesis <- initGenesis @DijkstraEra
      let staking =
            ShelleyGenesisStaking
              { sgsPools :: ListMap (KeyHash StakePool) (StakePoolParams ShelleyEra)
sgsPools = [(KeyHash StakePool, StakePoolParams ShelleyEra)]
-> ListMap (KeyHash StakePool) (StakePoolParams ShelleyEra)
forall k v. [(k, v)] -> ListMap k v
ListMap.fromList [(StakePoolParams era -> KeyHash StakePool
forall era. StakePoolParams era -> KeyHash StakePool
sppId StakePoolParams era
spp, StakePoolParams era -> StakePoolParams ShelleyEra
forall a b. Coercible a b => a -> b
coerce StakePoolParams era
spp) | StakePoolParams era
spp <- [StakePoolParams era]
stakePools]
              , sgsStake :: ListMap (KeyHash Staking) (KeyHash StakePool)
sgsStake = ListMap (KeyHash Staking) (KeyHash StakePool)
forall a. Monoid a => a
mempty
              }
          transitionConfig =
            ShelleyGenesis -> TransitionConfig ShelleyEra
mkShelleyTransitionConfig ShelleyGenesis
shelleyGenesis {sgStaking = staking}
              TransitionConfig ShelleyEra
-> (TransitionConfig ShelleyEra -> TransitionConfig AllegraEra)
-> TransitionConfig AllegraEra
forall a b. a -> (a -> b) -> b
& TranslationContext AllegraEra
-> TransitionConfig (PreviousEra AllegraEra)
-> TransitionConfig AllegraEra
forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
mkTransitionConfig TranslationContext AllegraEra
NoGenesis AllegraEra
forall era. NoGenesis era
NoGenesis
              TransitionConfig AllegraEra
-> (TransitionConfig AllegraEra -> TransitionConfig MaryEra)
-> TransitionConfig MaryEra
forall a b. a -> (a -> b) -> b
& TranslationContext MaryEra
-> TransitionConfig (PreviousEra MaryEra)
-> TransitionConfig MaryEra
forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
mkTransitionConfig TranslationContext MaryEra
NoGenesis MaryEra
forall era. NoGenesis era
NoGenesis
              TransitionConfig MaryEra
-> (TransitionConfig MaryEra -> TransitionConfig AlonzoEra)
-> TransitionConfig AlonzoEra
forall a b. a -> (a -> b) -> b
& TranslationContext AlonzoEra
-> TransitionConfig (PreviousEra AlonzoEra)
-> TransitionConfig AlonzoEra
forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
mkTransitionConfig TranslationContext AlonzoEra
AlonzoGenesis
alonzoGenesis
              TransitionConfig AlonzoEra
-> (TransitionConfig AlonzoEra -> TransitionConfig BabbageEra)
-> TransitionConfig BabbageEra
forall a b. a -> (a -> b) -> b
& TranslationContext BabbageEra
-> TransitionConfig (PreviousEra BabbageEra)
-> TransitionConfig BabbageEra
forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
mkTransitionConfig TranslationContext BabbageEra
NoGenesis BabbageEra
forall era. NoGenesis era
NoGenesis
              TransitionConfig BabbageEra
-> (TransitionConfig BabbageEra -> TransitionConfig ConwayEra)
-> TransitionConfig ConwayEra
forall a b. a -> (a -> b) -> b
& TranslationContext ConwayEra
-> TransitionConfig (PreviousEra ConwayEra)
-> TransitionConfig ConwayEra
forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
mkTransitionConfig TranslationContext ConwayEra
ConwayGenesis
conwayGenesis
              TransitionConfig ConwayEra
-> (TransitionConfig ConwayEra -> TransitionConfig DijkstraEra)
-> TransitionConfig DijkstraEra
forall a b. a -> (a -> b) -> b
& TranslationContext DijkstraEra
-> TransitionConfig (PreviousEra DijkstraEra)
-> TransitionConfig DijkstraEra
forall era.
EraTransition era =>
TranslationContext era
-> TransitionConfig (PreviousEra era) -> TransitionConfig era
mkTransitionConfig TranslationContext DijkstraEra
DijkstraGenesis
dijkstraGenesis
      nes <- getsNES id
      injectedNes <- liftIO $ do
        fs <- simHasFS' MockFS.empty
        injectIntoTestState fs transitionConfig nes
      modifyNES $ const injectedNes