{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StrictData #-}
module Control.Monad.Logger.Aeson.Internal
  ( -- * Disclaimer
    -- $disclaimer

    -- ** @Message@-related
    Message(..)
  , SeriesElem(..)
  , LoggedMessage(..)
  , threadContextStore
  , logCS
  , OutputOptions(..)
  , defaultLogStrBS
  , defaultLogStrLBS
  , messageEncoding
  , messageSeries

    -- ** @LogItem@-related
  , LogItem(..)
  , logItemEncoding

    -- ** Encoding-related
  , pairsEncoding
  , pairsSeries
  , levelEncoding
  , locEncoding

    -- ** @monad-logger@ internals
  , mkLoggerLoc
  , locFromCS
  , isDefaultLoc

    -- ** Aeson compat
  , Key
  , KeyMap
  , emptyKeyMap
  , keyMapFromList
  , keyMapToList
  , keyMapInsert
  , keyMapUnion
  ) where

import Context (Store)
import Control.Applicative (Applicative(liftA2))
import Control.Monad.Logger (Loc(..), LogLevel(..), MonadLogger(..), ToLogStr(..), LogSource)
import Data.Aeson (KeyValue((.=)), Value(Object), (.:), (.:?), Encoding, FromJSON, ToJSON)
import Data.Aeson.Encoding.Internal (Series(..))
import Data.Aeson.Types (Pair, Parser)
import Data.String (IsString)
import Data.Text (Text)
import Data.Time (UTCTime)
import GHC.Generics (Generic)
import GHC.Stack (SrcLoc(..), CallStack, getCallStack)
import qualified Context
import qualified Control.Monad.Logger as Logger
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encoding as Aeson
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as LBS8
import qualified Data.Maybe as Maybe
import qualified Data.String as String
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text.Encoding
import qualified Data.Text.Encoding.Error as Text.Encoding.Error
import qualified System.IO.Unsafe as IO.Unsafe

#if MIN_VERSION_fast_logger(3,0,1)
import System.Log.FastLogger.Internal (LogStr(..))
#else
import System.Log.FastLogger (LogStr, fromLogStr)
#endif

#if MIN_VERSION_aeson(2, 0, 0)
import Data.Aeson.Key (Key)
import Data.Aeson.KeyMap (KeyMap)
import qualified Data.Aeson.KeyMap as AesonCompat
#else
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as AesonCompat
type Key = Text
type KeyMap v = HashMap Key v
#endif

emptyKeyMap :: KeyMap v
emptyKeyMap :: forall v. KeyMap v
emptyKeyMap = forall v. KeyMap v
AesonCompat.empty

keyMapFromList :: [(Key, v)] -> KeyMap v
keyMapFromList :: forall v. [(Key, v)] -> KeyMap v
keyMapFromList = forall v. [(Key, v)] -> KeyMap v
AesonCompat.fromList

keyMapToList :: KeyMap v -> [(Key, v)]
keyMapToList :: forall v. KeyMap v -> [(Key, v)]
keyMapToList = forall v. KeyMap v -> [(Key, v)]
AesonCompat.toList

keyMapInsert :: Key -> v -> KeyMap v -> KeyMap v
keyMapInsert :: forall v. Key -> v -> KeyMap v -> KeyMap v
keyMapInsert = forall v. Key -> v -> KeyMap v -> KeyMap v
AesonCompat.insert

keyMapUnion :: KeyMap v -> KeyMap v -> KeyMap v
keyMapUnion :: forall v. KeyMap v -> KeyMap v -> KeyMap v
keyMapUnion = forall v. KeyMap v -> KeyMap v -> KeyMap v
AesonCompat.union

-- | A single key-value pair, where the value is encoded JSON. This is a more
-- restricted version of 'Series': a 'SeriesElem' is intended to encapsulate
-- exactly one key-value pair, whereas a 'Series' encapsulates zero or more
-- key-value pairs. 'SeriesElem' values can be created via '(.=)' from @aeson@.
--
-- While a 'SeriesElem' most often will map to a single pair, note that a
-- 'Semigroup' instance is available for performance's sake. The 'Semigroup'
-- instance is useful when multiple pairs are grouped together and then shared
-- across multiple logging calls. In that case, the cost of combining the pairs
-- in the group must only be paid once.
--
-- @since 0.3.0.0
newtype SeriesElem = UnsafeSeriesElem
  { SeriesElem -> Series
unSeriesElem :: Series
  }

-- | @since 0.3.0.0
deriving newtype instance KeyValue SeriesElem
-- | @since 0.3.1.0
deriving newtype instance Semigroup SeriesElem

-- | This type is the Haskell representation of each JSON log message produced
-- by this library.
--
-- While we never interact with this type directly when logging messages with
-- @monad-logger-aeson@, we may wish to use this type if we are
-- parsing/processing log files generated by this library.
--
-- @since 0.1.0.0
data LoggedMessage = LoggedMessage
  { LoggedMessage -> UTCTime
loggedMessageTimestamp :: UTCTime
  , LoggedMessage -> LogLevel
loggedMessageLevel :: LogLevel
  , LoggedMessage -> Maybe Loc
loggedMessageLoc :: Maybe Loc
  , LoggedMessage -> Maybe Text
loggedMessageLogSource :: Maybe LogSource
  , LoggedMessage -> KeyMap Value
loggedMessageThreadContext :: KeyMap Value
  , LoggedMessage -> Text
loggedMessageText :: Text
  , LoggedMessage -> KeyMap Value
loggedMessageMeta :: KeyMap Value
  } deriving stock (LoggedMessage -> LoggedMessage -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LoggedMessage -> LoggedMessage -> Bool
$c/= :: LoggedMessage -> LoggedMessage -> Bool
== :: LoggedMessage -> LoggedMessage -> Bool
$c== :: LoggedMessage -> LoggedMessage -> Bool
Eq, forall x. Rep LoggedMessage x -> LoggedMessage
forall x. LoggedMessage -> Rep LoggedMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LoggedMessage x -> LoggedMessage
$cfrom :: forall x. LoggedMessage -> Rep LoggedMessage x
Generic, Eq LoggedMessage
LoggedMessage -> LoggedMessage -> Bool
LoggedMessage -> LoggedMessage -> Ordering
LoggedMessage -> LoggedMessage -> LoggedMessage
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LoggedMessage -> LoggedMessage -> LoggedMessage
$cmin :: LoggedMessage -> LoggedMessage -> LoggedMessage
max :: LoggedMessage -> LoggedMessage -> LoggedMessage
$cmax :: LoggedMessage -> LoggedMessage -> LoggedMessage
>= :: LoggedMessage -> LoggedMessage -> Bool
$c>= :: LoggedMessage -> LoggedMessage -> Bool
> :: LoggedMessage -> LoggedMessage -> Bool
$c> :: LoggedMessage -> LoggedMessage -> Bool
<= :: LoggedMessage -> LoggedMessage -> Bool
$c<= :: LoggedMessage -> LoggedMessage -> Bool
< :: LoggedMessage -> LoggedMessage -> Bool
$c< :: LoggedMessage -> LoggedMessage -> Bool
compare :: LoggedMessage -> LoggedMessage -> Ordering
$ccompare :: LoggedMessage -> LoggedMessage -> Ordering
Ord, Int -> LoggedMessage -> ShowS
[LoggedMessage] -> ShowS
LoggedMessage -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LoggedMessage] -> ShowS
$cshowList :: [LoggedMessage] -> ShowS
show :: LoggedMessage -> String
$cshow :: LoggedMessage -> String
showsPrec :: Int -> LoggedMessage -> ShowS
$cshowsPrec :: Int -> LoggedMessage -> ShowS
Show)

