With own standard tracer

trace-dispatcher/src/Cardano/Logging.hs

@@ -8,4 +8,5 @@ import           Cardano.Logging.FrequencyLimiter as X
 import           Cardano.Logging.Trace as X
 import           Cardano.Logging.Tracer.EKG as X
 import           Cardano.Logging.Tracer.Katip as X
+import           Cardano.Logging.Tracer.StandardLogger as X
 import           Cardano.Logging.Types as X

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

@@ -65,7 +65,7 @@ withNamespaceConfig extract needsConfigFunc tr = do
                 Nothing  -> T.traceWith
                               (unpackTrace $ needsConfigFunc (Just v) tr)
                               (lc, Nothing, a)
-
+        Left (cmap, Nothing) -> error "Missing configuration"
     mkTrace ref (lc, Just Reset, a) = do
       liftIO $ writeIORef ref (Left (Map.empty, Nothing))
       T.traceWith (unpackTrace $ needsConfigFunc Nothing tr) (lc, Just Reset, a)

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

@@ -3,7 +3,11 @@
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Cardano.Logging.Tracer.Katip where
+module Cardano.Logging.Tracer.Katip (
+    stdoutObjectKatipTracer
+  , stdoutJsonKatipTracer
+  , stdoutHumanKatipTracer
+) where
 
 import           Control.Concurrent (myThreadId)
 import           Control.Concurrent.STM

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

