Network tracing instances for fetch decisions

* Provide instances for `FetchDecisionEvent` for new tracing
  system.
* Provide `ToJSON` instances for `FetchDecision` (via
  `FetchDecisionToJSON` newtype wrapper), `TraceDecisionEvent`, `Point`
  which can be used by both new and old tracing system.
* Provide `Verbose` newtype wrapper wich `ToJSON` instances provide more
  verbose output.

Author: coot

cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs

@@ -32,6 +32,7 @@ import           Cardano.Node.Tracing.Formatting ()
 import           Cardano.Node.Tracing.Render
 import           Cardano.Node.Tracing.Tracers.ConsensusStartupException ()
 import           Cardano.Node.Tracing.Tracers.StartLeadershipCheck
+import           Cardano.Tracing.OrphanInstances.Network (Verbose (..))
 import           Cardano.Protocol.TPraos.OCert (KESPeriod (..))
 import           Cardano.Slotting.Slot (WithOrigin (..))
 import           Ouroboros.Consensus.Block
@@ -65,7 +66,7 @@ import           Ouroboros.Network.Block hiding (blockPrevHash)
 import           Ouroboros.Network.BlockFetch.ClientState (TraceLabelPeer (..))
 import qualified Ouroboros.Network.BlockFetch.ClientState as BlockFetch
 import           Ouroboros.Network.BlockFetch.Decision
-import           Ouroboros.Network.BlockFetch.Decision.Trace
+import           Ouroboros.Network.BlockFetch.Decision.Trace (TraceDecisionEvent (..))
 import           Ouroboros.Network.ConnectionId (ConnectionId (..))
 import           Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..))
 import           Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..))
@@ -699,7 +700,6 @@ calculateBlockFetchClientMetrics cm _lc _ = pure cm
 -- BlockFetchDecision Tracer
 --------------------------------------------------------------------------------
 
--- TODO @ouroboros-network
 instance MetaTrace (TraceDecisionEvent peer (Header blk)) where
   namespaceFor PeersFetch{} = Namespace [] ["PeersFetch"]
   namespaceFor PeerStarvedUs{} = Namespace [] ["PeerStarvedUs"]
@@ -709,25 +709,28 @@ instance MetaTrace (TraceDecisionEvent peer (Header blk)) where
   severityFor _ _ = Nothing
 
   documentFor (Namespace [] ["PeersFetch"]) =
-    Just "TODO: @ouroboros-network"
+    Just "list of block-fetch decisions"
   documentFor (Namespace [] ["PeerStarvedUs"]) =
-    Just "TODO: @ouroboros-network"
+    Just "current peer starved us, the node will switch to a different peer"
   documentFor _ = Nothing
 
   allNamespaces =
     [ Namespace [] ["PeersFetch"], Namespace [] ["PeerStarvedUs"] ]
 
--- TODO @ouroboros-network
-instance LogFormatting (TraceDecisionEvent peer (Header blk)) where
-  forHuman (PeersFetch _traces) =
-    "TODO: @ouroboros-network"
-  forHuman (PeerStarvedUs _traces) =
-    "TODO: @ouroboros-network"
-
-  forMachine _dtal (PeersFetch _traces) =
-    mconcat [ "kind" .= String "TODO: @ouroboros-network" ]
-  forMachine _dtal (PeerStarvedUs _traces) =
-    mconcat [ "kind" .= String "TODO: @ouroboros-network" ]
+instance (Show peer, ToJSON peer, ConvertRawHash (Header blk), HasHeader blk)
+      => LogFormatting (TraceDecisionEvent peer (Header blk)) where
+  forHuman = Text.pack . show
+
+  forMachine dtal (PeersFetch xs) =
+    mconcat [ "kind" .= String "PeerFetch"
+            , "decisions" .= if dtal >= DMaximum
+                               then toJSON (Verbose <$> xs)
+                               else toJSON xs
+            ]
+  forMachine _dtal (PeerStarvedUs peer) =
+    mconcat [ "kind" .= String "PeerStarvedUs"
+            , "peer" .= toJSON peer
+            ]
 
 instance (LogFormatting peer, Show peer) =>
     LogFormatting [TraceLabelPeer peer (FetchDecision [Point header])] where

cardano-node/src/Cardano/Tracing/OrphanInstances/Network.hs

