{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, RecordWildCards #-}

-- | This module contains definitions for formatting log message to write it to output.
--
-- Log message format is defined by using @text-format-heavy@ syntax. Variables available are:
--
-- * level - message severity level. Variable format can be specified in form of
--   @selector[~convert]@, where:
--
--     * @selector@ is @name@ for level name, @value@ for level integer value,
--       @syslog@ for name of syslog equivalent of the level.
--
--     * @convert@ is @u@ for upper case, @l@ for lower case, @t@ for title case
--       (all words capitalized).
--   
--     Default format corresponds to @name@. For example, use @{level:~l}@ to
--     output level name in lower case.
--
-- * source - message source (module name)
--
-- * location - location from where message was logged (in form of @(line, column)@).
--
-- * line - source file line number from where message was logged.
--
-- * file - source file name from where message was logged.
--
-- * package - name of the package from where message was logged.
--
-- * time - message time
--
-- * message - message string itself
--
-- * fullcontext - full set of current context variable values, in @name=value; name=value;@ form.
--
-- * Also all variables from context are available.
--
module System.Log.Heavy.Format
  ( LogMessageWithTime (..),
    defaultLogFormat,
    formatLogMessage,
    formatLogMessage'
  ) where

import Control.Applicative
import Control.Monad
import Data.List (intercalate)
import Data.Maybe
import Data.Monoid
import Data.Default
import qualified Data.Map as M
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as Builder
import qualified Data.Text.Lazy.Builder.Int as Builder
import System.Log.FastLogger
import qualified Data.Text.Format.Heavy as F
import qualified Data.Text.Format.Heavy.Parse as PF
import Data.Text.Format.Heavy.Formats (Conversion (..))
import Data.Text.Format.Heavy.Build (convertText)
import Data.Attoparsec.Text
import Language.Haskell.TH.Syntax (Loc (..))
import Prelude hiding (takeWhile)

import System.Log.Heavy.Types
import System.Log.Heavy.Level

data LogMessageWithTime = LogMessageWithTime FormattedTime LogMessage

data LevelFormatSelector = ShowLevelName | ShowLevelValue | ShowSyslog
  deriving (LevelFormatSelector -> LevelFormatSelector -> Bool
(LevelFormatSelector -> LevelFormatSelector -> Bool)
-> (LevelFormatSelector -> LevelFormatSelector -> Bool)
-> Eq LevelFormatSelector
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LevelFormatSelector -> LevelFormatSelector -> Bool
$c/= :: LevelFormatSelector -> LevelFormatSelector -> Bool
== :: LevelFormatSelector -> LevelFormatSelector -> Bool
$c== :: LevelFormatSelector -> LevelFormatSelector -> Bool
Eq, Int -> LevelFormatSelector -> ShowS
[LevelFormatSelector] -> ShowS
LevelFormatSelector -> String
(Int -> LevelFormatSelector -> ShowS)
-> (LevelFormatSelector -> String)
-> ([LevelFormatSelector] -> ShowS)
-> Show LevelFormatSelector
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LevelFormatSelector] -> ShowS
$cshowList :: [LevelFormatSelector] -> ShowS
show :: LevelFormatSelector -> String
$cshow :: LevelFormatSelector -> String
showsPrec :: Int -> LevelFormatSelector -> ShowS
$cshowsPrec :: Int -> LevelFormatSelector -> ShowS
Show)

