Fix some tracing instances

bench/tx-generator/src/Cardano/Benchmarking/Command.hs

@@ -58,7 +58,6 @@ import           GHC.Weak as Weak (deRefWeak)
 import           System.Posix.Signals as Sig (Handler (CatchInfo),
                    SignalInfo (..), SignalSpecificInfo (..), installHandler,
                    sigINT, sigTERM)
-import Foreign.C (Errno(..))
 #if MIN_VERSION_base(4,18,0)
 import           Data.Maybe as Maybe (fromMaybe)
 import           GHC.Conc.Sync as Conc (threadLabel)

cabal.project

@@ -60,8 +60,7 @@ package plutus-scripts-bench
 constraints:
   , wai-extra < 3.1.15
   , Cabal < 3.14
-  , hedgehog-extras ==0.6.4.0
-  , io-sim ==1.5.1.0
+  , hedgehog-extras <0.6.5.1
 
 allow-newer:
   , katip:Win32
@@ -94,8 +93,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
@@ -789,7 +789,7 @@
 updateTopologyConfiguration startupTracer nc localRootsVar publicRootsVar useLedgerVar
                             useBootsrapPeersVar ledgerPeerSnapshotPathVar = do
     traceWith startupTracer NetworkConfigUpdate
-    result <- try $ readTopologyFileOrError nc
+    result <- try $ readTopologyFileOrError nc startupTracer
     case result of
       Left (FatalError err) ->
         traceWith startupTracer
@@ -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")