module Yam.Logger(
LogRank(..)
, LoggerConfig(..)
, MonadLogger(..)
, logL
, logLn
, errorLn
, warnLn
, infoLn
, debugLn
, traceLn
, stdoutLogger
, fileLogger
, withLoggerRank
, withLoggerName
) where
import Yam.Import
import qualified Control.Concurrent.Map as M
import Control.Monad.Catch (bracket_)
import Control.Monad.Trans.Reader
import Data.Aeson
import System.Log.FastLogger
data LogRank = TRACE
| DEBUG
| INFO
| WARN
| ERROR
deriving (Show,Eq,Ord)
instance FromJSON LogRank where
parseJSON v = go <$> parseJSON v
where go :: Text -> LogRank
go "trace" = TRACE
go "debug" = DEBUG
go "info" = INFO
go "warn" = WARN
go "error" = ERROR
go _ = INFO
type LoggerCache = M.Map ThreadId Text
type LoggerFunc = Text -> Maybe Text -> LogRank -> LogStr -> IO ()
data LoggerConfig = LoggerConfig
{ logger :: LoggerFunc
, clock :: IO FormattedTime
, rank :: LogRank
, name :: LoggerCache
}
class (MonadIO m) => MonadLogger m where
loggerConfig :: m LoggerConfig
withLoggerConfig :: LoggerConfig -> m a -> m a
instance (MonadIO m) => MonadLogger (ReaderT LoggerConfig m) where
loggerConfig = ask
withLoggerConfig = withReaderT . const
logL :: (MonadLogger m) => forall msg . (ToLogStr msg) => LogRank -> msg -> m ()
logL r msg = do
conf <- loggerConfig
mayName <- fetchName
liftIO $ when (r >= rank conf) $ do
now <- clock conf
logger conf (cs now) (cs <$> mayName) r (toLogStr msg)
fetchName :: MonadLogger m => m (Maybe Text)
fetchName = do
conf <- loggerConfig
liftIO $ do
threadId <- myThreadId
M.lookup threadId $ name conf
setName :: MonadLogger m => Maybe Text -> m ()
setName m = do
conf <- loggerConfig
liftIO $ myThreadId >>= void . go m (name conf)
where go (Just m) cache tid = M.insert tid m cache
go _ cache tid = M.delete tid cache
logLn :: (MonadLogger m) => LogRank -> Text -> m ()
logLn l msg = logL l $ msg <> "\n"
traceLn :: (MonadLogger m) => Text -> m ()
traceLn = logLn TRACE
debugLn :: (MonadLogger m) => Text -> m ()
debugLn = logLn DEBUG
infoLn :: (MonadLogger m) => Text -> m ()
infoLn = logLn INFO
warnLn :: (MonadLogger m) => Text -> m ()
warnLn = logLn WARN
errorLn :: (MonadLogger m) => Text -> m ()
errorLn = logLn ERROR
defaultLoggerConfig :: LoggerFunc -> IO LoggerConfig
defaultLoggerConfig func = do
nm <- M.empty
timeCache <- newTimeCache "%F %X"
return $ LoggerConfig func timeCache DEBUG nm
stdoutLogger :: IO LoggerConfig
stdoutLogger = newStdoutLoggerSet 4096 >>= newLog
fileLogger :: FilePath -> IO LoggerConfig
fileLogger file = newFileLoggerSet 4096 file >>= newLog
newLog :: LoggerSet -> IO LoggerConfig
newLog = defaultLoggerConfig . mkLogger . pushLogStr
where mkLogger :: FastLogger -> LoggerFunc
mkLogger logger time mayName rank msg = do
thread <- myThreadId
let name = time
<> " ["
<> showText thread
<> "] "
<> showText rank
<> " "
<> fromMaybe "" mayName
<> " - "
logger $ toLogStr name <> msg
withLoggerRank :: (MonadLogger m) => LogRank -> m a -> m a
withLoggerRank = withLogger . go
where go rk conf = conf {rank = rk}
withLoggerName :: (MonadLogger m, MonadMask m) => Text -> m a -> m a
withLoggerName nm action = do
mayName <- fetchName
let mayName' = Just $ merge nm mayName
bracket_ (setName mayName') (setName mayName) action
where merge n (Just v) = v <> "." <> n
merge n _ = n
withLogger :: (MonadLogger m) => (LoggerConfig -> LoggerConfig) -> m a -> m a
withLogger modify action = do
conf <- loggerConfig
withLoggerConfig (modify conf) action