@@ -0,0 +1,212 @@
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Cardano.Logging.Tracer.StandardLogger (
+    standardMachineTracer
+  , standardHumanTracer
+) where
+
+import           Control.Concurrent (forkIO, myThreadId)
+import           Control.Concurrent.Chan.Unagi.Bounded
+import           Control.Monad (forever, void)
+import           Control.Monad.IO.Class
+import qualified Data.Aeson as AE
+import qualified Data.ByteString.Lazy as BS
+import           Data.IORef (IORef, modifyIORef, newIORef, readIORef)
+import           Data.List (intersperse)
+import           Data.Maybe (fromMaybe)
+import           Data.Text (Text, pack, stripPrefix)
+import qualified Data.Text.Array as TA
+import           Data.Text.Encoding (decodeUtf8)
+import qualified Data.Text.IO as TIO
+import           Data.Text.Lazy (toStrict)
+import           Data.Text.Lazy.Builder as TB
+import           Data.Time (UTCTime (..), defaultTimeLocale, formatTime,
+                     getCurrentTime)
+import           Data.Time.Format.ISO8601 (FormatExtension (BasicFormat),
+                     calendarFormat, dayAndTimeFormat, formatShow, iso8601Show,
+                     timeOfDayFormat)
+import           GHC.Conc (ThreadId)
+import           Network.HostName (getHostName)
+
+
+import           Cardano.Logging.DocuGenerator
+import           Cardano.Logging.Types
+import qualified Control.Tracer as T
+
+-- | Do we log to stdout or to a file?
+data LogTarget = LogStdout | LogFile FilePath
+  deriving (Eq, Show)
+
+-- | The state of a standard tracer
+data StandardTracerState a =  StandardTracerState {
+    stRunning :: Maybe (InChan Text, OutChan Text, ThreadId)
+  , stTarget  :: LogTarget
+}
+
+emptyStandardTracerState :: Text -> StandardTracerState a
+emptyStandardTracerState name = StandardTracerState Nothing LogStdout
+
+standardMachineTracer :: forall a m. (MonadIO m, LogFormatting a)
+  => Text
+  -> Maybe (DetailLevel -> a -> AE.Object)
+  -> m (Trace m a)
+standardMachineTracer tracerName mbFormatter = do
+    stateRef <- liftIO $ newIORef (emptyStandardTracerState tracerName)
+    hostname <- liftIO getHostName
+    pure $ Trace $ T.arrow $ T.emit $ uncurry3 (output stateRef hostname)
+  where
+    output ::
+         IORef (StandardTracerState a)
+      -> String
+      -> LoggingContext
+      -> Maybe TraceControl
+      -> a
+      -> m ()
+    output stateRef _ LoggingContext {..} (Just Reset) a = liftIO $ do
+      st <- readIORef stateRef
+      case stRunning st of
+        Nothing -> initLogging stateRef
+        Just _  -> pure ()
+    output stateRef hostName lc@LoggingContext {..} Nothing a = liftIO $ do
+      st  <- readIORef stateRef
+      case stRunning st of
+        Just (inChannel, _, _) -> do
+          msg <- formatMachine mbFormatter (stTarget st == LogStdout) lc hostName a
+          writeChan inChannel msg
+        Nothing                -> pure ()
+    output _ _ lk (Just c@Document {}) a =
+       docIt (StandardBackend tracerName) Machine (lk, Just c, a)
+    output stateRef _ LoggingContext {..} _ a = pure ()
+
+formatMachine :: LogFormatting a =>
+     Maybe (DetailLevel -> a -> AE.Object)
+  -> Bool
+  -> LoggingContext
+  -> String
+  -> a
+  -> IO Text
+formatMachine mbFormatter withColor LoggingContext {..} hostname obj = do
+  thid <- myThreadId
+  time <- getCurrentTime
+  let severity = fromMaybe Info lcSeverity
+      tid      = fromMaybe ((pack . show) thid)
+                    ((stripPrefix "ThreadId " . pack . show) thid)
+      ns       = colorBySeverity
+                    withColor
+                    severity
+                    $ mconcat (intersperse (singleton '.')
+                      (fromString hostname : map fromText lcNamespace
+                      <> [fromString (show severity) , fromText tid] ))
+      ts       = fromString $ formatTime defaultTimeLocale "%F %T" time
+      payload  = case mbFormatter of
+                  Just form -> form (fromMaybe DRegular lcDetails) obj
+                  Nothing   -> forMachine (fromMaybe DRegular lcDetails) obj
+      pb       = fromText $ decodeUtf8 $ BS.toStrict $ AE.encode payload
+  pure $ toStrict
+          $ toLazyText
+            $ mconcat (map squareBrackets [ns, ts]) <> pb
+  where
+    squareBrackets :: Builder -> Builder
+    squareBrackets b = TB.singleton '[' <> b <> TB.singleton ']'
+
+standardHumanTracer :: forall a m. (MonadIO m, LogFormatting a)
+  => Text
+  -> Maybe (a -> Text)
+  -> m (Trace m a)
+standardHumanTracer tracerName mbFormatter = do
+    stateRef <- liftIO $ newIORef (emptyStandardTracerState tracerName)
+    hostname <- liftIO getHostName
+    pure $ Trace $ T.arrow $ T.emit $ uncurry3 (output stateRef hostname)
+  where
+    output ::
+         IORef (StandardTracerState a)
+      -> String
+      -> LoggingContext
+      -> Maybe TraceControl
+      -> a
+      -> m ()
+    output stateRef _ LoggingContext {..} (Just Reset) a = liftIO $ do
+      st <- readIORef stateRef
+      case stRunning st of
+        Nothing -> initLogging stateRef
+        Just _  -> pure ()
+    output stateRef hostName lc@LoggingContext {..} Nothing a = liftIO $ do
+      st  <- readIORef stateRef
+      case stRunning st of
+        Just (inChannel, _, _) -> do
+          msg <- formatHuman mbFormatter (stTarget st == LogStdout) lc hostName a
+          writeChan inChannel msg
+        Nothing                -> pure ()
+    output _ _ lk (Just c@Document {}) a =
+       docIt (StandardBackend tracerName) Machine (lk, Just c, a)
+    output stateRef _ LoggingContext {..} _ a = pure ()
+
+formatHuman :: LogFormatting a =>
+     Maybe (a -> Text)
+  -> Bool
+  -> LoggingContext
+  -> String
+  -> a
+  -> IO Text
+formatHuman mbFormatter withColor LoggingContext {..} hostname obj = do
+  thid <- myThreadId
+  time <- getCurrentTime
+  let severity = fromMaybe Info lcSeverity
+      tid      = fromMaybe ((pack . show) thid)
+                    ((stripPrefix "ThreadId " . pack . show) thid)
+      ns       = colorBySeverity
+                    withColor
+                    severity
+                    $ mconcat (intersperse (singleton '.')
+                      (fromString hostname : map fromText lcNamespace
+                      <> [fromString (show severity) , fromText tid] ))
+      ts       = fromString $ formatTime defaultTimeLocale "%F %T" time
+      payload  = case mbFormatter of
+                  Just form -> form obj
+                  Nothing   -> forHuman obj
+      pb       = fromText $ decodeUtf8 $ BS.toStrict $ AE.encode payload
+  pure $ toStrict
+          $ toLazyText
+            $ mconcat (map squareBrackets [ns, ts]) <> pb
+  where
+    squareBrackets :: Builder -> Builder
+    squareBrackets b = TB.singleton '[' <> b <> TB.singleton ']'
+
+
+-- | Color a text message based on `Severity`. `Error` and more severe errors
+-- are colored red, `Warning` is colored yellow, and all other messages are
+-- rendered in the default color.
+colorBySeverity :: Bool -> SeverityS -> Builder -> Builder
+colorBySeverity withColor severity msg = case severity of
+  Emergency -> red msg
+  Alert     -> red msg
+  Critical  -> red msg
+  Error     -> red msg
+  Warning   -> yellow msg
+  _         -> msg
+  where
+    red = colorize "31"
+    yellow = colorize "33"
+    colorize c s
+      | withColor = "\ESC["<> c <> "m" <> s <> "\ESC[0m"
+      | otherwise = s
+
+initLogging :: IORef (StandardTracerState a) -> IO ()
+initLogging stateRef = do
+  (inChan, outChan) <- newChan 2048
+  threadId <- forkIO $ forever $ do
+    state <- readIORef stateRef
+    msg   <- readChan outChan
+    case stTarget state of
+        LogFile f -> do
+                        TIO.appendFile f msg
+                        TIO.appendFile f "\n"
+        LogStdout -> TIO.putStrLn msg
+  modifyIORef stateRef (\ st ->
+    st {stRunning = Just (inChan, outChan, threadId)})
+
+-- | Converts a curried function to a function on a triple.
+uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)
+uncurry3 f ~(a,b,c) = f a b c

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

