GDD: add separate trace event for disconnections (#1244)

It is desirable to have an explicit trace event for when the GDD decides
to disconnect from someone. The already existing "debug info" already
contained this information, but it should not be traced by default.

Author: amesgen

ouroboros-consensus-diffusion/changelog.d/20240912_105915_alexander.esgen_gdd_disconnect_trace.md

@@ -23,11 +23,12 @@ module Test.Consensus.PeerSimulator.Trace (
 import           Control.Tracer (Tracer (Tracer), contramap, traceWith)
 import           Data.Bifunctor (second)
 import           Data.List (intersperse)
+import qualified Data.List.NonEmpty as NE
 import           Data.Time.Clock (DiffTime, diffTimeToPicoseconds)
 import           Ouroboros.Consensus.Block (GenesisWindow (..), Header, Point,
                      WithOrigin (NotOrigin, Origin), succWithOrigin)
 import           Ouroboros.Consensus.Genesis.Governor (DensityBounds (..),
-                     TraceGDDEvent (..))
+                     GDDDebugInfo (..), TraceGDDEvent (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
                      (TraceChainSyncClientEvent (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping
@@ -490,7 +491,15 @@ showPeers = map (\ (peer, v) -> "        " ++ condense peer ++ ": " ++ v)
 -- * Other utilities
 terseGDDEvent :: TraceGDDEvent PeerId TestBlock -> String
 terseGDDEvent = \case
-  TraceGDDEvent {sgen = GenesisWindow sgen, curChain, bounds, candidates, candidateSuffixes, losingPeers, loeHead} ->
+  TraceGDDDisconnected peers -> "GDD | Disconnected " <> show (NE.toList peers)
+  TraceGDDDebug GDDDebugInfo {
+      sgen = GenesisWindow sgen
+    , curChain, bounds
+    , candidates
+    , candidateSuffixes
+    , losingPeers
+    , loeHead
+    } ->
     unlines $ [
       "GDD | Window: " ++ window sgen loeHead,
       "      Selection: " ++ terseHFragment curChain,

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Trace.hs

@@ -0,0 +1,5 @@
+### Breaking
+
+- Made `TraceGDDEvent` into a sum type, added a new terse constructor for when
+  we disconnect from peers (this is supposed to get a high severity in the
+  tracing system).

ouroboros-consensus/changelog.d/20240912_105038_alexander.esgen_gdd_disconnect_trace.md

@@ -25,6 +25,7 @@
 --
 module Ouroboros.Consensus.Genesis.Governor (
     DensityBounds (..)
+  , GDDDebugInfo (..)
   , GDDStateView (..)
   , TraceGDDEvent (..)
   , densityDisconnect
@@ -38,6 +39,8 @@ import           Data.Bifunctor (second)
 import           Data.Containers.ListUtils (nubOrd)
 import           Data.Foldable (for_, toList)
 import           Data.Functor.Compose (Compose (..))
+import           Data.List.NonEmpty (NonEmpty)
+import qualified Data.List.NonEmpty as NE
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (mapMaybe, maybeToList)
@@ -215,9 +218,12 @@ evaluateGDD cfg tracer stateView = do
           densityDisconnect sgen (configSecurityParam cfg) states candidateSuffixes loeFrag
         loeHead = AF.headAnchor loeFrag
 
-      traceWith tracer TraceGDDEvent {sgen, curChain, bounds, candidates, candidateSuffixes, losingPeers, loeHead}
+      traceWith tracer $ TraceGDDDebug
+        GDDDebugInfo {sgen, curChain, bounds, candidates, candidateSuffixes, losingPeers, loeHead}
 
-      for_ losingPeers $ \peer -> killActions Map.! peer
+      whenJust (NE.nonEmpty losingPeers) $ \losingPeersNE -> do
+        for_ losingPeersNE $ \peer -> killActions Map.! peer
+        traceWith tracer $ TraceGDDDisconnected losingPeersNE
 
     pure loeFrag
 
@@ -424,8 +430,8 @@ densityDisconnect (GenesisWindow sgen) (SecurityParam k) states candidateSuffixe
 -- after the intersection. If both chains agree on the next header after
 -- the intersection, we don't disconnect peer1 either.
 
-data TraceGDDEvent peer blk =
-  TraceGDDEvent {
+data GDDDebugInfo peer blk =
+  GDDDebugInfo {
     bounds            :: [(peer, DensityBounds blk)],
     curChain          :: AnchoredFragment (Header blk),
     candidates        :: [(peer, AnchoredFragment (Header blk))],
@@ -435,6 +441,16 @@ data TraceGDDEvent peer blk =
     sgen              :: GenesisWindow
   }
 
+deriving stock instance
+  ( GetHeader blk, Show (Header blk), Show peer
+  ) => Show (GDDDebugInfo peer blk)
+
+data TraceGDDEvent peer blk =
+    -- | The GDD disconnected from the given peers due to insufficient density.
+    TraceGDDDisconnected (NonEmpty peer)
+  |
+    TraceGDDDebug (GDDDebugInfo peer blk)
+
 deriving stock instance
   ( GetHeader blk, Show (Header blk), Show peer
   ) => Show (TraceGDDEvent peer blk)