Merge pull request #3864 from input-output-hk/lehins/add-deposits-to-…

…imp-tests

Fix Proposal deposits and add deposit tests to imp tests

eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Epoch.hs

@@ -94,7 +94,7 @@ import Cardano.Ledger.Shelley.Rules (
  )
 import qualified Cardano.Ledger.Shelley.Rules as Shelley
 import Cardano.Ledger.Slot (EpochNo)
-import Cardano.Ledger.UMap (UView (..), unionKeyDeposits, (∪+), (◁))
+import Cardano.Ledger.UMap (UView (..), unionRewAgg, (∪+), (◁))
 import Cardano.Ledger.Val (zero, (<->))
 import Control.SetAlgebra (eval, (⨃))
 import Control.State.Transition (
@@ -169,7 +169,7 @@ returnProposalDeposits removedProposals =
   dsUnifiedL %~ returnProposalDepositsUMap
   where
     returnProposalDepositsUMap umap =
-      unionKeyDeposits (RewDepUView umap) $ foldl' addReward mempty removedProposals
+      unionRewAgg (RewDepUView umap) $ foldl' addReward mempty removedProposals
       where
         addReward m' GovActionState {..} =
           Map.insertWith

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

@@ -11,36 +11,34 @@
 
 module Test.Cardano.Ledger.Conway.Imp.EpochSpec (spec, electBasicCommittee) where
 
-import Cardano.Ledger.Address
 import Cardano.Ledger.BaseTypes (textToUrl)
 import Cardano.Ledger.Coin
-import Cardano.Ledger.Compactible
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Governance (
   Anchor (..),
   ConwayGovState,
   GovAction (..),
+  ProposalProcedure (..),
   Voter (..),
   cgEnactStateL,
   ensCommitteeL,
  )
 import Cardano.Ledger.Conway.PParams (
   ppCommitteeMaxTermLengthL,
   ppDRepVotingThresholdsL,
+  ppGovActionDepositL,
   ppGovActionLifetimeL,
  )
 import Cardano.Ledger.Credential (Credential (..))
 import Cardano.Ledger.Keys
 import Cardano.Ledger.Shelley.LedgerState (
   asTreasuryL,
-  epochStateUMapL,
   esAccountStateL,
   esLStateL,
   lsUTxOStateL,
   nesEsL,
   utxosGovStateL,
  )
-import Cardano.Ledger.UMap as UMap
 import Cardano.Ledger.Val
 import Data.Default.Class (Default (..))
 import qualified Data.Map.Strict as Map
@@ -126,13 +124,35 @@ spec =
       passEpoch
 
       treasuryEnd <- getsNES $ nesEsL . esAccountStateL . asTreasuryL
-      umap <- getsNES $ nesEsL . epochStateUMapL
-      let cred = getRwdCred rewardAcount
-      case UMap.lookup cred (RewDepUView umap) of
-        Nothing -> error $ "Expected a reward account: " ++ show cred
-        Just RDPair {rdReward} -> fromCompact rdReward `shouldBe` withdrawalAmount
+
       treasuryStart <-> treasuryEnd `shouldBe` withdrawalAmount
 
+    it "Expired proposl deposit refunded" $ do
+      let deposit = Coin 999
+      modifyPParams $ \pp ->
+        pp
+          & ppGovActionLifetimeL .~ 1
+          & ppGovActionDepositL .~ deposit
+      rewardAcount <- registerRewardAccount
+
+      getRewardAccountAmount rewardAcount `shouldReturn` Coin 0
+
+      govActionId <-
+        submitProposal $
+          ProposalProcedure
+            { pProcDeposit = deposit
+            , pProcReturnAddr = rewardAcount
+            , pProcGovAction = TreasuryWithdrawals [(rewardAcount, Coin 123456789)]
+            , pProcAnchor = def
+            }
+      expectPresentGovActionId govActionId
+      passEpoch
+      passEpoch
+      passEpoch
+      expectMissingGovActionId govActionId
+
+      getRewardAccountAmount rewardAcount `shouldReturn` deposit
+
 electBasicCommittee ::
   forall era.
   ( HasCallStack
@@ -152,6 +172,7 @@ electBasicCommittee = do
           }
       & ppCommitteeMaxTermLengthL .~ 10
       & ppGovActionLifetimeL .~ 2
+      & ppGovActionDepositL .~ Coin 123
   khDRep <- setupSingleDRep
 
   logEntry "Registering committee member"

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -16,6 +17,7 @@ module Test.Cardano.Ledger.Conway.ImpTest (
   ConwayEraImp,
   submitGovAction,
   submitGovAction_,
+  submitProposal,
   submitFailingProposal,
   trySubmitGovAction,
   trySubmitProposal,
@@ -28,7 +30,10 @@ module Test.Cardano.Ledger.Conway.ImpTest (
   setupSingleDRep,
   conwayModifyPParams,
   getEnactState,
+  getGovActionState,
   lookupGovActionState,
+  expectPresentGovActionId,
+  expectMissingGovActionId,
   getRatifyEnv,
   calculateDRepAcceptedRatio,
   calculateCommitteeAcceptedRatio,
@@ -86,7 +91,12 @@ import Cardano.Ledger.Conway.Governance (
   votingDRepThreshold,
   votingStakePoolThreshold,
  )
-import Cardano.Ledger.Conway.PParams (ConwayEraPParams, ppDRepActivityL, ppGovActionLifetimeL)
+import Cardano.Ledger.Conway.PParams (
+  ConwayEraPParams,
+  ppDRepActivityL,
+  ppGovActionDepositL,
+  ppGovActionLifetimeL,
+ )
 import Cardano.Ledger.Conway.Rules (
   EnactSignal,
   committeeAccepted,
@@ -349,6 +359,16 @@ trySubmitVote vote voter gaId = do
               )
           )
 
+submitProposal ::
+  forall era.
+  ( ShelleyEraImp era
+  , ConwayEraTxBody era
+  , HasCallStack
+  ) =>
+  ProposalProcedure era ->
+  ImpTestM era (GovActionId (EraCrypto era))
+submitProposal proposal = trySubmitProposal proposal >>= expectRightExpr
+
 -- | Submits a transaction that proposes the given proposal
 trySubmitProposal ::
   ( ShelleyEraImp era
@@ -399,14 +419,12 @@ trySubmitGovAction ::
         (GovActionId (EraCrypto era))
     )
 trySubmitGovAction ga = do
+  pp <- getsNES $ nesEsL . curPParamsEpochStateL
   khPropRwd <- freshKeyHash
   trySubmitProposal $
     ProposalProcedure
-      { pProcDeposit = zero
-      , pProcReturnAddr =
-          RewardAcnt
-            Testnet
-            (KeyHashObj khPropRwd)
+      { pProcDeposit = pp ^. ppGovActionDepositL
+      , pProcReturnAddr = RewardAcnt Testnet (KeyHashObj khPropRwd)
       , pProcGovAction = ga
       , pProcAnchor = def
       }
@@ -434,17 +452,43 @@ submitGovAction_ = void . submitGovAction
 getEnactState :: ConwayEraGov era => ImpTestM era (EnactState era)
 getEnactState = getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . enactStateGovStateL
 
--- | Looks up the governance action state corresponding to the governance
--- action id
+-- | Looks up the governance action state corresponding to the governance action id
 lookupGovActionState ::
-  (HasCallStack, ConwayEraGov era) =>
+  ConwayEraGov era =>
   GovActionId (EraCrypto era) ->
-  ImpTestM era (GovActionState era)
+  ImpTestM era (Maybe (GovActionState era))
 lookupGovActionState aId = do
   proposals <- getsNES $ nesEsL . esLStateL . lsUTxOStateL . utxosGovStateL . proposalsGovStateL
+  pure $ snapshotLookupId aId proposals
+
+-- | Looks up the governance action state corresponding to the governance action id
+getGovActionState ::
+  (HasCallStack, ConwayEraGov era) =>
+  GovActionId (EraCrypto era) ->
+  ImpTestM era (GovActionState era)
+getGovActionState govActionId =
   impAnn "Expecting an action state" $ do
-    maybe (assertFailure $ "Could not find action state for govActionId: " <> show aId) pure $
-      snapshotLookupId aId proposals
+    lookupGovActionState govActionId >>= \case
+      Nothing ->
+        assertFailure $ "Could not find action state for govActionId: " <> show govActionId
+      Just govActionState -> pure govActionState
+
+expectPresentGovActionId ::
+  (HasCallStack, ConwayEraGov era) =>
+  GovActionId (EraCrypto era) ->
+  ImpTestM era ()
+expectPresentGovActionId govActionId = void $ getGovActionState govActionId
+
+expectMissingGovActionId ::
+  (HasCallStack, ConwayEraGov era) =>
+  GovActionId (EraCrypto era) ->
+  ImpTestM era ()
+expectMissingGovActionId govActionId =
+  impAnn "Expecting for gov action state to be missing" $ do
+    lookupGovActionState govActionId >>= \case
+      Just _ ->
+        expectationFailure $ "Found gov action state for govActionId: " <> show govActionId
+      Nothing -> pure ()
 
 -- | Builds a RatifyState from the current state
 getRatifyEnv :: ConwayEraGov era => ImpTestM era (RatifyEnv era)
@@ -473,7 +517,7 @@ calculateDRepAcceptedRatio ::
   ImpTestM era Rational
 calculateDRepAcceptedRatio gaId = do
   ratEnv <- getRatifyEnv
-  gas <- lookupGovActionState gaId
+  gas <- getGovActionState gaId
   pure $
     dRepAcceptedRatio @era
       ratEnv
@@ -490,7 +534,7 @@ calculateCommitteeAcceptedRatio ::
 calculateCommitteeAcceptedRatio gaId = do
   eNo <- getsNES nesELL
   RatifyEnv {reCommitteeState} <- getRatifyEnv
-  GovActionState {gasCommitteeVotes} <- lookupGovActionState gaId
+  GovActionState {gasCommitteeVotes} <- getGovActionState gaId
   ens <- getEnactState
   let
     committee = ens ^. ensCommitteeL
@@ -524,7 +568,7 @@ canGovActionBeDRepAccepted gaId = do
   poolDistr <- getsNES nesPdL
   drepDistr <- getsNES $ nesEsL . epochStateDRepPulsingStateL . psDRepDistrG
   drepState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsDRepsL
-  action <- lookupGovActionState gaId
+  action <- getGovActionState gaId
   enactSt <- getEnactState
   committeeState <- getsNES $ nesEsL . esLStateL . lsCertStateL . certVStateL . vsCommitteeStateL
   let
@@ -551,7 +595,7 @@ logRatificationChecks ::
   GovActionId (EraCrypto era) ->
   ImpTestM era ()
 logRatificationChecks gaId = do
-  gas@GovActionState {gasDRepVotes, gasAction} <- lookupGovActionState gaId
+  gas@GovActionState {gasDRepVotes, gasAction} <- getGovActionState gaId
   ens@EnactState {..} <- getEnactState
   ratEnv <- getRatifyEnv
   let

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

@@ -47,6 +47,7 @@ module Test.Cardano.Ledger.Shelley.ImpTest (
   impNESL,
   runImpRule,
   registerRewardAccount,
+  getRewardAccountAmount,
   constitutionShouldBe,
   withImpState,
 ) where
@@ -70,7 +71,7 @@ import Cardano.Ledger.BaseTypes (
  )
 import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Core
-import Cardano.Ledger.Credential (Credential (..), StakeReference (..))
+import Cardano.Ledger.Credential (Credential (..), StakeReference (..), credToText)
 import Cardano.Ledger.Crypto (Crypto (..))
 import Cardano.Ledger.EpochBoundary (emptySnapShots)
 import Cardano.Ledger.Keys (
@@ -82,7 +83,7 @@ import Cardano.Ledger.Keys (
 import Cardano.Ledger.PoolDistr (IndividualPoolStake (..), PoolDistr (..))
 import Cardano.Ledger.SafeHash (HashAnnotated (..), SafeHash)
 import Cardano.Ledger.Shelley (ShelleyEra)
-import Cardano.Ledger.Shelley.Core (Constitution (..), EraGov (..), ShelleyEraTxBody)
+import Cardano.Ledger.Shelley.Core (Constitution (..), EraGov (..), ShelleyEraTxBody (..))
 import Cardano.Ledger.Shelley.LedgerState (
   AccountState (..),
   EpochState (..),
@@ -93,6 +94,7 @@ import Cardano.Ledger.Shelley.LedgerState (
   curPParamsEpochStateL,
   dsGenDelegsL,
   epochStateIncrStakeDistrL,
+  epochStateUMapL,
   esAccountStateL,
   esLStateL,
   lsCertStateL,
@@ -108,6 +110,7 @@ import Cardano.Ledger.Shelley.LedgerState (
 import Cardano.Ledger.Shelley.Rules (LedgerEnv (..), shelleyWitsVKeyNeeded)
 import Cardano.Ledger.Shelley.TxCert
 import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
+import Cardano.Ledger.UMap as UMap
 import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..), sumAllCoin)
 import Cardano.Ledger.Val (Val (..))
 import Control.DeepSeq (NFData)
@@ -200,6 +203,7 @@ class
       (Hash (HASH (EraCrypto era)) EraIndependentTxBody)
   , ToExpr (PredicateFailure (EraRule "LEDGER" era))
   , EraUTxO era
+  , ShelleyEraTxBody era
   , State (EraRule "LEDGER" era) ~ LedgerState era
   , Environment (EraRule "LEDGER" era) ~ LedgerEnv era
   , EraGov era
@@ -401,6 +405,14 @@ instance Example (ImpTestM era ()) where
 runShelleyBase :: Globals -> ShelleyBase a -> a
 runShelleyBase globals act = runIdentity $ runReaderT act globals
 
+getRewardAccountAmount :: RewardAcnt (EraCrypto era) -> ImpTestM era Coin
+getRewardAccountAmount rewardAcount = do
+  umap <- getsNES $ nesEsL . epochStateUMapL
+  let cred = getRwdCred rewardAcount
+  case UMap.lookup cred (RewDepUView umap) of
+    Nothing -> assertFailure $ "Expected a reward account: " ++ show cred
+    Just RDPair {rdReward} -> pure $ fromCompact rdReward
+
 fixupFees ::
   forall era.
   ShelleyEraImp era =>
@@ -409,11 +421,14 @@ fixupFees ::
 fixupFees tx = do
   ImpTestState {impRootTxId, impRootTxCoin} <- get
   pp <- getsNES $ nesEsL . curPParamsEpochStateL
+  certState <- getsNES $ nesEsL . esLStateL . lsCertStateL
   kpSpending <- lookupKeyPair =<< freshKeyHash
   kpStaking <- lookupKeyPair =<< freshKeyHash
   let
+    deposits = getTotalDepositsTxBody pp certState (tx ^. bodyTxL)
+    refunds = getTotalRefundsTxBody pp certState (tx ^. bodyTxL)
     outputsTotalCoin = sumAllCoin $ tx ^. bodyTxL . outputsTxBodyL
-    remainingCoin = impRootTxCoin <-> outputsTotalCoin
+    remainingCoin = impRootTxCoin <-> (outputsTotalCoin <+> deposits <-> refunds)
     remainingTxOut =
       mkBasicTxOut @era
         (mkAddr (kpSpending, kpStaking))
@@ -675,7 +690,6 @@ registerRewardAccount ::
   forall era.
   ( HasCallStack
   , ShelleyEraImp era
-  , ShelleyEraTxCert era
   ) =>
   ImpTestM era (RewardAcnt (EraCrypto era))
 registerRewardAccount = do
@@ -684,7 +698,7 @@ registerRewardAccount = do
   kpSpending <- lookupKeyPair =<< freshKeyHash
   let stakingCredential = KeyHashObj khDelegator
   _ <-
-    submitTx "Delegate to DRep" $
+    submitTx ("Register Reward Account: " <> T.unpack (credToText stakingCredential)) $
       mkBasicTx mkBasicTxBody
         & bodyTxL . outputsTxBodyL
           .~ SSeq.fromList