Merge #4811

4811: Optimized trace-dispatcher and tracing system r=jutaro a=jutaro

Make namespaces more opwerful, enhance the interface and have all metainformation accessible at runtime for optimizations.

Co-authored-by: Yupanqui <jnf@arcor.de>

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

@@ -52,13 +52,12 @@ import           Cardano.Benchmarking.Types
 import           Cardano.Benchmarking.Version as Version
 
 generatorTracer ::
-     LogFormatting a
-  => (a -> Namespace)
-  -> Text
+     (LogFormatting a, MetaTrace a)
+  => Text
   -> Maybe (Trace IO FormattedMessage)
   -> Maybe (Trace IO FormattedMessage)
   -> IO (Trace IO a)
-generatorTracer namesFor tracerName mbTrStdout mbTrForward = do
+generatorTracer tracerName mbTrStdout mbTrForward = do
   forwardTrace <- case mbTrForward of
                         Nothing -> mempty
                         Just trForward -> forwardFormatter Nothing trForward
@@ -67,9 +66,8 @@ generatorTracer namesFor tracerName mbTrStdout mbTrForward = do
                         Just trForward -> machineFormatter Nothing trForward
   let tr = forwardTrace <> stdoutTrace
   tr'  <- withDetailsFromConfig tr
-  pure $ withNamesAppended namesFor
-          $ appendName tracerName
-              tr'
+  pure $ withInnerNames $ appendPrefixName tracerName tr'
+
 
 initNullTracers :: BenchTracers
 initNullTracers = BenchTracers
@@ -84,14 +82,14 @@ initDefaultTracers :: IO BenchTracers
 initDefaultTracers = do
   mbStdoutTracer <- fmap Just standardTracer
   let mbForwardingTracer = Nothing
-  benchTracer <-  generatorTracer singletonName "benchmark"  mbStdoutTracer mbForwardingTracer
-  configureTracers initialTraceConfig benchTracerDocumented [benchTracer]
-  n2nSubmitTracer <- generatorTracer singletonName "submitN2N"  mbStdoutTracer mbForwardingTracer
-  configureTracers initialTraceConfig nodeToNodeSubmissionTraceDocumented [n2nSubmitTracer]
-  connectTracer <- generatorTracer singletonName "connect"  mbStdoutTracer mbForwardingTracer
-  configureTracers initialTraceConfig sendRecvConnectDocumented [connectTracer]
-  submitTracer <- generatorTracer namesForSubmission2 "submit"  mbStdoutTracer mbForwardingTracer
-  configureTracers initialTraceConfig submission2Documented [submitTracer]
+  benchTracer <-  generatorTracer "benchmark" mbStdoutTracer mbForwardingTracer
+  configureTracers initialTraceConfig [benchTracer]
+  n2nSubmitTracer <- generatorTracer "submitN2N" mbStdoutTracer mbForwardingTracer
+  configureTracers initialTraceConfig [n2nSubmitTracer]
+  connectTracer <- generatorTracer "connect" mbStdoutTracer mbForwardingTracer
+  configureTracers initialTraceConfig [connectTracer]
+  submitTracer <- generatorTracer "submit" mbStdoutTracer mbForwardingTracer
+  configureTracers initialTraceConfig [submitTracer]
 
   return $ BenchTracers
     { btTxSubmit_    = Tracer (traceWith benchTracer)
@@ -113,17 +111,17 @@ initTracers iomgr networkId tracerSocket = do
           pure (forwardTracer forwardSink, dataPointTracer dpStore)
   mbStdoutTracer <- fmap Just standardTracer
   let mbForwardingTracer = Just forwardingTracer
-  benchTracer <-  generatorTracer singletonName "benchmark" mbStdoutTracer mbForwardingTracer
-  configureTracers initialTraceConfig benchTracerDocumented [benchTracer]
-  n2nSubmitTracer <- generatorTracer singletonName "submitN2N" mbStdoutTracer mbForwardingTracer
-  configureTracers initialTraceConfig nodeToNodeSubmissionTraceDocumented [n2nSubmitTracer]
-  connectTracer <- generatorTracer singletonName "connect" mbStdoutTracer mbForwardingTracer
-  configureTracers initialTraceConfig sendRecvConnectDocumented [connectTracer]
-  submitTracer <- generatorTracer namesForSubmission2 "submit" mbStdoutTracer mbForwardingTracer
-  configureTracers initialTraceConfig submission2Documented [submitTracer]
+  benchTracer <-  generatorTracer "benchmark" mbStdoutTracer mbForwardingTracer
+  configureTracers initialTraceConfig [benchTracer]
+  n2nSubmitTracer <- generatorTracer "submitN2N" mbStdoutTracer mbForwardingTracer
+  configureTracers initialTraceConfig [n2nSubmitTracer]
+  connectTracer <- generatorTracer "connect" mbStdoutTracer mbForwardingTracer
+  configureTracers initialTraceConfig [connectTracer]
+  submitTracer <- generatorTracer "submit" mbStdoutTracer mbForwardingTracer
+  configureTracers initialTraceConfig [submitTracer]
   -- Now we need to provide "Nodeinfo" DataPoint, to forward generator's name
   -- to the acceptor application (for example, 'cardano-tracer').
-  nodeInfoTracer <- mkDataPointTracer dpTracer (const ["NodeInfo"])
+  nodeInfoTracer <- mkDataPointTracer dpTracer
   prepareGenInfo >>= traceWith nodeInfoTracer
 
   traceWith benchTracer $ TraceTxGeneratorVersion Version.txGeneratorVersion
@@ -163,12 +161,9 @@ initialTraceConfig = TraceConfig {
     , tcResourceFrequency = Just 1000 -- Every second
     }
   where
-    initConf :: Text -> (Namespace, [ConfigOption])
+    initConf :: Text -> ([Text], [ConfigOption])
     initConf tr = ([tr], [ConfDetail DMaximum])
 
-singletonName :: (ConstructorName f, Generic a, Rep a ~ D1 c f) => a -> [Text]
-singletonName a = [ genericName a ]
-
 genericName :: (ConstructorName f, Generic a, Rep a ~ D1 c f) => a -> Text
 genericName x = Text.pack $ constructorName $ unM1 $ from x
 
@@ -181,8 +176,6 @@ instance (ConstructorName f, ConstructorName g) => ConstructorName (f :+: g) whe
 instance (Constructor ('MetaCons n f r)) => ConstructorName (C1 ('MetaCons n f r) x) where
   constructorName = conName
 
-genericConstructorsOf :: forall a c f. (Rep a ~ D1 c f, ConstructorsOf f) => Proxy a -> [Text]
-genericConstructorsOf _ = map Text.pack $ constructorsOf (Proxy :: Proxy f)
 
 class ConstructorsOf (f :: Type -> Type ) where
   constructorsOf :: Proxy f -> [String]
@@ -261,9 +254,46 @@ instance LogFormatting (TraceBenchTxSubmit TxId) where
               , "msg"  .= A.String s
               ]
 
