Merge pull request #4555 from IntersectMBO/td/withdrawals-to-nondeleg…

…ated-accounts

Disallow withdrawals to non-delegated keyhashes post-bootstrap

eras/conway/impl/CHANGELOG.md

@@ -1,7 +1,7 @@
 # Version history for `cardano-ledger-conway`
 
-## 1.16.2.0
-
+## 1.17.0.0
+* Changed `ConwayWdrlNotDelegatedToDRep` to wrap `NonEmpty`
 * Add `showGovActionType`, `acceptedByEveryone`
 * Added `unRatifySignal`
 * Added lenses:
@@ -13,6 +13,12 @@
   * `reCurrentEpochL`
   * `reCommitteeStateL`
 
+### `testlib`
+
+  * Removed `redelegateDRep` from `ImpTest`
+  * Changed signature of `delegateToDRep` to take a `Credential` parameter
+
+
 ## 1.16.1.0
 
 * Replace GOVCERT `updateDRepExpiry` with `computeDRepExpiry`

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

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               cardano-ledger-conway
-version:            1.16.2.0
+version:            1.17.0.0
 license:            Apache-2.0
 maintainer:         operations@iohk.io
 author:             IOHK

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

@@ -79,9 +79,10 @@ import Cardano.Ledger.Conway.Rules.Utxo (ConwayUtxoPredFailure)
 import Cardano.Ledger.Conway.Rules.Utxos (ConwayUtxosPredFailure)
 import Cardano.Ledger.Conway.Rules.Utxow (ConwayUtxowPredFailure)
 import Cardano.Ledger.Conway.UTxO (txNonDistinctRefScriptsSize)
-import Cardano.Ledger.Credential (Credential)
+import Cardano.Ledger.Credential (Credential (..), credKeyHash)
 import Cardano.Ledger.Crypto (Crypto (..))
 import Cardano.Ledger.Keys (KeyRole (..))
