{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

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

import Cardano.Crypto.Hash.Class (hashSize)
import Cardano.Ledger.Address (accountAddressIdL, accountAddressNetworkIdL)
import Cardano.Ledger.BaseTypes (
  EpochInterval (..),
  EpochNo (..),
  Mismatch (..),
  Network (..),
  StrictMaybe (..),
  addEpochInterval,
 )
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Rules (DijkstraPoolPredFailure (..), DijkstraSubPoolPredFailure (..))
import qualified Cardano.Ledger.Dijkstra.Rules as Dijkstra
import Cardano.Ledger.Dijkstra.State
import Cardano.Ledger.Shelley.LedgerState (esLStateL, lsCertStateL, nesELL, nesEpochStateL)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import qualified Data.Set as Set
import Lens.Micro ((&), (.~), (^.))
import Lens.Micro.Extras (view)
import Test.Cardano.Base.Bytes (genByteArray)
import Test.Cardano.Ledger.Dijkstra.ImpTest
import Test.Cardano.Ledger.Imp.Common

lookupStakePoolParams ::
  ShelleyEraImp era =>
  KeyHash StakePool ->
  ImpTestM era (Maybe StakePoolState)
lookupStakePoolParams :: forall era.
ShelleyEraImp era =>
KeyHash StakePool -> ImpTestM era (Maybe StakePoolState)
lookupStakePoolParams KeyHash StakePool
spKH = do
  stakePools <- 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)
nesEpochStateL ((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
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const r (Map (KeyHash StakePool) StakePoolState))
    -> LedgerState era -> Const r (LedgerState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const r (Map (KeyHash StakePool) StakePoolState))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const r (Map (KeyHash StakePool) StakePoolState))
    -> CertState era -> Const r (CertState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const r (Map (KeyHash StakePool) StakePoolState))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Const r (PState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Const r (PState era))
 -> CertState era -> Const r (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const r (Map (KeyHash StakePool) StakePoolState))
    -> PState era -> Const r (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const r (Map (KeyHash StakePool) StakePoolState))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const r (Map (KeyHash StakePool) StakePoolState))
-> PState era -> Const r (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL
  pure $ Map.lookup spKH stakePools

lookupFutureStakePoolParams ::
  ShelleyEraImp era =>
  KeyHash StakePool ->
  ImpTestM era (Maybe (StakePoolParams era))
lookupFutureStakePoolParams :: forall era.
ShelleyEraImp era =>
KeyHash StakePool -> ImpTestM era (Maybe (StakePoolParams era))
lookupFutureStakePoolParams KeyHash StakePool
spKH = do
  stakePools <-
    SimpleGetter
  (NewEpochState era) (Map (KeyHash StakePool) (StakePoolParams era))
-> ImpTestM era (Map (KeyHash StakePool) (StakePoolParams era))
forall era a. SimpleGetter (NewEpochState era) a -> ImpTestM era a
getsNES (SimpleGetter
   (NewEpochState era) (Map (KeyHash StakePool) (StakePoolParams era))
 -> ImpTestM era (Map (KeyHash StakePool) (StakePoolParams era)))
-> SimpleGetter
     (NewEpochState era) (Map (KeyHash StakePool) (StakePoolParams era))
-> ImpTestM era (Map (KeyHash StakePool) (StakePoolParams era))
forall a b. (a -> b) -> a -> b
$ (EpochState era -> Const r (EpochState era))
-> NewEpochState era -> Const r (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEpochStateL ((EpochState era -> Const r (EpochState era))
 -> NewEpochState era -> Const r (NewEpochState era))
-> ((Map (KeyHash StakePool) (StakePoolParams era)
     -> Const r (Map (KeyHash StakePool) (StakePoolParams era)))
    -> EpochState era -> Const r (EpochState era))
-> (Map (KeyHash StakePool) (StakePoolParams era)
    -> Const r (Map (KeyHash StakePool) (StakePoolParams era)))
-> NewEpochState era
-> Const r (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const r (LedgerState era))
-> EpochState era -> Const r (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const r (LedgerState era))
 -> EpochState era -> Const r (EpochState era))
-> ((Map (KeyHash StakePool) (StakePoolParams era)
     -> Const r (Map (KeyHash StakePool) (StakePoolParams era)))
    -> LedgerState era -> Const r (LedgerState era))
-> (Map (KeyHash StakePool) (StakePoolParams era)
    -> Const r (Map (KeyHash StakePool) (StakePoolParams era)))
-> EpochState era
-> Const r (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const r (CertState era))
-> LedgerState era -> Const r (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const r (CertState era))
 -> LedgerState era -> Const r (LedgerState era))
