Fix some tracing instances

cabal.project

@@ -94,8 +94,8 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/ouroboros-consensus.git
-  tag: a50e092b71daef360c5d86bbbb45e26733797b42
-  --sha256: sha256-aEXe5LuU1i6NXadSF3ULdKp0l/+gT2a96nWPVPTqBHU=
+  tag: f2d134da6d6d4f7bcbfb85ba94b30f49b3f2b7c6
+  --sha256: sha256-4Lu716WX9S+5dguxa8lUjAgeCQYsxj9QZZ9xLyyjivQ=
   subdir:
     ouroboros-consensus
     ouroboros-consensus-cardano

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

@@ -9,7 +9,7 @@
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
 {-# LANGUAGE TypeApplications #-}
 
@@ -437,7 +437,7 @@
           { 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 @@
       , 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.hs

@@ -335,6 +335,11 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf
                 ["Consensus", "GSM"]
     configureTracers configReflection trConfig [consensusGsmTr]
 
+    !consensusCsjTr <- mkCardanoTracer
+                trBase trForward mbTrEKG
+                ["Consensus", "CSJ"]
+    configureTracers configReflection trConfig [consensusCsjTr]
+
     pure $ Consensus.Tracers
       { Consensus.chainSyncClientTracer = Tracer $
           traceWith chainSyncClientTr
@@ -377,6 +382,8 @@ mkConsensusTracers configReflection trBase trForward mbTrEKG _trDataPoint trConf
           traceWith consensusStartupErrorTr . ConsensusStartupException
       , Consensus.gsmTracer = Tracer $
           traceWith consensusGsmTr
+      , Consensus.csjTracer = Tracer $
+          traceWith consensusCsjTr
       }
 
 mkNodeToClientTracers :: forall blk.

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

@@ -93,10 +93,20 @@ instance (  LogFormatting (Header blk)
   forHuman (ChainDB.TraceLedgerReplayEvent v)      = forHumanOrMachine v
   forHuman (ChainDB.TraceImmutableDBEvent v)       = forHumanOrMachine v
   forHuman (ChainDB.TraceVolatileDBEvent v)        = forHumanOrMachine v
-  forHuman (ChainDB.TraceChainSelStarvationEvent v)= forHumanOrMachine v
+  forHuman (ChainDB.TraceChainSelStarvationEvent ev) = case ev of
+        ChainDB.ChainSelStarvation RisingEdge ->
+          "Chain Selection was starved."
+        ChainDB.ChainSelStarvation (FallingEdgeWith pt) ->
+          "Chain Selection was unstarved by " <> renderRealPoint pt
 
   forMachine _ ChainDB.TraceLastShutdownUnclean =
     mconcat [ "kind" .= String "LastShutdownUnclean" ]
+  forMachine dtal (ChainDB.TraceChainSelStarvationEvent (ChainDB.ChainSelStarvation edge)) =
+    mconcat [ "kind" .= String "ChainSelStarvation"
+             , case edge of
+                 RisingEdge -> "risingEdge" .= True
+                 FallingEdgeWith pt -> "fallingEdge" .= forMachine dtal pt
+             ]
   forMachine details (ChainDB.TraceAddBlockEvent v) =
     forMachine details v
   forMachine details (ChainDB.TraceFollowerEvent v) =
@@ -119,27 +129,27 @@ instance (  LogFormatting (Header blk)
     forMachine details v
   forMachine details (ChainDB.TraceVolatileDBEvent v) =
     forMachine details v
-  forMachine details (ChainDB.TraceChainSelStarvationEvent v) =
-    forMachine details v
 
-  asMetrics ChainDB.TraceLastShutdownUnclean        = []
-  asMetrics (ChainDB.TraceAddBlockEvent v)          = asMetrics v
-  asMetrics (ChainDB.TraceFollowerEvent v)          = asMetrics v
-  asMetrics (ChainDB.TraceCopyToImmutableDBEvent v) = asMetrics v
-  asMetrics (ChainDB.TraceGCEvent v)                = asMetrics v
-  asMetrics (ChainDB.TraceInitChainSelEvent v)      = asMetrics v
-  asMetrics (ChainDB.TraceOpenEvent v)              = asMetrics v
-  asMetrics (ChainDB.TraceIteratorEvent v)          = asMetrics v
-  asMetrics (ChainDB.TraceSnapshotEvent v)          = asMetrics v
-  asMetrics (ChainDB.TraceLedgerReplayEvent v)      = asMetrics v
-  asMetrics (ChainDB.TraceImmutableDBEvent v)       = asMetrics v
-  asMetrics (ChainDB.TraceVolatileDBEvent v)        = asMetrics v
-  asMetrics (ChainDB.TraceChainSelStarvationEvent v)= asMetrics v
+  asMetrics ChainDB.TraceLastShutdownUnclean         = []
+  asMetrics (ChainDB.TraceChainSelStarvationEvent _) = []
+  asMetrics (ChainDB.TraceAddBlockEvent v)           = asMetrics v
+  asMetrics (ChainDB.TraceFollowerEvent v)           = asMetrics v
+  asMetrics (ChainDB.TraceCopyToImmutableDBEvent v)  = asMetrics v
+  asMetrics (ChainDB.TraceGCEvent v)                 = asMetrics v
+  asMetrics (ChainDB.TraceInitChainSelEvent v)       = asMetrics v
+  asMetrics (ChainDB.TraceOpenEvent v)               = asMetrics v
+  asMetrics (ChainDB.TraceIteratorEvent v)           = asMetrics v
+  asMetrics (ChainDB.TraceSnapshotEvent v)           = asMetrics v
+  asMetrics (ChainDB.TraceLedgerReplayEvent v)       = asMetrics v
+  asMetrics (ChainDB.TraceImmutableDBEvent v)        = asMetrics v
+  asMetrics (ChainDB.TraceVolatileDBEvent v)         = asMetrics v
 
 
 instance MetaTrace  (ChainDB.TraceEvent blk) where
   namespaceFor ChainDB.TraceLastShutdownUnclean =
     Namespace [] ["LastShutdownUnclean"]
+  namespaceFor ChainDB.TraceChainSelStarvationEvent{} =
+    Namespace [] ["ChainSelStarvationEvent"]
   namespaceFor (ChainDB.TraceAddBlockEvent ev) =
     nsPrependInner "AddBlockEvent" (namespaceFor ev)
   namespaceFor (ChainDB.TraceFollowerEvent ev) =
@@ -162,10 +172,9 @@ instance MetaTrace  (ChainDB.TraceEvent blk) where
     nsPrependInner "ImmDbEvent" (namespaceFor ev)
   namespaceFor (ChainDB.TraceVolatileDBEvent ev) =
      nsPrependInner "VolatileDbEvent" (namespaceFor ev)
-  namespaceFor (ChainDB.TraceChainSelStarvationEvent ev) =
-     nsPrependInner "ChainSelStarvationEvent" (namespaceFor ev)
 
   severityFor (Namespace _ ["LastShutdownUnclean"]) _ = Just Info
+  severityFor (Namespace _ ["ChainSelStarvationEvent"]) _ = Just Debug
   severityFor (Namespace out ("AddBlockEvent" : tl)) (Just (ChainDB.TraceAddBlockEvent ev')) =
     severityFor (Namespace out tl) (Just ev')
   severityFor (Namespace out ("AddBlockEvent" : tl)) Nothing =
@@ -213,6 +222,7 @@ instance MetaTrace  (ChainDB.TraceEvent blk) where
   severityFor _ns _ = Nothing
 
   privacyFor (Namespace _ ["LastShutdownUnclean"]) _ = Just Public
+  privacyFor (Namespace _ ["ChainSelStarvationEvent"]) _ = Just Public
   privacyFor (Namespace out ("AddBlockEvent" : tl)) (Just (ChainDB.TraceAddBlockEvent ev')) =
     privacyFor (Namespace out tl) (Just ev')
   privacyFor (Namespace out ("AddBlockEvent" : tl)) Nothing =
@@ -260,6 +270,7 @@ instance MetaTrace  (ChainDB.TraceEvent blk) where
   privacyFor _ _ = Nothing
 
   detailsFor (Namespace _ ["LastShutdownUnclean"]) _ = Just DNormal
+  detailsFor (Namespace _ ["ChainSelStarvationEvent"]) _ = Just DNormal
   detailsFor (Namespace out ("AddBlockEvent" : tl)) (Just (ChainDB.TraceAddBlockEvent ev')) =
     detailsFor (Namespace out tl) (Just ev')
   detailsFor (Namespace out ("AddBlockEvent" : tl)) Nothing =
@@ -335,6 +346,10 @@ instance MetaTrace  (ChainDB.TraceEvent blk) where
     , " state. Therefore, revalidating all the immutable chunks is necessary to"
     , " ensure the correctness of the chain."
     ]
+  documentFor (Namespace _ ["ChainSelStarvationEvent"]) = Just $ mconcat
+    [ "ChainSel is waiting for a next block to process, but there is no block in the queue."
+    , " Despite the name, it is a pretty normal (and frequent) event."
+    ]
   documentFor (Namespace out ("AddBlockEvent" : tl)) =
     documentFor (Namespace out tl :: Namespace (ChainDB.TraceAddBlockEvent blk))
   documentFor (Namespace out ("FollowerEvent" : tl)) =
@@ -361,7 +376,7 @@ instance MetaTrace  (ChainDB.TraceEvent blk) where
 
   allNamespaces =
         Namespace [] ["LastShutdownUnclean"]
-
+          : Namespace [] ["ChainSelStarvationEvent"]
           : (map  (nsPrependInner "AddBlockEvent")
                   (allNamespaces :: [Namespace (ChainDB.TraceAddBlockEvent blk)])
           ++ map  (nsPrependInner "FollowerEvent")

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

@@ -49,8 +49,7 @@ import           Ouroboros.Consensus.Mempool (MempoolSize (..), TraceEventMempoo
 import           Ouroboros.Consensus.MiniProtocol.BlockFetch.Server
                    (TraceBlockFetchServerEvent (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
-import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping (Instruction (..),
-                   JumpInstruction (..), JumpResult (..))
+import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.Jumping as Jumping
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client.State (JumpInfo (..))
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Server
 import           Ouroboros.Consensus.MiniProtocol.LocalTxSubmission.Server
@@ -66,12 +65,14 @@ 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 (..))
 import           Ouroboros.Network.SizeInBytes (SizeInBytes (..))
 import           Ouroboros.Network.TxSubmission.Inbound hiding (txId)
 import           Ouroboros.Network.TxSubmission.Outbound
+import           Network.TypedProtocol.Core
 
 import           Control.Monad (guard)
 import           Control.Monad.Class.MonadTime.SI (Time (..))
@@ -231,6 +232,8 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk)
         [ "ChainSync Jumping -- the client is asked to jump to "
         , showT (jumpInstructionToPoint instruction)
         ]
+    TraceDrainingThePipe n ->
+      "ChainSync client is draining the pipe. Pipelined messages expected: " <> showT (natToInt n)
     where
       jumpInstructionToPoint = AF.headPoint . jTheirFragment . \case
         JumpTo ji          -> ji
@@ -304,6 +307,11 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk)
         [ "kind" .= String "TraceJumpingInstructionIs"
         , "instr" .= instructionToObject instruction
         ]
+    TraceDrainingThePipe n ->
+      mconcat
+        [ "kind" .= String "TraceDrainingThePipe"
+        , "n" .= natToInt n
+        ]
     where
       instructionToObject :: Instruction blk -> Aeson.Object
       instructionToObject = \case
@@ -327,6 +335,30 @@ instance (ConvertRawHash blk, LedgerSupportsProtocol blk)
 
       jumpInfoToPoint = AF.headPoint . jTheirFragment
 
+-- TODO @tweag-genesis
+instance MetaTrace (Jumping.TraceEvent addr) where
+  namespaceFor RotatedDynamo{} = Namespace [] ["RotatedDynamo"]
+
+  severityFor (Namespace [] ["RotatedDynamo"]) _ = Just Info
+  severityFor _ _ = Nothing
+
+  documentFor (Namespace [] ["RotatedDynamo"]) =
+    Just "The dynamo rotated"
+  documentFor _ = Nothing
+
+  allNamespaces =
+    [ Namespace [] ["RotatedDynamo"] ]
+
+instance Show addr => LogFormatting (Jumping.TraceEvent addr) where
+  forHuman (RotatedDynamo fromPeer toPeer) =
+    "Rotated the dynamo from " <> showT fromPeer <> " to " <> showT toPeer
+  forMachine _dtal (RotatedDynamo fromPeer toPeer) =
+    mconcat
+      [ "kind" .= String "RotatedDynamo"
+      , "from" .= showT fromPeer
+      , "to" .= showT toPeer
+      ]
+
 tipToObject :: forall blk. ConvertRawHash blk => Tip blk -> Aeson.Object
 tipToObject = \case
   TipGenesis -> mconcat
@@ -368,6 +400,8 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where
       Namespace [] ["JumpingWaitingForNextInstruction"]
     TraceJumpingInstructionIs _ ->
       Namespace [] ["JumpingInstructionIs"]
+    TraceDrainingThePipe _ ->
+      Namespace [] ["DrainingThePipe"]
 
   severityFor ns _ =
     case ns of
@@ -397,6 +431,8 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where
         Just Debug
       Namespace _ ["JumpingInstructionIs"] ->
         Just Debug
+      Namespace _ ["DrainingThePipe"] ->
+        Just Debug
       _ ->
         Nothing
 
@@ -434,6 +470,8 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where
         Just "The client is waiting for the next instruction"
       Namespace _ ["JumpingInstructionIs"] ->
         Just "The client got its next instruction"
+      Namespace _ ["DrainingThePipe"] ->
+        Just "The client is draining the pipe of messages"
       _ ->
         Nothing
 
@@ -451,6 +489,7 @@ instance MetaTrace (TraceChainSyncClientEvent blk) where
     , Namespace [] ["JumpResult"]
     , Namespace [] ["JumpingWaitingForNextInstruction"]
     , Namespace [] ["JumpingInstructionIs"]
+    , Namespace [] ["DrainingThePipe"]
     ]
 
 --------------------------------------------------------------------------------
@@ -660,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