+import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
 import Cardano.Ledger.Shelley.LedgerState (
   CertState (..),
   DState (..),
@@ -104,27 +105,28 @@ import Cardano.Ledger.Shelley.Rules (
   shelleyLedgerAssertions,
  )
 import Cardano.Ledger.Slot (epochInfoEpoch)
-import Cardano.Ledger.UMap (UView (..), dRepMap)
+import Cardano.Ledger.UMap (UView (..))
 import qualified Cardano.Ledger.UMap as UMap
 import Cardano.Ledger.UTxO (EraUTxO (..))
 import Control.DeepSeq (NFData)
-import Control.Monad (when)
+import Control.Monad (unless)
 import Control.Monad.Trans.Reader (asks)
 import Control.State.Transition.Extended (
   Embed (..),
   STS (..),
   TRC (..),
   TransitionRule,
+  failOnNonEmpty,
   judgmentContext,
   liftSTS,
   trans,
   (?!),
  )
 import Data.Kind (Type)
+import Data.List.NonEmpty (NonEmpty)
 import qualified Data.Map.Strict as Map
 import Data.Sequence (Seq)
 import qualified Data.Sequence.Strict as StrictSeq
-import Data.Set (Set)
 import qualified Data.Set as Set
 import GHC.Generics (Generic (..))
 import Lens.Micro as L
@@ -134,7 +136,7 @@ data ConwayLedgerPredFailure era
   = ConwayUtxowFailure (PredicateFailure (EraRule "UTXOW" era))
   | ConwayCertsFailure (PredicateFailure (EraRule "CERTS" era))
   | ConwayGovFailure (PredicateFailure (EraRule "GOV" era))
-  | ConwayWdrlNotDelegatedToDRep (Set (Credential 'Staking (EraCrypto era)))
+  | ConwayWdrlNotDelegatedToDRep (NonEmpty (Credential 'Staking (EraCrypto era)))
   | ConwayTreasuryValueMismatch
       -- | Actual
       Coin
@@ -396,16 +398,19 @@ ledgerTransition = do
               , certState
               , StrictSeq.fromStrict $ txBody ^. certsTxBodyL
               )
-        let wdrlAddrs = Map.keysSet . unWithdrawals $ tx ^. bodyTxL . withdrawalsTxBodyL
-            wdrlCreds = Set.map raCredential wdrlAddrs
-            dUnified = dsUnified $ certDState certStateAfterCERTS
-            delegatedAddrs = DRepUView dUnified
-
-        -- TODO: Finish this implementation once we are in bootstrap phase:
-        -- https://github.com/IntersectMBO/cardano-ledger/issues/4092
-        when False $ do
-          all (`UMap.member` delegatedAddrs) wdrlCreds
-            ?! ConwayWdrlNotDelegatedToDRep (wdrlCreds Set.\\ Map.keysSet (dRepMap dUnified))
+
+        -- Starting with version 10, we don't allow withdrawals into RewardAcounts that are KeyHashes and not delegated to Dreps
+        unless (HF.bootstrapPhase (pp ^. ppProtocolVersionL)) $ do
+          let dUnified = dsUnified $ certDState certStateAfterCERTS
+              wdrls = unWithdrawals $ tx ^. bodyTxL . withdrawalsTxBodyL
+              delegatedAddrs = DRepUView dUnified
+              wdrlsKeyHashes =
+                Set.fromList
+                  [ rc | (ra, _) <- Map.toList wdrls, let rc = raCredential ra, Just _ <- [credKeyHash rc]
+                  ]
+              nonExistentDelegations =
+                Set.filter (not . (`UMap.member` delegatedAddrs)) wdrlsKeyHashes
+          failOnNonEmpty nonExistentDelegations ConwayWdrlNotDelegatedToDRep
 
         -- Votes and proposals from signal tx
         let govSignal =

eras/conway/impl/src/Cardano/Ledger/Conway/TxCert.hs

@@ -433,7 +433,7 @@ data ConwayDelegCert c
   | -- | De-Register the staking credential. Deposit, if present, must match the amount
     -- that was left as a deposit upon stake credential registration.
     ConwayUnRegCert !(StakeCredential c) !(StrictMaybe Coin)
-  | -- | Redelegate to another delegatee. Staking credential must already be registered.
+  | -- | Delegate staking credentials to a delegatee. Staking credential must already be registered.
     ConwayDelegCert !(StakeCredential c) !(Delegatee c)
   | -- | This is a new type of certificate, which allows to register staking credential
     -- and delegate within a single certificate. Deposit is required and must match the

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

@@ -1,28 +1,39 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Test.Cardano.Ledger.Conway.Imp.LedgerSpec (spec) where
 
+import Cardano.Ledger.Address (RewardAccount (..))
+import Cardano.Ledger.BaseTypes
+import Cardano.Ledger.Coin (Coin (..))
 import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Rules (ConwayLedgerPredFailure (..), maxRefScriptSizePerTx)
-import Cardano.Ledger.Plutus (SLanguage (..))
+import Cardano.Ledger.DRep
+import Cardano.Ledger.Plutus (SLanguage (..), hashPlutusScript)
 import Cardano.Ledger.SafeHash (originalBytesSize)
+import qualified Cardano.Ledger.Shelley.HardForks as HF (bootstrapPhase)
 import qualified Data.Set as Set
 import Lens.Micro ((&), (.~))
 import Test.Cardano.Ledger.Conway.ImpTest
 import Test.Cardano.Ledger.Imp.Common
-import Test.Cardano.Ledger.Plutus.Examples (alwaysFailsWithDatum)
+import Test.Cardano.Ledger.Plutus.Examples (
+  alwaysFailsWithDatum,
+  alwaysSucceedsNoDatum,
+ )
+
+import Cardano.Ledger.Credential (Credential (..))
 
 spec ::
   forall era.
   ( ConwayEraImp era
   , InjectRuleFailure "LEDGER" ConwayLedgerPredFailure era
   ) =>
   SpecWith (ImpTestState era)
-spec =
+spec = do
   it "TxRefScriptsSizeTooBig" $ do
     -- we use here the largest script we currently have as many times as necessary to
     -- trigger the predicate failure
@@ -38,3 +49,45 @@ spec =
       tx
       [ injectFailure $ ConwayTxRefScriptsSizeTooBig (size * n) maxRefScriptSizePerTx
       ]
+
+  it "Withdraw from delegated and non-delegated staking key" $ do
+    modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
+    cred <- KeyHashObj <$> freshKeyHash
+    ra <- registerStakeCredential cred
+    submitAndExpireProposalToMakeReward cred
+    reward <- lookupReward cred
+
+    let tx = mkBasicTx $ mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(ra, reward)]
+
+    pv <- getProtVer
+    if HF.bootstrapPhase pv
+      then submitTx_ tx
+      else
+        submitFailingTx
+          tx
+          [injectFailure $ ConwayWdrlNotDelegatedToDRep [raCredential ra]]
+    _ <- delegateToDRep cred (Coin 1_000_000) DRepAlwaysAbstain
+    submitTx_ $
+      mkBasicTx $
+        mkBasicTxBody
+          & withdrawalsTxBodyL
+            .~ Withdrawals
+              [ (ra, if HF.bootstrapPhase pv then mempty else reward)
+              ]
+
+  it "Withdraw from delegated and non-delegated staking script" $ do
+    modifyPParams $ ppGovActionLifetimeL .~ EpochInterval 2
+    let scriptHash = hashPlutusScript $ alwaysSucceedsNoDatum SPlutusV3
+    let cred = ScriptHashObj scriptHash
+    ra <- registerStakeCredential cred
+    submitAndExpireProposalToMakeReward cred
+    reward <- lookupReward cred
+
+    submitTx_ $
+      mkBasicTx $
+        mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(ra, reward)]
+
+    _ <- delegateToDRep cred (Coin 1_000_000) DRepAlwaysAbstain
+    submitTx_ $
+      mkBasicTx $
+        mkBasicTxBody & withdrawalsTxBodyL .~ Withdrawals [(ra, mempty)]

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

@@ -744,20 +744,22 @@ votingSpec =
       describe "Predefined DReps" $ do
         it "acceptedRatio with default DReps" $ do
           (drep1, _, committeeGovId) <- electBasicCommittee
-          (drep2, drep2Staking, _) <- setupSingleDRep 1_000_000
+          (_, drep2Staking, _) <- setupSingleDRep 1_000_000
 
           paramChangeGovId <- submitParameterChange SNothing $ def & ppuMinFeeAL .~ SJust (Coin 3000)
           submitYesVote_ (DRepVoter drep1) paramChangeGovId
 
           passEpoch
           calculateDRepAcceptedRatio paramChangeGovId `shouldReturn` 1 % 2
 
-          _ <- delegateToDRep 1_000_000 DRepAlwaysNoConfidence
+          kh <- freshKeyHash
+          _ <- registerStakeCredential (KeyHashObj kh)
+          _ <- delegateToDRep (KeyHashObj kh) (Coin 1_000_000) DRepAlwaysNoConfidence
           passEpoch
           -- AlwaysNoConfidence vote acts like a 'No' vote for actions other than NoConfidence
           calculateDRepAcceptedRatio paramChangeGovId `shouldReturn` 1 % 3
 
-          redelegateDRep drep2 DRepAlwaysAbstain drep2Staking
+          _ <- delegateToDRep drep2Staking zero DRepAlwaysAbstain
           passEpoch
           -- AlwaysAbstain vote acts like 'Abstain' vote
           calculateDRepAcceptedRatio paramChangeGovId `shouldReturn` 1 % 2
@@ -796,14 +798,7 @@ votingSpec =
           passEpoch
           isDRepAccepted noConfidenceGovId `shouldReturn` False
 
-          submitTxAnn_ "Redelegate to AlwaysNoConfidence " $
-            mkBasicTx mkBasicTxBody
-              & bodyTxL . certsTxBodyL
-                .~ SSeq.fromList
-                  [ DelegTxCert @era
-                      drep2Staking
-                      (DelegVote DRepAlwaysNoConfidence)
-                  ]
+          _ <- delegateToDRep drep2Staking zero DRepAlwaysNoConfidence
           passEpoch
           isDRepAccepted noConfidenceGovId `shouldReturn` True
           passEpoch
@@ -829,7 +824,7 @@ votingSpec =
           passEpoch
           getTreasury `shouldReturn` initialTreasury
 
-          redelegateDRep drep2 DRepAlwaysAbstain drep2Staking
+          _ <- delegateToDRep drep2Staking zero DRepAlwaysAbstain
 
           passEpoch
           -- the delegation turns the No vote into an Abstain, enough to pass the action
@@ -844,7 +839,9 @@ votingSpec =
               & ppDRepVotingThresholdsL . dvtMotionNoConfidenceL .~ 1 %! 1
               & ppCoinsPerUTxOByteL .~ CoinPerByte (Coin 1)
           (drep, _, committeeId) <- electBasicCommittee
-          _ <- delegateToDRep 300 DRepAlwaysNoConfidence
+          kh <- freshKeyHash
+          _ <- registerStakeCredential (KeyHashObj kh)
+          _ <- delegateToDRep (KeyHashObj kh) (Coin 300) DRepAlwaysNoConfidence
           noConfidence <- submitGovAction (NoConfidence (SJust committeeId))
           submitYesVote_ (DRepVoter drep) noConfidence
           logAcceptedRatio noConfidence

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

@@ -43,7 +43,6 @@ module Test.Cardano.Ledger.Conway.ImpTest (
   unRegisterDRep,
   updateDRep,
   delegateToDRep,
-  redelegateDRep,
   setupSingleDRep,
   setupDRepWithoutStake,
   setupPoolWithStake,
@@ -216,7 +215,7 @@ import Lens.Micro
 import Test.Cardano.Ledger.Babbage.ImpTest
 import Test.Cardano.Ledger.Conway.Arbitrary ()
 import Test.Cardano.Ledger.Conway.TreeDiff ()
-import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkAddr)
+import Test.Cardano.Ledger.Core.KeyPair (KeyPair (..), mkCred)
 import Test.Cardano.Ledger.Core.Rational (IsRatio (..))
 import Test.Cardano.Ledger.Imp.Common
 import Test.Cardano.Ledger.Plutus (testingCostModel)
@@ -449,7 +448,7 @@ setupDRepWithoutStake = do
           ]
   pure (drepKH, delegatorKH)
 
--- | Registers a new DRep and delegates the specified amount of ADA to it.
+-- | Registers a new DRep, registers its stake credentials and delegates the specified amount of ADA to it.
 setupSingleDRep ::
   ConwayEraImp era =>
   Integer ->
@@ -461,54 +460,47 @@ setupSingleDRep ::
     )
 setupSingleDRep stake = do
   drepKH <- registerDRep