-> ((Map (KeyHash StakePool) (StakePoolParams era)
     -> Const r (Map (KeyHash StakePool) (StakePoolParams era)))
    -> CertState era -> Const r (CertState era))
-> (Map (KeyHash StakePool) (StakePoolParams era)
    -> Const r (Map (KeyHash StakePool) (StakePoolParams era)))
-> LedgerState era
-> Const r (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Const r (PState era))
-> CertState era -> Const r (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Const r (PState era))
 -> CertState era -> Const r (CertState era))
-> ((Map (KeyHash StakePool) (StakePoolParams era)
     -> Const r (Map (KeyHash StakePool) (StakePoolParams era)))
    -> PState era -> Const r (PState era))
-> (Map (KeyHash StakePool) (StakePoolParams era)
    -> Const r (Map (KeyHash StakePool) (StakePoolParams era)))
-> CertState era
-> Const r (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) (StakePoolParams era)
 -> Const r (Map (KeyHash StakePool) (StakePoolParams era)))
-> PState era -> Const r (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) (StakePoolParams era)
 -> f (Map (KeyHash StakePool) (StakePoolParams era)))
-> PState era -> f (PState era)
psFutureStakePoolParamsL
  pure $ Map.lookup spKH stakePools

expectStakePoolParams ::
  DijkstraEraImp era => KeyHash StakePool -> Maybe (StakePoolParams era) -> ImpTestM era ()
expectStakePoolParams :: forall era.
DijkstraEraImp era =>
KeyHash StakePool -> Maybe (StakePoolParams era) -> ImpTestM era ()
expectStakePoolParams KeyHash StakePool
kh Maybe (StakePoolParams era)
expected = String -> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a t. NFData a => String -> ImpM t a -> ImpM t a
impAnn String
"expectStakePoolParams" (ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ())
-> ImpM (LedgerSpec era) () -> ImpM (LedgerSpec era) ()
forall a b. (a -> b) -> a -> b
$ do
  actual <- KeyHash StakePool -> ImpTestM era (Maybe StakePoolState)