data LevelFormat = LevelFormat {
    LevelFormat -> LevelFormatSelector
lfSelector :: LevelFormatSelector
  , LevelFormat -> Maybe Conversion
lfConvert :: Maybe Conversion
  }
  deriving (LevelFormat -> LevelFormat -> Bool
(LevelFormat -> LevelFormat -> Bool)
-> (LevelFormat -> LevelFormat -> Bool) -> Eq LevelFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LevelFormat -> LevelFormat -> Bool
$c/= :: LevelFormat -> LevelFormat -> Bool
== :: LevelFormat -> LevelFormat -> Bool
$c== :: LevelFormat -> LevelFormat -> Bool
Eq, Int -> LevelFormat -> ShowS
[LevelFormat] -> ShowS
LevelFormat -> String
(Int -> LevelFormat -> ShowS)
-> (LevelFormat -> String)
-> ([LevelFormat] -> ShowS)
-> Show LevelFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LevelFormat] -> ShowS
$cshowList :: [LevelFormat] -> ShowS
show :: LevelFormat -> String
$cshow :: LevelFormat -> String
showsPrec :: Int -> LevelFormat -> ShowS
$cshowsPrec :: Int -> LevelFormat -> ShowS
Show)

instance Default LevelFormat where
  def :: LevelFormat
def = LevelFormatSelector -> Maybe Conversion -> LevelFormat
LevelFormat LevelFormatSelector
ShowLevelName Maybe Conversion
forall a. Maybe a
Nothing

instance F.IsVarFormat LevelFormat where
  parseVarFormat :: Text -> Either String LevelFormat
parseVarFormat Text
text = (String -> Either String LevelFormat)
-> (LevelFormat -> Either String LevelFormat)
-> Either String LevelFormat
-> Either String LevelFormat
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String LevelFormat
forall a b. a -> Either a b
Left (String -> Either String LevelFormat)
-> ShowS -> String -> Either String LevelFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
forall a. Show a => a -> String
show) LevelFormat -> Either String LevelFormat
forall a b. b -> Either a b
Right (Either String LevelFormat -> Either String LevelFormat)
-> Either String LevelFormat -> Either String LevelFormat
forall a b. (a -> b) -> a -> b
$ Text -> Either String LevelFormat
doParse (Text -> Either String LevelFormat)
-> Text -> Either String LevelFormat
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
text
    where
      pFormat :: Parser LevelFormat
      pFormat :: Parser LevelFormat
pFormat = do
        Maybe LevelFormatSelector
mbSelector <- Parser Text LevelFormatSelector
-> Parser Text (Maybe LevelFormatSelector)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optionMaybe (Parser Text LevelFormatSelector
pSelector Parser Text LevelFormatSelector
-> String -> Parser Text LevelFormatSelector
forall i a. Parser i a -> String -> Parser i a
<?> String
"level detail selector")
        let selector :: LevelFormatSelector
selector = LevelFormatSelector
-> Maybe LevelFormatSelector -> LevelFormatSelector
forall a. a -> Maybe a -> a
fromMaybe LevelFormatSelector
ShowLevelName Maybe LevelFormatSelector
mbSelector
        Maybe Conversion
mbConvert <- Parser Text Conversion -> Parser Text (Maybe Conversion)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optionMaybe (Parser Text Conversion
pConvert Parser Text Conversion -> String -> Parser Text Conversion
forall i a. Parser i a -> String -> Parser i a
<?> String
"conversion specification")
        LevelFormat -> Parser LevelFormat
forall (m :: * -> *) a. Monad m => a -> m a
return (LevelFormat -> Parser LevelFormat)
-> LevelFormat -> Parser LevelFormat
forall a b. (a -> b) -> a -> b
$ LevelFormatSelector -> Maybe Conversion -> LevelFormat
LevelFormat LevelFormatSelector
selector Maybe Conversion
mbConvert

      optionMaybe :: f a -> f (Maybe a)
