module Boots.Factory.Logger(
HasLogger(..)
, LogConfig(..)
, LogFunc
, traceVault
, addTrace
, buildLogger
, MonadLogger(..)
, MonadLoggerIO(..)
, runLoggingT
, logInfo
, logDebug
, logError
, logWarn
, logOther
, LogLevel(..)
) where
import Boots.App.Internal
import Boots.Factory
import Boots.Factory.Salak
import Boots.Factory.Vault
import Control.Monad
import Control.Monad.Logger.CallStack
import Data.Default
import Data.Text (Text, toLower, unpack)
import qualified Data.Vault.Lazy as L
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 env) => MonadLogger (AppT env m) where
monadLoggerLog a b c d = do
LogFunc{..} <- asks (view askLogger)
liftIO $ logfunc a b c (toLogStr d)
instance (MonadIO m, HasLogger env) => MonadLoggerIO (Factory m env) where
askLoggerIO = logfunc <$> asks (view askLogger)
instance (MonadIO m, HasLogger env) => MonadLoggerIO (AppT env m) where
askLoggerIO = logfunc <$> asks (view askLogger)
instance 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
, logKey :: L.Key Text
}
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,logend) <- newTimedFastLogger tc ft
logLvl <- toWritable level
logKey <- L.newKey
let logfunc = toLogger logLvl ln l
return (LogFunc{..})
where
toLogger logLvl ln f Loc{..} _ ll s = do
lc <- getWritable logLvl
when (lc <= ll) $ f $ \t ->
let locate = if ll /= LevelError then "" else " @" <> toLogStr loc_filename <> toLogStr (show loc_start)
in toLogStr t <> " " <> toStr ll <> ln <> toLogStr loc_module <> locate <> " - " <> s <> "\n"
traceVault :: L.Vault -> LogFunc -> LogFunc
traceVault v LogFunc{..} = LogFunc { logfunc = \a b c d -> logfunc a b c (go d), .. }
where
go :: LogStr -> LogStr
go d = maybe d (\p -> "[" <> toLogStr p <> "] " <> d) $ L.lookup logKey v
addTrace :: Maybe Text -> LogFunc -> L.Vault -> L.Vault
addTrace (Just msg) LogFunc{..} v =
let mt = L.lookup logKey v
in case mt of
Just m -> L.insert logKey (m <> "," <> msg) v
_ -> L.insert logKey msg v
addTrace _ _ v = v
buildLogger
:: (MonadIO m, MonadCatch m, HasSalak env, HasLogger cxt)
=> VaultRef cxt -> Text -> Factory m env LogFunc
buildLogger vf name = do
lc <- require "logging"
modifyVaultRef (over askLogger . traceVault) vf
bracket (liftIO $ newLogger name lc) (\LogFunc{..} -> liftIO logend)