Add a function to export a Gource visualisation script

ouroboros-network/ouroboros-network.cabal

@@ -382,13 +382,15 @@ library testlib
     Test.Ouroboros.Network.PeerSelection.Cardano.LocalRootPeers
     Test.Ouroboros.Network.PeerSelection.Cardano.MockEnvironment
     Test.Ouroboros.Network.PeerSelection.Cardano.PublicRootPeers
+    Test.Ouroboros.Network.PeerSelection.Gource
     Test.Ouroboros.Network.PeerSelection.Instances
     Test.Ouroboros.Network.PeerSelection.Json
     Test.Ouroboros.Network.PeerSelection.KnownPeers
     Test.Ouroboros.Network.PeerSelection.LocalRootPeers
     Test.Ouroboros.Network.PeerSelection.PeerGraph
     Test.Ouroboros.Network.PeerSelection.PeerMetric
     Test.Ouroboros.Network.PeerSelection.RootPeersDNS
+    Test.Ouroboros.Network.PeerSelection.Utils
     Test.Ouroboros.Network.TxSubmission
     Test.Ouroboros.Network.Version
 

ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection.hs

@@ -23,12 +23,7 @@
 {-# OPTIONS_GHC -Wno-x-partial #-}
 #endif
 
-module Test.Ouroboros.Network.PeerSelection
-  ( tests
-  , unfHydra
-  , takeBigLedgerPeers
-  , dropBigLedgerPeers
-  ) where
+module Test.Ouroboros.Network.PeerSelection (tests) where
 
 import Control.Concurrent.Class.MonadSTM.Strict
 import Control.Exception (AssertionFailed (..), catch, evaluate)
@@ -92,6 +87,7 @@ import Test.Ouroboros.Network.PeerSelection.Cardano.MockEnvironment hiding
            (tests)
 import Test.Ouroboros.Network.PeerSelection.Instances
 import Test.Ouroboros.Network.PeerSelection.PeerGraph
+import Test.Ouroboros.Network.PeerSelection.Utils
 import Test.Ouroboros.Network.Utils (disjointSetsProperty, isSubsetProperty,
            nightlyTest)
 
@@ -114,10 +110,6 @@ import Test.Tasty
 import Test.Tasty.QuickCheck
 import Text.Pretty.Simple
 
--- Exactly as named.
-unfHydra :: Int
-unfHydra = 1
-
 tests :: TestTree
 tests =
   testGroup "Ouroboros.Network.PeerSelection"
@@ -3924,64 +3916,6 @@ prop_governor_association_mode env =
                <*> publicRoots
                <*> associationMode)
 
---
--- Utils for properties
---
-
-takeFirstNHours :: DiffTime -> [(Time, a)] -> [(Time, a)]
-takeFirstNHours h = takeWhile (\(t,_) -> t < Time (60*60*h))
-
-selectEnvEvents :: Events (TestTraceEvent extraState extraFlags extraPeers extraCounters) -> Events TraceMockEnv
-selectEnvEvents = Signal.selectEvents
-                    (\case MockEnvEvent e -> Just $! e
-                           _              -> Nothing)
-
-selectGovEvents :: Events (TestTraceEvent extraState extraFlags extraPeers extracounters)
-                -> Events (TracePeerSelection extraState extraFlags extraPeers PeerAddr)
-selectGovEvents = Signal.selectEvents
-                    (\case GovernorEvent e -> Just $! e
-                           _               -> Nothing)
-
-selectGovCounters :: Events (TestTraceEvent extraState extraFlags extraPeers extraCounters)
-                  -> Events (PeerSelectionCounters extraCounters)
-selectGovCounters = Signal.selectEvents
-                      (\case GovernorCounters e -> Just $! e
-                             _                  -> Nothing)
-
-selectGovAssociationMode :: Events (TestTraceEvent extraState extraFlags extraPeers extraCounters)
-                         -> Events AssociationMode
-selectGovAssociationMode = Signal.selectEvents
-                             (\case GovernorAssociationMode e -> Just $! e
-                                    _                         -> Nothing)
-
-selectGovState :: Eq a
-               => (forall peerconn. Governor.PeerSelectionState extraState extraFlags extraPeers PeerAddr peerconn -> a)
-               -> extraState
-               -> extraPeers
-               -> Events (TestTraceEvent extraState extraFlags extraPeers extraCounters)
-               -> Signal a
-selectGovState f es ep =
-    Signal.nub
-  -- TODO: #3182 Rng seed should come from quickcheck.
-  --       and `NumberOfBigLedgerPeers`
-  . Signal.fromChangeEvents (f $! Governor.emptyPeerSelectionState (mkStdGen 42) es ep)
-  . Signal.selectEvents
-      (\case GovernorDebug (TraceGovernorState _ _ st) -> Just $! f st
-             _                                         -> Nothing)
-
-selectEnvTargets :: Eq a
-                 => (PeerSelectionTargets -> a)
-                 -> Events (TestTraceEvent extraState extraFlags extraPeers extraCounters)
-                 -> Signal a
-selectEnvTargets f =
-    Signal.nub
-  . fmap f
-  . Signal.fromChangeEvents nullPeerSelectionTargets
-  . Signal.selectEvents
-      (\case TraceEnvSetTargets targets -> Just $! targets
-             _                          -> Nothing)
-  . selectEnvEvents
-
 --
 -- Live examples
 --