optionMaybe f a
p = Maybe a -> f (Maybe a) -> f (Maybe a)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe a
forall a. Maybe a
Nothing (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> f a -> f (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
p)

      pSelector :: Parser LevelFormatSelector
      pSelector :: Parser Text LevelFormatSelector
pSelector =
        Parser Text LevelFormatSelector -> Parser Text LevelFormatSelector
forall i a. Parser i a -> Parser i a
try (Text -> Parser Text
string Text
"value" Parser Text
-> Parser Text LevelFormatSelector
-> Parser Text LevelFormatSelector
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LevelFormatSelector -> Parser Text LevelFormatSelector
forall (m :: * -> *) a. Monad m => a -> m a
return LevelFormatSelector
ShowLevelValue) Parser Text LevelFormatSelector
-> Parser Text LevelFormatSelector
-> Parser Text LevelFormatSelector
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        Parser Text LevelFormatSelector -> Parser Text LevelFormatSelector
forall i a. Parser i a -> Parser i a
try (Text -> Parser Text
string Text
"syslog" Parser Text
-> Parser Text LevelFormatSelector
-> Parser Text LevelFormatSelector
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LevelFormatSelector -> Parser Text LevelFormatSelector
forall (m :: * -> *) a. Monad m => a -> m a
return LevelFormatSelector
ShowSyslog) Parser Text LevelFormatSelector
-> Parser Text LevelFormatSelector
-> Parser Text LevelFormatSelector
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (Text -> Parser Text
string Text
"name" Parser Text
-> Parser Text LevelFormatSelector
-> Parser Text LevelFormatSelector
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LevelFormatSelector -> Parser Text LevelFormatSelector
forall (m :: * -> *) a. Monad m => a -> m a
return LevelFormatSelector
ShowLevelName)

      pConvert :: Parser Conversion
      pConvert :: Parser Text Conversion
pConvert = do
        Char -> Parser Char
char Char
'~'
        Char
conv <- (Char -> Bool) -> Parser Char
satisfy (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'u', Char
'l', Char
't'])
        case Char
conv of
          Char
'u' -> Conversion -> Parser Text Conversion
forall (m :: * -> *) a. Monad m => a -> m a
return Conversion
UpperCase
          Char
'l' -> Conversion -> Parser Text Conversion
forall (m :: * -> *) a. Monad m => a -> m a
return Conversion
LowerCase
          Char
't' -> Conversion -> Parser Text Conversion
forall (m :: * -> *) a. Monad m => a -> m a
return Conversion
TitleCase

      doParse :: Text -> Either String LevelFormat
doParse Text
text = Parser LevelFormat -> Text -> Either String LevelFormat
forall a. Parser a -> Text -> Either String a
parseOnly Parser LevelFormat
pFormat Text
text

instance F.Formatable Level where
  formatVar :: VarFormat -> Level -> Either String Builder
formatVar VarFormat
Nothing Level
level = Builder -> Either String Builder
forall a b. b -> Either a b
Right (Builder -> Either String Builder)
-> Builder -> Either String Builder
forall a b. (a -> b) -> a -> b
$ Text -> Builder
Builder.fromText (Level -> Text
levelName Level
level)
  formatVar (Just Text
fmt) Level
level = do
    LevelFormat
lf <- Text -> Either String LevelFormat
forall f. IsVarFormat f => Text -> Either String f
F.parseVarFormat Text
fmt
    let text :: Builder
text = case LevelFormat -> LevelFormatSelector
lfSelector LevelFormat
lf of
                 LevelFormatSelector
ShowLevelName -> Text -> Builder
Builder.fromText (Level -> Text
levelName Level
level)
                 LevelFormatSelector
ShowLevelValue -> Int -> Builder
forall a. Integral a => a -> Builder
Builder.decimal (Level -> Int
levelInt Level
level)
                 LevelFormatSelector
ShowSyslog -> String -> Builder
Builder.fromString (Priority -> String
forall a. Show a => a -> String
show (Priority -> String) -> Priority -> String
forall a b. (a -> b) -> a -> b
$ Level -> Priority
levelToPriority Level
level)
    Builder -> Either String Builder
forall a b. b -> Either a b
Right (Builder -> Either String Builder)
-> Builder -> Either String Builder
forall a b. (a -> b) -> a -> b
$ Maybe Conversion -> Builder -> Builder
convertText (LevelFormat -> Maybe Conversion
lfConvert LevelFormat
lf) Builder
text

instance F.VarContainer LogMessageWithTime where
  lookupVar :: Text -> LogMessageWithTime -> Maybe Variable
