{-# 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.BaseTypes
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (Compactible (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.Dijkstra
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.PParams (ppMaxPledgeLeverageL, ppMinPoolMarginL)
import Cardano.Ledger.Dijkstra.Rules
import Cardano.Ledger.Keys (coerceKeyRole)
import Cardano.Ledger.Plutus.CostModels (emptyCostModels)
import Cardano.Ledger.Shelley.LedgerState
import qualified Cardano.Ledger.Shelley.Rules as Shelley
import Cardano.Ledger.State
import Data.Coerce (coerce)
import Data.Foldable (fold, for_)
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 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, Credential Staking))
registerPoolWithPledge :: forall era.
DijkstraEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, (Credential Staking, 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 delegator.
poolRewards ::
  (HasCallStack, EraCertState era) => (Credential Staking, Credential Staking) -> ImpTestM era Coin
poolRewards :: forall era.
(HasCallStack, EraCertState era) =>
(Credential Staking, Credential Staking) -> ImpTestM era Coin
poolRewards (Credential Staking
o, Credential Staking
d) = [Coin] -> Coin
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold ([Coin] -> Coin)
-> ImpM (LedgerSpec era) [Coin] -> ImpM (LedgerSpec era) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse @[] Credential Staking -> ImpM (LedgerSpec era) Coin
forall era.
(HasCallStack, EraCertState era) =>
Credential Staking -> ImpTestM era Coin
getBalance [Item [Credential Staking]
Credential Staking
o, Item [Credential Staking]
Credential Staking
d]

-- | 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, Credential Staking))
forall era.
DijkstraEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, (Credential Staking, 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
      pps <- poolParams kh vrfNew
      submitAnyTx_ $ registerPoolTx pps
      expectPool kh (Just vrf)
      expectFuturePool kh (Just vrfNew)
      -- re-registering with the VRF already recorded in the pool's own
      -- future params should succeed
      submitAnyTx_ $ registerPoolTx pps
      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 ...
      poolParams kh vrf >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      expectFuturePool kh (Just vrf)
      expectVRFs [(vrf, 1)]
      -- ... and then with a fresh one
      vrfNew <- freshKeyHashVRF
      poolParams kh vrfNew >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      -- 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 ...
      poolParams khNew vrf >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      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
      poolParams kh1 vrfNew >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      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
      poolParams kh vrfNew >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      expectVRFs [(vrf, 1), (vrfNew, 1)]
      -- going back to the active VRF frees the previously requested one
      poolParams kh vrf >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      expectFuturePool kh (Just vrf)
      expectVRFs [(vrf, 1)]
      khNew <- freshKeyHash
      poolParams khNew vrfNew >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      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
      poolParams kh vrfNew >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      expectVRFs [(vrf, 1), (vrfNew, 1)]
      poolParams kh vrf >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      expectVRFs [(vrf, 1)]
      poolParams kh vrfNew >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      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)]
      poolParams khNew vrf >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      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
            poolParams kh vrfNew >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
            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
            poolParams kh vrf >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
            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 ...
        AnyLevelTx retireTx1 <- retirePoolTx kh1 (EpochInterval 1)
        submitAnyTx_ retireTx1
        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
        AnyLevelTx retireTx2 <- retirePoolTx kh2 (EpochInterval 1)
        submitAnyTx_ retireTx2
        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
      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
      ownerBlsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust ownerBlsKey)
      epochNo <- getsNES nesELL
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState ownerBlsKey epochNo))

    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
      ownerBlsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust ownerBlsKey)
      pStateBefore <- getPools
      invalidOwnerBlsKey <- BlsKey <$> arbitrary <*> arbitrary
      submitFailingTx
        (registerPoolTx 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 <- ImpTestM era (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      invalidOwnerBlsKey <- BlsKey <$> arbitrary <*> arbitrary
      submitFailingTx
        (registerPoolTx pps {sppBlsKey = SJust invalidOwnerBlsKey})
        [injectFailure $ BlsKeyInvalidProofOfPossession (sppId pps) invalidOwnerBlsKey]
      pools <- getPools
      expectNothing $ Map.lookup (sppId pps) pools

    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 same and different BLS key" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      blsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust blsKey)
      registeredIn <- getsNES nesELL
      passEpoch
      submitAnyTx_ $ registerPoolTx pps
      passEpoch
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey registeredIn))
      newBlsKey <- freshBlsKey
      renewalSubmittedIn <- getsNES nesELL
      submitAnyTx_ $ registerPoolTx pps {sppBlsKey = SJust newBlsKey}
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey registeredIn))
      passEpoch
      -- dated one epoch after the re-registration was submitted,
      -- because re-registration is applied by POOLREAP on entering the next epoch
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState newBlsKey (succ renewalSubmittedIn)))

    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 same BLS key within 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
      blsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust blsKey)
      submitAnyTx_ $ registerPoolTx pps
      registeredIn <- getsNES nesELL
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey registeredIn))
      passEpoch
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey registeredIn))

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-registering with a new BLS key within 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
      blsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust blsKey)
      newBlsKey <- freshBlsKey
      submitAnyTx_ $ registerPoolTx pps {sppBlsKey = SJust newBlsKey}
      registeredIn <- getsNES nesELL
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey registeredIn))
      passEpoch
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState newBlsKey (succ registeredIn)))

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"changing other pool parameters does not renew the BLS key" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      blsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust blsKey)
      registeredIn <- getsNES nesELL
      passEpoch
      minPoolCost <- getsPParams ppMinPoolCostL
      submitAnyTx_ $ registerPoolTx pps {sppCost = minPoolCost <> Coin 1}
      passEpoch
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey registeredIn))

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"dropping the BLS key clears 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
      pps <- StrictMaybe BlsKey
