{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Logging.Formatter (
    metricsFormatter
  , preFormatted
  , forwardFormatter
  , forwardFormatter'
  , machineFormatter
  , machineFormatter'
  , cborFormatter
  , cborFormatter'
  , humanFormatter
  , humanFormatter'
) where

import           Cardano.Logging.Trace (contramapM)
import           Cardano.Logging.Types
import           Cardano.Logging.Types.TraceMessage

import           Codec.Serialise (serialise)
import           Control.Concurrent (myThreadId)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Tracer as T
import           Data.Aeson ((.=))
import qualified Data.Aeson as AE
import qualified Data.Aeson.Encoding as AE
import qualified Data.ByteString.Lazy as BL (toStrict)
import           Data.Functor.Contravariant
import           Data.Maybe (fromMaybe)
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 (defaultTimeLocale, formatTime, getCurrentTime)
import           Network.HostName
import           System.IO.Unsafe (unsafePerformIO)


-- 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 :: Text
hostname = IO Text -> Text
forall a. IO a -> a
unsafePerformIO (IO Text -> Text) -> IO Text -> Text
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> IO String -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getHostName


-- | Format this trace as metrics
metricsFormatter
  :: forall a m . (LogFormatting a, MonadIO m)
  => Trace m FormattedMessage
  -> Trace m a
metricsFormatter :: forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Trace m FormattedMessage -> Trace m a
metricsFormatter (Trace Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr) = Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl a) -> Trace m a)
-> Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall a b. (a -> b) -> a -> b
$
    ((LoggingContext, Either TraceControl a)
 -> (LoggingContext, Either TraceControl FormattedMessage))
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Tracer m (LoggingContext, Either TraceControl a)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
T.contramap
      (\ case
        (LoggingContext
lc, Right a
v) ->
          let metrics :: [Metric]
metrics = a -> [Metric]
forall a. LogFormatting a => a -> [Metric]
asMetrics a
v
          in (LoggingContext
lc, FormattedMessage -> Either TraceControl FormattedMessage
forall a b. b -> Either a b
Right ([Metric] -> FormattedMessage
FormattedMetrics [Metric]
metrics))
        (LoggingContext
lc, Left TraceControl
ctrl) ->
             (LoggingContext
lc, TraceControl -> Either TraceControl FormattedMessage
forall a b. a -> Either a b
Left TraceControl
ctrl))
      Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr

-- | Transform this trace to a preformatted message, so that double serialization
-- is avoided
preFormatted ::
  (  LogFormatting a
  ,  MonadIO m)
  => Bool
  -> Trace m PreFormatted
  -> m (Trace m a)
preFormatted :: forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> m (Trace m a)
preFormatted Bool
withForHuman =
  (Trace m PreFormatted
 -> ((LoggingContext, Either TraceControl a)
     -> m (LoggingContext, Either TraceControl PreFormatted))
 -> m (Trace m a))
-> ((LoggingContext, Either TraceControl a)
    -> m (LoggingContext, Either TraceControl PreFormatted))
