139 lines
4.0 KiB
Haskell
139 lines
4.0 KiB
Haskell
{-# LANGUAGE BangPatterns #-}
|
|
module Yesod.Logger
|
|
( Logger
|
|
, handle
|
|
, developmentLogger, productionLogger
|
|
, defaultDevelopmentLogger, defaultProductionLogger
|
|
, toProduction
|
|
, flushLogger
|
|
, logText
|
|
, logLazyText
|
|
, logString
|
|
, logBS
|
|
, logMsg
|
|
, formatLogText
|
|
, timed
|
|
-- * Deprecated
|
|
, makeLoggerWithHandle
|
|
, makeDefaultLogger
|
|
) 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)
|
|
|
|
-- for timed logging
|
|
import Data.Time (getCurrentTime, diffUTCTime)
|
|
import Control.Monad.IO.Class (MonadIO, liftIO)
|
|
import Text.Printf (printf)
|
|
import Data.Text (unpack)
|
|
|
|
-- for formatter
|
|
import Language.Haskell.TH.Syntax (Loc)
|
|
import Yesod.Core (LogLevel, fileLocationToString)
|
|
|
|
data Logger = Logger {
|
|
loggerLogFun :: [LogStr] -> IO ()
|
|
, loggerHandle :: Handle
|
|
, loggerDateRef :: DateRef
|
|
}
|
|
|
|
handle :: Logger -> Handle
|
|
handle = loggerHandle
|
|
|
|
flushLogger :: Logger -> IO ()
|
|
flushLogger = hFlush . loggerHandle
|
|
|
|
makeDefaultLogger :: IO Logger
|
|
makeDefaultLogger = defaultDevelopmentLogger
|
|
{-# DEPRECATED makeDefaultLogger "Use defaultProductionLogger or defaultDevelopmentLogger instead" #-}
|
|
|
|
makeLoggerWithHandle, developmentLogger, productionLogger :: Handle -> IO Logger
|
|
makeLoggerWithHandle = productionLogger
|
|
{-# DEPRECATED makeLoggerWithHandle "Use productionLogger or developmentLogger instead" #-}
|
|
|
|
-- | uses stdout handle
|
|
defaultProductionLogger, defaultDevelopmentLogger :: IO Logger
|
|
defaultProductionLogger = productionLogger stdout
|
|
defaultDevelopmentLogger = developmentLogger stdout
|
|
|
|
|
|
productionLogger h = mkLogger h (handleToLogFun h)
|
|
-- | a development logger gets automatically flushed
|
|
developmentLogger h = mkLogger h (\bs -> (handleToLogFun h) bs >> hFlush h)
|
|
|
|
mkLogger :: Handle -> ([LogStr] -> IO ()) -> IO Logger
|
|
mkLogger h logFun = do
|
|
initHandle h
|
|
dateInit >>= return . Logger logFun h
|
|
|
|
-- convert (a development) logger to production settings
|
|
toProduction :: Logger -> Logger
|
|
toProduction (Logger _ h d) = Logger (handleToLogFun h) h d
|
|
|
|
handleToLogFun :: Handle -> ([LogStr] -> IO ())
|
|
handleToLogFun = hPutLogStr
|
|
|
|
logMsg :: Logger -> [LogStr] -> IO ()
|
|
logMsg = hPutLogStr . handle
|
|
|
|
logLazyText :: Logger -> TL.Text -> IO ()
|
|
logLazyText logger msg = loggerLogFun logger $
|
|
map LB (toChunks $ TLE.encodeUtf8 msg) ++ [newLine]
|
|
|
|
logText :: Logger -> Text -> IO ()
|
|
logText logger = logBS logger . encodeUtf8
|
|
|
|
logBS :: Logger -> ByteString -> IO ()
|
|
logBS logger msg = loggerLogFun logger $ [LB msg, newLine]
|
|
|
|
logString :: Logger -> String -> IO ()
|
|
logString logger msg = loggerLogFun 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"
|
|
|
|
-- | Execute a monadic action and log the duration
|
|
--
|
|
timed :: MonadIO m
|
|
=> Logger -- ^ Logger
|
|
-> Text -- ^ Message
|
|
-> m a -- ^ Action
|
|
-> m a -- ^ Timed and logged action
|
|
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
|