@@ -4351,7 +4285,6 @@ prop_governor_repromote_delay (MaxTime maxTime) env =
 -- Utils
 --
 
-
 -- | Max simulation time.  We start with 10hrs, and shrink it to smaller values
 -- if needed.
 --
@@ -4367,20 +4300,3 @@ instance Arbitrary MaxTime where
       [ MaxTime (Time (microsecondsAsIntToDiffTime t'))
       | t' <- shrink  (diffTimeToMicrosecondsAsInt t)
       ]
-
-
--- | filter big ledger peers
---
-takeBigLedgerPeers
-    :: (Governor.PeerSelectionState extraState extraFlags extraPeers PeerAddr peerconn -> Set PeerAddr)
-    ->  Governor.PeerSelectionState extraState extraFlags extraPeers PeerAddr peerconn -> Set PeerAddr
-takeBigLedgerPeers f =
-  \st -> f st `Set.intersection` (PublicRootPeers.getBigLedgerPeers . Governor.publicRootPeers) st
-
--- | filter out big ledger peers
---
-dropBigLedgerPeers
-    :: (Governor.PeerSelectionState extraState extraFlags extraPeers PeerAddr peerconn -> Set PeerAddr)
-    ->  Governor.PeerSelectionState extraState extraFlags extraPeers PeerAddr peerconn -> Set PeerAddr
-dropBigLedgerPeers f =
-  \st -> f st Set.\\ (PublicRootPeers.getBigLedgerPeers . Governor.publicRootPeers) st

ouroboros-network/testlib/Test/Ouroboros/Network/PeerSelection/Gource.hs

@@ -0,0 +1,180 @@
+{-# LANGUAGE NamedFieldPuns   #-}
+{-# LANGUAGE TypeApplications #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+
+module Test.Ouroboros.Network.PeerSelection.Gource (gourceVisualisationScript) where
+
+import Control.Monad.Class.MonadTime.SI
+import Data.List (intercalate)
+import Data.Map.Strict (Map)
+import Data.Map.Strict qualified as Map
+import Data.Set qualified as Set
+
+import Ouroboros.Network.PeerSelection.Governor.Types
+import Ouroboros.Network.PeerSelection.PublicRootPeers qualified as PublicRootPeers
+import Ouroboros.Network.PeerSelection.State.LocalRootPeers qualified as LocalRootPeers
+import Ouroboros.Network.PeerSelection.Types
+
+import Test.Ouroboros.Network.PeerSelection.Cardano.MockEnvironment
+import Test.Ouroboros.Network.PeerSelection.Instances
+import Test.Ouroboros.Network.PeerSelection.Utils
+
+--
+-- Visualisation of examples
+--
+
+-- | Graph visualisation tool, see <https://github.com/acaudwell/Gource/>
+--
+-- 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 <- Set.toList (LocalRootPeers.keysSet new) ]
+ ++ toGourceScript peers' trace
+  where
+    peers' = Map.fromList
+               [ (peeraddr, (PeerSourceLocalRoot, []))
+               | peeraddr <- Set.toList (LocalRootPeers.keysSet 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 (PublicRootPeers.toSet (\_ -> Set.empty) new)
+    , peeraddr `Map.notMember` peers
+    ]
+ ++ toGourceScript peers' trace
+  where
+    peers' = Map.fromList
+               [ (peeraddr, (PeerSourcePublicRoot, []))
+               | peeraddr <- Set.elems (PublicRootPeers.toSet (\_ -> Set.empty) new)
+               , peeraddr `Map.notMember` peers
+               ]
+          <> peers
+
+toGourceScript peers ((ts, TracePeerShareRequests _ _ _ _ selected):trace) =
+    [ GourceEntry {
+        timestamp = ts,
+        path      = discoverypath,
+        modtype   = NodeModified,
+        username  = "peer-sharing"
+      }
+    | peeraddr <- Set.elems selected
+    , let Just (_, discoverypath) = Map.lookup peeraddr peers ]
+ ++ toGourceScript peers trace
+
+toGourceScript peers ((ts, TracePeerShareResults results):trace) =
+    [ GourceEntry {
+        timestamp = ts,
+        path      = dstaddr : snd (peers Map.! srcaddr),
+        modtype   = NodeAdded,
+        username  = "discovered"
+      }
+    | (srcaddr, Right (PeerSharingResult dstaddrs)) <- results
+    , dstaddr <- dstaddrs
+    , dstaddr `Map.notMember` peers
+    ]
+ ++ toGourceScript peers' trace
+  where
+    peers' = Map.fromList
+               [ (dstaddr, (PeerSourcePeerShare, dstaddr : discoverypath))
+               | (srcaddr, Right (PeerSharingResult dstaddrs)) <- results
+               , dstaddr <- dstaddrs
+               , dstaddr `Map.notMember` peers
+               , let Just (_, discoverypath) = Map.lookup srcaddr peers ]
+          <> peers
+
+
+toGourceScript peers (_:trace) = toGourceScript peers trace
+toGourceScript _     []        = []
+
+-- | See <https://github.com/acaudwell/Gource/wiki/Custom-Log-Format>
+--
+-- * 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"
+