lookupVar Text
name (LogMessageWithTime FormattedTime
ftime  (LogMessage {vars
LogSource
LogContext
Text
Loc
Level
lmContext :: LogMessage -> LogContext
lmFormatVars :: ()
lmFormatString :: LogMessage -> Text
lmLocation :: LogMessage -> Loc
lmSource :: LogMessage -> LogSource
lmLevel :: LogMessage -> Level
lmContext :: LogContext
lmFormatVars :: vars
lmFormatString :: Text
lmLocation :: Loc
lmSource :: LogSource
lmLevel :: Level
..})) =
      case Text -> [(Text, Variable)] -> Maybe Variable
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name [(Text, Variable)]
stdVariables of
        Just Variable
value -> Variable -> Maybe Variable
forall a. a -> Maybe a
Just Variable
value
        Maybe Variable
Nothing -> Variable -> Maybe Variable
forall a. a -> Maybe a
Just (Variable -> Maybe Variable) -> Variable -> Maybe Variable
forall a b. (a -> b) -> a -> b
$ Variable -> Maybe Variable -> Variable
forall a. a -> Maybe a -> a
fromMaybe (Text -> Variable
forall a. Formatable a => a -> Variable
F.Variable Text
TL.empty) (Maybe Variable -> Variable) -> Maybe Variable -> Variable
forall a b. (a -> b) -> a -> b
$ [Maybe Variable] -> Maybe Variable
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe Variable] -> Maybe Variable)
-> [Maybe Variable] -> Maybe Variable
forall a b. (a -> b) -> a -> b
$ ([(Text, Variable)] -> Maybe Variable)
-> [[(Text, Variable)]] -> [Maybe Variable]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> [(Text, Variable)] -> Maybe Variable
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
name) [[(Text, Variable)]]
contextVariables
    where
      stdVariables :: [(TL.Text, F.Variable)]
      stdVariables :: [(Text, Variable)]
stdVariables = [(Text
"level", Level -> Variable
forall a. Formatable a => a -> Variable
F.Variable Level
lmLevel),
                      (Text
"source", String -> Variable
forall a. Formatable a => a -> Variable
F.Variable (String -> Variable) -> String -> Variable
forall a b. (a -> b) -> a -> b
$ String -> LogSource -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." LogSource
lmSource),
                      (Text
"location", String -> Variable
forall a. Formatable a => a -> Variable
F.Variable (String -> Variable) -> String -> Variable
forall a b. (a -> b) -> a -> b
$ CharPos -> String
forall a. Show a => a -> String
show (CharPos -> String) -> CharPos -> String
forall a b. (a -> b) -> a -> b
$ Loc -> CharPos
loc_start Loc
lmLocation),
                      (Text
"line", Int -> Variable
forall a. Formatable a => a -> Variable
F.Variable (Int -> Variable) -> Int -> Variable
forall a b. (a -> b) -> a -> b
$ CharPos -> Int
forall a b. (a, b) -> a
fst (CharPos -> Int) -> CharPos -> Int
forall a b. (a -> b) -> a -> b
$ Loc -> CharPos
loc_start Loc
lmLocation),
                      (Text
"file", String -> Variable
forall a. Formatable a => a -> Variable
F.Variable (String -> Variable) -> String -> Variable
forall a b. (a -> b) -> a -> b
$ Loc -> String
loc_filename Loc
lmLocation),
                      (Text
"package", String -> Variable
forall a. Formatable a => a -> Variable
F.Variable (String -> Variable) -> String -> Variable
forall a b. (a -> b) -> a -> b
$ Loc -> String
loc_package Loc
lmLocation),
                      (Text
"time", FormattedTime -> Variable
forall a. Formatable a => a -> Variable
F.Variable FormattedTime
ftime),
                      (Text
"message", Text -> Variable
forall a. Formatable a => a -> Variable
F.Variable Text
formattedMessage),
                      (Text
"fullcontext", Text -> Variable
forall a. Formatable a => a -> Variable
F.Variable Text
fullContext)]

      contextVariables :: [[(TL.Text, F.Variable)]]
      contextVariables :: [[(Text, Variable)]]
