Merge remote-tracking branch 'upstream/master'

Author: NanuIjaz

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

@@ -8,15 +8,11 @@
 
 module Cardano.Node.Tracing.Consistency
   ( getAllNamespaces
-  , asNSLookup
-  , checkConfiguration
-  , checkConfiguration'
+  , checkNodeTraceConfiguration
+  , checkNodeTraceConfiguration'
   ) where
 
 import           Control.Exception (SomeException)
-import           Data.Foldable (foldl')
-import qualified Data.Map.Strict as Map
-import           Data.Maybe (mapMaybe)
 import qualified Data.Text as T
 import           Network.Mux (MuxTrace (..), WithMuxBearer (..))
 import qualified Network.Socket as Socket
@@ -30,8 +26,7 @@ import qualified Cardano.Node.Tracing.StateRep as SR
 import           Cardano.Node.Tracing.Tracers.BlockReplayProgress
 import           Cardano.Node.Tracing.Tracers.Consensus
 import           Cardano.Node.Tracing.Tracers.Diffusion ()
--- import           Cardano.Node.Tracing.Tracers.ForgingThreadStats (ForgeThreadStats,
---                    forgeThreadStats, ForgingStats)
+
 import           Cardano.Node.Handlers.Shutdown (ShutdownTrace)
 import           Cardano.Node.Startup
 import           Cardano.Node.Tracing.Tracers.KESInfo ()
@@ -96,82 +91,30 @@ import           Ouroboros.Network.Subscription.Worker (SubscriptionTrace (..))
 import           Ouroboros.Network.TxSubmission.Inbound (TraceTxSubmissionInbound)
 import           Ouroboros.Network.TxSubmission.Outbound (TraceTxSubmissionOutbound)
 
--- | A data structure for the lookup of namespaces as nested maps
-newtype NSLookup = NSLookup (Map.Map T.Text NSLookup)
-  deriving Show
 
--- | Warniings as a list of text
-type NSWarnings = [T.Text]
 
 -- | Check the configuration in the given file.
 -- If there is no configuration in the file check the standard configuration
 -- An empty return list means, everything is well
-checkConfiguration ::
+checkNodeTraceConfiguration ::
      FilePath
   -> IO NSWarnings
-checkConfiguration configFileName = do
-    trConfig           <- readConfigurationWithDefault configFileName defaultCardanoConfig
-    pure (checkConfiguration' trConfig)
+checkNodeTraceConfiguration configFileName =
+  checkTraceConfiguration
+    configFileName
+    defaultCardanoConfig
+    getAllNamespaces
 
-checkConfiguration' ::
+-- | Check the configuration in the given file.
+-- If there is no configuration in the file check the standard configuration
+-- An empty return list means, everything is well
+checkNodeTraceConfiguration' ::
      TraceConfig
   -> NSWarnings
-checkConfiguration' trConfig =
-    let namespaces     = Map.keys (tcOptions trConfig)
-        (nsLookup, systemWarnings) = asNSLookup getAllNamespaces
-        configWarnings = mapMaybe (checkNamespace nsLookup) namespaces
-        allWarnings    = map ("System namespace error: "<>) systemWarnings ++
-                           map ("Config namespace error: " <>) configWarnings
-    in allWarnings
-
--- | Check if a single namespace is legal. Returns just a warning test,
--- if this is not the case
-checkNamespace :: NSLookup -> [T.Text] -> Maybe T.Text
-checkNamespace nsLookup ns = go nsLookup ns
-  where
-    go :: NSLookup -> [T.Text] -> Maybe T.Text
-    go _ [] = Nothing
-    go (NSLookup l) (nshd : nstl) = case Map.lookup nshd l of
-                                      Nothing -> Just ("Illegal namespace "
-                                                        <> T.intercalate "." ns)
-                                      Just l2 -> go l2 nstl
-
--- | Builds a namespace lookup structure from a list of namespaces
--- Warns if namespaces are not unique, and if a namespace is a subnamespace
--- of other namespaces
-asNSLookup :: [[T.Text]] -> (NSLookup, NSWarnings)
-asNSLookup = foldl' (fillLookup []) (NSLookup Map.empty, [])
-  where
-    fillLookup :: [T.Text] -> (NSLookup, NSWarnings) -> [T.Text] -> (NSLookup, NSWarnings)
-    fillLookup _nsFull (NSLookup nsl, nsw)  [] = (NSLookup nsl, nsw)
-    fillLookup nsFull (NSLookup nsl, nsw) (ns1 : nstail) =
-      case Map.lookup ns1 nsl of
-        Nothing   ->  let nsNew = Map.empty
-                          (NSLookup nsl2, nsw2) = fillLookup
-                                                    (nsFull <> [ns1])
-                                                    (NSLookup nsNew, [])
-                                                    nstail
-                          res = NSLookup (Map.insert ns1 (NSLookup nsl2) nsl)
-                          newWarnings =  nsw <> nsw2
-                      in (res, newWarnings)
-        Just (NSLookup nsm)
-                  ->  let (NSLookup nsl2, nsw2) = fillLookup
-                                                  (nsFull <> [ns1])
-                                                  (NSLookup nsm, [])
-                                                  nstail
-                          res = NSLookup (Map.insert ns1 (NSLookup nsl2) nsl)
-                          condWarning = if null nstail
-                                          then
-                                            if Map.null nsm
-                                              then Just ("Duplicate namespace "
-                                                        <> T.intercalate "." (nsFull <> [ns1]))
-                                              else Just ("Inner namespace duplicate "
-                                                        <> T.intercalate "." (nsFull <> [ns1]))
-                                          else Nothing
-                          newWarnings = case condWarning of
-                                           Nothing -> nsw <> nsw2
-                                           Just w  -> w : (nsw <> nsw2)
-                      in (res, newWarnings)
+checkNodeTraceConfiguration' trConfig =
+  checkTraceConfiguration'
+    trConfig
+    getAllNamespaces
 
 
 -- | Returns a list of all namepsaces from all tracers
@@ -212,8 +155,6 @@ getAllNamespaces =
                                                       remotePeer
                                                       (BlockFetch.TraceFetchClientState (Header blk)))])
 
