Basic cardano tracer

cardano-node/src/Cardano/TraceDispatcher/Tracers.hs

@@ -24,6 +24,7 @@ import           Network.Mux (MuxTrace (..), WithMuxBearer (..))
 import qualified Network.Socket as Socket
 
 import           Cardano.Logging
+import qualified "trace-dispatcher" Control.Tracer as NT
 import           Cardano.Prelude hiding (trace)
 import           Cardano.TraceDispatcher.ChainDB.Combinators
 import           Cardano.TraceDispatcher.ChainDB.Docu
@@ -106,7 +107,7 @@ import           Ouroboros.Network.TxSubmission.Outbound
 
 type Peer = NtN.ConnectionId Socket.SockAddr
 
-mkCardanoTracer ::
+mkCardanoTracer :: forall evt.
      LogFormatting evt
   => Text
   -> (evt -> [Text])
@@ -116,33 +117,54 @@ mkCardanoTracer ::
   -> Trace IO FormattedMessage
   -> Maybe (Trace IO FormattedMessage)
   -> IO (Trace IO evt)
-mkCardanoTracer name namesFor severityFor privacyFor trStdout trForward mbTrEkg = do
-  tr1 <- humanFormatter True "Cardano" trStdout
-  tr2' <- forwardFormatter "Cardano" trForward
-  let tr2 = filterTraceByPrivacy (Just Public) tr2'
-  tr3 <- filterSeverityFromConfig
-            (tr1 <> tr2)
-  case mbTrEkg of
-    Nothing ->
-      pure
-        $ withNamesAppended namesFor
-          $ appendName name
-            $ appendName "Node"
-              $ withSeverity severityFor
-                $ withPrivacy privacyFor
-                  tr3
+mkCardanoTracer name namesFor severityFor privacyFor
+  trStdout trForward mbTrEkg = do
+    tr <- withBackendsAndFormattingFromConfig routeAndFormat
+    transformer tr
+  where
+    transformer :: Trace IO evt -> IO (Trace IO evt)
+    transformer t = do
+      t'  <- filterSeverityFromConfig t
+      t'' <- withDetailsFromConfig t'
+      pure $ withNamesAppended namesFor
+            $ appendName name
+              $ appendName "Node"
+                $ withSeverity severityFor
+                  $ withPrivacy privacyFor
+                    t''
+    routeAndFormat ::
+         Maybe [Backend]
+      -> Trace m x
+      -> IO (Trace IO evt)
+    routeAndFormat mbBackends _ =
+      let backends = case mbBackends of
+                        Just b -> b
+                        Nothing -> [EKGBackend, Forwarder, Stdout HumanFormat]
+      in do
+        mbEkgTrace     <- case mbTrEkg of
+                            Nothing -> pure Nothing
+                            Just ekgTrace ->
+                              if elem EKGBackend backends
+                                then liftM Just
+                                      (metricsFormatter "Cardano" ekgTrace)
+                                else pure Nothing
+        mbForwardTrace <- if elem Forwarder backends
+                            then liftM (Just . filterTraceByPrivacy (Just Public))
+                                  (forwardFormatter "Cardano" trForward)
+                            else pure Nothing
+        mbStdoutTrace  <-  if elem (Stdout HumanFormat) backends
+                            then liftM Just
+                                (humanFormatter True "Cardano" trStdout)
+                            else if elem (Stdout MachineFormat) backends
+                              then liftM Just
+                                (machineFormatter "Cardano" trStdout)
+                              else pure Nothing
+        case mbEkgTrace <> mbForwardTrace <> mbStdoutTrace of
+          Nothing -> pure $ Trace NT.nullTracer
+          Just tr -> pure tr
+
+
 
-    Just trEkg -> do
-      tr4 <- metricsFormatter "Cardano" trEkg
-      tr5 <- filterSeverityFromConfig
-                (tr1 <> tr2 <> tr4)
-      pure
-        $ withNamesAppended namesFor
-          $ appendName name
-            $ appendName "Node"
-              $ withSeverity severityFor
-                $ withPrivacy privacyFor
-                  tr5
 
 mkStandardTracerSimple ::
      LogFormatting evt
@@ -185,7 +207,6 @@ mkDispatchTracers
   -> IO (Tracers peer localPeer blk)
 mkDispatchTracers _blockConfig (TraceDispatcher _trSel) _tr _nodeKern _ekgDirect
   trBase trForward mbTrEKG trConfig = do
-    trace ("traceConfig " <> show trConfig) $ pure ()
     cdbmTr <- mkCardanoTracer
                 "ChainDB"
                 namesForChainDBTraceEvents

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

@@ -10,6 +10,8 @@ module Cardano.Logging.Configuration
   ( configureTracers
   , withNamespaceConfig
   , filterSeverityFromConfig
+  , withDetailsFromConfig
+  , withBackendsAndFormattingFromConfig
   , readConfiguration
   ) where
 
@@ -27,7 +29,7 @@ import           Data.Text (Text, split)
 import           Data.Yaml
 import           GHC.Generics
 