instance FromJSON LoggedMessage where
  parseJSON :: Value -> Parser LoggedMessage
parseJSON = forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
Aeson.withObject String
"LoggedMessage" forall a b. (a -> b) -> a -> b
$ \KeyMap Value
obj -> do
    UTCTime
loggedMessageTimestamp <- KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"time"
    LogLevel
loggedMessageLevel <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> LogLevel
logLevelFromText forall a b. (a -> b) -> a -> b
$ KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"level"
    Maybe Loc
loggedMessageLoc <- Maybe Value -> Parser (Maybe Loc)
parseLoc forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"location"
    Maybe Text
loggedMessageLogSource <- KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"source"
    KeyMap Value
loggedMessageThreadContext <- Maybe Value -> Parser (KeyMap Value)
parsePairs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"context"
    (Text
loggedMessageText, KeyMap Value
loggedMessageMeta) <- Value -> Parser (Text, KeyMap Value)
parseMessage forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"message"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure LoggedMessage
      { UTCTime
loggedMessageTimestamp :: UTCTime
loggedMessageTimestamp :: UTCTime
loggedMessageTimestamp
      , LogLevel
loggedMessageLevel :: LogLevel
loggedMessageLevel :: LogLevel
loggedMessageLevel
      , Maybe Loc
loggedMessageLoc :: Maybe Loc
loggedMessageLoc :: Maybe Loc
loggedMessageLoc
      , Maybe Text
loggedMessageLogSource :: Maybe Text
loggedMessageLogSource :: Maybe Text
loggedMessageLogSource
      , KeyMap Value
loggedMessageThreadContext :: KeyMap Value
loggedMessageThreadContext :: KeyMap Value
loggedMessageThreadContext
      , Text
loggedMessageText :: Text
loggedMessageText :: Text
loggedMessageText
      , KeyMap Value
loggedMessageMeta :: KeyMap Value
loggedMessageMeta :: KeyMap Value
loggedMessageMeta
      }
    where
    logLevelFromText :: Text -> LogLevel
    logLevelFromText :: Text -> LogLevel
