diff --git a/ouroboros-consensus-cardano/app/snapshot-converter.hs b/ouroboros-consensus-cardano/app/snapshot-converter.hs index 739ac11bc3..3fbf99cc96 100644 --- a/ouroboros-consensus-cardano/app/snapshot-converter.hs +++ b/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 <> "]") diff --git a/ouroboros-consensus-cardano/changelog.d/20251010_111741_javier.sagredo_version_tables.md b/ouroboros-consensus-cardano/changelog.d/20251010_111741_javier.sagredo_version_tables.md new file mode 100644 index 0000000000..3707a19398 --- /dev/null +++ b/ouroboros-consensus-cardano/changelog.d/20251010_111741_javier.sagredo_version_tables.md @@ -0,0 +1,26 @@ + + + + + +### 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. diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Alonzo b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Alonzo index 711ac926d4..e0d2a9ff87 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Alonzo and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Alonzo differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Babbage b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Babbage index 40ac2a6b03..16698aa6f6 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Babbage and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Babbage differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Conway b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Conway index 40ac2a6b03..16698aa6f6 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Conway and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Conway differ diff --git a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Dijkstra b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Dijkstra index 40ac2a6b03..16698aa6f6 100644 Binary files a/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Dijkstra and b/ouroboros-consensus-cardano/golden/cardano/disk/LedgerTables_Dijkstra differ diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 90ba4ad714..e8368a7e5d 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/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, 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 index 2be95e56c4..ca4d5c03a7 100644 --- 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 @@ -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 = 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 index 536743defe..7dffcff9f0 100644 --- 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 index bfed11149c..cc1a248470 100644 --- 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 index c3c9fea8b7..72871d95e8 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/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 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 index ef5c256fbf..8871e22df7 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/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 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 index 84c9245c17..f27c67032d 100644 --- a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Query.hs +++ b/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 $ diff --git a/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 528cafef8f..f03c7320ea 100644 --- 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 index 3141d99331..7394a16518 100644 --- 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 @@ -361,7 +361,7 @@ instance answerShelleyLookupQueries (injectLedgerTables idx) (ejectHardForkTxOutDefault idx) - (ejectCanonicalTxIn idx) + (coerce . ejectCanonicalTxIn idx) ) answerBlockQueryHFTraverse = @@ -369,7 +369,7 @@ instance ( \idx -> answerShelleyTraversingQueries (ejectHardForkTxOutDefault idx) - (ejectCanonicalTxIn idx) + (coerce . ejectCanonicalTxIn idx) (queryLedgerGetTraversingFilter @('[ShelleyBlock proto1 era1, ShelleyBlock proto2 era2]) idx) ) @@ -503,7 +503,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 index 667ab64652..7d7bba34f5 100644 --- 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 index 414a57bf72..3de6553e3b 100644 --- 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 index e06ce63436..9a4e6d1973 100644 --- a/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs +++ b/ouroboros-consensus-cardano/test/cardano-test/Test/Consensus/Cardano/Translation.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -10,7 +11,10 @@ {-# LANGUAGE StandaloneDeriving #-} {-# 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 module Test.Consensus.Cardano.Translation (tests) where @@ -27,7 +31,6 @@ import Cardano.Ledger.Shelley.API , translateCompactTxOutByronToShelley , translateTxIdByronToShelley ) -import qualified Cardano.Ledger.Shelley.API as SL import Cardano.Ledger.Shelley.LedgerState ( esLState , lsUTxOState @@ -67,7 +70,8 @@ import Ouroboros.Consensus.Protocol.TPraos (TPraos) import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.HFEras () import Ouroboros.Consensus.Shelley.Ledger - ( ShelleyBlock + ( BigEndianTxIn (..) + , ShelleyBlock , ShelleyLedgerConfig , mkShelleyLedgerConfig , shelleyLedgerState @@ -75,6 +79,7 @@ import Ouroboros.Consensus.Shelley.Ledger ) import Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util import Test.Cardano.Ledger.Alonzo.Binary.Twiddle () import Test.Cardano.Ledger.Babbage.Binary.Twiddle () import Test.Cardano.Ledger.Dijkstra.Arbitrary () @@ -272,7 +277,7 @@ byronUtxosAreInsertsInShelleyUtxoDiff srcLedgerState destLedgerState = where toNextUtxoDiff :: LedgerState ByronBlock mk -> - Diff.Diff SL.TxIn (Core.TxOut ShelleyEra) + Diff.Diff BigEndianTxIn (Core.TxOut ShelleyEra) toNextUtxoDiff ledgerState = let Byron.UTxO utxo = Byron.cvsUtxo $ byronLedgerState ledgerState @@ -281,13 +286,13 @@ byronUtxosAreInsertsInShelleyUtxoDiff srcLedgerState destLedgerState = in Diff.Diff $ Map.map valFn $ Map.mapKeys keyFn utxo - translateTxInByronToShelley :: Byron.TxIn -> TxIn + translateTxInByronToShelley :: Byron.TxIn -> BigEndianTxIn translateTxInByronToShelley byronTxIn = let Byron.TxInUtxo txId txIx = byronTxIn shelleyTxId' = translateTxIdByronToShelley txId in - TxIn shelleyTxId' (TxIx txIx) + BigEndianTxIn $ TxIn shelleyTxId' (TxIx txIx) shelleyAvvmAddressesAreDeletesInUtxoDiff :: LedgerState (ShelleyBlock Proto ShelleyEra) EmptyMK -> @@ -298,9 +303,9 @@ shelleyAvvmAddressesAreDeletesInUtxoDiff srcLedgerState destLedgerState = where toNextUtxoDiff :: LedgerState (ShelleyBlock Proto ShelleyEra) EmptyMK -> - Diff.Diff SL.TxIn (Core.TxOut AllegraEra) + Diff.Diff BigEndianTxIn (Core.TxOut AllegraEra) toNextUtxoDiff = avvmAddressesToUtxoDiff . stashedAVVMAddresses . shelleyLedgerState - avvmAddressesToUtxoDiff (UTxO m) = Diff.Diff $ Map.map (\_ -> Diff.Delete) m + avvmAddressesToUtxoDiff (UTxO m) = Diff.Diff $ coerceMapKeys $ Map.map (\_ -> Diff.Delete) m utxoTablesAreEmpty :: LedgerState (ShelleyBlock srcProto srcEra) EmptyMK -> @@ -329,7 +334,7 @@ nonEmptyAvvmAddresses ledgerState = extractUtxoDiff :: LedgerState (ShelleyBlock proto era) DiffMK -> - Diff SL.TxIn (Core.TxOut era) + Diff BigEndianTxIn (Core.TxOut era) extractUtxoDiff shelleyLedgerState = let DiffMK tables = getLedgerTables $ shelleyLedgerTables shelleyLedgerState in tables diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/LedgerTables.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/LedgerTables.hs index 720d134382..a647b10492 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/LedgerTables.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/LedgerTables.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,6 +12,9 @@ module Test.Consensus.Shelley.LedgerTables (tests) where import qualified Cardano.Ledger.Api.Era as L +import qualified Cardano.Ledger.BaseTypes as L +import qualified Cardano.Ledger.Shelley.API.Types as L +import Data.MemPack import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.Constraint @@ -29,12 +33,16 @@ import Test.Cardano.Ledger.Dijkstra.Arbitrary () import Test.Consensus.Shelley.Generators () import Test.Consensus.Shelley.MockCrypto (CanMock) import Test.LedgerTables +import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck tests :: TestTree tests = testGroup "LedgerTables" + . (testProperty "Serializing BigEndianTxIn preserves order" testBigEndianTxInPreservesOrder :) + . (testProperty "Serializing TxIn fails to preserve order" (expectFailure testTxInPreservesOrder) :) + . (testProperty "BigEndianTxIn roundtrips" testBigEndianRoundtrips :) . hcollapse . hcmap (Proxy @TestLedgerTables) (K . f) $ (hpure Proxy :: NP Proxy (CardanoShelleyEras StandardCrypto)) @@ -74,3 +82,21 @@ instance Arbitrary (LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK) where arbitrary = projectLedgerTables . unstowLedgerTables <$> arbitrary + +testBigEndianTxInPreservesOrder :: L.TxId -> L.TxIx -> L.TxIx -> Property +testBigEndianTxInPreservesOrder txid txix1 txix2 = + let b1 = packByteString (BigEndianTxIn $ L.TxIn txid txix1) + b2 = packByteString (BigEndianTxIn $ L.TxIn txid txix2) + in counterexample (show b1 <> " " <> show b2) $ compare b1 b2 === compare txix1 txix2 + +testBigEndianRoundtrips :: L.TxIn -> Property +testBigEndianRoundtrips txin = + case unpack (pack txin) of + Left err -> counterexample ("unpack failed with error: " ++ show err) False + Right v -> v === txin + +testTxInPreservesOrder :: L.TxId -> L.TxIx -> L.TxIx -> Property +testTxInPreservesOrder txid txix1 txix2 = + let b1 = packByteString (L.TxIn txid txix1) + b2 = packByteString (L.TxIn txid txix2) + in counterexample (show b1 <> " " <> show b2) $ compare b1 b2 === compare txix1 txix2 diff --git a/ouroboros-consensus/changelog.d/20251010_111745_javier.sagredo_version_tables.md b/ouroboros-consensus/changelog.d/20251010_111745_javier.sagredo_version_tables.md new file mode 100644 index 0000000000..58cba76180 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20251010_111745_javier.sagredo_version_tables.md @@ -0,0 +1,25 @@ + + + + + +### Breaking + +- Version ledger tables encoding. Define `TablesCodecVersion1`. +- InMemory snapshots used to store the tables in `/tables/tvar`. Now they + store the tables in `/tables`. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs index a7e16aaada..095dd2130e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs @@ -28,6 +28,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.Snapshots , SnapshotFailure (..) , SnapshotMetadata (..) , SnapshotPolicyArgs (..) + , TablesCodecVersion (..) , defaultSnapshotPolicyArgs -- * Codec @@ -83,6 +84,7 @@ import Control.Monad.Except import Control.Tracer import Data.Aeson (FromJSON (..), ToJSON (..), (.:), (.=)) import qualified Data.Aeson as Aeson +import Data.Aeson.Types (Parser) import Data.Functor.Identity import qualified Data.List as List import Data.Maybe (isJust, mapMaybe) @@ -163,9 +165,24 @@ data ReadSnapshotErr ReadMetadataError FsPath MetadataErr deriving (Eq, Show) +data TablesCodecVersion = TablesCodecVersion1 + deriving (Eq, Show) + +instance ToJSON TablesCodecVersion where + toJSON TablesCodecVersion1 = Aeson.Number 1 + +instance FromJSON TablesCodecVersion where + parseJSON v = enforceVersion =<< parseJSON v + +enforceVersion :: Word8 -> Parser TablesCodecVersion +enforceVersion v = case v of + 1 -> pure TablesCodecVersion1 + _ -> fail "Unknown or outdated tables codec version" + data SnapshotMetadata = SnapshotMetadata { snapshotBackend :: SnapshotBackend , snapshotChecksum :: CRC + , snapshotTablesCodecVersion :: TablesCodecVersion } deriving (Eq, Show) @@ -174,6 +191,7 @@ instance ToJSON SnapshotMetadata where Aeson.object [ "backend" .= snapshotBackend sm , "checksum" .= getCRC (snapshotChecksum sm) + , "tablesCodecVersion" .= snapshotTablesCodecVersion sm ] instance FromJSON SnapshotMetadata where @@ -181,6 +199,7 @@ instance FromJSON SnapshotMetadata where SnapshotMetadata <$> o .: "backend" <*> fmap CRC (o .: "checksum") + <*> o .: "tablesCodecVersion" data SnapshotBackend = UTxOHDMemSnapshot diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs index 8c92c6e956..1b543bead8 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V1/Snapshots.hs @@ -260,6 +260,7 @@ writeSnapshot fs@(SomeHasFS hasFS) backingStore encLedger snapshot cs = do SnapshotMetadata { snapshotBackend = bsSnapshotBackend backingStore , snapshotChecksum = crc + , snapshotTablesCodecVersion = TablesCodecVersion1 } bsCopy backingStore diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs index 876cfc31c2..64eb0a0fca 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/InMemory.hs @@ -41,7 +41,6 @@ import Data.Functor.Identity import qualified Data.List as List import qualified Data.Map.Strict as Map import Data.Maybe -import Data.String (fromString) import GHC.Generics import NoThunks.Class import Ouroboros.Consensus.Block @@ -214,11 +213,11 @@ implTakeHandleSnapshot :: String -> m (Maybe CRC) implTakeHandleSnapshot tv hasFS hint snapshotName = do - createDirectoryIfMissing hasFS True $ mkFsPath [snapshotName, "tables"] + createDirectoryIfMissing hasFS True $ mkFsPath [snapshotName] h <- readTVarIO tv guardClosed h $ \values -> - withFile hasFS (mkFsPath [snapshotName, "tables", "tvar"]) (WriteMode MustBeNew) $ \hf -> + withFile hasFS (mkFsPath [snapshotName, "tables"]) (WriteMode MustBeNew) $ \hf -> fmap (Just . snd) $ hPutAllCRC hasFS hf $ CBOR.toLazyByteString $ @@ -300,6 +299,7 @@ implTakeSnapshot ccfg tracer shfs@(SomeHasFS hasFS) suffix st = do SnapshotMetadata { snapshotBackend = UTxOHDMemSnapshot , snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2 + , snapshotTablesCodecVersion = TablesCodecVersion1 } -- | Read snapshot from disk. @@ -339,10 +339,7 @@ loadSnapshot tracer _rr ccfg fs ds = do fs Identity (valuesMKDecoder extLedgerSt) - ( fsPathFromList $ - fsPathToList (snapshotToDirPath ds) - <> [fromString "tables", fromString "tvar"] - ) + (snapshotToDirPath ds mkFsPath ["tables"]) let computedCRC = crcOfConcat checksumAsRead crcTables Monad.when (computedCRC /= snapshotChecksum snapshotMeta) $ throwE $ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs index 30b63ea83b..471af89dd0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/LSM.hs @@ -398,6 +398,7 @@ implTakeSnapshot ccfg tracer shfs@(SomeHasFS hasFs) suffix st = SnapshotMetadata { snapshotBackend = UTxOHDLSMSnapshot , snapshotChecksum = maybe crc1 (crcOfConcat crc1) crc2 + , snapshotTablesCodecVersion = TablesCodecVersion1 } -- | Delete snapshot from disk and also from the LSM tree database. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs index 57e53aa126..734569a904 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} @@ -13,6 +14,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -- | Miscellaneous utilities @@ -94,6 +96,10 @@ module Ouroboros.Consensus.Util -- * Type-safe boolean flags , Flag (..) + + -- * Unsafe coercions or maps + , coerceMapKeys + , coerceSet ) where import Cardano.Crypto.Hash @@ -108,6 +114,7 @@ import Control.Monad.Trans.Class import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import Data.ByteString.Short (ShortByteString) +import Data.Coerce import Data.Foldable (asum, toList) import Data.Function (on) import Data.Functor.Identity @@ -115,7 +122,9 @@ import Data.Functor.Product import Data.Kind (Type) import Data.List as List (foldl', maximumBy) import Data.List.NonEmpty (NonEmpty (..), (<|)) +import Data.Map (Map) import Data.Maybe (fromMaybe) +import Data.Proxy import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) @@ -125,8 +134,10 @@ import GHC.Generics (Generic) import GHC.Stack import GHC.TypeLits (Symbol) import Ouroboros.Consensus.Util.IOLike +import Ouroboros.Consensus.Util.RedundantConstraints import Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..)) import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) +import Unsafe.Coerce {------------------------------------------------------------------------------- Type-level utility @@ -505,3 +516,33 @@ newtype FuseBlownException = FuseBlownException Text -- for an example. newtype Flag (name :: Symbol) = Flag {getFlag :: Bool} deriving (Eq, Show, Generic) + +{------------------------------------------------------------------------------- + Unsafe coercions from maps +-------------------------------------------------------------------------------} + +#if __GLASGOW_HASKELL__ >= 908 +{-# WARNING in "x-ord-preserving-coercions" + coerceMapKeys + [ "This function expects the types of the keys to have exactly the same Ord ordering." + , "If you are certain this is the case, ignore this warning with `-Wno-x-ord-preserving-coercions`." + ] + #-} +#endif +coerceMapKeys :: forall k1 k2 v. Coercible k1 k2 => Map k1 v -> Map k2 v +coerceMapKeys = unsafeCoerce + where + _ = keepRedundantConstraint (Proxy @(Coercible k1 k2)) + +#if __GLASGOW_HASKELL__ >= 908 +{-# WARNING in "x-ord-preserving-coercions" + coerceSet + [ "This function expects the types of the keys to have exactly the same Ord ordering." + , "If you are certain this is the case, ignore this warning with `-Wno-x-ord-preserving-coercions`." + ] + #-} +#endif +coerceSet :: forall k1 k2. Coercible k1 k2 => Set k1 -> Set k2 +coerceSet = unsafeCoerce + where + _ = keepRedundantConstraint (Proxy @(Coercible k1 k2)) diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/Snapshots.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/Snapshots.hs index e69c3b75ec..c65ba8435b 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/Snapshots.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/Snapshots.hs @@ -35,3 +35,4 @@ instance Arbitrary SnapshotMetadata where SnapshotMetadata <$> arbitrary <*> fmap CRC arbitrary + <*> pure TablesCodecVersion1