forall era.
ShelleyEraImp era =>
KeyHash StakePool -> ImpTestM era (Maybe StakePoolState)
lookupStakePoolParams KeyHash StakePool
kh
  impAnn "accountId" $
    (view spsAccountIdL <$> actual)
      `shouldBeExpr` (view (sppAccountAddressL . accountAddressIdL) <$> expected)
  impAnn "blsKey" $
    (fmap bksKey . view spsBlsKeyL <$> actual) `shouldBeExpr` (view sppBlsKeyL <$> expected)
  impAnn "vrf" $ (view spsVrfL <$> actual) `shouldBeExpr` (view sppVrfL <$> expected)
  impAnn "pledge" $ (view spsPledgeL <$> actual) `shouldBeExpr` (view sppPledgeL <$> expected)
  impAnn "cost" $ (view spsCostL <$> actual) `shouldBeExpr` (view sppCostL <$> expected)
  impAnn "margin" $ (view spsMarginL <$> actual) `shouldBeExpr` (view sppMarginL <$> expected)
  impAnn "owners" $ (view spsOwnersL <$> actual) `shouldBeExpr` (view sppOwnersL <$> expected)
  impAnn "relays" $ (view spsRelaysL <$> actual) `shouldBeExpr` (view sppRelaysL <$> expected)
  impAnn "metadata" $ (view spsMetadataL <$> actual) `shouldBeExpr` (view sppMetadataL <$> expected)

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
"SUBPOOL" (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
"Pool registration" (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
"Fails when registering a new pool with the same 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
      stakePoolParams1 <- ImpTestM era (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      let
        vrfKey = StakePoolParams era
stakePoolParams1 StakePoolParams era
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  (StakePoolParams era)
  (VRFVerKeyHash StakePoolVRF)
forall era (f :: * -> *).
Functor f =>
(VRFVerKeyHash StakePoolVRF -> f (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> f (StakePoolParams era)
sppVrfL
      stakePoolParams2 <- freshStakePool
      submitTxAnn_ "Registering the first pool" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL
                .~ [ RegPoolTxCert stakePoolParams1
                   ]
          ]
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL
                  .~ [ RegPoolTxCert $ stakePoolParams2 & sppVrfL .~ vrfKey
                     ]
            ]
        )
        [ injectFailure . DijkstraSubPoolPredFailure $
            Dijkstra.VRFKeyHashAlreadyRegistered (stakePoolParams2 ^. sppIdL) vrfKey
        ]
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fails when registering a pool with an invalid network ID" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      stakePoolParams <- ImpTestM era (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL
                  .~ [ RegPoolTxCert $
                         stakePoolParams & sppAccountAddressL . accountAddressNetworkIdL .~ Mainnet
                     ]
            ]
        )
        [ injectFailure . DijkstraSubPoolPredFailure $
            WrongNetworkPOOL (Mismatch Mainnet Testnet) (stakePoolParams ^. sppIdL)
        ]

    -- Disabled in conformance for the same reason as the corresponding top-level POOL
    -- test: https://github.com/IntersectMBO/formal-ledger-specifications/issues/1293
    String
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall era.
ShelleyEraImp era =>
String -> ImpTestM era () -> SpecWith (ImpInit (LedgerSpec era))
disableInConformanceIt String
"Fails when the metadata hash is too big" (ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era)))
-> ImpM (LedgerSpec era) () -> SpecWith (ImpInit (LedgerSpec era))
forall a b. (a -> b) -> a -> b
$ do
      stakePoolParams <- ImpTestM era (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      let maxMetadataHashSize = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ Proxy HASH -> Word
forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
hashSize (Proxy HASH
forall {k} (t :: k). Proxy t
Proxy :: Proxy HASH)
      tooBigSize <- choose (maxMetadataHashSize + 1, maxMetadataHashSize + 50)
      metadataHash <- liftGen $ genByteArray tooBigSize
      url <- arbitrary
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL
                  .~ [ RegPoolTxCert $
                         stakePoolParams & sppMetadataL .~ SJust (PoolMetadata url metadataHash)
                     ]
            ]
        )
        [ injectFailure . DijkstraSubPoolPredFailure $
            PoolMedataHashTooBig (stakePoolParams ^. sppIdL) tooBigSize
        ]
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Pool re-registration" (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
"Fails when re-registering an existing pool with the same VRF as another 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
      stakePoolParams1 <- ImpTestM era (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      let
        vrfKey = StakePoolParams era
stakePoolParams1 StakePoolParams era
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  (StakePoolParams era)
  (VRFVerKeyHash StakePoolVRF)
forall era (f :: * -> *).
Functor f =>
(VRFVerKeyHash StakePoolVRF -> f (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> f (StakePoolParams era)
sppVrfL
      stakePoolParams2 <- freshStakePool
      submitTxAnn_ "Registering the first pool" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL
                .~ [ RegPoolTxCert stakePoolParams1
                   ]
          ]
      submitTxAnn_ "Registering the second pool" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL
                .~ [ RegPoolTxCert stakePoolParams2
                   ]
          ]
      impAnn "Reregistering the second pool" $
        submitFailingTx
          ( mkTopTxWithSubTxs
              [ mkBasicTx mkBasicTxBody
                  & bodyTxL . certsTxBodyL
                    .~ [ RegPoolTxCert $ stakePoolParams2 & sppVrfL .~ vrfKey
                       ]
              ]
          )
          [ injectFailure . DijkstraSubPoolPredFailure $
              VRFKeyHashAlreadyRegistered (stakePoolParams2 ^. sppIdL) vrfKey
          ]
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fails when re-registering an existing pool with an invalid network ID" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      stakePoolParams <- ImpTestM era (StakePoolParams era)
forall era. ShelleyEraImp era => ImpTestM era (StakePoolParams era)
freshStakePool
      submitTxAnn_ "Registering the pool for the first time" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL
                .~ [ RegPoolTxCert stakePoolParams
                   ]
          ]
      impAnn "Reregistering the pool" $
        submitFailingTx
          ( mkTopTxWithSubTxs
              [ mkBasicTx mkBasicTxBody
                  & bodyTxL . certsTxBodyL
                    .~ [ RegPoolTxCert $
                           stakePoolParams
                             & sppAccountAddressL . accountAddressNetworkIdL .~ Mainnet
                       ]
              ]
          )
          [ injectFailure . DijkstraSubPoolPredFailure $
              WrongNetworkPOOL (Mismatch Mainnet Testnet) (stakePoolParams ^. sppIdL)
          ]
    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 a VRF claimed by a re-registration" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spKH <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      stakePoolParams <- freshPoolParams spKH =<< registerAccountAddress
      submitTxAnn_ "Register pool" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert stakePoolParams]
          ]
      newStakePoolParams <- freshPoolParams spKH =<< registerAccountAddress
      let newVrf = StakePoolParams era
