Add shelley-specific DELEG tests

and run them in all eras until Conway

Author: teodanciu

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

@@ -20,4 +20,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

@@ -16,6 +16,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 as ShelleyImp
 
 spec ::
   forall era.
@@ -40,4 +41,5 @@ alonzoEraSpecificSpec = do
       Utxow.alonzoEraSpecificSpec
 
 instance EraSpecificSpec AlonzoEra where
-  eraSpecificSpec = alonzoEraSpecificSpec
+  eraSpecificSpec =
+    ShelleyImp.shelleyEraSpecificSpec >> alonzoEraSpecificSpec

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

@@ -16,6 +16,7 @@ import qualified Test.Cardano.Ledger.Babbage.Imp.UtxosSpec as Utxos
 import qualified Test.Cardano.Ledger.Babbage.Imp.UtxowSpec as Utxow
 import Test.Cardano.Ledger.Babbage.ImpTest (BabbageEraImp)
 import Test.Cardano.Ledger.Imp.Common
+import qualified Test.Cardano.Ledger.Shelley.Imp as ShelleyImp
 
 spec :: forall era. (BabbageEraImp era, EraSpecificSpec era) => Spec
 spec = do
@@ -28,4 +29,4 @@ spec = do
 
 instance EraSpecificSpec BabbageEra where
   eraSpecificSpec =
-    AlonzoImp.alonzoEraSpecificSpec
+    ShelleyImp.shelleyEraSpecificSpec >> AlonzoImp.alonzoEraSpecificSpec

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

@@ -73,10 +73,9 @@ conwayEraGenericSpec = do
 
 conwayEraSpecificSpec :: SpecWith (ImpInit (LedgerSpec ConwayEra))
 conwayEraSpecificSpec = do
-  describe "Conway era specific Imp spec" $
-    describe "Certificates without deposits" $ do
-      describe "DELEG" Deleg.conwayEraSpecificSpec
-      describe "UTXO" Utxo.conwayEraSpecificSpec
+  describe "Conway era specific Imp spec" $ do
+    describe "DELEG" Deleg.conwayEraSpecificSpec
+    describe "UTXO" Utxo.conwayEraSpecificSpec
 
 instance EraSpecificSpec ConwayEra where
   eraSpecificSpec =

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

@@ -13,6 +13,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. (MaryEraImp era, EraSpecificSpec era) => Spec
 spec = do