logLevelFromText = \case
      Text
"debug" -> LogLevel
LevelDebug
      Text
"info" -> LogLevel
LevelInfo
      Text
"warn" -> LogLevel
LevelWarn
      Text
"error" -> LogLevel
LevelError
      Text
other -> Text -> LogLevel
LevelOther Text
other

    parseLoc :: Maybe Value -> Parser (Maybe Loc)
    parseLoc :: Maybe Value -> Parser (Maybe Loc)
parseLoc =
      forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Loc" forall a b. (a -> b) -> a -> b
$ \KeyMap Value
obj ->
        String -> String -> String -> CharPos -> CharPos -> Loc
Loc
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"file"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"package"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"module"
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"line") (KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"char"))
          forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
0, Int
0)

    parsePairs :: Maybe Value -> Parser (KeyMap Value)
    parsePairs :: Maybe Value -> Parser (KeyMap Value)
parsePairs = \case
      Maybe Value
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
      Just Value
value -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
Aeson.withObject String
"[Pair]") Value
value forall a b. (a -> b) -> a -> b
$ \KeyMap Value
obj -> do
        forall (f :: * -> *) a. Applicative f => a -> f a
pure KeyMap Value
obj

    parseMessage :: Value -> Parser (Text, KeyMap Value)
    parseMessage :: Value -> Parser (Text, KeyMap Value)
parseMessage = forall a. String -> (KeyMap Value -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Message" forall a b. (a -> b) -> a -> b
$ \KeyMap Value
obj ->
      (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser a
.: Key
"text" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe Value -> Parser (KeyMap Value)
parsePairs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KeyMap Value
obj forall a. FromJSON a => KeyMap Value -> Key -> Parser (Maybe a)
.:? Key
"meta")

instance ToJSON LoggedMessage where
  toJSON :: LoggedMessage -> Value
toJSON LoggedMessage
loggedMessage =
    [Pair] -> Value
Aeson.object forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
Maybe.catMaybes
      [ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"time" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UTCTime
loggedMessageTimestamp
      , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"level" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= LogLevel -> Text
logLevelToText LogLevel
loggedMessageLevel
      , case Maybe Loc
loggedMessageLoc of
          Maybe Loc
Nothing -> forall a. Maybe a
Nothing
          Just Loc
loc -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"location" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Loc -> Value
locToJSON Loc
loc
      , case Maybe Text
loggedMessageLogSource of
          Maybe Text
Nothing -> forall a. Maybe a
Nothing
          Just Text
logSource -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"source" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
logSource
      , if KeyMap Value
loggedMessageThreadContext forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty then
          forall a. Maybe a
Nothing
        else
          forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"context" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= KeyMap Value -> Value
Object KeyMap Value
loggedMessageThreadContext
      , forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
messageJSON
      ]
    where
    locToJSON :: Loc -> Value
    locToJSON :: Loc -> Value
locToJSON Loc
loc =
      [Pair] -> Value
Aeson.object
        [ Key
"package" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
loc_package
        , Key
"module" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
loc_module
        , Key
"file" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
loc_filename
        , Key
"line" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a, b) -> a
fst CharPos
loc_start
        , Key
"char" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall a b. (a, b) -> b
snd CharPos
loc_start
        ]
      where
      Loc { String
loc_filename :: Loc -> String
loc_filename :: String
loc_filename, String
loc_package :: Loc -> String
loc_package :: String
loc_package, String
loc_module :: Loc -> String
loc_module :: String
loc_module, CharPos
loc_start :: Loc -> CharPos
loc_start :: CharPos
loc_start } = Loc
loc

    messageJSON :: Value
    messageJSON :: Value
