Adjust Shelley PoolSpec for Dijkstra era

* Move tests that are reliant on certs w/out deposits and only run them pre-Dijkstra

Author: Lucsanszky

eras/allegra/impl/testlib/Test/Cardano/Ledger/Allegra/Imp.hs

@@ -34,4 +34,5 @@ spec = do
   describe "AllegraImpSpec" . withEachEraVersion @era $
     UtxowSpec.spec
 
-instance EraSpecificSpec AllegraEra
+instance EraSpecificSpec AllegraEra where
+  eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec

eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Imp.hs

@@ -27,6 +27,7 @@ import qualified Test.Cardano.Ledger.Alonzo.Imp.UtxowSpec as Utxow
 import Test.Cardano.Ledger.Alonzo.ImpTest
 import Test.Cardano.Ledger.Imp.Common
 import qualified Test.Cardano.Ledger.Mary.Imp as MaryImp
+import qualified Test.Cardano.Ledger.Shelley.Imp.PoolSpec as ShelleyImp
 
 spec ::
   forall era.
@@ -63,4 +64,4 @@ alonzoEraSpecificSpec = do
       Utxow.alonzoEraSpecificSpec
 
 instance EraSpecificSpec AlonzoEra where
-  eraSpecificSpec = alonzoEraSpecificSpec
+  eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec >> alonzoEraSpecificSpec

eras/babbage/impl/testlib/Test/Cardano/Ledger/Babbage/Imp.hs