contextVariables = (LogContextFrame -> [(Text, Variable)])
-> LogContext -> [[(Text, Variable)]]
forall a b. (a -> b) -> [a] -> [b]
map LogContextFrame -> [(Text, Variable)]
lcfVariables LogContext
lmContext

      fullContext :: TL.Text
      fullContext :: Text
fullContext = [Text] -> Text
TL.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ ((Text, Variable) -> Text) -> [(Text, Variable)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, Variable) -> Text
showContextVar ([(Text, Variable)] -> [Text]) -> [(Text, Variable)] -> [Text]
forall a b. (a -> b) -> a -> b
$ Map Text Variable -> [(Text, Variable)]
forall k a. Map k a -> [(k, a)]
M.assocs (Map Text Variable -> [(Text, Variable)])
-> Map Text Variable -> [(Text, Variable)]
forall a b. (a -> b) -> a -> b
$ [(Text, Variable)] -> Map Text Variable
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Text, Variable)] -> Map Text Variable)
-> [(Text, Variable)] -> Map Text Variable
forall a b. (a -> b) -> a -> b
$ [[(Text, Variable)]] -> [(Text, Variable)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Text, Variable)]]
contextVariables

      showContextVar :: (TL.Text, F.Variable) -> TL.Text
      showContextVar :: (Text, Variable) -> Text
showContextVar (Text
name, Variable
value) = Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Variable -> Text
formatVar Variable
value Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"; "

      formatVar :: F.Variable -> TL.Text
      formatVar :: Variable -> Text
formatVar Variable
var = (String -> Text)
-> (Builder -> Text) -> Either String Builder -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Text
forall a. HasCallStack => String -> a
error Builder -> Text
Builder.toLazyText (Either String Builder -> Text) -> Either String Builder -> Text
forall a b. (a -> b) -> a -> b
$ VarFormat -> Variable -> Either String Builder
forall a. Formatable a => VarFormat -> a -> Either String Builder
F.formatVar VarFormat
forall a. Maybe a
Nothing Variable
var

      formattedMessage :: Text
formattedMessage =
        let fmt :: Format
fmt = Text -> Format
PF.parseFormat' Text
lmFormatString
        in  Format -> vars -> Text
forall vars. VarContainer vars => Format -> vars -> Text
F.format Format
fmt vars
lmFormatVars

-- | Default log message format.
-- Corresponds to: @{time} [{level}] {source}: {message}\\n@
defaultLogFormat :: F.Format
defaultLogFormat :: Format
defaultLogFormat = Text -> Format
PF.parseFormat' Text
"{time} [{level}] {source}: {message}\n"

-- | Format log message for output.
formatLogMessage :: F.Format -> LogMessage -> FormattedTime -> LogStr
formatLogMessage :: Format -> LogMessage -> FormattedTime -> LogStr
formatLogMessage Format
fmt LogMessage
msg FormattedTime
ftime = Text -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$ Format -> LogMessage -> FormattedTime -> Text
formatLogMessage' Format
fmt LogMessage
msg FormattedTime
ftime

-- | Format log message for output.
formatLogMessage' :: F.Format -> LogMessage -> FormattedTime -> TL.Text
formatLogMessage' :: Format -> LogMessage -> FormattedTime -> Text
formatLogMessage' Format
fmt LogMessage
msg FormattedTime
ftime = Format -> LogMessageWithTime -> Text
forall vars. VarContainer vars => Format -> vars -> Text
F.format Format
fmt (LogMessageWithTime -> Text) -> LogMessageWithTime -> Text
forall a b. (a -> b) -> a -> b
$ FormattedTime -> LogMessage -> LogMessageWithTime
LogMessageWithTime FormattedTime
ftime LogMessage
msg