Flip TxIx serialization to big endian

jasagredo · jasagredo · commit a27507551ea6 · 2025-09-02T17:29:27.000+02:00
diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Alonzo b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Alonzo
diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Babbage
diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Conway
diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Dijkstra
diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/CanHardFork.hs
@@ -466,6 +466,7 @@ translateLedgerStateShelleyToAllegraWrapper =
                 LedgerTables
                   . DiffMK
                   . Diff.fromMapDeletes
+                  . coerceTxInMapKeys
                   . Map.map SL.upgradeTxOut
                   $ avvms
 
@@ -478,6 +479,7 @@ translateLedgerStateShelleyToAllegraWrapper =
                   . withLedgerTables ls
                   . LedgerTables
                   . ValuesMK
+                  . coerceTxInMapKeys
                   $ avvms
 
               resultingState =
diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Ledger.hs b/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
diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/QueryHF.hs b/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)
       )
 
diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs
@@ -54,10 +54,13 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger
 
     -- * Low-level UTxO manipulations
   , slUtxoL
+  , BigEndianTxIn (..)
+  , coerceTxInSet
+  , coerceTxInMapKeys
   ) 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,9 +100,11 @@ 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.Map.Strict (Map)
 import Data.MemPack
+import Data.Set (Set)
 import qualified Data.Text as T
 import qualified Data.Text as Text
 import Data.Word
@@ -135,7 +140,9 @@ import Ouroboros.Consensus.Util.CBOR
   , encodeWithOrigin
   )
 import Ouroboros.Consensus.Util.IndexedMemPack
+import Ouroboros.Consensus.Util.RedundantConstraints (keepRedundantConstraint)
 import Ouroboros.Consensus.Util.Versioned