-import           Cardano.Logging.Trace (filterTraceBySeverity)
+import           Cardano.Logging.Trace (filterTraceBySeverity, setDetails)
 import           Cardano.Logging.Types
 
 data TraceOptionSeverity = TraceOptionSeverity {
@@ -140,12 +142,12 @@ configureTracers config (Documented documented) tracers = do
 
 -- | Take a selector function, and a function from trace to trace with
 --   this selector to make a trace transformer with a config value
-withNamespaceConfig :: forall m a b. (MonadIO m, Ord b, Show b) =>
+withNamespaceConfig :: forall m a b c. (MonadIO m, Ord b) =>
      (TraceConfig -> Namespace -> b)
-  -> (Maybe b -> Trace m a -> Trace m a)
-  -> Trace m a
+  -> (Maybe b -> Trace m c -> m (Trace m a))
+  -> Trace m c
   -> m (Trace m a)
-withNamespaceConfig extract needsConfigFunc tr = do
+withNamespaceConfig extract withConfig tr = do
     ref  <- liftIO (newIORef (Left (Map.empty, Nothing)))
     pure $ Trace $ T.arrow $ T.emit $ mkTrace ref
   where
@@ -156,21 +158,23 @@ withNamespaceConfig extract needsConfigFunc tr = do
     mkTrace ref (lc, Nothing, a) = do
       eitherConf <- liftIO $ readIORef ref
       case eitherConf of
-        Right val ->
+        Right val -> do
+          tt <- withConfig (Just val) tr
           T.traceWith
-            (unpackTrace $ needsConfigFunc (Just val) tr) (lc, Nothing, a)
+            (unpackTrace tt) (lc, Nothing, a)
         Left (cmap, Just v) ->
           case Map.lookup (lcNamespace lc) cmap of
-                Just val -> T.traceWith
-                              (unpackTrace $ needsConfigFunc (Just val) tr)
-                              (lc, Nothing, a)
-                Nothing  -> T.traceWith
-                              (unpackTrace $ needsConfigFunc (Just v) tr)
-                              (lc, Nothing, a)
+                Just val -> do
+                  tt <- withConfig (Just val) tr
+                  T.traceWith (unpackTrace tt) (lc, Nothing, a)
+                Nothing  -> do
+                  tt <- withConfig (Just v) tr
+                  T.traceWith (unpackTrace tt) (lc, Nothing, a)
         Left (_cmap, Nothing) -> error ("Missing configuration " <> show (lcNamespace lc))
     mkTrace ref (lc, Just Reset, a) = do
       liftIO $ writeIORef ref (Left (Map.empty, Nothing))
-      T.traceWith (unpackTrace $ needsConfigFunc Nothing tr) (lc, Just Reset, a)
+      tt <- withConfig Nothing tr
+      T.traceWith (unpackTrace tt) (lc, Just Reset, a)
 
     mkTrace ref (lc, Just (Config c), m) = do
       let ! val = extract c (lcNamespace lc)
@@ -182,14 +186,13 @@ withNamespaceConfig extract needsConfigFunc tr = do
               liftIO
                   $ writeIORef ref
                   $ Left (Map.insert (lcNamespace lc) val cmap, Nothing)
-              T.traceWith
-                (unpackTrace $ needsConfigFunc (Just val) tr)
-                (lc, Just (Config c), m)
+              tt <- withConfig (Just val) tr
+              T.traceWith (unpackTrace tt) (lc, Just (Config c), m)
             Just v  -> do
               if v == val
-                then T.traceWith
-                      (unpackTrace $ needsConfigFunc (Just val) tr)
-                      (lc, Just (Config c), m)
+                then do
+                  tt <- withConfig (Just val) tr
+                  T.traceWith (unpackTrace tt) (lc, Just (Config c), m)
                 else error $ "Inconsistent trace configuration with context "
                                   ++ show (lcNamespace lc)
         Right _val -> error $ "Trace not reset before reconfiguration (1)"
@@ -206,9 +209,8 @@ withNamespaceConfig extract needsConfigFunc tr = do
                       pure ()
             [val]  -> do
                         liftIO $ writeIORef ref $ Right val
-                        T.traceWith
-                          (unpackTrace $ needsConfigFunc (Just val) tr)
-                          (lc, Just Optimize, m)
+                        tt <- withConfig (Just val) tr
+                        T.traceWith (unpackTrace tt) (lc, Just Optimize, m)
             _      -> let decidingDict =
                             foldl
                               (\acc e -> Map.insertWith (+) e (1 :: Int) acc)
@@ -220,9 +222,8 @@ withNamespaceConfig extract needsConfigFunc tr = do
                           newmap = Map.filter (/= mostCommon) cmap
                       in do
                         liftIO $ writeIORef ref (Left (newmap, Just mostCommon))
-                        T.traceWith
-                          (unpackTrace $ needsConfigFunc Nothing tr)
-                          (lc, Just Optimize, m)
+                        tt <- withConfig Nothing tr
+                        T.traceWith (unpackTrace tt) (lc, Just Optimize, m)
         Right _val -> error $ "Trace not reset before reconfiguration (3)"
                             ++ show (lcNamespace lc)
         Left (_cmap, Just _v) ->
@@ -233,7 +234,29 @@ withNamespaceConfig extract needsConfigFunc tr = do
 filterSeverityFromConfig :: (MonadIO m) =>
      Trace m a
   -> m (Trace m a)
-filterSeverityFromConfig = withNamespaceConfig getSeverity filterTraceBySeverity
+filterSeverityFromConfig =
+    withNamespaceConfig getSeverity (\ a b -> pure $ filterTraceBySeverity a b)
+
+-- | Set detail level of a trace from the config
+withDetailsFromConfig :: (MonadIO m) =>
+     Trace m a
+  -> m (Trace m a)
+withDetailsFromConfig =
+  withNamespaceConfig
+    getDetails
+    (\mbDtl b -> case mbDtl of
+              Just dtl  -> pure $ setDetails dtl b
+              Nothing   -> pure $ setDetails DRegular b)
+
+-- | Routing and formatting of a trace from the config
+withBackendsAndFormattingFromConfig :: (MonadIO m) =>
+     (Maybe [Backend] -> Trace m FormattedMessage -> m (Trace m a))
+  -> m (Trace m a)
+withBackendsAndFormattingFromConfig routerAndFormatter =
+  withNamespaceConfig
+    getBackends
+    routerAndFormatter
+    (Trace T.nullTracer)
 
 --------------------------------------------------------
 -- Internal
@@ -247,6 +270,26 @@ getSeverity config context =
     severitySelector (CoSeverity s) = Just s
     severitySelector _              = Nothing
 
+-- | If no details can be found in the config, it is set to DRegular
+getDetails :: TraceConfig -> Namespace -> DetailLevel
+getDetails config context =
+    fromMaybe DRegular (getOption detailSelector config context)
+  where
+    detailSelector :: ConfigOption -> Maybe DetailLevel
+    detailSelector (CoDetail d) = Just d
+    detailSelector _            = Nothing
+
+-- | If no backends can be found in the config, it is set to
+-- [EKGBackend, Forwarder, Stdout HumanFormat]
+getBackends :: TraceConfig -> Namespace -> [Backend]
+getBackends config context =
+    fromMaybe [EKGBackend, Forwarder, Stdout HumanFormat]
+      (getOption backendSelector config context)
+  where
+    backendSelector :: ConfigOption -> Maybe [Backend]
+    backendSelector (CoBackend s)  = Just s
+    backendSelector _              = Nothing
+
 -- | Searches in the config to find an option
 getOption :: (ConfigOption -> Maybe a) -> TraceConfig -> Namespace -> Maybe a
 getOption sel config [] =

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

@@ -181,18 +181,20 @@ formatContextHuman withColor hostname application LoggingContext {..}  txt = do
 -- The text argument gives the application name which is prepended to the namespace
 machineFormatter
   :: forall a m . (LogFormatting a, MonadIO m)
-  => DetailLevel
-  -> Text
+  => Text
   -> Trace m FormattedMessage
   -> m (Trace m a)
-machineFormatter detailLevel application (Trace tr) = do
+machineFormatter application (Trace tr) = do
   hn <- liftIO getHostName
   let trr = mkTracer hn
   pure $ Trace (T.arrow trr)
  where
     mkTracer hn = T.emit $
       \case
         (lc, Nothing, v) -> do
+          let detailLevel = case lcDetails lc of
+                              Nothing -> DRegular
+                              Just dl -> dl
           obj <- liftIO $ formatContextMachine hn application lc (forMachine detailLevel v)
           T.traceWith tr (lc { lcNamespace = application : lcNamespace lc}
                              , Nothing

trace-dispatcher/test/Examples/Documentation.hs

@@ -14,7 +14,7 @@ docTracer = do
   t1' <- humanFormatter True "cardano" t
   let t1 = withSeverityTraceForgeEvent
                 (appendName "node" t1')
-  t2' <- machineFormatter DRegular "cardano" t
+  t2' <- machineFormatter "cardano" t
   let t2 = withSeverityTraceForgeEvent
                 (appendName "node" t2')
   bl <- documentMarkdown traceForgeEventDocu [t1, t2]

trace-dispatcher/test/Examples/Routing.hs

@@ -25,7 +25,7 @@ routingTracer2 t1 t2 = t1 <> t2
 testRouting :: IO ()
 testRouting = do
     t <- standardTracer Nothing
-    tf <- machineFormatter DRegular "cardano" t
+    tf <- machineFormatter "cardano" t
     let t1 = appendName "tracer1" tf
     let t2 = appendName "tracer1" tf
     configureTracers emptyTraceConfig traceForgeEventDocu [t1, t2]

trace-dispatcher/test/Examples/Trivial.hs

@@ -14,7 +14,7 @@ import           Examples.TestObjects
 test1 :: IO ()
 test1 = do
     stdoutTracer' <- standardTracer Nothing
-    simpleTracer <- machineFormatter DRegular "cardano" stdoutTracer'
+    simpleTracer <- machineFormatter "cardano" stdoutTracer'
     configureTracers emptyTraceConfig traceForgeEventDocu [simpleTracer]
     let simpleTracer1 = filterTraceBySeverity (Just WarningF) simpleTracer
     let simpleTracerC1 = appendName "Outer1" simpleTracer1