@@ -204,6 +204,7 @@ emptyLogDoc d = LogDoc d [] [] [] [] []
 data Backend =
     KatipBackend Text
   | EKGBackend Text
+  | StandardBackend Text
   deriving(Eq, Show, Generic)
 
 -- | Type for a Fold

trace-dispatcher/test/Examples/Configuration.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
 module Examples.Configuration where
 
 import           Control.Monad (liftM)
@@ -27,15 +29,13 @@ testMessageDocumented = Documented [
   DocMsg (TestMessage "dummy") "text" "just a text"
   ]
 
-tracer1 :: MonadIO m => m (Trace m TestMessage)
-tracer1  = fmap
-            (appendName "tracer1")
-            (filterSeverityFromConfig =<< stdoutHumanKatipTracer)
 
-tracer2 :: MonadIO m => m (Trace m TestMessage)
-tracer2  = fmap
-            (appendName "tracer2")
-            (filterSeverityFromConfig =<< stdoutHumanKatipTracer)
+tracers :: MonadIO m => m (Trace m TestMessage, Trace m TestMessage)
+tracers  = do
+  t0 <- standardHumanTracer "stdout" Nothing
+  t1 <- appendName "tracer1" <$> filterSeverityFromConfig t0
+  t2 <- appendName "tracer2" <$> filterSeverityFromConfig t0
+  pure (t1, t2)
 
 config1 :: TraceConfig
 config1 = TraceConfig {
@@ -53,12 +53,10 @@ config2 = TraceConfig {
           (["tracer2","bubble"], [CoSeverity WarningF])]
     }
 
-testConfig' :: TraceConfig -> IO ()
-testConfig' tc = do
-    t1 <- tracer1
-    t2 <- tracer2
+testConfig' :: MonadIO m => TraceConfig -> Trace m TestMessage -> Trace m TestMessage -> m ()
+testConfig' tc t1 t2 = do
     let bubbleTracer = appendName "bubble" t2
-    configureTracers tc testMessageDocumented [t1, t2, bubbleTracer]
+    configureTracers tc testMessageDocumented [t1, t2]
     traceWith (setSeverity Critical t1) (TestMessage "Now setting config")
     traceWith
       (setSeverity Error t1)
@@ -76,10 +74,11 @@ testConfig' tc = do
       (setSeverity Info t2)
       (TestMessage "5: never show")
 
+testConfig :: IO ()
 testConfig = do
