module Control.Logger.Simple
( withGlobalLogging, LogConfig(..)
, setLogLevel, LogLevel(..)
, logTrace, logDebug, logInfo, logNote, logWarn, logError
, logFail
, showText, (<>)
)
where
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Data.IORef
import Data.Monoid
import System.IO.Unsafe
import System.Log.FastLogger
import qualified Data.Text as T
import qualified Data.Traversable as T
#if MIN_VERSION_base(4,9,0)
#else
import qualified GHC.SrcLoc as GHC
#endif
import qualified GHC.Stack as GHC
data Loggers
= Loggers
{ l_file :: Maybe (FastLogger, IO ())
, l_stderr :: Maybe (FastLogger, IO ())
, l_timeCache :: IO FormattedTime
}
data LogConfig
= LogConfig
{ lc_file :: Maybe FilePath
, lc_stderr :: Bool
}
data LogLevel
= LogTrace
| LogDebug
| LogInfo
| LogNote
| LogWarn
| LogError
deriving (Eq, Show, Read, Ord)
showText :: Show a => a -> T.Text
showText = T.pack . show
logTrace :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logTrace = doLog LogTrace ?callStack
logDebug :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logDebug = doLog LogDebug ?callStack
logInfo :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logInfo = doLog LogInfo ?callStack
logNote :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logNote = doLog LogNote ?callStack
logWarn :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logWarn = doLog LogWarn ?callStack
logError :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m ()
logError = doLog LogError ?callStack
logFail :: (?callStack :: GHC.CallStack) => MonadIO m => T.Text -> m a
logFail t =
do doLog LogError ?callStack t
fail (T.unpack t)
doLog :: MonadIO m => LogLevel -> GHC.CallStack -> T.Text -> m ()
doLog ll cs txt =
liftIO $
readIORef logLevel >>= \logLim ->
when (ll >= logLim) $
do lgrs <- readIORef loggers
time <- l_timeCache lgrs
let loc =
case GHC.getCallStack cs of
((_, l):_) ->
GHC.srcLocFile l <> ":" <> show (GHC.srcLocStartLine l)
_ -> "unknown"
msg =
"[" <> renderLevel <> " "
<> toLogStr time
<> " "
<> toLogStr loc
<> "] "
<> toLogStr txt
<> "\n"
forM_ (l_stderr lgrs) $ \(writeLog, _) -> writeLog (renderColor <> msg <> resetColor)
forM_ (l_file lgrs) $ \(writeLog, _) -> writeLog msg
where
renderLevel =
case ll of
LogTrace -> "TRACE"
LogDebug -> "DEBUG"
LogInfo -> "INFO"
LogNote -> "NOTE"
LogWarn -> "WARN"
LogError -> "ERROR"
resetColor =
"\o33[0;0m"
renderColor =
case ll of
LogTrace -> "\o33[0;30m"
LogDebug -> "\o33[0;34m"
LogInfo -> "\o33[0;34m"
LogNote -> "\o33[1;32m"
LogWarn -> "\o33[0;33m"
LogError -> "\o33[1;31m"
loggers :: IORef Loggers
loggers =
unsafePerformIO $
do tc <- newTimeCache timeFormat
newIORef (Loggers Nothing Nothing tc)
logLevel :: IORef LogLevel
logLevel = unsafePerformIO $ newIORef LogDebug
setLogLevel :: LogLevel -> IO ()
setLogLevel = atomicWriteIORef logLevel
withGlobalLogging :: LogConfig -> IO a -> IO a
withGlobalLogging lc f =
bracket initLogger flushLogger (const f)
where
flushLogger (Loggers a b _) =
do forM_ a $ \(_, flush) -> flush
forM_ b $ \(_, flush) -> flush
initLogger =
do fileLogger <-
flip T.mapM (lc_file lc) $ \fp ->
do let spec =
FileLogSpec
{ log_file = fp
, log_file_size = 1024 * 1024 * 50
, log_backup_number = 5
}
newFastLogger (LogFile spec defaultBufSize)
stderrLogger <-
if lc_stderr lc
then Just <$> newFastLogger (LogStderr defaultBufSize)
else pure Nothing
tc <- newTimeCache timeFormat
let lgrs = Loggers fileLogger stderrLogger tc
writeIORef loggers lgrs
pure lgrs
timeFormat :: TimeFormat
timeFormat = "%Y-%m-%d %T %z"