module B9.B9Logging
( Logger (..),
CommandIO,
LoggerReader,
withLogger,
b9Log,
traceL,
dbgL,
infoL,
errorL,
errorExitL,
printHash,
)
where
import B9.B9Config
import B9.B9Error
import Control.Eff
import Control.Eff.Reader.Lazy
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
( MonadBaseControl,
liftBaseWith,
restoreM,
)
import Data.Hashable
import Data.Maybe
import Data.Time.Clock
import Data.Time.Format
import qualified System.IO as SysIO
import Text.Printf
newtype Logger
= MkLogger
{ logFileHandle :: Maybe SysIO.Handle
}
type LoggerReader = Reader Logger
withLogger ::
(MonadBaseControl IO (Eff e), MonadIO (Eff e), Member B9ConfigReader e) =>
Eff (LoggerReader ': e) a ->
Eff e a
withLogger action = do
lf <- _logFile <$> getB9Config
effState <- liftBaseWith $ \runInIO ->
let fInIO = runInIO . flip runReader action . MkLogger
in maybe
(fInIO Nothing)
(\logf -> SysIO.withFile logf SysIO.AppendMode (fInIO . Just))
lf
restoreM effState
type CommandIO e =
( MonadBaseControl IO (Eff e),
MonadIO (Eff e),
Member LoggerReader e,
Member B9ConfigReader e
)
traceL :: CommandIO e => String -> Eff e ()
traceL = b9Log LogTrace
dbgL :: CommandIO e => String -> Eff e ()
dbgL = b9Log LogDebug
infoL :: CommandIO e => String -> Eff e ()
infoL = b9Log LogInfo
errorL :: CommandIO e => String -> Eff e ()
errorL = b9Log LogError
errorExitL :: (CommandIO e, Member ExcB9 e) => String -> Eff e a
errorExitL e = b9Log LogError e >> throwB9Error e
b9Log :: CommandIO e => LogLevel -> String -> Eff e ()
b9Log level msg = do
lv <- getLogVerbosity
lfh <- logFileHandle <$> ask
liftIO $ logImpl lv lfh level msg
logImpl :: Maybe LogLevel -> Maybe SysIO.Handle -> LogLevel -> String -> IO ()
logImpl minLevel mh level msg = do
lm <- formatLogMsg level msg
when (isJust minLevel && level >= fromJust minLevel) $ do
putStr lm
SysIO.hFlush SysIO.stdout
when (isJust mh) $ do
SysIO.hPutStr (fromJust mh) lm
SysIO.hFlush (fromJust mh)
formatLogMsg :: LogLevel -> String -> IO String
formatLogMsg l msg = do
u <- getCurrentTime
let time = formatTime defaultTimeLocale "%H:%M:%S" u
return $ unlines $ printf "[%s] %s - %s" (printLevel l) time <$> lines msg
printLevel :: LogLevel -> String
printLevel l = case l of
LogNothing -> "NOTHING"
LogError -> " ERROR "
LogInfo -> " INFO "
LogDebug -> " DEBUG "
LogTrace -> " TRACE "
printHash :: Hashable a => a -> String
printHash = printf "%x" . hash