-    -- TODO Yup
-    -- blockFetchClientMetricsTr <- do
         blockFetchServerNS = map (nsGetComplete . nsReplacePrefix ["BlockFetch", "Server"])
                     (allNamespaces :: [Namespace (TraceBlockFetchServerEvent blk)])
 

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

@@ -37,8 +37,7 @@ import           Cardano.Node.Tracing.Tracers.BlockReplayProgress
 import           Cardano.Node.Tracing.Tracers.ChainDB
 import           Cardano.Node.Tracing.Tracers.Consensus
 import           Cardano.Node.Tracing.Tracers.Diffusion ()
--- import           Cardano.Node.Tracing.Tracers.ForgingThreadStats (ForgeThreadStats,
---                    forgeThreadStats, ForgingStats)
+import           Cardano.Node.Tracing.Tracers.ForgingThreadStats (ForgeThreadStats)
 import           Cardano.Node.Tracing.Tracers.KESInfo ()
 import           Cardano.Node.Tracing.Tracers.NodeToClient ()
 import           Cardano.Node.Tracing.Tracers.NodeToNode ()
@@ -280,13 +279,13 @@ docTracers configFileName outputFileName _ _ _ = do
                   remotePeer
                   (BlockFetch.TraceFetchClientState (Header blk))))
 
-    -- TODO Yup
-    -- blockFetchClientMetricsTr <- do
-    --         foldMTraceM calculateBlockFetchClientMetrics initialClientMetrics
-    --             (metricsFormatter ""
-    --               (mkMetricsTracer mbTrEKG))
-    -- clientMetricsDoc <- documentTracer (blockFetchClientMetricsTr ::
-    --    Trace IO ClientMetrics)
+    blockFetchClientMetricsTr <- mkCardanoTracer
+                trBase trForward mbTrEKG
+                ["BlockFetch", "Client"]
+
+    configureTracers configReflection trConfig [blockFetchClientMetricsTr]
+    blockFetchClientMetricsDoc <- documentTracer (blockFetchClientMetricsTr ::
+        Trace IO ClientMetrics)
 
     blockFetchServerTr  <- mkCardanoTracer
                 trBase trForward mbTrEKG
