Merge pull request #5437 from input-output-hk/jutaro/optimizeMuxTracer

mgmeier · web-flow · commit 8063de9354de · 2023-08-21T11:44:47.000Z
Optimize Mux tracer
diff --git a/cardano-node/cardano-node.cabal b/cardano-node/cardano-node.cabal
@@ -160,6 +160,7 @@ library
                       , ekg
                       , ekg-core
                       , filepath
+                      , formatting
                       , generic-data
                       , hostname
                       , io-classes >= 0.3
diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Consensus.hs
@@ -83,12 +83,12 @@ import           Ouroboros.Consensus.Util.Enclose
 
 instance (LogFormatting adr, Show adr) => LogFormatting (ConnectionId adr) where
   forMachine _dtal (ConnectionId local' remote) =
-    mconcat [ "connectionId" .= String (forHuman local'
+    mconcat [ "connectionId" .= String (showT local'
                                           <> " "
-                                          <> forHuman remote)
+                                          <> showT remote)
     ]
   forHuman (ConnectionId local' remote) =
-    "ConnectionId " <>  forHuman local' <> " " <> forHuman remote
+    "ConnectionId " <>  showT local' <> " " <> showT remote
 
 --------------------------------------------------------------------------------
 --   TraceLabelCreds peer a
diff --git a/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs b/cardano-node/src/Cardano/Node/Tracing/Tracers/Diffusion.hs
diff --git a/cardano-tracer/cardano-tracer.cabal b/cardano-tracer/cardano-tracer.cabal
@@ -280,6 +280,9 @@ test-suite cardano-tracer-test
   type:                 exitcode-stdio-1.0
   default-extensions:   OverloadedStrings
 
+  if os(windows)
+    buildable:          False
+
   hs-source-dirs:       test
 
   main-is:              cardano-tracer-test.hs
diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Send.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Notifications/Send.hs
@@ -16,6 +16,8 @@ import qualified Data.Text as T
 import           Data.Time.Clock (UTCTime)
 import           Data.Time.Format (defaultTimeLocale, formatTime)
 
+import           Cardano.Logging (showT)
+
 import           Cardano.Tracer.Handlers.RTView.Notifications.Email
 import           Cardano.Tracer.Handlers.RTView.Notifications.Types
 import           Cardano.Tracer.Types
diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/EKG.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/EKG.hs
@@ -12,11 +12,12 @@ import qualified Data.Map.Strict as M
 import           Data.Text (intercalate, isPrefixOf)
 import           Graphics.UI.Threepenny.Core (UI, liftIO)
 
+import           Cardano.Logging (showT)
+
 import           Cardano.Tracer.Environment
 import           Cardano.Tracer.Handlers.Metrics.Utils
 import           Cardano.Tracer.Handlers.RTView.UI.Utils
 import           Cardano.Tracer.Types
-import           Cardano.Tracer.Utils
 
 updateEKGMetrics :: TracerEnv -> UI ()
 updateEKGMetrics TracerEnv{teAcceptedMetrics} = do
diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Logs.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Logs.hs
@@ -17,7 +17,7 @@ import           Data.Time.Format (defaultTimeLocale, formatTime)
 import qualified Graphics.UI.Threepenny as UI
 import           Graphics.UI.Threepenny.Core
 
-import           Cardano.Logging (SeverityS (..))
+import           Cardano.Logging (SeverityS (..), showT)
 
 import           Cardano.Tracer.Environment
 import           Cardano.Tracer.Handlers.RTView.State.TraceObjects
diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Nodes.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Nodes.hs
@@ -35,6 +35,8 @@ import           Graphics.UI.Threepenny.Core
 import           Text.Printf (printf)
 import           Text.Read (readMaybe)
 
+import           Cardano.Logging (showT)
+
 import           Cardano.Tracer.Configuration
 import           Cardano.Tracer.Environment
 import           Cardano.Tracer.Handlers.Metrics.Utils
diff --git a/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Peers.hs b/cardano-tracer/src/Cardano/Tracer/Handlers/RTView/Update/Peers.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Cardano.Tracer.Handlers.RTView.Update.Peers
@@ -18,6 +18,8 @@ import qualified Data.Text as T
 import qualified Graphics.UI.Threepenny as UI
 import           Graphics.UI.Threepenny.Core
 
+import           Cardano.Logging (showT)
+
 import           Cardano.Node.Tracing.Peers
 
 import           Cardano.Tracer.Environment
@@ -27,7 +29,6 @@ import           Cardano.Tracer.Handlers.RTView.UI.Utils
 import           Cardano.Tracer.Handlers.RTView.Update.Utils
 import           Cardano.Tracer.Handlers.RTView.Utils
 import           Cardano.Tracer.Types
-import           Cardano.Tracer.Utils
 
 updateNodesPeers
   :: TracerEnv
diff --git a/cardano-tracer/src/Cardano/Tracer/Utils.hs b/cardano-tracer/src/Cardano/Tracer/Utils.hs
@@ -29,7 +29,6 @@ module Cardano.Tracer.Utils
   , nl
   , runInLoop
   , showProblemIfAny
-  , showT
   ) where
 
 #if MIN_VERSION_base(4,18,0)
@@ -54,6 +53,7 @@ import qualified Data.Map.Strict as M
 import qualified Data.Set as S
 import qualified Data.Text as T
 import           Data.Tuple.Extra (uncurry3)
+
 import           System.IO (hFlush, stdout)
 import           System.Mem.Weak (deRefWeak)
 import qualified System.Signal as S
@@ -208,9 +208,6 @@ nl = "\n"
 nl = "\r\n"
 #endif
 
-showT :: Show a => a -> T.Text
-showT = T.pack . show
-
 -- | If 'cardano-tracer' process is going to die (by receiving some system signal),
 --   we want to do something before it stops.
 beforeProgramStops :: IO () -> IO ()
diff --git a/trace-dispatcher/src/Cardano/Logging.hs b/trace-dispatcher/src/Cardano/Logging.hs
@@ -15,4 +15,5 @@ import           Cardano.Logging.Tracer.EKG as X
 import           Cardano.Logging.Tracer.Forward as X
 import           Cardano.Logging.Tracer.Standard as X
 import           Cardano.Logging.Types as X
+import           Cardano.Logging.Utils as X
 import           Control.Tracer as X hiding (Tracer, nullTracer, traceWith)
diff --git a/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs b/trace-dispatcher/src/Cardano/Logging/DocuGenerator.hs
@@ -25,38 +25,32 @@ module Cardano.Logging.DocuGenerator (
   , DocTracer
 ) where
 
+import           Prelude hiding (lines, unlines)
 
 import           Data.IORef (modifyIORef, newIORef, readIORef)
 import           Data.List (groupBy, intersperse, nub, sortBy)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe, mapMaybe)
-import           Data.Text (Text, pack, toLower)
-import qualified Data.Text as T
+import           Data.Text (Text, lines, split, toLower, unlines)
 import           Data.Text.Internal.Builder (toLazyText)
 import           Data.Text.Lazy (toStrict)
 import           Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton)
 import           Data.Time (getZonedTime)
 
 import           Cardano.Logging.Types
 import           Control.Monad.IO.Class (MonadIO, liftIO)