messageJSON =
      [Pair] -> Value
Aeson.object forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
Maybe.catMaybes
        [ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"text" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
loggedMessageText
        , if KeyMap Value
loggedMessageMeta forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty then
            forall a. Maybe a
Nothing
          else
            forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Key
"meta" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= KeyMap Value -> Value
Object KeyMap Value
loggedMessageMeta
        ]

    LoggedMessage
      { UTCTime
loggedMessageTimestamp :: UTCTime
loggedMessageTimestamp :: LoggedMessage -> UTCTime
loggedMessageTimestamp
      , LogLevel
loggedMessageLevel :: LogLevel
loggedMessageLevel :: LoggedMessage -> LogLevel
loggedMessageLevel
      , Maybe Loc
loggedMessageLoc :: Maybe Loc
loggedMessageLoc :: LoggedMessage -> Maybe Loc
loggedMessageLoc
      , Maybe Text
loggedMessageLogSource :: Maybe Text
loggedMessageLogSource :: LoggedMessage -> Maybe Text
loggedMessageLogSource
      , KeyMap Value
loggedMessageThreadContext :: KeyMap Value
loggedMessageThreadContext :: LoggedMessage -> KeyMap Value
loggedMessageThreadContext
      , Text
loggedMessageText :: Text
loggedMessageText :: LoggedMessage -> Text
loggedMessageText
      , KeyMap Value
loggedMessageMeta :: KeyMap Value
loggedMessageMeta :: LoggedMessage -> KeyMap Value
loggedMessageMeta
      } = LoggedMessage
loggedMessage

  toEncoding :: LoggedMessage -> Encoding
toEncoding LoggedMessage
loggedMessage = LogItem -> Encoding
logItemEncoding LogItem
logItem
    where
    logItem :: LogItem
logItem =
      LogItem
        { logItemTimestamp :: UTCTime
logItemTimestamp = UTCTime
loggedMessageTimestamp
        , logItemLoc :: Loc
logItemLoc = forall a. a -> Maybe a -> a
Maybe.fromMaybe Loc
Logger.defaultLoc Maybe Loc
loggedMessageLoc
        , logItemLogSource :: Text
logItemLogSource = forall a. a -> Maybe a -> a
Maybe.fromMaybe Text
"" Maybe Text
loggedMessageLogSource
        , logItemLevel :: LogLevel
logItemLevel = LogLevel
loggedMessageLevel
        , logItemThreadContext :: KeyMap Value
logItemThreadContext = KeyMap Value
loggedMessageThreadContext
        , logItemMessageEncoding :: Encoding
logItemMessageEncoding =
            Message -> Encoding
messageEncoding forall a b. (a -> b) -> a -> b
$
              Text
loggedMessageText Text -> [SeriesElem] -> Message
:# KeyMap Value -> [SeriesElem]
keyMapToSeriesList KeyMap Value
loggedMessageMeta
        }

    keyMapToSeriesList :: KeyMap Value -> [SeriesElem]
    keyMapToSeriesList :: KeyMap Value -> [SeriesElem]
