module System.Wlog.Formatter
( stdoutFormatter
, stderrFormatter
, stdoutFormatterTimeRounded
, centiUtcTimeF
, getRoundedTime
, LogFormatter
, nullFormatter
, simpleLogFormatter
, tfLogFormatter
, varFormatter
) where
import Universum
import Control.Concurrent (myThreadId)
import Data.Monoid (mconcat)
import qualified Data.Text as T
import Data.Text.Lazy.Builder as B
import Data.Time (formatTime, getCurrentTime, getZonedTime)
import Data.Time.Clock (UTCTime (..))
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 (..), 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
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 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
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
stderrFormatter :: (UTCTime -> Text) -> Bool -> LogFormatter a
stderrFormatter timeF isShowTid handle (LR _ x) message = do
time <- getCurrentTime
createLogFormatter True isShowTid timeF time handle (LR Error x) message
stdoutFormatterTimeRounded :: (UTCTime -> Text) -> Int -> LogFormatter a
stdoutFormatterTimeRounded timeF roundN handle record message = do
time <- getRoundedTime roundN
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