Version ledger tables and encode TxIns in big-endian

ouroboros-consensus-cardano/app/snapshot-converter.hs

@@ -287,7 +287,7 @@ main = withStdTerminalHandles $ do
         let crcOut = maybe inCRC (crcOfConcat inCRC) mCRCOut
 
         lift $ putStr "Generating new metadata file..." >> hFlush stdout
-        putMetadata outFilePath (SnapshotMetadata outBackend crcOut)
+        putMetadata outFilePath (SnapshotMetadata outBackend crcOut TablesCodecVersion1)
 
         lift $ putColored Green True "Done"
 
@@ -356,7 +356,7 @@ main = withStdTerminalHandles $ do
         InEnv
           st
           fp
-          (fromInMemory (fp F.</> "tables" F.</> "tvar"))
+          (fromInMemory (fp F.</> "tables"))
           ("InMemory@[" <> fp <> "]")
           c
           mtd
@@ -412,7 +412,7 @@ main = withStdTerminalHandles $ do
       pure $
         OutEnv
           fp
-          (toInMemory (fp F.</> "tables" F.</> "tvar"))
+          (toInMemory (fp F.</> "tables"))
           (Just "tables")
           (Nothing)
           ("InMemory@[" <> fp <> "]")

ouroboros-consensus-cardano/changelog.d/20251010_111741_javier.sagredo_version_tables.md

@@ -0,0 +1,26 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->
+<!--
+### Non-Breaking
+
+- A bullet item for the Non-Breaking category.
+
+-->
+
+### Breaking
+
+- Flip serialization of `TxIx` in Mempack, to ensure lexicographic order on the
+  serialized form matches the Haskell Ord, allowing for incremental streaming of
+  values among backends. Note this happens at the same time as the versioning of
+  the LedgerTables codec which will induce a replay of the chain.

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -378,6 +378,7 @@ test-suite shelley-test
     contra-tracer,
     filepath,
     measures,
