trace-dispatcher: optimize core

trace-dispatcher/src/Cardano/Logging/Configuration.hs

@@ -77,41 +77,39 @@ maybeSilent :: forall m a. (MonadIO m) =>
   -> Bool
   -> Trace m a
   -> m (Trace m a)
-maybeSilent selectorFunc prefixNames isMetrics tr = do
+maybeSilent selectorFunc prefixNames isMetrics (Trace tr) = do
     ref  <- liftIO (newIORef Nothing)
     pure $ Trace $ T.arrow $ T.emit $ mkTrace ref
   where
     mkTrace ref (lc, Right a) = do
       silence <- liftIO $ readIORef ref
       if silence == Just True
         then pure ()
-        else T.traceWith (unpackTrace tr) (lc, Right a)
+        else T.traceWith tr (lc, Right a)
     mkTrace ref (lc, Left (Config c)) = do
       silence <- liftIO $ readIORef ref
       case silence of
         Nothing -> do
           let val = selectorFunc c (Namespace prefixNames [] :: Namespace a)
           liftIO $ writeIORef ref (Just val)
         Just _ -> pure ()
-      T.traceWith (unpackTrace tr) (lc,  Left (Config c))
+      T.traceWith tr (lc,  Left (Config c))
     mkTrace ref (lc, Left Reset) = do
       liftIO $ writeIORef ref Nothing
-      T.traceWith (unpackTrace tr) (lc,  Left Reset)
+      T.traceWith tr (lc,  Left Reset)
     mkTrace ref (lc, Left (Optimize s1 s2)) = do
       silence <- liftIO $ readIORef ref
       case silence of
         Just True -> liftIO $ if isMetrics
                                 then modifyIORef s2 (Set.insert prefixNames)
                                 else modifyIORef s1 (Set.insert prefixNames)
         _         -> pure ()
-      T.traceWith (unpackTrace tr) (lc,  Left (Optimize s1 s2))
+      T.traceWith tr (lc,  Left (Optimize s1 s2))
     mkTrace ref (lc, Left c@TCDocument {}) = do
       silence <- liftIO $ readIORef ref
       unless isMetrics
         (addSilent c silence)
-      T.traceWith (unpackTrace tr) (lc,  Left c)
-    -- mkTrace _ref (lc, Left other) =
-    --   T.traceWith (unpackTrace tr) (lc,  Left other)
+      T.traceWith tr (lc,  Left c)
 
 -- When all messages are filtered out, it is silent
 isSilentTracer :: forall a. MetaTrace a => TraceConfig -> Namespace a -> Bool

trace-dispatcher/src/Cardano/Logging/Trace.hs

