Translate bad Ptrs to valid Ptrs during translation to Conway.

Bad pointers and ugly addresses are not allowed in transactions starting
with Babbage era. However, Ptr's that did land on chain in prior eras are
still present in the LedgerState. Thanks to deprecation of `Ptr`s we can
simplify the Ptr decoding logic, but only after the bad ones have been
translated.

eras/babbage/impl/src/Cardano/Ledger/Babbage/TxOut.hs

@@ -45,6 +45,7 @@ import Cardano.Ledger.Address (
   CompactAddr,
   compactAddr,
   decompactAddr,
+  fromCborBackwardsBothAddr,
   fromCborBothAddr,
  )
 import Cardano.Ledger.Alonzo.Scripts.Data (
@@ -441,13 +442,16 @@ instance (EraScript era, Val (Value era)) => EncCBOR (BabbageTxOut era) where
     TxOutCompact addr cv -> encodeTxOut @era addr cv NoDatum SNothing
 
 instance (EraScript era, Val (Value era)) => DecCBOR (BabbageTxOut era) where
-  decCBOR = decodeBabbageTxOut
+  decCBOR = decodeBabbageTxOut fromCborBothAddr
   {-# INLINE decCBOR #-}
 
 instance (EraScript era, Val (Value era)) => DecShareCBOR (BabbageTxOut era) where
   type Share (BabbageTxOut era) = Interns (Credential 'Staking (EraCrypto era))
   decShareCBOR credsInterns =
-    internTxOut <$!> decodeBabbageTxOut
+    -- Even in Babbage the ledger state still contains garbage pointers that we need to
+    -- deal with. This will be taken care of upon entry to Conway era. After which this
+    -- backwards compatibility shim can be removed.
+    internTxOut <$!> decodeBabbageTxOut fromCborBackwardsBothAddr
     where
       internTxOut = \case
         TxOut_AddrHash28_AdaOnly cred addr28Extra ada ->
@@ -456,8 +460,14 @@ instance (EraScript era, Val (Value era)) => DecShareCBOR (BabbageTxOut era) whe
           TxOut_AddrHash28_AdaOnly_DataHash32 (interns credsInterns cred) addr28Extra ada dataHash32
         txOut -> txOut
 
-decodeBabbageTxOut :: (EraScript era, Val (Value era)) => Decoder s (BabbageTxOut era)
-decodeBabbageTxOut = do
+decodeBabbageTxOut ::
+  (EraScript era, Val (Value era)) =>
+  -- | We need to use a backwards compatible decoder for any address in a pre-babbage
+  -- TxOut format. This is needed in order to get rid of bogus pointers from the ledger
+  -- state in Conway
+  Decoder s (Addr (EraCrypto era), CompactAddr (EraCrypto era)) ->
+  Decoder s (BabbageTxOut era)
+decodeBabbageTxOut decAddr = do
   peekTokenType >>= \case
     TypeMapLenIndef -> decodeTxOut fromCborBothAddr
     TypeMapLen -> decodeTxOut fromCborBothAddr
@@ -467,25 +477,25 @@ decodeBabbageTxOut = do
       lenOrIndef <- decodeListLenOrIndef
       case lenOrIndef of
         Nothing -> do
-          (a, ca) <- fromCborBothAddr
+          (a, ca) <- decAddr
           v <- decCBOR
           decodeBreakOr >>= \case
             True -> pure $ mkTxOut a ca v NoDatum SNothing
             False -> do
               dh <- decCBOR
               decodeBreakOr >>= \case
                 True -> pure $ mkTxOut a ca v (DatumHash dh) SNothing
-                False -> cborError $ DecoderErrorCustom "txout" "Excess terms in txout"
+                False -> cborError $ DecoderErrorCustom "TxOut" "Excess terms in TxOut"
         Just 2 -> do
-          (a, ca) <- fromCborBothAddr
+          (a, ca) <- decAddr
           v <- decCBOR
           pure $ mkTxOut a ca v NoDatum SNothing
         Just 3 -> do
-          (a, ca) <- fromCborBothAddr
+          (a, ca) <- decAddr
           v <- decCBOR
           dh <- decCBOR
           pure $ mkTxOut a ca v (DatumHash dh) SNothing
-        Just _ -> cborError $ DecoderErrorCustom "txout" "wrong number of terms in txout"
+        Just _ -> cborError $ DecoderErrorCustom "TxOut" "Wrong number of terms in TxOut"
 
 {-# INLINE encodeTxOut #-}
 encodeTxOut ::

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
@@ -13,6 +14,7 @@
 
 module Cardano.Ledger.Conway.Translation where
 
+import Cardano.Ledger.Address (Addr (..))
 import Cardano.Ledger.Allegra.Scripts (translateTimelock)
 import Cardano.Ledger.Alonzo.Scripts (AlonzoScript (..))
 import Cardano.Ledger.Alonzo.Tx (AlonzoEraTx (..))
@@ -24,6 +26,7 @@ import Cardano.Ledger.Conway.Era (ConwayEra)
 import Cardano.Ledger.Conway.Scripts ()
 import Cardano.Ledger.Conway.Tx ()
 import qualified Cardano.Ledger.Core as Core (Tx)
+import Cardano.Ledger.Credential (StakeReference (..), normalizePtr)
 import Cardano.Ledger.Crypto (Crypto)
 import Cardano.Ledger.Shelley.API (
   DPState (..),
@@ -144,7 +147,26 @@ translateTxOut ::
   TxOut (BabbageEra c) ->
   TxOut (ConwayEra c)
 translateTxOut (BabbageTxOut addr value d s) =
-  BabbageTxOut addr value (translateDatum d) (translateScript <$> s)
+  BabbageTxOut (addrPtrNormalize addr) value (translateDatum d) (translateScript <$> s)
+
+-- | This function is implemented solely for the purpose of translating garbage pointers
+-- into knowingly invalid ones. Any pointer that contains a SlotNo, TxIx or CertIx that
+-- is too large to fit into Word32, Word16 and Word16 respectively, will have all of its
+-- values set to 0 using `normalizePtr`.
+--
+-- There are two reasons why we can safely do that at the Babbage/Conway era boundary:
+--
+-- * Invalid pointers are no longer allowed in transactions starting with Babbage era
+--
+-- * There are only a handful of `Ptr`s on mainnet that are invalid.
+--
+-- Once the transition is complete and we are officially in Conway era, this translation
+-- logic can be removed in favor of a fixed deserializer that does the same thing for all
+-- eras prior to Babbage.
+addrPtrNormalize :: Addr c -> Addr c
+addrPtrNormalize = \case
+  Addr n cred (StakeRefPtr ptr) -> Addr n cred (StakeRefPtr (normalizePtr ptr))
+  addr -> addr
 
 translateDatum :: Datum (BabbageEra c) -> Datum (ConwayEra c)
 translateDatum = \case

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

@@ -411,31 +411,31 @@ fromCborCompactAddr = snd <$> fromCborBothAddr
 -- that it was encoded as.
 fromCborBothAddr :: forall c s. Crypto c => Decoder s (Addr c, CompactAddr c)
 fromCborBothAddr = do
-  sbs <- decCBOR
-  ifDecoderVersionAtLeast (natVersion @7) (decodeAddrStrict sbs) (decodeAddrDropSlack sbs)
+  ifDecoderVersionAtLeast (natVersion @7) decodeAddrRigorous fromCborBackwardsBothAddr
   where
     -- Starting with Babbage we no longer allow addresses with garbage in them.
-    decodeAddrStrict sbs = flip evalStateT 0 $ do
-      addr <- decodeAddrStateAllowLeftoverT False sbs
-      pure (addr, UnsafeCompactAddr sbs)
-    -- Prior to Babbage era we did not check if a binary blob representing an address was
-    -- fully consumed, so unfortunately we must preserve this behavior. However, we do not
-    -- need to preserve the unconsumed bytes in memory, therefore we can to drop the
-    -- garbage after we successfully decoded the malformed address. We also need to allow
-    -- bogus pointer address to be deserializeable prior to Babbage era.
-    decodeAddrDropSlack sbs = flip evalStateT 0 $ do
-      addr <- decodeAddrStateAllowLeftoverT True sbs
-      bytesConsumed <- get
-      let sbsCropped = SBS.toShort $ BS.take bytesConsumed $ SBS.fromShort sbs
-      pure (addr, UnsafeCompactAddr sbsCropped)
+    decodeAddrRigorous = do
+      sbs <- decCBOR
+      flip evalStateT 0 $ do
+        addr <- decodeAddrStateAllowLeftoverT False sbs
+        pure (addr, UnsafeCompactAddr sbs)
+    {-# INLINE decodeAddrRigorous #-}
 {-# INLINE fromCborBothAddr #-}
 
-fromCborBackwardsBothAddr ::
-  forall c s.
-  Crypto c =>
-  Decoder s (Addr c, CompactAddr c)
-fromCborBackwardsBothAddr = fromCborBothAddr
-{-# DEPRECATED fromCborBackwardsBothAddr "Use `fromCborBothAddr` instead, they are the same" #-}
+-- | Prior to Babbage era we did not check if a binary blob representing an address was
+-- fully consumed, so unfortunately we must preserve this behavior. However, we do not
+-- need to preserve the unconsumed bytes in memory, therefore we can to drop the
+-- garbage after we successfully decoded the malformed address. We also need to allow
+-- bogus pointer address to be deserializeable prior to Babbage era.
+fromCborBackwardsBothAddr :: forall c s. Crypto c => Decoder s (Addr c, CompactAddr c)
+fromCborBackwardsBothAddr = do
+  sbs <- decCBOR
+  flip evalStateT 0 $ do
+    addr <- decodeAddrStateAllowLeftoverT True sbs
+    bytesConsumed <- get
+    let sbsCropped = SBS.toShort $ BS.take bytesConsumed $ SBS.fromShort sbs
+    pure (addr, UnsafeCompactAddr sbsCropped)
+{-# INLINE fromCborBackwardsBothAddr #-}
 
 class AddressBuffer b where
   bufLength :: b -> Int

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

@@ -54,10 +54,12 @@ module Cardano.Ledger.BaseTypes (
   TxIx (..),
   txIxToInt,
   txIxFromIntegral,
+  mkTxIx,
   mkTxIxPartial,
   CertIx (..),
   certIxToInt,
   certIxFromIntegral,
+  mkCertIx,
   mkCertIxPartial,
 
   -- * STS Base
@@ -670,6 +672,10 @@ newtype TxIx = TxIx Word64
   deriving stock (Eq, Ord, Show, Generic)
   deriving newtype (NFData, Enum, Bounded, NoThunks, EncCBOR, DecCBOR, ToCBOR, FromCBOR, ToJSON)
 
+-- | Construct a `TxIx` from a 16 bit unsigned integer
+mkTxIx :: Word16 -> TxIx
+mkTxIx = TxIx . fromIntegral
+
 txIxToInt :: TxIx -> Int
 txIxToInt (TxIx w16) = fromIntegral w16
 
@@ -690,6 +696,10 @@ newtype CertIx = CertIx Word64
   deriving stock (Eq, Ord, Show)
   deriving newtype (NFData, Enum, Bounded, NoThunks, EncCBOR, DecCBOR, ToCBOR, FromCBOR, ToJSON)
 
+-- | Construct a `CertIx` from a 16 bit unsigned integer
+mkCertIx :: Word16 -> CertIx
+mkCertIx = CertIx . fromIntegral
+
 certIxToInt :: CertIx -> Int
 certIxToInt (CertIx w16) = fromIntegral w16
 

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

@@ -21,6 +21,7 @@ module Cardano.Ledger.Credential (
   ptrCertIx,
   StakeCredential,
   StakeReference (..),
+  normalizePtr,
 )
 where
 
@@ -58,7 +59,7 @@ import Data.Aeson (
 import qualified Data.Aeson as Aeson
 import Data.Foldable (asum)
 import Data.Typeable (Typeable)
-import Data.Word (Word8)
+import Data.Word
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
 import Quiet (Quiet (Quiet))
@@ -141,6 +142,21 @@ data Ptr = Ptr !SlotNo !TxIx !CertIx
   deriving (Eq, Ord, Generic, NFData, NoThunks)
   deriving (EncCBOR, DecCBOR) via CBORGroup Ptr
 
+-- | Convert any invalid `Ptr` to a `Ptr` that contains all zeros for its fields. Any
+-- pointer that contains a `SlotNo`, `TxIx` or `CertIx` that is too large to fit into
+-- `Word32`, `Word16` and `Word16` respectively is considered to be an invalid
+-- `Ptr`. Valid `Ptr`s will be returned unmodified.
+--
+-- /Note/ - This is in no way related to dangling pointers, with an exception that any
+-- invalid `Ptr` is guarateed to be a dangling `Ptr`.
+normalizePtr :: Ptr -> Ptr
+normalizePtr ptr@(Ptr (SlotNo slotNo) (TxIx txIx) (CertIx certIx))
+  | slotNo > fromIntegral (maxBound :: Word32)
+      || txIx > fromIntegral (maxBound :: Word16)
+      || certIx > fromIntegral (maxBound :: Word16) =
+      Ptr (SlotNo 0) (TxIx 0) (CertIx 0)
+  | otherwise = ptr
+
 instance ToCBOR Ptr where
   toCBOR (Ptr slotNo txIx certIx) = toCBOR (slotNo, txIx, certIx)