-import qualified Control.Tracer as T
+import qualified Control.Tracer as TR
 
+import           Cardano.Logging.Utils (showT)
 import           Trace.Forward.Utils.DataPoint (DataPoint (..))
 
-
-
 -- | Convenience function for adding a namespace prefix to a documented
 addDocumentedNamespace  :: [Text] -> Documented a -> Documented a
 addDocumentedNamespace  tl (Documented list) =
   Documented $ map
     (\ dm@DocMsg {} -> dm {dmNamespace = nsReplacePrefix (dmNamespace dm) tl})
     list
 
--- | Convenience function
-{-# INLINE showT #-}
-showT :: Show a => a -> Text
-showT = pack . show
-
 data DocuResult =
   DocuTracer Builder
   | DocuMetric Builder
@@ -294,7 +288,7 @@ documentTracersRun tracers = do
                             , ldPrivacyCoded  = privacyFor ns Nothing
                             , ldDetailsCoded  = detailsFor ns Nothing
                           }))
-            T.traceWith tr (emptyLoggingContext {lcNSInner = nsGetInner ns},
+            TR.traceWith tr (emptyLoggingContext {lcNSInner = nsGetInner ns},
                             Left (TCDocument idx dc)))
         nsIdx
 
@@ -303,7 +297,7 @@ documentTracersRun tracers = do
 docTracer :: MonadIO m =>
      BackendConfig
   -> Trace m FormattedMessage
-docTracer backendConfig = Trace $ T.arrow $ T.emit output
+docTracer backendConfig = Trace $ TR.arrow $ TR.emit output
   where
     output p@(_, Left TCDocument {}) =
       docIt backendConfig p
@@ -312,7 +306,7 @@ docTracer backendConfig = Trace $ T.arrow $ T.emit output
 docTracerDatapoint :: MonadIO m =>
      BackendConfig
   -> Trace m DataPoint
-docTracerDatapoint backendConfig = Trace $ T.arrow $ T.emit output
+docTracerDatapoint backendConfig = Trace $ TR.arrow $ TR.emit output
   where
     output p@(_, Left TCDocument {}) =
       docItDatapoint backendConfig p
@@ -530,7 +524,7 @@ generateTOC dt traces metrics datapoints =
         [] -> error "inpossible"
 
     splitToNS :: [Text] -> [Text]
-    splitToNS [sym] = T.split (== '.') sym
+    splitToNS [sym] = split (== '.') sym
     splitToNS other = other
 
 
