Skip to content
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
11 changes: 3 additions & 8 deletions ouroboros-consensus-cardano/app/snapshot-converter.hs
Original file line number Diff line number Diff line change
Expand Up @@ -233,7 +233,6 @@ data OutEnv = OutEnv
LedgerState (CardanoBlock StandardCrypto) EmptyMK ->
ResourceRegistry IO ->
IO (SinkArgs (LedgerState (CardanoBlock StandardCrypto)) IO)
, outCreateExtra :: Maybe FilePath
, outDeleteExtra :: Maybe FilePath
, outProgressMsg :: String
, outBackend :: SnapshotBackend
Expand Down Expand Up @@ -287,13 +286,12 @@ 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"

wipeOutputPaths OutEnv{..} = do
wipePath outFilePath
lift $ maybe (pure ()) (D.createDirectory . (outFilePath F.</>)) outCreateExtra
maybe
(pure ())
wipePath
Expand Down Expand Up @@ -356,7 +354,7 @@ main = withStdTerminalHandles $ do
InEnv
st
fp
(fromInMemory (fp F.</> "tables" F.</> "tvar"))
(fromInMemory (fp F.</> "tables"))
("InMemory@[" <> fp <> "]")
c
mtd
Expand Down Expand Up @@ -412,8 +410,7 @@ main = withStdTerminalHandles $ do
pure $
OutEnv
fp
(toInMemory (fp F.</> "tables" F.</> "tvar"))
(Just "tables")
(toInMemory (fp F.</> "tables"))
Nothing
("InMemory@[" <> fp <> "]")
UTxOHDMemSnapshot
Expand All @@ -431,7 +428,6 @@ main = withStdTerminalHandles $ do
fp
(toLMDB fp defaultLMDBLimits)
Nothing
Nothing
("LMDB@[" <> fp <> "]")
UTxOHDLMDBSnapshot
LSM fp lsmDbPath -> do
Expand All @@ -447,7 +443,6 @@ main = withStdTerminalHandles $ do
OutEnv
fp
(toLSM lsmDbPath (last $ splitDirectories fp))
Nothing
(Just lsmDbPath)
("LSM@[" <> lsmDbPath <> "]")
UTxOHDLSMSnapshot
Expand Down
Original file line number Diff line number Diff line change
@@ -0,0 +1,23 @@
<!--
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

- Change `TxIn (ShelleyBlock proto era)` to `BigEndianTxIn` which is a newtype wrapper over `TxIn` that *only* modifies the `MemPack` instance to ensure big-endian serialization.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Original file line number Diff line number Diff line change
Expand Up @@ -375,6 +375,7 @@ test-suite shelley-test
containers,
filepath,
measures,
mempack,
microlens,
ouroboros-consensus:{ouroboros-consensus, unstable-consensus-testlib},
ouroboros-consensus-cardano,
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -466,6 +466,7 @@ translateLedgerStateShelleyToAllegraWrapper =
LedgerTables
. DiffMK
. Diff.fromMapDeletes
. coerceTxInMapKeys
. Map.map SL.upgradeTxOut
$ avvms

Expand All @@ -478,6 +479,7 @@ translateLedgerStateShelleyToAllegraWrapper =
. withLedgerTables ls
. LedgerTables
. ValuesMK
. coerceTxInMapKeys
$ avvms

resultingState =
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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)
)

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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.
Comment on lines +327 to +331
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

if we're explicitly only using this to ensure that the sorting is consistent between the serialized and unserialized versions, should there be a property test to ensure that this remains accurate?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Very good point. I will add a test.

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

FTR: As discussed today, this test will eventually be removed again, once we change the encoding for the benefit of the LSM compact index. Then, the test will actually start failing, which seems like a nice prompt to also remove this comment (instead explaining why it is fine that the Ord order and the serialization-implied order differ).

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
Expand Down Expand Up @@ -397,7 +429,7 @@ instance
, shelleyLedgerTables = emptyLedgerTables
}
where
(_, shelleyLedgerState') = shelleyLedgerState `slUtxoL` SL.UTxO m
(_, shelleyLedgerState') = shelleyLedgerState `slUtxoL` SL.UTxO (coerceTxInMapKeys m)
ShelleyLedgerState
{ shelleyLedgerTip
, shelleyLedgerState
Expand All @@ -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
Expand All @@ -419,6 +451,26 @@ instance
, shelleyLedgerTransition
} = st

-- | UNSAFE: use this function to coerce a @'Map' 'TxIn' ('TxOut' l)@ into and from
-- a @'Map' 'BigEndianTxIn' ('TxOut' l)@.
--
-- This is only safe in such case because the keys are coercible and the 'Ord'
-- instance is exactly the same.
coerceTxInMapKeys :: forall k1 k2 v. Coercible k1 k2 => Map k1 v -> Map k2 v
coerceTxInMapKeys = unsafeCoerce
where
_ = keepRedundantConstraint (Proxy @(Coercible k1 k2))

-- | UNSAFE: use this function to coerce a @'Set' 'TxIn'@ into and from
-- a @'Set' 'BigEndianTxIn'@.
--
-- This is only safe in such case because the keys are coercible and the 'Ord'
-- instance is exactly the same.
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)))
Expand All @@ -432,7 +484,7 @@ instance
}
where
(_, tickedShelleyLedgerState') =
tickedShelleyLedgerState `slUtxoL` SL.UTxO tbs
tickedShelleyLedgerState `slUtxoL` SL.UTxO (coerceTxInMapKeys tbs)
TickedShelleyLedgerState
{ untickedShelleyLedgerTip
, tickedShelleyLedgerTransition
Expand All @@ -445,7 +497,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
Expand Down Expand Up @@ -583,6 +635,7 @@ instance
getBlockKeySets =
LedgerTables
. KeysMK
. coerceTxInSet
. Core.neededTxInsForBlock
. shelleyBlockRaw

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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 $
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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 {}

Expand Down
Loading
Loading