keyMapToSeriesList =
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
(.=)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. KeyMap v -> [(Key, v)]
keyMapToList

    LoggedMessage
      { UTCTime
loggedMessageTimestamp :: UTCTime
loggedMessageTimestamp :: LoggedMessage -> UTCTime
loggedMessageTimestamp
      , LogLevel
loggedMessageLevel :: LogLevel
loggedMessageLevel :: LoggedMessage -> LogLevel
loggedMessageLevel
      , Maybe Loc
loggedMessageLoc :: Maybe Loc
loggedMessageLoc :: LoggedMessage -> Maybe Loc
loggedMessageLoc
      , Maybe Text
loggedMessageLogSource :: Maybe Text
loggedMessageLogSource :: LoggedMessage -> Maybe Text
loggedMessageLogSource
      , KeyMap Value
loggedMessageThreadContext :: KeyMap Value
loggedMessageThreadContext :: LoggedMessage -> KeyMap Value
loggedMessageThreadContext
      , Text
loggedMessageText :: Text
loggedMessageText :: LoggedMessage -> Text
loggedMessageText
      , KeyMap Value
loggedMessageMeta :: KeyMap Value
loggedMessageMeta :: LoggedMessage -> KeyMap Value
loggedMessageMeta
      } = LoggedMessage
loggedMessage

-- | A 'Message' captures a textual component and a metadata component. The
-- metadata component is a list of 'SeriesElem' to support tacking on arbitrary
-- structured data to a log message.
--
-- With the @OverloadedStrings@ extension enabled, 'Message' values can be
-- constructed without metadata fairly conveniently, just as if we were using
-- 'Text' directly:
--
-- > logDebug "Some log message without metadata"
--
-- Metadata may be included in a 'Message' via the ':#' constructor:
--
-- @
-- 'Control.Monad.Logger.Aeson.logDebug' $ "Some log message with metadata" ':#'
--   [ "bloorp" '.=' (42 :: 'Int')
--   , "bonk" '.=' ("abc" :: 'Text')
--   ]
-- @
--
-- The mnemonic for the ':#' constructor is that the @#@ symbol is sometimes
-- referred to as a hash, a JSON object can be thought of as a hash map, and
-- so with @:#@ (and enough squinting), we are @cons@-ing a textual message onto
-- a JSON object. Yes, this mnemonic isn't well-typed, but hopefully it still
-- helps!
--
-- @since 0.1.0.0
data Message = Text :# [SeriesElem]
infixr 5 :#

instance IsString Message where
  fromString :: String -> Message
fromString String
string = String -> Text
Text.pack String
string Text -> [SeriesElem] -> Message
:# []

instance ToLogStr Message where
  toLogStr :: Message -> LogStr
toLogStr = forall msg. ToLogStr msg => msg -> LogStr
toLogStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Encoding' a -> ByteString
Aeson.encodingToLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Encoding
messageEncoding

-- | Thread-safe, global 'Store' that captures the thread context of messages.
--
-- Note that there is a bit of somewhat unavoidable name-overloading here: this
-- binding is called 'threadContextStore' because it stores the thread context
-- (i.e. @ThreadContext@/@MDC@ from Java land) for messages. It also just so
-- happens that the 'Store' type comes from the @context@ package, which is a
-- package providing thread-indexed storage of arbitrary context values. Please
-- don't hate the player!
--
-- @since 0.1.0.0
threadContextStore :: Store (KeyMap Value)
threadContextStore :: Store (KeyMap Value)
threadContextStore =
  forall a. IO a -> a
IO.Unsafe.unsafePerformIO
    forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) ctx.
MonadIO m =>
PropagationStrategy -> Maybe ctx -> m (Store ctx)
Context.newStore PropagationStrategy
Context.noPropagation
    forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just
    forall a b. (a -> b) -> a -> b
