diff --git a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs index e8aef06379..e312fc7f32 100644 --- a/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs +++ b/ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Mempool.hs @@ -129,6 +129,7 @@ instance TxLimits ByronBlock where blockCapacityTxMeasure _cfg st = ByteSize + $ fromIntegral $ CC.getMaxBlockSize cvs - byronBlockEncodingOverhead where cvs = tickedByronLedgerState st 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 edd40920b4..f32885bdd3 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 @@ -282,7 +282,7 @@ txsMaxBytes :: -> ByteSize txsMaxBytes TickedShelleyLedgerState { tickedShelleyLedgerState } = -- `maxBlockBodySize` is expected to be bigger than `fixedBlockBodyOverhead` - ByteSize $ maxBlockBodySize - fixedBlockBodyOverhead + ByteSize $ fromIntegral $ maxBlockBodySize - fixedBlockBodyOverhead where maxBlockBodySize = getPParams tickedShelleyLedgerState ^. ppMaxBBSizeL diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs index cbf38e34f2..e630ddddf8 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/Consensus/Shelley/Coherence.hs @@ -5,7 +5,7 @@ import qualified Data.Measure as Measure import Data.Word (Word32) import Ouroboros.Consensus.Ledger.SupportsMempool (ByteSize (..)) import Ouroboros.Consensus.Shelley.Ledger.Mempool (AlonzoMeasure (..), - fromExUnits) + ConwayMeasure (..), fromExUnits) import Test.Cardano.Ledger.Alonzo.Serialisation.Generators () import Test.Tasty import Test.Tasty.QuickCheck @@ -16,11 +16,18 @@ tests = testGroup "Shelley coherences" [ ] -- | 'Measure.<=' and @'pointWiseExUnits' (<=)@ must agree -leqCoherence :: Word32 -> ExUnits -> ExUnits -> Property -leqCoherence w eu1 eu2 = +leqCoherence :: Word32 -> Word32 -> ExUnits -> ExUnits -> Property +leqCoherence w1 w2 eu1 eu2 = actual === expected where - inj eu = AlonzoMeasure (ByteSize w) (fromExUnits eu) + -- ConwayMeasure is the fullest TxMeasure and mainnet's + inj eu = + ConwayMeasure + (AlonzoMeasure + (ByteSize (fromIntegral w1)) + (fromExUnits eu) + ) + (ByteSize (fromIntegral w2)) actual = inj eu1 Measure.<= inj eu2 expected = pointWiseExUnits (<=) eu1 eu2 diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 21b6806fef..9f674ff549 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -706,7 +706,10 @@ getMempoolReader mempool = MempoolReader.TxSubmissionMempoolReader snapshotHasTx } = MempoolReader.MempoolSnapshot { mempoolTxIdsAfter = \idx -> - [ (txId (txForgetValidated tx), idx', unByteSize byteSize) + [ ( txId (txForgetValidated tx) + , idx' + , fromIntegral $ unByteSize byteSize -- TODO overflow? + ) | (tx, idx', byteSize) <- snapshotTxsAfter idx ] , mempoolLookupTx = snapshotLookupTx diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index ab1710babd..af7c5f2405 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -330,8 +330,7 @@ instance LedgerSupportsMempool BlockA where instance TxLimits BlockA where type TxMeasure BlockA = ByteSize - -- default mempool capacity is two blocks, so maxBound/2 avoids overflow - blockCapacityTxMeasure _cfg _st = ByteSize $ maxBound `div` 2 + blockCapacityTxMeasure _cfg _st = ByteSize $ 100 * 1024 -- arbitrary txMeasure _cfg _st _tx = ByteSize 0 newtype instance TxId (GenTx BlockA) = TxIdA Int diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index a689fed5cd..8fea7cea9c 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -266,8 +266,7 @@ instance LedgerSupportsMempool BlockB where instance TxLimits BlockB where type TxMeasure BlockB = ByteSize - -- default mempool capacity is two blocks, so maxBound/2 avoids overflow - blockCapacityTxMeasure _cfg _st = ByteSize $ maxBound `div` 2 + blockCapacityTxMeasure _cfg _st = ByteSize $ 100 * 1024 -- arbitrary txMeasure _cfg _st _tx = ByteSize 0 data instance TxId (GenTx BlockB) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs index 6bf334242b..8aa6fad564 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsMempool.hs @@ -26,9 +26,9 @@ import Data.ByteString.Short (ShortByteString) import Data.DerivingVia (InstantiatedAt (..)) import Data.Kind (Type) import Data.Measure (Measure) -import Data.Word (Word32) import GHC.Stack (HasCallStack) import NoThunks.Class +import Numeric.Natural (Natural) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ticked @@ -204,7 +204,10 @@ class ( Measure (TxMeasure blk) -> TickedLedgerState blk -> TxMeasure blk -newtype ByteSize = ByteSize { unByteSize :: Word32 } +-- | We intentionally do not declare a 'Num' instance! We prefer @ByteSize@ to +-- occur explicitly in the code where possible, for legibility/perspciousness. +-- We also do not need nor want subtraction. +newtype ByteSize = ByteSize { unByteSize :: Natural } deriving stock (Show) deriving newtype (Eq, Ord) deriving newtype (Measure) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs index c79ae2e8f8..edba35bb30 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs @@ -61,10 +61,10 @@ localTxMonitorServer mempool = , recvMsgGetSizes = do let MempoolSize{msNumTxs,msNumBytes} = snapshotMempoolSize snapshot let sizes = MempoolSizeAndCapacity - { capacityInBytes = unByteSize capacity - , sizeInBytes = unByteSize msNumBytes + { capacityInBytes = fromIntegral $ unByteSize capacity + , sizeInBytes = fromIntegral $ unByteSize msNumBytes , numberOfTxs = msNumTxs - } + } -- TODO what to do about overflow? pure $ SendMsgReplyGetSizes sizes (serverStAcquired s txs) , recvMsgAwaitAcquire = do s' <- atomically $ do diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs index ca4284c7c3..8bc8ea9861 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs @@ -35,7 +35,7 @@ module Test.Consensus.Mempool (tests) where import Cardano.Binary (Encoding, toCBOR) import Cardano.Crypto.Hash import Control.Exception (assert) -import Control.Monad (foldM, forM, forM_, void) +import Control.Monad (foldM, forM, forM_, void, when) import Control.Monad.Except (Except, runExcept) import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.State (State, evalState, get, modify) @@ -48,8 +48,9 @@ import qualified Data.Map.Strict as Map import Data.Maybe (mapMaybe) import Data.Semigroup (stimes) import qualified Data.Set as Set -import Data.Word +import Data.Word (Word32) import GHC.Stack (HasCallStack) +import Numeric.Natural (Natural) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config.SecurityParam @@ -355,7 +356,7 @@ ppTestTxWithHash x = condense -- -- The generated 'testMempoolCap' will be: -- > foldMap 'txSize' 'testInitialTxs' + extraCapacity -genTestSetupWithExtraCapacity :: Int -> Word32 -> Gen (TestSetup, LedgerState TestBlock) +genTestSetupWithExtraCapacity :: Int -> Natural -> Gen (TestSetup, LedgerState TestBlock) genTestSetupWithExtraCapacity maxInitialTxs extraCapacity = do ledgerSize <- choose (0, maxInitialTxs) nbInitialTxs <- choose (0, maxInitialTxs) @@ -831,20 +832,26 @@ instance Arbitrary MempoolCapTestSetup where -- The Mempool should at least be capable of containing the transactions -- it already contains. let currentSize = foldMap txSize (testInitialTxs testSetup) - ByteSize capacityMinBound = currentSize + capacityMinBound = currentSize validTxsToAdd = [tx | (tx, True) <- txs] -- Use the current size + the sum of all the valid transactions to add -- as the upper bound. - ByteSize capacityMaxBound = currentSize <> foldMap txSize validTxsToAdd + capacityMaxBound = currentSize <> foldMap txSize validTxsToAdd -- Note that we could pick @currentSize@, meaning that we can't add any -- more transactions to the Mempool + + when (unByteSize capacityMaxBound >= 2^(32 :: Int)) $ do + error "impossible!" -- could 'QC.discard' if this is actually feasible + capacity <- choose - ( capacityMinBound - , capacityMaxBound + ( fromIntegral (unByteSize capacityMinBound) :: Word32 + , fromIntegral (unByteSize capacityMaxBound) :: Word32 ) let testSetup' = testSetup { testMempoolCapOverride = - MempoolCapacityBytesOverride (ByteSize capacity) + MempoolCapacityBytesOverride + $ ByteSize + $ fromIntegral (capacity :: Word32) } return $ MempoolCapTestSetup testSetupWithTxs { testSetup = testSetup' } @@ -942,8 +949,8 @@ data TxSizeSplitTestSetup = TxSizeSplitTestSetup instance Arbitrary TxSizeSplitTestSetup where arbitrary = do - let txSizeMaxBound = 10 * 1024 * 1024 -- 10MB transaction max bound - txSizes <- listOf $ choose (1, txSizeMaxBound) + let txSizeMaxBound = 10 * 1024 * 1024 -- 10 mebibyte transaction max bound + txSizes <- listOf $ choose (1, txSizeMaxBound :: Word32) let totalTxsSize = sum txSizes txSizeToSplitOn <- frequency [ (1, pure 0) @@ -952,8 +959,8 @@ instance Arbitrary TxSizeSplitTestSetup where , (1, choose (totalTxsSize + 1, totalTxsSize + 1000)) ] pure TxSizeSplitTestSetup - { tssTxSizes = map ByteSize txSizes - , tssTxSizeToSplitOn = ByteSize txSizeToSplitOn + { tssTxSizes = map (ByteSize . fromIntegral) txSizes + , tssTxSizeToSplitOn = ByteSize $ fromIntegral txSizeToSplitOn } shrink TxSizeSplitTestSetup { tssTxSizes, tssTxSizeToSplitOn = ByteSize x } = @@ -1031,9 +1038,8 @@ prop_Mempool_idx_consistency (Actions actions) = , testMempoolCapOverride = MempoolCapacityBytesOverride $ ByteSize - $ maxBound - unByteSize simpleBlockCapacity - --- can't use maxBound, because then 'computeMempoolCapacity' - --- calculation overflows, resulting in a capacity of just one block + $ 1024*1024*1024 + -- There's no way this test will need more than a gibibyte. } lastOfMempoolRemoved txsInMempool = \case