-> ImpM (LedgerSpec era) (StakePoolParams (ZonkAny 4))
forall {era} {era}.
(Event (EraRule "LEDGER" era) ~ EraRuleEvent "LEDGER" era,
 Event (EraRule "TICK" era) ~ EraRuleEvent "TICK" era,
 PredicateFailure (EraRule "BBODY" era)
 ~ EraRuleFailure "BBODY" era,
 PredicateFailure (EraRule "LEDGER" era)
 ~ EraRuleFailure "LEDGER" 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 ...),
 ShelleyEraImp era, ToExpr (EraRuleFailure "BBODY" era),
 ToExpr (EraRuleFailure "LEDGER" era),
 EncCBOR (EraRuleFailure "BBODY" era),
 EncCBOR (EraRuleFailure "LEDGER" era),
 DecCBOR (EraRuleFailure "BBODY" era),
 DecCBOR (EraRuleFailure "LEDGER" era),
 Ord (EraRuleFailure "BBODY" era),
 Ord (EraRuleFailure "LEDGER" era),
 Show (EraRuleFailure "BBODY" era),
 Show (EraRuleFailure "LEDGER" era),
 NFData (EraRuleFailure "BBODY" era),
 NFData (EraRuleFailure "LEDGER" era)) =>
StrictMaybe BlsKey -> ImpM (LedgerSpec era) (StakePoolParams era)
registerPoolWithBlsKey (StrictMaybe BlsKey
 -> ImpM (LedgerSpec era) (StakePoolParams (ZonkAny 4)))