@@ -341,14 +340,13 @@ docTracers configFileName outputFileName _ _ _ = do
     forgeTrDoc <- documentTracer (forgeTr ::
       Trace IO (ForgeTracerType blk))
 
-    -- TODO YUP
-    -- forgeTr' <-  mkCardanoTracer'
-    --             trBase trForward mbTrEKG
-    --             ["Forge", "ThreadStats"]
-    --             forgeThreadStats
-    -- configureTracers configReflection trConfig [forgeTr']
-    -- forgeThreadStatsTrDoc <- documentTracer' forgeThreadStats (forgeTr' ::
-    --   Trace IO (ForgeTracerType blk))
+
+    forgeTr' <-  mkCardanoTracer
+                trBase trForward mbTrEKG
+                ["Forge", "ThreadStats"]
+    configureTracers configReflection trConfig [forgeTr']
+    forgeThreadStatsTrDoc <- documentTracer (forgeTr' ::
+      Trace IO ForgeThreadStats)
 
     blockchainTimeTr <- mkCardanoTracer
                 trBase trForward mbTrEKG
@@ -661,6 +659,14 @@ docTracers configFileName outputFileName _ _ _ = do
     dtAcceptPolicyTrDoc <- documentTracer (dtAcceptPolicyTr ::
       Trace IO NtN.AcceptConnectionsPolicyTrace)
 
+    internalTr <-  mkCardanoTracer
+                trBase trForward mbTrEKG
+                ["Reflection"]
+    configureTracers configReflection trConfig [internalTr]
+    internalTrDoc <- documentTracer (internalTr ::
+      Trace IO TraceDispatcherMessage)
+
+
     let bl =   nodeInfoDpDoc
             <> nodeStartupInfoDpDoc
             <> stateTrDoc
@@ -676,14 +682,15 @@ docTracers configFileName outputFileName _ _ _ = do
             <> chainSyncServerBlockTrDoc
             <> blockFetchDecisionTrDoc
             <> blockFetchClientTrDoc
+            <> blockFetchClientMetricsDoc
             <> blockFetchServerTrDoc
             <> forgeKESInfoTrDoc
             <> txInboundTrDoc
             <> txOutboundTrDoc
             <> localTxSubmissionServerTrDoc
             <> mempoolTrDoc
             <> forgeTrDoc
---            <> forgeThreadStatsTrDoc
+            <> forgeThreadStatsTrDoc
             <> blockchainTimeTrDoc
 -- NodeToClient
             <> keepAliveClientTrDoc
@@ -727,6 +734,8 @@ docTracers configFileName outputFileName _ _ _ = do
             <> dtErrorPolicyTrDoc
             <> dtLocalErrorPolicyTrDoc
             <> dtAcceptPolicyTrDoc
+-- Internal tracer
+            <> internalTrDoc
 
     res <- docuResultsToText bl trConfig
     T.writeFile outputFileName res

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

@@ -21,7 +21,7 @@ import           Control.Monad (unless)
 import           Data.Proxy (Proxy (..))
 
 import           Cardano.Logging
-import           Cardano.Node.Tracing.Consistency (checkConfiguration')
+import           Cardano.Node.Tracing.Consistency (checkNodeTraceConfiguration')
 import           Cardano.Node.Tracing.Formatting ()
 import           Cardano.Node.Tracing.Tracers.BlockReplayProgress
 import           Cardano.Node.Tracing.Tracers.ChainDB
@@ -165,7 +165,7 @@ mkDispatchTracers nodeKernel trBase trForward mbTrEKG trDataPoint trConfig enabl
 
     traceTracerInfo trBase trForward configReflection
 
-    let warnings = checkConfiguration' trConfig
+    let warnings = checkNodeTraceConfiguration' trConfig
     unless (null warnings) $
       traceConfigWarnings trBase trForward warnings
 

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

@@ -968,31 +968,31 @@ instance MetaTrace (ChainDB.TraceInitChainSelEvent blk) where
 
   severityFor (Namespace _ ["InitalChainSelected"]) _ = Just Info
   severityFor (Namespace _ ["StartedInitChainSelection"]) _ = Just Info
-  severityFor (Namespace out ("InitChainSelValidation" : tl))
+  severityFor (Namespace out ("Validation" : tl))
                             (Just (ChainDB.InitChainSelValidation ev')) =
     severityFor (Namespace out tl) (Just ev')
-  severityFor (Namespace out ("InitChainSelValidation" : tl)) Nothing =
+  severityFor (Namespace out ("Validation" : tl)) Nothing =
     severityFor (Namespace out tl ::
       Namespace (ChainDB.TraceValidationEvent blk)) Nothing
   severityFor _ _ = Nothing
 
-  privacyFor (Namespace out ("InitChainSelValidation" : tl))
+  privacyFor (Namespace out ("Validation" : tl))
               (Just (ChainDB.InitChainSelValidation ev')) =
     privacyFor (Namespace out tl) (Just ev')
-  privacyFor (Namespace out ("InitChainSelValidation" : tl)) Nothing =
+  privacyFor (Namespace out ("Validation" : tl)) Nothing =
     privacyFor (Namespace out tl ::
       Namespace (ChainDB.TraceValidationEvent blk)) Nothing
   privacyFor _ _ = Just Public
 
-  detailsFor (Namespace out ("InitChainSelValidation" : tl))
+  detailsFor (Namespace out ("Validation" : tl))
               (Just (ChainDB.InitChainSelValidation ev')) =
     detailsFor (Namespace out tl) (Just ev')
-  detailsFor (Namespace out ("InitChainSelValidation" : tl)) Nothing =
+  detailsFor (Namespace out ("Validation" : tl)) Nothing =
     detailsFor (Namespace out tl ::
       Namespace (ChainDB.TraceValidationEvent blk)) Nothing
   detailsFor _ _ = Just DNormal
 
-  metricsDocFor (Namespace out ("InitChainSelValidation" : tl)) =
+  metricsDocFor (Namespace out ("Validation" : tl)) =
     metricsDocFor (Namespace out tl :: Namespace (ChainDB.TraceValidationEvent blk))
   metricsDocFor _ = []
 
@@ -1002,7 +1002,7 @@ instance MetaTrace (ChainDB.TraceInitChainSelEvent blk) where
     [ "A garbage collection for the given 'SlotNo' was scheduled to happen"
     , " at the given time."
     ]
-  documentFor (Namespace o ("InitChainSelValidation" : tl)) =
+  documentFor (Namespace o ("Validation" : tl)) =
      documentFor (Namespace o tl :: Namespace (ChainDB.TraceValidationEvent blk))
   documentFor _ = Nothing
 

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

@@ -346,6 +346,23 @@ instance LogFormatting ClientMetrics where
              else msgs
       else []
 
+instance MetaTrace ClientMetrics where
+  namespaceFor _ = Namespace [] ["ClientMetrics"]
+  severityFor _ _ = Just Info
+  documentFor _ = Just ""
+
+  metricsDocFor (Namespace _ ["ClientMetrics"]) =
+      [ ("Blockfetch.Client.Blockdelay", "")
+      , ("Blockfetch.Client.Blockdelay.cdfOne", "")
+      , ("Blockfetch.Client.Blockdelay.cdfThree", "")
+      , ("Blockfetch.Client.Blockdelay.cdfFive", "")
+      ]
+  metricsDocFor _ = []
+
+  allNamespaces = [
+          Namespace [] ["ClientMetrics"]
+        ]
+
 initialClientMetrics :: ClientMetrics
 initialClientMetrics =
     ClientMetrics

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

@@ -64,9 +64,27 @@ instance LogFormatting ForgeThreadStats where
     , IntM "Forge.NodeIsLeaderNum"    (fromIntegral ftsNodeIsLeaderNum)
     , IntM "Forge.BlocksForgedNum"    (fromIntegral ftsBlocksForgedNum)
     , IntM "Forge.SlotsMissed"        (fromIntegral ftsSlotsMissedNum)
-    , IntM "Forge.LastSlot"           (fromIntegral ftsLastSlot)
     ]
 
+instance MetaTrace ForgeThreadStats where
+    namespaceFor ForgeThreadStats {} = Namespace [] ["ForgeThreadStats"]
+
+    severityFor _ _ = Just Info
+
+    documentFor _ = Just ""
+
+    metricsDocFor _ =
+      [("Forge.NodeCannotForgeNum",
+        "How many times was this node unable to forge [a block]?")
+      ,("Forge.NodeIsLeaderNum",
+        "How many times was this node slot leader?")
+      ,("Forge.BlocksForgedNum",
+        "How many blocks did this node forge?")
+      ,("Forge.SlotsMissed",
+        "How many slots did this node miss?")
+      ]
+
+    allNamespaces = [Namespace [] ["ForgeThreadStats"]]
 
 emptyForgeThreadStats :: ForgeThreadStats
 emptyForgeThreadStats = ForgeThreadStats 0 0 0 0 0
@@ -120,13 +138,13 @@ instance MetaTrace ForgingStats where
 
     metricsDocFor _ =
       [("Forge.NodeCannotForgeNum",
-        "How many times this node could not forge?")
+        "How many times was this node unable to forge [a block]?")
       ,("Forge.NodeIsLeaderNum",
-        "How many times this node was leader?")
+        "How many times was this node slot leader?")
       ,("Forge.BlocksForgedNum",
-        "How many blocks did forge in this node?")
+        "How many blocks did this node forge?")
       ,("Forge.SlotsMissed",
-        "How many slots were missed in this node?")
+        "How many slots did this node miss?")
       ,("Forge.LastSlot",
         "")
       ]

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

@@ -383,7 +383,7 @@ instance MetaTrace  (StartupTrace blk) where
   documentFor (Namespace [] ["ShelleyBased"]) = Just $ mconcat
     [ "bisEra is the current era, e.g. \"Shelley\", \"Allegra\", \"Mary\" "
     , "or \"Alonzo\". "
-    , "\n_bisSystemStartTime_: TODO JNF "
+    , "\n_bisSystemStartTime_: "
     , "\n_bisSlotLength_: gives the length of a slot as time interval. "
     , "\n_bisEpochLength_: gives the number of slots which forms an epoch. "
     , "\n_bisSlotsPerKESPeriod_: gives the slots per KES period."

cardano-node/test/Test/Cardano/Tracing/NewTracing/Consistency.hs

@@ -9,7 +9,7 @@ import qualified Hedgehog as H
 import qualified Hedgehog.Extras.Test.Base as H.Base
 import           Hedgehog.Internal.Property (PropertyName (PropertyName))
 
-import           Cardano.Node.Tracing.Consistency (checkConfiguration)
+import           Cardano.Node.Tracing.Consistency (checkNodeTraceConfiguration)
 
 tests :: IO Bool
 tests = H.checkSequential
@@ -32,7 +32,7 @@ goldenTestJSON :: [Text] -> FilePath -> Property
 goldenTestJSON expectedOutcome goldenFileBaseName =
     H.withTests 1 $ H.withShrinks 0 $ H.property $ do
       goldenFp    <- H.Base.note $ addPrefix goldenFileBaseName
-      actualValue <- liftIO $ checkConfiguration goldenFp
+      actualValue <- liftIO $ checkNodeTraceConfiguration goldenFp
       actualValue H.=== expectedOutcome