module Boots.Factory.Logger(
HasLogger(..)
, LogConfig(..)
, LogFunc
, addTrace
, buildLogger
, MonadLogger(..)
) where
import Boots.App.Internal
import Boots.Factory
import Boots.Factory.Salak
import Control.Monad
import Control.Monad.Logger.CallStack
import Data.Default
import Data.Text (Text, toLower, unpack)
import Data.Word
import Lens.Micro
import Lens.Micro.Extras
import Salak
import System.Log.FastLogger
class HasLogger env where
askLogger :: Lens' env LogFunc
askLogLevel :: Lens' env (Writable LogLevel)
askLogLevel = askLogger . lens logLvl (\x y -> x { logLvl = y })
instance HasLogger LogFunc where
askLogger = id
instance (MonadIO m, HasLogger env) => MonadLogger (Factory m env) where
monadLoggerLog a b c d = do
LogFunc{..} <- asks (view askLogger)
liftIO $ logfunc a b c (toLogStr d)
instance (MonadIO m, HasLogger cxt) => MonadLogger (AppT cxt m) where
monadLoggerLog a b c d = do
LogFunc{..} <- asks (view askLogger)
liftIO $ logfunc a b c (toLogStr d)
instance (MonadIO m, HasLogger cxt) => MonadLoggerIO (Factory m cxt) where
askLoggerIO = logfunc <$> asks (view askLogger)
instance (MonadIO m, HasLogger cxt) => MonadLoggerIO (AppT cxt m) where
askLoggerIO = logfunc <$> asks (view askLogger)
instance Monad m => FromProp m LogLevel where
fromProp = readEnum (fromEnumProp.toLower)
where
fromEnumProp "debug" = Right LevelDebug
fromEnumProp "info" = Right LevelInfo
fromEnumProp "warn" = Right LevelWarn
fromEnumProp "error" = Right LevelError
fromEnumProp u = Left $ "unknown level: " ++ unpack u
{-# INLINE toStr #-}
toStr :: LogLevel -> LogStr
toStr LevelDebug = "DEBUG"
toStr LevelInfo = " INFO"
toStr LevelWarn = " WARN"
toStr LevelError = "ERROR"
toStr (LevelOther l) = toLogStr l
data LogConfig = LogConfig
{ bufferSize :: !Word16
, file :: !(Maybe FilePath)
, maxSize :: !Word32
, rotateHistory :: !Word16
, level :: !(IO LogLevel)
}
instance Default LogConfig where
def = LogConfig 4096 Nothing 10485760 256 (return LevelInfo)
instance MonadIO m => FromProp m LogConfig where
fromProp = LogConfig
<$> "buffer-size" .?: bufferSize
<*> "file" .?: file
<*> "max-size" .?: maxSize
<*> "max-history" .?: rotateHistory
<*> "level" .?: level
data LogFunc = LogFunc
{ logfunc :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
, logend :: IO ()
, logLvl :: Writable LogLevel
}
newLogger :: Text -> LogConfig -> IO LogFunc
newLogger name LogConfig{..} = do
tc <- newTimeCache "%Y-%m-%d %T"
let ln = " [" <> toLogStr name <> "] "
ft = case file of
Just f -> LogFile (FileLogSpec f (toInteger maxSize) (fromIntegral rotateHistory)) $ fromIntegral bufferSize
_ -> LogStdout $ fromIntegral bufferSize
(l,close) <- newTimedFastLogger tc ft
lvl <- toWritable level
return (LogFunc (toLogger lvl ln l) close lvl)
where
toLogger lvl xn f Loc{..} _ ll s = do
lc <- getWritable lvl
when (lc <= ll) $ f $ \t ->
let locate = if ll /= LevelError then "" else " @" <> toLogStr loc_filename <> toLogStr (show loc_start)
in toLogStr t <> " " <> toStr ll <> xn <> toLogStr loc_module <> locate <> " - " <> s <> "\n"
addTrace :: Text -> LogFunc -> LogFunc
addTrace trace lf = lf { logfunc = \a b c d -> let p = "[" <> toLogStr trace <> "] " in logfunc lf a b c (p <> d) }
buildLogger
:: (MonadIO m, MonadCatch m, HasSalak env)
=> Text -> Factory m env LogFunc
buildLogger name = do
lc <- require "logging"
bracket (liftIO $ newLogger name lc) (\LogFunc{..} -> liftIO logend)