-> Trace m PreFormatted
-> m (Trace m a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Trace m PreFormatted
-> ((LoggingContext, Either TraceControl a)
    -> m (LoggingContext, Either TraceControl PreFormatted))
-> m (Trace m a)
forall (m :: * -> *) b a.
Monad m =>
Trace m b
-> ((LoggingContext, Either TraceControl a)
    -> m (LoggingContext, Either TraceControl b))
-> m (Trace m a)
contramapM
    (\case
      (LoggingContext
lc, Right a
msg) -> do
        UTCTime
time     <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        ThreadId
threadId <- IO ThreadId -> m ThreadId
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ThreadId
myThreadId
        let
            pf :: PreFormatted
pf = PreFormatted
              { pfTime :: UTCTime
pfTime              = UTCTime
time
              , pfNamespace :: Text
pfNamespace         = Text -> [Text] -> Text
intercalate Text
"." (LoggingContext -> [Text]
lcNSPrefix LoggingContext
lc [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ LoggingContext -> [Text]
lcNSInner LoggingContext
lc)
              , pfThreadId :: Text
pfThreadId          = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
9 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ThreadId -> String
forall a. Show a => a -> String
show ThreadId
threadId                           -- drop "ThreadId " prefix
              , pfForHuman :: Maybe Text
pfForHuman          = if Bool
withForHuman then (let txt :: Text
txt = a -> Text
forall a. LogFormatting a => a -> Text
forHuman a
msg in if Text -> Bool
T.null Text
txt then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
txt) else Maybe Text
forall a. Maybe a
Nothing
              , pfForMachineObject :: Object
pfForMachineObject  = DetailLevel -> a -> Object
forall a. LogFormatting a => DetailLevel -> a -> Object
forMachine (DetailLevel -> Maybe DetailLevel -> DetailLevel
forall a. a -> Maybe a -> a
fromMaybe DetailLevel
DNormal (LoggingContext -> Maybe DetailLevel
lcDetails LoggingContext
lc)) a
msg
              }
        (LoggingContext, Either TraceControl PreFormatted)
-> m (LoggingContext, Either TraceControl PreFormatted)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoggingContext
lc, PreFormatted -> Either TraceControl PreFormatted
forall a b. b -> Either a b
Right PreFormatted
pf)

      (LoggingContext
lc, Left TraceControl
ctrl) ->
        (LoggingContext, Either TraceControl PreFormatted)
-> m (LoggingContext, Either TraceControl PreFormatted)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoggingContext
lc, TraceControl -> Either TraceControl PreFormatted
forall a b. a -> Either a b
Left TraceControl
ctrl)
    )

-- | Format this trace as TraceObject for the trace forwarder
forwardFormatter'
  :: forall m .
     MonadIO m
  => Trace m FormattedMessage
  -> Trace m PreFormatted
forwardFormatter' :: forall (m :: * -> *).
MonadIO m =>
Trace m FormattedMessage -> Trace m PreFormatted
forwardFormatter' (Trace Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr) = Tracer m (LoggingContext, Either TraceControl PreFormatted)
-> Trace m PreFormatted
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl PreFormatted)
 -> Trace m PreFormatted)
-> Tracer m (LoggingContext, Either TraceControl PreFormatted)
-> Trace m PreFormatted
forall a b. (a -> b) -> a -> b
$
  ((LoggingContext, Either TraceControl PreFormatted)
 -> (LoggingContext, Either TraceControl FormattedMessage))
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Tracer m (LoggingContext, Either TraceControl PreFormatted)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap
    (\ case
      (LoggingContext
lc, Right PreFormatted
v) ->
            let
              jsonObj :: TraceMessage
jsonObj = TraceMessage
                { tmsgAt :: UTCTime
tmsgAt      = PreFormatted -> UTCTime
pfTime PreFormatted
v
                , tmsgNS :: Text
tmsgNS      = PreFormatted -> Text
pfNamespace PreFormatted
v
                , tmsgData :: Object
tmsgData    = PreFormatted -> Object
pfForMachineObject PreFormatted
v
                , tmsgSev :: SeverityS
tmsgSev     = SeverityS -> Maybe SeverityS -> SeverityS
forall a. a -> Maybe a -> a
fromMaybe SeverityS
Info (Maybe SeverityS -> SeverityS) -> Maybe SeverityS -> SeverityS
forall a b. (a -> b) -> a -> b
$ LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc
                , tmsgThread :: Text
tmsgThread  = PreFormatted -> Text
pfThreadId PreFormatted
v
                , tmsgHost :: Text
tmsgHost    = Text
hostname
                }
              to :: TraceObject
to = TraceObject
                { toHuman :: Maybe Text
toHuman     = PreFormatted -> Maybe Text
pfForHuman PreFormatted
v
                , toMachine :: Text
toMachine   = (Text -> Text
toStrict (Text -> Text) -> (TraceMessage -> Text) -> TraceMessage -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (TraceMessage -> ByteString) -> TraceMessage -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceMessage -> ByteString
forall a. ToJSON a => a -> ByteString
AE.encode) TraceMessage
jsonObj
                -- backwards compatible to not break ForwardingV_1 protocol' type: value used to be segmented (["name", "space"])
                , toNamespace :: [Text]
toNamespace = [PreFormatted -> Text
pfNamespace PreFormatted
v]
                , toSeverity :: SeverityS
toSeverity  = SeverityS -> Maybe SeverityS -> SeverityS
forall a. a -> Maybe a -> a
fromMaybe SeverityS
Info (LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc)
                , toDetails :: DetailLevel
toDetails   = DetailLevel -> Maybe DetailLevel -> DetailLevel
forall a. a -> Maybe a -> a
fromMaybe DetailLevel
DNormal (LoggingContext -> Maybe DetailLevel
lcDetails LoggingContext
lc)
                , toTimestamp :: UTCTime
toTimestamp = PreFormatted -> UTCTime
pfTime PreFormatted
v
                , toHostname :: Text
toHostname  = Text
hostname
                , toThreadId :: Text
toThreadId  = PreFormatted -> Text
pfThreadId PreFormatted
v
                }
            in (LoggingContext
lc, FormattedMessage -> Either TraceControl FormattedMessage
forall a b. b -> Either a b
Right (TraceObject -> FormattedMessage
FormattedForwarder TraceObject
to))
      (LoggingContext
lc, Left TraceControl
ctrl) -> (LoggingContext
lc, TraceControl -> Either TraceControl FormattedMessage
forall a b. a -> Either a b
Left TraceControl
ctrl))
      Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr

-- | Format this trace as TraceObject for machine-readable text output (JSON)
machineFormatter'
  :: forall m .
     MonadIO m
  => Trace m FormattedMessage
  -> Trace m PreFormatted
machineFormatter' :: forall (m :: * -> *).
MonadIO m =>
Trace m FormattedMessage -> Trace m PreFormatted
machineFormatter' (Trace Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr) = Tracer m (LoggingContext, Either TraceControl PreFormatted)
-> Trace m PreFormatted
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl PreFormatted)
 -> Trace m PreFormatted)
-> Tracer m (LoggingContext, Either TraceControl PreFormatted)
-> Trace m PreFormatted
forall a b. (a -> b) -> a -> b
$
  ((LoggingContext, Either TraceControl PreFormatted)
 -> (LoggingContext, Either TraceControl FormattedMessage))
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Tracer m (LoggingContext, Either TraceControl PreFormatted)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap
    (\ case
      (LoggingContext
lc, Right PreFormatted
v) ->
        let
          msg :: TraceMessage
msg = TraceMessage
            { tmsgAt :: UTCTime
tmsgAt      = PreFormatted -> UTCTime
pfTime PreFormatted
v
            , tmsgNS :: Text
tmsgNS      = PreFormatted -> Text
pfNamespace PreFormatted
v
            , tmsgData :: Object
tmsgData    = PreFormatted -> Object
pfForMachineObject PreFormatted
v
            , tmsgSev :: SeverityS
tmsgSev     = SeverityS -> Maybe SeverityS -> SeverityS
forall a. a -> Maybe a -> a
fromMaybe SeverityS
Info (Maybe SeverityS -> SeverityS) -> Maybe SeverityS -> SeverityS
forall a b. (a -> b) -> a -> b
$ LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc
            , tmsgThread :: Text
tmsgThread  = PreFormatted -> Text
pfThreadId PreFormatted
v
            , tmsgHost :: Text
tmsgHost    = Text
hostname
            }
        in (LoggingContext
lc, FormattedMessage -> Either TraceControl FormattedMessage
forall a b. b -> Either a b
Right (Text -> FormattedMessage
FormattedMachine (Text -> Text
toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ TraceMessage -> ByteString
forall a. ToJSON a => a -> ByteString
AE.encode TraceMessage
msg)))
      (LoggingContext
lc, Left TraceControl
ctrl) -> (LoggingContext
lc, TraceControl -> Either TraceControl FormattedMessage
forall a b. a -> Either a b
Left TraceControl
ctrl))
      Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr

-- | Format this trace in binary serialisation (CBOR)
cborFormatter'
  :: forall m .
     MonadIO m
  => Trace m FormattedMessage
  -> Trace m PreFormatted
cborFormatter' :: forall (m :: * -> *).
MonadIO m =>
Trace m FormattedMessage -> Trace m PreFormatted
cborFormatter' (Trace Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr) = Tracer m (LoggingContext, Either TraceControl PreFormatted)
-> Trace m PreFormatted
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl PreFormatted)
 -> Trace m PreFormatted)
-> Tracer m (LoggingContext, Either TraceControl PreFormatted)
-> Trace m PreFormatted
forall a b. (a -> b) -> a -> b
$
  ((LoggingContext, Either TraceControl PreFormatted)
 -> (LoggingContext, Either TraceControl FormattedMessage))
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Tracer m (LoggingContext, Either TraceControl PreFormatted)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap
    (\ case
      (LoggingContext
lc, Right PreFormatted
v) ->
        let
          cborObj :: TraceMessage
cborObj = TraceMessage
            { tmsgAt :: UTCTime
tmsgAt      = PreFormatted -> UTCTime
pfTime PreFormatted
v
            , tmsgNS :: Text
tmsgNS      = PreFormatted -> Text
pfNamespace PreFormatted
v
            , tmsgData :: Object
tmsgData    = PreFormatted -> Object
pfForMachineObject PreFormatted
v
            , tmsgSev :: SeverityS
tmsgSev     = SeverityS -> Maybe SeverityS -> SeverityS
forall a. a -> Maybe a -> a
fromMaybe SeverityS
Info (Maybe SeverityS -> SeverityS) -> Maybe SeverityS -> SeverityS
forall a b. (a -> b) -> a -> b
$ LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc
            , tmsgThread :: Text
tmsgThread  = PreFormatted -> Text
pfThreadId PreFormatted
v
            , tmsgHost :: Text
tmsgHost    = Text
hostname
            }
        in (LoggingContext
lc, FormattedMessage -> Either TraceControl FormattedMessage
forall a b. b -> Either a b
Right (ByteString -> FormattedMessage
FormattedCBOR (ByteString -> FormattedMessage) -> ByteString -> FormattedMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ TraceMessage -> ByteString
forall a. Serialise a => a -> ByteString
serialise TraceMessage
cborObj))
      (LoggingContext
lc, Left TraceControl
ctrl) -> (LoggingContext
lc, TraceControl -> Either TraceControl FormattedMessage
forall a b. a -> Either a b
Left TraceControl
ctrl))
      Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr

-- | Format this trace in human readable text output
humanFormatter'
  :: forall m .
     MonadIO m
  => Bool
  -> Trace m FormattedMessage
  -> Trace m PreFormatted
humanFormatter' :: forall (m :: * -> *).
MonadIO m =>
Bool -> Trace m FormattedMessage -> Trace m PreFormatted
humanFormatter' Bool
withColor (Trace Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr) =
  Tracer m (LoggingContext, Either TraceControl PreFormatted)
-> Trace m PreFormatted
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (Tracer m (LoggingContext, Either TraceControl PreFormatted)
 -> Trace m PreFormatted)
-> Tracer m (LoggingContext, Either TraceControl PreFormatted)
-> Trace m PreFormatted
forall a b. (a -> b) -> a -> b
$
      ((LoggingContext, Either TraceControl PreFormatted)
 -> (LoggingContext, Either TraceControl FormattedMessage))