-> (BlsKey -> StrictMaybe BlsKey)
-> BlsKey
-> ImpM (LedgerSpec era) (StakePoolParams (ZonkAny 4))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlsKey -> StrictMaybe BlsKey
forall a. a -> StrictMaybe a
SJust (BlsKey -> ImpM (LedgerSpec era) (StakePoolParams (ZonkAny 4)))
-> ImpTestM era BlsKey
-> ImpM (LedgerSpec era) (StakePoolParams (ZonkAny 4))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      passEpoch
      submitAnyTx_ $ registerPoolTx pps {sppBlsKey = SNothing}
      passEpoch
      expectBlsKeyState (sppId pps) SNothing

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"dropping and re-registering the BLS key within one epoch does not renew 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
      blsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust blsKey)
      registeredIn <- getsNES nesELL
      passEpoch
      submitAnyTx_ $ registerPoolTx pps {sppBlsKey = SNothing}
      submitAnyTx_ $ registerPoolTx pps
      passEpoch
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey registeredIn))

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"re-registering a dropped BLS key starts a fresh lifetime" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      blsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust blsKey)
      passEpoch
      submitAnyTx_ $ registerPoolTx pps {sppBlsKey = SNothing}
      passEpoch
      expectBlsKeyState (sppId pps) SNothing
      reRegisteredIn <- getsNES nesELL
      submitAnyTx_ $ registerPoolTx pps
      expectBlsKeyState (sppId pps) SNothing
      passEpoch
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey (succ reRegisteredIn)))

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"un-retiring a pool by re-registration does not renew its BLS key" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      blsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust blsKey)
      registeredIn <- getsNES nesELL
      AnyLevelTx tx <- retirePoolTx (sppId pps) (EpochInterval 2)
      submitAnyTx_ tx
      submitAnyTx_ $ registerPoolTx pps
      passNEpochs 3
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey registeredIn))

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a reaped pool that registers again starts a fresh lifetime" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      blsKey <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      pps <- registerPoolWithBlsKey (SJust blsKey)
      AnyLevelTx tx <- retirePoolTx (sppId pps) (EpochInterval 1)
      submitAnyTx_ tx
      passNEpochs 2
      expectPool (sppId pps) Nothing
      registeredAgainIn <- getsNES nesELL
      submitAnyTx_ $ registerPoolTx pps
      expectBlsKeyState (sppId pps) (SJust (BlsKeyState blsKey registeredAgainIn))

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"BLS key uniqueness" (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
"a new pool cannot take the active key of 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
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      _ <- registerBlsPool (SJust key)
      expectBlsKeys [key]
      expectBlsKeyTakenByNewPool key
      -- the key stays taken across the epoch boundary
      passEpoch
      expectBlsKeys [key]
      expectBlsKeyTakenByNewPool key

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a registered pool cannot take the active key of 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
      key1 <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      key2 <- freshBlsKey
      _ <- registerBlsPool (SJust key1)
      withKey <- registerBlsPool (SJust key2)
      withoutKey <- registerBlsPool SNothing
      expectBlsKeys [key1, key2]
      -- neither a pool with a key of its own nor one without any may take it
      expectBlsKeyTaken withKey key1
      expectBlsKeyTaken withoutKey key1
      expectBlsKeys [key1, key2]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a pending future key 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
      key1 <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      kh1 <- registerBlsPool (SJust key1)
      kh2 <- registerBlsPool SNothing
      newKey <- freshBlsKey
      reregisterBlsPool kh1 (SJust newKey)
      expectActiveBlsKey kh1 (SJust key1)
      expectFutureBlsKey kh1 (SJust newKey)
      expectBlsKeys [key1, newKey]
      -- a key is taken as soon as a re-registration requests it, so neither a new pool ...
      expectBlsKeyTakenByNewPool newKey
      -- ... nor another registered pool may claim it
      expectBlsKeyTaken kh2 newKey
      expectBlsKeys [key1, newKey]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a pool can re-register with its own active key" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      kh <- registerBlsPool (SJust key)
      reregisterBlsPool kh (SJust key)
      expectFutureBlsKey kh (SJust key)
      expectBlsKeys [key]
      passEpoch
      expectActiveBlsKey kh (SJust key)
      expectBlsKeys [key]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a pool can re-register with its own pending future key" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      kh <- registerBlsPool (SJust key)
      newKey <- freshBlsKey
      reregisterBlsPool kh (SJust newKey)
      -- registering with the key in the pool's own future params should succeed
      reregisterBlsPool kh (SJust newKey)
      expectActiveBlsKey kh (SJust key)
      expectFutureBlsKey kh (SJust newKey)
      expectBlsKeys [key, newKey]
      passEpoch
      expectActiveBlsKey kh (SJust newKey)
      expectBlsKeys [newKey]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a pending future key is released as soon as the pool replaces 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
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      kh <- registerBlsPool (SJust key)
      futureKey <- freshBlsKey
      reregisterBlsPool kh (SJust futureKey)
      newFutureKey <- freshBlsKey
      reregisterBlsPool kh (SJust newFutureKey)
      expectFutureBlsKey kh (SJust newFutureKey)
      expectBlsKeys [key, newFutureKey]
      -- the replaced key is free right away, while the active one stays taken
      other <- registerBlsPool (SJust futureKey)
      expectActiveBlsKey other (SJust futureKey)
      expectBlsKeyTakenByNewPool key
      passEpoch
      expectActiveBlsKey kh (SJust newFutureKey)
      expectBlsKeys [futureKey, newFutureKey]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"the active key stays taken when the future parameters move away from 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
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      kh <- registerBlsPool (SJust key)
      reregisterBlsPool kh (SJust key)
      newKey <- freshBlsKey
      reregisterBlsPool kh (SJust newKey)
      -- the future parameters no longer use the key, but the active ones still do
      expectBlsKeys [key, newKey]
      expectBlsKeyTakenByNewPool key
      passEpoch
      expectActiveBlsKey kh (SJust newKey)
      expectBlsKeys [newKey]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a key is released when its holder switches to 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
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      kh <- registerBlsPool (SJust key)
      newKey <- freshBlsKey
      reregisterBlsPool kh (SJust newKey)
      -- the pool keeps using the key until the epoch boundary, so it stays taken
      expectBlsKeyTakenByNewPool key
      passEpoch
      expectActiveBlsKey kh (SJust newKey)
      expectBlsKeys [newKey]
      -- now another pool can take it over ...
      other <- registerBlsPool (SJust key)
      expectActiveBlsKey other (SJust key)
      expectBlsKeys [key, newKey]
      -- ... but only a single one
      expectBlsKeyTakenByNewPool key

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a key is released when its holder drops 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
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      kh <- registerBlsPool (SJust key)
      reregisterBlsPool kh SNothing
      expectActiveBlsKey kh (SJust key)
      expectBlsKeys [key]
      expectBlsKeyTakenByNewPool key
      passEpoch
      expectActiveBlsKey kh SNothing
      expectBlsKeys []
      other <- registerBlsPool (SJust key)
      expectActiveBlsKey other (SJust key)
      expectBlsKeys [key]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"a key is released when its holder retires" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      kh <- registerBlsPool (SJust key)
      AnyLevelTx tx <- retirePoolTx kh (EpochInterval 1)
      submitAnyTx_ tx
      expectBlsKeys [key]
      expectBlsKeyTakenByNewPool key
      passEpoch
      expectPool kh Nothing
      expectBlsKeys []
      other <- registerBlsPool (SJust key)
      expectActiveBlsKey other (SJust key)
      expectBlsKeys [key]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"retiring with a pending future key releases both keys" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      kh <- registerBlsPool (SJust key)
      newKey <- freshBlsKey
      reregisterBlsPool kh (SJust newKey)
      AnyLevelTx tx <- retirePoolTx kh (EpochInterval 1)
      submitAnyTx_ tx
      expectBlsKeys [key, newKey]
      passEpoch
      expectPool kh Nothing
      expectBlsKeys []
      _ <- registerBlsPool (SJust key)
      _ <- registerBlsPool (SJust newKey)
      expectBlsKeys [key, newKey]

    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"only the public key counts, not the 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
      key <- ImpTestM era BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      _ <- registerBlsPool (SJust key)
      bogusProof <- arbitrary
      let bogusKey = BlsKey
key {blsPossessionProof = bogusProof}
      kh <- freshKeyHash
      pps <- blsPoolParams kh (SJust bogusKey)
      -- the key is rejected twice: its public key is taken and its proof is not valid
      submitFailingTx
        (registerPoolTx pps)
        [ injectFailure $ BlsKeyInvalidProofOfPossession kh bogusKey
        , injectFailure $ BlsKeyAlreadyRegistered kh bogusKey
        ]
      expectBlsKeys [key]

  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"CIP-23" (SpecWith (ImpInit (LedgerSpec era))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
    forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ @[] [Item [UnitInterval]
UnitInterval
forall a. Bounded a => a
minBound, Item [UnitInterval]
UnitInterval
forall a. Bounded a => a
maxBound] ((UnitInterval -> SpecWith (ImpInit (LedgerSpec era)))
 -> SpecWith (ImpInit (LedgerSpec era)))
-> (UnitInterval -> SpecWith (ImpInit (LedgerSpec era)))
-> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ \UnitInterval
margin -> do
      String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (String
"minimum pool margin (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> UnitInterval -> String
forall a. Show a => a -> String
show UnitInterval
margin String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")") (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
        (poolId, (poolOwner, poolDelegator)) <- Coin
-> ImpTestM
     era (KeyHash StakePool, (Credential Staking, Credential Staking))
forall era.
DijkstraEraImp era =>
Coin
-> ImpTestM
     era (KeyHash StakePool, (Credential Staking, Credential Staking))
registerPoolWithPledge (Coin
 -> ImpTestM
      era (KeyHash StakePool, (Credential Staking, Credential Staking)))
-> Coin
-> ImpTestM
     era (KeyHash StakePool, (Credential Staking, Credential Staking))
forall a b. (a -> b) -> a -> b
$ Integer -> Coin
Coin Integer
0

        pools <- psStakePools <$> getPState
        poolState <- expectJust $ Map.lookup poolId pools
        poolState ^. spsMarginL `shouldBe` minBound

        modifyPParams $ ppMinPoolMarginL .~ margin
        pParams <- getsNES $ nesEsL . curPParamsEpochStateL
        logToExpr $ pParams & ppCostModelsL .~ emptyCostModels

        passEpoch
        withIssuerAndTxsInBlock_ (coerceKeyRole poolId) $
          pure ()
        passEpoch
        replicateM_ 100 $
          withIssuerAndTxsInBlock_ (coerceKeyRole poolId) $
            pure ()
        passNEpochs 2

        certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
        logToExpr certState

        let accountsMap = CertState era
certState CertState era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (CertState era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. (DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> CertState era
-> Const
     (Map (Credential Staking) (AccountState era)) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era
  -> Const
       (Map (Credential Staking) (AccountState era)) (DState era))
 -> CertState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (CertState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> DState era
    -> Const
         (Map (Credential Staking) (AccountState era)) (DState era))
-> Getting
     (Map (Credential Staking) (AccountState era))
     (CertState era)
     (Map (Credential Staking) (AccountState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting
  (Map (Credential Staking) (AccountState era))
  (DState era)
  (Accounts era)
forall era. SimpleGetter (DState era) (Accounts era)
forall (t :: * -> *) era.
CanGetAccounts t =>
SimpleGetter (t era) (Accounts era)
accountsG Getting
  (Map (Credential Staking) (AccountState era))
  (DState era)
  (Accounts era)
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> Accounts era
    -> Const
         (Map (Credential Staking) (AccountState era)) (Accounts era))
-> (Map (Credential Staking) (AccountState era)
    -> Const
         (Map (Credential Staking) (AccountState era))
         (Map (Credential Staking) (AccountState era)))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Const
      (Map (Credential Staking) (AccountState era))
      (Map (Credential Staking) (AccountState era)))
-> Accounts era
-> Const
     (Map (Credential Staking) (AccountState era)) (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL
        ownerState <- expectJust $ Map.lookup poolOwner accountsMap
        delegatorState <- expectJust $ Map.lookup poolDelegator accountsMap

        -- The owner always gets some rewards
        let ownerBalance = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ AccountState era
ownerState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL
        ownerBalance `shouldNotBe` Coin 0

        -- Unless the margin is 1, the delegator should get a share of the
        -- remainder rewards that are left after the cost is subtracted.
        -- When the margin is 1, the delegator gets nothing because the pool
        -- takes everything, both the cost and the remainder.
        let delegatorBalance = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ AccountState era
delegatorState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL
        if margin /= maxBound
          then delegatorBalance `shouldNotBe` Coin 0
          else delegatorBalance `shouldBe` Coin 0
  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
      poolParams kh vrf >>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
      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
    registerPoolWithBlsKey :: StrictMaybe BlsKey -> ImpM (LedgerSpec era) (StakePoolParams era)
registerPoolWithBlsKey StrictMaybe BlsKey
mbBlsKey = do
      pps <- ImpTestM era (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      let ppsWithBlsKey = StakePoolParams era
pps {sppBlsKey = mbBlsKey}
      impAnn "Registering a new stake pool" $
        submitAnyTx_ $
          registerPoolTx ppsWithBlsKey
      pure ppsWithBlsKey
    retirePoolTx :: KeyHash StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (AnyLevelTx 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 $
        AnyLevelTx $
          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]
    expectBlsKeyState :: KeyHash StakePool
-> StrictMaybe BlsKeyState -> ImpM (LedgerSpec era) ()
expectBlsKeyState KeyHash StakePool
poolId StrictMaybe BlsKeyState
expected = do
      sps <- Maybe StakePoolState -> ImpM (LedgerSpec era) StakePoolState
forall (m :: * -> *) a. (HasCallStack, MonadIO m) => Maybe a -> m a
expectJust (Maybe StakePoolState -> ImpM (LedgerSpec era) StakePoolState)
-> (PState era -> Maybe StakePoolState)
-> PState era
-> ImpM (LedgerSpec era) StakePoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash StakePool
poolId (Map (KeyHash StakePool) StakePoolState -> Maybe StakePoolState)
-> (PState era -> Map (KeyHash StakePool) StakePoolState)
-> PState era
-> Maybe StakePoolState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools (PState era -> ImpM (LedgerSpec era) StakePoolState)
-> ImpM (LedgerSpec era) (PState era)
-> ImpM (LedgerSpec era) StakePoolState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ImpM (LedgerSpec era) (PState era)
forall era. EraCertState era => ImpTestM era (PState era)
getPState
      spsBlsKey sps `shouldBe` expected
    blsPoolParams ::
      KeyHash StakePool ->
      StrictMaybe BlsKey ->
      ImpTestM era (StakePoolParams era)
    blsPoolParams :: KeyHash StakePool
-> StrictMaybe BlsKey -> ImpTestM era (StakePoolParams era)
blsPoolParams KeyHash StakePool
kh StrictMaybe BlsKey
mbBlsKey = do
      pps <- ImpTestM era AccountAddress
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era AccountAddress
registerAccountAddress ImpTestM era AccountAddress
-> (AccountAddress -> ImpTestM era (StakePoolParams era))
-> ImpTestM 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 -> ImpTestM era (StakePoolParams era)
forall era.
ShelleyEraImp era =>
KeyHash StakePool
-> AccountAddress -> ImpTestM era (StakePoolParams era)
freshPoolParams KeyHash StakePool
kh
      pure pps {sppBlsKey = mbBlsKey}
    registerBlsPool :: StrictMaybe BlsKey -> ImpTestM era (KeyHash StakePool)
    registerBlsPool :: StrictMaybe BlsKey -> ImpM (LedgerSpec era) (KeyHash StakePool)
registerBlsPool StrictMaybe BlsKey
mbBlsKey = 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
      reregisterBlsPool kh mbBlsKey
      expectActiveBlsKey kh mbBlsKey
      pure kh
    -- Registers the pool, or re-registers it if it already is one
    reregisterBlsPool :: KeyHash StakePool -> StrictMaybe BlsKey -> ImpTestM era ()
    reregisterBlsPool :: KeyHash StakePool -> StrictMaybe BlsKey -> ImpM (LedgerSpec era) ()
reregisterBlsPool KeyHash StakePool
kh StrictMaybe BlsKey
mbBlsKey =
      KeyHash StakePool
-> StrictMaybe BlsKey -> ImpTestM era (StakePoolParams era)
blsPoolParams KeyHash StakePool
kh StrictMaybe BlsKey
mbBlsKey ImpTestM era (StakePoolParams era)
-> (StakePoolParams era -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec 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
>>= \StakePoolParams era
pps -> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
(forall (l :: TxLevel). Typeable l => Tx l era) -> ImpTestM era ()
submitAnyTx_ ((forall (l :: TxLevel). Typeable l => Tx l era)
 -> ImpM (LedgerSpec era) ())
-> (forall (l :: TxLevel). Typeable l => Tx l era)
-> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ StakePoolParams era -> Tx l era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx StakePoolParams era
pps
    expectActiveBlsKey :: KeyHash StakePool -> StrictMaybe BlsKey -> ImpTestM era ()
    expectActiveBlsKey :: KeyHash StakePool -> StrictMaybe BlsKey -> ImpM (LedgerSpec era) ()
expectActiveBlsKey KeyHash StakePool
kh StrictMaybe BlsKey
mbBlsKey = 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)
-> ImpTestM 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
      sps <- expectJust $ Map.lookup kh pools
      bksKey <$> spsBlsKey sps `shouldBe` mbBlsKey
    expectFutureBlsKey :: KeyHash StakePool -> StrictMaybe BlsKey -> ImpTestM era ()
    expectFutureBlsKey :: KeyHash StakePool -> StrictMaybe BlsKey -> ImpM (LedgerSpec era) ()
expectFutureBlsKey KeyHash StakePool
kh StrictMaybe BlsKey
mbBlsKey = 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
      spp <- expectJust $ Map.lookup kh fps
      sppBlsKey spp `shouldBe` mbBlsKey
    expectBlsKeys :: [BlsKey] -> ImpTestM era ()
    expectBlsKeys :: [BlsKey] -> ImpM (LedgerSpec era) ()
expectBlsKeys [BlsKey]
keys = PState era -> Set BlsVerKeyHash
forall era. PState era -> Set BlsVerKeyHash
psBlsKeyHashes (PState era -> Set BlsVerKeyHash)
-> ImpM (LedgerSpec era) (PState era)
-> ImpM (LedgerSpec era) (Set BlsVerKeyHash)
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) (Set BlsVerKeyHash)
-> Set BlsVerKeyHash -> ImpM (LedgerSpec era) ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a, Eq a) =>
m a -> a -> m ()
`shouldReturn` [BlsVerKeyHash] -> Set BlsVerKeyHash
forall a. Ord a => [a] -> Set a
Set.fromList (BlsKey -> BlsVerKeyHash
hashBlsKey (BlsKey -> BlsVerKeyHash) -> [BlsKey] -> [BlsVerKeyHash]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlsKey]
keys)
    -- Registering the pool with the BLS key fails, because another pool is using it
    expectBlsKeyTaken :: KeyHash StakePool -> BlsKey -> ImpTestM era ()
    expectBlsKeyTaken :: KeyHash StakePool -> BlsKey -> ImpM (LedgerSpec era) ()
expectBlsKeyTaken KeyHash StakePool
kh BlsKey
key = do
      tx <- StakePoolParams era -> Tx TopTx era
forall {era} {l :: TxLevel}.
(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 ...),
 EraTx era, Typeable l) =>
StakePoolParams era -> Tx l era
registerPoolTx (StakePoolParams era -> Tx TopTx era)
-> ImpTestM era (StakePoolParams era)
-> ImpM (LedgerSpec era) (Tx TopTx era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash StakePool
-> StrictMaybe BlsKey -> ImpTestM era (StakePoolParams era)
blsPoolParams KeyHash StakePool
kh (BlsKey -> StrictMaybe BlsKey
forall a. a -> StrictMaybe a
SJust BlsKey
key)
      submitFailingTx tx [injectFailure $ BlsKeyAlreadyRegistered kh key]
    expectBlsKeyTakenByNewPool :: BlsKey -> ImpTestM era ()
    expectBlsKeyTakenByNewPool :: BlsKey -> ImpM (LedgerSpec era) ()
expectBlsKeyTakenByNewPool BlsKey
key = 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
      expectBlsKeyTaken kh key
    poolParams ::
      KeyHash StakePool ->
      VRFVerKeyHash StakePoolVRF ->
      ImpTestM era (StakePoolParams era)
    poolParams :: KeyHash StakePool
-> VRFVerKeyHash StakePoolVRF -> ImpTestM 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 -> ImpTestM era (StakePoolParams era))
-> ImpTestM 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 -> ImpTestM era (StakePoolParams era)
forall era.
ShelleyEraImp era =>
KeyHash StakePool
-> AccountAddress -> ImpTestM era (StakePoolParams era)
freshPoolParams KeyHash StakePool
kh
      pure $ pps & sppVrfL .~ vrf

-- | These need to run the POOL rule on its own, which needs the concrete rule
-- types of Dijkstra, so can't be bundled in the era-polymorphic ones above
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
      -- register the pool the way a network that starts in Dijkstra does: by injecting it
      -- from the genesis rather than through POOL
      injectGenesisStaking [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]

    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 BLS key" (ImpM (LedgerSpec DijkstraEra) ()
 -> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ())))
-> ImpM (LedgerSpec DijkstraEra) ()
-> SpecWith (Arg (ImpM (LedgerSpec DijkstraEra) ()))
forall a b. (a -> b) -> a -> b
$ do
      blsKey <- ImpTestM DijkstraEra BlsKey
forall era. ImpTestM era BlsKey
freshBlsKey
      stakePoolParams <- (\StakePoolParams DijkstraEra
pps -> StakePoolParams DijkstraEra
pps {sppBlsKey = SJust blsKey}) <$> freshStakePool
      -- set up before the injection, since no transaction can follow it (see `runPool`)
      newStakePoolParams <- freshStakePool
      injectGenesisStaking [stakePoolParams] [] []
      -- the pool can re-register with the BLS key it is already using ...
      runPool (RegPool stakePoolParams) >>= expectRightDeep_
      -- ... because its BLS key is tracked just like that of a pool registered through POOL ...
      psBlsKeyHashes <$> getPState `shouldReturn` [hashBlsKey blsKey]
      -- ... which also keeps any other pool from registering with it
      runPool (RegPool newStakePoolParams {sppBlsKey = SJust blsKey})
        `shouldReturn` Left [BlsKeyAlreadyRegistered (sppId newStakePoolParams) blsKey]
  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