Add ConvertRawTxId, use it for comparing OneEraGenTxIds

ouroboros-consensus-cardano/changelog.d/20240325_124120_alexander.esgen_compare_txid_on_raw_hash.md

@@ -0,0 +1,3 @@
+### Non-Breaking
+
+- Add `ConvertRawTxId` instances for Shelley and Byron.

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs

@@ -47,6 +47,7 @@ import qualified Cardano.Chain.Update as Update
 import qualified Cardano.Chain.UTxO as Utxo
 import qualified Cardano.Chain.ValidationMode as CC
 import           Cardano.Crypto (hashDecoded)
+import qualified Cardano.Crypto as CC
 import           Cardano.Ledger.Binary (ByteSpan, DecoderError (..),
                      byronProtVer, fromByronCBOR, serialize, slice, toByronCBOR,
                      unsafeDeserialize)
@@ -162,6 +163,12 @@ instance HasTxId (GenTx ByronBlock) where
   txId (ByronUpdateProposal i _) = ByronUpdateProposalId i
   txId (ByronUpdateVote     i _) = ByronUpdateVoteId     i
 
+instance ConvertRawTxId (GenTx ByronBlock) where
+  toRawTxIdHash (ByronTxId             i) = CC.abstractHashToShort i
+  toRawTxIdHash (ByronDlgId            i) = CC.abstractHashToShort i
+  toRawTxIdHash (ByronUpdateProposalId i) = CC.abstractHashToShort i
+  toRawTxIdHash (ByronUpdateVoteId     i) = CC.abstractHashToShort i
+
 instance HasTxs ByronBlock where
   extractTxs blk = case byronBlockRaw blk of
     -- EBBs don't contain transactions

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

@@ -34,6 +34,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Mempool (
   , fromExUnits
   ) where
 
