{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-# OPTIONS_GHC -Wno-orphans #-}

module Hermod.Tracing.Formatter (
    FormattedMessage(..)
  , PreFormatted(..)
  , TraceObject(..)
  , metricsFormatter
  , preFormatted
  , forwardFormatter
  , forwardFormatter'
  , machineFormatter
  , machineFormatter'
  , cborFormatter
  , cborFormatter'
  , humanFormatter
  , humanFormatter'
) where

import           Hermod.Tracing.Trace (contramapM)
import           Hermod.Tracing.Types
import           Hermod.Tracing.Types.TraceMessage

import           Codec.Serialise (Serialise (..), serialise)
import           Control.DeepSeq (NFData)
import           Data.ByteString (ByteString)
import           GHC.Generics (Generic)
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 (UTCTime, defaultTimeLocale, formatTime, getCurrentTime)
import           Network.HostName
import           System.Environment (lookupEnv)
import           System.IO.Unsafe (unsafePerformIO)



data FormattedMessage =
      FormattedHuman Bool Text
      -- ^ The bool specifies if the formatting includes colours
    | FormattedMachine Text
    | FormattedMetrics [Metric]
    | FormattedForwarder TraceObject
    | FormattedCBOR ByteString
  deriving stock (FormattedMessage -> FormattedMessage -> Bool
(FormattedMessage -> FormattedMessage -> Bool)
-> (FormattedMessage -> FormattedMessage -> Bool)
-> Eq FormattedMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FormattedMessage -> FormattedMessage -> Bool
== :: FormattedMessage -> FormattedMessage -> Bool
$c/= :: FormattedMessage -> FormattedMessage -> Bool
/= :: FormattedMessage -> FormattedMessage -> Bool
Eq, Int -> FormattedMessage -> ShowS
[FormattedMessage] -> ShowS
FormattedMessage -> String
(Int -> FormattedMessage -> ShowS)
-> (FormattedMessage -> String)
-> ([FormattedMessage] -> ShowS)
-> Show FormattedMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FormattedMessage -> ShowS
showsPrec :: Int -> FormattedMessage -> ShowS
$cshow :: FormattedMessage -> String
show :: FormattedMessage -> String
$cshowList :: [FormattedMessage] -> ShowS
showList :: [FormattedMessage] -> ShowS
Show)


data PreFormatted = PreFormatted {
    PreFormatted -> UTCTime
pfTime             :: !UTCTime
  , PreFormatted -> Text
pfNamespace        :: !Text
  , PreFormatted -> Text
pfThreadId         :: !Text
  , PreFormatted -> Maybe Text
pfForHuman         :: !(Maybe Text)
  , PreFormatted -> Object
pfForMachineObject :: AE.Object
}

-- | Used as interface object for ForwarderTracer
data TraceObject = TraceObject {
    TraceObject -> Maybe Text
toHuman     :: !(Maybe Text)
  , TraceObject -> Text
toMachine   :: !Text
  , TraceObject -> [Text]
toNamespace :: ![Text]
  , TraceObject -> SeverityS
toSeverity  :: !SeverityS
  , TraceObject -> DetailLevel
toDetails   :: !DetailLevel
  , TraceObject -> UTCTime
toTimestamp :: !UTCTime
  , TraceObject -> Text
toHostname  :: !Text
  , TraceObject -> Text
toThreadId  :: !Text
} deriving stock
    (TraceObject -> TraceObject -> Bool
(TraceObject -> TraceObject -> Bool)
-> (TraceObject -> TraceObject -> Bool) -> Eq TraceObject
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TraceObject -> TraceObject -> Bool
== :: TraceObject -> TraceObject -> Bool
$c/= :: TraceObject -> TraceObject -> Bool
/= :: TraceObject -> TraceObject -> Bool
Eq, Int -> TraceObject -> ShowS
[TraceObject] -> ShowS
TraceObject -> String
(Int -> TraceObject -> ShowS)
-> (TraceObject -> String)
-> ([TraceObject] -> ShowS)
-> Show TraceObject
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TraceObject -> ShowS
showsPrec :: Int -> TraceObject -> ShowS
$cshow :: TraceObject -> String
show :: TraceObject -> String
$cshowList :: [TraceObject] -> ShowS
showList :: [TraceObject] -> ShowS
Show, (forall x. TraceObject -> Rep TraceObject x)
-> (forall x. Rep TraceObject x -> TraceObject)
-> Generic TraceObject
forall x. Rep TraceObject x -> TraceObject
forall x. TraceObject -> Rep TraceObject x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TraceObject -> Rep TraceObject x
from :: forall x. TraceObject -> Rep TraceObject x
$cto :: forall x. Rep TraceObject x -> TraceObject
to :: forall x. Rep TraceObject x -> TraceObject
Generic)
  -- ^ Instances for 'TraceObject' to forward it using 'trace-forward' library.
  deriving anyclass
    ([TraceObject] -> Encoding
TraceObject -> Encoding
(TraceObject -> Encoding)
-> (forall s. Decoder s TraceObject)
-> ([TraceObject] -> Encoding)
-> (forall s. Decoder s [TraceObject])
-> Serialise TraceObject
forall s. Decoder s [TraceObject]
forall s. Decoder s TraceObject
forall a.
(a -> Encoding)
-> (forall s. Decoder s a)
-> ([a] -> Encoding)
-> (forall s. Decoder s [a])
-> Serialise a
$cencode :: TraceObject -> Encoding
encode :: TraceObject -> Encoding
$cdecode :: forall s. Decoder s TraceObject
decode :: forall s. Decoder s TraceObject
$cencodeList :: [TraceObject] -> Encoding
encodeList :: [TraceObject] -> Encoding
$cdecodeList :: forall s. Decoder s [TraceObject]
decodeList :: forall s. Decoder s [TraceObject]
Serialise, TraceObject -> ()
(TraceObject -> ()) -> NFData TraceObject
forall a. (a -> ()) -> NFData a
$crnf :: TraceObject -> ()
rnf :: TraceObject -> ()
NFData)


-- | If the @HERMOD_TRACING_LOGGING_HOSTNAME@ environment variable is set,
--   it overrides the system hostname in the trace message. This is useful when
--   multiple instances of a service or application on the same host.
--
--   The env var is expected to be set (if desired) before the application emits its first trace, as this is evaluated only once.
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 -> IO (Maybe String)
lookupEnv String
"HERMOD_TRACING_LOGGING_HOSTNAME" IO (Maybe String) -> (Maybe String -> IO Text) -> IO Text
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO Text -> (String -> IO Text) -> Maybe String -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO Text
hostNameOnly (Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> (String -> Text) -> String -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)
  where
    -- disregard FQDNs
    hostNameOnly :: IO Text
hostNameOnly = String -> Text
T.pack (String -> Text) -> ShowS -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.') (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
  -> Trace m a
preFormatted :: forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> Trace m a
preFormatted Bool
withForHuman =
  (Trace m PreFormatted
 -> ((LoggingContext, Either TraceControl a)
     -> m (LoggingContext, Either TraceControl PreFormatted))
 -> Trace m a)
-> ((LoggingContext, Either TraceControl a)
    -> m (LoggingContext, Either TraceControl PreFormatted))
-> Trace m PreFormatted
-> 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))
-> Trace m a
forall (m :: * -> *) b a.
Monad m =>
Trace m b
-> ((LoggingContext, Either TraceControl a)
    -> m (LoggingContext, Either TraceControl b))