+import Unsafe.Coerce
 
 {-------------------------------------------------------------------------------
   Config
@@ -317,7 +324,32 @@ 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.
+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 (coerceTxInMapKeys m)
     ShelleyLedgerState
       { shelleyLedgerTip
       , shelleyLedgerState
@@ -409,7 +441,7 @@ instance
       { shelleyLedgerTip = shelleyLedgerTip
       , shelleyLedgerState = shelleyLedgerState'
       , shelleyLedgerTransition = shelleyLedgerTransition
-      , shelleyLedgerTables = LedgerTables (ValuesMK (SL.unUTxO tbs))
+      , shelleyLedgerTables = LedgerTables (ValuesMK (coerceTxInMapKeys $ SL.unUTxO tbs))
       }
    where
     (tbs, shelleyLedgerState') = shelleyLedgerState `slUtxoL` mempty
@@ -419,6 +451,16 @@ instance
       , shelleyLedgerTransition
       } = st
 
+coerceTxInMapKeys :: forall k1 k2 v. Coercible k1 k2 => Map k1 v -> Map k2 v
+coerceTxInMapKeys = unsafeCoerce
+ where
+  _ = keepRedundantConstraint (Proxy @(Coercible k1 k2))
+
+coerceTxInSet :: forall k1 k2. Coercible k1 k2 => Set k1 -> Set k2
+coerceTxInSet = unsafeCoerce
+ where
+  _ = keepRedundantConstraint (Proxy @(Coercible k1 k2))
+
 instance
   ShelleyBasedEra era =>
   CanStowLedgerTables (Ticked (LedgerState (ShelleyBlock proto era)))
@@ -432,7 +474,7 @@ instance
       }
    where
     (_, tickedShelleyLedgerState') =
-      tickedShelleyLedgerState `slUtxoL` SL.UTxO tbs
+      tickedShelleyLedgerState `slUtxoL` SL.UTxO (coerceTxInMapKeys tbs)
     TickedShelleyLedgerState
       { untickedShelleyLedgerTip
       , tickedShelleyLedgerTransition
@@ -445,7 +487,7 @@ instance
       { untickedShelleyLedgerTip = untickedShelleyLedgerTip
       , tickedShelleyLedgerTransition = tickedShelleyLedgerTransition
       , tickedShelleyLedgerState = tickedShelleyLedgerState'
-      , tickedShelleyLedgerTables = LedgerTables (ValuesMK (SL.unUTxO tbs))
+      , tickedShelleyLedgerTables = LedgerTables (ValuesMK (coerceTxInMapKeys (SL.unUTxO tbs)))
       }
    where
     (tbs, tickedShelleyLedgerState') = tickedShelleyLedgerState `slUtxoL` mempty
@@ -583,6 +625,7 @@ instance
   getBlockKeySets =
     LedgerTables
       . KeysMK
+      . coerceTxInSet
       . Core.neededTxInsForBlock
       . shelleyBlockRaw
 
diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs
@@ -98,8 +98,10 @@ 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)
+  , coerceTxInSet
   , getPParams
   )
 import Ouroboros.Consensus.Shelley.Protocol.Abstract (ProtoCrypto)
@@ -177,8 +179,9 @@ instance
 
   getTransactionKeySets (ShelleyTx _ tx) =
     LedgerTables $
-      KeysMK
-        (tx ^. bodyTxL . allInputsTxBodyF)
+      KeysMK $
+        coerceTxInSet
+          (tx ^. bodyTxL . allInputsTxBodyF)
 
 mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era)
 mkShelleyTx tx = ShelleyTx (txIdTx tx) tx
diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs
@@ -67,6 +67,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
@@ -554,9 +555,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
@@ -1242,7 +1243,7 @@ answerShelleyLookupQueries injTables ejTxOut ejTxIn cfg q forker =
     LedgerTables (ValuesMK values) <-
       LedgerDB.roforkerReadTables
         forker
-        (castLedgerTables $ injTables (LedgerTables $ KeysMK txins))
+        (castLedgerTables $ injTables (LedgerTables $ KeysMK $ coerceTxInSet txins))
     pure $
       SL.UTxO $
         Map.mapKeys ejTxIn $
diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/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 {}
 
diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs
@@ -357,15 +357,15 @@ instance
           answerShelleyLookupQueries
             (injectLedgerTables idx)
             (ejectHardForkTxOutDefault idx)
-            (ejectCanonicalTxIn idx)
+            (coerce . ejectCanonicalTxIn idx)
       )
 
   answerBlockQueryHFTraverse =
     answerShelleyBasedQueryHF
       ( \idx ->
           answerShelleyTraversingQueries
             (ejectHardForkTxOutDefault idx)
-            (ejectCanonicalTxIn idx)
+            (coerce . ejectCanonicalTxIn idx)
             (queryLedgerGetTraversingFilter @('[ShelleyBlock proto1 era1, ShelleyBlock proto2 era2]) idx)
       )
 
@@ -494,7 +494,7 @@ instance
   where
   newtype CanonicalTxIn (ShelleyBasedHardForkEras proto1 era1 proto2 era2)
     = ShelleyHFCTxIn
-    { getShelleyHFCTxIn :: SL.TxIn
+    { getShelleyHFCTxIn :: BigEndianTxIn
     }
     deriving stock (Show, Eq, Ord)
     deriving newtype (NoThunks, MemPack)
diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs
@@ -102,7 +102,7 @@ mkLedgerTables tx =
       Map.fromList $
         zip exampleTxIns exampleTxOuts
  where
-  exampleTxIns :: [SL.TxIn]
+  exampleTxIns :: [BigEndianTxIn]
   exampleTxIns = case toList (tx ^. (LC.bodyTxL . LC.allInputsTxBodyF)) of
     [] -> error "No transaction inputs were provided to construct the ledger tables"
     -- We require at least one transaction input (and one
@@ -112,7 +112,7 @@ mkLedgerTables tx =
     --
     -- Also all transactions in Cardano have at least one input for
     -- automatic replay protection.
-    xs -> xs
+    xs -> map BigEndianTxIn xs
 
   exampleTxOuts :: [LC.TxOut era]
   exampleTxOuts = case toList (tx ^. (LC.bodyTxL . LC.outputsTxBodyL)) of
diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Generators.hs
@@ -1,9 +1,12 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -239,6 +242,8 @@ instance
       <*> arbitrary
       <*> (LedgerTables . ValuesMK <$> arbitrary)
 
+deriving newtype instance Arbitrary BigEndianTxIn
+
 instance CanMock proto era => Arbitrary (AnnTip (ShelleyBlock proto era)) where
   arbitrary =
     AnnTip
diff --git a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs
