Dummy implementation for network tracers

cardano-node/src/Cardano/Node/Configuration/TopologyP2P.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE PackageImports #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE NamedFieldPuns #-}
@@ -28,7 +29,6 @@ import           Cardano.Node.Configuration.POM (NodeConfiguration (..))
 import           Cardano.Node.Configuration.Topology (TopologyError (..))
 import           Cardano.Node.Startup (StartupTrace (..))
 import           Cardano.Node.Types
-import           Cardano.Logging (traceWith)
 import           Cardano.Tracing.OrphanInstances.Network ()
 import           Ouroboros.Network.ConsensusMode
 import           Ouroboros.Network.NodeToNode (DiffusionMode (..), PeerAdvertise (..))
@@ -45,6 +45,7 @@ import           Control.Exception (IOException)
 import qualified Control.Exception as Exception
 import           Control.Exception.Base (Exception (..))
 import           Control.Monad.Trans.Except.Extra
+import qualified "contra-tracer" Control.Tracer as CT
 import           Data.Aeson
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
@@ -213,26 +214,26 @@ instance ToJSON NetworkTopology where
 
 -- | Read the `NetworkTopology` configuration from the specified file.
 --
-readTopologyFile :: NodeConfiguration -> IO (Either Text NetworkTopology)
-readTopologyFile nc = do
+readTopologyFile :: NodeConfiguration -> CT.Tracer IO (StartupTrace blk) -> IO (Either Text NetworkTopology)
+readTopologyFile nc tr = do
   eBs <- Exception.try $ BS.readFile (unTopology $ ncTopologyFile nc)
 
   case eBs of
     Left e -> return . Left $ handler e
     Right bs ->
       let bs' = LBS.fromStrict bs in
-        return $ case eitherDecode bs' of
-          Left err -> Left (handlerJSON err)
+        case eitherDecode bs' of
+          Left err -> return $ Left (handlerJSON err)
           Right t
             | isValidTrustedPeerConfiguration t ->
                 if isGenesisCompatible (ncConsensusMode nc) (ntUseBootstrapPeers t)
                   then return (Right t)
                   else do
-                    traceWith (ncTraceConfig nc) $
+                    CT.traceWith tr $
                       NetworkConfigUpdateError genesisIncompatible
                     return . Right $ t { ntUseBootstrapPeers = DontUseBootstrapPeers }
             | otherwise ->
-                Left handlerBootstrap
+                pure $ Left handlerBootstrap
   where
     handler :: IOException -> Text
     handler e = Text.pack $ "Cardano.Node.Configuration.Topology.readTopologyFile: "
@@ -260,9 +261,9 @@ readTopologyFile nc = do
     isGenesisCompatible GenesisMode (UseBootstrapPeers{}) = False
     isGenesisCompatible _ _ = True
 
-readTopologyFileOrError :: NodeConfiguration -> IO NetworkTopology
-readTopologyFileOrError nc =
-      readTopologyFile nc
+readTopologyFileOrError :: NodeConfiguration -> CT.Tracer IO (StartupTrace blk) -> IO NetworkTopology
+readTopologyFileOrError nc tr =
+      readTopologyFile nc tr
   >>= either (\err -> error $ "Cardano.Node.Configuration.TopologyP2P.readTopologyFile: "
                            <> Text.unpack err)
              pure

cardano-node/src/Cardano/Node/Run.hs

@@ -437,7 +437,7 @@ handleSimpleNode blockType runP p2pMode tracers nc onKernel = do
           { ntUseLedgerPeers
           , ntUseBootstrapPeers
           , ntPeerSnapshotPath
-          } <- TopologyP2P.readTopologyFileOrError nc
+          } <- TopologyP2P.readTopologyFileOrError nc (startupTracer tracers)
         let (localRoots, publicRoots) = producerAddresses nt
         traceWith (startupTracer tracers)
                 $ NetworkConfig localRoots
@@ -922,8 +922,6 @@ mkP2PArguments NodeConfiguration {
       , P2P.daReadUseLedgerPeers
       , P2P.daReadUseBootstrapPeers
       , P2P.daReadLedgerPeerSnapshot
-      , P2P.daConsensusMode = ncConsensusMode
-      , P2P.daMinBigLedgerPeersForTrustedState = ncMinBigLedgerPeersForTrustedState
       , P2P.daProtocolIdleTimeout   = ncProtocolIdleTimeout
       , P2P.daTimeWaitTimeout       = ncTimeWaitTimeout
       , P2P.daDeadlineChurnInterval = Configuration.defaultDeadlineChurnInterval

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

@@ -65,6 +65,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.ConnectionId (ConnectionId (..))
 import           Ouroboros.Network.DeltaQ (GSV (..), PeerGSV (..))
 import           Ouroboros.Network.KeepAlive (TraceKeepAliveClient (..))
@@ -698,6 +699,36 @@ 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"]
+
+  severityFor (Namespace _ ["PeersFetch"]) _ = Just Debug
+  severityFor (Namespace _ ["PeerStarvedUs"]) _ = Just Info
+  severityFor _ _ = Nothing
+
+  documentFor (Namespace [] ["PeersFetch"]) =
+    Just "TODO: @ouroboros-network"
+  documentFor (Namespace [] ["PeerStarvedUs"]) =
+    Just "TODO: @ouroboros-network"
+  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 (LogFormatting peer, Show peer) =>
     LogFormatting [TraceLabelPeer peer (FetchDecision [Point header])] where
   forMachine DMinimal _ = mempty

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

@@ -559,9 +559,6 @@ instance LogFormatting (TracePeerSelection SockAddr) where
             , "upstreamyness" .= dpssUpstreamyness ds
             , "fetchynessBlocks" .= dpssFetchynessBlocks ds
             ]
-  forMachine _dtal (TraceVerifyPeerSnapshot result) =
-    mconcat [ "kind" .= String "VerifyPeerSnapshot"
-            , "result" .= result]
 
   forHuman = pack . show
 
@@ -688,8 +685,6 @@ instance MetaTrace (TracePeerSelection SockAddr) where
       Namespace [] ["ChurnTimeout"]
     namespaceFor TraceDebugState {} =
       Namespace [] ["DebugState"]
-    namespaceFor TraceVerifyPeerSnapshot {} =
-      Namespace [] ["VerifyPeerSnapshot"]
 
     severityFor (Namespace [] ["LocalRootPeersChanged"]) _ = Just Notice
     severityFor (Namespace [] ["TargetsChanged"]) _ = Just Notice
@@ -1206,7 +1201,7 @@ instance (Show addr, Show versionNumber, Show agreedOptions, LogFormatting addr,
           , "remoteAddress" .= forMachine dtal peerAddr
           , "provenance" .= String (pack . show $ prov)
           ]
-    forMachine dtal (TrReleaseConnection prov connId) =
+    forMachine _dtal (TrReleaseConnection prov connId) =
         mconcat $ reverse
           [ "kind" .= String "UnregisterConnection"
           , "remoteAddress" .= toJSON connId
@@ -1323,7 +1318,7 @@ instance (Show addr, Show versionNumber, Show agreedOptions, LogFormatting addr,
                                              listValue (\(localAddr, connState) ->
                                                 object
                                                   [ "localAddress" .= localAddr
-                                                  , "state" .= toJSON connState  
+                                                  , "state" .= toJSON connState
                                                   ]
                                              )
                                              (Map.toList inner)
@@ -1537,7 +1532,7 @@ instance MetaTrace (ConnectionManager.AbstractTransitionTrace peerAddr) where
 
 instance (Show addr, LogFormatting addr, ToJSON addr)
       => LogFormatting (Server.Trace addr) where
-  forMachine dtal (TrAcceptConnection connId)     =
+  forMachine _dtal (TrAcceptConnection connId)     =
     mconcat [ "kind" .= String "AcceptConnection"
              , "address" .= toJSON connId
              ]

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

@@ -93,6 +93,7 @@ import           Ouroboros.Network.Block (BlockNo (..), ChainUpdate (..), HasHea
 import           Ouroboros.Network.BlockFetch.ClientState (TraceFetchClientState (..),
                    TraceLabelPeer (..))
 import           Ouroboros.Network.BlockFetch.Decision (FetchDecision, FetchDecline (..))
+import           Ouroboros.Network.BlockFetch.Decision.Trace
 import           Ouroboros.Network.ConnectionId (ConnectionId)
 import qualified Ouroboros.Network.ConnectionManager.Core as ConnectionManager
 import           Ouroboros.Network.ConnectionManager.Types (ConnectionManagerCounters (..))
@@ -1455,6 +1456,7 @@ nodeToNodeTracers' trSel verb tr =
                   verb "KeepAliveProtocol" tr
   }
 
+-- TODO @ouroboros-network
 teeTraceBlockFetchDecision
     :: ( Eq peer
        , HasHeader blk
@@ -1464,11 +1466,14 @@ teeTraceBlockFetchDecision
     => TracingVerbosity
     -> MVar (Maybe (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])]),Integer)
     -> Trace IO Text
-    -> Tracer IO (WithSeverity [TraceLabelPeer peer (FetchDecision [Point (Header blk)])])
+    -> Tracer IO (WithSeverity (TraceDecisionEvent peer (Header blk)))
 teeTraceBlockFetchDecision verb eliding tr =
-  Tracer $ \ev -> do
-    traceWith (teeTraceBlockFetchDecision' meTr) ev
-    traceWith (teeTraceBlockFetchDecisionElide verb eliding bfdTr) ev
+  Tracer $ \(WithSeverity s ev) -> case ev of
+    PeerStarvedUs {} -> do
+      traceWith (toLogObject' verb meTr) ev
+    PeersFetch ev' -> do
+      traceWith (teeTraceBlockFetchDecision' meTr) (WithSeverity s ev')
+      traceWith (teeTraceBlockFetchDecisionElide verb eliding bfdTr) (WithSeverity s ev')
  where
    meTr  = appendName "metrics" tr
    bfdTr = appendName "BlockFetchDecision" tr