Skip to content

Commit f38c02f

Browse files
SaizanSaizan
committed
simulation: fix generate-topology for more consistent producers
1 parent 2eeaacb commit f38c02f

26 files changed

+201
-176
lines changed

‎simulation/ouroboros-leios-sim.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -38,6 +38,7 @@ library
3838
default-extensions:
3939
DisambiguateRecordFields
4040
OverloadedRecordDot
41+
PatternSynonyms
4142
ScopedTypeVariables
4243

4344
exposed-modules:

‎simulation/src/LeiosProtocol/Short/DataSimP2P.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -493,7 +493,7 @@ idealDiffusionTimes p2pNetwork@P2PNetwork{p2pLinks} BlockDiffusionConfig{..} =
493493
where
494494
communicationDelay n1 n2 = latency * realToFrac hops + serialization
495495
where
496-
(secondsToDiffTime -> latency, bandwidth) = fromMaybe undefined (Map.lookup (n1, n2) p2pLinks)
496+
(secondsToDiffTime -> latency, bandwidth) = fromMaybe undefined (Map.lookup (n1 :<- n2) p2pLinks)
497497
serialization = case bandwidth of
498498
Nothing -> 0
499499
Just bps -> secondsToDiffTime $ realToFrac size / realToFrac bps
@@ -636,7 +636,7 @@ reportOnTopology prefixDir P2PNetwork{..} = do
636636
[ (d, Links{upstream = [u], downstream = []})
637637
, (u, Links{upstream = [], downstream = [d]})
638638
]
639-
let links = Map.fromListWith (<>) $ concat [mkLinks d u | (d, u) <- Map.keys p2pLinks]
639+
let links = Map.fromListWith (<>) $ concat [mkLinks d u | (d :<- u) <- Map.keys p2pLinks]
640640
let mkCsv f = unlines . map (show . getSum . f) $ Map.elems links
641641
writeFile (prefixDir </> "downcounts.csv") $ mkCsv (.downstream)
642642
writeFile (prefixDir </> "upcounts.csv") $ mkCsv (.upstream)

‎simulation/src/LeiosProtocol/Short/Sim.hs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -48,6 +48,7 @@ import LeiosProtocol.Short
4848
import LeiosProtocol.Short.Node
4949
import ModelTCP
5050
import Network.TypedProtocol
51+
import P2P
5152
import PraosProtocol.BlockFetch (Message (..))
5253
import qualified PraosProtocol.Common.Chain as Chain
5354
import PraosProtocol.PraosNode (PraosMessage (..), praosMessageLabel)
@@ -64,7 +65,7 @@ data LeiosEvent
6465
!World
6566
!(Map NodeId Point) -- nodes and locations
6667
!(Map NodeId StakeFraction)
67-
!(Set (NodeId, NodeId)) -- links between nodes
68+
!(Set Link) -- links between nodes
6869
| -- | An event at a node
6970
LeiosEventNode (LabelNode LeiosNodeEvent)
7071
| -- | An event on a tcp link between two nodes
@@ -383,7 +384,7 @@ traceRelayLink1 connectionOptions =
383384
]
384385
)
385386
( Set.fromList
386-
[(nodeA, nodeB), (nodeB, nodeA)]
387+
[(nodeA :<- nodeB), (nodeB :<- nodeA)]
387388
)
388389
slotConfig <- slotConfigFromNow
389390
let praosConfig@PraosConfig{configureConnection} = defaultPraosConfig

‎simulation/src/LeiosProtocol/Short/SimP2P.hs‎