-> Trace m a
contramapM (((LoggingContext, Either TraceControl a)
  -> m (LoggingContext, Either TraceControl PreFormatted))
 -> Trace m PreFormatted -> Trace m a)
-> ((LoggingContext, Either TraceControl a)
    -> m (LoggingContext, Either TraceControl PreFormatted))
-> Trace m PreFormatted
-> Trace m a
forall a b. (a -> b) -> a -> b
$ \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 -> ShowS
forall a. Int -> [a] -> [a]
drop Int
9 ShowS -> ShowS
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
  -> Trace m a
humanFormatter :: forall a (m :: * -> *).
(MonadIO m, LogFormatting a) =>
Bool -> Trace m FormattedMessage -> Trace m a
humanFormatter Bool
withColor =
  Bool -> Trace m PreFormatted -> Trace m a
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> Trace m a
preFormatted Bool
True (Trace m PreFormatted -> Trace m a)
-> (Trace m FormattedMessage -> Trace m PreFormatted)
-> Trace m FormattedMessage
-> 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
  -> Trace m a
machineFormatter :: forall a (m :: * -> *).
(MonadIO m, LogFormatting a) =>
Trace m FormattedMessage -> Trace m a
machineFormatter =
  Bool -> Trace m PreFormatted -> Trace m a
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> Trace m a
preFormatted Bool
False (Trace m PreFormatted -> Trace m a)
-> (Trace m FormattedMessage -> Trace m PreFormatted)
-> Trace m FormattedMessage
-> 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
  -> Trace m a
cborFormatter :: forall a (m :: * -> *).
(MonadIO m, LogFormatting a) =>
Trace m FormattedMessage -> Trace m a
cborFormatter =
  Bool -> Trace m PreFormatted -> Trace m a
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> Trace m a
preFormatted Bool
False (Trace m PreFormatted -> Trace m a)
-> (Trace m FormattedMessage -> Trace m PreFormatted)
-> Trace m FormattedMessage
-> 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
  -> Trace m a
forwardFormatter :: forall a (m :: * -> *).
(MonadIO m, LogFormatting a) =>
Trace m FormattedMessage -> Trace m a
forwardFormatter =
  Bool -> Trace m PreFormatted -> Trace m a
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> Trace m a
preFormatted Bool
True (Trace m PreFormatted -> Trace m a)
-> (Trace m FormattedMessage -> Trace m PreFormatted)
-> Trace m FormattedMessage
-> 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'