Skip to content

Commit 053dc5a

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 86e5ff8 commit 053dc5a

File tree

3 files changed

+329
-0
lines changed

3 files changed

+329
-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: 326 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,326 @@
1+
{-# LANGUAGE DerivingVia #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE FunctionalDependencies #-}
5+
{-# LANGUAGE GADTs #-}
6+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7+
{-# LANGUAGE KindSignatures #-}
8+
{-# LANGUAGE NumericUnderscores #-}
9+
{-# LANGUAGE RankNTypes #-}
10+
{-# LANGUAGE ScopedTypeVariables #-}
11+
12+
-- | Smoke tests for the object diffusion protocol. This uses a trivial object
13+
-- pool and checks that a few objects can indeed be transferred from the
14+
-- outbound to the inbound peer.
15+
module Test.Consensus.MiniProtocol.ObjectDiffusion.Smoke
16+
( tests
17+
, WithId (..)
18+
, ListWithUniqueIds (..)
19+
, genListWithUniqueIds
20+
, ProtocolConstants
21+
, genProtocolConstants
22+
, prop_smoke_object_diffusion
23+
) where
24+
25+
import Control.Monad (void)
26+
import Control.Monad.IOSim (runSimStrictShutdown)
27+
import Control.ResourceRegistry (forkLinkedThread, withRegistry)
28+
import Control.Tracer (Tracer, nullTracer, traceWith)
29+
import Data.Containers.ListUtils (nubOrdOn)
30+
import Data.Data (Typeable)
31+
import Data.Functor.Contravariant (contramap)
32+
import qualified Data.Map as Map
33+
import Network.TypedProtocol.Channel (Channel, createConnectedChannels)
34+
import Network.TypedProtocol.Codec (AnyMessage)
35+
import Network.TypedProtocol.Driver.Simple (runPeer, runPipelinedPeer)
36+
import NoThunks.Class (NoThunks)
37+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Inbound
38+
( objectDiffusionInbound
39+
)
40+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.ObjectPool.API
41+
( ObjectPoolReader (..)
42+
, ObjectPoolWriter (..)
43+
)
44+
import Ouroboros.Consensus.MiniProtocol.ObjectDiffusion.Outbound (objectDiffusionOutbound)
45+
import Ouroboros.Consensus.Util.IOLike
46+
( IOLike
47+
, MonadDelay (..)
48+
, MonadSTM (..)
49+
, StrictTVar
50+
, modifyTVar
51+
, readTVar
52+
, uncheckedNewTVarM
53+
, writeTVar
54+
)
55+
import Ouroboros.Network.ControlMessage (ControlMessage (..))
56+
import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion (..))
57+
import Ouroboros.Network.Protocol.ObjectDiffusion.Codec (codecObjectDiffusionId)
58+
import Ouroboros.Network.Protocol.ObjectDiffusion.Inbound
59+
( ObjectDiffusionInboundPipelined
60+
, objectDiffusionInboundPeerPipelined
61+
)
62+
import Ouroboros.Network.Protocol.ObjectDiffusion.Outbound
63+
( ObjectDiffusionOutbound
64+
, objectDiffusionOutboundPeer
65+
)
66+
import Ouroboros.Network.Protocol.ObjectDiffusion.Type
67+
( NumObjectIdsReq (..)
68+
, NumObjectsOutstanding (..)
69+
, NumObjectsReq (..)
70+
, ObjectDiffusion
71+
)
72+
import Test.QuickCheck
73+
import Test.Tasty
74+
import Test.Tasty.QuickCheck
75+
import Test.Util.Orphans.IOLike ()
76+
77+
tests :: TestTree
78+
tests =
79+
testGroup
80+
"ObjectDiffusion.Smoke"
81+
[ testProperty
82+
"ObjectDiffusion smoke test with mock objects"
83+
prop_smoke
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+
genListWithUniqueIds :: (Ord idTy, WithId a idTy) => Gen a -> Gen (ListWithUniqueIds a idTy)
93+
genListWithUniqueIds genA = ListWithUniqueIds . nubOrdOn getId <$> listOf genA
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)
103+
104+
newtype SmokeObject = SmokeObject {getSmokeObjectId :: SmokeObjectId}
105+
deriving (Eq, Ord, Show, NoThunks)
106+
107+
genSmokeObject :: Gen SmokeObject
108+
genSmokeObject = SmokeObject . SmokeObjectId <$> arbitrary
109+
110+
newtype SmokeObjectPool m = SmokeObjectPool (StrictTVar m [SmokeObject])
111+
112+
newObjectPool :: MonadSTM m => [SmokeObject] -> m (SmokeObjectPool m)
113+
newObjectPool initialPoolContent = SmokeObjectPool <$> uncheckedNewTVarM initialPoolContent
114+
115+
makeObjectPoolReader ::
116+
MonadSTM m => SmokeObjectPool m -> ObjectPoolReader SmokeObjectId SmokeObject Int m
117+
makeObjectPoolReader (SmokeObjectPool poolContentTvar) =
118+
ObjectPoolReader
119+
{ oprObjectId = getSmokeObjectId
120+
, oprObjectsAfter = \minTicketNo limit -> do
121+
poolContent <- readTVar poolContentTvar
122+
let newContent = drop minTicketNo $ zip [(1 :: Int) ..] poolContent
123+
if null newContent
124+
then pure Nothing
125+
else
126+
pure . Just . pure $
127+
Map.fromList (take (fromIntegral limit) newContent)
128+
, oprZeroTicketNo = 0
129+
}
130+
131+
makeObjectPoolWriter ::
132+
MonadSTM m => SmokeObjectPool m -> ObjectPoolWriter SmokeObjectId SmokeObject m
133+
makeObjectPoolWriter (SmokeObjectPool poolContentTvar) =
134+
ObjectPoolWriter
135+
{ opwObjectId = getSmokeObjectId
136+
, opwAddObjects = \objects -> do
137+
atomically $ modifyTVar poolContentTvar (++ objects)
138+
return ()
139+
, opwHasObject = do
140+
poolContent <- readTVar poolContentTvar
141+
pure $ \objectId -> any (\obj -> getSmokeObjectId obj == objectId) poolContent
142+
}
143+
144+
mkMockPoolInterfaces ::
145+
MonadSTM m =>
146+
[SmokeObject] ->
147+
m
148+
( ObjectPoolReader SmokeObjectId SmokeObject Int m
149+
, ObjectPoolWriter SmokeObjectId SmokeObject m
150+
, m [SmokeObject]
151+
)
152+
mkMockPoolInterfaces objects = do
153+
outboundPool <- newObjectPool objects
154+
inboundPool@(SmokeObjectPool tvar) <- newObjectPool []
155+
156+
let outboundPoolReader = makeObjectPoolReader outboundPool
157+
inboundPoolWriter = makeObjectPoolWriter inboundPool
158+
159+
return (outboundPoolReader, inboundPoolWriter, atomically $ readTVar tvar)
160+
161+
{-------------------------------------------------------------------------------
162+
Main properties
163+
-------------------------------------------------------------------------------}
164+
165+
-- Protocol constants
166+
167+
newtype ProtocolConstants
168+
= ProtocolConstants (NumObjectsOutstanding, NumObjectIdsReq, NumObjectsReq)
169+
deriving Show
170+
171+
genProtocolConstants :: Gen ProtocolConstants
172+
genProtocolConstants = do
173+
maxFifoSize <- choose (5, 20)
174+
maxIdsToReq <- choose (3, maxFifoSize)
175+
maxObjectsToReq <- choose (2, maxIdsToReq)
176+
pure $
177+
ProtocolConstants
178+
( NumObjectsOutstanding maxFifoSize
179+
, NumObjectIdsReq maxIdsToReq
180+
, NumObjectsReq maxObjectsToReq
181+
)
182+
183+
nodeToNodeVersion :: NodeToNodeVersion
184+
nodeToNodeVersion = NodeToNodeV_14
185+
186+
prop_smoke :: Property
187+
prop_smoke =
188+
forAll genProtocolConstants $ \protocolConstants ->
189+
forAll (genListWithUniqueIds genSmokeObject) $ \(ListWithUniqueIds objects) ->
190+
let
191+
runOutboundPeer outbound outboundChannel tracer =
192+
runPeer
193+
((\x -> "Outbound (Server): " ++ show x) `contramap` tracer)
194+
codecObjectDiffusionId
195+
outboundChannel
196+
(objectDiffusionOutboundPeer outbound)
197+
>> pure ()
198+
199+
runInboundPeer inbound inboundChannel tracer =
200+
runPipelinedPeer
201+
((\x -> "Inbound (Client): " ++ show x) `contramap` tracer)
202+
codecObjectDiffusionId
203+
inboundChannel
204+
(objectDiffusionInboundPeerPipelined inbound)
205+
>> pure ()
206+
in
207+
prop_smoke_object_diffusion
208+
protocolConstants
209+
objects
210+
runOutboundPeer
211+
runInboundPeer
212+
(mkMockPoolInterfaces objects)
213+
214+
--- The core logic of the smoke test is shared between the generic smoke tests for ObjectDiffusion, and the ones specialised to PerasCert/PerasVote diffusion
215+
prop_smoke_object_diffusion ::
216+
( Eq object
217+
, Show object
218+
, Ord objectId
219+
, Typeable objectId
220+
, Typeable object
221+
, NoThunks objectId
222+
, Show objectId
223+
, NoThunks object
224+
, Ord ticketNo
225+
) =>
226+
ProtocolConstants ->
227+
[object] ->
228+
( forall m.
229+
IOLike m =>
230+
ObjectDiffusionOutbound objectId object m () ->
231+
Channel m (AnyMessage (ObjectDiffusion objectId object)) ->
232+
(Tracer m String) ->
233+
m ()
234+
) ->
235+
( forall m.
236+
IOLike m =>
237+
ObjectDiffusionInboundPipelined objectId object m () ->
238+
(Channel m (AnyMessage (ObjectDiffusion objectId object))) ->
239+
(Tracer m String) ->
240+
m ()
241+
) ->
242+
( forall m.
243+
IOLike m =>
244+
m
245+
( ObjectPoolReader objectId object ticketNo m
246+
, ObjectPoolWriter objectId object m
247+
, m [object]
248+
)
249+
) ->
250+
Property
251+
prop_smoke_object_diffusion
252+
(ProtocolConstants (maxFifoSize, maxIdsToReq, maxObjectsToReq))
253+
objects
254+
runOutboundPeer
255+
runInboundPeer
256+
mkPoolInterfaces =
257+
let
258+
simulationResult = runSimStrictShutdown $ do
259+
let tracer = nullTracer
260+
261+
traceWith tracer "========== [ Starting ObjectDiffusion smoke test ] =========="
262+
traceWith tracer "objects: "
263+
traceWith tracer (show objects)
264+
265+
(outboundPoolReader, inboundPoolWriter, getAllInboundPoolContent) <- mkPoolInterfaces
266+
267+
-- We wait until the inbound pool content stabilizes
268+
-- Caveat: in the case where objects are continuously added to the
269+
-- outbound pool, this may never terminate.
270+
let waitUntilSettlement prevValue = do
271+
-- TODO: should have a delay value equal to 4·Δ + Ɛ
272+
-- were Δ is the delay in which any message is delivered on the
273+
-- network and Ɛ is a small margin to encompass computation time;
274+
-- as in the worst case, we need 4 echanged messages
275+
-- (+ computation time, assumed negligible w.r.t. network delays)
276+
-- to see a state update on the inbound side
277+
threadDelay 10_000
278+
newValue <- getAllInboundPoolContent
279+
if newValue == prevValue
280+
then pure ()
281+
else waitUntilSettlement newValue
282+
283+
controlMessage <- uncheckedNewTVarM Continue
284+
285+
let
286+
inbound =
287+
objectDiffusionInbound
288+
tracer
289+
( maxFifoSize
290+
, maxIdsToReq
291+
, maxObjectsToReq
292+
)
293+
inboundPoolWriter
294+
nodeToNodeVersion
295+
(readTVar controlMessage)
296+
297+
outbound =
298+
objectDiffusionOutbound
299+
tracer
300+
maxFifoSize
301+
outboundPoolReader
302+
nodeToNodeVersion
303+
304+
withRegistry $ \reg -> do
305+
(outboundChannel, inboundChannel) <- createConnectedChannels
306+
_outboundThread <-
307+
forkLinkedThread reg "ObjectDiffusion Outbound peer thread" $
308+
runOutboundPeer outbound outboundChannel tracer
309+
_inboundThread <-
310+
forkLinkedThread reg "ObjectDiffusion Inbound peer thread" $
311+
runInboundPeer inbound inboundChannel tracer
312+
313+
void $ waitUntilSettlement []
314+
atomically $ writeTVar controlMessage Terminate
315+
316+
traceWith tracer "========== [ ObjectDiffusion smoke test finished ] =========="
317+
318+
poolContent <- getAllInboundPoolContent
319+
traceWith tracer "inboundPoolContent: "
320+
traceWith tracer (show poolContent)
321+
traceWith tracer "========== ======================================= =========="
322+
pure poolContent
323+
in
324+
case simulationResult of
325+
Right inboundPoolContent -> inboundPoolContent === objects
326+
Left msg -> counterexample (show msg) $ property False

0 commit comments

Comments
 (0)