+    mempack,
     microlens,
     ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib},
     ouroboros-consensus-cardano,

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE EmptyCase #-}
@@ -12,7 +13,10 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-x-ord-preserving-coercions #-}
+#if __GLASGOW_HASKELL__ < 908
+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-}
+#endif
 
 module Ouroboros.Consensus.Cardano.CanHardFork
   ( CardanoHardForkConstraints
@@ -92,7 +96,7 @@ import Ouroboros.Consensus.Shelley.Node ()
 import Ouroboros.Consensus.Shelley.Protocol.Praos ()
 import Ouroboros.Consensus.Shelley.ShelleyHFC
 import Ouroboros.Consensus.TypeFamilyWrappers
-import Ouroboros.Consensus.Util (eitherToMaybe)
+import Ouroboros.Consensus.Util (coerceMapKeys, eitherToMaybe)
 
 {-------------------------------------------------------------------------------
   CanHardFork
@@ -466,6 +470,7 @@ translateLedgerStateShelleyToAllegraWrapper =
                 LedgerTables
                   . DiffMK
                   . Diff.fromMapDeletes
+                  . coerceMapKeys
                   . Map.map SL.upgradeTxOut
                   $ avvms
 
@@ -478,6 +483,7 @@ translateLedgerStateShelleyToAllegraWrapper =
                   . withLedgerTables ls
                   . LedgerTables
                   . ValuesMK
+                  . coerceMapKeys
                   $ avvms
 
               resultingState =

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs

@@ -28,7 +28,6 @@ import Cardano.Ledger.Binary.Decoding hiding (Decoder)
 import Cardano.Ledger.Binary.Encoding hiding (Encoding)
 import qualified Cardano.Ledger.Conway.State as SL
 import Cardano.Ledger.Core (Era, eraDecoder, eraProtVerLow)
-import qualified Cardano.Ledger.Shelley.API as SL
 import Cardano.Ledger.Shelley.LedgerState as SL
   ( esLStateL
   , lsCertStateL
@@ -57,7 +56,8 @@ import Ouroboros.Consensus.Ledger.Tables
 import Ouroboros.Consensus.Protocol.Praos (Praos)
 import Ouroboros.Consensus.Protocol.TPraos (TPraos)
 import Ouroboros.Consensus.Shelley.Ledger
-  ( IsShelleyBlock
+  ( BigEndianTxIn
+  , IsShelleyBlock
   , ShelleyBlock
   , ShelleyCompatible
   , shelleyLedgerState
@@ -70,7 +70,7 @@ instance
   HasCanonicalTxIn (CardanoEras c)
   where
   newtype CanonicalTxIn (CardanoEras c) = CardanoTxIn
-    { getCardanoTxIn :: SL.TxIn
+    { getCardanoTxIn :: BigEndianTxIn
     }
     deriving stock (Show, Eq, Ord)
     deriving newtype NoThunks

ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs

@@ -19,6 +19,7 @@
 
 module Ouroboros.Consensus.Cardano.QueryHF () where
 
+import Data.Coerce
 import Data.Functor.Product
 import Data.SOP.BasicFunctors
 import Data.SOP.Constraint
@@ -98,14 +99,14 @@ instance CardanoHardForkConstraints c => BlockSupportsHFLedgerQuery (CardanoEras
           answerShelleyLookupQueries
             (injectLedgerTables idx)
             (ejectHardForkTxOut idx)
-            (ejectCanonicalTxIn idx)
+            (coerce . ejectCanonicalTxIn idx)
       )
   answerBlockQueryHFTraverse =
     answerCardanoQueryHF
       ( \idx ->
           answerShelleyTraversingQueries
             (ejectHardForkTxOut idx)
-            (ejectCanonicalTxIn idx)
+            (coerce . ejectCanonicalTxIn idx)
             (queryLedgerGetTraversingFilter idx)
       )
 

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -19,7 +19,10 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-x-ord-preserving-coercions #-}
+#if __GLASGOW_HASKELL__ < 908
+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-}
+#endif
 
 module Ouroboros.Consensus.Shelley.Ledger.Ledger
   ( LedgerState (..)
@@ -54,10 +57,11 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger
 
     -- * Low-level UTxO manipulations
   , slUtxoL
+  , BigEndianTxIn (..)
   ) where
 
 import qualified Cardano.Ledger.BHeaderView as SL (BHeaderView)
-import qualified Cardano.Ledger.BaseTypes as SL (epochInfoPure)
+import qualified Cardano.Ledger.BaseTypes as SL (TxIx (..), epochInfoPure)
 import Cardano.Ledger.BaseTypes.NonZero (unNonZero)
 import Cardano.Ledger.Binary.Decoding
   ( decShareCBOR
@@ -97,7 +101,7 @@ import Control.Arrow (left, second)
 import qualified Control.Exception as Exception
 import Control.Monad.Except
 import qualified Control.State.Transition.Extended as STS
-import Data.Coerce (coerce)
+import Data.Coerce
 import Data.Functor.Identity
 import Data.MemPack
 import qualified Data.Text as T
@@ -130,6 +134,7 @@ import Ouroboros.Consensus.Shelley.Protocol.Abstract
   , mkHeaderView
   )
 import Ouroboros.Consensus.Storage.LedgerDB
+import Ouroboros.Consensus.Util
 import Ouroboros.Consensus.Util.CBOR
   ( decodeWithOrigin
   , encodeWithOrigin
@@ -317,7 +322,34 @@ shelleyLedgerTipPoint = shelleyTipToPoint . shelleyLedgerTip
 
 instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era)
 
-type instance TxIn (LedgerState (ShelleyBlock proto era)) = SL.TxIn
+-- | The only purpose of this type is to modify the MemPack instance to use big
+-- endian serialization. This is necessary to ensure streaming functions of the
+-- UTxO set preserve the order of the entries, as otherwise we would get
+-- different sortings if sorting via the Serialized form and the Haskell Ord
+-- instance.
+--
+-- TODO: fix this in the Ledger. See cardano-ledger#5336.
+newtype BigEndianTxIn = BigEndianTxIn {getOriginalTxIn :: SL.TxIn}
+  deriving newtype (Eq, Show, Ord, NoThunks)
+
+newtype BigEndianTxIx = BigEndianTxIx {getOriginalTxIx :: SL.TxIx}
+
+instance MemPack BigEndianTxIx where
+  typeName = "BigEndianTxIx"
+  packedByteCount = packedByteCount . getOriginalTxIx
+  packM (BigEndianTxIx (SL.TxIx w)) = packM (byteSwap16 w)
+  unpackM = BigEndianTxIx . SL.TxIx . byteSwap16 <$> unpackM
+
+instance MemPack BigEndianTxIn where
+  typeName = "BigEndianTxIn"
+  packedByteCount = packedByteCount . getOriginalTxIn
+  packM (BigEndianTxIn (SL.TxIn txid txix)) = do
+    packM txid
+    packM (BigEndianTxIx txix)
+  unpackM = do
+    BigEndianTxIn <$> (SL.TxIn <$> unpackM <*> (getOriginalTxIx <$> unpackM))
+
+type instance TxIn (LedgerState (ShelleyBlock proto era)) = BigEndianTxIn
 type instance TxOut (LedgerState (ShelleyBlock proto era)) = Core.TxOut era
 
 instance
@@ -397,7 +429,7 @@ instance
       , shelleyLedgerTables = emptyLedgerTables
       }
    where
-    (_, shelleyLedgerState') = shelleyLedgerState `slUtxoL` SL.UTxO m
+    (_, shelleyLedgerState') = shelleyLedgerState `slUtxoL` SL.UTxO (coerceMapKeys m)
     ShelleyLedgerState
       { shelleyLedgerTip
       , shelleyLedgerState
@@ -409,7 +441,7 @@ instance
       { shelleyLedgerTip = shelleyLedgerTip
       , shelleyLedgerState = shelleyLedgerState'
       , shelleyLedgerTransition = shelleyLedgerTransition
-      , shelleyLedgerTables = LedgerTables (ValuesMK (SL.unUTxO tbs))
+      , shelleyLedgerTables = LedgerTables (ValuesMK (coerceMapKeys $ SL.unUTxO tbs))
       }
    where
     (tbs, shelleyLedgerState') = shelleyLedgerState `slUtxoL` mempty
@@ -432,7 +464,7 @@ instance
       }
    where
     (_, tickedShelleyLedgerState') =
-      tickedShelleyLedgerState `slUtxoL` SL.UTxO tbs
+      tickedShelleyLedgerState `slUtxoL` SL.UTxO (coerceMapKeys tbs)
     TickedShelleyLedgerState
       { untickedShelleyLedgerTip
       , tickedShelleyLedgerTransition
@@ -445,7 +477,7 @@ instance
       { untickedShelleyLedgerTip = untickedShelleyLedgerTip
       , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition
       , tickedShelleyLedgerState = tickedShelleyLedgerState'
-      , tickedShelleyLedgerTables = LedgerTables (ValuesMK (SL.unUTxO tbs))
+      , tickedShelleyLedgerTables = LedgerTables (ValuesMK (coerceMapKeys (SL.unUTxO tbs)))
       }
    where
     (tbs, tickedShelleyLedgerState') = tickedShelleyLedgerState `slUtxoL` mempty
@@ -583,6 +615,7 @@ instance
   getBlockKeySets =
     LedgerTables
       . KeysMK
+      . coerceSet
       . Core.neededTxInsForBlock
       . shelleyBlockRaw
 

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -14,7 +15,10 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-x-ord-preserving-coercions #-}
+#if __GLASGOW_HASKELL__ < 908
+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-}
+#endif
 
 -- | Shelley mempool integration
 --
@@ -98,12 +102,13 @@ import Ouroboros.Consensus.Ledger.Tables.Utils
 import Ouroboros.Consensus.Shelley.Eras
 import Ouroboros.Consensus.Shelley.Ledger.Block
 import Ouroboros.Consensus.Shelley.Ledger.Ledger
-  ( ShelleyLedgerConfig (shelleyLedgerGlobals)
+  ( BigEndianTxIn (..)
+  , ShelleyLedgerConfig (shelleyLedgerGlobals)
   , Ticked (TickedShelleyLedgerState, tickedShelleyLedgerState)
   , getPParams
   )
 import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto)
-import Ouroboros.Consensus.Util (ShowProxy (..))
+import Ouroboros.Consensus.Util (ShowProxy (..), coerceSet)
 import Ouroboros.Consensus.Util.Condense
 import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)
 
@@ -177,8 +182,9 @@ instance
 
   getTransactionKeySets (ShelleyTx _ tx) =
     LedgerTables $
-      KeysMK
-        (tx ^. bodyTxL . allInputsTxBodyF)
+      KeysMK $
+        coerceSet
+          (tx ^. bodyTxL . allInputsTxBodyF)
 
 mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era)
 mkShelleyTx tx = ShelleyTx (txIdTx tx) tx

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs

@@ -18,7 +18,10 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# OPTIONS_GHC -Wno-orphans -Wno-x-ord-preserving-coercions #-}
+#if __GLASGOW_HASKELL__ < 908
+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags #-}
+#endif
 
 module Ouroboros.Consensus.Shelley.Ledger.Query
   ( BlockQuery (..)
@@ -67,6 +70,7 @@ import qualified Codec.CBOR.Encoding as CBOR
 import Codec.Serialise (decode, encode)
 import Control.DeepSeq (NFData)
 import Data.Bifunctor (second)
+import Data.Coerce
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import Data.MemPack
@@ -105,7 +109,7 @@ import Ouroboros.Consensus.Shelley.Ledger.Query.Types
 import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto)
 import Ouroboros.Consensus.Storage.LedgerDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
-import Ouroboros.Consensus.Util (ShowProxy (..))
+import Ouroboros.Consensus.Util (ShowProxy (..), coerceSet)
 import Ouroboros.Consensus.Util.IndexedMemPack
 import Ouroboros.Network.Block
   ( Serialised (..)
@@ -543,9 +547,9 @@ instance
     hst = headerState ext
     st = shelleyLedgerState lst
 
-  answerBlockQueryLookup = answerShelleyLookupQueries id id id
+  answerBlockQueryLookup = answerShelleyLookupQueries id id coerce
 
-  answerBlockQueryTraverse = answerShelleyTraversingQueries id id shelleyQFTraverseTablesPredicate
+  answerBlockQueryTraverse = answerShelleyTraversingQueries id coerce shelleyQFTraverseTablesPredicate
 
   -- \| Is the given query supported by the given 'ShelleyNodeToClientVersion'?
   blockQueryIsSupportedOnVersion = \case
@@ -1231,7 +1235,7 @@ answerShelleyLookupQueries injTables ejTxOut ejTxIn cfg q forker =
     LedgerTables (ValuesMK values) <-
       LedgerDB.roforkerReadTables
         forker
-        (castLedgerTables $ injTables (LedgerTables $ KeysMK txins))
+        (castLedgerTables $ injTables (LedgerTables $ KeysMK $ coerceSet txins))
     pure $
       SL.UTxO $
         Map.mapKeys ejTxIn $

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs

@@ -425,7 +425,7 @@ instance
   HasCanonicalTxIn '[ShelleyBlock proto era]
   where
   newtype CanonicalTxIn '[ShelleyBlock proto era] = ShelleyBlockHFCTxIn
-    { getShelleyBlockHFCTxIn :: SL.TxIn
+    { getShelleyBlockHFCTxIn :: BigEndianTxIn
     }
     deriving stock (Show, Eq, Ord)
     deriving newtype (NoThunks, MemPack)
@@ -462,14 +462,14 @@ instance
   BlockSupportsHFLedgerQuery '[ShelleyBlock proto era]
   where
   answerBlockQueryHFLookup = \case
-    IZ -> answerShelleyLookupQueries (injectLedgerTables IZ) id (ejectCanonicalTxIn IZ)
+    IZ -> answerShelleyLookupQueries (injectLedgerTables IZ) id (coerce . ejectCanonicalTxIn IZ)
     IS idx -> case idx of {}
 
   answerBlockQueryHFTraverse = \case
     IZ ->
       answerShelleyTraversingQueries
         id
-        (ejectCanonicalTxIn IZ)
+        (coerce . ejectCanonicalTxIn IZ)
         (queryLedgerGetTraversingFilter @('[ShelleyBlock proto era]) IZ)
     IS idx -> case idx of {}