module Canteven.Log.MonadLog (
LoggerTImpl,
cantevenLogFormat,
getRunCantevenLoggingT,
getCantevenOutput,
runCantevenLoggingDefaultT,
) where
import Canteven.Config (canteven)
import Canteven.Log.Types (LoggingConfig(LoggingConfig, logfile,
level, loggers),
LoggerDetails(LoggerDetails, loggerName, loggerPackage,
loggerModule, loggerLevel),
LogPriority(LP),
defaultLogging)
import Control.Applicative ((<$>))
import Control.Concurrent (ThreadId, myThreadId)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (LogSource,
LogLevel(LevelDebug, LevelInfo, LevelWarn, LevelError, LevelOther),
LoggingT(runLoggingT))
import Data.Char (toUpper)
import Data.List (dropWhileEnd, isPrefixOf, isSuffixOf)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Monoid ((<>), mempty)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Data.Time.LocalTime (ZonedTime, getZonedTime)
import Language.Haskell.TH (Loc(loc_filename, loc_package, loc_module,
loc_start))
import System.Directory (createDirectoryIfMissing)
import System.FilePath (dropFileName)
import System.IO (Handle, IOMode(AppendMode), openFile, stdout, hFlush)
import System.Log.FastLogger (LogStr, fromLogStr, toLogStr)
import System.Log.Logger (Priority(DEBUG, INFO, NOTICE, WARNING, ERROR,
NOTICE, CRITICAL, ALERT, EMERGENCY))
import qualified Data.ByteString.Char8 as S8
import qualified Data.Text as T
type LoggerTImpl = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
runCantevenLoggingT
:: (MonadIO io)
=> LoggingConfig
-> LoggingT io a
-> io a
runCantevenLoggingT config action = do
handle <- liftIO $ setupHandle config
runLoggingT action (cantevenOutput config handle)
getRunCantevenLoggingT
:: (Functor io1, MonadIO io1, MonadIO io2)
=> io1 (LoggingT io2 a -> io2 a)
getRunCantevenLoggingT =
runCantevenLoggingT <$> liftIO canteven
getCantevenOutput
:: (Functor io, MonadIO io)
=> io LoggerTImpl
getCantevenOutput =
uncurry cantevenOutput <$> liftIO setupLogger
where
setupLogger = do
config <- canteven
handle <- setupHandle config
return (config, handle)
runCantevenLoggingDefaultT
:: (MonadIO io)
=> LoggingT io a
-> io a
runCantevenLoggingDefaultT = runCantevenLoggingT defaultLogging
cantevenOutput
:: LoggingConfig
-> Handle
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> IO ()
cantevenOutput config handle loc src level msg =
when (configPermits config loc src level) $ do
time <- getZonedTime
threadId <- myThreadId
S8.hPutStr handle . fromLogStr $ cantevenLogFormat loc src level msg time threadId
hFlush handle
configPermits :: LoggingConfig -> Loc -> LogSource -> LogLevel -> Bool
configPermits LoggingConfig {level=LP defaultLP, loggers} = runFilters
where
predicates = map toPredicate loggers
toPredicate LoggerDetails {loggerName, loggerPackage,
loggerModule, loggerLevel=LP loggerLevel}
loc src level =
if matches (T.pack <$> loggerName) src &&
matches loggerPackage (loc_package loc) &&
matchesGlob loggerModule (loc_module loc)
then Just (toHSLogPriority level >= loggerLevel)
else Nothing
matches Nothing _ = True
matches (Just s1) s2 = s1 == s2
matchesGlob Nothing _ = True
matchesGlob (Just pattern) candidate
| "*" `isSuffixOf` pattern = dropWhileEnd (=='*') pattern `isPrefixOf` candidate
| otherwise = pattern == candidate
runFilters loc src level =
fromMaybe (toHSLogPriority level >= defaultLP) $
listToMaybe $
mapMaybe (\p -> p loc src level) predicates
toHSLogPriority :: LogLevel -> Priority
toHSLogPriority LevelDebug = DEBUG
toHSLogPriority LevelInfo = INFO
toHSLogPriority LevelWarn = WARNING
toHSLogPriority LevelError = ERROR
toHSLogPriority (LevelOther other) =
fromMaybe EMERGENCY $
lookup (T.toLower other) [
("notice", NOTICE),
("critical", CRITICAL),
("alert", ALERT)
]
cantevenLogLevelStr :: LogLevel -> LogStr
cantevenLogLevelStr level = case level of
LevelOther t -> toLogStr $ T.toUpper t
_ -> toLogStr $ S8.pack $ map toUpper $ drop 5 $ show level
cantevenLogFormat
:: Loc
-> LogSource
-> LogLevel
-> LogStr
-> ZonedTime
-> ThreadId
-> LogStr
cantevenLogFormat loc src level msg t tid =
"[" <> toLogStr (fmtTime t) <> "] " <>
cantevenLogLevelStr level <>
" " <>
(if T.null src
then mempty
else toLogStr src) <>
"@" <> toLogStr (loc_package loc ++ ":" ++ loc_module loc) <>
"[" <>
toLogStr (show tid) <> "]: " <>
msg <> " (" <> toLogStr (S8.pack fileLocStr) <> ")\n"
where
fmtTime = formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S.%q %Z"
fileLocStr =
loc_filename loc ++ ':' : line loc ++ ':' : char loc
where
line = show . fst . loc_start
char = show . snd . loc_start
openFileForLogging :: FilePath -> IO Handle
openFileForLogging filename = do
createDirectoryIfMissing True (dropFileName filename)
openFile filename AppendMode
setupHandle :: LoggingConfig -> IO Handle
setupHandle LoggingConfig {logfile} =
maybe (return stdout) openFileForLogging logfile