Disallow witdrawals 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:

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/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,

libs/cardano-ledger-api/cardano-ledger-api.cabal

@@ -58,7 +58,7 @@ library
         cardano-ledger-alonzo >=1.9 && <1.11,
         cardano-ledger-babbage ^>=1.9,
         cardano-ledger-binary ^>=1.3,
-        cardano-ledger-conway >=1.13 && <1.18,
+        cardano-ledger-conway >=1.13 && <1.19,
         cardano-ledger-core ^>=1.15,
         cardano-ledger-mary ^>=1.7,
         cardano-ledger-shelley >=1.13 && <1.15,

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.15.0.0
 
+* Add `credKeyHash` to `Credential`
 * Remove `maxMajorPV` from `Globals`
 
 ## 1.14.0.0

libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs

@@ -13,6 +13,7 @@ module Cardano.Ledger.Credential (
   Credential (KeyHashObj, ScriptHashObj),
   GenesisCredential (..),
   PaymentCredential,
+  credKeyHash,
   credKeyHashWitness,
   credScriptHash,
   credToText,
@@ -143,11 +144,14 @@ type PaymentCredential c = Credential 'Payment c
 
 type StakeCredential c = Credential 'Staking c
 
+credKeyHash :: Credential r c -> Maybe (KeyHash r c)
+credKeyHash = \case
+  KeyHashObj hk -> Just hk
+  ScriptHashObj _ -> Nothing
+
 -- | Convert a KeyHash into a Witness KeyHash. Does nothing for Script credentials.
 credKeyHashWitness :: Credential r c -> Maybe (KeyHash 'Witness c)
-credKeyHashWitness = \case
-  KeyHashObj hk -> Just $ asWitness hk
-  ScriptHashObj _ -> Nothing
+credKeyHashWitness = credKeyHash . asWitness
 
 -- | Extract ScriptHash from a Credential. Returns Nothing for KeyHashes
 credScriptHash :: Credential kr c -> Maybe (ScriptHash c)