@@ -22,7 +22,10 @@
 {-# OPTIONS_GHC -Wno-name-shadowing #-}
 #endif
 
-module Cardano.Tracing.OrphanInstances.Network () where
+module Cardano.Tracing.OrphanInstances.Network
+  ( Verbose (..)
+  , FetchDecisionToJSON (..)
+  ) where
 
 import           Cardano.Node.Queries (ConvertTxId)
 import           Cardano.Tracing.OrphanInstances.Common
@@ -630,7 +633,7 @@ instance HasTextFormatter NtN.AcceptConnectionsPolicyTrace where
   formatText a _ = pack (show a)
 
 
-instance (StandardHash header, Show peer, ToObject peer)
+instance (StandardHash header, Show peer, ToJSON peer, ConvertRawHash header)
       => Transformable Text IO [TraceLabelPeer peer (FetchDecision [Point header])] where
   trTransformer = trStructuredText
 instance (StandardHash header, Show peer)
@@ -644,7 +647,7 @@ instance (Show header, StandardHash header, Show peer)
      => HasTextFormatter (TraceLabelPeer peer (TraceFetchClientState header)) where
   formatText a _ = pack (show a)
 
-instance (StandardHash header, Show peer, ToObject peer)
+instance (StandardHash header, Show peer, ToJSON peer, ConvertRawHash header)
       => Transformable Text IO (BlockFetch.TraceDecisionEvent peer header) where
   trTransformer = trStructuredText
 instance (StandardHash header, Show peer)
@@ -1129,16 +1132,6 @@ instance Aeson.ToJSON ConnectionManagerCounters where
                  , "outbound"       .= outboundConns
                  ]
 
-instance ToObject (FetchDecision [Point header]) where
-  toObject _verb (Left decline) =
-    mconcat [ "kind" .= String "FetchDecision declined"
-             , "declined" .= String (pack (show decline))
-             ]
-  toObject _verb (Right results) =
-    mconcat [ "kind" .= String "FetchDecision results"
-             , "length" .= String (pack $ show $ length results)
-             ]
-
 -- TODO: use 'ToJSON' constraints
 instance (Show ntnAddr, Show ntcAddr) => ToObject (ND.DiffusionTracer ntnAddr ntcAddr) where
   toObject _verb (ND.RunServer sockAddr) = mconcat
@@ -1244,17 +1237,45 @@ instance ToObject NtN.AcceptConnectionsPolicyTrace where
              ]
 
 
+instance ConvertRawHash header
+      => ToJSON (Point header) where
+  toJSON GenesisPoint = String "GenesisPoint"
+  toJSON (BlockPoint (SlotNo slotNo) hash) =
+    -- it is unlikely that there will be two short hashes in the same slot
+    String $ renderHeaderHashForVerbosity
+               (Proxy @header)
+                MinimalVerbosity
+                hash
+          <> "@"
+          <> pack (show slotNo)
+
+
+newtype Verbose a = Verbose a
+
+instance ConvertRawHash header
+      => ToJSON (Verbose (Point header)) where
+  toJSON (Verbose GenesisPoint) = String "GenesisPoint"
+  toJSON (Verbose (BlockPoint (SlotNo slotNo) hash)) =
+    -- it is unlikely that there will be two short hashes in the same slot
+    String $ renderHeaderHashForVerbosity
+               (Proxy @header)
+                MaximalVerbosity
+                hash
+          <> "@"
+          <> pack (show slotNo)
+
+
 instance ConvertRawHash blk
       => ToObject (Point blk) where
   toObject _verb GenesisPoint =
-    mconcat
-      [ "kind" .= String "GenesisPoint" ]
-  toObject verb (BlockPoint slot h) =
-    mconcat
-      [ "kind" .= String "BlockPoint"
-      , "slot" .= toJSON (unSlotNo slot)
-      , "headerHash" .= renderHeaderHashForVerbosity (Proxy @blk) verb h
-      ]
+    mconcat [ "point" .= String "GenesisPoint" ]
+  toObject verb point@BlockPoint{} =
+    mconcat [ "point" .=
+                case verb of
+                  MaximalVerbosity
+                    -> toJSON (Verbose point)
+                  _ -> toJSON point
+            ]
 
 
 instance ToObject SlotNo where
@@ -1330,26 +1351,51 @@ instance (HasHeader header, ConvertRawHash header)
              , "outstanding" .= outstanding
              ]
 
