Fix mempool QSM test

IntersectMBO · Sep 30, 2024 · b0c4487 · b0c4487
1 parent 237372f
commit b0c4487
Show file tree

Hide file tree

Showing 8 changed files with 267 additions and 245 deletions.
diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -592,6 +592,8 @@ test-suite consensus-test
     cardano-binary,
     cardano-crypto-class,
     cardano-crypto-tests,
+    measures,
+    cardano-ledger-core:testlib,
     cardano-slotting:{cardano-slotting, testlib},
     cardano-strict-containers,
     cborg,

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/API.hs
@@ -25,6 +25,8 @@ module Ouroboros.Consensus.Mempool.API (
   , ForgeLedgerState (..)
     -- * Mempool Snapshot
   , MempoolSnapshot (..)
+    -- * Mempool capacity
+  , MempoolCapacity (..)
     -- * Re-exports
   , SizeInBytes
   , TicketNo
@@ -215,9 +217,16 @@ data Mempool m blk = Mempool {
       -- Instead, we treat it the same way as a Mempool which is /at/
       -- capacity, i.e., we won't admit new transactions until some have been
       -- removed because they have become invalid.
-    , getCapacity    :: STM m (TxMeasure blk)
+    , getCapacity    :: STM m (MempoolCapacity blk)
     }
 
+-- | TODO: The LocalTxMonitor protocol computes these values too. This could be
+-- unified, see "Ouroboros.Consensus.MiniProtocol.LocalTxMonitor.Server".
+data MempoolCapacity blk = MempoolCapacity {
+    currentSize :: TxMeasure blk
+  , capacity    :: TxMeasure blk
+  }
+
 {-------------------------------------------------------------------------------
   Result of adding a transaction to the mempool
 -------------------------------------------------------------------------------}

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Capacity.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Capacity.hs
@@ -76,7 +76,9 @@ computeMempoolCapacity cfg st override =
         -- This calculation is happening at Word32. Thus overflow is silently
         -- accepted. Adding one less than the denominator to the numerator
         -- effectively rounds up instead of down.
-        max 1 $ (x + oneBlockBytes - 1) `div` oneBlockBytes
+        max 1 $ if x + oneBlockBytes < x
+                then x `div` oneBlockBytes
+                else (x + oneBlockBytes - 1) `div` oneBlockBytes
 
     SemigroupViaMeasure capacity =
       stimes blockCount (SemigroupViaMeasure oneBlock)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs
@@ -13,10 +13,11 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool
-import           Ouroboros.Consensus.Mempool.API (Mempool (..))
+import           Ouroboros.Consensus.Mempool.API
 import           Ouroboros.Consensus.Mempool.Capacity
 import           Ouroboros.Consensus.Mempool.Impl.Common
 import           Ouroboros.Consensus.Mempool.Query
+import qualified Ouroboros.Consensus.Mempool.TxSeq as TxSeq
 import           Ouroboros.Consensus.Mempool.Update
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Consensus.Util.ResourceRegistry
@@ -107,7 +108,9 @@ mkMempool mpEnv = Mempool
     , syncWithLedger = implSyncWithLedger mpEnv
     , getSnapshot    = snapshotFromIS <$> readTMVar istate
     , getSnapshotFor = implGetSnapshotFor mpEnv
-    , getCapacity    = isCapacity <$> readTMVar istate
+    , getCapacity    = do
+        st <- readTMVar istate
+        pure (MempoolCapacity (TxSeq.toSize $ isTxs st) (isCapacity st))
     }
   where
     MempoolEnv {

diff --git a/...nsensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs b/...nsensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/LocalTxMonitor/Server.hs
@@ -8,6 +8,7 @@ module Ouroboros.Consensus.MiniProtocol.LocalTxMonitor.Server (localTxMonitorSer
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Mempool
+import qualified Ouroboros.Consensus.Mempool.API as Mempool
 import           Ouroboros.Consensus.Util.IOLike
 import           Ouroboros.Network.Protocol.LocalTxMonitor.Server
 import           Ouroboros.Network.Protocol.LocalTxMonitor.Type
@@ -33,7 +34,7 @@ localTxMonitorServer mempool =
       , recvMsgAcquire = do
           s <- atomically $
                 (,)
-            <$> (txMeasureByteSize <$> getCapacity mempool)
+            <$> (txMeasureByteSize . Mempool.capacity <$> getCapacity mempool)
             <*> getSnapshot mempool
           pure $ serverStAcquiring s
       }
@@ -70,7 +71,7 @@ localTxMonitorServer mempool =
           s' <- atomically $ do
             s'@(_, snapshot') <-
                   (,)
-              <$> (txMeasureByteSize <$> getCapacity mempool)
+              <$> (txMeasureByteSize . Mempool.capacity <$> getCapacity mempool)
               <*> getSnapshot mempool
             s' <$ check (not (snapshot `isSameSnapshot` snapshot'))
           pure $ serverStAcquiring s'

diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs
@@ -416,6 +416,11 @@ deriving anyclass instance ( SimpleCrypto c
                            , Typeable ext
                            )
                            => NoThunks (Ticked1 (LedgerState (SimpleBlock c ext)) TrackingMK)
+deriving instance ( SimpleCrypto c
+                  , Typeable ext
+                  , Show (LedgerState (SimpleBlock c ext) mk)
+                  )
+                  => Show (Ticked1 (LedgerState (SimpleBlock c ext)) mk)
 
 instance MockProtocolSpecific c ext => UpdateLedger (SimpleBlock c ext)
 

diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Mempool.hs
@@ -56,6 +56,7 @@ import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Ledger.Tables.Utils
 import           Ouroboros.Consensus.Mempool
+import qualified Ouroboros.Consensus.Mempool.API as Mempool
 import           Ouroboros.Consensus.Mempool.TxSeq as TxSeq
 import           Ouroboros.Consensus.Mock.Ledger hiding (TxId)
 import           Ouroboros.Consensus.Util (repeatedly, repeatedlyM)
@@ -212,7 +213,7 @@ prop_Mempool_semigroup_removeTxs (TestSetupWithTxsInMempoolToRemove testSetup tx
 prop_Mempool_getCapacity :: MempoolCapTestSetup -> Property
 prop_Mempool_getCapacity mcts =
     withTestMempool testSetup $ \TestMempool{mempool} -> do
-      IgnoringOverflow actualCapacity <- atomically $ getCapacity mempool
+      IgnoringOverflow actualCapacity <- atomically $ Mempool.capacity <$> getCapacity mempool
       pure $ actualCapacity === expectedCapacity
   where
     MempoolCapacityBytesOverride testCapacity = testMempoolCapOverride testSetup