$ forall v. KeyMap v
emptyKeyMap
{-# NOINLINE threadContextStore #-}

-- | 'OutputOptions' is for use with
-- 'Control.Monad.Logger.Aeson.defaultOutputWith' and enables us to configure
-- the JSON output produced by this library.
--
-- We can get a hold of a value of this type via
-- 'Control.Monad.Logger.Aeson.defaultOutputOptions'.
--
-- @since 0.1.0.0
data OutputOptions = OutputOptions
  { OutputOptions -> LogLevel -> ByteString -> IO ()
outputAction :: LogLevel -> BS8.ByteString -> IO ()
  , -- | Controls whether or not the thread ID is included in each log message's
    -- thread context.
    --
    -- Default: 'False'
    --
    -- @since 0.1.0.0
    OutputOptions -> Bool
outputIncludeThreadId :: Bool
  , -- | Allows for setting a "base" thread context, i.e. a set of 'Pair' that
    -- will always be present in log messages.
    --
    -- If we subsequently use 'Control.Monad.Logger.Aeson.withThreadContext' to
    -- register some thread context for our messages, if any of the keys in
    -- those 'Pair' values overlap with the "base" thread context, then the
    -- overlapped 'Pair' values in the "base" thread context will be overridden
    -- for the duration of the action provided to
    -- 'Control.Monad.Logger.Aeson.withThreadContext'.
    --
    -- Default: 'mempty'
    --
    -- @since 0.1.0.0
    OutputOptions -> [Pair]
outputBaseThreadContext :: [Pair]
  }

defaultLogStrBS
  :: UTCTime
  -> KeyMap Value
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> BS8.ByteString
defaultLogStrBS :: UTCTime
-> KeyMap Value -> Loc -> Text -> LogLevel -> LogStr -> ByteString
defaultLogStrBS UTCTime
now KeyMap Value
threadContext Loc
loc Text
logSource LogLevel
logLevel LogStr
logStr =
  ByteString -> ByteString
LBS.toStrict
    forall a b. (a -> b) -> a -> b
$ UTCTime
-> KeyMap Value -> Loc -> Text -> LogLevel -> LogStr -> ByteString
defaultLogStrLBS UTCTime
now KeyMap Value
threadContext Loc
loc Text
logSource LogLevel
logLevel LogStr
logStr

defaultLogStrLBS
  :: UTCTime
  -> KeyMap Value
  -> Loc
  -> LogSource
  -> LogLevel
  -> LogStr
  -> LBS8.ByteString
defaultLogStrLBS :: UTCTime
-> KeyMap Value -> Loc -> Text -> LogLevel -> LogStr -> ByteString
defaultLogStrLBS UTCTime
now KeyMap Value
threadContext Loc
loc Text
logSource LogLevel
logLevel LogStr
logStr =
  forall a. Encoding' a -> ByteString
Aeson.encodingToLazyByteString forall a b. (a -> b) -> a -> b
$ LogItem -> Encoding
logItemEncoding LogItem
logItem
  where
  logItem :: LogItem
  logItem :: LogItem
logItem =
    case Int64 -> ByteString -> ByteString
LBS8.take Int64
9 ByteString
logStrLBS of
      ByteString
"{\"text\":\"" ->
        Encoding -> LogItem
mkLogItem
          forall a b. (a -> b) -> a -> b
$ forall a. Builder -> Encoding' a
Aeson.unsafeToEncoding
          forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
Builder.lazyByteString ByteString
logStrLBS
      ByteString
_ ->
        Encoding -> LogItem
mkLogItem
          forall a b. (a -> b) -> a -> b
$ Message -> Encoding
messageEncoding
          forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeLenient ByteString
logStrLBS Text -> [SeriesElem] -> Message
:# []

  mkLogItem :: Encoding -> LogItem
  mkLogItem :: Encoding -> LogItem
mkLogItem Encoding
messageEnc =
    LogItem
      { logItemTimestamp :: UTCTime
logItemTimestamp = UTCTime
now
      , logItemLoc :: Loc
logItemLoc = Loc
loc
      , logItemLogSource :: Text
logItemLogSource = Text
logSource
      , logItemLevel :: LogLevel
logItemLevel = LogLevel
logLevel
      , logItemThreadContext :: KeyMap Value
logItemThreadContext = KeyMap Value
threadContext
      , logItemMessageEncoding :: Encoding
logItemMessageEncoding = Encoding
messageEnc
      }

  decodeLenient :: ByteString -> Text
decodeLenient =
    OnDecodeError -> ByteString -> Text
Text.Encoding.decodeUtf8With OnDecodeError
Text.Encoding.Error.lenientDecode
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict

  logStrLBS :: ByteString
logStrLBS = LogStr -> ByteString
logStrToLBS LogStr
logStr

logStrToLBS :: LogStr -> LBS.ByteString
logStrToLBS :: LogStr -> ByteString
logStrToLBS =
#if MIN_VERSION_fast_logger(3,0,1)
  -- Use (presumably) faster/better conversion if we have new enough fast-logger
  Builder -> ByteString
Builder.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> Builder
unLogStr
   where
    unLogStr :: LogStr -> Builder
unLogStr (LogStr Int
_ Builder
builder) = Builder
builder
#else
  LBS.fromStrict . fromLogStr
#endif

logCS
  :: (MonadLogger m)
  => CallStack
  -> LogSource
  -> LogLevel
  -> Message
  -> m ()
logCS :: forall (m :: * -> *).
MonadLogger m =>
CallStack -> Text -> LogLevel -> Message -> m ()
logCS CallStack
cs Text
logSource LogLevel
logLevel Message
msg =
  forall (m :: * -> *) msg.
(MonadLogger m, ToLogStr msg) =>
Loc -> Text -> LogLevel -> msg -> m ()
monadLoggerLog (CallStack -> Loc
locFromCS CallStack
cs) Text
logSource LogLevel
logLevel forall a b. (a -> b) -> a -> b
$ forall msg. ToLogStr msg => msg -> LogStr
toLogStr Message
msg

data LogItem = LogItem
  { LogItem -> UTCTime
logItemTimestamp :: UTCTime
  , LogItem -> Loc
logItemLoc :: Loc
  , LogItem -> Text
logItemLogSource :: LogSource
  , LogItem -> LogLevel
logItemLevel :: LogLevel
  , LogItem -> KeyMap Value
logItemThreadContext :: KeyMap Value
  , LogItem -> Encoding
logItemMessageEncoding :: Encoding
  }

logItemEncoding :: LogItem -> Encoding
logItemEncoding :: LogItem -> Encoding
logItemEncoding LogItem
logItem =
  Series -> Encoding
Aeson.pairs forall a b. (a -> b) -> a -> b
$
    (String -> Encoding -> Series
Aeson.pairStr String
"time" forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Encoding
Aeson.toEncoding UTCTime
logItemTimestamp)
      forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"level" forall a b. (a -> b) -> a -> b
$ LogLevel -> Encoding
levelEncoding LogLevel
logItemLevel)
      forall a. Semigroup a => a -> a -> a