@@ -6,7 +6,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Test.Cardano.Ledger.Babbage.Imp (spec) where
+module Test.Cardano.Ledger.Babbage.Imp (spec, babbageEraSpecificSpec) where
 
 import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
 import Cardano.Ledger.Alonzo.Rules (
@@ -15,12 +15,11 @@ import Cardano.Ledger.Alonzo.Rules (
   AlonzoUtxowPredFailure,
  )
 import Cardano.Ledger.Babbage (BabbageEra)
-import Cardano.Ledger.Babbage.Core (BabbageEraTxBody, InjectRuleFailure)
+import Cardano.Ledger.Babbage.Core (BabbageEraTxBody, InjectRuleFailure, ShelleyEraTxCert)
 import Cardano.Ledger.Babbage.Rules (BabbageUtxoPredFailure, BabbageUtxowPredFailure)
 import Cardano.Ledger.Babbage.TxInfo (BabbageContextError)
 import Cardano.Ledger.BaseTypes (Inject)
 import Cardano.Ledger.Shelley.Rules (
-  ShelleyDelegPredFailure,
   ShelleyPoolPredFailure,
   ShelleyUtxoPredFailure,
   ShelleyUtxowPredFailure,
@@ -31,13 +30,13 @@ import qualified Test.Cardano.Ledger.Babbage.Imp.UtxoSpec as Utxo
 import qualified Test.Cardano.Ledger.Babbage.Imp.UtxosSpec as Utxos
 import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
 import Test.Cardano.Ledger.Imp.Common
+import qualified Test.Cardano.Ledger.Shelley.Imp.PoolSpec as ShelleyImp
 
 spec ::
   forall era.
   ( AlonzoEraImp era
   , EraSpecificSpec era
   , BabbageEraTxBody era
-  , InjectRuleFailure "LEDGER" ShelleyDelegPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
@@ -57,7 +56,20 @@ spec = do
       Utxow.spec
       Utxos.spec @era
 
+babbageEraSpecificSpec ::
+  forall era.
+  ( AlonzoEraImp era
+  , ShelleyEraTxCert era
+  , BabbageEraTxBody era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+babbageEraSpecificSpec = do
+  describe "Babbage era specific Imp spec" $
+    describe "Certificates without deposits" $
+      describe "UTXOW" Utxow.babbageEraSpecificSpec
+
 instance EraSpecificSpec BabbageEra where
   eraSpecificSpec =
-    AlonzoImp.alonzoEraSpecificSpec
-      >> Utxow.babbageEraSpecificSpec
+    ShelleyImp.shelleyEraSpecificSpec
+      >> AlonzoImp.alonzoEraSpecificSpec
+      >> babbageEraSpecificSpec

eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Imp.hs

@@ -59,6 +59,7 @@ import qualified Test.Cardano.Ledger.Conway.Imp.UtxosSpec as Utxos
 import qualified Test.Cardano.Ledger.Conway.Imp.UtxowSpec as Utxow
 import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Imp.Common
+import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp
 
 spec ::
   forall era.
@@ -156,5 +157,7 @@ conwayEraSpecificSpec = do
 
 instance EraSpecificSpec ConwayEra where
   eraSpecificSpec =
-    AlonzoImp.alonzoEraSpecificSpec
+    ShelleyImp.shelleyEraSpecificSpec
+      >> AlonzoImp.alonzoEraSpecificSpec
+      >> BabbageImp.babbageEraSpecificSpec
       >> conwayEraSpecificSpec

eras/dijkstra/testlib/Test/Cardano/Ledger/Dijkstra/Imp.hs

@@ -37,6 +37,7 @@ spec ::
   , InjectRuleFailure "LEDGER" AlonzoUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxowPredFailure era
+  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxoPredFailure era
   , InjectRuleFailure "LEDGER" ShelleyUtxowPredFailure era
   , InjectRuleFailure "LEDGER" ConwayDelegPredFailure era

eras/mary/impl/testlib/Test/Cardano/Ledger/Mary/Imp.hs

@@ -19,6 +19,7 @@ import qualified Test.Cardano.Ledger.Allegra.Imp as AllegraImp
 import Test.Cardano.Ledger.Imp.Common
 import qualified Test.Cardano.Ledger.Mary.Imp.UtxoSpec as Utxo
 import Test.Cardano.Ledger.Mary.ImpTest
+import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp
 
 spec ::
   forall era.
@@ -35,4 +36,5 @@ spec = do
     withEachEraVersion @era $
       Utxo.spec
 
-instance EraSpecificSpec MaryEra
+instance EraSpecificSpec MaryEra where
+  eraSpecificSpec = ShelleyImp.shelleyEraSpecificSpec

eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
-module Test.Cardano.Ledger.Shelley.Imp (spec) where
+module Test.Cardano.Ledger.Shelley.Imp (spec, shelleyEraSpecificSpec) where
 
 import Cardano.Ledger.Core
 import Cardano.Ledger.Shelley (ShelleyEra)
@@ -14,6 +14,7 @@ import Cardano.Ledger.Shelley.Rules (
   ShelleyUtxoPredFailure,
   ShelleyUtxowPredFailure,
  )
+import Cardano.Ledger.Shelley.TxCert (ShelleyEraTxCert)
 import Test.Cardano.Ledger.Imp.Common
 import qualified Test.Cardano.Ledger.Shelley.Imp.EpochSpec as Epoch
 import qualified Test.Cardano.Ledger.Shelley.Imp.LedgerSpec as Ledger
@@ -43,4 +44,16 @@ spec = do
   describe "ShelleyPureTests" $ do
     Instant.spec @era
 
-instance EraSpecificSpec ShelleyEra
+shelleyEraSpecificSpec ::
+  ( ShelleyEraImp era
+  , ShelleyEraTxCert era
+  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+shelleyEraSpecificSpec = do
+  describe "Shelley era specific Imp spec" $
+    describe "Certificates without deposits" $ do
+      describe "POOL" Pool.shelleyEraSpecificSpec
+
+instance EraSpecificSpec ShelleyEra where
+  eraSpecificSpec = shelleyEraSpecificSpec

eras/shelley/impl/testlib/Test/Cardano/Ledger/Shelley/Imp/PoolSpec.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
 
-module Test.Cardano.Ledger.Shelley.Imp.PoolSpec (spec) where
+module Test.Cardano.Ledger.Shelley.Imp.PoolSpec (spec, shelleyEraSpecificSpec) where
 
 import Cardano.Crypto.Hash.Class (sizeHash)
 import Cardano.Ledger.Address (RewardAccount (..))
@@ -15,7 +15,8 @@ import Cardano.Ledger.Core
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Shelley.LedgerState
 import Cardano.Ledger.Shelley.Rules (ShelleyPoolPredFailure (..))
-import Cardano.Ledger.State (PoolMetadata (..), ppCostL, ppMetadataL, ppVrfL, spsVrf)
+import Cardano.Ledger.Shelley.TxCert (ShelleyEraTxCert)
+import Cardano.Ledger.State (PoolMetadata (..), PoolParams, ppCostL, ppMetadataL, ppVrfL, spsVrf)
 import qualified Data.Map.Strict as Map
 import Data.Proxy
 import Lens.Micro
@@ -31,16 +32,6 @@ spec ::
   SpecWith (ImpInit (LedgerSpec era))
 spec = describe "POOL" $ do
   describe "Register and re-register pools" $ do
-    it "register a pool with too low cost" $ do
-      (kh, vrf) <- (,) <$> freshKeyHash <*> freshKeyHashVRF
-      minPoolCost <- getsPParams ppMinPoolCostL
-      tooLowCost <- Coin <$> choose (0, unCoin minPoolCost)
-      let pps = (\p -> p & ppCostL .~ tooLowCost) <$> poolParams kh vrf
-      registerPoolTx <$> pps >>= \tx ->
-        submitFailingTx
-          tx
-          [injectFailure $ StakePoolCostTooLowPOOL $ Mismatch tooLowCost minPoolCost]
-
     it "register a pool with a reward account having the wrong network id" $ do
       pv <- getsPParams ppProtocolVersionL
       rewardCredential <- KeyHashObj <$> freshKeyHash
@@ -58,6 +49,31 @@ spec = describe "POOL" $ do
           else
             submitFailingTx tx [injectFailure $ WrongNetworkPOOL (Mismatch Mainnet Testnet) kh]
 
+  describe "Retiring pools" $ do
+    it "retire an unregistered pool" $ do
+      khNew <- freshKeyHash
+      retirePoolTx khNew (EpochInterval 10) >>= \tx ->
+        submitFailingTx tx [injectFailure $ StakePoolNotRegisteredOnKeyPOOL khNew]
+
+shelleyEraSpecificSpec ::
+  forall era.
+  ( ShelleyEraImp era
+  , ShelleyEraTxCert era
+  , InjectRuleFailure "LEDGER" ShelleyPoolPredFailure era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+shelleyEraSpecificSpec = describe "POOL" $ do
+  describe "Register and re-register pools" $ do
+    it "register a pool with too low cost" $ do
+      (kh, vrf) <- (,) <$> freshKeyHash <*> freshKeyHashVRF
+      minPoolCost <- getsPParams ppMinPoolCostL
+      tooLowCost <- Coin <$> choose (0, unCoin minPoolCost)
+      let pps = (\p -> p & ppCostL .~ tooLowCost) <$> poolParams kh vrf
+      registerPoolTx <$> pps >>= \tx ->
+        submitFailingTx
+          tx
+          [injectFailure $ StakePoolCostTooLowPOOL $ Mismatch tooLowCost minPoolCost]
+
     it "register a pool with too big metadata" $ do
       pv <- getsPParams ppProtocolVersionL
       let maxMetadataSize = sizeHash (Proxy :: Proxy HASH)
@@ -197,11 +213,6 @@ spec = describe "POOL" $ do
             submitFailingTx tx [injectFailure $ VRFKeyHashAlreadyRegistered khNew vrf]
 
   describe "Retiring pools" $ do
-    it "retire an unregistered pool" $ do
-      khNew <- freshKeyHash
-      retirePoolTx khNew (EpochInterval 10) >>= \tx ->
-        submitFailingTx tx [injectFailure $ StakePoolNotRegisteredOnKeyPOOL khNew]
-
     it "retire a pool with too high a retirement epoch" $ do
       (kh, _) <- registerNewPool
       maxRetireInterval <- getsPParams ppEMaxL
@@ -322,15 +333,6 @@ spec = describe "POOL" $ do
       registerPoolTx <$> poolParams kh vrf >>= submitTx_
       expectPool kh (Just vrf)
       pure (kh, vrf)
-    registerPoolTx pps =
-      mkBasicTx mkBasicTxBody
-        & bodyTxL . certsTxBodyL .~ [RegPoolTxCert pps]
-    retirePoolTx kh retirementInterval = do
-      curEpochNo <- getsNES nesELL
-      let retirement = addEpochInterval curEpochNo retirementInterval
-      pure $
-        mkBasicTx mkBasicTxBody
-          & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert kh retirement]
     expectPool poolKh mbVrf = do
       pps <- psStakePools <$> getPState
       spsVrf <$> Map.lookup poolKh pps `shouldBe` mbVrf
@@ -349,3 +351,17 @@ spec = describe "POOL" $ do
       pps <- registerRewardAccount >>= freshPoolParams kh
       pure $ pps & ppVrfL .~ vrf
     getPState = getsNES @era $ nesEsL . esLStateL . lsCertStateL . certPStateL
+
+registerPoolTx :: ShelleyEraImp era => PoolParams -> Tx era
+registerPoolTx pps =
+  mkBasicTx mkBasicTxBody
+    & bodyTxL . certsTxBodyL .~ [RegPoolTxCert pps]
+
+retirePoolTx ::
+  ShelleyEraImp era => KeyHash 'StakePool -> EpochInterval -> ImpM (LedgerSpec era) (Tx era)
+retirePoolTx kh retirementInterval = do
+  curEpochNo <- getsNES nesELL
+  let retirement = addEpochInterval curEpochNo retirementInterval
+  pure $
+    mkBasicTx mkBasicTxBody
+      & bodyTxL . certsTxBodyL .~ [RetirePoolTxCert kh retirement]