-benchTracerDocumented :: Documented (TraceBenchTxSubmit TxId)
-benchTracerDocumented
-  = Documented $ map (emptyDoc2 "benchmark") $ genericConstructorsOf (Proxy :: Proxy (TraceBenchTxSubmit x))
+instance MetaTrace (TraceBenchTxSubmit TxId) where
+    namespaceFor TraceTxGeneratorVersion {} = Namespace [] ["TxGeneratorVersion"]
+    namespaceFor TraceBenchTxSubRecv {} = Namespace [] ["BenchTxSubRecv"]
+    namespaceFor TraceBenchTxSubStart {} = Namespace [] ["BenchTxSubStart"]
+    namespaceFor SubmissionClientReplyTxIds {} = Namespace [] ["SubmissionClientReplyTxIds"]
+    namespaceFor TraceBenchTxSubServReq {} = Namespace [] ["BenchTxSubServReq"]
+    namespaceFor SubmissionClientDiscardAcknowledged {} = Namespace [] ["SubmissionClientDiscardAcknowledged"]
+    namespaceFor TraceBenchTxSubServDrop {} = Namespace [] ["BenchTxSubServDrop"]
+    namespaceFor SubmissionClientUnAcked {} = Namespace [] ["SubmissionClientUnAcked"]
+    namespaceFor TraceBenchTxSubServUnav {} = Namespace [] ["BenchTxSubServUnav"]
+    namespaceFor TraceBenchTxSubServFed {} = Namespace [] ["BenchTxSubServFed"]
+    namespaceFor TraceBenchTxSubServCons {} = Namespace [] ["BenchTxSubServCons"]
+    namespaceFor TraceBenchTxSubIdle {} = Namespace [] ["BenchTxSubIdle"]
+    namespaceFor TraceBenchTxSubRateLimit {} = Namespace [] ["BenchTxSubRateLimit"]
+    namespaceFor TraceBenchTxSubSummary {} = Namespace [] ["eBenchTxSubSummary"]
+    namespaceFor TraceBenchTxSubDebug {} = Namespace [] ["BenchTxSubDebug"]
+    namespaceFor TraceBenchTxSubError {} = Namespace [] ["BenchTxSubError"]
+
+    severityFor _ _ = Just Info
+
+    documentFor _ = Just ""
+
+    allNamespaces = [
+          Namespace [] ["TxGeneratorVersion"]
+        , Namespace [] ["BenchTxSubRecv"]
+        , Namespace [] ["BenchTxSubStart"]
+        , Namespace [] ["SubmissionClientReplyTxIds"]
+        , Namespace [] ["BenchTxSubServReq"]
+        , Namespace [] ["SubmissionClientDiscardAcknowledged"]
+        , Namespace [] ["BenchTxSubServDrop"]
+        , Namespace [] ["SubmissionClientUnAcked"]
+        , Namespace [] ["BenchTxSubServUnav"]
+        , Namespace [] ["BenchTxSubServFed"]
+        , Namespace [] ["BenchTxSubServCons"]
+        , Namespace [] ["BenchTxSubIdle"]
+        , Namespace [] ["BenchTxSubRateLimit"]
+        , Namespace [] ["eBenchTxSubSummary"]
+        , Namespace [] ["BenchTxSubDebug"]
+        , Namespace [] ["BenchTxSubError"]
+        ]
 
 instance LogFormatting NodeToNodeSubmissionTrace where
   forHuman = Text.pack . show
@@ -290,33 +320,54 @@ instance LogFormatting NodeToNodeSubmissionTrace where
        [ "kind" .= A.String "TxList"
        , "sent" .= A.toJSON sent ]
 
-nodeToNodeSubmissionTraceDocumented :: Documented NodeToNodeSubmissionTrace
-nodeToNodeSubmissionTraceDocumented
-  = Documented $ map (emptyDoc2 "submitN2N") $ genericConstructorsOf (Proxy :: Proxy NodeToNodeSubmissionTrace)
+
+instance MetaTrace NodeToNodeSubmissionTrace where
+    namespaceFor ReqIdsBlocking {} = Namespace [] ["ReqIdsBlocking"]
+    namespaceFor IdsListBlocking {} = Namespace [] ["IdsListBlocking"]
+    namespaceFor ReqIdsNonBlocking {} = Namespace [] ["ReqIdsNonBlocking"]
+    namespaceFor IdsListNonBlocking {} = Namespace [] ["IdsListNonBlocking"]
+    namespaceFor EndOfProtocol {} = Namespace [] ["EndOfProtocol"]
+    namespaceFor ReqTxs {} = Namespace [] ["ReqTxs"]
+    namespaceFor TxList {} = Namespace [] ["TxList"]
+
+    severityFor _ _ = Just Info
+
+    documentFor _ = Just ""
+
+    allNamespaces = [
+          Namespace [] ["ReqIdsBlocking"]
+        , Namespace [] ["IdsListBlocking"]
+        , Namespace [] ["ReqIdsNonBlocking"]
+        , Namespace [] ["IdsListNonBlocking"]
+        , Namespace [] ["EndOfProtocol"]
+        , Namespace [] ["ReqTxs"]
+        , Namespace [] ["TxList"]
+        ]
 
 instance LogFormatting SendRecvConnect where
   forHuman = Text.pack . show
   forMachine _ _ = KeyMap.fromList [ "kind" .= A.String "SendRecvConnect" ]
 
-sendRecvConnectDocumented :: Documented SendRecvConnect
-sendRecvConnectDocumented = Documented
-  [ emptyDoc ["connect"]
-  ]
+instance MetaTrace SendRecvConnect where
+    namespaceFor _ = Namespace [] ["ReqIdsBlocking"]
+    severityFor _ _ = Just Info
+
+    documentFor _ = Just ""
+
+    allNamespaces = [
+          Namespace [] ["SendRecvConnect"]
+        ]
 
 instance LogFormatting SendRecvTxSubmission2 where
   forHuman = Text.pack . show
   forMachine _ _ = KeyMap.fromList [ "kind" .= A.String "SendRecvTxSubmission2" ]
 
