Disallow witdrawals to non-delegated keyhashes post-bootstrap

IntersectMBO · Aug 28, 2024 · b7e8891 · b7e8891
1 parent f5f6cac
commit b7e8891
Show file tree

Hide file tree

Showing 3 changed files with 26 additions and 18 deletions.
diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ledger.hs b/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 (..),
@@ -108,7 +109,7 @@ import Cardano.Ledger.UMap (UView (..), dRepMap)
 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 (..),
@@ -125,7 +126,6 @@ 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
 import NoThunks.Class (NoThunks (..))
@@ -396,16 +396,20 @@ 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 =
+                Map.mapKeys raCredential $
+                  Map.mapMaybeWithKey
+                    (\k v -> v <$ credKeyHash (raCredential k))
+                    wdrls
+              notDelegated = Map.keysSet (wdrlsKeyHashes Map.\\ dRepMap dUnified)
+          all (`UMap.member` delegatedAddrs) (Map.keysSet wdrlsKeyHashes)
+            ?! ConwayWdrlNotDelegatedToDRep notDelegated
 
         -- Votes and proposals from signal tx
         let govSignal =

diff --git a/libs/cardano-ledger-core/CHANGELOG.md b/libs/cardano-ledger-core/CHANGELOG.md
@@ -1,8 +1,8 @@
 # Version history for `cardano-ledger-core`
 
-## 1.14.0.1
+## 1.14.1.0
 
-*
+* Add `credKeyHash` to `Credential`
 
 ## 1.14.0.0
 

diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Credential.hs b/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)