{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- HLINT ignore "Monad law, left identity" -}

module Cardano.Logging.Tracer.Composed (
    mkCardanoTracer
  , mkCardanoTracer'
  , mkMetricsTracer
  , traceTracerInfo
  , traceConfigWarnings
  , traceEffectiveConfiguration
  ) where

import           Cardano.Logging.Configuration
import           Cardano.Logging.Formatter
import           Cardano.Logging.Trace
import           Cardano.Logging.TraceDispatcherMessage
import           Cardano.Logging.Types

import           Control.Concurrent.MVar
import           Control.Monad (when)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Control.Tracer as T
import           Data.IORef
import qualified Data.List as L
import qualified Data.Map as Map
import           Data.Maybe (fromMaybe, isNothing)
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
-- messages and an instance of MetaTrace for meta information such as
-- severity, privacy, details and backends'.
-- The tracer gets the backends': 'trStdout', 'trForward' and 'mbTrEkg'
-- as arguments.
-- The returned tracer needs to be configured with a configuration
-- before it is used.
mkCardanoTracer :: forall evt.
     ( LogFormatting evt
     , MetaTrace evt)
  => Trace IO FormattedMessage
  -> Trace IO FormattedMessage
  -> Maybe (Trace IO FormattedMessage)
  -> [Text]
  -> IO (Trace IO evt)
mkCardanoTracer :: forall evt.
(LogFormatting evt, MetaTrace evt) =>
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe (Trace IO FormattedMessage)
-> [Text]
-> IO (Trace IO evt)
mkCardanoTracer Trace IO FormattedMessage
trStdout Trace IO FormattedMessage
trForward Maybe (Trace IO FormattedMessage)
mbTrEkg [Text]
tracerPrefix =
    Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe (Trace IO FormattedMessage)
-> [Text]
-> (Trace IO evt -> IO (Trace IO evt))
-> IO (Trace IO evt)
forall evt evt1.
(LogFormatting evt1, MetaTrace evt1) =>
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe (Trace IO FormattedMessage)
-> [Text]
-> (Trace IO evt1 -> IO (Trace IO evt))
-> IO (Trace IO evt)
mkCardanoTracer' Trace IO FormattedMessage
trStdout Trace IO FormattedMessage
trForward Maybe (Trace IO FormattedMessage)
mbTrEkg [Text]
tracerPrefix Trace IO evt -> IO (Trace IO evt)
noHook
  where
    noHook :: Trace IO evt -> IO (Trace IO evt)
    noHook :: Trace IO evt -> IO (Trace IO evt)
