Skip to content

Commit

Permalink
Added test that checks tx multiplicities
Browse files Browse the repository at this point in the history
  • Loading branch information
@bolt12
bolt12 committed Aug 20, 2024
1 parent 0a7eb7d commit 3f32750
Show file tree
Hide file tree
Showing 2 changed files with 96 additions and 52 deletions.
8 changes: 4 additions & 4 deletions ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/Common.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -259,13 +259,13 @@ instance Arbitrary a => Arbitrary (LargeNonEmptyList a) where


-- TODO: Belongs in iosim.
data SimResult a = SimReturn a [String]
| SimException SomeException [String]
| SimDeadLock [String]
data SimResults a = SimReturn a [String]
| SimException SomeException [String]
| SimDeadLock [String]

-- Traverses a list of trace events and returns the result along with all log messages.
-- Incase of a pure exception, ie an assert, all tracers evaluated so far are returned.
evaluateTrace :: SimTrace a -> IO (SimResult a)
evaluateTrace :: SimTrace a -> IO (SimResults a)
evaluateTrace = go []
where
go as tr = do
Expand Down
140 changes: 92 additions & 48 deletions ouroboros-network/sim-tests-lib/Test/Ouroboros/Network/TxSubmission/TxSubmissionV2.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,6 +7,7 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

{-# OPTIONS_GHC -Wno-orphans #-}
Expand Down Expand Up @@ -73,6 +74,7 @@ import Test.Ouroboros.Network.TxSubmission.Common hiding (tests)
tests :: TestTree
tests = testGroup "Ouroboros.Network.TxSubmission.TxSubmissionV2"
[ testProperty "txSubmission" prop_txSubmission
, testProperty "txSubmission inflight" prop_txSubmission_inflight
]

data TxSubmissionV2State =
Expand Down Expand Up @@ -111,7 +113,7 @@ instance Arbitrary TxSubmissionV2State where
where
singletonMaps = [Map.singleton k v | (k, v) <- Map.toList m]

txSubmissionSimulation
runTxSubmissionV2
:: forall m peeraddr txid.
( MonadAsync m
, MonadDelay m
Expand Down Expand Up @@ -143,7 +145,7 @@ txSubmissionSimulation
)
-> TxDecisionPolicy
-> m ([Tx txid], [[Tx txid]])
txSubmissionSimulation tracer tracerDST state txDecisionPolicy = do
runTxSubmissionV2 tracer tracerDST state txDecisionPolicy = do

state' <- traverse (\(b, c, d, e) -> do
mempool <- newMempool b
Expand Down Expand Up @@ -235,12 +237,55 @@ txSubmissionSimulation tracer tracerDST state txDecisionPolicy = do
go as [] = action (reverse as)
go as (x:xs) = withAsync x (\a -> go (a:as) xs)

prop_txSubmission
:: TxSubmissionV2State
-> Property
prop_txSubmission (TxSubmissionV2State state txDecisionPolicy) =
txSubmissionV2Simulation :: forall s . TxSubmissionV2State -> IOSim s ([Tx Int], [[Tx Int]])
txSubmissionV2Simulation (TxSubmissionV2State state txDecisionPolicy) = do
state' <- traverse (\(txs, mbOutDelay, mbInDelay) -> do
let mbOutDelayTime = getSmallDelay . getPositive <$> mbOutDelay
mbInDelayTime = getSmallDelay . getPositive <$> mbInDelay
controlMessageVar <- newTVarIO Continue
return ( txs
, controlMessageVar
, mbOutDelayTime
, mbInDelayTime
)
)
state

state'' <- traverse (\(txs, var, mbOutDelay, mbInDelay) -> do
return ( txs
, readTVar var
, mbOutDelay
, mbInDelay
)
)
state'

let simDelayTime = Map.foldl' (\m (txs, _, mbInDelay, mbOutDelay) ->
max m ( fromMaybe 1 (max <$> mbInDelay <*> mbOutDelay)
* realToFrac (length txs `div` 4)
)
)
0
$ state''
controlMessageVars = (\(_, x, _, _) -> x)
<$> Map.elems state'

