diff --git a/simulation/src/LeiosProtocol/Short/VizSim.hs b/simulation/src/LeiosProtocol/Short/VizSim.hs index 1efc1fa7..a585ad5f 100644 --- a/simulation/src/LeiosProtocol/Short/VizSim.hs +++ b/simulation/src/LeiosProtocol/Short/VizSim.hs @@ -119,6 +119,9 @@ data LeiosSimVizState , -- these are `Block`s generated (globally). vizNumMsgsGenerated :: !Int , vizMsgsDiffusionLatency :: !DiffusionLatencyMap + , ibDiffusionLatency :: !(DiffusionLatencyMap' InputBlockId InputBlockHeader) + , ebDiffusionLatency :: !(DiffusionLatencyMap' EndorseBlockId EndorseBlock) + , voteDiffusionLatency :: !(DiffusionLatencyMap' VoteId VoteMsg) , ibMsgs :: !(LeiosSimVizMsgsState InputBlockId InputBlock) , ebMsgs :: !(LeiosSimVizMsgsState EndorseBlockId EndorseBlock) , voteMsgs :: !(LeiosSimVizMsgsState VoteId VoteMsg) @@ -177,26 +180,42 @@ accumChains :: Time -> LeiosEvent -> ChainsMap -> ChainsMap accumChains _ (LeiosEventNode (LabelNode nid (PraosNodeEvent (PraosNodeEventNewTip ch)))) = IMap.insert (coerce nid) ch accumChains _ _ = id -type DiffusionLatencyMap = Map (HeaderHash RankingBlockHeader) (RankingBlockHeader, NodeId, Time, [Time]) +type DiffusionLatencyMap = DiffusionLatencyMap' (HeaderHash RankingBlockHeader) RankingBlockHeader +type DiffusionLatencyMap' id msg = Map id (msg, NodeId, Time, [Time]) accumDiffusionLatency :: Time -> LeiosEvent -> DiffusionLatencyMap -> DiffusionLatencyMap -accumDiffusionLatency now (LeiosEventNode (LabelNode n (PraosNodeEvent e))) = accumDiffusionLatency' now (LabelNode n e) +accumDiffusionLatency now (LeiosEventNode (LabelNode n (PraosNodeEvent e))) = + case e of + PraosNodeEventGenerate blk -> accumDiffusionLatency' now n Generate (blockHash blk) (blockHeader blk) + PraosNodeEventReceived blk -> accumDiffusionLatency' now n Received (blockHash blk) (blockHeader blk) + PraosNodeEventEnterState blk -> accumDiffusionLatency' now n EnterState (blockHash blk) (blockHeader blk) + PraosNodeEventCPU{} -> id + PraosNodeEventNewTip{} -> id accumDiffusionLatency _ _ = id -accumDiffusionLatency' :: Time -> LabelNode (PraosNodeEvent RankingBlockBody) -> DiffusionLatencyMap -> DiffusionLatencyMap -accumDiffusionLatency' now (LabelNode nid (PraosNodeEventGenerate blk)) vs = - assert (not (blockHash blk `Map.member` vs)) $ + +accumDiffusionLatency' :: + Ord id => + Time -> + NodeId -> + BlockEvent -> + id -> + msg -> + DiffusionLatencyMap' id msg -> + DiffusionLatencyMap' id msg +accumDiffusionLatency' now nid Generate msgid msg vs = + assert (not (msgid `Map.member` vs)) $ Map.insert - (blockHash blk) - (blockHeader blk, nid, now, [now]) + msgid + (msg, nid, now, [now]) vs -accumDiffusionLatency' now (LabelNode _nid (PraosNodeEventEnterState blk)) vs = +accumDiffusionLatency' now _nid EnterState msgid _msg vs = Map.adjust ( \(hdr, nid', created, arrivals) -> (hdr, nid', created, now : arrivals) ) - (blockHash blk) + msgid vs -accumDiffusionLatency' _ _ vs = vs +accumDiffusionLatency' _now _nid _event _id _msg vs = vs -- | Make the vizualisation model for the relay simulation from a simulation -- trace. @@ -224,6 +243,9 @@ leiosSimVizModel = , vizMsgsAtNodeTotalBuffer = Map.empty , vizNumMsgsGenerated = 0 , vizMsgsDiffusionLatency = Map.empty + , ibDiffusionLatency = Map.empty + , ebDiffusionLatency = Map.empty + , voteDiffusionLatency = Map.empty , ibMsgs = initMsgs , ebMsgs = initMsgs , voteMsgs = initMsgs @@ -253,15 +275,24 @@ leiosSimVizModel = vs{vizNodeTip = Map.insert nid (fullTip tip) (vizNodeTip vs)} accumEventVizState now (LeiosEventNode (LabelNode nid (LeiosNodeEvent event blk))) vs = case blk of - EventIB x -> vs{ibMsgs = accumLeiosMsgs now nid event x vs.ibMsgs} + EventIB x -> + vs + { ibMsgs = accumLeiosMsgs now nid event x vs.ibMsgs + , ibDiffusionLatency = accumDiffusionLatency' now nid event x.id x.header vs.ibDiffusionLatency + } EventEB x -> vs { ebMsgs = accumLeiosMsgs now nid event x vs.ebMsgs , ibsInRBs = case event of Generate -> accumIBsInRBs (Right x) vs.ibsInRBs _ -> vs.ibsInRBs + , ebDiffusionLatency = accumDiffusionLatency' now nid event x.id x vs.ebDiffusionLatency + } + EventVote x -> + vs + { voteMsgs = accumLeiosMsgs now nid event x vs.voteMsgs + , voteDiffusionLatency = accumDiffusionLatency' now nid event x.id x vs.voteDiffusionLatency } - EventVote x -> vs{voteMsgs = accumLeiosMsgs now nid event x vs.voteMsgs} accumEventVizState now (LeiosEventNode (LabelNode nid (PraosNodeEvent (PraosNodeEventGenerate blk)))) vs = vs { vizMsgsAtNodeBuffer = @@ -364,6 +395,12 @@ leiosSimVizModel = Map.map (recentPrune secondsAgo30) (vizMsgsAtNodeRecentBuffer vs) , vizMsgsDiffusionLatency = Map.filter (\(_, _, t, _) -> t >= secondsAgo30) (vizMsgsDiffusionLatency vs) + , ibDiffusionLatency = + Map.filter (\(_, _, t, _) -> t >= secondsAgo30) (ibDiffusionLatency vs) + , ebDiffusionLatency = + Map.filter (\(_, _, t, _) -> t >= secondsAgo30) (ebDiffusionLatency vs) + , voteDiffusionLatency = + Map.filter (\(_, _, t, _) -> t >= secondsAgo30) (voteDiffusionLatency vs) , ibMsgs = pruneLeiosMsgsState now vs.ibMsgs , ebMsgs = pruneLeiosMsgsState now vs.ebMsgs , voteMsgs = pruneLeiosMsgsState now vs.voteMsgs diff --git a/simulation/src/LeiosProtocol/Short/VizSimP2P.hs b/simulation/src/LeiosProtocol/Short/VizSimP2P.hs index c357ddc0..26863b14 100644 --- a/simulation/src/LeiosProtocol/Short/VizSimP2P.hs +++ b/simulation/src/LeiosProtocol/Short/VizSimP2P.hs @@ -24,7 +24,8 @@ import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.Rendering.Chart.Easy as Chart import ChanDriver -import Data.Bifunctor (Bifunctor (bimap), second) +import Control.Arrow ((&&&)) +import Data.Bifunctor (second) import Data.Hashable (hash) import Data.List (foldl', intercalate, sortOn) import Data.Monoid @@ -103,10 +104,14 @@ messageLegend = -- The vizualisation rendering -- data MsgTag = RB | IB | EB | VT + deriving (Show, Enum, Bounded) data LeiosP2PSimVizConfig = LeiosP2PSimVizConfig { nodeMessageColor :: BlockHeader -> (Double, Double, Double) + , ibColor :: InputBlockHeader -> (Double, Double, Double) + , ebColor :: EndorseBlock -> (Double, Double, Double) + , voteColor :: VoteMsg -> (Double, Double, Double) , ptclMessageColor :: LeiosMessage -> Maybe (MsgTag, Dia.Colour Double) } @@ -363,48 +368,54 @@ diffusionLatencyPerStakeFraction nnodes created arrivals = chartDiffusionLatency :: LeiosP2PSimVizConfig -> + MsgTag -> VizRender LeiosSimVizModel -chartDiffusionLatency LeiosP2PSimVizConfig{nodeMessageColor} = +chartDiffusionLatency cfg@LeiosP2PSimVizConfig{nodeMessageColor} tag = chartVizRender 25 $ \_ _ ( SimVizModel _ - LeiosSimVizState + st@LeiosSimVizState { vizNodePos - , vizMsgsDiffusionLatency - } - ) -> - (Chart.def :: Chart.Layout DiffTime Chart.Percent) - { Chart._layout_title = "Diffusion latency" - , Chart._layout_title_style = Chart.def{Chart._font_size = 15} - , Chart._layout_y_axis = - (Chart.def :: Chart.LayoutAxis Chart.Percent) - { Chart._laxis_generate = - Chart.scaledAxis Chart.def{Chart._la_nLabels = 10} (0, 1) - , Chart._laxis_title = "Stake fraction reached" - } - , Chart._layout_x_axis = - Chart.def - { Chart._laxis_title = "Time (seconds)" - } - , Chart._layout_plots = - [ Chart.toPlot $ - Chart.def - { Chart._plot_lines_values = [timeseries] - , Chart._plot_lines_style = - let (r, g, b) = nodeMessageColor blk - in Chart.def - { Chart._line_color = Chart.opaque (Colour.sRGB r g b) - } - } - | let nnodes = Map.size vizNodePos - , (blk, _nid, created, arrivals) <- Map.elems vizMsgsDiffusionLatency - , let timeseries = - map (second Chart.Percent) $ - diffusionLatencyPerStakeFraction nnodes created arrivals - ] } + ) -> case tag of + RB -> theChart (show tag) vizNodePos nodeMessageColor st.vizMsgsDiffusionLatency + IB -> theChart (show tag) vizNodePos cfg.ibColor st.ibDiffusionLatency + EB -> theChart (show tag) vizNodePos cfg.ebColor st.ebDiffusionLatency + VT -> theChart (show tag) vizNodePos cfg.voteColor st.voteDiffusionLatency + where + theChart lbl nodePos nodeMsgColor msgsDiffusionLatency = + (Chart.def :: Chart.Layout DiffTime Chart.Percent) + { Chart._layout_title = "Diffusion latency" ++ "(" ++ lbl ++ ")" + , Chart._layout_title_style = Chart.def{Chart._font_size = 15} + , Chart._layout_y_axis = + (Chart.def :: Chart.LayoutAxis Chart.Percent) + { Chart._laxis_generate = + Chart.scaledAxis Chart.def{Chart._la_nLabels = 10} (0, 1) + , Chart._laxis_title = "Stake fraction reached" + } + , Chart._layout_x_axis = + Chart.def + { Chart._laxis_title = "Time (seconds)" + } + , Chart._layout_plots = + [ Chart.toPlot $ + Chart.def + { Chart._plot_lines_values = [timeseries] + , Chart._plot_lines_style = + let (r, g, b) = nodeMsgColor blk + in Chart.def + { Chart._line_color = Chart.opaque (Colour.sRGB r g b) + } + } + | let nnodes = Map.size nodePos + , (blk, _nid, created, arrivals) <- Map.elems msgsDiffusionLatency + , let timeseries = + map (second Chart.Percent) $ + diffusionLatencyPerStakeFraction nnodes created arrivals + ] + } chartDiffusionImperfection :: P2PTopography -> @@ -621,6 +632,9 @@ defaultVizConfig stageLength = LeiosP2PSimVizConfig { nodeMessageColor = testNodeMessageColor , ptclMessageColor = testPtclMessageColor + , voteColor = toSRGB . voteColor + , ebColor = toSRGB . ebColor + , ibColor = toSRGB . pipelineColor Propose . (hash . (.id) &&& (.slot)) } where testPtclMessageColor :: @@ -634,12 +648,15 @@ defaultVizConfig stageLength = let (r, g, b) = praosMessageColor examplesLeiosSimVizConfig msg Just $ Dia.sRGB r g b _ -> Nothing - RelayIB msg -> (IB,) <$> relayMessageColor (pipelineColor Propose . bimap hash (.slot)) msg - RelayEB msg -> (EB,) <$> relayMessageColor (pipelineColor Endorse . bimap hash (.slot)) msg - RelayVote msg -> (VT,) <$> relayMessageColor (pipelineColor Vote . bimap hash (.slot)) msg - relayMessageColor :: ((id, body) -> Dia.Colour Double) -> RelayMessage id header body -> Maybe (Dia.Colour Double) + RelayIB msg -> (IB,) <$> relayMessageColor ibColor msg + RelayEB msg -> (EB,) <$> relayMessageColor ebColor msg + RelayVote msg -> (VT,) <$> relayMessageColor voteColor msg + ibColor = pipelineColor Propose . (hash . (.id) &&& (.slot)) + ebColor = pipelineColor Endorse . (hash . (.id) &&& (.slot)) + voteColor = pipelineColor Vote . (hash . (.id) &&& (.slot)) + relayMessageColor :: (body -> Dia.Colour Double) -> RelayMessage id header body -> Maybe (Dia.Colour Double) relayMessageColor f (ProtocolMessage (SomeMessage msg)) = case msg of - MsgRespondBodies bodies -> Just $ blendColors $ map f bodies + MsgRespondBodies bodies -> Just $ blendColors $ map (f . snd) bodies _otherwise -> Nothing testNodeMessageColor :: BlockHeader -> (Double, Double, Double) testNodeMessageColor = blockHeaderColorAsBody @@ -690,16 +707,17 @@ example2 = leiosP2PSimVizRender config , LayoutBeside [ LayoutAbove - [ LayoutReqSize 350 300 $ - Layout $ - chartDiffusionLatency config - -- , LayoutReqSize 350 300 $ - -- Layout $ - -- chartDiffusionImperfection - -- p2pTopography - -- 0.1 - -- (96 / 1000) - -- config + [ LayoutReqSize 350 250 $ + Layout $ + chartDiffusionLatency config tag + | -- , LayoutReqSize 350 300 $ + -- Layout $ + -- chartDiffusionImperfection + -- p2pTopography + -- 0.1 + -- (96 / 1000) + -- config + tag <- [minBound .. maxBound] ] , LayoutAbove [ LayoutReqSize 350 300 $