noHook = Trace IO evt -> IO (Trace IO evt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Adds the possibility to add special tracers via the hook function
mkCardanoTracer' :: forall evt evt1.
     ( LogFormatting evt1
     , MetaTrace evt1
     )
  => Trace IO FormattedMessage
  -> Trace IO FormattedMessage
  -> Maybe (Trace IO FormattedMessage)
  -> [Text]
  -> (Trace IO evt1 -> IO (Trace IO evt))
  -> IO (Trace IO evt)
mkCardanoTracer' :: forall evt evt1.
(LogFormatting evt1, MetaTrace evt1) =>
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe (Trace IO FormattedMessage)
-> [Text]
-> (Trace IO evt1 -> IO (Trace IO evt))
-> IO (Trace IO evt)
mkCardanoTracer' Trace IO FormattedMessage
trStdout Trace IO FormattedMessage
trForward Maybe (Trace IO FormattedMessage)
mbTrEkg [Text]
tracerPrefix Trace IO evt1 -> IO (Trace IO evt)
hook = do

    !Trace IO TraceDispatcherMessage
internalTr <-  Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO Any
-> IO (Trace IO TraceDispatcherMessage)
forall a x.
LogFormatting a =>
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO x
-> IO (Trace IO a)
backendsAndFormat
                      Trace IO FormattedMessage
trStdout
                      Trace IO FormattedMessage
trForward
                      Maybe [BackendConfig]
forall a. Maybe a
Nothing
                      (Tracer IO (LoggingContext, Either TraceControl Any) -> Trace IO Any
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer IO (LoggingContext, Either TraceControl Any)
forall (m :: * -> *) a. Monad m => Tracer m a
T.nullTracer)
                    IO (Trace IO TraceDispatcherMessage)
-> (Trace IO TraceDispatcherMessage
    -> IO (Trace IO TraceDispatcherMessage))
-> IO (Trace IO TraceDispatcherMessage)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Trace IO TraceDispatcherMessage
-> IO (Trace IO TraceDispatcherMessage)
forall a. MetaTrace a => Trace IO a -> IO (Trace IO a)
addContextAndFilter

    -- handle the messages
    !Trace IO evt
messageTrace <- (Maybe [BackendConfig]
 -> Trace IO FormattedMessage -> IO (Trace IO evt1))
-> IO (Trace IO evt1)
forall (m :: * -> *) a.
MonadIO m =>
(Maybe [BackendConfig]
 -> Trace m FormattedMessage -> m (Trace m a))
-> m (Trace m a)
withBackendsFromConfig (Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO FormattedMessage
-> IO (Trace IO evt1)
forall a x.
LogFormatting a =>
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO x
-> IO (Trace IO a)
backendsAndFormat Trace IO FormattedMessage
trStdout Trace IO FormattedMessage
trForward)
                    IO (Trace IO evt1)
-> (Trace IO evt1 -> IO (Trace IO evt1)) -> IO (Trace IO evt1)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Trace IO TraceDispatcherMessage
-> Trace IO evt1 -> IO (Trace IO evt1)
forall a (m :: * -> *).
MonadUnliftIO m =>
Trace m TraceDispatcherMessage -> Trace m a -> m (Trace m a)
withLimitersFromConfig Trace IO TraceDispatcherMessage
internalTr
                    IO (Trace IO evt1)
-> (Trace IO evt1 -> IO (Trace IO evt1)) -> IO (Trace IO evt1)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Trace IO TraceDispatcherMessage
-> Trace IO evt1 -> IO (Trace IO evt1)
traceNamespaceErrors Trace IO TraceDispatcherMessage
internalTr
                    IO (Trace IO evt1)
-> (Trace IO evt1 -> IO (Trace IO evt1)) -> IO (Trace IO evt1)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Trace IO evt1 -> IO (Trace IO evt1)
forall a. MetaTrace a => Trace IO a -> IO (Trace IO a)
addContextAndFilter
                    IO (Trace IO evt1)
-> (Trace IO evt1 -> IO (Trace IO evt1)) -> IO (Trace IO evt1)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TraceConfig -> Namespace evt1 -> Bool)
-> [Text] -> Bool -> Trace IO evt1 -> IO (Trace IO evt1)
forall (m :: * -> *) a.
MonadIO m =>
(TraceConfig -> Namespace a -> Bool)
-> [Text] -> Bool -> Trace m a -> m (Trace m a)
maybeSilent TraceConfig -> Namespace evt1 -> Bool
forall a. MetaTrace a => TraceConfig -> Namespace a -> Bool
isSilentTracer [Text]
tracerPrefix Bool
False
                    IO (Trace IO evt1)
-> (Trace IO evt1 -> IO (Trace IO evt)) -> IO (Trace IO evt)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Trace IO evt1 -> IO (Trace IO evt)
hook

    -- handle the metrics
    !Trace IO evt
metricsTrace <- case Maybe (Trace IO FormattedMessage)
mbTrEkg of
                      Maybe (Trace IO FormattedMessage)
Nothing -> Trace IO evt -> IO (Trace IO evt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace IO evt -> IO (Trace IO evt))
-> Trace IO evt -> IO (Trace IO evt)
forall a b. (a -> b) -> a -> b
$ Tracer IO (LoggingContext, Either TraceControl evt) -> Trace IO evt
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer IO (LoggingContext, Either TraceControl evt)
forall (m :: * -> *) a. Monad m => Tracer m a
T.nullTracer
                      Just Trace IO FormattedMessage
ekgTrace ->
                        Trace IO evt1 -> IO (Trace IO evt1)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace IO FormattedMessage -> Trace IO evt1
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Trace m FormattedMessage -> Trace m a
metricsFormatter Trace IO FormattedMessage
ekgTrace)
--                      >>= recordMetricsStatistics internalTr
                        IO (Trace IO evt1)
-> (Trace IO evt1 -> IO (Trace IO evt1)) -> IO (Trace IO evt1)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (TraceConfig -> Namespace evt1 -> Bool)
-> [Text] -> Bool -> Trace IO evt1 -> IO (Trace IO evt1)
forall (m :: * -> *) a.
MonadIO m =>
(TraceConfig -> Namespace a -> Bool)
-> [Text] -> Bool -> Trace m a -> m (Trace m a)
maybeSilent TraceConfig -> Namespace evt1 -> Bool
forall a. MetaTrace a => TraceConfig -> Namespace a -> Bool
hasNoMetrics [Text]
tracerPrefix Bool
True
                        IO (Trace IO evt1)