Lines changed: 8 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -20,6 +20,7 @@ import qualified LeiosProtocol.Config as OnDisk
2020
import LeiosProtocol.Short (LeiosConfig (..), convertConfig)
2121
import LeiosProtocol.Short.Node
2222
import LeiosProtocol.Short.Sim
23+
import P2P
2324
import SimTCPLinks (labelDirToLabelLink, selectTimedEvents, simTracer)
2425
import SimTypes
2526
import System.Random (StdGen, split)
@@ -50,39 +51,20 @@ traceLeiosP2P
5051
p2pNodes
5152
p2pNodeStakes
5253
(Map.keysSet p2pLinks)
53-
tcplinks <-
54-
sequence
55-
[ do
56-
(inChan, outChan) <-
57-
newConnectionBundle @Leios
58-
(linkTracer na nb)
59-
(tcpprops (realToFrac latency) bandwidth)
60-
return ((na, nb), (inChan, outChan))
61-
| ((na, nb), (latency, bandwidth)) <- Map.toList p2pLinks
62-
]
63-
let tcplinksInChan =
64-
Map.fromListWith
65-
(++)
66-
[ (nfrom, [inChan])
67-
| ((nfrom, _nto), (inChan, _outChan)) <- tcplinks
68-
]
69-
tcplinksOutChan =
70-
Map.fromListWith
71-
(++)
72-
[ (nto, [outChan])
73-
| ((_nfrom, nto), (_inChan, outChan)) <- tcplinks
74-
]
75-
-- Note that the incomming edges are the output ends of the
76-
-- channels and vice versa. That's why it looks backwards.
7754

