{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module EasyLogger.Logger ( LogDestination (..) , LogLevel (..) , initLogger , initLoggerAllPackages , setLoggingDestination , setMinLogLevel , logAll , logPrintAll , logDebug , logPrintDebug , logInfo , logPrintInfo , logWarning , logPrintWarning , logError , logPrintError , pureLogAll , pureLogPrintAll , pureLogDebug , pureLogPrintDebug , pureLogInfo , pureLogPrintInfo , pureLogWarning , pureLogPrintWarning , pureLogError , pureLogPrintError , finalizeAllLoggers , finalizeLogger , flushLoggers ) where import Control.Applicative ((<|>)) import Control.Monad (join, when) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Char8 as S8 import Data.IORef import Data.List (find) import qualified Data.Map.Strict as M import qualified Data.Text as T import Language.Haskell.TH.Syntax as TH import System.IO import System.IO.Unsafe (unsafePerformIO) import EasyLogger.Date import EasyLogger.LogStr import EasyLogger.LoggerSet import EasyLogger.Push import EasyLogger.Util (liftLoc) import Debug.Trace -- | Add a @LoggerSet@ to the known loggers. setLoggerSet :: String -> LoggerSet -> IO () setLoggerSet pkgName set = modifyIORef' loggerSets (M.insert pkgName set) -- | Set of loggers. We have one @LoggerSet@ for each package. loggerSets :: IORef (M.Map String LoggerSet) loggerSets = unsafePerformIO $ newIORef mempty {-# NOINLINE loggerSets #-} -- | Should be used to ensure all logs are completely written before the program exists. Cleans all the file descriptors. You (and also no other library) MUST NOT log after this command as all loggers -- are deinitalized. However, you might initialize the loggers again and before restarting to log. finalizeAllLoggers :: IO () finalizeAllLoggers = do pkgs <- map fst . M.toList <$> readIORef loggerSets mapM_ closeLoggerPkg pkgs -- | Can be used to destroy your own logger (from your package) only. You MUST NOT log after this command. finalizeLogger :: Q Exp finalizeLogger = [| closeLogger $(qLocation >>= liftLoc)|] -- | Flush all loggers of all packages. flushLoggers :: IO () flushLoggers = readIORef loggerSets >>= mapM_ flushLoggerSet -- | Close logger of calling package. closeLogger :: Loc -> IO () closeLogger (Loc _ pkgName _ _ _) = closeLoggerPkg pkgName -- | Close logger of package with provided package name. closeLoggerPkg :: String -> IO () closeLoggerPkg pkgName = do refs <- readIORef loggerSets case M.lookup pkgName refs of Nothing -> return () Just set@(LoggerSet Nothing _ _ _) -> deletePackage pkgName >> rmLoggerSet set Just set@(LoggerSet justFp _ _ _) -> do deletePackage pkgName let nrFD = length $ filter (\(LoggerSet mFp _ _ _) -> mFp == justFp) (M.elems refs) if nrFD <= 1 then rmLoggerSet set else flushLoggerSet set -- | Delete a package from the logger sets and with this disable all logging. Ensure the LoggerSet is deleted in case this is the last FD before calling this function! deletePackage :: String -> IO () deletePackage pkg = modifyIORef' loggerSets (M.delete pkg) -- | Logging destination. See also `setLoggingDestination`. data LogDestination = LogStdErr | LogStdOut | LogFile FilePath -- | Log messages from other packages that use this library too, even if they did not call @initLogger@? type LogFromAllPackages = Bool -- | Initialise the logger. MUST only be called in the executable code (not the exposed library code)! Takes a `Bool` that decides wether to log messages from other packages that use the same library -- and did not initalize the Logger (which should be the case for all of them!). initLoggerAllPackages :: Q Exp initLoggerAllPackages = [| \dest logLevel logAllPkgs -> setMinLogLevel logLevel >> setLoggingDestination (loc_package $(qLocation >>= liftLoc)) dest logAllPkgs |] -- | Initialise the logger. MUST only be called in the executable code (not the exposed library code)! Ignores the other packages logs, if the same packages is used for logging. initLogger :: Q Exp initLogger = [| \dest logLevel -> setMinLogLevel logLevel >> setLoggingDestination (loc_package $(qLocation >>= liftLoc)) dest False |] -- | Set the destination for all consequitive for logging. You should only set this once, at the beginning of the program! The default is `LogStdOut`. setLoggingDestination :: String -> LogDestination -> LogFromAllPackages -> IO () setLoggingDestination pkgName LogStdErr logAllPkgs = newStderrLoggerSet defaultBufSize >>= \ls -> setLoggerSet pkgName ls >> when logAllPkgs (setLoggingDestinationAllPkgs ls defaultLogPkgName LogStdErr) setLoggingDestination pkgName LogStdOut logAllPkgs = newStdoutLoggerSet defaultBufSize >>= \ls -> setLoggerSet pkgName ls >> when logAllPkgs (setLoggingDestinationAllPkgs ls defaultLogPkgName LogStdOut) setLoggingDestination pkgName (LogFile fp) logAllPkgs = do allLs <- M.elems <$> readIORef loggerSets ls <- case find (\(LoggerSet mFp _ _ _) -> mFp == Just fp) allLs of Nothing -> newFileLoggerSet defaultBufSize fp Just lsFile -> newFileLoggerSetSameFile defaultBufSize lsFile setLoggerSet pkgName ls >> when logAllPkgs (setLoggingDestinationAllPkgs ls defaultLogPkgName (LogFile fp)) setLoggingDestinationAllPkgs :: LoggerSet -> String -> LogDestination -> IO () setLoggingDestinationAllPkgs _ pkgName LogStdErr = newStderrLoggerSet defaultBufSize >>= setLoggerSet pkgName setLoggingDestinationAllPkgs _ pkgName LogStdOut = newStdoutLoggerSet defaultBufSize >>= setLoggerSet pkgName setLoggingDestinationAllPkgs ls pkgName LogFile{} = newFileLoggerSetSameFile defaultBufSize ls >>= setLoggerSet pkgName defaultLogPkgName :: String defaultLogPkgName = "__default__" mainLogPkgName :: String mainLogPkgName = "main" -- | The default buffer size (4,096 bytes). defaultBufSize :: BufSize defaultBufSize = 4096 -- | Log Level. Levels are sorted. `All` < `Debug` < `Info` < `Warning` < `Error`. None disables all logging. Default: All data LogLevel = LogNone | LogAll | LogDebug | LogInfo | LogWarning | LogError deriving (Show, Read, Bounded, Enum, Eq, Ord) -- | Log level text. Make sure you call @initLogger@, or logging will be disabled. logLevelText :: LogLevel -> T.Text logLevelText LogNone = mempty logLevelText LogAll = "ALL" logLevelText LogDebug = "DEBUG" logLevelText LogInfo = "INFO " logLevelText LogWarning = "WARN " logLevelText LogError = "ERROR" -- | Generic log function. Use TH version, e.g. `logDebug`. logFun :: (ToLogStr msg) => Loc -> LogLevel -> msg -> IO () logFun _ LogNone _ = return () logFun loc@(Loc _ pkg _ _ _) level msg = do minLevel <- readIORef minLogLevel when (level >= minLevel) $ do now <- join (readIORef cachedTime) readIORef loggerSets >>= \sets -> case getLogger sets of Nothing -- Check the package name of the caller, as otherwise any library logging would halt the process. | M.null sets && pkg == mainLogPkgName -> error "You must call `initLogger` at the start of your application! See the documentation of `EasyLogger.Logger`." Nothing -> return () Just set -> pushLogStr set (defaultLogStr loc now level (toLogStr msg)) where getLogger sets = M.lookup pkg sets <|> M.lookup defaultLogPkgName sets cachedTime :: IORef (IO FormattedTime) cachedTime = unsafePerformIO $ do cache <- newTimeCache simpleTimeFormat' newIORef cache minLogLevel :: IORef LogLevel minLogLevel = unsafePerformIO $ newIORef LogAll {-# NOINLINE minLogLevel #-} -- | Set the least logging level. Levels lower will not be logged. Log Level Order: `Debug` < `Info` < `Warning` < `Error`. `None` disables all logging. Note that the output to stderr using e.g. `logPrintError` will not -- be affected! setMinLogLevel :: LogLevel -> IO () setMinLogLevel = writeIORef minLogLevel ------------------------------ All ------------------------------ -- | Generates a function that takes a 'Text' and logs a 'LevelAll' message. Usage: -- -- > $(logAll) "This is a debug log message" logAll :: Q Exp logAll = [| liftIO . logFun $(qLocation >>= liftLoc) LogAll |] -- | Same as `logAll`, but for pure code. Uses @unsafePerformIO@. -- -- > $(pureLogAll) "This is a debug log message" (3 * 3) pureLogAll :: Q Exp pureLogAll = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogAll txt >> return a) |] -- | Same as `logAll`, but also prints the message on `stdout`. logPrintAll :: Q Exp logPrintAll = [| \txt -> liftIO (hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogAll txt) |] -- | Same as `pureLogAll`, but also prints the message on `stdout`. -- -- > $(pureLogPrintAll) "This is a debug log message" (3 * 3) pureLogPrintAll :: Q Exp pureLogPrintAll = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogAll txt >> return a) |] ------------------------------ Debug ------------------------------ -- | Generates a function that takes a 'Text' and logs a 'LevelDebug' message. Usage: -- -- > $(logDebug) "This is a debug log message" logDebug :: Q Exp logDebug = [| liftIO . logFun $(qLocation >>= liftLoc) LogDebug |] -- | Same as `logDebug`, but for pure code. Uses @unsafePerformIO@ -- -- > $(pureLogDebug) "This is a debug log message" defaultValue pureLogDebug :: Q Exp pureLogDebug = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogDebug txt >> return a) |] -- | Same as `logDebug`, but also prints the message on `stdout`. logPrintDebug :: Q Exp logPrintDebug = [| \txt -> hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogDebug txt |] -- | Same as `pureLogDebug`, but also prints the message on `stdout`. -- -- > $(purePrintLogDebug) "This is a debug log message" defaultValue pureLogPrintDebug :: Q Exp pureLogPrintDebug = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("DEBUG: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogDebug txt >> return a) |] ------------------------------ Info ------------------------------ -- | Generates a function that takes a 'Text' and logs a 'LevelInfo' message. Usage: -- -- > $(logInfo) "This is a info log message" logInfo :: Q Exp logInfo = [| liftIO . logFun $(qLocation >>= liftLoc) LogInfo |] -- | Same as `logInfo`, but for pure code. Uses @unsafePerformIO@. -- -- > $(pureLogInfo) "This is a warning log message" (funcX 10) pureLogInfo :: Q Exp pureLogInfo = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogInfo txt >> return a) |] -- | Same as `logInfo`, but also prints the message on `stdout`. logPrintInfo :: Q Exp logPrintInfo = [| \txt -> liftIO (hPutStrLn stdout ("INFO: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogInfo txt) |] -- | Same as `pureLogInfo`, but also prints the message on `stdout`. -- -- > $(pureLogPrintInfo) "This is a warning log message" (funcX 10) pureLogPrintInfo :: Q Exp pureLogPrintInfo = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("INFO: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogInfo txt >> return a) |] ------------------------------ Warning ------------------------------ -- | Generates a function that takes a 'Text' and logs a 'LevelWarning' message. Usage: -- -- > $(logWarning) "This is a warning log message" logWarning :: Q Exp logWarning = [| liftIO . logFun $(qLocation >>= liftLoc) LogWarning |] -- | Same as `logWarning`, but for pure code. Uses @unsafePerformIO@. -- -- > $(pureLogWarning) "This is a warning log message" "myresult" pureLogWarning :: Q Exp pureLogWarning = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogWarning txt >> return a) |] -- | Same as `logWarning`, but also prints the message on `stdout`. logPrintWarning :: Q Exp logPrintWarning = [| \txt -> liftIO (hPutStrLn stdout ("WARNING: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogWarning txt) |] -- | Same as `pureLogWarning`, but also prints the warning. -- -- > $(pureLogPrintWarning) "This is a error log message" (4 + 4) pureLogPrintWarning :: Q Exp pureLogPrintWarning = [| \txt a -> unsafePerformIO (hPutStrLn stdout ("WARNING: " ++ T.unpack txt) >> hFlush stdout >> logFun $(qLocation >>= liftLoc) LogWarning txt >> return a) |] ------------------------------ Error ------------------------------ -- | Generates a function that takes a 'Text' and logs a 'LevelError' message. Usage: -- -- > $(logError) "This is a error log message" logError :: Q Exp logError = [| liftIO . logFun $(qLocation >>= liftLoc) LogError |] -- | Same as `logError`, but for pure code. Uses @unsafePerformIO@. -- -- > $(pureLogError) "This is a error log message" (4 + 4) pureLogError :: Q Exp pureLogError = [| \txt a -> unsafePerformIO (logFun $(qLocation >>= liftLoc) LogError txt >> return a) |] -- | Same as `logError`, but also prints the message on `stderr`. logPrintError :: Q Exp logPrintError = [| \txt -> liftIO (hPutStrLn stderr ("ERROR: " ++ T.unpack txt) >> hFlush stderr >> logFun $(qLocation >>= liftLoc) LogError txt) |] -- | Same as `pureLogError`, but also prints the message on `stderr`. -- -- > $(pureLogPrintError) "This is a error log message" (4 + 4) pureLogPrintError :: Q Exp pureLogPrintError = [| \txt a -> unsafePerformIO (hPutStrLn stderr ("ERROR: " ++ T.unpack txt) >> hFlush stderr >> logFun $(qLocation >>= liftLoc) LogError txt >> return a) |] ---- Helpers: defaultLogStr :: Loc -> FormattedTime -> LogLevel -> LogStr -> LogStr defaultLogStr loc time level msg = "[" <> toLogStr (logLevelText level) <> ("#" <> toLogStr time) <> "] " <> mkTrailWs msg <> " @(" <> toLogStr (S8.pack fileLocStr) <> ")\n" where mkTrailWs = mkMinLogStrLen defaultMinLogMsgLen fileLocStr = loc_package loc ++ ':' : loc_module loc ++ ' ' : loc_filename loc ++ ':' : line loc ++ ':' : char loc ++ '-' : lineEnd loc ++ ':' : charEnd loc line = show . fst . loc_start char = show . snd . loc_start lineEnd = show . fst . loc_end charEnd = show . snd . loc_end defaultMinLogMsgLen :: Int defaultMinLogMsgLen = 60