module Canteven.Log.MonadLog (
LoggerTImpl,
getCantevenOutput,
LoggingConfig(LoggingConfig, level, logfile, loggers),
LoggerDetails(loggerName, loggerPackage, loggerModule, loggerLevel)
) where
import Canteven.Log.Types (LoggingConfig(LoggingConfig, logfile,
level, loggers),
LoggerDetails(LoggerDetails, loggerName, loggerPackage,
loggerModule, loggerLevel))
import Control.Concurrent (ThreadId, myThreadId)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (LogSource, LogLevel(LevelOther))
import Data.Char (toUpper)
import Data.List (dropWhileEnd, isPrefixOf, isSuffixOf)
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Monoid ((<>))
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 qualified Data.ByteString.Char8 as S8
import qualified Data.Text as T
type LoggerTImpl = Loc -> LogSource -> LogLevel -> LogStr -> IO ()
getCantevenOutput
:: (MonadIO io)
=> LoggingConfig
-> io LoggerTImpl
getCantevenOutput config =
uncurry cantevenOutput <$> liftIO setupLogger
where
setupLogger = do
handle <- setupHandle config
return (config, handle)
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=defaultLP, loggers} = runFilters
where
predicates = map toPredicate loggers
toPredicate LoggerDetails {loggerName, loggerPackage,
loggerModule, loggerLevel=loggerLevel}
loc src level =
if matches (T.pack <$> loggerName) src &&
matches loggerPackage (loc_package loc) &&
matchesGlob loggerModule (loc_module loc)
then Just (level >= loggerLevel)
else Nothing
matches Nothing _ = True
matches (Just s1) s2 = s1 == s2
matchesGlob Nothing _ = True
matchesGlob (Just p) candidate
| "*" `isSuffixOf` p = dropWhileEnd (=='*') p `isPrefixOf` candidate
| otherwise = p == candidate
runFilters loc src level =
fromMaybe (level >= defaultLP) $
listToMaybe $
mapMaybe (\p -> p loc src level) predicates
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