-> (Trace IO evt1 -> IO (Trace IO evt)) -> IO (Trace IO evt)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Trace IO evt1 -> IO (Trace IO evt)
hook

    Trace IO evt -> IO (Trace IO evt)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace IO evt
messageTrace Trace IO evt -> Trace IO evt -> Trace IO evt
forall a. Semigroup a => a -> a -> a
<> Trace IO evt
metricsTrace)

  where
    {-# INLINE addContextAndFilter #-}
    addContextAndFilter :: MetaTrace a => Trace IO a -> IO (Trace IO a)
    addContextAndFilter :: forall a. MetaTrace a => Trace IO a -> IO (Trace IO a)
addContextAndFilter Trace IO a
tr = do
      Trace IO a
tr'  <- Trace IO a -> IO (Trace IO a)
forall (m :: * -> *) a. MonadIO m => Trace m a -> m (Trace m a)
withDetailsFromConfig
                (Trace IO a -> IO (Trace IO a)) -> Trace IO a -> IO (Trace IO a)
forall a b. (a -> b) -> a -> b
$ Trace IO a -> Trace IO a
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withPrivacy
                  (Trace IO a -> Trace IO a) -> Trace IO a -> Trace IO a
forall a b. (a -> b) -> a -> b
$ Trace IO a -> Trace IO a
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withDetails Trace IO a
tr
      Trace IO a
tr'' <- Trace IO a -> IO (Trace IO a)
forall (m :: * -> *) a. MonadIO m => Trace m a -> m (Trace m a)
filterSeverityFromConfig Trace IO a
tr'
      Trace IO a -> IO (Trace IO a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace IO a -> IO (Trace IO a)) -> Trace IO a -> IO (Trace IO a)
forall a b. (a -> b) -> a -> b
$ [Text] -> Trace IO a -> Trace IO a
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
[Text] -> Trace m a -> Trace m a
withNames [Text]
tracerPrefix
             (Trace IO a -> Trace IO a) -> Trace IO a -> Trace IO a
forall a b. (a -> b) -> a -> b
$ Trace IO a -> Trace IO a
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withSeverity Trace IO a
tr''

    traceNamespaceErrors ::
         Trace IO TraceDispatcherMessage
      -> Trace IO evt1
      -> IO (Trace IO evt1)
    traceNamespaceErrors :: Trace IO TraceDispatcherMessage
-> Trace IO evt1 -> IO (Trace IO evt1)
traceNamespaceErrors Trace IO TraceDispatcherMessage
internalTr (Trace Tracer IO (LoggingContext, Either TraceControl evt1)
tr) = do
        Trace IO evt1 -> IO (Trace IO evt1)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace IO evt1 -> IO (Trace IO evt1))
-> Trace IO evt1 -> IO (Trace IO evt1)
forall a b. (a -> b) -> a -> b
$ Tracer IO (LoggingContext, Either TraceControl evt1)
-> Trace IO evt1
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (TracerA IO (LoggingContext, Either TraceControl evt1) ()
-> Tracer IO (LoggingContext, Either TraceControl evt1)
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
T.arrow (((LoggingContext, Either TraceControl evt1) -> IO ())
-> TracerA IO (LoggingContext, Either TraceControl evt1) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
T.emit
          (\case
            (LoggingContext
lc, Right evt1
e) -> LoggingContext -> Either TraceControl evt1 -> IO ()
process LoggingContext
lc (evt1 -> Either TraceControl evt1
forall a b. b -> Either a b
Right evt1
e)
            (LoggingContext
lc, Left TraceControl
e) -> Tracer IO (LoggingContext, Either TraceControl evt1)
-> (LoggingContext, Either TraceControl evt1) -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer IO (LoggingContext, Either TraceControl evt1)
tr (LoggingContext
lc, TraceControl -> Either TraceControl evt1
forall a b. a -> Either a b
Left TraceControl
e))))
      where
        process :: LoggingContext -> Either TraceControl evt1 -> IO ()
        process :: LoggingContext -> Either TraceControl evt1 -> IO ()