-
-instance (ToObject peer)
+instance (ToJSON peer, ConvertRawHash header)
       => ToObject [TraceLabelPeer peer (FetchDecision [Point header])] where
   toObject MinimalVerbosity _ = mempty
   toObject _ [] = mempty
   toObject _ xs = mconcat
-    [ "kind"  .= String "PeersFetch"
-    , "peers" .= toJSON
-      (foldl' (\acc x -> toObject MaximalVerbosity x : acc) [] xs) ]
+    [ "kind" .= String "FetchDecisions"
+    , "decisions" .= toJSON xs
+    ]
 
 instance (ToObject peer, ToObject a) => ToObject (TraceLabelPeer peer a) where
   toObject verb (TraceLabelPeer peerid a) =
     mconcat [ "peer" .= toObject verb peerid ] <> toObject verb a
 
-instance ToObject peer
+instance (ToJSON peer, ToJSON point)
+      => ToJSON (TraceLabelPeer peer (FetchDecision [point])) where
+  toJSON (TraceLabelPeer peer decision) =
+    Aeson.object
+      [ "peer" .= toJSON peer
+      , "decision" .= toJSON (FetchDecisionToJSON decision)
+      ]
+
+instance (ToJSON peer, ToJSON (Verbose point))
+    => ToJSON (Verbose (TraceLabelPeer peer (FetchDecision [point]))) where
+              toJSON (Verbose (TraceLabelPeer peer decision)) =
+                Aeson.object
+                [ "peer" .= toJSON peer
+                , "decision" .= toJSON (FetchDecisionToJSON $ map Verbose <$> decision)
+                ]
+
+newtype FetchDecisionToJSON point =
+    FetchDecisionToJSON (FetchDecision [point])
+
+instance ToJSON point
+      => ToJSON (FetchDecisionToJSON point) where
+  toJSON (FetchDecisionToJSON (Left decline)) =
+    Aeson.object [ "declined" .= String (pack . show $ decline) ]
+  toJSON (FetchDecisionToJSON (Right points)) =
+    toJSON points
+
+instance (ToJSON peer, ConvertRawHash header)
       => ToObject (BlockFetch.TraceDecisionEvent peer header) where
-  toObject verb (BlockFetch.PeersFetch as) = toObject verb as
-  toObject verb (BlockFetch.PeerStarvedUs peer) = mconcat
-    [ "kind" .= String "PeersStarvedUs"
-    , "peer" .= toObject verb peer
+  toObject  verb (BlockFetch.PeersFetch as) = toObject verb as
+  toObject _verb (BlockFetch.PeerStarvedUs peer) = mconcat
+    [ "kind" .= String "PeerStarvedUs"
+    , "peer" .= toJSON peer
     ]
 
 instance ToObject (AnyMessage ps)

cardano-node/src/Cardano/Tracing/Tracers.hs

@@ -725,6 +725,8 @@ mkConsensusTracers
   :: forall blk peer localPeer.
      ( Show peer
      , Eq peer
+     , ToObject peer
+     , ToJSON peer
      , LedgerQueries blk
      , ToJSON (GenTxId blk)
      , ToObject (ApplyTxErr blk)
@@ -734,7 +736,6 @@ mkConsensusTracers
      , ToObject (OtherHeaderEnvelopeError blk)
      , ToObject (ValidationErr (BlockProtocol blk))
      , ToObject (ForgeStateUpdateError blk)
-     , ToObject peer
      , Consensus.RunNode blk
      , HasKESMetricsData blk
      , HasKESInfo blk
@@ -1459,9 +1460,10 @@ nodeToNodeTracers' trSel verb tr =
 -- TODO @ouroboros-network
 teeTraceBlockFetchDecision
     :: ( Eq peer
-       , HasHeader blk
        , Show peer
-       , ToObject peer
+       , ToJSON peer
+       , HasHeader blk
+       , ConvertRawHash blk
        )
     => TracingVerbosity
     -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer)
@@ -1489,9 +1491,10 @@ teeTraceBlockFetchDecision' tr =
 
 teeTraceBlockFetchDecisionElide
     :: ( Eq peer
-       , HasHeader blk
        , Show peer
-       , ToObject peer
+       , ToJSON peer
+       , HasHeader blk
+       , ConvertRawHash blk
        )
     => TracingVerbosity
     -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer)