Merge pull request #4589 from IntersectMBO/lehins/fix-deserialization…

…-of-bad-ptrs-in-incrementalstakedistr

Fix deserialization of bad `Ptr`s in `IncrementalStake`

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

@@ -209,9 +209,11 @@ test-suite tests
         cardano-ledger-alonzo:testlib,
         cardano-ledger-alonzo,
         cardano-ledger-babbage,
+        cardano-ledger-binary,
         cardano-ledger-conway,
         cardano-ledger-core,
         cardano-ledger-binary:testlib,
+        cardano-ledger-shelley >=1.14,
         cardano-slotting:testlib,
         cardano-strict-containers,
         containers,

eras/conway/impl/test/Test/Cardano/Ledger/Conway/BinarySpec.hs

@@ -1,13 +1,22 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
 module Test.Cardano.Ledger.Conway.BinarySpec (spec) where
 
+import Cardano.Ledger.Babbage
+import Cardano.Ledger.BaseTypes
+import Cardano.Ledger.Binary
 import Cardano.Ledger.Conway
+import Cardano.Ledger.Conway.Core
 import Cardano.Ledger.Conway.Genesis
 import Cardano.Ledger.Conway.Governance
+import Cardano.Ledger.Credential
 import Cardano.Ledger.Crypto
+import Cardano.Ledger.Shelley.LedgerState
 import Data.Default.Class (def)
+import qualified Data.Map.Strict as Map
+import Lens.Micro
 import Test.Cardano.Ledger.Binary.RoundTrip
 import Test.Cardano.Ledger.Common
 import Test.Cardano.Ledger.Conway.Arbitrary ()
@@ -30,3 +39,15 @@ spec = do
     roundTripConwayCommonSpec @Conway
     -- ConwayGenesis only makes sense in Conway era
     roundTripEraSpec @Conway @(ConwayGenesis StandardCrypto)
+    describe "Regression" $ do
+      prop "Drop Ptrs from Incrementasl Stake" $ \(ls :: LedgerState Babbage) conwayGenesis slotNo testCoin -> do
+        let
+          badPtr = Ptr slotNo (TxIx maxBound) (CertIx maxBound)
+          lsBabbage :: LedgerState Babbage
+          lsBabbage = ls & lsUTxOStateL . utxosStakeDistrL . ptrMapL <>~ Map.singleton badPtr testCoin
+          lsConway :: LedgerState Conway
+          lsConway = translateEra' conwayGenesis lsBabbage
+          v = eraProtVerLow @Conway
+          expectNoBadPtr :: LedgerState Conway -> LedgerState Conway -> Expectation
+          expectNoBadPtr x y = x `shouldBe` (y & lsUTxOStateL . utxosStakeDistrL . ptrMapL .~ mempty)
+        embedTripExpectation v v (mkTrip encCBOR decNoShareCBOR) expectNoBadPtr lsConway

eras/shelley/impl/CHANGELOG.md

@@ -6,6 +6,7 @@
 * Added `EncCBOR` instances for:
   * `UtxoEnv`
   * `CertEnv`
+* Expose `ptrMapL`
 
 ### `testlib`
 

eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState.hs

@@ -127,6 +127,7 @@ module Cardano.Ledger.Shelley.LedgerState (
   vsDRepsL,
   vsCommitteeStateL,
   credMapL,
+  ptrMapL,
 
   -- * Lenses from SnapShot(s)
   ssStakeMarkL,

eras/shelley/impl/src/Cardano/Ledger/Shelley/LedgerState/Types.hs

@@ -27,7 +27,7 @@ import Cardano.Ledger.BaseTypes (
   StrictMaybe (..),
  )
 import Cardano.Ledger.Binary (
-  DecCBOR (decCBOR),
+  DecCBOR (decCBOR, dropCBOR),
   DecShareCBOR (Share, decShareCBOR, decSharePlusCBOR),
   EncCBOR (encCBOR),
   FromCBOR (..),
@@ -38,6 +38,9 @@ import Cardano.Ledger.Binary (
   decodeRecordNamed,
   decodeRecordNamedT,
   encodeListLen,
+  enforceDecoderVersion,
+  ifDecoderVersionAtLeast,
+  natVersion,
   toPlainDecoder,
  )
 import Cardano.Ledger.Binary.Coders (Decode (From, RecD), Encode (..), decode, encode, (!>), (<!))
@@ -79,6 +82,7 @@ import Data.Default.Class (Default, def)
 import Data.Group (Group, invert)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import Data.Proxy
 import Data.VMap (VB, VMap, VP)
 import GHC.Generics (Generic)
 import Lens.Micro
@@ -239,7 +243,11 @@ instance Crypto c => DecShareCBOR (IncrementalStake c) where
   decShareCBOR credInterns =
     decodeRecordNamed "Stake" (const 2) $ do
       stake <- decShareCBOR (credInterns, mempty)
-      IStake stake <$> decCBOR
+      let dropPtrs =
+            mempty
+              <$ enforceDecoderVersion (natVersion @8) (dropCBOR (Proxy @(Map Ptr (CompactForm Coin))))
+      ptrs <- ifDecoderVersionAtLeast (natVersion @9) dropPtrs decCBOR
+      pure $ IStake stake ptrs
 
 instance Semigroup (IncrementalStake c) where
   (IStake a b) <> (IStake c d) = IStake (Map.unionWith (<>) a c) (Map.unionWith (<>) b d)

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

@@ -213,7 +213,7 @@ instance Arbitrary AccountState where
   shrink = genericShrink
 
 instance Crypto c => Arbitrary (IncrementalStake c) where
-  arbitrary = IStake <$> arbitrary <*> arbitrary
+  arbitrary = IStake <$> arbitrary <*> pure mempty -- Once in Conway Ptrs Map will be removed
   shrink = genericShrink
 
 ------------------------------------------------------------------------------------------

libs/cardano-ledger-binary/src/Cardano/Ledger/Binary/Decoding/DecCBOR.hs

@@ -106,7 +106,7 @@ class Typeable a => DecCBOR a where
   {-# INLINE decCBOR #-}
 
   -- | Validate decoding of a Haskell value, without the need to actually construct
-  -- it. Coule be slightly faster than `decCBOR`, however it should respect this law:
+  -- it. Could be slightly faster than `decCBOR`, however it should respect this law:
   --
   -- > dropCBOR (proxy :: Proxy a) = () <$ (decCBOR :: Decoder s a)
   dropCBOR :: Proxy a -> Decoder s ()

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Constrained/Vars.hs

@@ -83,6 +83,7 @@ import Cardano.Ledger.Shelley.LedgerState hiding (
   deltaReserves,
   deltaTreasury,
   ptrMap,
+  ptrMapL,
   rewards,
  )
 import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates (..))