-namesForSubmission2 :: SendRecvTxSubmission2 ->  [Text]
-namesForSubmission2 _ = []
-
-submission2Documented :: Documented SendRecvTxSubmission2
-submission2Documented = Documented
-  [ emptyDoc ["submission2"]
-  ]
+instance MetaTrace SendRecvTxSubmission2 where
+    namespaceFor _ = Namespace [] ["SendRecvTxSubmission2"]
+    severityFor _ _ = Just Info
 
-emptyDoc :: Namespace -> DocMsg a
-emptyDoc ns = DocMsg ns [] "ToDo: write benchmark tracer docs"
+    documentFor _ = Just ""
 
-emptyDoc2 :: Text -> Text -> DocMsg a
-emptyDoc2 n1 n2 = DocMsg [n1, n2] [] "ToDo: write benchmark tracer docs"
+    allNamespaces = [
+          Namespace [] ["SendRecvTxSubmission2"]
+        ]

cabal.project

@@ -47,7 +47,7 @@ package cardano-git-rev
   ghc-options: -Werror
 
 package cardano-node
-  ghc-options: -Werror
+--  ghc-options: -Werror
 
 package cardano-node-chairman
   ghc-options: -Werror

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

@@ -24,9 +24,9 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import qualified Data.Text as Text
 
+import           Cardano.Node.Configuration.NodeAddress
 import           Cardano.Node.Configuration.POM (NodeConfiguration (..))
 import           Cardano.Node.Types
-import           Cardano.Node.Configuration.NodeAddress
 
 import           Ouroboros.Consensus.Util.Condense (Condense (..))
 

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

@@ -1,6 +1,6 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
 
@@ -33,21 +33,22 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS
 import qualified Data.Text as Text
 
-import "contra-tracer" Control.Tracer (Tracer, traceWith)
+import           "contra-tracer" Control.Tracer (Tracer, traceWith)
 
 import           Cardano.Node.Configuration.POM (NodeConfiguration (..))
 import           Cardano.Slotting.Slot (SlotNo (..))
 
 import           Cardano.Node.Configuration.NodeAddress
-import           Cardano.Node.Types
-import           Cardano.Node.Startup (StartupTrace (..))
 import           Cardano.Node.Configuration.Topology (TopologyError (..))
+import           Cardano.Node.Startup (StartupTrace (..))
+import           Cardano.Node.Types
 
 import           Ouroboros.Network.NodeToNode (PeerAdvertise (..))
 import           Ouroboros.Network.PeerSelection.LedgerPeers (UseLedgerAfter (..))
 import           Ouroboros.Network.PeerSelection.RelayAccessPoint (RelayAccessPoint (..))
 
 
+
 -- | A newtype wrapper around 'UseLedgerAfter' which provides 'FromJSON' and
 -- 'ToJSON' instances.
 --
@@ -248,7 +249,7 @@ readTopologyFile tr nc = do
   combine a b = case (a, b) of
     (Right {}, _)     -> return a
     (_, Right {})     -> traceWith tr NetworkConfigLegacy
-                      >> return (getLegacy <$> b)
+                           >> return (getLegacy <$> b)
     (Left _, Left _)  -> -- ignore parsing error of legacy format
                          return a
 

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

@@ -117,15 +117,7 @@ data StartupTrace blk =
   | BIByron BasicInfoByron
   | BINetwork BasicInfoNetwork
 
-severityStartupTracer :: StartupTrace blk -> SeverityS
-severityStartupTracer (StartupSocketConfigError _) = Error
-severityStartupTracer NetworkConfigUpdate = Notice
-severityStartupTracer (NetworkConfigUpdateError _) = Error
-severityStartupTracer NetworkConfigUpdateUnsupported = Warning
-severityStartupTracer P2PWarning = Warning
-severityStartupTracer P2PWarningDevelopementNetworkProtocols = Warning
-severityStartupTracer WarningDevelopmentNetworkProtocols {} = Warning
-severityStartupTracer _ = Info
+
 
 data BasicInfoCommon = BasicInfoCommon {
     biConfigPath    :: FilePath
@@ -166,19 +158,25 @@ data NodeInfo = NodeInfo
   , niSystemStartTime :: UTCTime
   } deriving (Eq, Generic, ToJSON, FromJSON, Show)
 