<> ( if Loc -> Bool
isDefaultLoc Loc
logItemLoc then
             forall a. Monoid a => a
mempty
           else
             String -> Encoding -> Series
Aeson.pairStr String
"location" forall a b. (a -> b) -> a -> b
$ Loc -> Encoding
locEncoding Loc
logItemLoc
         )
      forall a. Semigroup a => a -> a -> a
<> ( if Text -> Bool
Text.null Text
logItemLogSource then
             forall a. Monoid a => a
mempty
           else
             String -> Encoding -> Series
Aeson.pairStr String
"source" forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Encoding
Aeson.toEncoding Text
logItemLogSource
         )
      forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null KeyMap Value
logItemThreadContext then
             forall a. Monoid a => a
mempty
           else
             String -> Encoding -> Series
Aeson.pairStr String
"context" forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Encoding
Aeson.toEncoding KeyMap Value
logItemThreadContext
         )
      forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"message" Encoding
logItemMessageEncoding)
  where
  LogItem
    { UTCTime
logItemTimestamp :: UTCTime
logItemTimestamp :: LogItem -> UTCTime
logItemTimestamp
    , Loc
logItemLoc :: Loc
logItemLoc :: LogItem -> Loc
logItemLoc
    , Text
logItemLogSource :: Text
logItemLogSource :: LogItem -> Text
logItemLogSource
    , LogLevel
logItemLevel :: LogLevel
logItemLevel :: LogItem -> LogLevel
logItemLevel
    , KeyMap Value
logItemThreadContext :: KeyMap Value
logItemThreadContext :: LogItem -> KeyMap Value
logItemThreadContext
    , Encoding
logItemMessageEncoding :: Encoding
logItemMessageEncoding :: LogItem -> Encoding
logItemMessageEncoding
    } = LogItem
logItem

messageEncoding :: Message -> Encoding
messageEncoding :: Message -> Encoding
messageEncoding  = Series -> Encoding
Aeson.pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> Series
messageSeries

messageSeries :: Message -> Series
messageSeries :: Message -> Series
messageSeries Message
message =
  Key
"text" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
messageText
    forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SeriesElem]
messageMeta then
           forall a. Monoid a => a
mempty
         else
           String -> Encoding -> Series
Aeson.pairStr String
"meta" forall a b. (a -> b) -> a -> b
$ Series -> Encoding
Aeson.pairs forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap SeriesElem -> Series
unSeriesElem [SeriesElem]
messageMeta
       )
  where
  Text
messageText :# [SeriesElem]
messageMeta = Message
message