@@ -21,4 +22,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,9 +5,11 @@
 {-# 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.Shelley (ShelleyEra)
+import Cardano.Ledger.Shelley.Core
+import Cardano.Ledger.Shelley.Rules
 import Test.Cardano.Ledger.Imp.Common
 import qualified Test.Cardano.Ledger.Shelley.Imp.DelegSpec as Deleg
 import qualified Test.Cardano.Ledger.Shelley.Imp.EpochSpec as Epoch
@@ -36,4 +38,17 @@ spec = do
   describe "ShelleyPureTests" $ do
     Instant.spec @era
 
-instance EraSpecificSpec ShelleyEra
+shelleyEraSpecificSpec ::
+  forall era.
+  ( ShelleyEraImp era
+  , InjectRuleFailure "LEDGER" ShelleyDelegsPredFailure era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+shelleyEraSpecificSpec = do
+  describe "Shelley era specific Imp spec" $
+    describe "DELEG" $
+      Deleg.shelleyEraSpecificSpec
+
+instance EraSpecificSpec ShelleyEra where
+  eraSpecificSpec =
+    describe "DELEG" Deleg.shelleyEraSpecificSpec

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

@@ -8,19 +8,98 @@
 {-# LANGUAGE TypeFamilies #-}
 
 module Test.Cardano.Ledger.Shelley.Imp.DelegSpec (
+  shelleyEraSpecificSpec,
   spec,
 ) where
 
 import Cardano.Ledger.BaseTypes
+import Cardano.Ledger.Coin (Coin (Coin))
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Shelley.Core
 import Cardano.Ledger.Shelley.Rules
 import Cardano.Ledger.Shelley.Scripts
+import qualified Data.Map.Strict as Map
 import Lens.Micro
 import Test.Cardano.Ledger.Imp.Common
 import Test.Cardano.Ledger.Shelley.Arbitrary ()
 import Test.Cardano.Ledger.Shelley.ImpTest
 
+shelleyEraSpecificSpec ::
+  ( ShelleyEraImp era
+  , InjectRuleFailure "LEDGER" ShelleyDelegsPredFailure era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+shelleyEraSpecificSpec = do
+  it "Twice the same certificate in the same transaction" $ do
+    freshKeyHash >>= \kh -> do
+      regTxCert <- genRegTxCert (KeyHashObj kh)
+      submitFailingTx
+        ( mkBasicTx mkBasicTxBody
+            & bodyTxL . certsTxBodyL
+              .~ [regTxCert, regTxCert]
+        )
+        [injectFailure $ StakeKeyAlreadyRegisteredDELEG (KeyHashObj kh)]
+      expectStakeCredNotRegistered (KeyHashObj kh)
+
+  it "Delegate to unregistered pool" $ do
+    cred <- KeyHashObj <$> freshKeyHash
+    regTxCert <- genRegTxCert cred
+    submitTx_ $
+      mkBasicTx mkBasicTxBody
+        & bodyTxL . certsTxBodyL .~ [regTxCert]
+
+    poolKh <- freshKeyHash
+    submitFailingTx
+      ( mkBasicTx mkBasicTxBody
+          & bodyTxL . certsTxBodyL .~ [delegStakeTxCert cred poolKh]
+      )
+      [injectFailure $ DelegateeNotRegisteredDELEG poolKh]
+    expectNotDelegatedToPool cred
+
+  it "Deregistering returns the deposit" $ do
+    let keyDeposit = Coin 2
+    -- This is paid out as the reward
+    let poolDeposit = Coin 3
+    modifyPParams $ \pp ->
+      pp
+        & ppKeyDepositL .~ keyDeposit
+        & ppPoolDepositL .~ poolDeposit
+    stakeCred <- KeyHashObj <$> freshKeyHash
+    rewardAccount <- getRewardAccountFor stakeCred
+    otherStakeCred <- KeyHashObj <$> freshKeyHash
+    otherRewardAccount <- getRewardAccountFor otherStakeCred
+    khStakePool <- freshKeyHash
+    registerPool khStakePool
+    stakeCredRegTxCert <- genRegTxCert stakeCred
+    otherStakeCredRegTxCert <- genRegTxCert otherStakeCred
+    submitTx_ . mkBasicTx $
+      mkBasicTxBody
+        & certsTxBodyL
+          .~ [ stakeCredRegTxCert
+             , delegStakeTxCert stakeCred khStakePool
+             , otherStakeCredRegTxCert
+             , delegStakeTxCert otherStakeCred khStakePool
+             ]
+    expectRegisteredRewardAddress rewardAccount
+    expectRegisteredRewardAddress otherRewardAccount
+    registerAndRetirePoolToMakeReward otherStakeCred
+
+    getBalance otherStakeCred `shouldReturn` poolDeposit
+    unRegTxCert <- genUnRegTxCert stakeCred
+
+    submitTx_ . mkBasicTx $
+      mkBasicTxBody
+        & certsTxBodyL .~ [unRegTxCert]
+        & withdrawalsTxBodyL
+          .~ Withdrawals
+            ( Map.fromList
+                [ (rewardAccount, Coin 0)
+                , (otherRewardAccount, poolDeposit)
+                ]
+            )
+    getBalance otherStakeCred `shouldReturn` Coin 0
+    expectNotRegisteredRewardAddress rewardAccount
+
 spec ::
   ShelleyEraImp era =>
   SpecWith (ImpInit (LedgerSpec era))