process LoggingContext
lc Either TraceControl evt1
cont = do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Privacy -> Bool
forall a. Maybe a -> Bool
isNothing (LoggingContext -> Maybe Privacy
lcPrivacy LoggingContext
lc)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  Trace IO TraceDispatcherMessage -> TraceDispatcherMessage -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith
                    ([Text]
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text
"Reflection"] Trace IO TraceDispatcherMessage
internalTr)
                    ([Text] -> [Text] -> UnknownNamespaceKind -> TraceDispatcherMessage
UnknownNamespace (LoggingContext -> [Text]
lcNSPrefix LoggingContext
lc) (LoggingContext -> [Text]
lcNSInner LoggingContext
lc) UnknownNamespaceKind
UKFPrivacy)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe SeverityS -> Bool
forall a. Maybe a -> Bool
isNothing (LoggingContext -> Maybe SeverityS
lcSeverity LoggingContext
lc)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  Trace IO TraceDispatcherMessage -> TraceDispatcherMessage -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith
                    ([Text]
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text
"Reflection"] Trace IO TraceDispatcherMessage
internalTr)
                    ([Text] -> [Text] -> UnknownNamespaceKind -> TraceDispatcherMessage
UnknownNamespace (LoggingContext -> [Text]
lcNSPrefix LoggingContext
lc) (LoggingContext -> [Text]
lcNSInner LoggingContext
lc) UnknownNamespaceKind
UKFSeverity)
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe DetailLevel -> Bool
forall a. Maybe a -> Bool
isNothing (LoggingContext -> Maybe DetailLevel
lcDetails LoggingContext
lc)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                  Trace IO TraceDispatcherMessage -> TraceDispatcherMessage -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith
                    ([Text]
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text
"Reflection"] Trace IO TraceDispatcherMessage
internalTr)
                    ([Text] -> [Text] -> UnknownNamespaceKind -> TraceDispatcherMessage
UnknownNamespace (LoggingContext -> [Text]
lcNSPrefix LoggingContext
lc) (LoggingContext -> [Text]
lcNSInner LoggingContext
lc) UnknownNamespaceKind
UKFDetails)
          Tracer IO (LoggingContext, Either TraceControl evt1)
-> (LoggingContext, Either TraceControl evt1) -> IO ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer IO (LoggingContext, Either TraceControl evt1)
tr (LoggingContext
lc, Either TraceControl evt1
cont)

backendsAndFormat ::
     LogFormatting a
  => Trace IO FormattedMessage
  -> Trace IO FormattedMessage
  -> Maybe [BackendConfig]
  -> Trace IO x
  -> IO (Trace IO a)
backendsAndFormat :: forall a x.
LogFormatting a =>
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO x
-> IO (Trace IO a)
backendsAndFormat Trace IO FormattedMessage
trStdout Trace IO FormattedMessage
trForward Maybe [BackendConfig]
mbBackends Trace IO x
_ = do
    let mbForwardTrace :: Maybe (Trace IO PreFormatted)
mbForwardTrace  = if Bool
forwarder
                            then Trace IO PreFormatted -> Maybe (Trace IO PreFormatted)
forall a. a -> Maybe a
Just (Trace IO PreFormatted -> Maybe (Trace IO PreFormatted))
-> Trace IO PreFormatted -> Maybe (Trace IO PreFormatted)
forall a b. (a -> b) -> a -> b
$ Maybe Privacy -> Trace IO PreFormatted -> Trace IO PreFormatted
forall (m :: * -> *) a.
Monad m =>
Maybe Privacy -> Trace m a -> Trace m a
filterTraceByPrivacy (Privacy -> Maybe Privacy
forall a. a -> Maybe a
Just Privacy
Public)
                                (Trace IO FormattedMessage -> Trace IO PreFormatted
forall (m :: * -> *).
MonadIO m =>
Trace m FormattedMessage -> Trace m PreFormatted
forwardFormatter' Trace IO FormattedMessage
trForward)
                            else Maybe (Trace IO PreFormatted)
forall a. Maybe a
Nothing
        mbStdoutTrace :: Maybe (Trace IO PreFormatted)
mbStdoutTrace   | Bool
humColoured
                        = Trace IO PreFormatted -> Maybe (Trace IO PreFormatted)
forall a. a -> Maybe a
Just (Bool -> Trace IO FormattedMessage -> Trace IO PreFormatted
forall (m :: * -> *).
MonadIO m =>
Bool -> Trace m FormattedMessage -> Trace m PreFormatted
humanFormatter' Bool
True Trace IO FormattedMessage
trStdout)
                        | Bool
humUncoloured
                        = Trace IO PreFormatted -> Maybe (Trace IO PreFormatted)