@@ -6,23 +6,23 @@
 
 module Cardano.Logging.Trace (
     traceWith
+  , withLoggingContext
+
   , filterTrace
   , filterTraceMaybe
   , filterTraceBySeverity
-  , withLoggingContext
+  , filterTraceByPrivacy
+
   , setSeverity
   , withSeverity
-  , withSeverity'
   , privately
   , setPrivacy
   , withPrivacy
-  , withPrivacy'
   , allPublic
   , allConfidential
-  , filterTraceByPrivacy
   , setDetails
   , withDetails
-  , withDetails'
+
   , foldTraceM
   , foldMTraceM
   , foldMCondTraceM
@@ -42,7 +42,6 @@ import           Data.Maybe (isJust)
 import           Data.Text (Text)
 import           UnliftIO.MVar
 
-import           Cardano.Logging.TraceDispatcherMessage
 import           Cardano.Logging.Types
 
 -- | Adds a message object to a trace
@@ -175,41 +174,6 @@ withSeverity (Trace tr) = Trace $
         else (lc {lcSeverity = severityFor (Namespace [] (lcNSInner lc)
                                               :: Namespace a) Nothing}, cont)
 
--- | Sets privacy for the messages in this trace based on the MetaTrace class
--- Handles errors by sending traces to the trace system tracer
-withSeverity' :: forall m a.
-     (Monad m, MetaTrace a)
-  => (TraceDispatcherMessage -> m ())
-  -> Trace m a
-  -> m (Trace m a)
-withSeverity' errHdl (Trace tr) = do
-    pure $ Trace (T.arrow (T.emit
-      (\case
-        (lc, Right e) -> process lc (Right e)
-        (lc, Left c@(Config _)) -> process lc (Left c)
-        (lc, Left d@(TCDocument _ _)) -> process lc (Left d)
-        (lc, Left e) -> T.traceWith tr (lc, Left e))))
-
-  where
-    process :: LoggingContext -> Either TraceControl a -> m ()
-    process lc cont =
-      if isJust (lcSeverity lc)
-        then T.traceWith tr (lc,cont)
-        else
-          case severityFor
-                  (Namespace [] (lcNSInner lc) :: Namespace a)
-                  (case cont of
-                    Right v -> Just v
-                    Left _  -> Nothing) of
-            Just sev -> T.traceWith tr (lc {lcSeverity = Just sev}, cont)
-            Nothing -> do
-              T.traceWith tr (lc, cont)
-              let Namespace _ nsLegal = case allNamespaces :: [Namespace a] of
-                              (hd : _) -> hd
-                              _          -> Namespace []
-                                              ["Can't find legal namemespace"]
-              errHdl (UnknownNamespace (lcNSInner lc) nsLegal UKFSeverity)
-
 --- | Only processes messages further with a privacy greater then the given one
 filterTraceByPrivacy :: (Monad m) =>
      Maybe Privacy
@@ -264,42 +228,6 @@ withPrivacy (Trace tr) = Trace $
         else (lc {lcPrivacy = privacyFor (Namespace [] (lcNSInner lc)
                                               :: Namespace a) Nothing}, cont)
 
--- | Sets privacy for the messages in this trace based on the MetaTrace class
--- Handles errors by sending traces to the trace system tracer
-withPrivacy' :: forall m a.
-     (Monad m, MetaTrace a)
-  => (TraceDispatcherMessage -> m ())
-  -> Trace m a
-  -> m (Trace m a)
-withPrivacy' errHndl (Trace tr) = do
-    pure $ Trace (T.arrow (T.emit
-      (\case
-        (lc, Right e) -> process lc (Right e)
-        (lc, Left c@(Config _)) -> process lc (Left c)
-        (lc, Left d@(TCDocument _ _)) -> process lc (Left d)
-        (lc, Left e) -> T.traceWith tr (lc, Left e))))
-
-  where
-    process :: LoggingContext -> Either TraceControl a -> m ()
-    process lc cont =
-      if isJust (lcPrivacy lc)
-        then T.traceWith tr (lc,cont)
-        else
-          case privacyFor
-                  (Namespace [] (lcNSInner lc) :: Namespace a)
-                  (case cont of
-                    Right v -> Just v
-                    Left _  -> Nothing) of
-            Just pri -> T.traceWith tr (lc {lcPrivacy = Just pri}, cont)
-            Nothing -> do
-              T.traceWith tr (lc, cont)
-              let Namespace _ nsLegal = case allNamespaces :: [Namespace a] of
-                              (hd : _) -> hd
-                              _          -> Namespace []
-                                              ["Can't find legal namemespace"]
-              errHndl (UnknownNamespace (lcNSInner lc) nsLegal UKFPrivacy)
-
-
 -- | Sets detail level for the messages in this trace
 setDetails :: Monad m => DetailLevel -> Trace m a -> Trace m a
 setDetails p (Trace tr) = Trace $
@@ -332,41 +260,6 @@ withDetails (Trace tr) = Trace $
         else (lc {lcDetails = detailsFor (Namespace [] (lcNSInner lc)
                                               :: Namespace a) Nothing}, cont)
 
--- | Sets privacy for the messages in this trace based on the MetaTrace class
--- Handles errors by sending traces to the trace system tracer
-withDetails' :: forall m a.
-     (Monad m, MetaTrace a)
-  => (TraceDispatcherMessage -> m ())
-  -> Trace m a
-  -> m (Trace m a)
-withDetails' errHdl (Trace tr) = do
-    pure $ Trace (T.arrow (T.emit
-      (\case
-        (lc, Right e) -> process lc (Right e)
-        (lc, Left c@(Config _)) -> process lc (Left c)
-        (lc, Left d@(TCDocument _ _)) -> process lc (Left d)
-        (lc, Left e) -> T.traceWith tr (lc, Left e))))
-
-  where
-    process :: LoggingContext -> Either TraceControl a -> m ()
-    process lc cont =
-      if isJust (lcDetails lc)
-        then T.traceWith tr (lc,cont)
-        else
-          case detailsFor
-                  (Namespace [] (lcNSInner lc) :: Namespace a)
-                  (case cont of
-                    Right v -> Just v
-                    Left _  -> Nothing) of
-            Just dtl -> T.traceWith tr (lc {lcDetails = Just dtl}, cont)
-            Nothing -> do
-              T.traceWith tr (lc, cont)
-              let Namespace _ nsLegal = case allNamespaces :: [Namespace a] of
-                              (hd : _) -> hd
-                              _          -> Namespace []
-                                              ["Can't find legal namemespace"]
-              errHdl (UnknownNamespace (lcNSInner lc) nsLegal UKFDetails)
-
 -- | Folds the cata function with acc over a.
 -- Uses an MVar to store the state
 foldTraceM

trace-dispatcher/src/Cardano/Logging/Tracer/Composed.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -16,35 +16,16 @@ import           Cardano.Logging.Formatter
 import           Cardano.Logging.Trace
 import           Cardano.Logging.TraceDispatcherMessage
 import           Cardano.Logging.Types
+import qualified Control.Tracer as T
 
-
-import qualified Control.Tracer as NT
+import           Control.Monad (when)
 import           Data.IORef
 import qualified Data.List as L
-import           Data.Maybe (fromMaybe)
+import           Data.Maybe (fromMaybe, isNothing)
 import qualified Data.Set as Set
 import           Data.Text hiding (map)
 
 
-traceTracerInfo ::
-     Trace IO FormattedMessage
-  -> Trace IO FormattedMessage
-  -> ConfigReflection
-  -> IO ()
-traceTracerInfo trStdout trForward (ConfigReflection silentRef metricsRef) = do
-    internalTr <- backendsAndFormat
-                      trStdout
-                      trForward
-                      (Just [Forwarder, Stdout MachineFormat])
-                      (Trace NT.nullTracer)
-    silentSet <- readIORef silentRef
-    metricSet <- readIORef metricsRef
-    let silentList  = map (intercalate (singleton '.')) (Set.toList silentSet)
-    let metricsList = map (intercalate (singleton '.')) (Set.toList metricSet)
-    traceWith (withInnerNames (appendPrefixNames ["Reflection"] internalTr))
-              (TracerInfo silentList metricsList)
-    writeIORef silentRef Set.empty
-    writeIORef metricsRef Set.empty
 
 -- | Construct a tracer according to the requirements for cardano node.
 -- The tracer gets a 'name', which is appended to its namespace.
@@ -81,40 +62,63 @@ mkCardanoTracer' :: forall evt evt1.
   -> IO (Trace IO evt)
 mkCardanoTracer' trStdout trForward mbTrEkg tracerPrefix hook = do
 
-    ! internalTr <- fmap (appendPrefixNames ["Reflection"])
+    internalTr <- fmap (appendPrefixNames ["Reflection"])
                        (withBackendsFromConfig (backendsAndFormat trStdout trForward))
 
     -- handle the messages
-    ! messageTrace <- withBackendsFromConfig (backendsAndFormat trStdout trForward)
+    messageTrace <- withBackendsFromConfig (backendsAndFormat trStdout trForward)
                     >>= withLimitersFromConfig internalTr
-                    >>= addContextAndFilter internalTr
+                    >>= traceNamespaceErrors internalTr
+                    >>= addContextAndFilter
                     >>= maybeSilent isSilentTracer tracerPrefix False
                     >>= hook
 
-
     -- handle the metrics
-    ! metricsTrace <- (maybeSilent hasNoMetrics tracerPrefix True
+    metricsTrace <- (maybeSilent hasNoMetrics tracerPrefix True
                         . filterTrace (\ (_, v) -> not (Prelude.null (asMetrics v))))
                         (case mbTrEkg of
-                            Nothing -> Trace NT.nullTracer
+                            Nothing -> Trace T.nullTracer
                             Just ekgTrace -> metricsFormatter "Cardano" ekgTrace)
                     >>= hook
-    pure (messageTrace <> metricsTrace)
 
+    pure (messageTrace <> metricsTrace)
 
   where
-    -- TODO YUP: More flexible error handling
-    addContextAndFilter ::
+    addContextAndFilter :: Trace IO evt1 -> IO (Trace IO evt1)
+    addContextAndFilter tr = do
+      tr'  <- withDetailsFromConfig tr
+      tr'' <- filterSeverityFromConfig tr'
+      pure $ withDetails
+            $ withSeverity
+              $ withPrivacy
+                $ withInnerNames
+                  $ appendPrefixNames tracerPrefix tr''
+
+    traceNamespaceErrors ::
          Trace IO TraceDispatcherMessage
       -> Trace IO evt1
       -> IO (Trace IO evt1)
-    addContextAndFilter tri tr = do
-      tr' <- withDetailsFromConfig tr
-              >>= filterSeverityFromConfig
-              >>= withSeverity' (traceWith tri)
-              >>= withPrivacy' (traceWith tri)
-              >>= withDetails' (traceWith tri)
-      pure $ withInnerNames $ appendPrefixNames tracerPrefix tr'
+    traceNamespaceErrors internalTr (Trace tr) = do
+        pure $ Trace (T.arrow (T.emit
+          (\case
+            (lc, Right e) -> process lc (Right e)
+            (lc, Left e) -> T.traceWith tr (lc, Left e))))
+      where
+        process :: LoggingContext -> Either TraceControl evt1 -> IO ()
+        process lc cont = do
+          when (isNothing (lcPrivacy lc)) $
+                  traceWith
+                    internalTr
+                    (UnknownNamespace (lcNSPrefix lc) (lcNSInner lc) UKFPrivacy)
+          when (isNothing (lcSeverity lc)) $
+                  traceWith
+                    internalTr
+                    (UnknownNamespace (lcNSPrefix lc) (lcNSInner lc) UKFSeverity)
+          when (isNothing (lcDetails lc)) $
+                  traceWith
+                    internalTr
+                    (UnknownNamespace (lcNSPrefix lc) (lcNSInner lc) UKFDetails)
+          T.traceWith tr (lc, cont)
 
 backendsAndFormat ::
      LogFormatting a
@@ -140,11 +144,31 @@ backendsAndFormat trStdout trForward mbBackends _ =
                         = Just (machineFormatter' Nothing trStdout)
                         | otherwise = Nothing
     case mbForwardTrace <> mbStdoutTrace of
-      Nothing -> pure $ Trace NT.nullTracer
+      Nothing -> pure $ Trace T.nullTracer
       Just tr -> preFormatted backends' tr
 
+traceTracerInfo ::
+     Trace IO FormattedMessage
+  -> Trace IO FormattedMessage
+  -> ConfigReflection
+  -> IO ()
+traceTracerInfo trStdout trForward (ConfigReflection silentRef metricsRef) = do
+    internalTr <- backendsAndFormat
+                      trStdout
+                      trForward
+                      (Just [Forwarder, Stdout MachineFormat])
+                      (Trace T.nullTracer)
+    silentSet <- readIORef silentRef
+    metricSet <- readIORef metricsRef
+    let silentList  = map (intercalate (singleton '.')) (Set.toList silentSet)
+    let metricsList = map (intercalate (singleton '.')) (Set.toList metricSet)
+    traceWith (withInnerNames (appendPrefixNames ["Reflection"] internalTr))
+              (TracerInfo silentList metricsList)
+    writeIORef silentRef Set.empty
+    writeIORef metricsRef Set.empty
+
 -- A basic ttracer just for metrics
 mkMetricsTracer :: Maybe (Trace IO FormattedMessage) -> Trace IO FormattedMessage
 mkMetricsTracer mbTrEkg = case mbTrEkg of
-                          Nothing -> Trace NT.nullTracer
+                          Nothing -> Trace T.nullTracer
                           Just ekgTrace -> ekgTrace

trace-dispatcher/src/Cardano/Logging/Utils.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE PackageImports #-}
 
 module Cardano.Logging.Utils (
     runInLoop
@@ -9,7 +8,7 @@ module Cardano.Logging.Utils (
 
 import           Control.Concurrent (threadDelay)
 import           Control.Exception (SomeAsyncException (..), fromException, tryJust)
-import           "contra-tracer" Control.Tracer (showTracing, stdoutTracer, traceWith)
+import           Control.Tracer (stdoutTracer, traceWith)
 
 -- | Run monadic action in a loop. If there's an exception, it will re-run
 --   the action again, after pause that grows.
@@ -27,7 +26,7 @@ runInLoop action localSocket prevDelayInSecs =
       Just SomeAsyncException {} -> Nothing
       _ -> Just e
 
-  logTrace = traceWith $ showTracing stdoutTracer
+  logTrace = traceWith stdoutTracer
 
   currentDelayInSecs =
     if prevDelayInSecs < 60