-> Tracer m (LoggingContext, Either TraceControl FormattedMessage)
-> Tracer m (LoggingContext, Either TraceControl PreFormatted)
forall a' a. (a' -> a) -> Tracer m a -> Tracer m a'
forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap
        (\ case
          (LoggingContext
lc, Right PreFormatted
v) ->
              let sev :: SeverityS
sev      = SeverityS -> Maybe SeverityS -> SeverityS
forall a. a -> Maybe a -> a
fromMaybe SeverityS
Info (LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc)
                  ns :: Builder
ns       = Text -> Builder
fromText Text
hostname
                                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
':'
                                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText (PreFormatted -> Text
pfNamespace PreFormatted
v)
                  showTime :: UTCTime -> String
showTime = TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%F %H:%M:%S%4QZ"
                  prePart :: Builder
prePart  = Builder -> Builder
squareBrackets (String -> Builder
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ UTCTime -> String
showTime (UTCTime -> String) -> UTCTime -> String
forall a b. (a -> b) -> a -> b
$ PreFormatted -> UTCTime
pfTime PreFormatted
v)
                                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
squareBrackets Builder
ns
                                Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder -> Builder
roundBrackets
                                    (String -> Builder
fromString (SeverityS -> String
forall a. Show a => a -> String
show SeverityS
sev)
                                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
','
                                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText (PreFormatted -> Text
pfThreadId PreFormatted
v))
                  dataPart :: Text
dataPart = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe
                                (Text -> Text
toStrict (Text -> Text) -> (Encoding -> Text) -> Encoding -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (Encoding -> ByteString) -> Encoding -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
forall a. Encoding' a -> ByteString
AE.encodingToLazyByteString (Encoding -> Text) -> Encoding -> Text
forall a b. (a -> b) -> a -> b
$ 
                                  Series -> Encoding
AE.pairs (Key
"data" Key -> Object -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PreFormatted -> Object
pfForMachineObject PreFormatted
v)
                                )
                                (PreFormatted -> Maybe Text
pfForHuman PreFormatted
v)
                  forHuman'' :: Text
forHuman'' = Text -> Text
toStrict
                                (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText
                                  (Bool -> SeverityS -> Builder -> Builder
colorBySeverity Bool
withColor SeverityS
sev Builder
prePart
                                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
' '
                                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
dataPart)
                  in (LoggingContext
lc, FormattedMessage -> Either TraceControl FormattedMessage
forall a b. b -> Either a b
Right (Bool -> Text -> FormattedMessage
FormattedHuman Bool
withColor Text
forHuman''))
          (LoggingContext
lc, Left TraceControl
ctrl) -> (LoggingContext
lc, TraceControl -> Either TraceControl FormattedMessage
forall a b. a -> Either a b
Left TraceControl
ctrl))
          Tracer m (LoggingContext, Either TraceControl FormattedMessage)
tr

squareBrackets :: Builder -> Builder
squareBrackets :: Builder -> Builder
squareBrackets Builder
b = Char -> Builder
singleton Char
'[' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
']'

roundBrackets :: Builder -> Builder
roundBrackets :: Builder -> Builder
roundBrackets Builder
b = Char -> Builder
singleton Char
'(' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
b Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
')'

-- | 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 :: Bool -> SeverityS -> Builder -> Builder
colorBySeverity Bool
withColor SeverityS
severity' Builder
msg =
  if Bool
withColor
    then case SeverityS
severity' of
            SeverityS
Emergency -> Builder -> Builder
red Builder
msg
            SeverityS
Alert     -> Builder -> Builder
red Builder
msg
            SeverityS
Critical  -> Builder -> Builder
red Builder
msg
            SeverityS
Error     -> Builder -> Builder
red Builder
msg
            SeverityS
Warning   -> Builder -> Builder
yellow Builder
msg
            SeverityS
Notice    -> Builder -> Builder
magenta Builder
msg
            SeverityS
Info      -> Builder -> Builder
blue Builder
msg
            SeverityS
Debug     -> Builder
msg
    else Builder
msg
  where
    red :: Builder -> Builder
red = Builder -> Builder -> Builder
forall {a}. (Semigroup a, IsString a) => a -> a -> a
colorize Builder
"31"
    yellow :: Builder -> Builder
yellow = Builder -> Builder -> Builder
forall {a}. (Semigroup a, IsString a) => a -> a -> a
colorize Builder
"33"
    magenta :: Builder -> Builder
magenta = Builder -> Builder -> Builder
forall {a}. (Semigroup a, IsString a) => a -> a -> a
colorize Builder
"35"
    blue :: Builder -> Builder
blue = Builder -> Builder -> Builder
forall {a}. (Semigroup a, IsString a) => a -> a -> a
colorize Builder
"34"
    colorize :: a -> a -> a
colorize a
c a
msg' = a
"\ESC[" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
c a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"m" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
msg' a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\ESC[0m"

humanFormatter
  :: forall a m .
     MonadIO m
  => LogFormatting a
  => Bool
  -> Trace m FormattedMessage
  -> m (Trace m a)
humanFormatter :: forall a (m :: * -> *).
(MonadIO m, LogFormatting a) =>
Bool -> Trace m FormattedMessage -> m (Trace m a)
humanFormatter Bool
withColor =
  Bool -> Trace m PreFormatted -> m (Trace m a)
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> m (Trace m a)
preFormatted Bool
True (Trace m PreFormatted -> m (Trace m a))
-> (Trace m FormattedMessage -> Trace m PreFormatted)
-> Trace m FormattedMessage
-> m (Trace m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Trace m FormattedMessage -> Trace m PreFormatted
forall (m :: * -> *).
MonadIO m =>
Bool -> Trace m FormattedMessage -> Trace m PreFormatted
humanFormatter' Bool
withColor

machineFormatter
  :: forall a m .
     (MonadIO m
  ,  LogFormatting a)
  => Trace m FormattedMessage
  -> m (Trace m a)
machineFormatter :: forall a (m :: * -> *).
(MonadIO m, LogFormatting a) =>
Trace m FormattedMessage -> m (Trace m a)
machineFormatter =
  Bool -> Trace m PreFormatted -> m (Trace m a)
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> m (Trace m a)
preFormatted Bool
False (Trace m PreFormatted -> m (Trace m a))
-> (Trace m FormattedMessage -> Trace m PreFormatted)
-> Trace m FormattedMessage
-> m (Trace m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace m FormattedMessage -> Trace m PreFormatted
forall (m :: * -> *).
MonadIO m =>
Trace m FormattedMessage -> Trace m PreFormatted
machineFormatter'

cborFormatter
  :: forall a m .
     (MonadIO m
  ,  LogFormatting a)
  => Trace m FormattedMessage
  -> m (Trace m a)
cborFormatter :: forall a (m :: * -> *).
(MonadIO m, LogFormatting a) =>
Trace m FormattedMessage -> m (Trace m a)
cborFormatter =
  Bool -> Trace m PreFormatted -> m (Trace m a)
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> m (Trace m a)
preFormatted Bool
False (Trace m PreFormatted -> m (Trace m a))
-> (Trace m FormattedMessage -> Trace m PreFormatted)
-> Trace m FormattedMessage
-> m (Trace m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace m FormattedMessage -> Trace m PreFormatted
forall (m :: * -> *).
MonadIO m =>
Trace m FormattedMessage -> Trace m PreFormatted
cborFormatter'

forwardFormatter
  :: forall a m .
     MonadIO m
  => LogFormatting a
  => Trace m FormattedMessage
  -> m (Trace m a)
forwardFormatter :: forall a (m :: * -> *).
(MonadIO m, LogFormatting a) =>
Trace m FormattedMessage -> m (Trace m a)
forwardFormatter =
  Bool -> Trace m PreFormatted -> m (Trace m a)
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> m (Trace m a)
preFormatted Bool
True (Trace m PreFormatted -> m (Trace m a))
-> (Trace m FormattedMessage -> Trace m PreFormatted)
-> Trace m FormattedMessage
-> m (Trace m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace m FormattedMessage -> Trace m PreFormatted
forall (m :: * -> *).
MonadIO m =>
Trace m FormattedMessage -> Trace m PreFormatted
forwardFormatter'