-docNodeInfoTraceEvent :: Documented NodeInfo
-docNodeInfoTraceEvent = Documented [
-    DocMsg
-      ["NodeInfo"]
-        []
-        "Basic information about this node collected at startup\
+instance MetaTrace NodeInfo where
+  namespaceFor NodeInfo {}  =
+    Namespace [] ["NodeInfo"]
+  severityFor  (Namespace _ ["NodeInfo"]) _ =
+    Just Info
+  severityFor _ns _ =
+    Nothing
+  documentFor  (Namespace _ ["NodeInfo"]) = Just
+    "Basic information about this node collected at startup\
         \\n\
         \\n _niName_: Name of the node. \
         \\n _niProtocol_: Protocol which this nodes uses. \
         \\n _niVersion_: Software version which this node is using. \
         \\n _niStartTime_: Start time of this node. \
         \\n _niSystemStartTime_: How long did the start of the node took."
-  ]
+  documentFor _ns =
+     Nothing
+  allNamespaces = [ Namespace [] ["NodeInfo"]]
+
 
 -- | Prepare basic info about the node. This info will be sent to 'cardano-tracer'.
 prepareNodeInfo
@@ -243,15 +241,20 @@ data NodeStartupInfo = NodeStartupInfo {
   , suiSlotsPerKESPeriod :: Word64
   } deriving (Eq, Generic, ToJSON, FromJSON, Show)
 
-docNodeStartupInfoTraceEvent :: Documented NodeStartupInfo
-docNodeStartupInfoTraceEvent = Documented
-  [ DocMsg
-      ["NodeStartupInfo"]
-        []
-        "Startup information about this node, required for RTView\
+instance MetaTrace NodeStartupInfo where
+  namespaceFor NodeStartupInfo {}  =
+    Namespace [] ["NodeStartupInfo"]
+  severityFor  (Namespace _ ["NodeStartupInfo"]) _ =
+    Just Info
+  severityFor _ns _ =
+    Nothing
+  documentFor  (Namespace _ ["NodeStartupInfo"]) = Just
+    "Startup information about this node, required for RTView\
         \\n\
         \\n _suiEra_: Name of the current era. \
         \\n _suiSlotLength_: Slot length, in seconds. \
         \\n _suiEpochLength_: Epoch length, in slots. \
         \\n _suiSlotsPerKESPeriod_: KES period length, in slots."
-  ]
+  documentFor _ns =
+     Nothing
+  allNamespaces = [ Namespace [] ["NodeStartupInfo"]]

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

@@ -11,8 +11,8 @@ import           Cardano.Logging (LogFormatting)
 import           Cardano.Node.Queries (ConvertTxId, GetKESInfo (..), HasKESInfo (..),
                    HasKESMetricsData (..), LedgerQueries)
 
-import           Ouroboros.Consensus.Block (BlockProtocol, CannotForge,
-                   ForgeStateUpdateError, Header)
+import           Ouroboros.Consensus.Block (BlockProtocol, CannotForge, ForgeStateUpdateError,
+                   Header)
 import           Ouroboros.Consensus.HeaderValidation (OtherHeaderEnvelopeError)
 import           Ouroboros.Consensus.Ledger.Abstract (LedgerError)
 import           Ouroboros.Consensus.Ledger.Inspect (LedgerEvent, LedgerUpdate, LedgerWarning)
@@ -21,6 +21,7 @@ import           Ouroboros.Consensus.Protocol.Abstract (ValidationErr)
 import           Ouroboros.Consensus.Shelley.Ledger.Mempool (GenTx, TxId)
 
 
+
 -- | Tracing-related constraints for monitoring purposes.
 type TraceConstraints blk =
     ( ConvertTxId blk
@@ -52,4 +53,5 @@ type TraceConstraints blk =
     , LogFormatting (ValidationErr (BlockProtocol blk))
     , LogFormatting (CannotForge blk)
     , LogFormatting (ForgeStateUpdateError blk)
+
     )

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

@@ -26,6 +26,7 @@ import           Cardano.Node.Startup (NodeInfo, NodeStartupInfo, StartupTrace)
 import           Cardano.Logging.Resources
 import           Cardano.Node.Tracing.StateRep (NodeState)
 import           Cardano.Node.Tracing.Tracers.ConsensusStartupException
+                   (ConsensusStartupException (..))
 import           Cardano.Node.Tracing.Tracers.Peer (PeerT)
 
 data Tracers peer localPeer blk p2p = Tracers