{-# 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 :: GovernorMockEnvironment -> String
gourceVisualisationScript =
    [GourceEntry] -> String
renderGourceScript
  ([GourceEntry] -> String)
-> (GovernorMockEnvironment -> [GourceEntry])
-> GovernorMockEnvironment
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map PeerAddr (PeerSource, [PeerAddr])
-> [(Time, TracePeerSelection () () () PeerAddr)] -> [GourceEntry]
toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
forall k a. Map k a
Map.empty
  ([(Time, TracePeerSelection () () () PeerAddr)] -> [GourceEntry])
-> (GovernorMockEnvironment
    -> [(Time, TracePeerSelection () () () PeerAddr)])
-> GovernorMockEnvironment
-> [GourceEntry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GovernorMockEnvironment
-> [(Time, TracePeerSelection () () () PeerAddr)]
visualisationTrace

visualisationTrace :: GovernorMockEnvironment
                   -> [(Time, TracePeerSelection () () () PeerAddr)]
visualisationTrace :: GovernorMockEnvironment
-> [(Time, TracePeerSelection () () () PeerAddr)]
visualisationTrace =
    DiffTime
-> [(Time, TracePeerSelection () () () PeerAddr)]
-> [(Time, TracePeerSelection () () () PeerAddr)]
forall a. DiffTime -> [(Time, a)] -> [(Time, a)]
takeFirstNHours DiffTime
24
  ([(Time, TracePeerSelection () () () PeerAddr)]
 -> [(Time, TracePeerSelection () () () PeerAddr)])
-> (GovernorMockEnvironment
    -> [(Time, TracePeerSelection () () () PeerAddr)])
-> GovernorMockEnvironment
-> [(Time, TracePeerSelection () () () PeerAddr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Time, TestTraceEvent () () () ())]
-> [(Time, TracePeerSelection () () () PeerAddr)]
forall extraState extraFlags extraPeers extraCounters.
[(Time,
  TestTraceEvent extraState extraFlags extraPeers extraCounters)]
-> [(Time,
     TracePeerSelection extraState extraFlags extraPeers PeerAddr)]
selectGovernorEvents
  ([(Time, TestTraceEvent () () () ())]
 -> [(Time, TracePeerSelection () () () PeerAddr)])
-> (GovernorMockEnvironment
    -> [(Time, TestTraceEvent () () () ())])
-> GovernorMockEnvironment
-> [(Time, TracePeerSelection () () () PeerAddr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall extraState extraFlags extraPeers extraCounters a.
(Typeable extraState, Typeable extraFlags, Typeable extraPeers,
 Typeable extraCounters) =>
SimTrace a
-> [(Time,
     TestTraceEvent extraState extraFlags extraPeers extraCounters)]
selectPeerSelectionTraceEvents @() @() @() @()
  (SimTrace Void -> [(Time, TestTraceEvent () () () ())])
-> (GovernorMockEnvironment -> SimTrace Void)
-> GovernorMockEnvironment
-> [(Time, TestTraceEvent () () () ())]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GovernorMockEnvironment -> SimTrace Void
runGovernorInMockEnvironment

toGourceScript :: Map PeerAddr (PeerSource, [PeerAddr])
               -> [(Time, TracePeerSelection () () () PeerAddr)]
               -> [GourceEntry]
toGourceScript :: Map PeerAddr (PeerSource, [PeerAddr])
-> [(Time, TracePeerSelection () () () PeerAddr)] -> [GourceEntry]
toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers ((Time
ts, TraceLocalRootPeersChanged LocalRootPeers () PeerAddr
_ LocalRootPeers () PeerAddr
new):[(Time, TracePeerSelection () () () PeerAddr)]
trace) =
    -- link new root peers directly to the root as cold
    [ GourceEntry {
        timestamp :: Time
timestamp = Time
ts,
        path :: [PeerAddr]
path      = PeerAddr
peeraddr PeerAddr -> [PeerAddr] -> [PeerAddr]
forall a. a -> [a] -> [a]
: [],
        modtype :: NodeModification
modtype   = NodeModification
NodeAdded,
        username :: String
username  = String
"local root"
      }
    | PeerAddr
peeraddr <- Set PeerAddr -> [PeerAddr]
forall a. Set a -> [a]
Set.toList (LocalRootPeers () PeerAddr -> Set PeerAddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers () PeerAddr
new) ]
 [GourceEntry] -> [GourceEntry] -> [GourceEntry]
forall a. [a] -> [a] -> [a]
++ Map PeerAddr (PeerSource, [PeerAddr])
-> [(Time, TracePeerSelection () () () PeerAddr)] -> [GourceEntry]
toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers' [(Time, TracePeerSelection () () () PeerAddr)]
trace
  where
    peers' :: Map PeerAddr (PeerSource, [PeerAddr])
peers' = [(PeerAddr, (PeerSource, [PeerAddr]))]
-> Map PeerAddr (PeerSource, [PeerAddr])
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
               [ (PeerAddr
peeraddr, (PeerSource
PeerSourceLocalRoot, []))
               | PeerAddr
peeraddr <- Set PeerAddr -> [PeerAddr]
forall a. Set a -> [a]
Set.toList (LocalRootPeers () PeerAddr -> Set PeerAddr
forall extraFlags peeraddr.
LocalRootPeers extraFlags peeraddr -> Set peeraddr
LocalRootPeers.keysSet LocalRootPeers () PeerAddr
new) ]
          Map PeerAddr (PeerSource, [PeerAddr])
-> Map PeerAddr (PeerSource, [PeerAddr])
-> Map PeerAddr (PeerSource, [PeerAddr])
forall a. Semigroup a => a -> a -> a
<> Map PeerAddr (PeerSource, [PeerAddr])
peers

toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers ((Time
ts, TracePublicRootsRequest Int
_ Int
_):[(Time, TracePeerSelection () () () PeerAddr)]
trace) =
    GourceEntry {
      timestamp :: Time
timestamp = Time
ts,
      path :: [PeerAddr]
path      = [],
      modtype :: NodeModification
modtype   = NodeModification
NodeModified,
      username :: String
username  = String
"public roots request"
    }
  GourceEntry -> [GourceEntry] -> [GourceEntry]
forall a. a -> [a] -> [a]
: Map PeerAddr (PeerSource, [PeerAddr])
-> [(Time, TracePeerSelection () () () PeerAddr)] -> [GourceEntry]
toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers [(Time, TracePeerSelection () () () PeerAddr)]
trace

toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers ((Time
ts, TracePublicRootsResults PublicRootPeers () PeerAddr
new Int
_ DiffTime
_):[(Time, TracePeerSelection () () () PeerAddr)]
trace) =
    -- link new root peers directly to the root as cold
    [ GourceEntry {
        timestamp :: Time
timestamp = Time
ts,
        path :: [PeerAddr]
path      = PeerAddr
peeraddr PeerAddr -> [PeerAddr] -> [PeerAddr]
forall a. a -> [a] -> [a]
: [],
        modtype :: NodeModification
modtype   = NodeModification
NodeAdded,
        username :: String
username  = String
"public root"
      }
    | PeerAddr
peeraddr <- Set PeerAddr -> [PeerAddr]
forall a. Set a -> [a]
Set.elems ((() -> Set PeerAddr) -> PublicRootPeers () PeerAddr -> Set PeerAddr
forall peeraddr extraPeers.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.toSet (\()
_ -> Set PeerAddr
forall a. Set a
Set.empty) PublicRootPeers () PeerAddr
new)
    , PeerAddr
peeraddr PeerAddr -> Map PeerAddr (PeerSource, [PeerAddr]) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map PeerAddr (PeerSource, [PeerAddr])
peers
    ]
 [GourceEntry] -> [GourceEntry] -> [GourceEntry]
forall a. [a] -> [a] -> [a]
++ Map PeerAddr (PeerSource, [PeerAddr])
-> [(Time, TracePeerSelection () () () PeerAddr)] -> [GourceEntry]
toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers' [(Time, TracePeerSelection () () () PeerAddr)]
trace
  where
    peers' :: Map PeerAddr (PeerSource, [PeerAddr])
peers' = [(PeerAddr, (PeerSource, [PeerAddr]))]
-> Map PeerAddr (PeerSource, [PeerAddr])
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
               [ (PeerAddr
peeraddr, (PeerSource
PeerSourcePublicRoot, []))
               | PeerAddr
peeraddr <- Set PeerAddr -> [PeerAddr]
forall a. Set a -> [a]
Set.elems ((() -> Set PeerAddr) -> PublicRootPeers () PeerAddr -> Set PeerAddr
forall peeraddr extraPeers.
Ord peeraddr =>
(extraPeers -> Set peeraddr)
-> PublicRootPeers extraPeers peeraddr -> Set peeraddr
PublicRootPeers.toSet (\()
_ -> Set PeerAddr
forall a. Set a
Set.empty) PublicRootPeers () PeerAddr
new)
               , PeerAddr
peeraddr PeerAddr -> Map PeerAddr (PeerSource, [PeerAddr]) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map PeerAddr (PeerSource, [PeerAddr])
peers
               ]
          Map PeerAddr (PeerSource, [PeerAddr])
-> Map PeerAddr (PeerSource, [PeerAddr])
-> Map PeerAddr (PeerSource, [PeerAddr])
forall a. Semigroup a => a -> a -> a
<> Map PeerAddr (PeerSource, [PeerAddr])
peers

toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers ((Time
ts, TracePeerShareRequests Int
_ Int
_ PeerSharingAmount
_ Set PeerAddr
_ Set PeerAddr
selected):[(Time, TracePeerSelection () () () PeerAddr)]
trace) =
    [ GourceEntry {
        timestamp :: Time
timestamp = Time
ts,
        path :: [PeerAddr]
path      = [PeerAddr]
discoverypath,
        modtype :: NodeModification
modtype   = NodeModification
NodeModified,
        username :: String
username  = String
"peer-sharing"
      }
    | PeerAddr
peeraddr <- Set PeerAddr -> [PeerAddr]
forall a. Set a -> [a]
Set.elems Set PeerAddr
selected
    , let Just (PeerSource
_, [PeerAddr]
discoverypath) = PeerAddr
-> Map PeerAddr (PeerSource, [PeerAddr])
-> Maybe (PeerSource, [PeerAddr])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PeerAddr
peeraddr Map PeerAddr (PeerSource, [PeerAddr])
peers ]
 [GourceEntry] -> [GourceEntry] -> [GourceEntry]
forall a. [a] -> [a] -> [a]
++ Map PeerAddr (PeerSource, [PeerAddr])
-> [(Time, TracePeerSelection () () () PeerAddr)] -> [GourceEntry]
toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers [(Time, TracePeerSelection () () () PeerAddr)]
trace

toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers ((Time
ts, TracePeerShareResults [(PeerAddr, Either SomeException (PeerSharingResult PeerAddr))]
results):[(Time, TracePeerSelection () () () PeerAddr)]
trace) =
    [ GourceEntry {
        timestamp :: Time
timestamp = Time
ts,
        path :: [PeerAddr]
path      = PeerAddr
dstaddr PeerAddr -> [PeerAddr] -> [PeerAddr]
forall a. a -> [a] -> [a]
: (PeerSource, [PeerAddr]) -> [PeerAddr]
forall a b. (a, b) -> b
snd (Map PeerAddr (PeerSource, [PeerAddr])
peers Map PeerAddr (PeerSource, [PeerAddr])
-> PeerAddr -> (PeerSource, [PeerAddr])
forall k a. Ord k => Map k a -> k -> a
Map.! PeerAddr
srcaddr),
        modtype :: NodeModification
modtype   = NodeModification
NodeAdded,
        username :: String
username  = String
"discovered"
      }
    | (PeerAddr
srcaddr, Right (PeerSharingResult [PeerAddr]
dstaddrs)) <- [(PeerAddr, Either SomeException (PeerSharingResult PeerAddr))]
results
    , PeerAddr
dstaddr <- [PeerAddr]
dstaddrs
    , PeerAddr
dstaddr PeerAddr -> Map PeerAddr (PeerSource, [PeerAddr]) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map PeerAddr (PeerSource, [PeerAddr])
peers
    ]
 [GourceEntry] -> [GourceEntry] -> [GourceEntry]
forall a. [a] -> [a] -> [a]
++ Map PeerAddr (PeerSource, [PeerAddr])
-> [(Time, TracePeerSelection () () () PeerAddr)] -> [GourceEntry]
toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers' [(Time, TracePeerSelection () () () PeerAddr)]
trace
  where
    peers' :: Map PeerAddr (PeerSource, [PeerAddr])
peers' = [(PeerAddr, (PeerSource, [PeerAddr]))]
-> Map PeerAddr (PeerSource, [PeerAddr])
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
               [ (PeerAddr
dstaddr, (PeerSource
PeerSourcePeerShare, PeerAddr
dstaddr PeerAddr -> [PeerAddr] -> [PeerAddr]
forall a. a -> [a] -> [a]
: [PeerAddr]
discoverypath))
               | (PeerAddr
srcaddr, Right (PeerSharingResult [PeerAddr]
dstaddrs)) <- [(PeerAddr, Either SomeException (PeerSharingResult PeerAddr))]
results
               , PeerAddr
dstaddr <- [PeerAddr]
dstaddrs
               , PeerAddr
dstaddr PeerAddr -> Map PeerAddr (PeerSource, [PeerAddr]) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map PeerAddr (PeerSource, [PeerAddr])
peers
               , let Just (PeerSource
_, [PeerAddr]
discoverypath) = PeerAddr
-> Map PeerAddr (PeerSource, [PeerAddr])
-> Maybe (PeerSource, [PeerAddr])
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup PeerAddr
srcaddr Map PeerAddr (PeerSource, [PeerAddr])
peers ]
          Map PeerAddr (PeerSource, [PeerAddr])
-> Map PeerAddr (PeerSource, [PeerAddr])
-> Map PeerAddr (PeerSource, [PeerAddr])
forall a. Semigroup a => a -> a -> a
<> Map PeerAddr (PeerSource, [PeerAddr])
peers


toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers ((Time, TracePeerSelection () () () PeerAddr)
_:[(Time, TracePeerSelection () () () PeerAddr)]
trace) = Map PeerAddr (PeerSource, [PeerAddr])
-> [(Time, TracePeerSelection () () () PeerAddr)] -> [GourceEntry]
toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
peers [(Time, TracePeerSelection () () () PeerAddr)]
trace
toGourceScript Map PeerAddr (PeerSource, [PeerAddr])
_     []        = []

-- | 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 {
       GourceEntry -> Time
timestamp :: Time,
       GourceEntry -> [PeerAddr]
path      :: [PeerAddr],
       GourceEntry -> NodeModification
modtype   :: NodeModification,
       GourceEntry -> String
username  :: String
--       colour    :: Colour
     }

data NodeModification = NodeAdded | NodeModified | NodeDeleted

--data Colour = ColourLocalRoot
--            | ColourPublicRoot

renderGourceScript :: [GourceEntry] -> String
renderGourceScript :: [GourceEntry] -> String
renderGourceScript = [String] -> String
unlines ([String] -> String)
-> ([GourceEntry] -> [String]) -> [GourceEntry] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GourceEntry -> String) -> [GourceEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GourceEntry -> String
renderGourceEntry

renderGourceEntry :: GourceEntry -> String
renderGourceEntry :: GourceEntry -> String
renderGourceEntry GourceEntry {
                    Time
timestamp :: GourceEntry -> Time
timestamp :: Time
timestamp,
                    [PeerAddr]
path :: GourceEntry -> [PeerAddr]
path :: [PeerAddr]
path,
                    NodeModification
modtype :: GourceEntry -> NodeModification
modtype :: NodeModification
modtype,
                    String
username :: GourceEntry -> String
username :: String
username
--                  colour
                  } =
    String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"|"
      [ Time -> String
renderTime Time
timestamp
      , String
username
      , NodeModification -> String
renderModType NodeModification
modtype
      , String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"/" (String
"root" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [ Int -> String
forall a. Show a => a -> String
show Int
addr | PeerAddr Int
addr <- [PeerAddr] -> [PeerAddr]
forall a. [a] -> [a]
reverse [PeerAddr]
path ])
                 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".node"
--      , renderColour colour
      ]
  where
    renderTime :: Time -> String
    renderTime :: Time -> String
renderTime Time
t = Int -> String
forall a. Show a => a -> String
show (DiffTime -> Int
forall b. Integral b => DiffTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (Time -> Time -> DiffTime
diffTime Time
t (DiffTime -> Time
Time DiffTime
0)) :: Int)

    renderModType :: NodeModification -> String
renderModType NodeModification
NodeAdded    = String
"A"
    renderModType NodeModification
NodeModified = String
"M"
    renderModType NodeModification
NodeDeleted  = String
"D"

--    renderColour ColourLocalRoot  = "FFFFFF"
--    renderColour ColourPublicRoot = "FFFF00"