newStakePoolParams StakePoolParams era
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  (StakePoolParams era)
  (VRFVerKeyHash StakePoolVRF)
forall era (f :: * -> *).
Functor f =>
(VRFVerKeyHash StakePoolVRF -> f (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> f (StakePoolParams era)
sppVrfL
      submitTxAnn_ "Re-register pool with a fresh VRF" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert newStakePoolParams]
          ]
      otherStakePoolParams <- freshStakePool
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL
                  .~ [RegPoolTxCert $ otherStakePoolParams & sppVrfL .~ newVrf]
            ]
        )
        [ injectFailure . DijkstraSubPoolPredFailure $
            VRFKeyHashAlreadyRegistered (otherStakePoolParams ^. sppIdL) newVrf
        ]
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Re-registering again with a fresh VRF releases the previously claimed 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
      spKH <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      stakePoolParams <- freshPoolParams spKH =<< registerAccountAddress
      submitTxAnn_ "Register pool" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert stakePoolParams]
          ]
      reRegStakePoolParams1 <- freshPoolParams spKH =<< registerAccountAddress
      submitTxAnn_ "Re-register pool with a fresh VRF" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert reRegStakePoolParams1]
          ]
      reRegStakePoolParams2 <- freshPoolParams spKH =<< registerAccountAddress
      submitTxAnn_ "Re-register pool with another fresh VRF" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert reRegStakePoolParams2]
          ]
      otherStakePoolParams <- freshStakePool
      submitTxAnn_ "Register a new pool with the released VRF" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL
                .~ [ RegPoolTxCert $
                       otherStakePoolParams & sppVrfL .~ (reRegStakePoolParams1 ^. sppVrfL)
                   ]
          ]
      anotherStakePoolParams <- freshStakePool
      let claimedVrf = StakePoolParams era
reRegStakePoolParams2 StakePoolParams era
-> Getting
     (VRFVerKeyHash StakePoolVRF)
     (StakePoolParams era)
     (VRFVerKeyHash StakePoolVRF)
-> VRFVerKeyHash StakePoolVRF
forall s a. s -> Getting a s a -> a
^. Getting
  (VRFVerKeyHash StakePoolVRF)
  (StakePoolParams era)
  (VRFVerKeyHash StakePoolVRF)
forall era (f :: * -> *).
Functor f =>
(VRFVerKeyHash StakePoolVRF -> f (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> f (StakePoolParams era)
sppVrfL
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL
                  .~ [RegPoolTxCert $ anotherStakePoolParams & sppVrfL .~ claimedVrf]
            ]
        )
        [ injectFailure . DijkstraSubPoolPredFailure $
            VRFKeyHashAlreadyRegistered (anotherStakePoolParams ^. sppIdL) claimedVrf
        ]
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Tracks the VRF through a sequence of re-registrations" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      khPool <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      accountAddr <- registerAccountAddress
      oldVRF <- arbitrary
      pps <- freshPoolParams khPool accountAddr
      let
        oldPPS = StakePoolParams era
