diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Test.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Test.hs index 8c246d08c01..0d7cba538e5 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Test.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Test.hs @@ -17,7 +17,7 @@ import Data.Typeable (Typeable) import Data.Dynamic (fromDynamic) import Data.Maybe (listToMaybe) import qualified Data.ByteString.Char8 as BS -import Data.List (nub, groupBy) +import Data.List (nub, groupBy, intercalate) import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.Map.Strict as Map @@ -1081,3 +1081,162 @@ _governorFindingPublicRoots targetNumberOfRootPeers domains = pickTrivially :: Applicative m => Map IPv4 a -> Int -> m (Set IPv4) pickTrivially m n = pure . Set.take n . Map.keysSet $ m + +-- +-- Visualisation of examples +-- + +-- | Graph visualisation tool, see +-- +-- It's not designed for general graphs, just file hierarchies, but it's got +-- a very convenient input format, so not much effort to visualise. +-- +_gourceVisualisationScript :: GovernorMockEnvironment -> String +_gourceVisualisationScript = + renderGourceScript + . toGourceScript Map.empty + . visualisationTrace + +visualisationTrace :: GovernorMockEnvironment + -> [(Time, TracePeerSelection PeerAddr)] +visualisationTrace = + takeFirstNHours 24 + . selectGovernorEvents + . selectPeerSelectionTraceEvents + . runGovernorInMockEnvironment + +toGourceScript :: Map PeerAddr (PeerSource, [PeerAddr]) + -> [(Time, TracePeerSelection PeerAddr)] + -> [GourceEntry] +toGourceScript peers ((ts, TraceLocalRootPeersChanged _ new):trace) = + -- link new root peers directly to the root as cold + [ GourceEntry { + timestamp = ts, + path = peeraddr : [], + modtype = NodeAdded, + username = "local root" + } + | peeraddr <- Map.keys new ] + ++ toGourceScript peers' trace + where + peers' = Map.fromList + [ (peeraddr, (PeerSourceLocalRoot, [])) + | peeraddr <- Map.keys new ] + <> peers + +toGourceScript peers ((ts, TracePublicRootsRequest _ _):trace) = + GourceEntry { + timestamp = ts, + path = [], + modtype = NodeModified, + username = "public roots request" + } + : toGourceScript peers trace + +toGourceScript peers ((ts, TracePublicRootsResults new _ _):trace) = + -- link new root peers directly to the root as cold + [ GourceEntry { + timestamp = ts, + path = peeraddr : [], + modtype = NodeAdded, + username = "public root" + } + | peeraddr <- Set.elems new + , peeraddr `Map.notMember` peers + ] + ++ toGourceScript peers' trace + where + peers' = Map.fromList + [ (peeraddr, (PeerSourcePublicRoot, [])) + | peeraddr <- Set.elems new + , peeraddr `Map.notMember` peers + ] + <> peers + +toGourceScript peers ((ts, TraceGossipRequests _ _ _ gossip):trace) = + [ GourceEntry { + timestamp = ts, + path = discoverypath, + modtype = NodeModified, + username = "gossip" + } + | peeraddr <- Set.elems gossip + , let Just (_, discoverypath) = Map.lookup peeraddr peers ] + ++ toGourceScript peers trace + +toGourceScript peers ((ts, TraceGossipResults results):trace) = + [ GourceEntry { + timestamp = ts, + path = dstaddr : snd (peers Map.! srcaddr), + modtype = NodeAdded, + username = "discovered" + } + | (srcaddr, Right dstaddrs) <- results + , dstaddr <- dstaddrs + , dstaddr `Map.notMember` peers + ] + ++ toGourceScript peers' trace + where + peers' = Map.fromList + [ (dstaddr, (PeerSourceGossip, dstaddr : discoverypath)) + | (srcaddr, Right dstaddrs) <- results + , dstaddr <- dstaddrs + , dstaddr `Map.notMember` peers + , let Just (_, discoverypath) = Map.lookup srcaddr peers ] + <> peers + + +toGourceScript peers (_:trace) = toGourceScript peers trace +toGourceScript _ [] = [] + +-- | See +-- +-- * timestamp - A unix timestamp of when the update occured. +-- * username - The name of the user who made the update. +-- * type - initial for the update type - (A)dded, (M)odified or (D)eleted. +-- * file - Path of the file updated. +-- * colour - A colour for the file in hex (FFFFFF) format. Optional. +-- +data GourceEntry = GourceEntry { + timestamp :: Time, + path :: [PeerAddr], + modtype :: NodeModification, + username :: String +-- colour :: Colour + } + +data NodeModification = NodeAdded | NodeModified | NodeDeleted + +--data Colour = ColourLocalRoot +-- | ColourPublicRoot + +renderGourceScript :: [GourceEntry] -> String +renderGourceScript = unlines . map renderGourceEntry + +renderGourceEntry :: GourceEntry -> String +renderGourceEntry GourceEntry { + timestamp, + path, + modtype, + username +-- colour + } = + intercalate "|" + [ renderTime timestamp + , username + , renderModType modtype + , intercalate "/" ("root" : [ show addr | PeerAddr addr <- reverse path ]) + ++ ".node" +-- , renderColour colour + ] + where + renderTime :: Time -> String + renderTime t = show (floor (diffTime t (Time 0)) :: Int) + + renderModType NodeAdded = "A" + renderModType NodeModified = "M" + renderModType NodeDeleted = "D" + +-- renderColour ColourLocalRoot = "FFFFFF" +-- renderColour ColourPublicRoot = "FFFF00" +