Skip to content

Commit 4b80165

Browse files
nfrisbynfrisby
committed
consensus-test: add basic CSJ-GSM regression test
1 parent e4888d2 commit 4b80165

File tree

3 files changed

+307
-0
lines changed

3 files changed

+307
-0
lines changed

‎ouroboros-consensus/ouroboros-consensus.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -585,6 +585,7 @@ test-suite consensus-test
585585
Test.Consensus.Mempool.StateMachine
586586
Test.Consensus.Mempool.Util
587587
Test.Consensus.MiniProtocol.BlockFetch.Client
588+
Test.Consensus.MiniProtocol.ChainSync.CSJ
588589
Test.Consensus.MiniProtocol.ChainSync.Client
589590
Test.Consensus.MiniProtocol.LocalStateQuery.Server
590591
Test.Consensus.Util.MonadSTM.NormalForm

‎ouroboros-consensus/test/consensus-test/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -13,6 +13,7 @@ import qualified Test.Consensus.Mempool.Fairness (tests)
1313
import qualified Test.Consensus.Mempool.StateMachine (tests)
1414
import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests)
1515
import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests)
16+
import qualified Test.Consensus.MiniProtocol.ChainSync.CSJ (tests)
1617
import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests)
1718
import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests)
1819
import qualified Test.Consensus.Util.Versioned (tests)
@@ -29,6 +30,7 @@ tests =
2930
[ Test.Consensus.BlockchainTime.Simple.tests
3031
, Test.Consensus.HeaderValidation.tests
3132
, Test.Consensus.MiniProtocol.BlockFetch.Client.tests
33+
, Test.Consensus.MiniProtocol.ChainSync.CSJ.tests
3234
, Test.Consensus.MiniProtocol.ChainSync.Client.tests
3335
, Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests
3436
, testGroup "Mempool"

‎ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/CSJ.hs

Lines changed: 304 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,304 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
{-# LANGUAGE NamedFieldPuns #-}
3+
{-# LANGUAGE ScopedTypeVariables #-}
4+
5+
-- | Narrow tests for ChainSync Jumping
6+
module Test.Consensus.MiniProtocol.ChainSync.CSJ (tests) where
7+
8+
import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as TVar
9+
import Control.Monad (void)
10+
import Control.Monad.Class.MonadTimer (MonadTimer)
11+
import Control.Monad.IOSim (runSim)
12+
import Control.ResourceRegistry
13+
import Control.Tracer (nullTracer)
14+
import Data.Typeable
15+
import Network.TypedProtocol.Channel
16+
import Network.TypedProtocol.Driver.Simple
17+
import Ouroboros.Consensus.Block
18+
import Ouroboros.Consensus.BlockchainTime
19+
import Ouroboros.Consensus.Config
20+
import qualified Ouroboros.Consensus.HeaderStateHistory as HeaderStateHistory
21+
import Ouroboros.Consensus.Ledger.Tables.Utils (forgetLedgerTables)
22+
import Ouroboros.Consensus.MiniProtocol.ChainSync.Client
23+
(CSJConfig (..), CSJEnabledConfig (..), ChainDbView (..),
24+
ChainSyncLoPBucketConfig (..), ChainSyncStateView (..),
25+
ConfigEnv (..), Consensus, DynamicEnv (..),
26+
bracketChainSyncClient, chainSyncClient,
27+
newChainSyncClientHandleCollection)
28+
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.HistoricityCheck as HistoricityCheck
29+
import qualified Ouroboros.Consensus.MiniProtocol.ChainSync.Client.InFutureCheck as InFutureCheck
30+
import qualified Ouroboros.Consensus.Node.GsmState as GSM
31+
import Ouroboros.Consensus.Node.NetworkProtocolVersion
32+
(NodeToNodeVersion)
33+
import Ouroboros.Consensus.NodeId
34+
import Ouroboros.Consensus.Util.IOLike
35+
import Ouroboros.Consensus.Util.STM (Fingerprint (..),
36+
WithFingerprint (..))
37+
import qualified Ouroboros.Network.AnchoredFragment as AF
38+
import Ouroboros.Network.ControlMessage (ControlMessage (..))
39+
import qualified Ouroboros.Network.Mock.Chain as MockChain
40+
import Ouroboros.Network.Protocol.ChainSync.ClientPipelined
41+
import Ouroboros.Network.Protocol.ChainSync.Codec (codecChainSyncId)
42+
import Ouroboros.Network.Protocol.ChainSync.Examples
43+
import Ouroboros.Network.Protocol.ChainSync.PipelineDecision
44+
(pipelineDecisionLowHighMark)
45+
import Ouroboros.Network.Protocol.ChainSync.Server
46+
import Test.QuickCheck
47+
import Test.Tasty
48+
import Test.Tasty.QuickCheck
49+
import Test.Util.Orphans.Arbitrary ()
50+
import Test.Util.Orphans.IOLike ()
51+
import Test.Util.TestBlock
52+
53+
{-------------------------------------------------------------------------------
54+
Top-level tests
55+
-------------------------------------------------------------------------------}
56+
57+
tests :: TestTree
58+
tests = testGroup "Narrow CSJ"
59+
[ testProperty "CaughtUp" prop_CaughtUpCsj
60+
]
61+
62+
{-------------------------------------------------------------------------------
63+
Main property
64+
-------------------------------------------------------------------------------}
65+
66+
data TestSetup =
67+
-- | This test is very simple for now, since it's so far merely a
68+
-- regression test of a simple property we're very surprised made it past
69+
-- code review.
70+
TestSetup
71+
deriving (Read, Show)
72+
73+
instance Arbitrary TestSetup where
74+
arbitrary = pure TestSetup
75+
76+
-- | When the node is CaughtUp, CSJ should be disabled.
77+
--
78+
-- The test checks for that by testing whether two upstream peers joining
79+
-- causes them both to promptly receive @MsgRequestNext@. If CSJ were enabled,
80+
-- then instead only the first peer to join would promptly receive
81+
-- @MsgRequestNext@.
82+
prop_CaughtUpCsj :: TestSetup -> Property
83+
prop_CaughtUpCsj testSetup =
84+
case runSim $ runTest testSetup of
85+
86+
Left exn ->
87+
counterexample ("`runTest' threw an exception: " <> show exn)
88+
$ property False
89+
90+
Right results ->
91+
counterexample "At least one peer did not receive MsgRequestNext"
92+
$ results === (HasReceived, HasReceived)
93+
94+
data WhetherReceivedMsgNextRequest =
95+
HasNotYetReceived
96+
|
97+
HasReceived
98+
deriving (Eq, Show)
99+
100+
runTest :: forall m.
101+
(
102+
IOLike m
103+
,
104+
MonadTimer m
105+
)
106+
=> TestSetup
107+
-> m (WhetherReceivedMsgNextRequest, WhetherReceivedMsgNextRequest)
108+
runTest TestSetup = withRegistry $ \registry -> do
109+
110+
-- The "Ouroboros.Consensus.NodeKernel" does not do anything more than this
111+
-- in order to "initialize" CSJ.
112+
varHandles <- atomically newChainSyncClientHandleCollection
113+
114+
let chainDbView :: ChainDbView m TestBlock
115+
chainDbView = ChainDbView {
116+
getCurrentChain = pure $ AF.Empty AF.AnchorGenesis
117+
,
118+
getHeaderStateHistory =
119+
pure
120+
$ HeaderStateHistory.fromChain
121+
topLevelCfg
122+
testInitExtLedger
123+
MockChain.Genesis
124+
,
125+
getPastLedger = pure . \case
126+
GenesisPoint -> Just $ forgetLedgerTables testInitExtLedger
127+
BlockPoint{} -> Nothing
128+
,
129+
getIsInvalidBlock =
130+
pure $ WithFingerprint (\_hash -> Nothing) (Fingerprint 0)
131+
}
132+
133+
version :: NodeToNodeVersion
134+
version = maxBound
135+
136+
lopBucketConfig :: ChainSyncLoPBucketConfig
137+
lopBucketConfig = ChainSyncLoPBucketDisabled
138+
139+
csjConfig :: CSJEnabledConfig
140+
csjConfig = CSJEnabledConfig { csjcJumpSize = SlotNo 10000 }
141+
142+
diffusionPipelining :: DiffusionPipeliningSupport
143+
diffusionPipelining = DiffusionPipeliningOn
144+
145+
headerInFutureCheck ::
146+
InFutureCheck.SomeHeaderInFutureCheck m TestBlock
147+
headerInFutureCheck =
148+
InFutureCheck.SomeHeaderInFutureCheck
149+
$ InFutureCheck.HeaderInFutureCheck {
150+
InFutureCheck.proxyArrival = Proxy :: Proxy ()
151+
,
152+
InFutureCheck.recordHeaderArrival = \_ -> pure ()
153+
,
154+
InFutureCheck.judgeHeaderArrival =
155+
\_lcfg _lstate () -> pure ()
156+
,
157+
InFutureCheck.handleHeaderArrival =
158+
\() -> pure $ pure $ RelativeTime 0
159+
}
160+
161+
mkClient ::
162+
ChainSyncStateView m TestBlock
163+
-> Consensus ChainSyncClientPipelined TestBlock m
164+
mkClient csv =
165+
let ChainSyncStateView {
166+
csvSetCandidate
167+
,
168+
csvSetLatestSlot
169+
,
170+
csvIdling
171+
,
172+
csvLoPBucket
173+
,
174+
csvJumping
175+
} = csv
176+
in
177+
chainSyncClient
178+
ConfigEnv {
179+
chainDbView
180+
,
181+
cfg = topLevelCfg
182+
,
183+
tracer = nullTracer
184+
,
185+
someHeaderInFutureCheck = headerInFutureCheck
186+
,
187+
historicityCheck = HistoricityCheck.noCheck
188+
,
189+
mkPipelineDecision0 = pipelineDecisionLowHighMark 10 20
190+
,
191+
getDiffusionPipeliningSupport = diffusionPipelining
192+
}
193+
DynamicEnv {
194+
version
195+
,
196+
controlMessageSTM = return Continue
197+
,
198+
headerMetricsTracer = nullTracer
199+
,
200+
setCandidate = csvSetCandidate
201+
,
202+
idling = csvIdling
203+
,
204+
loPBucket = csvLoPBucket
205+
,
206+
setLatestSlot = csvSetLatestSlot
207+
,
208+
jumping = csvJumping
209+
}
210+
211+
bracketedClient ::
212+
CoreNodeId
213+
-> (Consensus ChainSyncClientPipelined TestBlock m -> m a)
214+
-> m a
215+
bracketedClient peer k =
216+
bracketChainSyncClient
217+
nullTracer
218+
nullTracer
219+
chainDbView
220+
varHandles
221+
(pure GSM.CaughtUp)
222+
peer
223+
version
224+
lopBucketConfig
225+
(CSJEnabled csjConfig)
226+
diffusionPipelining
227+
(k . mkClient)
228+
229+
spawnConnection ::
230+
CoreNodeId
231+
-> m (TVar.StrictTVar m WhetherReceivedMsgNextRequest)
232+
spawnConnection peer = do
233+
var <- TVar.newTVarIO HasNotYetReceived
234+
(clientChannel, serverChannel) <- createConnectedChannels
235+
void $ forkLinkedThread registry ("client " <> show peer) $ do
236+
bracketedClient peer $ \client -> do
237+
runPipelinedPeer
238+
nullTracer
239+
codecChainSyncId
240+
clientChannel
241+
(chainSyncClientPeerPipelined client)
242+
void $ forkLinkedThread registry ("server " <> show peer) $ do
243+
runPeer
244+
nullTracer
245+
codecChainSyncId
246+
serverChannel
247+
$ chainSyncServerPeer
248+
$ server
249+
$ atomically (TVar.writeTVar var HasReceived)
250+
pure var
251+
252+
var1 <- spawnConnection $ CoreNodeId 1
253+
var2 <- spawnConnection $ CoreNodeId 2
254+
255+
threadDelay testDuration
256+
257+
atomically $ (,) <$> TVar.readTVar var1 <*> TVar.readTVar var2
258+
259+
-- | How long the test runs for
260+
--
261+
-- The only time-sensitive thing in this test is the 'Exhausted' exception in
262+
-- 'server', so as long as that happens after this duration, time should be
263+
-- irrelevant.
264+
testDuration :: Num a => a
265+
testDuration = 100
266+
267+
server ::
268+
IOLike m
269+
=> m ()
270+
-- ^ action to perform on the first @MsgRequestNext@, after which this
271+
-- peer becomes unresponsive
272+
-> ChainSyncServer (Header TestBlock) (Point TestBlock) (Tip TestBlock) m ()
273+
server onFirstMsgRequestNext =
274+
go
275+
where
276+
dummyTip = Tip (SlotNo 1000) (testHashFromList [0]) (BlockNo 1000)
277+
-- inconsequential for this test
278+
279+
go = ChainSyncServer $ pure $ ServerStIdle {
280+
recvMsgRequestNext = do
281+
onFirstMsgRequestNext
282+
threadDelay $ testDuration + 1
283+
throwIO Exhausted
284+
,
285+
recvMsgFindIntersect = \_points ->
286+
pure $ SendMsgIntersectFound GenesisPoint dummyTip go
287+
,
288+
recvMsgDoneClient = throwIO UnexpectedTermination
289+
}
290+
291+
data TestException =
292+
-- | The test ran for longer than it expected to; see 'testDuration'
293+
Exhausted
294+
|
295+
-- | A peer received @MsgDone@, which shouldn't happen in this test
296+
UnexpectedTermination
297+
deriving (Eq, Show)
298+
299+
instance Exception TestException
300+
301+
-- | This data structure contains a lot of values that are inconsequential for
302+
-- this test, especially since this test doesn't actually involve any blocks
303+
topLevelCfg :: TopLevelConfig TestBlock
304+
topLevelCfg = singleNodeTestConfig

0 commit comments

Comments
 (0)