module Yesod.Logger
( Logger
, makeLogger
, makeLoggerWithHandle
, makeDefaultLogger
, flushLogger
, timed
, logText
, logLazyText
, logString
, logBS
, logMsg
, formatLogText
) where
import System.IO (Handle, stdout, hFlush)
import Data.ByteString (ByteString)
import Data.ByteString.Char8 (pack)
import Data.ByteString.Lazy (toChunks)
import qualified Data.Text.Lazy as TL
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import qualified Data.Text.Lazy.Encoding as TLE
import System.Log.FastLogger
import Network.Wai.Logger.Date (DateRef, dateInit, getDate)
import Data.Time (getCurrentTime, diffUTCTime)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Text.Printf (printf)
import Data.Text (unpack)
import Language.Haskell.TH.Syntax (Loc)
import Yesod.Core (LogLevel, fileLocationToString)
data Logger = Logger {
loggerHandle :: Handle
, loggerDateRef :: DateRef
}
makeLogger :: IO Logger
makeLogger = makeDefaultLogger
makeLoggerWithHandle :: Handle -> IO Logger
makeLoggerWithHandle handle = dateInit >>= return . Logger handle
makeDefaultLogger :: IO Logger
makeDefaultLogger = makeLoggerWithHandle stdout
flushLogger :: Logger -> IO ()
flushLogger = hFlush . loggerHandle
logMsg :: Logger -> [LogStr] -> IO ()
logMsg = hPutLogStr . loggerHandle
logLazyText :: Logger -> TL.Text -> IO ()
logLazyText logger msg = logMsg logger $
map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine]
logText :: Logger -> Text -> IO ()
logText logger = logBS logger . encodeUtf8
logBS :: Logger -> ByteString -> IO ()
logBS logger msg = logMsg logger [LB msg, newLine]
logString :: Logger -> String -> IO ()
logString logger msg = logMsg logger [LS msg, newLine]
formatLogText :: Logger -> Loc -> LogLevel -> Text -> IO [LogStr]
formatLogText logger loc level msg = formatLogMsg logger loc level (toLB msg)
toLB :: Text -> LogStr
toLB = LB . encodeUtf8
formatLogMsg :: Logger -> Loc -> LogLevel -> LogStr -> IO [LogStr]
formatLogMsg logger loc level msg = do
date <- liftIO $ getDate $ loggerDateRef logger
return
[ LB date
, LB $ pack" ["
, LS (drop 5 $ show level)
, LB $ pack "] "
, msg
, LB $ pack " @("
, LS (fileLocationToString loc)
, LB $ pack ") "
]
newLine :: LogStr
newLine = LB $ pack "\"\n"
timed :: MonadIO m
=> Logger
-> Text
-> m a
-> m a
timed logger msg action = do
start <- liftIO getCurrentTime
!result <- action
stop <- liftIO getCurrentTime
let diff = fromEnum $ diffUTCTime stop start
ms = diff `div` 10 ^ (9 :: Int)
formatted = printf " [%4dms] %s" ms (unpack msg)
liftIO $ logString logger formatted
return result