@@ -562,4 +556,4 @@ accentuated :: Text -> Builder
 accentuated t = if t == ""
                   then fromText "\n"
                   else fromText "\n"
-                        <> fromText (T.unlines $ map ("> " <>) (T.lines t))
+                        <> fromText (unlines $ map ("> " <>) (lines t))
diff --git a/trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs b/trace-dispatcher/src/Cardano/Logging/TraceDispatcherMessage.hs
@@ -46,9 +46,9 @@ instance LogFormatting TraceDispatcherMessage where
     ". Suppressed " <> pack (show num) <> " messages."
   forHuman (RememberLimiting txt num) = "Frequency limiting still active for " <> txt <>
     ". Suppressed so far " <> pack (show num) <> " messages."
-  forHuman (UnknownNamespace nsUnknown nsLegal qk) = "Unknown namespace detected "
-    <> intercalate (singleton '.') nsUnknown <> ". Used for querying " <> (pack . show) qk
-    <> " a legal namespace would be " <> intercalate (singleton '.') nsLegal <> "."
+  forHuman (UnknownNamespace nsPrefixNS nsInnerNS qk) = "Unknown namespace detected "
+    <> intercalate (singleton '.') (nsPrefixNS ++ nsInnerNS)
+    <> ". Used for querying " <> (pack . show) qk <> "."
   forHuman (TracerInfo silent noMetrics allTracers) = "The tracing system has silent the following tracer,"
     <> " as they will never have any output according to the current config: "
     <> intercalate (singleton ' ') silent <> ". The following tracers will not emit metrics "
diff --git a/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs b/trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs
@@ -71,6 +71,7 @@ mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do
                       trForward
                       Nothing
                       (Trace T.nullTracer)
+                    >>= addContextAndFilter
 
     -- handle the messages
     !messageTrace <- withBackendsFromConfig (backendsAndFormat trStdout trForward)
@@ -92,7 +93,7 @@ mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do
     pure (messageTrace <> metricsTrace)
 
   where
-    addContextAndFilter :: Trace IO evt1 -> IO (Trace IO evt1)
+    addContextAndFilter :: MetaTrace a => Trace IO a -> IO (Trace IO a)
     addContextAndFilter tr = do
       tr'  <- withDetailsFromConfig tr
       tr'' <- filterSeverityFromConfig tr'
diff --git a/trace-dispatcher/src/Cardano/Logging/Utils.hs b/trace-dispatcher/src/Cardano/Logging/Utils.hs
@@ -1,14 +1,21 @@
 {-# LANGUAGE LambdaCase #-}
 
+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
+-- showHex needs to be a show instance on ghc8, but not any more on ghc9
+
 module Cardano.Logging.Utils (
     runInLoop
   , uncurry3
   , mapSnd
+  , showT
+  , showTHex
   ) where
 
 import           Control.Concurrent (threadDelay)
 import           Control.Exception (SomeAsyncException (..), fromException, tryJust)
 import           Control.Tracer (stdoutTracer, traceWith)
+import qualified Data.Text as T
+import           Numeric (showHex)
 
 -- | Run monadic action in a loop. If there's an exception, it will re-run
 --   the action again, after pause that grows.
@@ -39,3 +46,13 @@ uncurry3 f (a,b,c) = f a b c
 
 mapSnd :: (a -> b) -> (c, a) -> (c, b)
 mapSnd f (x,y) = (x,f y)
+
+-- | Convenience function
+{-# INLINE showT #-}
+showT :: Show a => a -> T.Text
+showT = T.pack . show
+
+-- | Convenience function
+{-# INLINE showTHex #-}
+showTHex :: (Integral a, Show a) => a -> T.Text
+showTHex i = T.pack (showHex i [])
diff --git a/trace-dispatcher/trace-dispatcher.cabal b/trace-dispatcher/trace-dispatcher.cabal
@@ -13,14 +13,15 @@ maintainer:             operations@iohk.io
 license:                Apache-2.0
 license-files:          LICENSE
                         NOTICE
-extra-source-files:     CHANGELOG.md
+extra-doc-files:        CHANGELOG.md
                         README.md
                         doc/trace-dispatcher.md
 
 common project-config
   default-language:     Haskell2010
 
 library
+  import:               project-config
   hs-source-dirs:     src
   exposed-modules:    Cardano.Logging
                       Cardano.Logging.Configuration
@@ -129,6 +130,7 @@ executable trace-dispatcher-examples
                         -Wno-incomplete-patterns
 
 test-suite trace-dispatcher-test
+  import:              project-config
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             trace-dispatcher-test.hs
diff --git a/trace-forward/trace-forward.cabal b/trace-forward/trace-forward.cabal
@@ -30,7 +30,6 @@ common project-config
                         -Wpartial-fields
                         -Wredundant-constraints
                         -Wunused-packages
-                        -fprof-auto
 
 library
   import:               project-config