pairsEncoding :: [Pair] -> Encoding
pairsEncoding :: [Pair] -> Encoding
pairsEncoding = Series -> Encoding
Aeson.pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pair] -> Series
pairsSeries

pairsSeries :: [Pair] -> Series
pairsSeries :: [Pair] -> Series
pairsSeries = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
(.=))

levelEncoding :: LogLevel -> Encoding
levelEncoding :: LogLevel -> Encoding
levelEncoding = forall a. Text -> Encoding' a
Aeson.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> Text
logLevelToText

logLevelToText :: LogLevel -> Text
logLevelToText :: LogLevel -> Text
logLevelToText = \case
  LogLevel
LevelDebug -> Text
"debug"
  LogLevel
LevelInfo -> Text
"info"
  LogLevel
LevelWarn -> Text
"warn"
  LogLevel
LevelError -> Text
"error"
  LevelOther Text
otherLevel -> Text
otherLevel

locEncoding :: Loc -> Encoding
locEncoding :: Loc -> Encoding
locEncoding Loc
loc =
  Series -> Encoding
Aeson.pairs forall a b. (a -> b) -> a -> b
$
    (String -> Encoding -> Series
Aeson.pairStr String
"package" forall a b. (a -> b) -> a -> b
$ forall a. String -> Encoding' a
Aeson.string String
loc_package)
      forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"module" forall a b. (a -> b) -> a -> b
$ forall a. String -> Encoding' a
Aeson.string String
loc_module)
      forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"file" forall a b. (a -> b) -> a -> b
$ forall a. String -> Encoding' a
Aeson.string String
loc_filename)
      forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"line" forall a b. (a -> b) -> a -> b
$ Int -> Encoding
Aeson.int forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst CharPos
loc_start)
      forall a. Semigroup a => a -> a -> a
<> (String -> Encoding -> Series
Aeson.pairStr String
"char" forall a b. (a -> b) -> a -> b
$ Int -> Encoding
Aeson.int forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd CharPos
loc_start)
  where
  Loc { String
loc_filename :: String
loc_filename :: Loc -> String
loc_filename, String
loc_package :: String
loc_package :: Loc -> String
loc_package, String
loc_module :: String
loc_module :: Loc -> String
loc_module, CharPos
loc_start :: CharPos
loc_start :: Loc -> CharPos
loc_start } = Loc
loc

-- | Not exported from 'monad-logger', so copied here.
mkLoggerLoc :: SrcLoc -> Loc
mkLoggerLoc :: SrcLoc -> Loc
mkLoggerLoc SrcLoc
loc =
  Loc { loc_filename :: String
loc_filename = SrcLoc -> String
srcLocFile SrcLoc
loc
      , loc_package :: String
loc_package  = SrcLoc -> String
srcLocPackage SrcLoc
loc
      , loc_module :: String
loc_module   = SrcLoc -> String
srcLocModule SrcLoc
loc
      , loc_start :: CharPos
loc_start    = ( SrcLoc -> Int
srcLocStartLine SrcLoc
loc
                       , SrcLoc -> Int
srcLocStartCol SrcLoc
loc)
      , loc_end :: CharPos
loc_end      = ( SrcLoc -> Int
srcLocEndLine SrcLoc
loc
                       , SrcLoc -> Int
srcLocEndCol SrcLoc
loc)
      }

-- | Not exported from 'monad-logger', so copied here.
locFromCS :: CallStack -> Loc
locFromCS :: CallStack -> Loc
locFromCS CallStack
cs = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
                 ((String
_, SrcLoc
loc):[(String, SrcLoc)]
_) -> SrcLoc -> Loc
mkLoggerLoc SrcLoc
loc
                 [(String, SrcLoc)]
_            -> Loc
Logger.defaultLoc

-- | Not exported from 'monad-logger', so copied here.
isDefaultLoc :: Loc -> Bool
isDefaultLoc :: Loc -> Bool
isDefaultLoc (Loc String
"<unknown>" String
"<unknown>" String
"<unknown>" (Int
0,Int
0) (Int
0,Int
0)) = Bool
True
isDefaultLoc Loc
_ = Bool
False

-- $disclaimer
--
-- In general, changes to this module will not be reflected in the library's
-- version updates. Direct use of this module should be done with care.