-  (stakingCred, spendingKh) <- delegateToDRep stake (DRepCredential (KeyHashObj drepKH))
-  pure (KeyHashObj drepKH, stakingCred, spendingKh)
+  delegatorKH <- freshKeyHash
+  deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
+  let tx =
+        mkBasicTx mkBasicTxBody
+          & bodyTxL . certsTxBodyL
+            .~ SSeq.fromList
+              [ RegDepositTxCert
+                  (KeyHashObj delegatorKH)
+                  deposit
+              ]
+  submitTx_ tx
+  spendingKP <-
+    delegateToDRep (KeyHashObj delegatorKH) (Coin stake) (DRepCredential (KeyHashObj drepKH))
+  pure (KeyHashObj drepKH, KeyHashObj delegatorKH, spendingKP)
 
 delegateToDRep ::
   ConwayEraImp era =>
-  Integer ->
+  Credential 'Staking (EraCrypto era) ->
+  Coin ->
   DRep (EraCrypto era) ->
   ImpTestM
     era
-    ( Credential 'Staking (EraCrypto era)
-    , KeyPair 'Payment (EraCrypto era)
-    )
-delegateToDRep stake dRep = do
-  (delegatorKH, delegatorKP) <- freshKeyPair
+    (KeyPair 'Payment (EraCrypto era))
+delegateToDRep cred stake dRep = do
   (_, spendingKP) <- freshKeyPair
-  deposit <- getsNES $ nesEsL . curPParamsEpochStateL . ppKeyDepositL
+  let addr = Addr Testnet (mkCred spendingKP) (StakeRefBase cred)
   submitTxAnn_ "Delegate to DRep" $
     mkBasicTx mkBasicTxBody
       & bodyTxL . outputsTxBodyL
         .~ SSeq.singleton
           ( mkBasicTxOut
-              (mkAddr (spendingKP, delegatorKP))
-              (inject $ Coin stake)
+              addr
+              (inject stake)
           )
       & bodyTxL . certsTxBodyL
         .~ SSeq.fromList
-          [ RegDepositDelegTxCert
-              (KeyHashObj delegatorKH)
+          [ DelegTxCert
+              cred
               (DelegVote dRep)
-              deposit
-          ]
-  pure (KeyHashObj delegatorKH, spendingKP)
-
-redelegateDRep ::
-  ConwayEraImp era =>
-  Credential 'DRepRole (EraCrypto era) ->
-  DRep (EraCrypto era) ->
-  Credential 'Staking (EraCrypto era) ->
-  ImpTestM era ()
-redelegateDRep dRepCred newDRep stakingCred = do
-  drepState <- lookupDRepState dRepCred
-  submitTx_ $
-    mkBasicTx mkBasicTxBody
-      & bodyTxL . certsTxBodyL
-        .~ SSeq.fromList
-          [ UnRegDRepTxCert dRepCred (drepState ^. drepDepositL)
-          , DelegTxCert stakingCred (DelegVote newDRep)
           ]
+  pure spendingKP
 
 lookupDRepState ::
   HasCallStack =>
@@ -774,7 +766,7 @@ submitAndExpireProposalToMakeReward stakingC = do
       ProposalProcedure
         { pProcDeposit = deposit
         , pProcReturnAddr = rewardAccount
-        , pProcGovAction = TreasuryWithdrawals mempty def
+        , pProcGovAction = InfoAction
         , pProcAnchor = def
         }
   passNEpochs $ 2 + fromIntegral lifetime

eras/conway/test-suite/cardano-ledger-conway-test.cabal

@@ -36,7 +36,7 @@ library
         cardano-ledger-babbage >=1.3,
         cardano-ledger-babbage-test >=1.1.1,
         cardano-ledger-binary >=1.0,
-        cardano-ledger-conway:{cardano-ledger-conway, testlib} >=1.16.1 && <1.17,
+        cardano-ledger-conway:{cardano-ledger-conway, testlib} >=1.16.1 && <1.18,
         cardano-ledger-core:{cardano-ledger-core, testlib} >=1.11,
         cardano-ledger-mary >=1.4,
         cardano-ledger-shelley-ma-test >=1.1,