Merge pull request #4913 from IntersectMBO/lehins/fix-pointer-decoding-leniency

Fix various issues with Ptr decoding

Author: lehins

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

@@ -47,7 +47,6 @@ import Cardano.Ledger.Address (
   compactAddr,
   decompactAddr,
   fromCborBothAddr,
-  fromCborRigorousBothAddr,
  )
 import Cardano.Ledger.Alonzo.Core
 import Cardano.Ledger.Alonzo.TxBody (
@@ -535,7 +534,7 @@ instance
       peekTokenType >>= \case
         TypeBytes -> decodeMemPack
         TypeBytesIndef -> decodeMemPack
-        _ -> decodeBabbageTxOut fromCborRigorousBothAddr
+        _ -> decCBOR
     pure $! internBabbageTxOut (interns credsInterns) txOut
   {-# INLINEABLE decShareCBOR #-}
 

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

@@ -20,7 +20,7 @@ module Cardano.Ledger.Conway.Translation (
 import Cardano.Ledger.Address (addrPtrNormalize)
 import Cardano.Ledger.Babbage (BabbageEra)
 import Cardano.Ledger.Binary (DecoderError)
-import Cardano.Ledger.CertState (CommitteeState (..), upgradeCertState)
+import Cardano.Ledger.CertState (EraCertState (..))
 import Cardano.Ledger.Conway.CertState ()
 import Cardano.Ledger.Conway.Core hiding (Tx)
 import Cardano.Ledger.Conway.Era (ConwayEra)
@@ -46,12 +46,12 @@ import Cardano.Ledger.Shelley.API (
   PState (..),
   StrictMaybe (..),
   UTxOState (..),
-  VState (..),
  )
 import qualified Cardano.Ledger.Shelley.API as API
-import Cardano.Ledger.Shelley.CertState (ShelleyCertState)
+import Cardano.Ledger.Shelley.CertState (ShelleyCertState (..))
 import Cardano.Ledger.Shelley.LedgerState (
   epochStateGovStateL,
+  lsCertStateL,
  )
 import qualified Cardano.Ledger.UMap as UM
 import Data.Default (Default (def))
@@ -147,26 +147,20 @@ instance TranslateEra ConwayEra DState where
           , UM.umPtrs = mempty
           }
 
-instance TranslateEra ConwayEra CommitteeState where
-  translateEra _ CommitteeState {..} = pure CommitteeState {..}
-
-instance TranslateEra ConwayEra VState where
-  translateEra ctx VState {..} = do
-    committeeState <- translateEra ctx vsCommitteeState
-    pure VState {vsCommitteeState = committeeState, ..}
-
 instance TranslateEra ConwayEra PState where
   translateEra _ PState {..} = pure PState {..}
 
-instance TranslateEra ConwayEra ShelleyCertState where
-  translateEra ConwayGenesis {} = pure . upgradeCertState
-
 instance TranslateEra ConwayEra API.LedgerState where
   translateEra conwayGenesis ls =
     pure
       API.LedgerState
         { API.lsUTxOState = translateEra' conwayGenesis $ API.lsUTxOState ls
-        , API.lsCertState = translateEra' conwayGenesis $ API.lsCertState ls
+        , API.lsCertState =
+            ShelleyCertState
+              { shelleyCertDState = translateEra' conwayGenesis (ls ^. lsCertStateL . certDStateL)
+              , shelleyCertPState = translateEra' conwayGenesis (ls ^. lsCertStateL . certPStateL)
+              , shelleyCertVState = def
+              }
         }
 
 translateGovState ::

libs/cardano-ledger-core/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 1.17.0.0
 
+* Add boolean argument to `fromCborRigorousBothAddr` for lenient `Ptr` decoding
 * Add `ToCBOR` and `FromCBOR` instances for:
   * `BoundedRatio`
   * `PositiveUnitInterval`

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

@@ -7,9 +7,7 @@
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE InstanceSigs #-}
-{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeSynonymInstances #-}
@@ -427,15 +425,25 @@ fromCborCompactAddr = snd <$> fromCborBothAddr
 -- that it was encoded as.
 fromCborBothAddr :: Decoder s (Addr, CompactAddr)
 fromCborBothAddr = do
-  ifDecoderVersionAtLeast (natVersion @7) fromCborRigorousBothAddr fromCborBackwardsBothAddr
+  ifDecoderVersionAtLeast
+    (natVersion @7)
+    ( ifDecoderVersionAtLeast
+        (natVersion @9)
+        (fromCborRigorousBothAddr False)
+        (fromCborRigorousBothAddr True)
+    )
+    fromCborBackwardsBothAddr
 {-# INLINE fromCborBothAddr #-}
 
 -- | Starting with Babbage we no longer allow addresses with garbage in them.
-fromCborRigorousBothAddr :: Decoder s (Addr, CompactAddr)
-fromCborRigorousBothAddr = do
+fromCborRigorousBothAddr ::
+  -- | Should there be a hard failure for garbage pointers (`False`) or should they be normalized instead (`True`)
+  Bool ->
+  Decoder s (Addr, CompactAddr)
+fromCborRigorousBothAddr isPtrLenient = do
   sbs <- decCBOR
   flip evalStateT 0 $ do
-    addr <- decodeAddrStateLenientT False False sbs
+    addr <- decodeAddrStateLenientT isPtrLenient False sbs
     pure (addr, UnsafeCompactAddr sbs)
 {-# INLINE fromCborRigorousBothAddr #-}
 

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

@@ -320,4 +320,4 @@ instance DecCBORGroup Ptr where
   decCBORGroup = do
     let decPtrStrict = Ptr <$> decCBOR <*> decCBOR <*> decCBOR
         decPtrNormalized = mkPtrNormalized <$> decCBOR <*> decCBOR <*> decCBOR
-    ifDecoderVersionAtLeast (natVersion @7) decPtrStrict decPtrNormalized
+    ifDecoderVersionAtLeast (natVersion @9) decPtrStrict decPtrNormalized

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

@@ -11,7 +11,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 

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

@@ -121,7 +121,7 @@ import Cardano.Ledger.BaseTypes (strictMaybe)
 import Cardano.Ledger.Binary
 import Cardano.Ledger.Coin (Coin (..), CompactForm (CompactCoin), compactCoinOrError)
 import Cardano.Ledger.Compactible (Compactible (..))
-import Cardano.Ledger.Credential (Credential (..), Ptr)
+import Cardano.Ledger.Credential (Credential (..), Ptr, mkPtrNormalized)
 import Cardano.Ledger.DRep (DRep)
 import Cardano.Ledger.Keys (KeyHash, KeyRole (..))
 import Control.DeepSeq (NFData (..))
@@ -469,11 +469,18 @@ instance DecShareCBOR UMap where
           decodeRecordNamed "UMap" (const 2) $ do
             umElems <- decodeMap (interns a <$> decCBOR) (decShareCBOR (b, c))
             let a' = internsFromMap umElems <> a
+                decodePtrNormalized =
+                  decodeRecordNamed "Ptr" (const 3) $
+                    mkPtrNormalized <$> decCBOR <*> decCBOR <*> decCBOR
+                decDropPtrMap = do
+                  m <- decodeMap decodePtrNormalized decCBOR
+                  -- ensure that we are dropping the same type as needed for decoding
+                  let idConst :: a -> a -> a
+                      idConst = const
+                  pure $ idConst mempty m
             umPtrs <-
-              ifDecoderVersionAtLeast
-                (natVersion @9)
-                (mempty <$ dropCBOR (Proxy @(Map (Credential 'Staking) (Set Ptr))))
-                $ decodeMap decCBOR (interns a' <$> decCBOR)
+              ifDecoderVersionAtLeast (natVersion @9) decDropPtrMap $
+                decodeMap decCBOR (interns a' <$> decCBOR)
             pure (UMap {umElems, umPtrs}, (a', b, c))
       )