+import qualified Cardano.Crypto.Hash as Hash
 import           Cardano.Ledger.Alonzo.Core (Tx, TxSeq, bodyTxL, eraProtVerLow,
                      fromTxSeq, ppMaxBBSizeL, ppMaxBlockExUnitsL, sizeTxF)
 import           Cardano.Ledger.Alonzo.Scripts (ExUnits, ExUnits',
@@ -44,6 +45,7 @@ import           Cardano.Ledger.Binary (Annotator (..), DecCBOR (..),
                      ToCBOR (..), toPlainDecoder)
 import qualified Cardano.Ledger.Core as SL (txIdTxBody)
 import           Cardano.Ledger.Crypto (Crypto)
+import qualified Cardano.Ledger.SafeHash as SL
 import qualified Cardano.Ledger.Shelley.API as SL
 import           Control.Monad.Except (Except)
 import           Control.Monad.Identity (Identity (..))
@@ -171,6 +173,10 @@ instance (Typeable era, Typeable proto)
 instance ShelleyBasedEra era => HasTxId (GenTx (ShelleyBlock proto era)) where
   txId (ShelleyTx i _) = ShelleyTxId i
 
+instance ShelleyBasedEra era => ConvertRawTxId (GenTx (ShelleyBlock proto era)) where
+  toRawTxIdHash (ShelleyTxId i) =
+      Hash.hashToBytesShort . SL.extractHash . SL.unTxId $ i
+
 instance ShelleyBasedEra era => HasTxs (ShelleyBlock proto era) where
   extractTxs =
         map mkShelleyTx

ouroboros-consensus-diffusion/changelog.d/20240325_124036_alexander.esgen_compare_txid_on_raw_hash.md

@@ -0,0 +1,3 @@
+### Non-Breaking
+
+- Add `ConvertRawTxId` instances.

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs

@@ -44,7 +44,9 @@ import           Control.Monad (guard)
 import           Control.Monad.Except (runExcept)
 import qualified Data.Binary as B
 import           Data.ByteString as Strict
+import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Lazy as Lazy
+import qualified Data.ByteString.Short as SBS
 import           Data.Functor.Identity (Identity)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
@@ -336,6 +338,9 @@ newtype instance TxId (GenTx BlockA) = TxIdA Int
 instance HasTxId (GenTx BlockA) where
   txId = txA_id
 
+instance ConvertRawTxId (GenTx BlockA) where
+  toRawTxIdHash = SBS.toShort . BL.toStrict . serialise
+
 instance ShowQuery (BlockQuery BlockA) where
   showResult qry = case qry of {}
 

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs

@@ -273,6 +273,9 @@ data instance TxId (GenTx BlockB)
 instance HasTxId (GenTx BlockB) where
   txId tx = case tx of {}
 
+instance ConvertRawTxId (GenTx BlockB) where
+  toRawTxIdHash = \case {}
+
 instance ShowQuery (BlockQuery BlockB) where
   showResult qry = case qry of {}
 

ouroboros-consensus/changelog.d/20240325_123915_alexander.esgen_compare_txid_on_raw_hash.md

@@ -0,0 +1,3 @@
+### Breaking
+
+- Add `ConvertRawTxId` and require it for `SingleEraBlock`.

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs

@@ -56,7 +56,7 @@ import           Ouroboros.Consensus.Util.Condense
 class ( LedgerSupportsProtocol blk
       , InspectLedger blk
       , LedgerSupportsMempool blk
-      , HasTxId (GenTx blk)
+      , ConvertRawTxId (GenTx blk)
       , QueryLedger blk
       , HasPartialConsensusConfig (BlockProtocol blk)
       , HasPartialLedgerConfig blk

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/AcrossEras.hs

@@ -66,6 +66,7 @@ import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Char8 as BSC
 import           Data.ByteString.Short (ShortByteString)
 import qualified Data.ByteString.Short as Short
+import           Data.Function (on)
 import           Data.Proxy
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Constraint
@@ -156,6 +157,23 @@ instance Show (OneEraHash xs) where
 instance Condense (OneEraHash xs) where
   condense = show
 
+{-------------------------------------------------------------------------------
+  OneEraGenTxId
+-------------------------------------------------------------------------------}
+
+-- | This instance compares the underlying raw hash ('toRawTxIdHash') of the
+-- 'TxId'.
+--
+-- Note that this means that transactions in different eras can have equal
+-- 'TxId's. This should only be the case when the transaction format is
+-- backwards compatible from one era to the next.
+instance CanHardFork xs => Eq (OneEraGenTxId xs) where
+  (==) = (==) `on` oneEraGenTxIdRawHash
+
+-- | See the corresponding 'Eq' instance.
+instance CanHardFork xs => Ord (OneEraGenTxId xs) where
+  compare = compare `on` oneEraGenTxIdRawHash
+
 {-------------------------------------------------------------------------------
   Value for two /different/ eras
 -------------------------------------------------------------------------------}
@@ -245,6 +263,12 @@ getSameValue values =
         | otherwise
         = throwError "differing values across hard fork"
 
+oneEraGenTxIdRawHash :: CanHardFork xs => OneEraGenTxId xs -> ShortByteString
+oneEraGenTxIdRawHash =
+      hcollapse
+    . hcmap proxySingle (K . toRawTxIdHash . unwrapGenTxId)
+    . getOneEraGenTxId
+
 {-------------------------------------------------------------------------------
   NoThunks instances
 -------------------------------------------------------------------------------}
@@ -301,7 +325,6 @@ deriving via LiftNamedMismatch "MismatchEraInfo" SingleEraInfo LedgerEraInfo xs
 deriving via LiftNS WrapApplyTxErr     xs instance CanHardFork xs => Eq (OneEraApplyTxErr     xs)
 deriving via LiftNS WrapEnvelopeErr    xs instance CanHardFork xs => Eq (OneEraEnvelopeErr    xs)
 deriving via LiftNS GenTx              xs instance CanHardFork xs => Eq (OneEraGenTx          xs)
-deriving via LiftNS WrapGenTxId        xs instance CanHardFork xs => Eq (OneEraGenTxId        xs)
 deriving via LiftNS WrapLedgerErr      xs instance CanHardFork xs => Eq (OneEraLedgerError    xs)
 deriving via LiftNS WrapLedgerUpdate   xs instance CanHardFork xs => Eq (OneEraLedgerUpdate   xs)
 deriving via LiftNS WrapLedgerWarning  xs instance CanHardFork xs => Eq (OneEraLedgerWarning  xs)
@@ -310,8 +333,6 @@ deriving via LiftNS WrapTipInfo        xs instance CanHardFork xs => Eq (OneEraT
 deriving via LiftNS WrapValidatedGenTx xs instance CanHardFork xs => Eq (OneEraValidatedGenTx xs)
 deriving via LiftNS WrapValidationErr  xs instance CanHardFork xs => Eq (OneEraValidationErr  xs)
 
-deriving via LiftNS WrapGenTxId xs instance CanHardFork xs => Ord (OneEraGenTxId xs)
-
 deriving via LiftNS WrapEnvelopeErr           xs instance CanHardFork xs => Show (OneEraEnvelopeErr           xs)
 deriving via LiftNS WrapForgeStateInfo        xs instance CanHardFork xs => Show (OneEraForgeStateInfo        xs)
 deriving via LiftNS WrapForgeStateUpdateError xs instance CanHardFork xs => Show (OneEraForgeStateUpdateError xs)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE TypeFamilies     #-}
 module Ouroboros.Consensus.Ledger.SupportsMempool (
     ApplyTxErr
+  , ConvertRawTxId (..)
   , GenTx
   , GenTxId
   , HasTxId (..)
@@ -13,6 +14,7 @@ module Ouroboros.Consensus.Ledger.SupportsMempool (
   ) where
 
 import           Control.Monad.Except
+import           Data.ByteString.Short (ShortByteString)
 import           Data.Kind (Type)
 import           Data.Word (Word32)
 import           GHC.Stack (HasCallStack)
@@ -146,6 +148,13 @@ class ( Show     (TxId tx)
   -- Should be cheap as this will be called often.
   txId :: tx -> TxId tx
 
+-- | Extract the raw hash bytes from a 'TxId'.
+class HasTxId tx => ConvertRawTxId tx where
+
+  -- | NOTE: The composition @'toRawTxIdHash' . 'txId'@ must satisfy the same
+  -- properties as defined in the docs of 'txId'.
+  toRawTxIdHash :: TxId tx -> ShortByteString
+
 -- | Shorthand: ID of a generalized transaction
 type GenTxId blk = TxId (GenTx blk)