module System.Wlog.Formatter
( formatLogMessage
, formatLogMessageColors
, stdoutFormatter
, stderrFormatter
, stdoutFormatterTimeRounded
, getRoundedTime
, LogFormatter
, nullFormatter
, simpleLogFormatter
, tfLogFormatter
, varFormatter
) where
import Control.Concurrent (myThreadId)
import Data.Monoid (mconcat)
import qualified Data.Text as T
import Data.Time (formatTime, getCurrentTime, getZonedTime)
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format (FormatTime)
import Data.Text.Lazy.Builder as B
import Formatting (Format, sformat, shown, stext, (%))
import Universum
#ifndef mingw32_HOST_OS
import System.Posix.Process (getProcessID)
#endif
#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
import System.Wlog.Color (colorizer)
import System.Wlog.LoggerName (LoggerName, loggerNameF)
import System.Wlog.Severity (LogRecord(..), Severity (..))
type LogFormatter a
= a
-> LogRecord
-> Text
-> IO Builder
nullFormatter :: LogFormatter a
nullFormatter _ (LR _ msg) _ = pure (B.fromText msg)
replaceVars
:: [(Text, Text)]
-> Text
-> Builder
replaceVars _ (T.null -> True) = mempty
replaceVars keyVals (T.breakOn "$" -> (before,after)) =
if T.null after then B.fromText before
else
let (f, rest) = replaceStart keyVals $ T.drop 1 after
repRest = replaceVars keyVals rest
in B.fromText before <> f <> repRest
where
replaceStart :: [(Text, Text)] -> Text -> (Builder, Text)
replaceStart [] str = (B.singleton '$', str)
replaceStart ((k, v):kvs) txt
| k `T.isPrefixOf` txt = (B.fromText v, T.drop (T.length k) txt)
| otherwise = replaceStart kvs txt
varFormatter :: [(Text, Text)] -> Text -> LogFormatter a
varFormatter vars format _h (LR prio msg) loggername = do
defaultVars <- predefinedVars
platformVars <- osSpecificVars
return $ replaceVars (vars <> defaultVars <> platformVars) format
where
predefinedVars = do
tid <- T.pack . show <$> myThreadId
pure [ ("msg", msg)
, ("prio", T.toUpper $ show prio)
, ("loggername", loggername)
, ("tid", tid)
]
#ifndef mingw32_HOST_OS
osSpecificVars = do
pid <- T.pack . show <$> getProcessID
pure [("pid", pid)]
#else
osSpecificVars = return mempty
#endif
tfLogFormatter :: Text -> Text -> LogFormatter a
tfLogFormatter timeFormat format = \h kv loggername -> do
time <- ftime <$> getZonedTime
utcTime <- ftime <$> getCurrentTime
varFormatter [ ("time", time)
, ("utcTime", utcTime)
]
format h kv loggername
where
ftime :: FormatTime t => t -> Text
ftime = T.pack . formatTime defaultTimeLocale (T.unpack timeFormat)
simpleLogFormatter :: Text -> LogFormatter a
simpleLogFormatter format h logRecord loggername =
tfLogFormatter "%F %X %Z" format h logRecord loggername
timeFmt :: Text
timeFmt = "[$time] "
timeFmtStdout :: Bool -> Text
timeFmtStdout = bool mempty timeFmt
getRoundedTime :: Int -> IO UTCTime
getRoundedTime roundN = do
UTCTime{..} <- liftIO $ getCurrentTime
let newSec = fromIntegral $ roundBy (round $ toRational utctDayTime :: Int)
pure $ UTCTime { utctDayTime = newSec, .. }
where
roundBy :: (Num a, Integral a) => a -> a
roundBy x = let y = x `div` fromIntegral roundN in y * fromIntegral roundN
stderrFormatter :: Bool -> LogFormatter a
stderrFormatter isShowTid = simpleLogFormatter $
mconcat $! [colorizer Error $ "[$loggername:$prio" <> tid <> "] ", timeFmt, "$msg"]
where
tid = if isShowTid then ":$tid" else ""
stdoutFmt :: Severity -> Bool -> Bool -> Text
stdoutFmt pr isShowTime isShowTid = mconcat $!
[colorizer pr $ "[$loggername:$prio" <> tid <> "] ", timeFmtStdout isShowTime, "$msg"]
where
tid = if isShowTid then ":$tid" else mempty
stdoutFormatter :: Bool -> Bool -> LogFormatter a
stdoutFormatter isShowTime isShowTid handle r@(LR pr _) =
simpleLogFormatter (stdoutFmt pr isShowTime isShowTid) handle r
stdoutFormatterTimeRounded :: Int -> LogFormatter a
stdoutFormatterTimeRounded roundN a r@(LR pr _) s = do
t <- getRoundedTime roundN
simpleLogFormatter (fmt t) a r s
where
fmt time = mconcat $!
[ colorizer pr "[$loggername:$prio:$tid]"
, " ["
, T.pack $ formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" time
, "] $msg"]
formatLogMessage :: LoggerName -> Severity -> UTCTime -> Text -> Text
formatLogMessage = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"] "%stext)
where
utcTimeF :: Format r (UTCTime -> r)
utcTimeF = shown
formatLogMessageColors :: LoggerName -> Severity -> UTCTime -> Text -> Text
formatLogMessageColors lname severity time msg =
colorizer severity prefix <> " " <> msg
where
prefix = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"]") lname severity time
utcTimeF :: Format r (UTCTime -> r)
utcTimeF = shown