trace-dispatcher: optimize, sharing Encoding value; simplify

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

@@ -69,10 +69,10 @@ generatorTracer ::
 generatorTracer tracerName mbTrStdout mbTrForward = do
   forwardTrace <- case mbTrForward of
                         Nothing -> mempty
-                        Just trForward -> forwardFormatter Nothing trForward
+                        Just trForward -> forwardFormatter trForward
   stdoutTrace  <- case mbTrStdout of
                         Nothing -> mempty
-                        Just trForward -> machineFormatter Nothing trForward
+                        Just trForward -> machineFormatter trForward
   let tr = forwardTrace <> stdoutTrace
   tr'  <- withDetailsFromConfig tr
   pure $ withInnerNames $ appendPrefixName tracerName tr'

cardano-tracer/src/Cardano/Tracer/MetaTrace.hs

@@ -297,7 +297,7 @@ mkTracerTracer :: SeverityF -> IO (Trace IO TracerTrace)
 mkTracerTracer defSeverity = do
   base     :: Trace IO FormattedMessage <- standardTracer
   metaBase :: Trace IO TracerTrace      <-
-    machineFormatter Nothing base
+    machineFormatter base
     >>= withDetailsFromConfig
   let tr = metaBase
            & withInnerNames

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

@@ -1,8 +1,11 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Cardano.Logging.Formatter (
     metricsFormatter
   , preFormatted
@@ -16,7 +19,6 @@ module Cardano.Logging.Formatter (
 
 import           Cardano.Logging.Trace (contramapM)
 import           Cardano.Logging.Types
-import           Cardano.Logging.Utils (showT)
 
 import           Control.Concurrent (myThreadId)
 import           Control.Monad.IO.Class (MonadIO, liftIO)
@@ -26,18 +28,35 @@ import qualified Data.Aeson as AE
 import qualified Data.Aeson.Encoding as AE
 import           Data.Functor.Contravariant
 import           Data.Maybe (fromMaybe)
-import           Data.Text (Text, intercalate, pack, stripPrefix)
+import           Data.Text as T (Text, intercalate, null, pack)
 import           Data.Text.Lazy (toStrict)
 import           Data.Text.Lazy.Builder as TB
 import           Data.Text.Lazy.Encoding (decodeUtf8)
 import           Data.Time (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
 import           Network.HostName
+import           System.IO.Unsafe (unsafePerformIO)
 
 
 encodingToText :: AE.Encoding -> Text
 {-# INLINE encodingToText #-}
 encodingToText = toStrict . decodeUtf8 . AE.encodingToLazyByteString
 
+timeFormatted :: UTCTime -> Text
+{-# INLINE timeFormatted #-}
+timeFormatted = pack . formatTime defaultTimeLocale "%F %H:%M:%S%4QZ"
+
+-- If the hostname in the logs should be anything different from the system reported hostname,
+-- a new field would need to be added to PreFormatted to carry a new hostname argument to preFormatted.
+hostname :: Text
+{-# NOINLINE hostname #-}
+hostname = unsafePerformIO $ T.pack <$> getHostName
+
+-- This allows data sharing of an Encoding value, avoiding reconstruction of the underlying Builder
+instance AE.ToJSON AE.Encoding where
+  toJSON     = error "ToJSON(Aeson.Encoding): must never be called"
+  toEncoding = id
+
+
 -- | Format this trace as metrics
 metricsFormatter
   :: forall a m . (LogFormatting a, MonadIO m)
@@ -58,72 +77,57 @@ metricsFormatter (Trace tr) = Trace $
 preFormatted ::
   (  LogFormatting a
   ,  MonadIO m)
-  => [BackendConfig]
-  -> Trace m (PreFormatted a)
+  => Bool
+  -> Trace m PreFormatted
   -> m (Trace m a)
-preFormatted backends' (Trace tr) = do
-  hostname <- liftIO getHostName
-  contramapM (Trace tr)
+preFormatted withForHuman =
+  flip contramapM
     (\case
       (lc, Right msg) -> do
         time     <- liftIO getCurrentTime
         threadId <- liftIO myThreadId
         let ns' = lcNSPrefix lc ++ lcNSInner lc
-            threadText = showT threadId
-            threadTextShortened =
-              fromMaybe threadText (stripPrefix "ThreadId " threadText)
+            threadTextShortened = T.pack $ drop 9 $ show threadId       -- drop "ThreadId " prefix
             details = fromMaybe DNormal (lcDetails lc)
-            condForHuman = if elem (Stdout HumanFormatUncoloured) backends'
-                          || elem (Stdout HumanFormatColoured) backends'
-                          || elem Forwarder backends'
-                          then case forHuman msg of
-                                  "" -> Nothing
-                                  txt -> Just txt
-                          else Nothing
-            machineFormatted = forMachine details msg
+            condForHuman = let txt = forHuman msg in if T.null txt then Nothing else Just txt
+            machineFormatted = AE.toEncoding $ forMachine details msg
 
         pure (lc, Right (PreFormatted
-                          { pfMessage = msg
-                          , pfForHuman = condForHuman
+                          { pfForHuman = if withForHuman then condForHuman else Nothing
                           , pfForMachine = machineFormatted
                           , pfTimestamp = timeFormatted time
                           , pfTime = time
                           , pfNamespace = ns'
-                          , pfHostname = hostname
                           , pfThreadId = threadTextShortened
                           }))
       (lc, Left ctrl) ->
         pure (lc, Left ctrl))
 
 -- | Format this trace as TraceObject for the trace forwarder
 forwardFormatter'
-  :: forall a m .
+  :: forall m .
      MonadIO m
-  => Maybe Text
-  -> Trace m FormattedMessage
-  -> Trace m (PreFormatted a)
-forwardFormatter' condPrefix (Trace tr) = Trace $
+  => Trace m FormattedMessage
+  -> Trace m PreFormatted
+forwardFormatter' (Trace tr) = Trace $
   contramap
     (\ case
       (lc, Right v) ->
-            let ns = case condPrefix of
-                                  Just app -> app : pfNamespace v
-                                  Nothing -> pfNamespace v
-                machineObj = AE.pairs $
+            let machineObj = AE.pairs $
                       "at"       .= pfTime v
-                    <> "ns"      .= ns
+                    <> "ns"      .= intercalate "." (pfNamespace v)
                     <> "data"    .= pfForMachine v
                     <> "sev"     .= fromMaybe Info (lcSeverity lc)
                     <> "thread"  .= pfThreadId v
-                    <> "host"    .= pfHostname v
+                    <> "host"    .= hostname
                 to = TraceObject {
                     toHuman     = pfForHuman v
                   , toMachine   = encodingToText machineObj
-                  , toNamespace = ns
+                  , toNamespace = pfNamespace v
                   , toSeverity  = fromMaybe Info (lcSeverity lc)
                   , toDetails   = fromMaybe DNormal (lcDetails lc)
                   , toTimestamp = pfTime v
-                  , toHostname  = pfHostname v
+                  , toHostname  = hostname
                   , toThreadId  = pfThreadId v
                 }
             in (lc, Right (FormattedForwarder to))
@@ -132,50 +136,41 @@ forwardFormatter' condPrefix (Trace tr) = Trace $
 
 -- | Format this trace as TraceObject for the trace forwarder
 machineFormatter'
-  :: forall a m .
+  :: forall m .
      MonadIO m
-  => Maybe Text
-  -> Trace m FormattedMessage
-  -> Trace m (PreFormatted a)
-machineFormatter' condPrefix (Trace tr) = Trace $
+  => Trace m FormattedMessage
+  -> Trace m PreFormatted
+machineFormatter' (Trace tr) = Trace $
   contramap
     (\ case
       (lc, Right v) ->
-        let ns = case condPrefix of
-                                  Just app -> app : pfNamespace v
-                                  Nothing -> pfNamespace v
-            machineObj = AE.pairs $
+        let machineObj = AE.pairs $
                    "at"      .= pfTime v
-                <> "ns"      .= intercalate "." ns
+                <> "ns"      .= intercalate "." (pfNamespace v)
                 <> "data"    .= pfForMachine v
                 <> "sev"     .= fromMaybe Info (lcSeverity lc)
                 <> "thread"  .= pfThreadId v
-                <> "host"    .= pfHostname v
+                <> "host"    .= hostname
         in (lc, Right (FormattedMachine (encodingToText machineObj)))
       (lc, Left ctrl) -> (lc, Left ctrl))
       tr
 
 -- | Format this trace in human readable style
 humanFormatter'
-  :: forall a m .
+  :: forall m .
      MonadIO m
   => Bool
-  -> Maybe Text
   -> Trace m FormattedMessage
-  -> Trace m (PreFormatted a)
-humanFormatter' withColor condPrefix (Trace tr) =
+  -> Trace m PreFormatted
+humanFormatter' withColor (Trace tr) =
   Trace $
       contramap
         (\ case
           (lc, Right v) ->
               let sev      = fromMaybe Info (lcSeverity lc)
-                  ns       = fromString (pfHostname v)
+                  ns       = fromText hostname
                                 <> singleton ':'
-                                <> fromText
-                                    (intercalate "."
-                                      (case condPrefix of
-                                          Just app -> app : pfNamespace v
-                                          Nothing  ->pfNamespace v))
+                                <> fromText (intercalate "." (pfNamespace v))
                   prePart  = squareBrackets (fromText (pfTimestamp v))
                                 <> squareBrackets ns
                                 <> roundBrackets
@@ -223,41 +218,30 @@ colorBySeverity withColor severity' msg =
     blue = colorize "34"
     colorize c msg' = "\ESC[" <> c <> "m" <> msg' <> "\ESC[0m"
 
-timeFormatted :: UTCTime -> Text
-timeFormatted = pack . formatTime defaultTimeLocale "%F %H:%M:%S%4QZ"
-
 humanFormatter
   :: forall a m .
      MonadIO m
   => LogFormatting a
   => Bool
-  -> Maybe Text
   -> Trace m FormattedMessage
   -> m (Trace m a)
-humanFormatter withColor condPrefix tr = do
-    let tr' = humanFormatter' withColor condPrefix tr
-    preFormatted [Stdout (if withColor
-                            then HumanFormatColoured
-                            else HumanFormatUncoloured)] tr'
+humanFormatter withColor =
+  preFormatted True . humanFormatter' withColor
 
 machineFormatter
   :: forall a m .
      (MonadIO m
   ,  LogFormatting a)
-  => Maybe Text
-  -> Trace m FormattedMessage
+  => Trace m FormattedMessage
   -> m (Trace m a)
-machineFormatter condPrefix tr = do
-    let tr' = machineFormatter' condPrefix tr
-    preFormatted [Stdout MachineFormat] tr'
+machineFormatter =
+  preFormatted False . machineFormatter'
 
 forwardFormatter
   :: forall a m .
      MonadIO m
   => LogFormatting a
-  => Maybe Text
-  -> Trace m FormattedMessage
+  => Trace m FormattedMessage
   -> m (Trace m a)
-forwardFormatter condPrefix tr = do
-    let tr' = forwardFormatter' condPrefix tr
-    preFormatted [Stdout MachineFormat, Stdout HumanFormatColoured] tr'
+forwardFormatter =
+  preFormatted True . forwardFormatter'

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

@@ -30,7 +30,6 @@ import qualified Data.Set as Set
 import           Data.Text hiding (map)
 
 
-
 -- | Construct a tracer according to the requirements for cardano node.
 -- The tracer gets a 'name', which is appended to its namespace.
 -- The tracer has to be an instance of LogFormatting for the display of
@@ -137,25 +136,29 @@ backendsAndFormat ::
   -> Maybe [BackendConfig]
   -> Trace IO x
   -> IO (Trace IO a)
-backendsAndFormat trStdout trForward mbBackends _ =
-  let backends' = fromMaybe
-                    [Forwarder, Stdout MachineFormat]
-                    mbBackends
-  in do
-    let mbForwardTrace  = if Forwarder `L.elem` backends'
+backendsAndFormat trStdout trForward mbBackends _ = do
+    let mbForwardTrace  = if forwarder
                             then Just $ filterTraceByPrivacy (Just Public)
-                                (forwardFormatter' Nothing trForward)
+                                (forwardFormatter' trForward)
                             else Nothing
-        mbStdoutTrace   | Stdout HumanFormatColoured `L.elem` backends'
-                        = Just (humanFormatter' True Nothing trStdout)
-                        | Stdout HumanFormatUncoloured `L.elem` backends'
-                        = Just (humanFormatter' False Nothing trStdout)
+        mbStdoutTrace   | humColoured
+                        = Just (humanFormatter' True trStdout)
+                        | humUncoloured
+                        = Just (humanFormatter' False trStdout)
                         | Stdout MachineFormat `L.elem` backends'
-                        = Just (machineFormatter' Nothing trStdout)
+                        = Just (machineFormatter' trStdout)
                         | otherwise = Nothing
     case mbForwardTrace <> mbStdoutTrace of
       Nothing -> pure $ Trace T.nullTracer
-      Just tr -> preFormatted backends' tr
+      Just tr -> preFormatted (humColoured || humUncoloured || forwarder) tr
+  where
+    backends'     = fromMaybe
+                    [Forwarder, Stdout MachineFormat]
+                    mbBackends
+
+    humColoured   = Stdout HumanFormatColoured   `L.elem` backends'
+    humUncoloured = Stdout HumanFormatUncoloured `L.elem` backends'
+    forwarder     = Forwarder `L.elem` backends'
 
 traceConfigWarnings ::
      Trace IO FormattedMessage

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

@@ -61,7 +61,6 @@ import           Codec.Serialise (Serialise (..))
 import qualified Control.Tracer as T
 import qualified Data.Aeson as AE
 import qualified Data.Aeson.Encoding as AE
-import qualified Data.Aeson.KeyMap as AE
 import qualified Data.HashMap.Strict as HM
 import           Data.IORef
 import           Data.Map.Strict (Map)
@@ -343,14 +342,12 @@ data FormattedMessage =
   deriving (Eq, Show)
 
 
-data PreFormatted a = PreFormatted {
-    pfMessage    :: !a
-  , pfForHuman   :: !(Maybe Text)
-  , pfForMachine :: !(AE.KeyMap AE.Value)
+data PreFormatted = PreFormatted {
+    pfForHuman   :: !(Maybe Text)
+  , pfForMachine :: !AE.Encoding
   , pfNamespace  :: ![Text]
   , pfTimestamp  :: !Text
   , pfTime       :: !UTCTime
-  , pfHostname   :: !HostName
   , pfThreadId   :: !Text
 }
 
@@ -362,7 +359,7 @@ data TraceObject = TraceObject {
   , toSeverity  :: !SeverityS
   , toDetails   :: !DetailLevel
   , toTimestamp :: !UTCTime
-  , toHostname  :: !HostName
+  , toHostname  :: !Text
   , toThreadId  :: !Text
 } deriving (Eq, Show)
 

trace-dispatcher/test/Cardano/Logging/Test/Unit/Aggregation.hs

@@ -66,7 +66,7 @@ testAggregation :: IO [Text]
 testAggregation = do
     testTracerRef <- newIORef []
     simpleTracer <- testTracer testTracerRef
-    formTracer <- machineFormatter Nothing simpleTracer
+    formTracer <- machineFormatter simpleTracer
     tracer <- foldTraceM calculate emptyStats (contramap unfold formTracer)
     confState <- emptyConfigReflection
     configureTracers confState emptyTraceConfig [formTracer]

trace-dispatcher/test/Cardano/Logging/Test/Unit/Configuration.hs

@@ -37,7 +37,7 @@ instance MetaTrace TestMessage where
 tracers :: MonadIO m => IORef [FormattedMessage] -> m (Trace m TestMessage, Trace m TestMessage, Trace m TestMessage)
 tracers testTracerRef = do
   t <- testTracer testTracerRef
-  t0 <- machineFormatter Nothing t
+  t0 <- machineFormatter t
   t1 <- withInnerNames . appendPrefixName "tracer1" <$> filterSeverityFromConfig t0
   t2 <- withInnerNames . appendPrefixName "tracer2" <$> filterSeverityFromConfig t0
   t3 <- withInnerNames . appendPrefixName "tracer3" <$> filterSeverityFromConfig t0

trace-dispatcher/test/Cardano/Logging/Test/Unit/FrequencyLimiting.hs

@@ -22,8 +22,8 @@ testLimiting :: IO [Text]
 testLimiting = do
   testTracerRef <- newIORef []
   simpleTracer <- testTracer testTracerRef
-  tf <- machineFormatter Nothing simpleTracer
-  tflimit <- machineFormatter (Just "limiter") simpleTracer
+  tf <- machineFormatter simpleTracer
+  tflimit <- machineFormatter simpleTracer
   tf2 <- limitFrequency 5 "5 messages per second" tflimit tf
   tf3 <- limitFrequency 15 "15 messages per second" tflimit tf
   confState <- emptyConfigReflection