Add CertsSpec and some withdrawals-related tests

Author: teodanciu

eras/conway/impl/cardano-ledger-conway.cabal

@@ -118,6 +118,7 @@ library testlib
         Test.Cardano.Ledger.Conway.ImpTest
         Test.Cardano.Ledger.Conway.Imp
         Test.Cardano.Ledger.Conway.Imp.BbodySpec
+        Test.Cardano.Ledger.Conway.Imp.CertsSpec
         Test.Cardano.Ledger.Conway.Imp.DelegSpec
         Test.Cardano.Ledger.Conway.Imp.EpochSpec
         Test.Cardano.Ledger.Conway.Imp.EnactSpec

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

@@ -20,6 +20,7 @@ import Cardano.Ledger.BaseTypes (Inject, natVersion)
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Rules (
   ConwayBbodyPredFailure,
+  ConwayCertsPredFailure,
   ConwayDelegPredFailure,
   ConwayEpochEvent,
   ConwayGovCertPredFailure,
@@ -33,6 +34,7 @@ import Data.Typeable (Typeable)
 import qualified Test.Cardano.Ledger.Babbage.Imp as BabbageImp
 import Test.Cardano.Ledger.Common
 import qualified Test.Cardano.Ledger.Conway.Imp.BbodySpec as Bbody
+import qualified Test.Cardano.Ledger.Conway.Imp.CertsSpec as Certs
 import qualified Test.Cardano.Ledger.Conway.Imp.DelegSpec as Deleg
 import qualified Test.Cardano.Ledger.Conway.Imp.EnactSpec as Enact
 import qualified Test.Cardano.Ledger.Conway.Imp.EpochSpec as Epoch
@@ -50,6 +52,7 @@ spec ::
   , ConwayEraImp era
   , EraSegWits era
   , InjectRuleFailure "LEDGER" ConwayGovPredFailure era
+  , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era
   , Inject (BabbageContextError era) (ContextError era)
   , Inject (ConwayContextError era) (ContextError era)
   , InjectRuleFailure "LEDGER" BabbageUtxoPredFailure era
@@ -89,6 +92,7 @@ spec = do
   describe "ConwayImpSpec - bootstrap phase (protocol version 9)" $
     withImpState @era $ do
       describe "BBODY" $ Bbody.spec @era
+      describe "CERTS" $ Certs.spec @era
       describe "DELEG" $ Deleg.spec @era
       describe "ENACT" $ Enact.relevantDuringBootstrapSpec @era
       describe "EPOCH" $ Epoch.relevantDuringBootstrapSpec @era

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

@@ -0,0 +1,87 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Test.Cardano.Ledger.Conway.Imp.CertsSpec (
+  spec,
+) where
+
+import Cardano.Ledger.BaseTypes (EpochInterval (..))
+import Cardano.Ledger.Coin (Coin (..))
+import Cardano.Ledger.Conway.Core
+import Cardano.Ledger.Conway.Rules (ConwayCertsPredFailure (..))
+import Cardano.Ledger.Credential (Credential (..))
+import Cardano.Ledger.Val (Val (..))
+import Lens.Micro ((&), (.~))
+import Test.Cardano.Ledger.Conway.Arbitrary ()
+import Test.Cardano.Ledger.Conway.ImpTest
+import Test.Cardano.Ledger.Imp.Common
+
+spec ::
+  forall era.
+  ( ConwayEraImp era
+  , InjectRuleFailure "LEDGER" ConwayCertsPredFailure era
+  ) =>
+  SpecWith (ImpTestState era)
+spec = do
+  describe "Withdrawals" $ do
+    it "Withdrawing from an unregistered reward account" $ do
+      modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
+
+      rwdAccount <- KeyHashObj <$> freshKeyHash >>= getRewardAccountFor
+      submitFailingTx
+        ( mkBasicTx $
+            mkBasicTxBody
+              & withdrawalsTxBodyL
+                .~ Withdrawals
+                  [(rwdAccount, Coin 20)]
+        )
+        [injectFailure $ WithdrawalsNotInRewardsCERTS [(rwdAccount, Coin 20)]]
+
+      (registeredRwdAccount, reward) <- setupRewardAccount
+      submitFailingTx
+        ( mkBasicTx $
+            mkBasicTxBody
+              & withdrawalsTxBodyL
+                .~ Withdrawals
+                  [(rwdAccount, zero), (registeredRwdAccount, reward)]
+        )
+        [injectFailure $ WithdrawalsNotInRewardsCERTS [(rwdAccount, zero)]]
+
+    it "Withdrawing the wrong amount" $ do
+      modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
+
+      (rwdAccount1, reward1) <- setupRewardAccount
+      (rwdAccount2, reward2) <- setupRewardAccount
+      submitFailingTx
+        ( mkBasicTx $
+            mkBasicTxBody
+              & withdrawalsTxBodyL
+                .~ Withdrawals
+                  [ (rwdAccount1, reward1 <+> Coin 1)
+                  , (rwdAccount2, reward2)
+                  ]
+        )
+        [injectFailure $ WithdrawalsNotInRewardsCERTS [(rwdAccount1, reward1 <+> Coin 1)]]
+
+      submitFailingTx
+        ( mkBasicTx $
+            mkBasicTxBody
+              & withdrawalsTxBodyL
+                .~ Withdrawals
+                  [(rwdAccount1, zero)]
+        )
+        [injectFailure $ WithdrawalsNotInRewardsCERTS [(rwdAccount1, zero)]]
+  where
+    setupRewardAccount = do
+      cred <- KeyHashObj <$> freshKeyHash
+      ra <- registerStakeCredential cred
+      submitAndExpireProposalToMakeReward cred
+      rw <- lookupReward cred
+      pure (ra, rw)