pps StakePoolParams era
-> (StakePoolParams era -> StakePoolParams era)
-> StakePoolParams era
forall a b. a -> (a -> b) -> b
& (VRFVerKeyHash StakePoolVRF
 -> Identity (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> Identity (StakePoolParams era)
forall era (f :: * -> *).
Functor f =>
(VRFVerKeyHash StakePoolVRF -> f (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> f (StakePoolParams era)
sppVrfL ((VRFVerKeyHash StakePoolVRF
  -> Identity (VRFVerKeyHash StakePoolVRF))
 -> StakePoolParams era -> Identity (StakePoolParams era))
-> VRFVerKeyHash StakePoolVRF
-> StakePoolParams era
-> StakePoolParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ VRFVerKeyHash StakePoolVRF
oldVRF
      submitTxAnn_ "Registering a new stake pool" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert oldPPS]
          ]
      expectStakePoolParams khPool $ Just oldPPS
      newVRF <- arbitrary
      let
        newPPS = StakePoolParams era
pps StakePoolParams era
-> (StakePoolParams era -> StakePoolParams era)
-> StakePoolParams era
forall a b. a -> (a -> b) -> b
& (VRFVerKeyHash StakePoolVRF
 -> Identity (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> Identity (StakePoolParams era)
forall era (f :: * -> *).
Functor f =>
(VRFVerKeyHash StakePoolVRF -> f (VRFVerKeyHash StakePoolVRF))
-> StakePoolParams era -> f (StakePoolParams era)
sppVrfL ((VRFVerKeyHash StakePoolVRF
  -> Identity (VRFVerKeyHash StakePoolVRF))
 -> StakePoolParams era -> Identity (StakePoolParams era))
-> VRFVerKeyHash StakePoolVRF
-> StakePoolParams era
-> StakePoolParams era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ VRFVerKeyHash StakePoolVRF
newVRF
      submitTxAnn_ "Change VRF key" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert newPPS]
          ]
      expectStakePoolParams khPool $ Just oldPPS
      do
        Just futureParams <- lookupFutureStakePoolParams khPool
        futureParams ^. sppVrfL `shouldBe` newPPS ^. sppVrfL
      let maxMetadataHashSize = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Int) -> Word -> Int
forall a b. (a -> b) -> a -> b
$ Proxy HASH -> Word
forall h (proxy :: * -> *). HashAlgorithm h => proxy h -> Word
hashSize (Proxy HASH
forall {k} (t :: k). Proxy t
Proxy :: Proxy HASH)
      metadataHashSize <- choose (0, maxMetadataHashSize)
      newMetadata <- PoolMetadata <$> arbitrary <*> liftGen (genByteArray metadataHashSize)
      submitTxAnn_ "Same VRF key" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert $ newPPS & sppMetadataL .~ SJust newMetadata]
          ]
      Just futureParams <- lookupFutureStakePoolParams khPool
      futureParams ^. sppVrfL `shouldBe` newPPS ^. sppVrfL
      futureParams ^. sppMetadataL `shouldBe` SJust newMetadata
      submitTxAnn_ "Back to the active VRF key" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert oldPPS]
          ]
      anotherVRF <- arbitrary
      submitTxAnn_ "Another VRF key" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert $ pps & sppVrfL .~ anotherVRF]
          ]
      -- The pool keeps using its active VRF key until the epoch boundary, so it must stay taken
      otherPPS <- freshStakePool
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL .~ [RegPoolTxCert $ otherPPS & sppVrfL .~ oldVRF]
            ]
        )
        [ injectFailure . DijkstraSubPoolPredFailure $
            VRFKeyHashAlreadyRegistered (otherPPS ^. sppIdL) oldVRF
        ]
  String
-> SpecWith (ImpInit (LedgerSpec era))
-> SpecWith (ImpInit (LedgerSpec era))
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"Pool retirement" (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
"Fails when pool is not registered" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spKH <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      currentEpoch <- getsNES nesELL
      EpochNo maxEpoch <- addEpochInterval currentEpoch <$> getsPParams ppEMaxL
      retireEpoch <- EpochNo <$> choose (succ $ unEpochNo currentEpoch, maxEpoch)
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert spKH retireEpoch]
            ]
        )
        [ injectFailure . DijkstraSubPoolPredFailure $
            StakePoolNotRegisteredOnKeyPOOL spKH
        ]
    String
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"Fails when retirement epoch is outside valid range" (ImpM (LedgerSpec era) ()
 -> SpecWith (Arg (ImpM (LedgerSpec era) ())))
