Internal.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# 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.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 = AesonCompat.empty

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

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

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

keyMapUnion :: KeyMap v -> KeyMap v -> KeyMap v
keyMapUnion = 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
  { unSeriesElem :: Series
  }

-- | @since 0.3.0.0
#if MIN_VERSION_aeson(2, 2, 0)
instance KeyValue Encoding SeriesElem where
  (.=) = explicitToField Aeson.toEncoding
  {-# INLINE (.=) #-}

  explicitToField f name value =
    UnsafeSeriesElem $ Aeson.pair name $ f value
  {-# INLINE explicitToField #-}
#else
deriving newtype instance KeyValue SeriesElem
#endif
-- | @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
  { loggedMessageTimestamp :: UTCTime
  , loggedMessageLevel :: LogLevel
  , loggedMessageLoc :: Maybe Loc
  , loggedMessageLogSource :: Maybe LogSource
  , loggedMessageThreadContext :: KeyMap Value
  , loggedMessageText :: Text
  , loggedMessageMeta :: KeyMap Value
  } deriving stock (Eq, Generic, Ord, Show)

instance FromJSON LoggedMessage where
  parseJSON = Aeson.withObject "LoggedMessage" $ \obj -> do
    loggedMessageTimestamp <- obj .: "time"
    loggedMessageLevel <- fmap logLevelFromText $ obj .: "level"
    loggedMessageLoc <- parseLoc =<< obj .:? "location"
    loggedMessageLogSource <- obj .:? "source"
    loggedMessageThreadContext <- parsePairs =<< obj .:? "context"
    (loggedMessageText, loggedMessageMeta) <- parseMessage =<< obj .: "message"
    pure LoggedMessage
      { loggedMessageTimestamp
      , loggedMessageLevel
      , loggedMessageLoc
      , loggedMessageLogSource
      , loggedMessageThreadContext
      , loggedMessageText
      , loggedMessageMeta
      }
    where
    logLevelFromText :: Text -> LogLevel
    logLevelFromText = \case
      "debug" -> LevelDebug
      "info" -> LevelInfo
      "warn" -> LevelWarn
      "error" -> LevelError
      other -> LevelOther other

    parseLoc :: Maybe Value -> Parser (Maybe Loc)
    parseLoc =
      traverse $ Aeson.withObject "Loc" $ \obj ->
        Loc
          <$> obj .: "file"
          <*> obj .: "package"
          <*> obj .: "module"
          <*> (pure (,) <*> (obj .: "line") <*> (obj .: "char"))
          <*> pure (0, 0)

    parsePairs :: Maybe Value -> Parser (KeyMap Value)
    parsePairs = \case
      Nothing -> pure mempty
      Just value -> flip (Aeson.withObject "[Pair]") value $ \obj -> do
        pure obj

    parseMessage :: Value -> Parser (Text, KeyMap Value)
    parseMessage = Aeson.withObject "Message" $ \obj ->
      (,) <$> obj .: "text" <*> (parsePairs =<< obj .:? "meta")

instance ToJSON LoggedMessage where
  toJSON loggedMessage =
    Aeson.object $ Maybe.catMaybes
      [ Just $ "time" .= loggedMessageTimestamp
      , Just $ "level" .= logLevelToText loggedMessageLevel
      , case loggedMessageLoc of
          Nothing -> Nothing
          Just loc -> Just $ "location" .= locToJSON loc
      , case loggedMessageLogSource of
          Nothing -> Nothing
          Just logSource -> Just $ "source" .= logSource
      , if loggedMessageThreadContext == mempty then
          Nothing
        else
          Just $ "context" .= Object loggedMessageThreadContext
      , Just $ "message" .= messageJSON
      ]
    where
    locToJSON :: Loc -> Value
    locToJSON loc =
      Aeson.object
        [ "package" .= loc_package
        , "module" .= loc_module
        , "file" .= loc_filename
        , "line" .= fst loc_start
        , "char" .= snd loc_start
        ]
      where
      Loc { loc_filename, loc_package, loc_module, loc_start } = loc

    messageJSON :: Value
    messageJSON =
      Aeson.object $ Maybe.catMaybes
        [ Just $ "text" .= loggedMessageText
        , if loggedMessageMeta == mempty then
            Nothing
          else
            Just $ "meta" .= Object loggedMessageMeta
        ]

    LoggedMessage
      { loggedMessageTimestamp
      , loggedMessageLevel
      , loggedMessageLoc
      , loggedMessageLogSource
      , loggedMessageThreadContext
      , loggedMessageText
      , loggedMessageMeta
      } = loggedMessage

  toEncoding loggedMessage = logItemEncoding logItem
    where
    logItem =
      LogItem
        { logItemTimestamp = loggedMessageTimestamp
        , logItemLoc = Maybe.fromMaybe Logger.defaultLoc loggedMessageLoc
        , logItemLogSource = Maybe.fromMaybe "" loggedMessageLogSource
        , logItemLevel = loggedMessageLevel
        , logItemThreadContext = loggedMessageThreadContext
        , logItemMessageEncoding =
            messageEncoding $
              loggedMessageText :# keyMapToSeriesList loggedMessageMeta
        }

    keyMapToSeriesList :: KeyMap Value -> [SeriesElem]
    keyMapToSeriesList =
      fmap (uncurry (.=)) . keyMapToList

    LoggedMessage
      { loggedMessageTimestamp
      , loggedMessageLevel
      , loggedMessageLoc
      , loggedMessageLogSource
      , loggedMessageThreadContext
      , loggedMessageText
      , loggedMessageMeta
      } = 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 = Text.pack string :# []

instance ToLogStr Message where
  toLogStr = toLogStr . Aeson.encodingToLazyByteString . 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 =
  IO.Unsafe.unsafePerformIO
    $ Context.newStore Context.noPropagation
    $ Just
    $ 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
  { 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
    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
    outputBaseThreadContext :: [Pair]
  }

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

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

  mkLogItem :: Encoding -> LogItem
  mkLogItem messageEnc =
    LogItem
      { logItemTimestamp = now
      , logItemLoc = loc
      , logItemLogSource = logSource
      , logItemLevel = logLevel
      , logItemThreadContext = threadContext
      , logItemMessageEncoding = messageEnc
      }

  decodeLenient =
    Text.Encoding.decodeUtf8With Text.Encoding.Error.lenientDecode
      . LBS.toStrict

  logStrLBS = logStrToLBS logStr

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

logCS
  :: (MonadLogger m)
  => CallStack
  -> LogSource
  -> LogLevel
  -> Message
  -> m ()
logCS cs logSource logLevel msg =
  monadLoggerLog (locFromCS cs) logSource logLevel $ toLogStr msg

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

logItemEncoding :: LogItem -> Encoding
logItemEncoding logItem =
  Aeson.pairs $
    (Aeson.pairStr "time" $ Aeson.toEncoding logItemTimestamp)
      <> (Aeson.pairStr "level" $ levelEncoding logItemLevel)
      <> ( if isDefaultLoc logItemLoc then
             mempty
           else
             Aeson.pairStr "location" $ locEncoding logItemLoc
         )
      <> ( if Text.null logItemLogSource then
             mempty
           else
             Aeson.pairStr "source" $ Aeson.toEncoding logItemLogSource
         )
      <> ( if null logItemThreadContext then
             mempty
           else
             Aeson.pairStr "context" $ Aeson.toEncoding logItemThreadContext
         )
      <> (Aeson.pairStr "message" logItemMessageEncoding)
  where
  LogItem
    { logItemTimestamp
    , logItemLoc
    , logItemLogSource
    , logItemLevel
    , logItemThreadContext
    , logItemMessageEncoding
    } = logItem

messageEncoding :: Message -> Encoding
messageEncoding  = Aeson.pairs . messageSeries

messageSeries :: Message -> Series
messageSeries message =
  "text" .= messageText
    <> ( if null messageMeta then
           mempty
         else
           Aeson.pairStr "meta" $ Aeson.pairs $ foldMap unSeriesElem messageMeta
       )
  where
  messageText :# messageMeta = message

pairsEncoding :: [Pair] -> Encoding
pairsEncoding = Aeson.pairs . pairsSeries

pairsSeries :: [Pair] -> Series
pairsSeries = mconcat . fmap (uncurry (.=))

levelEncoding :: LogLevel -> Encoding
levelEncoding = Aeson.text . logLevelToText

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

locEncoding :: Loc -> Encoding
locEncoding loc =
  Aeson.pairs $
    (Aeson.pairStr "package" $ Aeson.string loc_package)
      <> (Aeson.pairStr "module" $ Aeson.string loc_module)
      <> (Aeson.pairStr "file" $ Aeson.string loc_filename)
      <> (Aeson.pairStr "line" $ Aeson.int $ fst loc_start)
      <> (Aeson.pairStr "char" $ Aeson.int $ snd loc_start)
  where
  Loc { loc_filename, loc_package, loc_module, loc_start } = loc

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

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

-- | Not exported from 'monad-logger', so copied here.
isDefaultLoc :: Loc -> Bool
isDefaultLoc (Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)) = True
isDefaultLoc _ = 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.