{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}
module System.Wlog.Formatter
( stdoutFormatter
, stdoutFormatterTimeRounded
, centiUtcTimeF
, getRoundedTime
, LogFormatter
, nullFormatter
, simpleLogFormatter
, tfLogFormatter
, varFormatter
) where
import Universum
import Control.Concurrent (myThreadId)
import Data.Text.Lazy.Builder as B
import Data.Time (formatTime, getCurrentTime, getZonedTime)
import Data.Time.Clock (UTCTime (..), diffTimeToPicoseconds, picosecondsToDiffTime)
import Data.Time.Format (FormatTime)
import Fmt (fmt, padRightF, (+|), (|+), (|++|))
import Fmt.Time (dateDashF, hmsF, subsecondF, tzNameF)
#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.Severity (LogRecord (..))
import qualified Data.Text as T
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 = tfLogFormatter "%F %X %Z"
centiUtcTimeF :: UTCTime -> Text
centiUtcTimeF t =
dateDashF t |+ " "
+| hmsF t |++|
centiSecondF t |+ " "
+| tzNameF t |+ ""
where
centiSecondF = padRightF 3 '0' . T.take 3 . fmt . subsecondF
getRoundedTime :: Int -> IO UTCTime
getRoundedTime n = do
UTCTime{..} <- getCurrentTime
let m = if n < 0 then 0 else (fromIntegral n :: Integer)
multiplier = 10 ^ m
picoseconds = diffTimeToPicoseconds utctDayTime
roundedPicoseconds = (picoseconds `div` multiplier) * multiplier
pure UTCTime { utctDayTime = picosecondsToDiffTime roundedPicoseconds, .. }
stdoutFormatter :: (UTCTime -> Text) -> Bool -> Bool -> LogFormatter a
stdoutFormatter timeF isShowTime isShowTid handle record message = do
time <- getCurrentTime
createLogFormatter isShowTime isShowTid timeF time handle record message
stdoutFormatterTimeRounded :: (UTCTime -> Text) -> Int -> LogFormatter a
stdoutFormatterTimeRounded timeF n handle record message = do
time <- getRoundedTime n
createLogFormatter True True timeF time handle record message
createLogFormatter
:: Bool
-> Bool
-> (UTCTime -> Text)
-> UTCTime
-> LogFormatter a
createLogFormatter
isShowTime
isShowTid
timeF
time
handle
record@(LR priority _)
=
simpleLogFormatter format handle record
where
format = mconcat
[ colorizer priority $ "[$loggername:$prio" <> tidShower <> "] "
, timeShower
, "$msg"
]
timeShower, tidShower :: Text
timeShower = if isShowTime then "[" <> timeF time <> "] " else mempty
tidShower = if isShowTid then ":$tid" else mempty