{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Control.Monad.Logger.Aeson
  ( -- * Synopsis
    -- $synopsis

    -- * Types
    Message(..)
  , SeriesElem
  , LoggedMessage(..)

    -- * Logging functions
    -- ** Implicit call stack, no @LogSource@
  , logDebug
  , logInfo
  , logWarn
  , logError
  , logOther
    -- ** Explicit call stack, no @LogSource@
  , logDebugCS
  , logInfoCS
  , logWarnCS
  , logErrorCS
  , logOtherCS
    -- ** Implicit call stack, with @LogSource@
  , logDebugNS
  , logInfoNS
  , logWarnNS
  , logErrorNS
  , logOtherNS

    -- ** Thread context
  , withThreadContext
  , myThreadContext

    -- * @LoggingT@ runners
  , runFileLoggingT
  , runHandleLoggingT
  , runStdoutLoggingT
  , runStderrLoggingT
  , runFastLoggingT

    -- * Utilities for defining our own loggers
  , defaultOutput
  , handleOutput
  , fastLoggerOutput
  , defaultOutputWith
  , defaultOutputOptions
  , OutputOptions
  , outputIncludeThreadId
  , outputBaseThreadContext
  , defaultLogStr
  , defaultHandleFromLevel

    -- * Re-exports from @aeson@
  , (.=)

    -- * Re-exports from @monad-logger@
  , module Log
  ) where

-- N.B. This import is not grouped with the others as this makes it easier to
-- cross-reference with this module's exports.
import Control.Monad.Logger as Log hiding
  ( logDebug
  , logInfo
  , logWarn
  , logError
  , logOther
  , logDebugCS
  , logInfoCS
  , logWarnCS
  , logErrorCS
  , logOtherCS
  , logWithoutLoc -- No re-export, as the 'log*NS' here use call stack for loc
  , logDebugNS
  , logInfoNS
  , logWarnNS
  , logErrorNS
  , logOtherNS
  , runFileLoggingT
  , runStderrLoggingT
  , runStdoutLoggingT
#if MIN_VERSION_monad_logger(0,3,36)
  , defaultOutput
#endif
  , defaultLogStr
  )

import Control.Monad.Catch (MonadMask, MonadThrow)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Logger.Aeson.Internal
  ( LoggedMessage(..), Message(..), OutputOptions(..), KeyMap, SeriesElem
  )
import Data.Aeson (KeyValue((.=)), Value(String))
import Data.Aeson.Types (Pair)
import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.Stack (CallStack, HasCallStack, callStack)
import System.IO
  ( BufferMode(LineBuffering), IOMode(AppendMode), Handle, hClose, hSetBuffering, openFile, stderr
  , stdout
  )
import System.Log.FastLogger (LoggerSet)
import qualified Context
import qualified Control.Concurrent as Concurrent
import qualified Control.Monad.Catch as Catch
import qualified Control.Monad.Logger.Aeson.Internal as Internal
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Text as Text
import qualified Data.Time as Time
import qualified System.Log.FastLogger as FastLogger

-- | Logs a 'Message' with the location provided by an implicit 'CallStack'.
--
-- @since 0.1.0.0
logDebug :: (HasCallStack, MonadLogger m) => Message -> m ()
logDebug :: Message -> m ()
logDebug = CallStack -> Message -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Message -> m ()
logDebugCS CallStack
HasCallStack => CallStack
callStack

-- | See 'logDebug'
--
-- @since 0.1.0.0
logInfo :: (HasCallStack, MonadLogger m) => Message -> m ()
logInfo :: Message -> m ()
logInfo = CallStack -> Message -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Message -> m ()
logInfoCS CallStack
HasCallStack => CallStack
callStack

-- | See 'logDebug'
--
-- @since 0.1.0.0
logWarn :: (HasCallStack, MonadLogger m) => Message -> m ()
logWarn :: Message -> m ()
logWarn = CallStack -> Message -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Message -> m ()
logWarnCS CallStack
HasCallStack => CallStack
callStack

-- | See 'logDebug'
--
-- @since 0.1.0.0
logError :: (HasCallStack, MonadLogger m) => Message -> m ()
logError :: Message -> m ()
logError = CallStack -> Message -> m ()
forall (m :: * -> *). MonadLogger m => CallStack -> Message -> m ()
logErrorCS CallStack
HasCallStack => CallStack
callStack

-- | See 'logDebug'
--
-- @since 0.1.0.0
logOther :: (HasCallStack, MonadLogger m) => LogLevel -> Message -> m ()
logOther :: LogLevel -> Message -> m ()
logOther = CallStack -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogLevel -> Message -> m ()
logOtherCS CallStack
HasCallStack => CallStack
callStack

-- | Logs a 'Message' with location given by 'CallStack'.
--
-- @since 0.1.0.0
logDebugCS :: (MonadLogger m) => CallStack -> Message -> m ()
logDebugCS :: CallStack -> Message -> m ()
logDebugCS CallStack
cs Message
msg = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
cs LogSource
"" LogLevel
LevelDebug Message
msg

-- | See 'logDebugCS'
--
-- @since 0.1.0.0
logInfoCS :: (MonadLogger m) => CallStack -> Message -> m ()
logInfoCS :: CallStack -> Message -> m ()
logInfoCS CallStack
cs Message
msg = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
cs LogSource
"" LogLevel
LevelInfo Message
msg

-- | See 'logDebugCS'
--
-- @since 0.1.0.0
logWarnCS :: (MonadLogger m) => CallStack -> Message -> m ()
logWarnCS :: CallStack -> Message -> m ()
logWarnCS CallStack
cs Message
msg = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
cs LogSource
"" LogLevel
LevelWarn Message
msg

-- | See 'logDebugCS'
--
-- @since 0.1.0.0
logOtherCS :: (MonadLogger m) => CallStack -> LogLevel -> Message -> m ()
logOtherCS :: CallStack -> LogLevel -> Message -> m ()
logOtherCS CallStack
cs LogLevel
lvl Message
msg = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
cs LogSource
"" LogLevel
lvl Message
msg

-- | See 'logDebugCS'
--
-- @since 0.1.0.0
logErrorCS :: (MonadLogger m) => CallStack -> Message -> m ()
logErrorCS :: CallStack -> Message -> m ()
logErrorCS CallStack
cs Message
msg = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
cs LogSource
"" LogLevel
LevelError Message
msg

-- | See 'logDebugCS'
--
-- @since 0.1.0.0
logDebugNS :: (HasCallStack, MonadLogger m) => LogSource -> Message -> m ()
logDebugNS :: LogSource -> Message -> m ()
logDebugNS LogSource
src = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
HasCallStack => CallStack
callStack LogSource
src LogLevel
LevelDebug

-- | See 'logDebugNS'
--
-- @since 0.1.0.0
logInfoNS :: (HasCallStack, MonadLogger m) => LogSource -> Message -> m ()
logInfoNS :: LogSource -> Message -> m ()
logInfoNS LogSource
src = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
HasCallStack => CallStack
callStack LogSource
src LogLevel
LevelInfo

-- | See 'logDebugNS'
--
-- @since 0.1.0.0
logWarnNS :: (HasCallStack, MonadLogger m) => LogSource -> Message -> m ()
logWarnNS :: LogSource -> Message -> m ()
logWarnNS LogSource
src = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
HasCallStack => CallStack
callStack LogSource
src LogLevel
LevelWarn

-- | See 'logDebugNS'
--
-- @since 0.1.0.0
logErrorNS :: (HasCallStack, MonadLogger m) => LogSource -> Message -> m ()
logErrorNS :: LogSource -> Message -> m ()
logErrorNS LogSource
src = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
HasCallStack => CallStack
callStack LogSource
src LogLevel
LevelError

-- | See 'logDebugNS'
--
-- @since 0.1.0.0
logOtherNS :: (HasCallStack, MonadLogger m) => LogSource -> LogLevel -> Message -> m ()
logOtherNS :: LogSource -> LogLevel -> Message -> m ()
logOtherNS = CallStack -> LogSource -> LogLevel -> Message -> m ()
forall (m :: * -> *).
MonadLogger m =>
CallStack -> LogSource -> LogLevel -> Message -> m ()
Internal.logCS CallStack
HasCallStack => CallStack
callStack

-- | This function lets us register structured, contextual info for the duration
-- of the provided action. All messages logged within the provided action will
-- automatically include this contextual info. This function is thread-safe, as
-- the contextual info is scoped to the calling thread only.
--
-- This function is additive: if we nest calls to it, each nested call will add
-- to the existing thread context. In the case of overlapping keys, the nested
-- call's 'Pair' value(s) will win. Whenever the inner action completes, the
-- thread context is rolled back to its value set in the enclosing action.
--
-- If we wish to include the existing thread context from one thread in another
-- thread, we must register the thread context explicitly on that other thread.
-- 'myThreadContext' can be leveraged in this case.
--
-- Registering thread context for messages can be useful in many scenarios. One
-- particularly apt scenario is in @wai@ middlewares. We can generate an ID for
-- each incoming request then include it in the thread context. Now all messages
-- subsequently logged from our endpoint handler will automatically include that
-- request ID:
--
-- > import Control.Monad.Logger.Aeson ((.=), withThreadContext)
-- > import Network.Wai (Middleware)
-- > import qualified Data.UUID.V4 as UUID
-- >
-- > addRequestId :: Middleware
-- > addRequestId app = \request sendResponse -> do
-- >   uuid <- UUID.nextRandom
-- >   withThreadContext ["requestId" .= uuid] do
-- >     app request sendResponse
--
-- If we're coming from a Java background, it may be helpful for us to draw
-- parallels between this function and @log4j2@'s @ThreadContext@ (or perhaps
-- @log4j@'s @MDC@). They all enable the same thing: setting some thread-local
-- info that will be automatically pulled into each logged message.
--
-- @since 0.1.0.0
withThreadContext :: (MonadIO m, MonadMask m) => [Pair] -> m a -> m a
withThreadContext :: [Pair] -> m a -> m a
withThreadContext [Pair]
pairs =
  Store (KeyMap Value)
-> (KeyMap Value -> KeyMap Value) -> m a -> m a
forall (m :: * -> *) ctx a.
(MonadIO m, MonadMask m) =>
Store ctx -> (ctx -> ctx) -> m a -> m a
Context.adjust Store (KeyMap Value)
Internal.threadContextStore ((KeyMap Value -> KeyMap Value) -> m a -> m a)
-> (KeyMap Value -> KeyMap Value) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
pairsMap ->
    KeyMap Value -> KeyMap Value -> KeyMap Value
forall v. KeyMap v -> KeyMap v -> KeyMap v
Internal.keyMapUnion ([Pair] -> KeyMap Value
forall v. [(Key, v)] -> KeyMap v
Internal.keyMapFromList [Pair]
pairs) KeyMap Value
pairsMap

-- | This function lets us retrieve the calling thread's thread context. For
-- more detail, we can consult the docs for 'withThreadContext'.
--
-- Note that even though the type signature lists 'MonadThrow' as a required
-- constraint, the library guarantees that 'myThreadContext' will never throw.
--
-- @since 0.1.0.0
myThreadContext :: (MonadIO m, MonadThrow m) => m (KeyMap Value)
myThreadContext :: m (KeyMap Value)
myThreadContext = do
  Store (KeyMap Value) -> m (KeyMap Value)
forall (m :: * -> *) ctx.
(MonadIO m, MonadThrow m) =>
Store ctx -> m ctx
Context.mine Store (KeyMap Value)
Internal.threadContextStore

-- | Run a block using a 'MonadLogger' instance which appends to the specified
-- file.
--
-- Note that this differs from the @monad-logger@ version in its constraints.
-- We use the @exceptions@ package's 'MonadMask' here for bracketing, rather
-- than @monad-control@.
--
-- @since 0.1.0.0
runFileLoggingT :: (MonadIO m, MonadMask m) => FilePath -> LoggingT m a -> m a
runFileLoggingT :: FilePath -> LoggingT m a -> m a
runFileLoggingT FilePath
filePath LoggingT m a
action =
  m Handle -> (Handle -> m ()) -> (Handle -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
Catch.bracket (IO Handle -> m Handle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Handle -> m Handle) -> IO Handle -> m Handle
forall a b. (a -> b) -> a -> b
$ FilePath -> IOMode -> IO Handle
openFile FilePath
filePath IOMode
AppendMode) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Handle -> IO ()) -> Handle -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ()
hClose) ((Handle -> m a) -> m a) -> (Handle -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \Handle
h -> do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
h BufferMode
LineBuffering
    LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT LoggingT m a
action ((Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall a b. (a -> b) -> a -> b
$ Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
defaultOutput Handle
h

-- | Run a block using a 'MonadLogger' instance which prints to 'stderr'.
--
-- @since 0.1.0.0
runStderrLoggingT :: LoggingT m a -> m a
runStderrLoggingT :: LoggingT m a -> m a
runStderrLoggingT = (LoggingT m a
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT m a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
defaultOutput Handle
stderr)

-- | Run a block using a 'MonadLogger' instance which prints to 'stdout'.
--
-- @since 0.1.0.0
runStdoutLoggingT :: LoggingT m a -> m a
runStdoutLoggingT :: LoggingT m a -> m a
runStdoutLoggingT = (LoggingT m a
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT m a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
defaultOutput Handle
stdout)

-- | Run a block using a 'MonadLogger' instance which prints to a 'Handle'
-- determined by the log message's 'LogLevel'.
--
-- A common use case for this function is to log warn\/error messages to 'stderr'
-- and debug\/info messages to 'stdout' in CLIs/tools (see
-- 'defaultHandleFromLevel').
--
-- @since 0.1.0.0
runHandleLoggingT :: (LogLevel -> Handle) -> LoggingT m a -> m a
runHandleLoggingT :: (LogLevel -> Handle) -> LoggingT m a -> m a
runHandleLoggingT = (LoggingT m a
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT m a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT ((Loc -> LogSource -> LogLevel -> LogStr -> IO ())
 -> LoggingT m a -> m a)
-> ((LogLevel -> Handle)
    -> Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> (LogLevel -> Handle)
-> LoggingT m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LogLevel -> Handle)
-> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
handleOutput

-- | Run a block using a 'MonadLogger' instance which appends to the specified
-- 'LoggerSet'.
--
-- @since 0.1.0.0
runFastLoggingT :: LoggerSet -> LoggingT m a -> m a
runFastLoggingT :: LoggerSet -> LoggingT m a -> m a
runFastLoggingT LoggerSet
loggerSet = (LoggingT m a
 -> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a)
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> LoggingT m a
-> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (LoggerSet -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
fastLoggerOutput LoggerSet
loggerSet)

-- | A default implementation of the action that backs the 'monadLoggerLog'
-- function. It accepts a file handle as the first argument and will log
-- incoming 'LogStr' values wrapped in the JSON structure prescribed by this
-- library.
--
-- This is used in the definition of 'runStdoutLoggingT' and
-- 'runStderrLoggingT':
--
-- @
-- 'runStdoutLoggingT' :: 'LoggingT' m a -> m a
-- 'runStdoutLoggingT' = 'flip' 'runLoggingT' ('defaultOutput' 'stdout')
-- @
--
-- We can instead use 'defaultOutputWith' if we need more control of the output.
--
-- @since 0.1.0.0
defaultOutput
  :: Handle
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
defaultOutput :: Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
defaultOutput Handle
handle = (LogLevel -> Handle)
-> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
handleOutput (Handle -> LogLevel -> Handle
forall a b. a -> b -> a
const Handle
handle)

-- | Given an output action for log messages, this function will produce the
-- default recommended 'OutputOptions'.
--
-- Specific options can be overriden via record update syntax using
-- 'outputIncludeThreadId', 'outputBaseThreadContext', and friends.
--
-- @since 0.1.0.0
defaultOutputOptions :: (LogLevel -> BS8.ByteString -> IO ()) -> OutputOptions
defaultOutputOptions :: (LogLevel -> ByteString -> IO ()) -> OutputOptions
defaultOutputOptions LogLevel -> ByteString -> IO ()
outputAction =
  OutputOptions :: (LogLevel -> ByteString -> IO ())
-> Bool -> [Pair] -> OutputOptions
OutputOptions
    { LogLevel -> ByteString -> IO ()
outputAction :: LogLevel -> ByteString -> IO ()
outputAction :: LogLevel -> ByteString -> IO ()
outputAction
    , outputIncludeThreadId :: Bool
outputIncludeThreadId = Bool
False
    , outputBaseThreadContext :: [Pair]
outputBaseThreadContext = []
    }

-- | This function is a lower-level helper for implementing the action that
-- backs the 'monadLoggerLog' function.
--
-- We should generally prefer 'defaultOutput' over this function, but this
-- function is available if we do need more control over our output.
--
-- @since 0.1.0.0
defaultOutputWith
  :: OutputOptions
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
defaultOutputWith :: OutputOptions -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
defaultOutputWith OutputOptions
outputOptions Loc
location LogSource
logSource LogLevel
logLevel LogStr
msg = do
  UTCTime
now <- IO UTCTime
Time.getCurrentTime
  LogSource
threadIdText <- (ThreadId -> LogSource) -> IO ThreadId -> IO LogSource
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> LogSource
Text.pack (FilePath -> LogSource)
-> (ThreadId -> FilePath) -> ThreadId -> LogSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> FilePath
forall a. Show a => a -> FilePath
show) IO ThreadId
Concurrent.myThreadId
  KeyMap Value
threadContext <- Store (KeyMap Value)
-> (KeyMap Value -> KeyMap Value) -> IO (KeyMap Value)
forall (m :: * -> *) ctx a.
(MonadIO m, MonadThrow m) =>
Store ctx -> (ctx -> a) -> m a
Context.mines Store (KeyMap Value)
Internal.threadContextStore ((KeyMap Value -> KeyMap Value) -> IO (KeyMap Value))
-> (KeyMap Value -> KeyMap Value) -> IO (KeyMap Value)
forall a b. (a -> b) -> a -> b
$ \KeyMap Value
hashMap ->
    ( if Bool
outputIncludeThreadId then
        Key -> Value -> KeyMap Value -> KeyMap Value
forall v. Key -> v -> KeyMap v -> KeyMap v
Internal.keyMapInsert Key
"tid" (Value -> KeyMap Value -> KeyMap Value)
-> Value -> KeyMap Value -> KeyMap Value
forall a b. (a -> b) -> a -> b
$ LogSource -> Value
String LogSource
threadIdText
      else
        KeyMap Value -> KeyMap Value
forall a. a -> a
id
    ) (KeyMap Value -> KeyMap Value) -> KeyMap Value -> KeyMap Value
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> KeyMap Value -> KeyMap Value
forall v. KeyMap v -> KeyMap v -> KeyMap v
Internal.keyMapUnion KeyMap Value
hashMap (KeyMap Value -> KeyMap Value) -> KeyMap Value -> KeyMap Value
forall a b. (a -> b) -> a -> b
$ KeyMap Value
baseThreadContextHashMap
  LogLevel -> ByteString -> IO ()
outputAction LogLevel
logLevel
    (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime
-> KeyMap Value
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> ByteString
Internal.defaultLogStrBS UTCTime
now KeyMap Value
threadContext Loc
location LogSource
logSource LogLevel
logLevel LogStr
msg
  where
  baseThreadContextHashMap :: KeyMap Value
baseThreadContextHashMap = [Pair] -> KeyMap Value
forall v. [(Key, v)] -> KeyMap v
Internal.keyMapFromList [Pair]
outputBaseThreadContext
  OutputOptions
    { LogLevel -> ByteString -> IO ()
outputAction :: LogLevel -> ByteString -> IO ()
outputAction :: OutputOptions -> LogLevel -> ByteString -> IO ()
outputAction
    , Bool
outputIncludeThreadId :: Bool
outputIncludeThreadId :: OutputOptions -> Bool
outputIncludeThreadId
    , [Pair]
outputBaseThreadContext :: [Pair]
outputBaseThreadContext :: OutputOptions -> [Pair]
outputBaseThreadContext
    } = OutputOptions
outputOptions

-- | An implementation of the action that backs the 'monadLoggerLog' function,
-- where the 'Handle' destination for each log message is determined by the log
-- message's 'LogLevel'. This function will log incoming 'LogStr' values wrapped
-- in the JSON structure prescribed by this library.
--
-- This is used in the definition of 'runHandleLoggingT':
--
-- @
-- 'runHandleLoggingT' :: ('LogLevel' -> 'Handle') -> 'LoggingT' m a -> m a
-- 'runHandleLoggingT' = 'flip' 'runLoggingT' . 'handleOutput'
-- @
--
-- @since 0.1.0.0
handleOutput
  :: (LogLevel -> Handle)
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
handleOutput :: (LogLevel -> Handle)
-> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
handleOutput LogLevel -> Handle
levelToHandle =
  OutputOptions -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
defaultOutputWith (OutputOptions -> Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> OutputOptions -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ (LogLevel -> ByteString -> IO ()) -> OutputOptions
defaultOutputOptions ((LogLevel -> ByteString -> IO ()) -> OutputOptions)
-> (LogLevel -> ByteString -> IO ()) -> OutputOptions
forall a b. (a -> b) -> a -> b
$ \LogLevel
logLevel ByteString
bytes -> do
    Handle -> ByteString -> IO ()
BS8.hPutStrLn (LogLevel -> Handle
levelToHandle LogLevel
logLevel) ByteString
bytes

-- | An implementation of the action that backs the 'monadLoggerLog' function,
-- where log messages are written to a provided 'LoggerSet'. This function will
-- log incoming 'LogStr' values wrapped in the JSON structure prescribed by this
-- library.
--
-- This is used in the definition of 'runFastLoggingT':
--
-- @
-- 'runFastLoggingT' :: 'LoggerSet' -> 'LoggingT' m a -> m a
-- 'runFastLoggingT' loggerSet = 'flip' 'runLoggingT' ('fastLoggerOutput' loggerSet)
-- @
--
-- @since 0.1.0.0
fastLoggerOutput
  :: LoggerSet
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> IO ()
fastLoggerOutput :: LoggerSet -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
fastLoggerOutput LoggerSet
loggerSet =
  OutputOptions -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
defaultOutputWith (OutputOptions -> Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> OutputOptions -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ (LogLevel -> ByteString -> IO ()) -> OutputOptions
defaultOutputOptions ((LogLevel -> ByteString -> IO ()) -> OutputOptions)
-> (LogLevel -> ByteString -> IO ()) -> OutputOptions
forall a b. (a -> b) -> a -> b
$ \LogLevel
_logLevel ByteString
bytes -> do
    LoggerSet -> LogStr -> IO ()
FastLogger.pushLogStrLn LoggerSet
loggerSet (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ByteString
bytes

-- | @since 0.1.0.0
defaultLogStr
  :: UTCTime
  -> KeyMap Value
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> LogStr
defaultLogStr :: UTCTime
-> KeyMap Value -> Loc -> LogSource -> LogLevel -> LogStr -> LogStr
defaultLogStr UTCTime
now KeyMap Value
threadContext Loc
loc LogSource
logSource LogLevel
logLevel LogStr
logStr =
  ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr
    (ByteString -> LogStr) -> ByteString -> LogStr
forall a b. (a -> b) -> a -> b
$ UTCTime
-> KeyMap Value
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> ByteString
Internal.defaultLogStrBS UTCTime
now KeyMap Value
threadContext Loc
loc LogSource
logSource LogLevel
logLevel LogStr
logStr

-- | This function maps the possible 'LogLevel' values to 'Handle' values.
-- Specifically, 'LevelDebug' and 'LevelInfo' map to 'stdout', while 'LevelWarn'
-- and 'LevelError' map to 'stderr'. The function is most useful for CLIs/tools
-- (see 'runHandleLoggingT').
--
-- The input function discriminating 'Text' is used to determine the 'Handle'
-- mapping for 'LevelOther'. For example, if we wish for all 'LevelOther'
-- messages to be logged to 'stderr', we can supply @(const stderr)@ as the
-- value for this input function.
--
-- @since 0.1.0.0
defaultHandleFromLevel :: (Text -> Handle) -> LogLevel -> Handle
defaultHandleFromLevel :: (LogSource -> Handle) -> LogLevel -> Handle
defaultHandleFromLevel LogSource -> Handle
otherLevelToHandle = \case
  LogLevel
LevelDebug -> Handle
stdout
  LogLevel
LevelInfo -> Handle
stdout
  LogLevel
LevelWarn -> Handle
stderr
  LogLevel
LevelError -> Handle
stderr
  LevelOther LogSource
otherLevel -> LogSource -> Handle
otherLevelToHandle LogSource
otherLevel

-- $synopsis
--
-- @monad-logger-aeson@ provides structured JSON logging using @monad-logger@'s
-- interface. Specifically, it is intended to be a (largely) drop-in replacement
-- for @monad-logger@'s "Control.Monad.Logger.CallStack" module.
--
-- In brief, this program:
--
-- > {-# LANGUAGE BlockArguments #-}
-- > {-# LANGUAGE OverloadedStrings #-}
-- > module Main
-- >   ( main
-- >   ) where
-- >
-- > import Control.Monad.Logger.Aeson
-- >
-- > doStuff :: (MonadLogger m) => Int -> m ()
-- > doStuff x = do
-- >   logDebug $ "Doing stuff" :# ["x" .= x]
-- >
-- > main :: IO ()
-- > main = do
-- >   runStdoutLoggingT do
-- >     doStuff 42
-- >     logInfo "Done"
--
-- Would produce this output (formatted for readability here with @jq@):
--
-- > {
-- >   "time": "2022-05-15T20:52:15.5559417Z",
-- >   "level": "debug",
-- >   "location": {
-- >     "package": "main",
-- >     "module": "Main",
-- >     "file": "app/readme-example.hs",
-- >     "line": 11,
-- >     "char": 3
-- >   },
-- >   "message": {
-- >     "text": "Doing stuff",
-- >     "meta": {
-- >       "x": 42
-- >     }
-- >   }
-- > }
-- > {
-- >   "time": "2022-05-15T20:52:15.5560448Z",
-- >   "level": "info",
-- >   "location": {
-- >     "package": "main",
-- >     "module": "Main",
-- >     "file": "app/readme-example.hs",
-- >     "line": 17,
-- >     "char": 5
-- >   },
-- >   "message": {
-- >     "text": "Done"
-- >   }
-- > }
--
-- For additional detail on the library, please see the remainder of these
-- Haddocks and the following external resources:
--
-- * [README](https://github.com/jship/monad-logger-aeson/blob/main/monad-logger-aeson/README.md)
-- * [Announcement blog post](https://jship.github.io/posts/2022-05-17-announcing-monad-logger-aeson/)