WIP - UtxoSpec

Author: Lucsanszky

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

@@ -50,7 +50,7 @@ import qualified Test.Cardano.Ledger.Conway.Imp.GovCertSpec as GovCert
 import qualified Test.Cardano.Ledger.Conway.Imp.GovSpec as Gov
 import qualified Test.Cardano.Ledger.Conway.Imp.LedgerSpec as Ledger
 import qualified Test.Cardano.Ledger.Conway.Imp.RatifySpec as Ratify
--- import qualified Test.Cardano.Ledger.Conway.Imp.UtxoSpec as Utxo
+import qualified Test.Cardano.Ledger.Conway.Imp.UtxoSpec as Utxo
 -- import qualified Test.Cardano.Ledger.Conway.Imp.UtxosSpec as Utxos
 import Test.Cardano.Ledger.Conway.ImpTest (
   ConwayEraImp,
@@ -138,6 +138,6 @@ conwaySpec = do
   describe "GOVCERT" GovCert.spec
   describe "LEDGER" Ledger.spec
   describe "RATIFY" Ratify.spec
+  describe "UTXO" Utxo.spec
 
--- describe "UTXO" Utxo.spec
 -- describe "UTXOS" Utxos.spec

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

@@ -8,7 +8,10 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Test.Cardano.Ledger.Conway.Imp.UtxoSpec (spec) where
+module Test.Cardano.Ledger.Conway.Imp.UtxoSpec (
+  spec,
+  shelleyCertsSpec,
+) where
 
 import Cardano.Ledger.Address
 import Cardano.Ledger.Alonzo.Plutus.Context (EraPlutusContext (..))
@@ -45,7 +48,6 @@ import Test.Cardano.Ledger.Plutus.Examples (alwaysSucceedsNoDatum, inputsOverlap
 spec ::
   forall era.
   ( ConwayEraImp era
-  , ShelleyEraTxCert era
   , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
   , InjectRuleFailure "LEDGER" AlonzoUtxosPredFailure era
   , Inject (ConwayContextError era) (ContextError era)
@@ -73,14 +75,16 @@ spec = do
           mkBasicTx mkBasicTxBody
             & bodyTxL . certsTxBodyL
               .~ SSeq.fromList
+                -- NOTE: we might not want to do all this again,
+                -- as we already do it for all eras pre-dijkstra in `shelleyCertsSpec`
                 [ RegPoolTxCert poolParams
                 , RegDRepTxCert dRepCred dRepDeposit anchor
                 , RegDepositDelegTxCert cred0 delegatee accountDeposit
-                , RegTxCert cred1
+                , RegDepositTxCert cred1 accountDeposit
                 , RegDepositTxCert cred2 accountDeposit
                 , RegDepositTxCert cred3 accountDeposit
-                , UnRegTxCert cred2
                 , UnRegDepositTxCert cred1 accountDeposit
+                , UnRegDepositTxCert cred2 accountDeposit
                 , RegDepositTxCert cred4 accountDeposit
                 ]
       utxoAfterRegister <- getUTxO
@@ -107,7 +111,7 @@ spec = do
               .~ SSeq.fromList
                 [ RetirePoolTxCert poolId (succ curEpochNo)
                 , UnRegDRepTxCert dRepCred dRepDeposit
-                , UnRegTxCert cred3
+                , UnRegDepositTxCert cred3 accountDeposit
                 , UnRegDepositTxCert cred4 accountDeposit
                 ]
       utxoAfterUnRegister <- getUTxO
@@ -179,3 +183,79 @@ spec = do
         [ injectFailure $
             CollectErrors [BadTranslation . inject $ ReferenceInputsNotDisjointFromInputs @era [txIn]]
         ]
+
+shelleyCertsSpec ::
+  forall era.
+  ( ConwayEraImp era
+  , ShelleyEraTxCert era
+  ) =>
+  SpecWith (ImpInit (LedgerSpec era))
+shelleyCertsSpec = do
+  describe "Certificates" $ do
+    it "Reg/UnReg collect and refund correct amounts" $ do
+      utxoStart <- getUTxO
+      accountDeposit <- getsPParams ppKeyDepositL
+      stakePoolDeposit <- getsPParams ppPoolDepositL
+      dRepDeposit <- getsPParams ppDRepDepositL
+      cred0 <- KeyHashObj <$> freshKeyHash @'Staking
+      cred1 <- KeyHashObj <$> freshKeyHash @'Staking
+      cred2 <- KeyHashObj <$> freshKeyHash @'Staking
+      cred3 <- KeyHashObj <$> freshKeyHash @'Staking
+      cred4 <- KeyHashObj <$> freshKeyHash @'Staking
+      poolId <- freshKeyHash
+      poolParams <- freshPoolParams poolId (RewardAccount Testnet cred0)
+      dRepCred <- KeyHashObj <$> freshKeyHash @'DRepRole
+      let delegatee = DelegStakeVote poolId (DRepCredential dRepCred)
+      anchor <- arbitrary
+      txRegister <-
+        submitTx $
+          mkBasicTx mkBasicTxBody
+            & bodyTxL . certsTxBodyL
+              .~ SSeq.fromList
+                [ RegPoolTxCert poolParams
+                , RegDRepTxCert dRepCred dRepDeposit anchor
+                , RegDepositDelegTxCert cred0 delegatee accountDeposit
+                , RegTxCert cred1
+                , RegDepositTxCert cred2 accountDeposit
+                , RegDepositTxCert cred3 accountDeposit
+                , UnRegTxCert cred2
+                , UnRegDepositTxCert cred1 accountDeposit
+                , RegDepositTxCert cred4 accountDeposit
+                ]
+      utxoAfterRegister <- getUTxO
+      -- Overwrite deposit protocol parameters in order to ensure they does not affect refunds
+      modifyPParams
+        ( \pp ->
+            pp
+              & ppKeyDepositL .~ Coin 1
+              & ppPoolDepositL .~ Coin 2
+              & ppDRepDepositL .~ Coin 3
+        )
+      (sumUTxO utxoStart <-> sumUTxO utxoAfterRegister)
+        `shouldBe` inject
+          ( (txRegister ^. bodyTxL . feeTxBodyL)
+              <+> ((3 :: Int) <×> accountDeposit) -- Only three accounts retained that are still registered
+              <+> stakePoolDeposit
+              <+> dRepDeposit
+          )
+      curEpochNo <- getsNES nesELL
+      txUnRegister <-
+        submitTx $
+          mkBasicTx mkBasicTxBody
+            & bodyTxL . certsTxBodyL
+              .~ SSeq.fromList
+                [ RetirePoolTxCert poolId (succ curEpochNo)
+                , UnRegDRepTxCert dRepCred dRepDeposit
+                , UnRegTxCert cred3
+                , UnRegDepositTxCert cred4 accountDeposit
+                ]
+      utxoAfterUnRegister <- getUTxO
+      let totalFees = (txRegister ^. bodyTxL . feeTxBodyL) <+> (txUnRegister ^. bodyTxL . feeTxBodyL)
+      fees <- getsNES (nesEsL . esLStateL . lsUTxOStateL . utxosFeesL)
+      totalFees `shouldBe` fees
+      -- only deposits for stake pool and its account are not refunded at this point
+      (sumUTxO utxoStart <-> sumUTxO utxoAfterUnRegister)
+        `shouldBe` inject (totalFees <+> stakePoolDeposit <+> accountDeposit)
+      passEpoch
+      -- Check for successfull pool refund
+      getReward cred0 `shouldReturn` stakePoolDeposit