forall a. a -> Maybe a
Just (Bool -> Trace IO FormattedMessage -> Trace IO PreFormatted
forall (m :: * -> *).
MonadIO m =>
Bool -> Trace m FormattedMessage -> Trace m PreFormatted
humanFormatter' Bool
False Trace IO FormattedMessage
trStdout)
                        | FormatLogging -> BackendConfig
Stdout FormatLogging
MachineFormat BackendConfig -> [BackendConfig] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [BackendConfig]
backends'
                        = Trace IO PreFormatted -> Maybe (Trace IO PreFormatted)
forall a. a -> Maybe a
Just (Trace IO FormattedMessage -> Trace IO PreFormatted
forall (m :: * -> *).
MonadIO m =>
Trace m FormattedMessage -> Trace m PreFormatted
machineFormatter' Trace IO FormattedMessage
trStdout)
                        | Bool
otherwise = Maybe (Trace IO PreFormatted)
forall a. Maybe a
Nothing
    case Maybe (Trace IO PreFormatted)
mbForwardTrace Maybe (Trace IO PreFormatted)
-> Maybe (Trace IO PreFormatted) -> Maybe (Trace IO PreFormatted)
forall a. Semigroup a => a -> a -> a
<> Maybe (Trace IO PreFormatted)
mbStdoutTrace of
      Maybe (Trace IO PreFormatted)
Nothing -> Trace IO a -> IO (Trace IO a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace IO a -> IO (Trace IO a)) -> Trace IO a -> IO (Trace IO a)
forall a b. (a -> b) -> a -> b
$ Tracer IO (LoggingContext, Either TraceControl a) -> Trace IO a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer IO (LoggingContext, Either TraceControl a)
forall (m :: * -> *) a. Monad m => Tracer m a
T.nullTracer
      Just Trace IO PreFormatted
tr -> Bool -> Trace IO PreFormatted -> IO (Trace IO a)
forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Bool -> Trace m PreFormatted -> m (Trace m a)
preFormatted (Bool
humColoured Bool -> Bool -> Bool
|| Bool
humUncoloured Bool -> Bool -> Bool
|| Bool
forwarder) Trace IO PreFormatted
tr
  where
    backends' :: [BackendConfig]
backends'     = [BackendConfig] -> Maybe [BackendConfig] -> [BackendConfig]
forall a. a -> Maybe a -> a
fromMaybe
                    [BackendConfig
Forwarder, FormatLogging -> BackendConfig
Stdout FormatLogging
MachineFormat]
                    Maybe [BackendConfig]
mbBackends

    humColoured :: Bool
humColoured   = FormatLogging -> BackendConfig
Stdout FormatLogging
HumanFormatColoured   BackendConfig -> [BackendConfig] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [BackendConfig]
backends'
    humUncoloured :: Bool
humUncoloured = FormatLogging -> BackendConfig
Stdout FormatLogging
HumanFormatUncoloured BackendConfig -> [BackendConfig] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [BackendConfig]
backends'
    forwarder :: Bool