-> ImpM (LedgerSpec era) ()
-> SpecWith (Arg (ImpM (LedgerSpec era) ()))
forall a b. (a -> b) -> a -> b
$ do
      spKH <- ImpM (LedgerSpec era) (KeyHash StakePool)
forall (r :: KeyRole) s g (m :: * -> *).
(HasKeyPairs s, MonadState s m, HasStatefulGen g m) =>
m (KeyHash r)
freshKeyHash
      stakePoolParams <- freshPoolParams spKH =<< registerAccountAddress
      submitTxAnn_ "Registering a stake pool" $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL .~ [RegPoolTxCert stakePoolParams]
          ]
      expectStakePoolParams spKH $ Just stakePoolParams
      currentEpoch <- getsNES nesELL
      maxEpoch <- addEpochInterval currentEpoch <$> getsPParams ppEMaxL
      retireEpoch <-
        frequency
          [ (1, pure $ succ maxEpoch)
          , (1, pure currentEpoch)
          , (49, EpochNo <$> choose (0, unEpochNo currentEpoch))
          , (49, EpochNo <$> choose (unEpochNo $ succ maxEpoch, maxBound))
          ]
      submitFailingTx
        ( mkTopTxWithSubTxs
            [ mkBasicTx mkBasicTxBody
                & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert spKH retireEpoch]
            ]
        )
        [ injectFailure . DijkstraSubPoolPredFailure $
            StakePoolRetirementWrongEpochPOOL
              (Mismatch retireEpoch currentEpoch)
              (Mismatch retireEpoch maxEpoch)
        ]
  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 :: ImpM (LedgerSpec era) (Map (KeyHash StakePool) StakePoolState)
getPools = 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

    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 . DijkstraSubPoolPredFailure $
            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 . DijkstraSubPoolPredFailure $
            BlsKeyInvalidProofOfPossession (sppId pps) invalidOwnerBlsKey
        ]
      pools <- getPools
      expectNothing $ Map.lookup (sppId pps) pools

  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 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)
      submitTx_ =<< retirePoolTx kh (EpochInterval 1)
      expectBlsKeys [key]
      expectBlsKeyTakenByNewPool key
      passEpoch
      expectNoPool kh
      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
"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 . DijkstraSubPoolPredFailure $ BlsKeyInvalidProofOfPossession kh bogusKey
        , injectFailure . DijkstraSubPoolPredFailure $ BlsKeyAlreadyRegistered kh bogusKey
        ]
      expectBlsKeys [key]
  where
    registerPoolTx :: StakePoolParams era -> Tx TopTx era
registerPoolTx StakePoolParams era
pps =
      [Tx SubTx era] -> Tx TopTx era
forall era. DijkstraEraImp era => [Tx SubTx era] -> Tx TopTx era
mkTopTxWithSubTxs
        [ TxBody SubTx era -> Tx SubTx era
forall era (l :: TxLevel). EraTx era => TxBody l era -> Tx l era
forall (l :: TxLevel). TxBody l era -> Tx l era
mkBasicTx TxBody SubTx era
forall era (l :: TxLevel).
(EraTxBody era, Typeable l) =>
TxBody l era
forall (l :: TxLevel). Typeable l => TxBody l era
mkBasicTxBody
            Tx SubTx era -> (Tx SubTx era -> Tx SubTx era) -> Tx SubTx era
forall a b. a -> (a -> b) -> b
& (TxBody SubTx era -> Identity (TxBody SubTx era))
-> Tx SubTx era -> Identity (Tx SubTx 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 SubTx era -> Identity (TxBody SubTx era))
 -> Tx SubTx era -> Identity (Tx SubTx era))