-  t1 <- tracer1
-  testConfig' config1
-  testConfig' config2
+  (t1, t2) <- tracers
+  testConfig' config1 t1 t2
+  testConfig' config2 t1 t2
 
 {-
 >>> config1

trace-dispatcher/test/Examples/Routing.hs

@@ -15,11 +15,11 @@ import           Examples.TestObjects
 
 tracer1 :: (LogFormatting (TraceForgeEvent blk), MonadIO m) =>
   m (Trace m (TraceForgeEvent blk))
-tracer1  = fmap (appendName "tracer1") stdoutHumanKatipTracer
+tracer1  = fmap (appendName "tracer1") (standardHumanTracer "t1" Nothing)
 
 tracer2 :: (LogFormatting (TraceForgeEvent blk), MonadIO m) =>
   m (Trace m (TraceForgeEvent blk))
-tracer2  = fmap (appendName "tracer2") stdoutJsonKatipTracer
+tracer2  = fmap (appendName "tracer2") (standardMachineTracer "t2" Nothing)
 
 routingTracer1 :: (Monad m)
   => Trace m (TraceForgeEvent LogBlock)
@@ -40,6 +40,7 @@ testRouting :: IO ()
 testRouting = do
     t1 <- tracer1
     t2 <- tracer2
+    configureTracers emptyTraceConfig traceForgeEventDocu [t1, t2]
     traceWith (routingTracer1 t1 t2) message1
     traceWith (routingTracer1 t1 t2) message2
     traceWith (t1 <> t2) message3

trace-dispatcher/test/Examples/Trivial.hs

@@ -5,14 +5,16 @@ import           Katip
 import           Katip.Scribes.Handle (ioLogEnv)
 
 import           Cardano.Logging
+import           Examples.Configuration (testMessageDocumented)
 import           Examples.TestObjects
 
 
 -- | Make shure the function append name is only called once
 --   for every path element
 test1 :: IO ()
 test1 = do
-    simpleTracer1 <- stdoutHumanKatipTracer
+    simpleTracer1 <- standardMachineTracer "simpleTracer1" Nothing
+    configureTracers emptyTraceConfig traceForgeEventDocu [simpleTracer1]
     let simpleTracer1' = filterTraceBySeverity (Just WarningF) simpleTracer1
     let simpleTracerC1 = appendName "Outer1" simpleTracer1'
     let simpleTracerC2 = appendName "Inner1" simpleTracerC1
@@ -26,7 +28,8 @@ test1 = do
 
 test2 :: IO ()
 test2 = do
-    simpleTracer <- stdoutHumanKatipTracer
+    simpleTracer <- standardHumanTracer "simpleTracer2" Nothing
+    configureTracers emptyTraceConfig traceForgeEventDocu [simpleTracer]
     let simpleTracer1  = withSeverity loSeverity
                             (filterTraceBySeverity (Just WarningF) simpleTracer)
     let simpleTracerC1 = appendName "Outer1" simpleTracer1

trace-dispatcher/trace-dispatcher.cabal

@@ -16,6 +16,7 @@ library
   exposed-modules:    Cardano.Logging.Trace
                       Cardano.Logging.Tracer.Katip
                       Cardano.Logging.Tracer.EKG
+                      Cardano.Logging.Tracer.StandardLogger
                       Cardano.Logging.Types
                       Cardano.Logging.Configuration
                       Cardano.Logging.FrequencyLimiter
@@ -27,6 +28,7 @@ library
   default-extensions: OverloadedStrings
   build-depends:      base >=4.12 && <5
                       , aeson
+                      , bytestring
                       , containers
                       , ekg
                       , ekg-core
@@ -35,6 +37,7 @@ library
                       , stm
                       , text
                       , time
+                      , unagi-chan
                       , unliftio
                       , unliftio-core
                       , unordered-containers
@@ -54,6 +57,7 @@ executable trace-dispatcher-examples
     default-extensions:  OverloadedStrings
     build-depends:    base >=4.12 && <5
                       , aeson
+                      , bytestring
                       , containers
                       , ekg
                       , ekg-core
@@ -62,6 +66,7 @@ executable trace-dispatcher-examples
                       , text
                       , trace-dispatcher
                       , time
+                      , unagi-chan
                       , unliftio
                       , unliftio-core
                       , stm