_ <- async do
threadDelay (simDelayTime + 1000)
atomically (traverse_ (`writeTVar` Terminate) controlMessageVars)

let tracer = verboseTracer <> debugTracer
tracer' = verboseTracer <> debugTracer
runTxSubmissionV2 tracer tracer' state'' txDecisionPolicy

-- | Tests overall tx submission semantics. The properties checked in this
-- property test are the same as for tx submission v1. We need this to know we
-- didn't regress.
--
prop_txSubmission :: TxSubmissionV2State -> Property
prop_txSubmission st =
ioProperty $ do
tr' <- evaluateTrace (runSimTrace sim)
tr' <- evaluateTrace (runSimTrace (txSubmissionV2Simulation st))
case tr' of
SimException e trace -> do
return $ counterexample (intercalate "\n" $ show e : trace) False
Expand Down Expand Up @@ -282,47 +327,46 @@ prop_txSubmission (TxSubmissionV2State state txDecisionPolicy) =
outmps
return $ counterexample (intercalate "\n" _trace)
$ conjoin r
where
sim :: forall s . IOSim s ([Tx Int], [[Tx Int]])
sim = do
state' <- traverse (\(txs, mbOutDelay, mbInDelay) -> do
let mbOutDelayTime = getSmallDelay . getPositive <$> mbOutDelay
mbInDelayTime = getSmallDelay . getPositive <$> mbInDelay
controlMessageVar <- newTVarIO Continue
return ( txs
, controlMessageVar
, mbOutDelayTime
, mbInDelayTime
)
)
state

state'' <- traverse (\(txs, var, mbOutDelay, mbInDelay) -> do
return ( txs
, readTVar var
, mbOutDelay
, mbInDelay
)
)
state'

let simDelayTime = Map.foldl' (\m (txs, _, mbInDelay, mbOutDelay) ->
max m ( fromMaybe 1 (max <$> mbInDelay <*> mbOutDelay)
* realToFrac (length txs `div` 4)
)
)
0
$ state''
controlMessageVars = (\(_, x, _, _) -> x)
<$> Map.elems state'

_ <- async do
threadDelay (simDelayTime + 1000)
atomically (traverse_ (`writeTVar` Terminate) controlMessageVars)

let tracer = verboseTracer <> debugTracer
tracer' = verboseTracer <> debugTracer
txSubmissionSimulation tracer tracer' state'' txDecisionPolicy

-- | This test checks that all txs are downloaded from all available peers if
-- available.
--
-- This test takes advantage of the fact that the mempool implementation
-- allows duplicates.
--
prop_txSubmission_inflight :: TxSubmissionV2State -> Property
prop_txSubmission_inflight st@(TxSubmissionV2State state _) =
let trace = runSimTrace (txSubmissionV2Simulation st)
maxRepeatedValidTxs = Map.foldr (\(txs, _, _) r ->
foldr (\tx rr ->
if Map.member tx rr && getTxValid tx
then Map.update (Just . succ @Int) tx rr
else if getTxValid tx
then Map.insert tx 1 rr
else rr
)
r
txs
)
Map.empty
state

in case traceResult True trace of
Left err -> counterexample (ppTrace trace)
$ counterexample (show err)
$ property False
Right (inmp, _) ->
let resultRepeatedValidTxs =
foldr (\tx rr ->
if Map.member tx rr && getTxValid tx
then Map.update (Just . succ @Int) tx rr
else if getTxValid tx
then Map.insert tx 1 rr
else rr
)
Map.empty
inmp
in resultRepeatedValidTxs === maxRepeatedValidTxs

checkMempools :: (Eq a, Show a) => [a] -> [a] -> Property
checkMempools [] [] = property True
Expand Down

0 comments on commit 3f32750

Please sign in to comment.