55+
(chansToDownstream :<- chansToUpstream) <-
56+
traverseLinks p2pLinks $ \na nb (latency, bandwidth) ->
57+
newConnectionBundle @Leios
58+
(linkTracer na nb)
59+
(tcpprops (realToFrac latency) bandwidth)
7860
-- Nested children threads are slow with IOSim, this impl forks them all as direct children.
7961
mapM_
8062
(\m -> mapM_ forkIO =<< m)
8163
[ leiosNode
8264
(nodeTracer nid)
8365
(leiosNodeConfig slotConfig nid rng)
84-
(Map.findWithDefault [] nid tcplinksInChan)
85-
(Map.findWithDefault [] nid tcplinksOutChan)
66+
(Map.findWithDefault [] nid chansToDownstream)
67+
(Map.findWithDefault [] nid chansToUpstream)
8668
| (nid, rng) <-
8769
zip
8870
(Map.keys p2pNodes)

‎simulation/src/LeiosProtocol/Short/VizSim.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,7 @@ import LeiosProtocol.Short.Node (BlockEvent (..), LeiosEventBlock (..), LeiosMes
3535
import LeiosProtocol.Short.Sim (LeiosEvent (..), LeiosTrace, exampleTrace1)
3636
import ModelTCP
3737
import Network.TypedProtocol
38-
import P2P (linkPathLatenciesSquared)
38+
import P2P (Link, linkPathLatenciesSquared, pattern (:<-))
3939
import PraosProtocol.BlockFetch (Message (MsgBlock))
4040
import PraosProtocol.ChainSync (Message (MsgRollForward_StCanAwait, MsgRollForward_StMustReply))
4141
import PraosProtocol.PraosNode (PraosMessage (..))
@@ -102,7 +102,7 @@ data LeiosSimVizState
102102
{ vizWorld :: !World
103103
, vizNodePos :: !(Map NodeId Point)
104104
, vizNodeStakes :: !(Map NodeId StakeFraction)
105-
, vizNodeLinks :: !(Map (NodeId, NodeId) LinkPoints)
105+
, vizNodeLinks :: !(Map Link LinkPoints)
106106
, vizMsgsInTransit ::
107107
!( Map
108108
(NodeId, NodeId)
@@ -324,7 +324,7 @@ leiosSimVizModel LeiosModelConfig{recentSpan} =
324324
, vizNodeStakes = stakes
325325
, vizNodeLinks =
326326
Map.fromSet
327-
( \(n1, n2) ->
327+
( \(n1 :<- n2) ->
328328
linkPoints
329329
shape
330330
(nodes Map.! n1)
@@ -779,7 +779,7 @@ leiosSimVizRenderModel
779779
where
780780
linksAndMsgs =
781781
[ (fromPos, toPos, msgs)
782-
| (fromNode, toNode) <- Map.keys vizNodeLinks
782+
| (fromNode :<- toNode) <- Map.keys vizNodeLinks
783783
, let (fromPos, toPos) =
784784
translateLineNormal
785785
displace
@@ -790,7 +790,7 @@ leiosSimVizRenderModel
790790
-- so they don't overlap each other, but for unidirectional
791791
-- links we can draw it centrally.
792792
displace
793-
| Map.notMember (toNode, fromNode) vizNodeLinks = 0
793+
| Map.notMember (toNode :<- fromNode) vizNodeLinks = 0
794794
| otherwise = -10
795795

796796
msgs =

‎simulation/src/LeiosProtocol/Short/VizSimP2P.hs‎

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -61,6 +61,7 @@ import LeiosProtocol.Short.VizSim (
6161
import Linear.V2
6262
import ModelTCP (Bytes, TcpMsgForecast (..))
6363
import Network.TypedProtocol
64+
import P2P
6465
import PraosProtocol.BlockFetch (Message (..))
6566
import PraosProtocol.ExamplesPraosP2P ()
6667
import PraosProtocol.PraosNode (PraosMessage (..))
@@ -272,7 +273,7 @@ leiosP2PSimVizRenderModel
272273
Cairo.setSourceRGB r g b
273274
Cairo.setLineWidth 1
274275
Cairo.setDash [10, 5] 0
275-
case vizNodeLinks Map.! (fromNode, toNode) of
276+
case vizNodeLinks !!! (fromNode, toNode) of
276277
LinkPointsNoWrap fromPos toPos -> do
277278
withPoint Cairo.moveTo (toScreenPoint fromPos)
278279
withPoint Cairo.lineTo (toScreenPoint toPos)
@@ -293,7 +294,7 @@ leiosP2PSimVizRenderModel
293294
Cairo.setSourceRGB r g b
294295
Cairo.setDash [] 0
295296
Cairo.setLineWidth 2
296-
case vizNodeLinks Map.! (fromNode, toNode) of
297+
case vizNodeLinks !!! (fromNode, toNode) of
297298
LinkPointsNoWrap fromPos toPos -> do
298299
withPoint Cairo.moveTo (toScreenPoint fromPos)
299300
withPoint Cairo.lineTo (toScreenPoint toPos)
@@ -310,7 +311,7 @@ leiosP2PSimVizRenderModel
310311
Cairo.restore
311312
-- draw the messages in flight on top
312313
sequence_
313-
[ case vizNodeLinks Map.! (fromNode, toNode) of
314+
[ case vizNodeLinks !!! (fromNode, toNode) of
314315
LinkPointsNoWrap fromPos toPos -> do
315316
let (msgTrailingEdge, _msgLeadingEdge) =
316317
lineMessageInFlight now fromPos toPos msgforecast

‎simulation/src/LeiosProtocol/SimTestRelay.hs‎

Lines changed: 7 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -35,6 +35,7 @@ import qualified Data.Set as Set
3535
import LeiosProtocol.Relay
3636
import LeiosProtocol.RelayBuffer (RelayBuffer)
3737
import qualified LeiosProtocol.RelayBuffer as RB
38+
import P2P
3839
import STMCompat
3940
import SimTCPLinks (labelDirToLabelLink, selectTimedEvents, simTracer)
4041
import SimTypes
@@ -54,7 +55,7 @@ data RelaySimEvent
5455
RelaySimEventSetup
5556
!World
5657
!(Map NodeId Point) -- nodes and locations
57-
!(Set (NodeId, NodeId)) -- links between nodes
58+
!(Set Link) -- links between nodes
5859
| -- | An event at a node
5960
RelaySimEventNode (LabelNode (RelayNodeEvent TestBlock))
6061
| -- | An event on a tcp link between two nodes
@@ -248,8 +249,8 @@ relayNode
248249
testHeader :: TestBlock -> TestBlockHeader
249250
testHeader blk = TestBlockHeader (testBlockId blk) (testBlockExpiry blk)
250251

251-
symmetric :: Ord a => Set (a, a) -> Set (a, a)
252-
symmetric xys = xys <> Set.map (\(x, y) -> (y, x)) xys
252+
symmetric :: Ord a => Set (Link' a) -> Set (Link' a)
253+
symmetric xys = xys <> Set.map (\(x :<- y) -> (y :<- x)) xys
253254

254255
newtype TestRelayBundle f = TestRelayBundle
255256
{ testMsg :: f TestBlockRelayMessage
@@ -287,7 +288,7 @@ traceRelayLink1 tcpprops generationPattern =
287288
]
288289
)
289290
( Set.fromList
290-
[(NodeId 0, NodeId 1), (NodeId 1, NodeId 0)]
291+
[(NodeId 0 :<- NodeId 1), (NodeId 1 :<- NodeId 0)]
291292
)
292293
(inChan, outChan) <- newConnectionTCP (linkTracer na nb) tcpprops
293294
concurrently_
@@ -335,7 +336,7 @@ traceRelayLink4 tcpprops generationPattern =
335336
]
336337
)
337338
( symmetric $
338-
Set.fromList
339+
Set.fromList . map (uncurry (:<-)) $
339340
[ (NodeId 0, NodeId 1)
340341
, (NodeId 1, NodeId 3)
341342
, (NodeId 0, NodeId 2)
@@ -397,7 +398,7 @@ traceRelayLink4Asymmetric tcppropsShort tcppropsLong generationPattern =
397398
]
398399
)
399400
( symmetric $
400-
Set.fromList
401+
Set.fromList . map (uncurry (:<-)) $
401402
[ (NodeId 0, NodeId 1)
402403
, (NodeId 1, NodeId 3)
403404
, (NodeId 0, NodeId 2)

‎simulation/src/LeiosProtocol/VizSimTestRelay.hs‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ import LeiosProtocol.Relay (Message (MsgRespondBodies), relayMessageLabel)
1717
import LeiosProtocol.SimTestRelay
1818
import ModelTCP
1919
import Network.TypedProtocol (SomeMessage (..))
20-
import P2P (linkPathLatenciesSquared)
20+
import P2P (Link, linkPathLatenciesSquared, pattern (:<-))
2121
import SimTypes
2222
import System.Random (mkStdGen)
2323
import System.Random.Stateful (uniform)
@@ -124,7 +124,7 @@ type RelaySimVizModel =
124124
data RelaySimVizState = RelaySimVizState
125125
{ vizWorld :: !World
126126
, vizNodePos :: !(Map NodeId Point)
127-
, vizNodeLinks :: !(Map (NodeId, NodeId) LinkPoints)
127+
, vizNodeLinks :: !(Map Link LinkPoints)
128128
, vizMsgsInTransit ::
129129
!( Map
130130
(NodeId, NodeId)
@@ -201,7 +201,7 @@ relaySimVizModel =
201201
, vizNodePos = nodes
202202
, vizNodeLinks =
203203
Map.fromSet
204-
( \(n1, n2) ->
204+
( \(n1 :<- n2) ->
205205
linkPoints
206206
shape
207207
(nodes Map.! n1)
@@ -521,7 +521,7 @@ relaySimVizRenderModel
521521
where
522522
linksAndMsgs =
523523
[ (fromPos, toPos, msgs)
524-
| (fromNode, toNode) <- Map.keys vizNodeLinks
524+
| (fromNode :<- toNode) <- Map.keys vizNodeLinks
525525
, let (fromPos, toPos) =
526526
translateLineNormal
527527
displace
@@ -532,7 +532,7 @@ relaySimVizRenderModel
532532
-- so they don't overlap each other, but for unidirectional
533533
-- links we can draw it centrally.
534534
displace
535-
| Map.notMember (toNode, fromNode) vizNodeLinks = 0
535+
| Map.notMember (toNode :<- fromNode) vizNodeLinks = 0
536536
| otherwise = -10
537537

538538
msgs =

0 commit comments

Comments
 (0)