-> ((StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
    -> TxBody SubTx era -> Identity (TxBody SubTx era))
-> (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> Tx SubTx era
-> Identity (Tx SubTx era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictSeq (TxCert era) -> Identity (StrictSeq (TxCert era)))
-> TxBody SubTx era -> Identity (TxBody SubTx 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 SubTx era -> Identity (Tx SubTx era))
-> StrictSeq (TxCert era) -> Tx SubTx era -> Tx SubTx era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [StakePoolParams era -> TxCert era
forall era. EraTxCert era => StakePoolParams era -> TxCert era
RegPoolTxCert StakePoolParams era
pps]
        ]
    retirePoolTx :: KeyHash StakePool
-> EpochInterval -> ImpM (LedgerSpec era) (Tx TopTx 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 $
        mkTopTxWithSubTxs
          [ mkBasicTx mkBasicTxBody
              & bodyTxL . certsTxBodyL
                .~ [RetirePoolTxCert kh (addEpochInterval curEpochNo retirementInterval)]
          ]
    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}
      submitTxAnn_ "Registering a new stake pool" $
        registerPoolTx ppsWithBlsKey
      pure ppsWithBlsKey
    expectNoPool :: KeyHash StakePool -> ImpM (LedgerSpec era) ()
expectNoPool KeyHash StakePool
poolKh = 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
      expectNothing $ Map.lookup poolKh pools
    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 <- ImpM (LedgerSpec era) AccountAddress
forall era.
(HasCallStack, ShelleyEraImp era) =>
ImpTestM era AccountAddress
registerAccountAddress ImpM (LedgerSpec 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
>>= Tx TopTx era -> ImpM (LedgerSpec era) ()
forall era.
(HasCallStack, ShelleyEraImp era) =>
Tx TopTx era -> ImpTestM era ()
submitTx_ (Tx TopTx era -> ImpM (LedgerSpec era) ())
-> (StakePoolParams era -> Tx TopTx era)
-> StakePoolParams era
-> ImpM (LedgerSpec era) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakePoolParams era -> Tx TopTx era
forall {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,
 PredicateFailure (EraRule "MEMPOOL" era)
 ~ EraRuleFailure "MEMPOOL" 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 ...),
 DijkstraEraImp era, ToExpr (EraRuleFailure "BBODY" era),
 ToExpr (EraRuleFailure "LEDGER" era),
 EncCBOR (EraRuleFailure "BBODY" era),
 EncCBOR (EraRuleFailure "LEDGER" era),
 Ord (EraRuleFailure "BBODY" era),
 Ord (EraRuleFailure "LEDGER" era),
 NFData (EraRuleFailure "BBODY" era),
 NFData (EraRuleFailure "LEDGER" era),
 Show (EraRuleFailure "BBODY" era),
 Show (EraRuleFailure "LEDGER" era),
 DecCBOR (EraRuleFailure "BBODY" era),
 DecCBOR (EraRuleFailure "LEDGER" era),
 Inject (NonEmpty (EraRuleFailure "LEDGER" era)) (ApplyTxError era),
 Inject
   (NonEmpty (EraRuleFailure "MEMPOOL" era)) (ApplyTxError era)) =>
StakePoolParams era -> Tx TopTx era
registerPoolTx
    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)
-> 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
      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}.
(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,
 PredicateFailure (EraRule "MEMPOOL" era)
 ~ EraRuleFailure "MEMPOOL" 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 ...),
 DijkstraEraImp era, ToExpr (EraRuleFailure "BBODY" era),
 ToExpr (EraRuleFailure "LEDGER" era),
 EncCBOR (EraRuleFailure "BBODY" era),
 EncCBOR (EraRuleFailure "LEDGER" era),
 Ord (EraRuleFailure "BBODY" era),
 Ord (EraRuleFailure "LEDGER" era),
 NFData (EraRuleFailure "BBODY" era),
 NFData (EraRuleFailure "LEDGER" era),
 Show (EraRuleFailure "BBODY" era),
 Show (EraRuleFailure "LEDGER" era),
 DecCBOR (EraRuleFailure "BBODY" era),
 DecCBOR (EraRuleFailure "LEDGER" era),
 Inject (NonEmpty (EraRuleFailure "LEDGER" era)) (ApplyTxError era),
 Inject
   (NonEmpty (EraRuleFailure "MEMPOOL" era)) (ApplyTxError era)) =>
StakePoolParams era -> Tx TopTx 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 . DijkstraSubPoolPredFailure $ 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