forwarder     = BackendConfig
Forwarder BackendConfig -> [BackendConfig] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` [BackendConfig]
backends'

traceConfigWarnings ::
     Trace IO FormattedMessage
  -> Trace IO FormattedMessage
  -> [Text]
  -> IO ()
traceConfigWarnings :: Trace IO FormattedMessage
-> Trace IO FormattedMessage -> [Text] -> IO ()
traceConfigWarnings Trace IO FormattedMessage
trStdout Trace IO FormattedMessage
trForward [Text]
errs = do
    Trace IO TraceDispatcherMessage
internalTr <- Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO Any
-> IO (Trace IO TraceDispatcherMessage)
forall a x.
LogFormatting a =>
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO x
-> IO (Trace IO a)
backendsAndFormat
                      Trace IO FormattedMessage
trStdout
                      Trace IO FormattedMessage
trForward
                      Maybe [BackendConfig]
forall a. Maybe a
Nothing
                      (Tracer IO (LoggingContext, Either TraceControl Any) -> Trace IO Any
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer IO (LoggingContext, Either TraceControl Any)
forall (m :: * -> *) a. Monad m => Tracer m a
T.nullTracer)
    Trace IO TraceDispatcherMessage -> TraceDispatcherMessage -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith ((Trace IO TraceDispatcherMessage -> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withInnerNames (Trace IO TraceDispatcherMessage
 -> Trace IO TraceDispatcherMessage)
-> (Trace IO TraceDispatcherMessage
    -> Trace IO TraceDispatcherMessage)
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text]
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text
"Reflection"](Trace IO TraceDispatcherMessage
 -> Trace IO TraceDispatcherMessage)
-> (Trace IO TraceDispatcherMessage
    -> Trace IO TraceDispatcherMessage)
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace IO TraceDispatcherMessage -> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withSeverity)
                  Trace IO TraceDispatcherMessage
internalTr)
              ([Text] -> TraceDispatcherMessage
TracerConsistencyWarnings [Text]
errs)

traceEffectiveConfiguration ::
     Trace IO FormattedMessage
  -> Trace IO FormattedMessage
  -> TraceConfig
  -> IO ()
traceEffectiveConfiguration :: Trace IO FormattedMessage
-> Trace IO FormattedMessage -> TraceConfig -> IO ()
traceEffectiveConfiguration Trace IO FormattedMessage
trStdout Trace IO FormattedMessage
trForward TraceConfig
trConfig = do
    Trace IO TraceDispatcherMessage
internalTr <- Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO Any
-> IO (Trace IO TraceDispatcherMessage)
forall a x.
LogFormatting a =>
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO x
-> IO (Trace IO a)
backendsAndFormat
                      Trace IO FormattedMessage
trStdout
                      Trace IO FormattedMessage
trForward
                      Maybe [BackendConfig]
forall a. Maybe a
Nothing
                      (Tracer IO (LoggingContext, Either TraceControl Any) -> Trace IO Any
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer IO (LoggingContext, Either TraceControl Any)
forall (m :: * -> *) a. Monad m => Tracer m a
T.nullTracer)
    Trace IO TraceDispatcherMessage -> TraceDispatcherMessage -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith ((Trace IO TraceDispatcherMessage -> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withInnerNames (Trace IO TraceDispatcherMessage
 -> Trace IO TraceDispatcherMessage)
-> (Trace IO TraceDispatcherMessage
    -> Trace IO TraceDispatcherMessage)
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text]
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text
"Reflection"](Trace IO TraceDispatcherMessage
 -> Trace IO TraceDispatcherMessage)
-> (Trace IO TraceDispatcherMessage
    -> Trace IO TraceDispatcherMessage)
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace IO TraceDispatcherMessage -> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withSeverity)
                  Trace IO TraceDispatcherMessage
internalTr)
              (TraceConfig -> TraceDispatcherMessage
TracerInfoConfig TraceConfig
trConfig)

traceTracerInfo ::
     Trace IO FormattedMessage
  -> Trace IO FormattedMessage
  -> ConfigReflection
  -> IO ()
traceTracerInfo :: Trace IO FormattedMessage
-> Trace IO FormattedMessage -> ConfigReflection -> IO ()
traceTracerInfo Trace IO FormattedMessage
trStdout Trace IO FormattedMessage
trForward ConfigReflection
cr = do
    Trace IO TraceDispatcherMessage
internalTr <- Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO Any
-> IO (Trace IO TraceDispatcherMessage)
forall a x.
LogFormatting a =>
Trace IO FormattedMessage
-> Trace IO FormattedMessage
-> Maybe [BackendConfig]
-> Trace IO x
-> IO (Trace IO a)
backendsAndFormat
                      Trace IO FormattedMessage
trStdout
                      Trace IO FormattedMessage
trForward
                      Maybe [BackendConfig]
forall a. Maybe a
Nothing
                      (Tracer IO (LoggingContext, Either TraceControl Any) -> Trace IO Any
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer IO (LoggingContext, Either TraceControl Any)
forall (m :: * -> *) a. Monad m => Tracer m a
T.nullTracer)
    Set [Text]
silentSet <- IORef (Set [Text]) -> IO (Set [Text])
forall a. IORef a -> IO a
readIORef (ConfigReflection -> IORef (Set [Text])
crSilent ConfigReflection
cr)
    Set [Text]
metricSet <- IORef (Set [Text]) -> IO (Set [Text])
forall a. IORef a -> IO a
readIORef (ConfigReflection -> IORef (Set [Text])
crNoMetrics ConfigReflection
cr)
    Set [Text]
allTracerSet <- IORef (Set [Text]) -> IO (Set [Text])
forall a. IORef a -> IO a
readIORef (ConfigReflection -> IORef (Set [Text])
crAllTracers ConfigReflection
cr)
    let silentList :: [Text]
silentList  = ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Text] -> Text
intercalate (Char -> Text
singleton Char
'.')) (Set [Text] -> [[Text]]
forall a. Set a -> [a]
Set.toList Set [Text]
silentSet)
    let metricsList :: [Text]
metricsList = ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Text] -> Text
intercalate (Char -> Text
singleton Char
'.')) (Set [Text] -> [[Text]]
forall a. Set a -> [a]
Set.toList Set [Text]
metricSet)
    let allTracersList :: [Text]
allTracersList = ([Text] -> Text) -> [[Text]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [Text] -> Text
intercalate (Char -> Text
singleton Char
'.')) (Set [Text] -> [[Text]]
forall a. Set a -> [a]
Set.toList Set [Text]
allTracerSet)
    Trace IO TraceDispatcherMessage -> TraceDispatcherMessage -> IO ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith ((Trace IO TraceDispatcherMessage -> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withInnerNames (Trace IO TraceDispatcherMessage
 -> Trace IO TraceDispatcherMessage)
-> (Trace IO TraceDispatcherMessage
    -> Trace IO TraceDispatcherMessage)
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text]
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text
"Reflection"](Trace IO TraceDispatcherMessage
 -> Trace IO TraceDispatcherMessage)
-> (Trace IO TraceDispatcherMessage
    -> Trace IO TraceDispatcherMessage)
-> Trace IO TraceDispatcherMessage
-> Trace IO TraceDispatcherMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace IO TraceDispatcherMessage -> Trace IO TraceDispatcherMessage
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withSeverity)
                  Trace IO TraceDispatcherMessage
internalTr)
              ([Text] -> [Text] -> [Text] -> TraceDispatcherMessage
TracerInfo [Text]
silentList [Text]
metricsList [Text]
allTracersList)
    IORef (Set [Text]) -> Set [Text] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ConfigReflection -> IORef (Set [Text])
crSilent ConfigReflection
cr) Set [Text]
forall a. Set a
Set.empty
    IORef (Set [Text]) -> Set [Text] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ConfigReflection -> IORef (Set [Text])
crNoMetrics ConfigReflection
cr) Set [Text]
forall a. Set a
Set.empty
    IORef (Set [Text]) -> Set [Text] -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef (ConfigReflection -> IORef (Set [Text])
crAllTracers ConfigReflection
cr) Set [Text]
forall a. Set a
Set.empty

-- A basic tracer just for metrics
mkMetricsTracer :: Maybe (Trace IO FormattedMessage) -> Trace IO FormattedMessage
mkMetricsTracer :: Maybe (Trace IO FormattedMessage) -> Trace IO FormattedMessage
mkMetricsTracer Maybe (Trace IO FormattedMessage)
mbTrEkg = case Maybe (Trace IO FormattedMessage)
mbTrEkg of
                          Maybe (Trace IO FormattedMessage)
Nothing -> Tracer IO (LoggingContext, Either TraceControl FormattedMessage)
-> Trace IO FormattedMessage
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace Tracer IO (LoggingContext, Either TraceControl FormattedMessage)
forall (m :: * -> *) a. Monad m => Tracer m a
T.nullTracer
                          Just Trace IO FormattedMessage
ekgTrace -> Trace IO FormattedMessage
ekgTrace

_recordMetricsStatistics :: forall a m . (LogFormatting a, MonadIO m)
  => Trace m TraceDispatcherMessage
  -> Trace m a
  -> m (Trace m a)
_recordMetricsStatistics :: forall a (m :: * -> *).
(LogFormatting a, MonadIO m) =>
Trace m TraceDispatcherMessage -> Trace m a -> m (Trace m a)
_recordMetricsStatistics Trace m TraceDispatcherMessage
internalTr (Trace Tracer m (LoggingContext, Either TraceControl a)
tr) = do
    MVar (Int, Map Text Int)
ref <- IO (MVar (Int, Map Text Int)) -> m (MVar (Int, Map Text Int))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar (Int, Map Text Int)) -> m (MVar (Int, Map Text Int)))
-> IO (MVar (Int, Map Text Int)) -> m (MVar (Int, Map Text Int))
forall a b. (a -> b) -> a -> b
$ (Int, Map Text Int) -> IO (MVar (Int, Map Text Int))
forall a. a -> IO (MVar a)
newMVar (Int
0, Map Text Int
forall k a. Map k a
Map.empty)
    Trace m a -> m (Trace m a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Trace m a -> m (Trace m a)) -> Trace m a -> m (Trace m a)
forall a b. (a -> b) -> a -> b
$ Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
forall (m :: * -> *) a.
Tracer m (LoggingContext, Either TraceControl a) -> Trace m a
Trace (TracerA m (LoggingContext, Either TraceControl a) ()
-> Tracer m (LoggingContext, Either TraceControl a)
forall (m :: * -> *) a. TracerA m a () -> Tracer m a
T.arrow (((LoggingContext, Either TraceControl a) -> m ())
-> TracerA m (LoggingContext, Either TraceControl a) ()
forall (m :: * -> *) a.
Applicative m =>
(a -> m ()) -> TracerA m a ()
T.emit
      (\case
        (LoggingContext
lc, Right a
e) -> MVar (Int, Map Text Int) -> LoggingContext -> a -> m ()
process MVar (Int, Map Text Int)
ref LoggingContext
lc a
e
        (LoggingContext
lc, Left TraceControl
e) -> Tracer m (LoggingContext, Either TraceControl a)
-> (LoggingContext, Either TraceControl a) -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer m (LoggingContext, Either TraceControl a)
tr (LoggingContext
lc, TraceControl -> Either TraceControl a
forall a b. a -> Either a b
Left TraceControl
e))))
  where
    process :: MVar (Int, Map.Map Text Int) -> LoggingContext -> a -> m ()
    process :: MVar (Int, Map Text Int) -> LoggingContext -> a -> m ()
process MVar (Int, Map Text Int)
ref LoggingContext
lc a
msg = do
      let metrics :: [Metric]
metrics = a -> [Metric]
forall a. LogFormatting a => a -> [Metric]
asMetrics a
msg
      (Metric -> m ()) -> [Metric] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Metric
m ->
              let mName :: Text
mName = Metric -> Text
getMetricName Metric
m
              in IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Int, Map Text Int)
-> ((Int, Map Text Int) -> IO ((Int, Map Text Int), ())) -> IO ()
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Int, Map Text Int)
ref (\ (Int
i', Map Text Int
mmap) ->
                  case Text -> Map Text Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
mName Map Text Int
mmap of
                    Maybe Int
Nothing -> ((Int, Map Text Int), ()) -> IO ((Int, Map Text Int), ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int
i' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Text -> Int -> Map Text Int -> Map Text Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
mName Int
1 Map Text Int
mmap), ())
                    Just Int
_  -> ((Int, Map Text Int), ()) -> IO ((Int, Map Text Int), ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int
i' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, (Int -> Int) -> Text -> Map Text Int -> Map Text Int
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Text
mName Map Text Int
mmap), ()))) [Metric]
metrics
      (Int
i,Map Text Int
mmap) <- IO (Int, Map Text Int) -> m (Int, Map Text Int)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Int, Map Text Int) -> m (Int, Map Text Int))
-> IO (Int, Map Text Int) -> m (Int, Map Text Int)
forall a b. (a -> b) -> a -> b
$ MVar (Int, Map Text Int) -> IO (Int, Map Text Int)
forall a. MVar a -> IO a
readMVar MVar (Int, Map Text Int)
ref
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1000) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        Trace m TraceDispatcherMessage -> TraceDispatcherMessage -> m ()
forall (m :: * -> *) a. Monad m => Trace m a -> a -> m ()
traceWith (Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a.
(Monad m, MetaTrace a) =>
Trace m a -> Trace m a
withInnerNames ([Text]
-> Trace m TraceDispatcherMessage -> Trace m TraceDispatcherMessage
forall (m :: * -> *) a. Monad m => [Text] -> Trace m a -> Trace m a
appendPrefixNames [Text
"Reflection"] Trace m TraceDispatcherMessage
internalTr))
                  (Map Text Int -> TraceDispatcherMessage
MetricsInfo Map Text Int
mmap)
        IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ MVar (Int, Map Text Int)
-> ((Int, Map Text Int) -> IO ((Int, Map Text Int), ())) -> IO ()
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Int, Map Text Int)
ref (\ (Int
_i, Map Text Int
mmap') -> ((Int, Map Text Int), ()) -> IO ((Int, Map Text Int), ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int
0,Map Text Int
mmap'), ()))
      Tracer m (LoggingContext, Either TraceControl a)
-> (LoggingContext, Either TraceControl a) -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
T.traceWith Tracer m (LoggingContext, Either TraceControl a)
tr (LoggingContext
lc, a -> Either TraceControl a
forall a b. b -> Either a b
Right a
msg)