Skip to content

Commit df7581b

Browse files
tbagrel1agustinmistaamesgengeo2anbacquey
committed
Add smoke tests for generic ObjectDiffusion
Co-authored-by: Agustin Mista <agustin.mista@moduscreate.com> Co-authored-by: Alexander Esgen <alexander.esgen@iohk.io> Co-authored-by: Georgy Lukyanov <georgy.lukyanov@iohk.io> Co-authored-by: Thomas BAGREL <thomas.bagrel@tweag.io> Co-authored-by: Nicolas BACQUEY <nicolas.bacquey@tweag.io> Co-authored-by: Nicolas "Niols" Jeannerod <nicolas.jeannerod@moduscreate.com>
1 parent a61270a commit df7581b

File tree

3 files changed

+305
-0
lines changed

3 files changed

+305
-0
lines changed

‎ouroboros-consensus/ouroboros-consensus.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -667,6 +667,7 @@ test-suite consensus-test
667667
Test.Consensus.MiniProtocol.ChainSync.CSJ
668668
Test.Consensus.MiniProtocol.ChainSync.Client
669669
Test.Consensus.MiniProtocol.LocalStateQuery.Server
670+
Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
670671
Test.Consensus.Peras.WeightSnapshot
671672
Test.Consensus.Util.MonadSTM.NormalForm
672673
Test.Consensus.Util.Versioned

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests)
1616
import qualified Test.Consensus.MiniProtocol.ChainSync.CSJ (tests)
1717
import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests)
1818
import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests)
19+
import qualified Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke (tests)
1920
import qualified Test.Consensus.Peras.WeightSnapshot (tests)
2021
import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests)
2122
import qualified Test.Consensus.Util.Versioned (tests)
@@ -37,6 +38,7 @@ tests =
3738
, Test.Consensus.MiniProtocol.BlockFetch.Client.tests
3839
, Test.Consensus.MiniProtocol.ChainSync.CSJ.tests
3940
, Test.Consensus.MiniProtocol.ChainSync.Client.tests
41+
, Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke.tests
4042
, Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests
4143
, testGroup
4244
"Mempool"

‎ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ObjectDiffusion/Smoke.hs‎

