module System.Wlog.Formatter
( formatLogMessage
, formatLogMessageColors
, stdoutFormatter
, stderrFormatter
, stdoutFormatterTimeRounded
, getRoundedTime
, LogFormatter
, nullFormatter
, simpleLogFormatter
, tfLogFormatter
, varFormatter
) where
import Control.Concurrent (myThreadId)
import Data.List (span)
import Data.Monoid (mconcat)
import Data.String (IsString)
import qualified Data.Text as T
import Data.Time (formatTime, getCurrentTime, getZonedTime)
import Data.Time.Clock (UTCTime (..))
import Data.Time.Format (FormatTime)
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, colorizerT)
import System.Wlog.LoggerName (LoggerName, loggerNameF)
import System.Wlog.Severity (LogRecord, Severity (..))
type LogFormatter a
= a
-> LogRecord
-> String
-> IO Text
nullFormatter :: LogFormatter a
nullFormatter _ (_,msg) _ = pure msg
replaceVarM
:: [(String, IO Text)]
-> String
-> IO Text
replaceVarM _ [] = pure ""
replaceVarM keyVals (span (/= '$') -> (before,after)) = do
if null after then pure $ T.pack before
else do
(f, rest) <- replaceStart keyVals $ drop 1 after
repRest <- replaceVarM keyVals rest
pure $ T.pack before <> f <> repRest
where
replaceStart [] str = return ("$", str)
replaceStart ((k, v):kvs) str
| k `isPrefixOf` str = do
vs <- v
return (vs, drop (length k) str)
| otherwise = replaceStart kvs str
varFormatter :: [(String, IO Text)] -> String -> LogFormatter a
varFormatter vars format _h (prio,msg) loggername = do
replaceVarM (vars ++ predefinedVars) format
where
predefinedVars = [ ("msg", pure msg)
, ("prio", pure $ T.toUpper $ show prio)
, ("loggername", pure $ T.pack loggername)
, ("tid", show <$> myThreadId)
#ifndef mingw32_HOST_OS
, ("pid", show <$> getProcessID)
#endif
]
tfLogFormatter :: String -> String -> LogFormatter a
tfLogFormatter timeFormat format = do
let ftime :: FormatTime t => t -> Text
ftime = T.pack . formatTime defaultTimeLocale timeFormat
varFormatter [ ("time", ftime <$> getZonedTime)
, ("utcTime", ftime <$> getCurrentTime)
]
format
simpleLogFormatter :: String -> LogFormatter a
simpleLogFormatter format h (prio, msg) loggername =
tfLogFormatter "%F %X %Z" format h (prio,msg) loggername
timeFmt :: IsString s => s
timeFmt = "[$time] "
timeFmtStdout :: IsString s => Bool -> s
timeFmtStdout = bool "" 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 -> String
stdoutFmt pr isShowTime isShowTid = mconcat
[colorizer pr $ "[$loggername:$prio" ++ tid ++ "] ", timeFmtStdout isShowTime, "$msg"]
where
tid = if isShowTid then ":$tid" else ""
stdoutFormatter :: Bool -> Bool -> LogFormatter a
stdoutFormatter isShowTime isShowTid handle r@(pr, _) =
simpleLogFormatter (stdoutFmt pr isShowTime isShowTid) handle r
stdoutFormatterTimeRounded :: Int -> LogFormatter a
stdoutFormatterTimeRounded roundN a r@(pr,_) s = do
t <- getRoundedTime roundN
simpleLogFormatter (fmt t) a r s
where
fmt time = mconcat $
[ colorizer pr "[$loggername:$prio:$tid]"
, " ["
, 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 =
colorizerT severity prefix <> " " <> msg
where
prefix = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"]") lname severity time
utcTimeF :: Format r (UTCTime -> r)
utcTimeF = shown