Lines changed: 302 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,302 @@
1+
{-# LANGUAGE DerivingVia #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE FunctionalDependencies #-}
5+
{-# LANGUAGE GADTs #-}
6+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+
{-# LANGUAGE KindSignatures #-}
8+
{-# LANGUAGE RankNTypes #-}
9+
{-# LANGUAGE ScopedTypeVariables #-}
10+
11+
-- | Smoke tests for the object diffusion protocol. This uses a trivial object
12+
-- pool and checks that a few objects can indeed be transferred from the
13+
-- outbound to the inbound peer.
14+
module Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
15+
( tests
16+
, WithId (..)
17+
, ListWithUniqueIds (..)
18+
, ProtocolConstants
19+
, prop_smoke_object_diffusion
20+
) where
21+
22+
import Control.Monad.IOSim (runSimStrictShutdown)
23+
import Control.ResourceRegistry (forkLinkedThread, waitAnyThread, withRegistry)
24+
import Control.Tracer (Tracer, nullTracer, traceWith)
25+
import Data.Containers.ListUtils (nubOrdOn)
26+
import Data.Functor.Contravariant (contramap)
27+
import Network.TypedProtocol.Channel (Channel, createConnectedChannels)
28+
import Network.TypedProtocol.Codec (AnyMessage)
29+
import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer)
30+
import NoThunks.Class (NoThunks)
31+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound
32+
( objectDiffusionInbound
33+
)
34+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
35+
( ObjectPoolReader (..)
36+
, ObjectPoolWriter (..)
37+
)
38+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound)
39+
import Ouroboros.Consensus.Util.IOLike
40+
( IOLike
41+
, MonadDelay (..)
42+
, MonadSTM (..)
43+
, StrictTVar
44+
, modifyTVar
45+
, readTVar
46+
, uncheckedNewTVarM
47+
, writeTVar
48+
)
49+
import Ouroboros.Network.ControlMessage (ControlMessage (..))
50+
import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion (..))
51+
import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId)
52+
import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound
53+
( ObjectDiffusionInboundPipelined
54+
, objectDiffusionInboundPeerPipelined
55+
)
56+
import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound
57+
( ObjectDiffusionOutbound
58+
, objectDiffusionOutboundPeer
59+
)
60+
import Ouroboros.Network.Protocol.ObjectDiffusion.Type
61+
( NumObjectIdsReq (..)
62+
, NumObjectsOutstanding (..)
63+
, NumObjectsReq (..)
64+
, ObjectDiffusion
65+
)
66+
import Test.QuickCheck
67+
import Test.Tasty
68+
import Test.Tasty.QuickCheck
69+
import Test.Util.Orphans.Arbitrary ()
70+
import Test.Util.Orphans.IOLike ()
71+
72+
tests :: TestTree
73+
tests =
74+
testGroup
75+
"ObjectDiffusion.Smoke"
76+
[ testProperty
77+
"ObjectDiffusion smoke test with mock objects"
78+
prop_smoke
79+
]
80+
81+
{-------------------------------------------------------------------------------
82+
Provides a way to generate lists composed of objects with no duplicate ids,
83+
with an Arbitrary instance
84+
-------------------------------------------------------------------------------}
85+
86+
class WithId a idTy | a -> idTy where
87+
getId :: a -> idTy
88+
89+
newtype ListWithUniqueIds a idTy = ListWithUniqueIds [a]
90+
deriving (Eq, Show, Ord)
91+
92+
instance (Ord idTy, WithId a idTy, Arbitrary a) => Arbitrary (ListWithUniqueIds a idTy) where
93+
arbitrary = ListWithUniqueIds . nubOrdOn getId <$> arbitrary
94+
95+
instance WithId SmokeObject SmokeObjectId where getId = getSmokeObjectId
96+
97+
{-------------------------------------------------------------------------------
98+
Mock objectPools
99+
-------------------------------------------------------------------------------}
100+
101+
newtype SmokeObjectId = SmokeObjectId Int
102+
deriving (Eq, Ord, Show, NoThunks, Arbitrary)
103+
104+
newtype SmokeObject = SmokeObject {getSmokeObjectId :: SmokeObjectId}
105+
deriving (Eq, Ord, Show, NoThunks, Arbitrary)
106+
107+
newtype SmokeObjectPool m = SmokeObjectPool (StrictTVar m [SmokeObject])
108+
109+
newObjectPool :: MonadSTM m => [SmokeObject] -> m (SmokeObjectPool m)
110+
newObjectPool initialPoolContent = SmokeObjectPool <$> uncheckedNewTVarM initialPoolContent
111+
112+
makeObjectPoolReader ::
113+
MonadSTM m => SmokeObjectPool m -> ObjectPoolReader SmokeObjectId SmokeObject Int m
114+
makeObjectPoolReader (SmokeObjectPool poolContentTvar) =
115+
ObjectPoolReader
116+
{ oprObjectId = getSmokeObjectId
117+
, oprObjectsAfter = \minTicketNo limit -> do
118+
poolContent <- readTVar poolContentTvar
119+
pure $
120+
take (fromIntegral limit) $
121+
drop (minTicketNo + 1) $
122+
( (\(ticketNo, smokeObject) -> (ticketNo, getSmokeObjectId smokeObject, pure smokeObject))
123+
<$> zip [(0 :: Int) ..] poolContent
124+
)
125+
, oprZeroTicketNo = -1 -- objectPoolObjectIdsAfter uses strict comparison, and first ticketNo is 0.
126+
}
127+
128+
makeObjectPoolWriter ::
129+
MonadSTM m => SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m
130+
makeObjectPoolWriter (SmokeObjectPool poolContentTvar) =
131+
ObjectPoolWriter
132+
{ opwObjectId = getSmokeObjectId
133+
, opwAddObjects = \objects -> do
134+
atomically $ modifyTVar poolContentTvar (++ objects)
135+
return ()
136+
, opwHasObject = do
137+
poolContent <- readTVar poolContentTvar
138+
pure $ \objectId -> any (\obj -> getSmokeObjectId obj == objectId) poolContent
139+
}
140+
141+
mkMockPoolInterfaces ::
142+
MonadSTM m =>
143+
[SmokeObject] ->
144+
m
145+
( ObjectPoolReader SmokeObjectId SmokeObject Int m
146+
, ObjectPoolWriter SmokeObjectId SmokeObject m
147+
, m [SmokeObject]
148+
)
149+
mkMockPoolInterfaces objects = do
150+
outboundPool <- newObjectPool objects
151+
inboundPool@(SmokeObjectPool tvar) <- newObjectPool []
152+
153+
let outboundPoolReader = makeObjectPoolReader outboundPool
154+
inboundPoolWriter = makeObjectPoolWriter inboundPool
155+
156+
return (outboundPoolReader, inboundPoolWriter, atomically $ readTVar tvar)
157+
158+
{-------------------------------------------------------------------------------
159+
Main properties
160+
-------------------------------------------------------------------------------}
161+
162+
-- Protocol constants
163+
164+
newtype ProtocolConstants
165+
= ProtocolConstants (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq)
166+
deriving Show
167+
168+
instance Arbitrary ProtocolConstants where
169+
arbitrary = do
170+
maxFifoSize <- choose (5, 20)
171+
maxIdsToReq <- choose (3, maxFifoSize)
172+
maxObjectsToReq <- choose (2, maxIdsToReq)
173+
pure $
174+
ProtocolConstants
175+
( NumObjectsOutstanding maxFifoSize
176+
, NumObjectIdsReq maxIdsToReq
177+
, NumObjectsReq maxObjectsToReq
178+
)
179+
180+
nodeToNodeVersion :: NodeToNodeVersion
181+
nodeToNodeVersion = NodeToNodeV_14
182+
183+
prop_smoke :: ProtocolConstants -> ListWithUniqueIds SmokeObject idTy -> Property
184+
prop_smoke protocolConstants (ListWithUniqueIds objects) =
185+
prop_smoke_object_diffusion
186+
protocolConstants
187+
objects
188+
runOutboundPeer
189+
runInboundPeer
190+
(mkMockPoolInterfaces objects)
191+
where
192+
runOutboundPeer outbound outboundChannel tracer =
193+
runPeer
194+
((\x -> "Outbound (Server): " ++ show x) `contramap` tracer)
195+
codecObjectDiffusionId
196+
outboundChannel
197+
(objectDiffusionOutboundPeer outbound)
198+
>> pure ()
199+
200+
runInboundPeer inbound inboundChannel tracer =
201+
runPipelinedPeer
202+
((\x -> "Inbound (Client): " ++ show x) `contramap` tracer)
203+
codecObjectDiffusionId
204+
inboundChannel
205+
(objectDiffusionInboundPeerPipelined inbound)
206+
>> pure ()
207+
208+
--- The core logic of the smoke test is shared between the generic smoke tests for ObjectDiffusion, and the ones specialised to PerasCert/PerasVote diffusion
209+
prop_smoke_object_diffusion ::
210+
( Eq object
211+
, Show object
212+
, Ord objectId
213+
, NoThunks objectId
214+
, Show objectId
215+
, NoThunks object
216+
, Ord ticketNo
217+
) =>
218+
ProtocolConstants ->
219+
[object] ->
220+
( forall m.
221+
IOLike m =>
222+
ObjectDiffusionOutbound objectId object m () ->
223+
Channel m (AnyMessage (ObjectDiffusion objectId object)) ->
224+
(Tracer m String) ->
225+
m ()
226+
) ->
227+
( forall m.
228+
IOLike m =>
229+
ObjectDiffusionInboundPipelined objectId object m () ->
230+
(Channel m (AnyMessage (ObjectDiffusion objectId object))) ->
231+
(Tracer m String) ->
232+
m ()
233+
) ->
234+
( forall m.
235+
IOLike m =>
236+
m
237+
( ObjectPoolReader objectId object ticketNo m
238+
, ObjectPoolWriter objectId object m
239+
, m [object]
240+
)
241+
) ->
242+
Property
243+
prop_smoke_object_diffusion
244+
(ProtocolConstants (maxFifoSize, maxIdsToReq, maxObjectsToReq))
245+
objects
246+
runOutboundPeer
247+
runInboundPeer
248+
mkPoolInterfaces =
249+
let
250+
simulationResult = runSimStrictShutdown $ do
251+
let tracer = nullTracer
252+
253+
traceWith tracer "========== [ Starting ObjectDiffusion smoke test ] =========="
254+
traceWith tracer (show objects)
255+
256+
(outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) <- mkPoolInterfaces
257+
controlMessage <- uncheckedNewTVarM Continue
258+
259+
let
260+
inbound =
261+
objectDiffusionInbound
262+
tracer
263+
( maxFifoSize
264+
, maxIdsToReq
265+
, maxObjectsToReq
266+
)
267+
inboundPoolWriter
268+
nodeToNodeVersion
269+
(readTVar controlMessage)
270+
271+
outbound =
272+
objectDiffusionOutbound
273+
tracer
274+
maxFifoSize
275+
outboundPoolReader
276+
nodeToNodeVersion
277+
278+
withRegistry $ \reg -> do
279+
(outboundChannel, inboundChannel) <- createConnectedChannels
280+
outboundThread <-
281+
forkLinkedThread reg "ObjectDiffusion Outbound peer thread" $
282+
runOutboundPeer outbound outboundChannel tracer
283+
inboundThread <-
284+
forkLinkedThread reg "ObjectDiffusion Inbound peer thread" $
285+
runInboundPeer inbound inboundChannel tracer
286+
controlMessageThread <- forkLinkedThread reg "ObjectDiffusion Control thread" $ do
287+
threadDelay 1000 -- give a head start to the other threads
288+
atomically $ writeTVar controlMessage Terminate
289+
threadDelay 1000 -- wait for the other threads to finish
290+
waitAnyThread [outboundThread, inboundThread, controlMessageThread]
291+
292+
traceWith tracer "========== [ ObjectDiffusion smoke test finished ] =========="
293+
poolContent <- getAllInboundPoolContent
294+
295+
traceWith tracer "inboundPoolContent:"
296+
traceWith tracer (show poolContent)
297+
traceWith tracer "========== ======================================= =========="
298+
pure poolContent
299+
in
300+
case simulationResult of
301+
Right inboundPoolContent -> inboundPoolContent === objects
302+
Left msg -> counterexample (show msg) $ property False

0 commit comments

Comments
 (0)