diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,19 @@ +1.6.0 +===== + +* `Error` is now printed only to `stderr`, all other messages to `stdout`. +* `Logger` severity is now `Set Severity`. +* Interface changes: functions which worked with `Severity` now work with `Set Severity`. +* Remove `releaseAllHandlers`, `streamHandlerWithLock`, + `trapLogging`, `debugM`, `errorM`, `infoM`, `noticeM`, `warningM`. +* Rename `Wrapper` module to `Terminal`. +* Rename `Handler` module to `LogHandler`. +* Rename `Logger` module to `IOLogger`. +* Move `setSeverity` and `setSeverityMaybe` to `IOLogger`. +* Lift all functions inside `IOLogger` module to `MonadIO`. +* `handle` from `LogHandler` module is renamed to `logHandlerMessage` + and moved out of type class `LogHandler`. + 1.5.3 ===== diff --git a/examples/Playground.hs b/examples/Playground.hs --- a/examples/Playground.hs +++ b/examples/Playground.hs @@ -2,16 +2,15 @@ module Main where -import Universum +import Universum -import Data.Monoid ((<>)) -import Data.Yaml.Pretty (defConfig, encodePretty) +import Data.Monoid ((<>)) +import Data.Yaml.Pretty (defConfig, encodePretty) -import System.Wlog (CanLog, Severity (Debug), buildAndSetupYamlLogging, - dispatchEvents, logDebug, logError, logInfo, logNotice, - logWarning, modifyLoggerName, parseLoggerConfig, - prefixB, productionB, releaseAllHandlers, runPureLog, - termSeverityB, usingLoggerName) +import System.Wlog (CanLog, Severity (Debug), buildAndSetupYamlLogging, dispatchEvents, logDebug, + logError, logInfo, logNotice, logWarning, modifyLoggerName, parseLoggerConfig, + prefixB, productionB, removeAllHandlers, runPureLog, termSeverityB, + usingLoggerName) testLoggerConfigPath :: FilePath testLoggerConfigPath = "logger-config-example.yaml" @@ -49,5 +48,5 @@ let config = (productionB <> prefixB "logs" <> termSeverityB Debug) bracket_ (buildAndSetupYamlLogging config testLoggerConfigPath) - releaseAllHandlers + removeAllHandlers (testLogging >> showPureLog) diff --git a/log-warper.cabal b/log-warper.cabal --- a/log-warper.cabal +++ b/log-warper.cabal @@ -1,5 +1,5 @@ name: log-warper -version: 1.5.3 +version: 1.6.0 synopsis: Flexible, configurable, monadic and pretty logging homepage: https://github.com/serokell/log-warper license: MIT @@ -20,19 +20,19 @@ System.Wlog.CanLog System.Wlog.FileUtils System.Wlog.Formatter - System.Wlog.Handler - System.Wlog.Handler.Roller - System.Wlog.Handler.Simple - System.Wlog.Handler.Syslog System.Wlog.HasLoggerName + System.Wlog.IOLogger System.Wlog.Launcher - System.Wlog.Logger System.Wlog.LoggerConfig System.Wlog.LoggerName System.Wlog.LoggerNameBox + System.Wlog.LogHandler + System.Wlog.LogHandler.Roller + System.Wlog.LogHandler.Simple + System.Wlog.LogHandler.Syslog System.Wlog.PureLogging System.Wlog.Severity - System.Wlog.Wrapper + System.Wlog.Terminal other-modules: System.Wlog.Color System.Wlog.MemoryQueue diff --git a/src/System/Wlog.hs b/src/System/Wlog.hs --- a/src/System/Wlog.hs +++ b/src/System/Wlog.hs @@ -14,31 +14,31 @@ module System.Wlog ( module System.Wlog.CanLog , module System.Wlog.FileUtils - , module System.Wlog.Handler.Roller - , module System.Wlog.Handler.Simple - , module System.Wlog.Handler.Syslog , module System.Wlog.HasLoggerName + , module System.Wlog.IOLogger , module System.Wlog.Launcher - , module System.Wlog.Logger , module System.Wlog.LoggerConfig , module System.Wlog.LoggerName , module System.Wlog.LoggerNameBox + , module System.Wlog.LogHandler.Roller + , module System.Wlog.LogHandler.Simple + , module System.Wlog.LogHandler.Syslog , module System.Wlog.PureLogging , module System.Wlog.Severity - , module System.Wlog.Wrapper + , module System.Wlog.Terminal ) where import System.Wlog.CanLog import System.Wlog.FileUtils -import System.Wlog.Handler.Roller -import System.Wlog.Handler.Simple -import System.Wlog.Handler.Syslog import System.Wlog.HasLoggerName +import System.Wlog.IOLogger import System.Wlog.Launcher -import System.Wlog.Logger import System.Wlog.LoggerConfig import System.Wlog.LoggerName import System.Wlog.LoggerNameBox +import System.Wlog.LogHandler.Roller +import System.Wlog.LogHandler.Simple +import System.Wlog.LogHandler.Syslog import System.Wlog.PureLogging import System.Wlog.Severity -import System.Wlog.Wrapper +import System.Wlog.Terminal diff --git a/src/System/Wlog/CanLog.hs b/src/System/Wlog/CanLog.hs --- a/src/System/Wlog/CanLog.hs +++ b/src/System/Wlog/CanLog.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} @@ -22,21 +21,22 @@ , logMessage ) where -import Universum +import Universum -import Control.Monad.Except (ExceptT) -import qualified Control.Monad.RWS as RWSLazy -import qualified Control.Monad.RWS.Strict as RWSStrict -import qualified Control.Monad.State.Lazy as StateLazy -import Control.Monad.Trans (MonadTrans (lift)) +import Control.Monad.Except (ExceptT) +import Control.Monad.Trans (MonadTrans (lift)) -import System.Wlog.HasLoggerName (HasLoggerName (..)) -import System.Wlog.Logger (logM) -import System.Wlog.LoggerName (LoggerName (..)) -import System.Wlog.LoggerNameBox (LoggerNameBox (..)) -import System.Wlog.Severity (Severity (..)) +import System.Wlog.HasLoggerName (HasLoggerName (..)) +import System.Wlog.IOLogger (logM) +import System.Wlog.LoggerName (LoggerName (..)) +import System.Wlog.LoggerNameBox (LoggerNameBox (..)) +import System.Wlog.Severity (Severity (..)) +import qualified Control.Monad.RWS as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import qualified Control.Monad.State.Lazy as StateLazy + -- | Type alias for constraints 'CanLog' and 'HasLoggerName'. -- We need two different type classes to support more flexible interface -- but in practice we usually use them both. @@ -56,7 +56,7 @@ dispatchMessage name sev t = lift $ dispatchMessage name sev t instance CanLog IO where - dispatchMessage name prior msg = logM name prior msg + dispatchMessage = logM instance CanLog m => CanLog (LoggerNameBox m) instance CanLog m => CanLog (ReaderT r m) diff --git a/src/System/Wlog/FileUtils.hs b/src/System/Wlog/FileUtils.hs --- a/src/System/Wlog/FileUtils.hs +++ b/src/System/Wlog/FileUtils.hs @@ -1,14 +1,12 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -- | Some helpers and utilites to work with files module System.Wlog.FileUtils ( whenExist ) where -import Universum +import Universum -import System.Directory (doesFileExist) +import System.Directory (doesFileExist) -- | Performs given action on file if file exists. whenExist :: MonadIO m => FilePath -> (FilePath -> m ()) -> m () diff --git a/src/System/Wlog/Formatter.hs b/src/System/Wlog/Formatter.hs --- a/src/System/Wlog/Formatter.hs +++ b/src/System/Wlog/Formatter.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : System.Wlog.Formatter @@ -29,29 +28,30 @@ , varFormatter ) where -import Universum +import Universum -import Control.Concurrent (myThreadId) -import Data.Monoid (mconcat) -import qualified Data.Text as T -import Data.Text.Lazy.Builder as B -import Data.Time (formatTime, getCurrentTime, getZonedTime) -import Data.Time.Clock (UTCTime (..)) -import Data.Time.Format (FormatTime) -import Fmt (fmt, padRightF, (+|), (|+), (|++|)) -import Fmt.Time (dateDashF, hmsF, subsecondF, tzNameF) +import Control.Concurrent (myThreadId) +import Data.Monoid (mconcat) +import Data.Text.Lazy.Builder as B +import Data.Time (formatTime, getCurrentTime, getZonedTime) +import Data.Time.Clock (UTCTime (..)) +import Data.Time.Format (FormatTime) +import Fmt (fmt, padRightF, (+|), (|+), (|++|)) +import Fmt.Time (dateDashF, hmsF, subsecondF, tzNameF) #ifndef mingw32_HOST_OS -import System.Posix.Process (getProcessID) +import System.Posix.Process (getProcessID) #endif #if MIN_VERSION_time(1,5,0) -import Data.Time.Format (defaultTimeLocale) +import Data.Time.Format (defaultTimeLocale) #else -import System.Locale (defaultTimeLocale) +import System.Locale (defaultTimeLocale) #endif -import System.Wlog.Color (colorizer) -import System.Wlog.Severity (LogRecord (..), Severity (..)) +import System.Wlog.Color (colorizer) +import System.Wlog.Severity (LogRecord (..), Severity (..)) + +import qualified Data.Text as T ---------------------------------------------------------------------------- -- Basic formatting functionality (initially taken from hslogger) diff --git a/src/System/Wlog/Handler.hs b/src/System/Wlog/Handler.hs deleted file mode 100644 --- a/src/System/Wlog/Handler.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} - -{- | - Module : System.Log.Handler - Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -Definition of log handler support - -For some handlers, check out "System.WLog.Handler.Simple" and -"System.WLog.Handler.Syslog". - -Please see "System.WLog.Logger" for extensive documentation on the -logging system. - -Written by John Goerzen, jgoerzen\@complete.org --} -module System.Wlog.Handler - ( -- * Basic Types - LogHandlerTag(..) - , LogHandler(..) - ) where - -import Universum - -import Data.Text.Lazy.Builder as B - -import System.Wlog.Formatter (LogFormatter, nullFormatter) -import System.Wlog.LoggerName (LoggerName (..)) -import System.Wlog.Severity (LogRecord (..), Severity) - --- | Tag identifying handlers. -data LogHandlerTag - = HandlerFilelike FilePath - | HandlerOther String - deriving (Show, Eq) - --- | This is the base class for the various log handlers. They should --- all adhere to this class. -class LogHandler a where - -- TODO it should be data/type family like in 'System.Exception' - -- | Tag of handler. Is arbitrary. Made for identification. - getTag :: a -> LogHandlerTag - - -- | Sets the log level. 'handle' will drop items beneath this - -- level. - setLevel :: a -> Severity -> a - - -- | Gets the current level. - getLevel :: a -> Severity - - -- | Set a log formatter to customize the log format for this Handler - setFormatter :: a -> LogFormatter a -> a - getFormatter :: a -> LogFormatter a - getFormatter _h = nullFormatter - - -- | Logs an event if it meets the requirements - -- given by the most recent call to 'setLevel'. - handle :: a -> LogRecord -> LoggerName -> IO () - handle h lr@(LR pri _) logname = - when (pri >= (getLevel h)) $ do - let lName = getLoggerName logname - formattedMsg <- (getFormatter h) h lr lName - emit h formattedMsg lName - - -- | Forces an event to be logged regardless of - -- the configured level. - emit :: a -> B.Builder -> Text -> IO () - - -- | Read back from logger (e.g. file), newest first. You specify - -- the number of (newest) logging entries. Logger can return @pure - -- []@ if this behaviour can't be emulated or store buffer. - readBack :: a -> Int -> IO [Text] - - -- | Closes the logging system, causing it to close - -- any open files, etc. - close :: a -> IO () diff --git a/src/System/Wlog/Handler/Roller.hs b/src/System/Wlog/Handler/Roller.hs deleted file mode 100644 --- a/src/System/Wlog/Handler/Roller.hs +++ /dev/null @@ -1,120 +0,0 @@ --- | Custom implementation of 'LogHandler' with log rotation support. - -module System.Wlog.Handler.Roller - ( InvalidRotation (..) - , RollerHandler (..) - , logIndex - , rotationFileHandler - ) where - -import Control.Concurrent (modifyMVar, modifyMVar_, withMVar) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import Data.Text.Lazy.Builder as B -import Formatting (sformat, shown, (%)) -import Universum - -import System.Directory (removeFile, renameFile) -import System.FilePath ((<.>)) -import System.IO (Handle, IOMode (ReadWriteMode), - SeekMode (AbsoluteSeek, SeekFromEnd), hClose, - hFileSize, hFlush, hSeek) -import System.Wlog.FileUtils (whenExist) -import System.Wlog.Formatter (LogFormatter, nullFormatter) -import System.Wlog.Handler (LogHandler (..), - LogHandlerTag (HandlerFilelike)) -import System.Wlog.Handler.Simple (GenericHandler (..), fileHandler) -import System.Wlog.LoggerConfig (RotationParameters (..), isValidRotation) -import System.Wlog.Severity (Severity (..)) - --- | Similar to 'GenericHandler'. But holds file 'Handle' inside --- mutable variable ('MVar') to be able to rotate loggers. -data RollerHandler = RollerHandler - { rhSeverity :: !Severity - , rhFormatter :: !(LogFormatter RollerHandler) - , rhFileHandle :: !(MVar Handle) - , rhWriteAction :: !(Handle -> Text -> IO ()) - , rhCloseAction :: !(Handle -> IO ()) - , rhFileName :: !FilePath - } - -instance LogHandler RollerHandler where - getTag rh = HandlerFilelike $ rhFileName rh - setLevel rh p = rh { rhSeverity = p } - setFormatter rh f = rh { rhFormatter = f } - getLevel = rhSeverity - getFormatter = rhFormatter - readBack = rollerReadback - - emit rh bldr _ = rhWriteAction rh (error "Handler is used internally") (toText . B.toLazyText $ bldr) - close RollerHandler{..} = withMVar rhFileHandle rhCloseAction - -data InvalidRotation = InvalidRotation !Text - deriving (Show, Eq) - -instance Exception InvalidRotation - -logIndex :: FilePath -> Int -> FilePath -logIndex handlerPath i = handlerPath <.> show i - -rollerReadback :: RollerHandler -> Int -> IO [Text] -rollerReadback RollerHandler{..} logsNum = do - modifyMVar rhFileHandle $ \h -> do - hFlush h - hSeek h AbsoluteSeek 0 - contents <- T.lines <$> TIO.hGetContents h - hClose h - h' <- openFile rhFileName ReadWriteMode - hSeek h' SeekFromEnd 0 - pure (h', take logsNum $ reverse contents) - --- TODO: correct exceptions handling here is too smart for me -rollerWriting - :: RotationParameters - -> FilePath - -> (Handle -> Text -> IO ()) - -> MVar Handle - -> Handle - -> Text - -> IO () -rollerWriting RotationParameters{..} handlerPath loggingAction varHandle _ msg = - modifyMVar_ varHandle $ \landle -> do - loggingAction landle msg - logFileSize <- fromIntegral <$> hFileSize landle - if logFileSize < rpLogLimit - then return landle - -- otherwise should rename all files and create new handle putting in MVar - else do - hClose landle - let lastIndex = fromIntegral $ rpKeepFiles - 1 - for_ [lastIndex - 1,lastIndex - 2 .. 0] $ \i -> do - let oldLogFile = logIndex handlerPath i - let newLogFile = logIndex handlerPath (i + 1) - whenExist oldLogFile $ (`renameFile` newLogFile) - let zeroIndex = logIndex handlerPath 0 - renameFile handlerPath zeroIndex - let lastLogFile = logIndex handlerPath lastIndex - whenExist lastLogFile removeFile - h <- openFile handlerPath ReadWriteMode - hSeek h SeekFromEnd 0 - pure h - --- | Create rotation logging handler. -rotationFileHandler - :: MonadIO m - => RotationParameters - -> FilePath - -> Severity - -> m RollerHandler -rotationFileHandler rp@RotationParameters{..} _ _ - | not $ isValidRotation rp = liftIO $ throwM $ InvalidRotation $ - sformat ("Rotation parameters must be positive: "%shown) rp -rotationFileHandler rp@RotationParameters{..} handlerPath rhSeverity = liftIO $ do - GenericHandler{..} <- fileHandler handlerPath rhSeverity - rhFileHandle <- newMVar privData - let rhWriteAction = rollerWriting rp handlerPath writeFunc rhFileHandle - pure RollerHandler { rhFormatter = nullFormatter - , rhCloseAction = closeFunc - , rhFileName = handlerPath - , .. - } diff --git a/src/System/Wlog/Handler/Simple.hs b/src/System/Wlog/Handler/Simple.hs deleted file mode 100644 --- a/src/System/Wlog/Handler/Simple.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} - -{- | - Module : System.Log.Handler.Simple - Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -Simple log handlers - -Written by John Goerzen, jgoerzen\@complete.org --} - -module System.Wlog.Handler.Simple - ( GenericHandler(..) - , defaultHandleAction - - -- * Custom handlers - , fileHandler - , streamHandler - ) where - -import Control.Concurrent (modifyMVar_, withMVar) -import Control.Exception (SomeException) -import qualified Data.Text.IO as TIO -import Data.Text.Lazy.Builder as B -import Data.Typeable (Typeable) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (takeDirectory) -import System.IO (Handle, IOMode (ReadWriteMode), - SeekMode (SeekFromEnd), hClose, hFlush, hSeek) -import Universum - -import System.Wlog.Formatter (LogFormatter, nullFormatter) -import System.Wlog.Handler (LogHandler (..), LogHandlerTag (..)) -import System.Wlog.MemoryQueue (MemoryQueue) -import System.Wlog.MemoryQueue as MQ -import System.Wlog.Severity (Severity (..)) - --- | A helper data type. -data GenericHandler a = GenericHandler - { severity :: !Severity - , formatter :: !(LogFormatter (GenericHandler a)) - , privData :: !a - , writeFunc :: !(a -> Text -> IO ()) - , closeFunc :: !(a -> IO ()) - , readBackBuffer :: !(MVar (MemoryQueue Text)) - , ghTag :: !LogHandlerTag - } deriving Typeable - -instance Typeable a => LogHandler (GenericHandler a) where - getTag = ghTag - setLevel sh s = sh {severity = s} - getLevel sh = severity sh - setFormatter sh f = sh{formatter = f} - getFormatter sh = formatter sh - readBack sh i = withMVar (readBackBuffer sh) $ \mq' -> pure $! take i . MQ.toList $ mq' - emit sh bldr _ = (writeFunc sh) (privData sh) (toText . B.toLazyText $ bldr) - close sh = (closeFunc sh) (privData sh) - --- | Default action which just prints to handle using given message. -defaultHandleAction :: Handle -> Text -> IO () -defaultHandleAction h message = - TIO.hPutStrLn h message `catch` handleWriteException - where - handleWriteException :: SomeException -> IO () - handleWriteException e = do - let errorMessage = "Error writing log message: " - <> show e <> " (original message: " <> message <> ")" - TIO.hPutStrLn h errorMessage - --- | Creates custom write action and memory queue where write action --- updates memory queue as well. -createWriteFuncWrapper - :: (Handle -> Text -> IO ()) - -> MVar () - -> IO ( Handle -> Text -> IO () - , MVar (MemoryQueue Text) - ) -createWriteFuncWrapper action lock = do - memoryQueue <- newMVar $ MQ.newMemoryQueue $ 2 * 1024 * 1024 -- 2 MB - - let customWriteFunc :: Handle -> Text -> IO () - customWriteFunc hdl msg = withMVar lock $ const $ do - action hdl msg - - -- Important to force the queue here, else a massive closure will - -- be retained until the queue is actually used. - modifyMVar_ memoryQueue $ \mq -> pure $! pushFront msg mq - - hFlush hdl - - return (customWriteFunc, memoryQueue) - --- | Create a stream log handler. Log messages sent to this handler --- will be sent to the stream used initially. Note that the 'close' --- method will have no effect on stream handlers; it does not actually --- close the underlying stream. -streamHandler :: Handle - -> (Handle -> Text -> IO ()) - -> MVar () - -> Severity - -> IO (GenericHandler Handle) -streamHandler privData writeAction lock severity = do - (writeFunc, readBackBuffer) <- createWriteFuncWrapper writeAction lock - return GenericHandler - { formatter = nullFormatter - , closeFunc = const $ pure () - , ghTag = HandlerOther "GenericHandler/StreamHandler" - , .. - } - --- | Create a file log handler. Log messages sent to this handler --- will be sent to the filename specified, which will be opened in --- Append mode. Calling 'close' on the handler will close the file. -fileHandler :: FilePath -> Severity -> IO (GenericHandler Handle) -fileHandler fp sev = do - createDirectoryIfMissing True (takeDirectory fp) - h <- openFile fp ReadWriteMode - hSeek h SeekFromEnd 0 - - lock <- newMVar () - sh <- streamHandler h defaultHandleAction lock sev - pure $ sh { closeFunc = hClose - , ghTag = HandlerFilelike fp - } diff --git a/src/System/Wlog/Handler/Syslog.hs b/src/System/Wlog/Handler/Syslog.hs deleted file mode 100644 --- a/src/System/Wlog/Handler/Syslog.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TypeFamilies #-} - -{- | - Module : System.Log.Handler.Syslog - Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -Syslog handler for the Haskell Logging Framework - -Written by John Goerzen, jgoerzen\@complete.org - -This module implements an interface to the Syslog service commonly -found in Unix\/Linux systems. This interface is primarily of interest to -developers of servers, as Syslog does not typically display messages in -an interactive fashion. - -This module is written in pure Haskell and is capable of logging to a local -or remote machine using the Syslog protocol. - -You can create a new Syslog 'LogHandler' by calling 'openlog'. - -More information on the Haskell Logging Framework can be found at -"System.Log.Logger". This module can also be used outside -of the rest of that framework for those interested in that. --} - -module System.Wlog.Handler.Syslog - ( SyslogHandler -- No constructors. - -- * Handler Initialization - , openlog - -- * Advanced handler initialization -#ifndef mingw32_HOST_OS - , openlog_local -#endif - , openlog_remote - , openlog_generic - -- * Data Types - , Facility(..) - , Option(..) - ) where - -import qualified Control.Exception as E -import Control.Monad (void, when) -import Data.Bits (shiftL, (.|.)) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Text.Lazy.Builder as B -import Network.BSD (getHostByName, hostAddresses) -import Network.Socket (Family, Family (..), HostName, - PortNumber, SockAddr (..), Socket, - SocketType (Datagram, Stream), - connect, socket) -import qualified Network.Socket as S -import qualified Network.Socket.ByteString as NBS -#ifndef mingw32_HOST_OS -import System.Posix.Process (getProcessID) -#endif -import qualified Data.Text.Lazy.IO as TIO -import System.IO () -import Universum hiding (Option, identity) - -import System.Wlog.Formatter (LogFormatter, varFormatter) -import System.Wlog.Handler (LogHandler (..), - LogHandlerTag (HandlerOther)) -import System.Wlog.Severity (Severity (..)) - - - -code_of_pri :: Severity -> Int -code_of_pri p = - case p of - Error -> 3 - Warning -> 4 - Notice -> 5 - Info -> 6 - Debug -> 7 - -{- | Facilities are used by the system to determine where messages -are sent. -} - -data Facility - = KERN -- ^ Kernel messages; you should likely never use this in your programs - | USER -- ^ General userland messages. Use this if nothing else is appropriate - | MAIL -- ^ E-Mail system - | DAEMON -- ^ Daemon (server process) messages - | AUTH -- ^ Authentication or security messages - | SYSLOG -- ^ Internal syslog messages; you should likely never use this in your programs - | LPR -- ^ Printer messages - | NEWS -- ^ Usenet news - | UUCP -- ^ UUCP messages - | CRON -- ^ Cron messages - | AUTHPRIV -- ^ Private authentication messages - | FTP -- ^ FTP messages - | LOCAL0 -- ^ LOCAL0 through LOCAL7 are reserved for you to customize as you wish - | LOCAL1 - | LOCAL2 - | LOCAL3 - | LOCAL4 - | LOCAL5 - | LOCAL6 - | LOCAL7 - deriving (Eq, Show, Read) - -code_of_fac :: Facility -> Int -code_of_fac f = case f of - KERN -> 0 - USER -> 1 - MAIL -> 2 - DAEMON -> 3 - AUTH -> 4 - SYSLOG -> 5 - LPR -> 6 - NEWS -> 7 - UUCP -> 8 - CRON -> 9 - AUTHPRIV -> 10 - FTP -> 11 - LOCAL0 -> 16 - LOCAL1 -> 17 - LOCAL2 -> 18 - LOCAL3 -> 19 - LOCAL4 -> 20 - LOCAL5 -> 21 - LOCAL6 -> 22 - LOCAL7 -> 23 - -makeCode :: Facility -> Severity -> Int -makeCode fac pri = - let faccode = code_of_fac fac - pricode = code_of_pri pri - in (faccode `shiftL` 3) .|. pricode - --- | Options for 'openlog'. -data Option - = PID -- ^ Automatically log process ID (PID) with each message - | PERROR -- ^ Send a copy of each message to stderr - deriving (Eq, Show, Read) - -data SyslogHandler = SyslogHandler - { options :: [Option] - , facility :: Facility - , identity :: String - , logsocket :: Socket - , address :: SockAddr - , sock_type :: SocketType - , priority :: Severity - , formatter :: LogFormatter SyslogHandler - } - -{- | Initialize the Syslog system using the local system's default interface, -\/dev\/log. Will return a new 'System.Log.Handler.LogHandler'. - -On Windows, instead of using \/dev\/log, this will attempt to send -UDP messages to something listening on the syslog port (514) on localhost. - -Use 'openlog_remote' if you need more control. --} - -openlog :: String -- ^ The name of this program -- will be - -- prepended to every log message - -> [Option] -- ^ A list of 'Option's. The list [] is - -- perfectly valid. ['PID'] is probably - -- most common here. - -> Facility -- ^ The 'Facility' value to pass to the - -- syslog system for every message logged - -> Severity -- ^ Messages logged below this priority - -- will be ignored. To include every - -- message, set this to 'DEBUG'. - -> IO SyslogHandler -- ^ Returns the new handler -#ifdef mingw32_HOST_OS -openlog = openlog_remote AF_INET "localhost" 514 -#elif darwin_HOST_OS -openlog = openlog_local "/var/run/syslog" -#else -openlog = openlog_local "/dev/log" -#endif - -{- | Initialize the Syslog system using an arbitrary Unix socket (FIFO). - -Not supported under Windows. --} - -#ifndef mingw32_HOST_OS -openlog_local :: String -- ^ Path to FIFO - -> String -- ^ Program name - -> [Option] -- ^ 'Option's - -> Facility -- ^ Facility value - -> Severity -- ^ Severity limit - -> IO SyslogHandler -openlog_local fifopath ident options fac pri = - do (s, t) <- do -- "/dev/log" is usually Datagram, - -- but most of syslog loggers allow it to be - -- of Stream type. glibc's" openlog()" - -- does roughly the similar thing: - -- http://www.gnu.org/software/libc/manual/html_node/openlog.html - - s <- socket AF_UNIX Stream 0 - tryStream s `E.catch` (onIOException (fallbackToDgram s)) - openlog_generic s (SockAddrUnix fifopath) t ident options fac pri - - where onIOException :: IO a -> E.IOException -> IO a - onIOException a _ = a - - tryStream :: Socket -> IO (Socket, SocketType) - tryStream s = - do connect s (SockAddrUnix fifopath) - return (s, Stream) - - fallbackToDgram :: Socket -> IO (Socket, SocketType) - fallbackToDgram s = - do S.close s -- close Stream variant - d <- socket AF_UNIX Datagram 0 - return (d, Datagram) -#endif - -{- | Log to a remote server via UDP. -} -openlog_remote - :: Family -- ^ Usually AF_INET or AF_INET6; see Network.Socket - -> HostName -- ^ Remote hostname. Some use @localhost@ - -> PortNumber -- ^ 514 is the default for syslog - -> String -- ^ Program name - -> [Option] -- ^ 'Option's - -> Facility -- ^ Facility value - -> Severity -- ^ Severity limit - -> IO SyslogHandler -openlog_remote fam hostname port ident options fac pri = - do - he <- getHostByName hostname - s <- socket fam Datagram 0 - let addr = SockAddrInet port (fromMaybe (error "head in openlog_remote") $ - head (hostAddresses he)) - openlog_generic s addr Datagram ident options fac pri - -{- | The most powerful initialization mechanism. Takes an open datagram -socket. -} -openlog_generic :: Socket -- ^ A datagram socket - -> SockAddr -- ^ Address for transmissions - -> SocketType -- ^ socket connection mode (stream / datagram) - -> String -- ^ Program name - -> [Option] -- ^ 'Option's - -> Facility -- ^ Facility value - -> Severity -- ^ Severity limit - -> IO SyslogHandler -openlog_generic sock addr sock_t ident opt fac pri = - return (SyslogHandler {options = opt, - facility = fac, - identity = ident, - logsocket = sock, - address = addr, - sock_type = sock_t, - priority = pri, - formatter = syslogFormatter - }) - -syslogFormatter :: LogFormatter SyslogHandler -syslogFormatter sh lr logname = - let format = "[$loggername/$prio] $msg" - in varFormatter [] format sh lr logname - - -instance LogHandler SyslogHandler where - getTag = const $ HandlerOther "SyslogHandlerTag" - setLevel sh p = sh{priority = p} - getLevel sh = priority sh - setFormatter sh f = sh{formatter = f} - getFormatter sh = formatter sh - readBack _ _ = pure [] - emit sh bldr _ = do - when (elem PERROR (options sh)) (TIO.hPutStrLn stderr (B.toLazyText bldr)) - pidPart <- getPidPart - void $ sendstr (toSyslogFormat (toText $ B.toLazyText bldr) pidPart) - where - prio = getLevel sh - sendstr :: Text -> IO () - sendstr t | T.null t = pass - sendstr omsg = do - let omsg' = TE.encodeUtf8 omsg - sent <- case sock_type sh of - Datagram -> NBS.sendTo (logsocket sh) omsg' (address sh) - Stream -> NBS.send (logsocket sh) omsg' - sck -> - error $ "sysloghandler: unsupported socket type " <> show sck <> - " only datagram/stream sockets are supported" - sendstr $ T.drop (fromIntegral sent) omsg - toSyslogFormat m pidPart = - "<" <> code <> ">" <> T.pack identity' <> T.pack pidPart <> ": " <> m <> "\0" - code = show $ makeCode (facility sh) prio - identity' = identity sh - getPidPart = if elem PID (options sh) - then getPid >>= \pid -> return ("[" ++ pid ++ "]") - else return "" - getPid :: IO String - getPid = -#ifndef mingw32_HOST_OS - getProcessID >>= return . show -#else - return "windows" -#endif - - close sh = S.close (logsocket sh) diff --git a/src/System/Wlog/IOLogger.hs b/src/System/Wlog/IOLogger.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/IOLogger.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +{- | + Module : System.Log.Logger + Copyright : Copyright (C) 2004-2011 John Goerzen + License : BSD3 + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Haskell Logging Framework, Primary Interface + +Written by John Goerzen, jgoerzen\@complete.org + +This module is a modification of "System.Log.Logger" of 'hslogger' +library. Unless proper description is written here, please use the +original documentation available on hackage/hslogger. +-} + +module System.Wlog.IOLogger + ( + -- * Basic Types + Logger + -- ** Re-Exported from System.Wlog + , Severity(..) + + -- * Logging Messages + -- ** Basic + , logM + , logMCond + -- ** Utility Functions + , removeAllHandlers + + -- * Logger Manipulation + -- ** Finding ∨ Creating Loggers + , getLogger, getRootLogger, rootLoggerName + -- ** Modifying Loggers + , addHandler, removeHandler, setHandlers + , getLevel, setLevel, clearLevel + -- ** Severity settings + , setSeverities, setSeveritiesMaybe + -- ** Saving Your Changes + , saveGlobalLogger + , updateGlobalLogger + , setPrefix + , retrieveLogContent + ) where + +import Universum + +import Control.Concurrent.MVar (modifyMVar, modifyMVar_, withMVar) +import Control.Lens (makeLenses) +import Data.Maybe (fromJust) +import System.FilePath (()) +import System.IO.Unsafe (unsafePerformIO) + +import System.Wlog.LoggerName (LoggerName (..)) +import System.Wlog.LogHandler (LogHandler (getTag), LogHandlerTag (HandlerFilelike), close, + readBack) +import System.Wlog.Severity (LogRecord (..), Severities, Severity (..), debugPlus, warningPlus) + + +import qualified Data.Map as M +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +import qualified System.Wlog.LogHandler (logHandlerMessage) + +--------------------------------------------------------------------------- +-- Basic logger types +--------------------------------------------------------------------------- + +data HandlerT = forall a. LogHandler a => HandlerT a + +data Logger = Logger + { _lLevel :: Maybe Severities + , _lHandlers :: [HandlerT] + , _lName :: LoggerName + } deriving (Generic) + +makeLenses ''Logger + +type LogTree = Map LoggerName Logger + +data LogInternalState = LogInternalState + { liTree :: LogTree + , liPrefix :: Maybe FilePath + } deriving (Generic) + +--------------------------------------------------------------------------- +-- Utilities +--------------------------------------------------------------------------- + +-- | The name of the root logger, which is always defined and present +-- on the system. +rootLoggerName :: LoggerName +rootLoggerName = mempty + +--------------------------------------------------------------------------- +-- Logger Tree Storage +--------------------------------------------------------------------------- + +-- | The log tree. Initialize it with a default root logger. +{-# NOINLINE logInternalState #-} +logInternalState :: MVar LogInternalState +-- note: only kick up tree if handled locally +logInternalState = unsafePerformIO $ do + let liTree = M.singleton rootLoggerName $ + Logger { _lLevel = Just warningPlus + , _lName = "" + , _lHandlers = []} + liPrefix = Nothing + newMVar $ LogInternalState {..} + +{- | Given a name, return all components of it, starting from the root. +Example return value: + +>["", "MissingH", "System.Cmd.Utils", "System.Cmd.Utils.pOpen"] + +-} +componentsOfName :: LoggerName -> [LoggerName] +componentsOfName (LoggerName name) = + rootLoggerName : (LoggerName <$> (joinComp (T.splitOn "." name) "")) + where + joinComp [] _ = [] + joinComp (x:xs) "" = x : joinComp xs x + joinComp (x:xs) accum = + let newlevel = accum <> "." <> x + in newlevel : joinComp xs newlevel + +--------------------------------------------------------------------------- +-- Logging With Location +--------------------------------------------------------------------------- + +-- | Log a message using the given logger at a given priority. +logM :: MonadIO m + => LoggerName -- ^ Name of the logger to use + -> Severity -- ^ Severity of this message + -> Text -- ^ The log text itself + -> m () +logM logname sev msg = do + l <- getLogger logname + handle l (LR sev msg) (const True) + +logMCond :: MonadIO m => LoggerName -> Severity -> Text -> (LogHandlerTag -> Bool) -> m () +logMCond logname sev msg cond = do + l <- getLogger logname + handle l (LR sev msg) cond + +--------------------------------------------------------------------------- +-- Public Logger Interaction Support +--------------------------------------------------------------------------- + +-- | Returns the logger for the given name. If no logger with that name +-- exists, creates new loggers and any necessary parent loggers, with +-- no connected handlers. +getLogger :: MonadIO m => LoggerName -> m Logger +getLogger lname = liftIO $ modifyMVar logInternalState $ \lt@LogInternalState{..} -> + case M.lookup lname liTree of + Just x -> return (lt, x) -- A logger exists; return it and leave tree + Nothing -> do + -- Add logger(s). Then call myself to retrieve it. + let newlt = createLoggers (componentsOfName lname) liTree + let result = fromJust $ M.lookup lname newlt + return (LogInternalState newlt liPrefix, result) + where + createLoggers :: [LoggerName] -> LogTree -> LogTree + createLoggers [] lt = lt -- No names to add; return tree unmodified + createLoggers (x:xs) lt = -- Add logger to tree + createLoggers xs $ + if M.member x lt + then lt + else M.insert x (defaultLogger & lName .~ x) lt + + defaultLogger :: Logger + defaultLogger = Logger Nothing [] (error "log-warper has some strange code") -- ???!??! + +-- | Returns the root logger. +getRootLogger :: MonadIO m => m Logger +getRootLogger = getLogger rootLoggerName + +-- | Handle a log request. +handle :: MonadIO m => Logger -> LogRecord -> (LogHandlerTag -> Bool) -> m () +handle l lrecord@(LR sev _) handlerFilter = do + lp <- getLoggerSeverities nm + when (sev `Set.member` lp) $ do + ph <- concatMap (view lHandlers) <$> parentLoggers nm + forM_ ph $ callHandler lrecord nm + where + nm :: LoggerName + nm = view lName l + + parentLoggers :: MonadIO m => LoggerName -> m [Logger] + parentLoggers = mapM getLogger . componentsOfName + + -- Get the severity we should use. Find the first logger in the + -- tree, starting here, with a set severity. If even root doesn't + -- have one, assume "Debug". + getLoggerSeverities :: MonadIO m => LoggerName -> m Severities + getLoggerSeverities name = do + pl <- parentLoggers name + case catMaybes . map (view lLevel) $ (l : pl) of + [] -> pure debugPlus + (x:_) -> pure x + + callHandler :: MonadIO m => LogRecord -> LoggerName -> HandlerT -> m () + callHandler lr loggername (HandlerT x) = + when (handlerFilter $ getTag x) $ + System.Wlog.LogHandler.logHandlerMessage x lr loggername + +-- | Sets file prefix to 'LogInternalState'. +setPrefix :: MonadIO m => Maybe FilePath -> m () +setPrefix p = liftIO + $ modifyMVar_ logInternalState + $ \li -> pure $ li { liPrefix = p } + +-- | Add handler to 'Logger'. Returns a new 'Logger'. +addHandler :: LogHandler a => a -> Logger -> Logger +addHandler h = lHandlers %~ (HandlerT h:) + +-- | Remove a handler from the 'Logger'. Handlers are removed in the reverse +-- order they were added, so the following property holds for any 'LogHandler' +-- @h@: +-- +-- > removeHandler . addHandler h = id +-- +-- If no handlers are associated with the 'Logger', it is returned unchanged. +-- +-- The root logger's default handler that writes every message to stderr can +-- be removed by using this function before any handlers have been added +-- to the root logger: +-- +-- > updateGlobalLogger rootLoggerName removeHandler +removeHandler :: Logger -> Logger +removeHandler = lHandlers %~ drop 1 + +-- | Set the 'Logger'\'s list of handlers to the list supplied. +-- All existing handlers are removed first. +setHandlers :: LogHandler a => [a] -> Logger -> Logger +setHandlers hl = lHandlers .~ map HandlerT hl + +-- | Returns the "level" of the logger. Items beneath this +-- level will be ignored. +getLevel :: Logger -> Maybe Severities +getLevel = _lLevel + +-- | Sets the "level" of the 'Logger'. Returns a new +-- 'Logger' object with the new level. +setLevel :: Severities -> Logger -> Logger +setLevel p = lLevel .~ Just p + +-- | Clears the "level" of the 'Logger'. It will now inherit the level of +-- | its parent. +clearLevel :: Logger -> Logger +clearLevel = lLevel .~ Nothing + +-- | Set severities for given logger. By default parent's severities are used. +setSeverities :: MonadIO m => LoggerName -> Severities -> m () +setSeverities name = updateGlobalLogger name . setLevel + +-- | Set or clear severities. +setSeveritiesMaybe + :: MonadIO m + => LoggerName -> Maybe Severities -> m () +setSeveritiesMaybe name Nothing = updateGlobalLogger name clearLevel +setSeveritiesMaybe n (Just x) = setSeverities n x + +-- | Updates the global record for the given logger to take into +-- account any changes you may have made. +saveGlobalLogger :: MonadIO m => Logger -> m () +saveGlobalLogger l = liftIO $ + modifyMVar_ logInternalState $ \LogInternalState{..} -> + pure $ LogInternalState (M.insert (view lName l) l liTree) liPrefix + +-- | Helps you make changes on the given logger. Takes a function +-- that makes changes and writes those changes back to the global +-- database. Here's an example from above (\"s\" is a 'LogHandler'): +-- +-- > updateGlobalLogger "MyApp.BuggyComponent" +-- > (setLevel DEBUG . setHandlers [s]) +updateGlobalLogger + :: MonadIO m + => LoggerName -- ^ Logger name + -> (Logger -> Logger) -- ^ Function to call + -> m () +updateGlobalLogger ln func = do + l <- getLogger ln + saveGlobalLogger (func l) + +-- | Allow graceful shutdown. Release all opened files/handlers/etc. +removeAllHandlers :: MonadIO m => m () +removeAllHandlers = liftIO $ + modifyMVar_ logInternalState $ \LogInternalState{..} -> do + let allHandlers = M.foldr (\l r -> concat [r, view lHandlers l]) [] liTree + mapM_ (\(HandlerT h) -> close h) allHandlers + let newTree = map (lHandlers .~ []) liTree + return $ LogInternalState newTree liPrefix + +---------------------------------------------------------------------------- +-- Retrieving logs ad-hoc +---------------------------------------------------------------------------- + +-- | Retrieves content of log file(s) given path (w/o '_lcFilePrefix', +-- as specified in your config). Example: there's @component.log@ in +-- config, but this function will return @[component.log.122, +-- component.log.123]@ if you want to. Content is file lines newest +-- first. +-- +-- FYI: this function is implemented to avoid the following problem: +-- log-warper holds open handles to files, so trying to open log file +-- for read would result in 'IOException'. +retrieveLogContent :: (MonadIO m) => FilePath -> Maybe Int -> m [Text] +retrieveLogContent filePath linesNum = + liftIO $ withMVar logInternalState $ \LogInternalState{..} -> do + let filePathFull = fromMaybe "" liPrefix filePath + let appropriateHandlers = + filter (\(HandlerT h) -> getTag h == HandlerFilelike filePathFull) $ + concatMap _lHandlers $ + M.elems liTree + let takeMaybe = maybe identity take linesNum + case appropriateHandlers of + [HandlerT h] -> liftIO $ readBack h 12345 -- all of them + [] -> takeMaybe . reverse . T.lines <$> TIO.readFile filePathFull + xs -> error $ "Found more than one (" <> show (length xs) <> + "handle with the same filePath tag, impossible." diff --git a/src/System/Wlog/Launcher.hs b/src/System/Wlog/Launcher.hs --- a/src/System/Wlog/Launcher.hs +++ b/src/System/Wlog/Launcher.hs @@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : System.Wlog.Parser @@ -32,30 +31,29 @@ , setupLogging ) where -import Universum +import Universum -import Control.Error.Util ((?:)) -import Control.Exception (throwIO) -import qualified Data.HashMap.Strict as HM hiding (HashMap) -import Data.Time (UTCTime) -import Data.Yaml (decodeFileEither) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (()) +import Control.Error.Util ((?:)) +import Control.Exception (throwIO) +import Data.Time (UTCTime) +import Data.Yaml (decodeFileEither) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) -import System.Wlog.Formatter (centiUtcTimeF, stdoutFormatter, - stdoutFormatterTimeRounded) -import System.Wlog.Handler (LogHandler (setFormatter)) -import System.Wlog.Handler.Roller (rotationFileHandler) -import System.Wlog.Handler.Simple (fileHandler) -import System.Wlog.Logger (addHandler, setPrefix, updateGlobalLogger) -import System.Wlog.LoggerConfig (HandlerWrap (..), LoggerConfig (..), - LoggerTree (..)) -import System.Wlog.LoggerName (LoggerName (..)) -import System.Wlog.Wrapper (Severity (Debug), initTerminalLogging, - setSeverityMaybe) +import System.Wlog.Formatter (centiUtcTimeF, stdoutFormatter, stdoutFormatterTimeRounded) +import System.Wlog.IOLogger (addHandler, setPrefix, setSeveritiesMaybe, updateGlobalLogger) +import System.Wlog.LoggerConfig (HandlerWrap (..), LoggerConfig (..), LoggerTree (..)) +import System.Wlog.LoggerName (LoggerName (..)) +import System.Wlog.LogHandler (LogHandler (setFormatter)) +import System.Wlog.LogHandler.Roller (rotationFileHandler) +import System.Wlog.LogHandler.Simple (fileHandler) +import System.Wlog.Severity (Severities, debugPlus, severityPlus) +import System.Wlog.Terminal (initTerminalLogging) +import qualified Data.HashMap.Strict as HM hiding (HashMap) + data HandlerFabric - = forall h . LogHandler h => HandlerFabric (FilePath -> Severity -> IO h) + = forall h . LogHandler h => HandlerFabric (FilePath -> Severities -> IO h) -- | This function traverses 'LoggerConfig' initializing all subloggers -- with 'Severity' and redirecting output in file handlers. @@ -69,7 +67,7 @@ customTerminalAction isShowTime isShowTid - _lcTermSeverity + (severityPlus <$> _lcTermSeverity) liftIO $ setPrefix _lcFilePrefix processLoggers mempty _lcTree @@ -90,14 +88,14 @@ processLoggers parent LoggerTree{..} = do -- This prevents logger output to appear in terminal unless (parent == mempty && isNothing consoleAction) $ - setSeverityMaybe parent _ltSeverity + setSeveritiesMaybe parent (severityPlus <$> _ltSeverity) forM_ _ltFiles $ \HandlerWrap{..} -> liftIO $ do - let fileSeverity = _ltSeverity ?: Debug + let fileSeverities = (severityPlus <$> _ltSeverity) ?: debugPlus let handlerPath = handlerPrefix _hwFilePath case handlerFabric of HandlerFabric fabric -> do - let handlerCreator = fabric handlerPath fileSeverity + let handlerCreator = fabric handlerPath fileSeverities let defFmt = (`setFormatter` stdoutFormatter timeF isShowTime isShowTid) let roundFmt r = (`setFormatter` stdoutFormatterTimeRounded timeF r) let fmt = maybe defFmt roundFmt _hwRounding diff --git a/src/System/Wlog/LogHandler.hs b/src/System/Wlog/LogHandler.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/LogHandler.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + Module : System.Log.LogHandler + Copyright : Copyright (C) 2004-2011 John Goerzen + License : BSD3 + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Definition of log handler support + +For some handlers, check out "System.WLog.Handler.Simple" and +"System.WLog.Handler.Syslog". + +Please see "System.WLog.Logger" for extensive documentation on the +logging system. + +Written by John Goerzen, jgoerzen\@complete.org +-} +module System.Wlog.LogHandler + ( -- * Basic Types + LogHandlerTag(..) + , LogHandler(..) + , logHandlerMessage + ) where + +import Universum + +import Data.Text.Lazy.Builder as B + +import System.Wlog.Formatter (LogFormatter, nullFormatter) +import System.Wlog.LoggerName (LoggerName (..)) +import System.Wlog.Severity (LogRecord (..), Severities) + +import qualified Data.Set as Set + + +-- | Logs an event if it meets the requirements +-- given by the most recent call to 'setLevel'. +logHandlerMessage :: (MonadIO m, LogHandler a) => a -> LogRecord -> LoggerName -> m () +logHandlerMessage h lr@(LR pri _) logname = + when (pri `Set.member` (getLevel h)) $ do + let lName = getLoggerName logname + formattedMsg <- liftIO $ (getFormatter h) h lr lName + emit h formattedMsg lName + +-- | Tag identifying handlers. +data LogHandlerTag + = HandlerFilelike FilePath + | HandlerOther String + deriving (Show, Eq) + +-- | This is the base class for the various log handlers. They should +-- all adhere to this class. +class LogHandler a where + -- TODO it should be data/type family like in 'System.Exception' + -- | Tag of handler. Is arbitrary. Made for identification. + getTag :: a -> LogHandlerTag + + -- | Sets the log level. 'handle' will drop items beneath this + -- level. + setLevel :: a -> Severities -> a + + -- | Gets the current level. + getLevel :: a -> Severities + + -- | Set a log formatter to customize the log format for this Handler + setFormatter :: a -> LogFormatter a -> a + getFormatter :: a -> LogFormatter a + getFormatter _h = nullFormatter + + -- | Forces an event to be logged regardless of + -- the configured level. + emit :: MonadIO m => a -> B.Builder -> Text -> m () + + -- | Read back from logger (e.g. file), newest first. You specify + -- the number of (newest) logging entries. Logger can return @pure + -- []@ if this behaviour can't be emulated or store buffer. + readBack :: MonadIO m => a -> Int -> m [Text] + + -- | Closes the logging system, causing it to close + -- any open files, etc. + close :: MonadIO m => a -> m () diff --git a/src/System/Wlog/LogHandler/Roller.hs b/src/System/Wlog/LogHandler/Roller.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/LogHandler/Roller.hs @@ -0,0 +1,120 @@ +-- | Custom implementation of 'LogHandler' with log rotation support. + +module System.Wlog.LogHandler.Roller + ( InvalidRotation (..) + , RollerHandler (..) + , logIndex + , rotationFileHandler + ) where + +import Universum + +import Control.Concurrent (modifyMVar, modifyMVar_, withMVar) +import Data.Text.Lazy.Builder as B +import Formatting (sformat, shown, (%)) + +import System.Directory (removeFile, renameFile) +import System.FilePath ((<.>)) +import System.IO (Handle, IOMode (ReadWriteMode), SeekMode (AbsoluteSeek, SeekFromEnd), hClose, + hFileSize, hFlush, hSeek) +import System.Wlog.FileUtils (whenExist) +import System.Wlog.Formatter (LogFormatter, nullFormatter) +import System.Wlog.LoggerConfig (RotationParameters (..), isValidRotation) +import System.Wlog.LogHandler (LogHandler (..), LogHandlerTag (HandlerFilelike)) +import System.Wlog.LogHandler.Simple (GenericHandler (..), fileHandler) +import System.Wlog.Severity (Severities) + +import qualified Data.Text as T +import qualified Data.Text.IO as TIO + +-- | Similar to 'GenericHandler'. But holds file 'Handle' inside +-- mutable variable ('MVar') to be able to rotate loggers. +data RollerHandler = RollerHandler + { rhSeverities :: !Severities + , rhFormatter :: !(LogFormatter RollerHandler) + , rhFileHandle :: !(MVar Handle) + , rhWriteAction :: !(Handle -> Text -> IO ()) + , rhCloseAction :: !(Handle -> IO ()) + , rhFileName :: !FilePath + } + +instance LogHandler RollerHandler where + getTag rh = HandlerFilelike $ rhFileName rh + setLevel rh p = rh { rhSeverities = p } + setFormatter rh f = rh { rhFormatter = f } + getLevel = rhSeverities + getFormatter = rhFormatter + readBack = rollerReadback + + emit rh bldr _ = liftIO $ rhWriteAction rh (error "Handler is used internally") (toText . B.toLazyText $ bldr) + close RollerHandler{..} = liftIO $ withMVar rhFileHandle rhCloseAction + +data InvalidRotation = InvalidRotation !Text + deriving (Show, Eq) + +instance Exception InvalidRotation + +logIndex :: FilePath -> Int -> FilePath +logIndex handlerPath i = handlerPath <.> show i + +rollerReadback :: MonadIO m => RollerHandler -> Int -> m [Text] +rollerReadback RollerHandler{..} logsNum = liftIO $ do + modifyMVar rhFileHandle $ \h -> do + hFlush h + hSeek h AbsoluteSeek 0 + contents <- T.lines <$> TIO.hGetContents h + hClose h + h' <- openFile rhFileName ReadWriteMode + hSeek h' SeekFromEnd 0 + pure (h', take logsNum $ reverse contents) + +-- TODO: correct exceptions handling here is too smart for me +rollerWriting + :: RotationParameters + -> FilePath + -> (Handle -> Text -> IO ()) + -> MVar Handle + -> Handle + -> Text + -> IO () +rollerWriting RotationParameters{..} handlerPath loggingAction varHandle _ msg = + modifyMVar_ varHandle $ \landle -> do + loggingAction landle msg + logFileSize <- fromIntegral <$> hFileSize landle + if logFileSize < rpLogLimit + then return landle + -- otherwise should rename all files and create new handle putting in MVar + else do + hClose landle + let lastIndex = fromIntegral $ rpKeepFiles - 1 + for_ [lastIndex - 1,lastIndex - 2 .. 0] $ \i -> do + let oldLogFile = logIndex handlerPath i + let newLogFile = logIndex handlerPath (i + 1) + whenExist oldLogFile $ (`renameFile` newLogFile) + let zeroIndex = logIndex handlerPath 0 + renameFile handlerPath zeroIndex + let lastLogFile = logIndex handlerPath lastIndex + whenExist lastLogFile removeFile + h <- openFile handlerPath ReadWriteMode + hSeek h SeekFromEnd 0 + pure h + +-- | Create rotation logging handler. +rotationFileHandler + :: MonadIO m + => RotationParameters + -> FilePath + -> Severities + -> m RollerHandler +rotationFileHandler rp@RotationParameters{..} _ _ + | not $ isValidRotation rp = liftIO $ throwM $ InvalidRotation $ + sformat ("Rotation parameters must be positive: "%shown) rp +rotationFileHandler rp@RotationParameters{..} handlerPath rhSeverities = liftIO $ do + GenericHandler{..} <- fileHandler handlerPath rhSeverities + rhFileHandle <- newMVar privData + let rhWriteAction = rollerWriting rp handlerPath writeFunc rhFileHandle + pure RollerHandler { rhFormatter = nullFormatter + , rhCloseAction = closeFunc + , rhFileName = handlerPath + , .. + } diff --git a/src/System/Wlog/LogHandler/Simple.hs b/src/System/Wlog/LogHandler/Simple.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/LogHandler/Simple.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + Module : System.Log.Handler.Simple + Copyright : Copyright (C) 2004-2011 John Goerzen + License : BSD3 + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Simple log handlers + +Written by John Goerzen, jgoerzen\@complete.org +-} + +module System.Wlog.LogHandler.Simple + ( GenericHandler(..) + , defaultHandleAction + + -- * Custom handlers + , fileHandler + , streamHandler + ) where + +import Universum + +import Control.Concurrent (modifyMVar_, withMVar) +import Control.Exception (SomeException) +import Data.Text.Lazy.Builder as B +import Data.Typeable (Typeable) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) +import System.IO (Handle, IOMode (ReadWriteMode), SeekMode (SeekFromEnd), hClose, hFlush, hSeek) + +import System.Wlog.Formatter (LogFormatter, nullFormatter) +import System.Wlog.LogHandler (LogHandler (..), LogHandlerTag (..)) +import System.Wlog.MemoryQueue (MemoryQueue) +import System.Wlog.MemoryQueue as MQ +import System.Wlog.Severity (Severities) + +import qualified Data.Text.IO as TIO + +-- | A helper data type. +data GenericHandler a = GenericHandler + { severities :: !Severities + , formatter :: !(LogFormatter (GenericHandler a)) + , privData :: !a + , writeFunc :: !(a -> Text -> IO ()) + , closeFunc :: !(a -> IO ()) + , readBackBuffer :: !(MVar (MemoryQueue Text)) + , ghTag :: !LogHandlerTag + } deriving Typeable + +instance Typeable a => LogHandler (GenericHandler a) where + getTag = ghTag + setLevel sh s = sh {severities = s} + getLevel sh = severities sh + setFormatter sh f = sh{formatter = f} + getFormatter sh = formatter sh + readBack sh i = liftIO $ withMVar (readBackBuffer sh) $ \mq' -> pure $! take i . MQ.toList $ mq' + emit sh bldr _ = liftIO $ (writeFunc sh) (privData sh) (toText . B.toLazyText $ bldr) + close sh = liftIO $ (closeFunc sh) (privData sh) + +-- | Default action which just prints to handle using given message. +defaultHandleAction :: Handle -> Text -> IO () +defaultHandleAction h message = + TIO.hPutStrLn h message `catch` handleWriteException + where + handleWriteException :: SomeException -> IO () + handleWriteException e = do + let errorMessage = "Error writing log message: " + <> show e <> " (original message: " <> message <> ")" + TIO.hPutStrLn h errorMessage + +-- | Creates custom write action and memory queue where write action +-- updates memory queue as well. +createWriteFuncWrapper + :: (Handle -> Text -> IO ()) + -> MVar () + -> IO ( Handle -> Text -> IO () + , MVar (MemoryQueue Text) + ) +createWriteFuncWrapper action lock = do + memoryQueue <- newMVar $ MQ.newMemoryQueue $ 2 * 1024 * 1024 -- 2 MB + + let customWriteFunc :: Handle -> Text -> IO () + customWriteFunc hdl msg = withMVar lock $ const $ do + action hdl msg + + -- Important to force the queue here, else a massive closure will + -- be retained until the queue is actually used. + modifyMVar_ memoryQueue $ \mq -> pure $! pushFront msg mq + + hFlush hdl + + return (customWriteFunc, memoryQueue) + +-- | Create a stream log handler. Log messages sent to this handler +-- will be sent to the stream used initially. Note that the 'close' +-- method will have no effect on stream handlers; it does not actually +-- close the underlying stream. +streamHandler :: Handle + -> (Handle -> Text -> IO ()) + -> MVar () + -> Severities + -> IO (GenericHandler Handle) +streamHandler privData writeAction lock severities = do + (writeFunc, readBackBuffer) <- createWriteFuncWrapper writeAction lock + return GenericHandler + { formatter = nullFormatter + , closeFunc = const $ pure () + , ghTag = HandlerOther "GenericHandler/StreamHandler" + , .. + } + +-- | Create a file log handler. Log messages sent to this handler +-- will be sent to the filename specified, which will be opened in +-- Append mode. Calling 'close' on the handler will close the file. +fileHandler :: FilePath -> Severities -> IO (GenericHandler Handle) +fileHandler fp sev = do + createDirectoryIfMissing True (takeDirectory fp) + h <- openFile fp ReadWriteMode + hSeek h SeekFromEnd 0 + + lock <- newMVar () + sh <- streamHandler h defaultHandleAction lock sev + pure $ sh { closeFunc = hClose + , ghTag = HandlerFilelike fp + } diff --git a/src/System/Wlog/LogHandler/Syslog.hs b/src/System/Wlog/LogHandler/Syslog.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/LogHandler/Syslog.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} + +{- | + Module : System.Log.LogHandler.Syslog + Copyright : Copyright (C) 2004-2011 John Goerzen + License : BSD3 + + Maintainer : John Goerzen + Stability : provisional + Portability: portable + +Syslog handler for the Haskell Logging Framework + +Written by John Goerzen, jgoerzen\@complete.org + +This module implements an interface to the Syslog service commonly +found in Unix\/Linux systems. This interface is primarily of interest to +developers of servers, as Syslog does not typically display messages in +an interactive fashion. + +This module is written in pure Haskell and is capable of logging to a local +or remote machine using the Syslog protocol. + +You can create a new Syslog 'LogHandler' by calling 'openlog'. + +More information on the Haskell Logging Framework can be found at +"System.Log.Logger". This module can also be used outside +of the rest of that framework for those interested in that. +-} + +module System.Wlog.LogHandler.Syslog + ( SyslogHandler -- No constructors. + -- * Handler Initialization + , openlog + -- * Advanced handler initialization +#ifndef mingw32_HOST_OS + , openlog_local +#endif + , openlog_remote + , openlog_generic + -- * Data Types + , Facility(..) + , Option(..) + ) where + +import Universum hiding (Option, identity) + +import Control.Monad (void, when) +import Data.Bits (shiftL, (.|.)) +import Data.Text.Lazy.Builder as B +import Network.BSD (getHostByName, hostAddresses) +import Network.Socket (Family, Family (..), HostName, PortNumber, SockAddr (..), Socket, + SocketType (Datagram, Stream), connect, socket) +#ifndef mingw32_HOST_OS +import System.Posix.Process (getProcessID) +#endif +import System.IO () + +import System.Wlog.Formatter (LogFormatter, varFormatter) +import System.Wlog.LogHandler (LogHandler (..), LogHandlerTag (HandlerOther)) +import System.Wlog.Severity (Severities, Severity (..)) + + +import qualified Control.Exception as E +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy.IO as TIO +import qualified Network.Socket as S +import qualified Network.Socket.ByteString as NBS + +code_of_sev :: Severities -> Int +code_of_sev sevs = + case fromMaybe Debug (Set.lookupMin sevs) of + Error -> 3 + Warning -> 4 + Notice -> 5 + Info -> 6 + Debug -> 7 + +{- | Facilities are used by the system to determine where messages +are sent. -} + +data Facility + = KERN -- ^ Kernel messages; you should likely never use this in your programs + | USER -- ^ General userland messages. Use this if nothing else is appropriate + | MAIL -- ^ E-Mail system + | DAEMON -- ^ Daemon (server process) messages + | AUTH -- ^ Authentication or security messages + | SYSLOG -- ^ Internal syslog messages; you should likely never use this in your programs + | LPR -- ^ Printer messages + | NEWS -- ^ Usenet news + | UUCP -- ^ UUCP messages + | CRON -- ^ Cron messages + | AUTHPRIV -- ^ Private authentication messages + | FTP -- ^ FTP messages + | LOCAL0 -- ^ LOCAL0 through LOCAL7 are reserved for you to customize as you wish + | LOCAL1 + | LOCAL2 + | LOCAL3 + | LOCAL4 + | LOCAL5 + | LOCAL6 + | LOCAL7 + deriving (Eq, Show, Read) + +code_of_fac :: Facility -> Int +code_of_fac f = case f of + KERN -> 0 + USER -> 1 + MAIL -> 2 + DAEMON -> 3 + AUTH -> 4 + SYSLOG -> 5 + LPR -> 6 + NEWS -> 7 + UUCP -> 8 + CRON -> 9 + AUTHPRIV -> 10 + FTP -> 11 + LOCAL0 -> 16 + LOCAL1 -> 17 + LOCAL2 -> 18 + LOCAL3 -> 19 + LOCAL4 -> 20 + LOCAL5 -> 21 + LOCAL6 -> 22 + LOCAL7 -> 23 + +makeCode :: Facility -> Set Severity -> Int +makeCode fac sevs = + let faccode = code_of_fac fac + pricode = code_of_sev sevs + in (faccode `shiftL` 3) .|. pricode + +-- | Options for 'openlog'. +data Option + = PID -- ^ Automatically log process ID (PID) with each message + | PERROR -- ^ Send a copy of each message to stderr + deriving (Eq, Show, Read) + +data SyslogHandler = SyslogHandler + { options :: [Option] + , facility :: Facility + , identity :: String + , logsocket :: Socket + , address :: SockAddr + , sock_type :: SocketType + , severities :: Set Severity + , formatter :: LogFormatter SyslogHandler + } + +{- | Initialize the Syslog system using the local system's default interface, +\/dev\/log. Will return a new 'System.Log.Handler.LogHandler'. + +On Windows, instead of using \/dev\/log, this will attempt to send +UDP messages to something listening on the syslog port (514) on localhost. + +Use 'openlog_remote' if you need more control. +-} + +openlog :: String -- ^ The name of this program -- will be + -- prepended to every log message + -> [Option] -- ^ A list of 'Option's. The list [] is + -- perfectly valid. ['PID'] is probably + -- most common here. + -> Facility -- ^ The 'Facility' value to pass to the + -- syslog system for every message logged + -> Severities -- ^ Messages logged below this priority + -- will be ignored. To include every + -- message, set this to 'DEBUG'. + -> IO SyslogHandler -- ^ Returns the new handler +#ifdef mingw32_HOST_OS +openlog = openlog_remote AF_INET "localhost" 514 +#elif darwin_HOST_OS +openlog = openlog_local "/var/run/syslog" +#else +openlog = openlog_local "/dev/log" +#endif + +{- | Initialize the Syslog system using an arbitrary Unix socket (FIFO). + +Not supported under Windows. +-} + +#ifndef mingw32_HOST_OS +openlog_local :: String -- ^ Path to FIFO + -> String -- ^ Program name + -> [Option] -- ^ 'Option's + -> Facility -- ^ Facility value + -> Severities -- ^ Severities + -> IO SyslogHandler +openlog_local fifopath ident options fac sevs = + do (s, t) <- do -- "/dev/log" is usually Datagram, + -- but most of syslog loggers allow it to be + -- of Stream type. glibc's" openlog()" + -- does roughly the similar thing: + -- http://www.gnu.org/software/libc/manual/html_node/openlog.html + + s <- socket AF_UNIX Stream 0 + tryStream s `E.catch` (onIOException (fallbackToDgram s)) + openlog_generic s (SockAddrUnix fifopath) t ident options fac sevs + + where onIOException :: IO a -> E.IOException -> IO a + onIOException a _ = a + + tryStream :: Socket -> IO (Socket, SocketType) + tryStream s = + do connect s (SockAddrUnix fifopath) + return (s, Stream) + + fallbackToDgram :: Socket -> IO (Socket, SocketType) + fallbackToDgram s = + do S.close s -- close Stream variant + d <- socket AF_UNIX Datagram 0 + return (d, Datagram) +#endif + +{- | Log to a remote server via UDP. -} +openlog_remote + :: Family -- ^ Usually AF_INET or AF_INET6; see Network.Socket + -> HostName -- ^ Remote hostname. Some use @localhost@ + -> PortNumber -- ^ 514 is the default for syslog + -> String -- ^ Program name + -> [Option] -- ^ 'Option's + -> Facility -- ^ Facility value + -> Severities -- ^ Severity limit + -> IO SyslogHandler +openlog_remote fam hostname port ident options fac sevs = + do + he <- getHostByName hostname + s <- socket fam Datagram 0 + let addr = SockAddrInet port (fromMaybe (error "head in openlog_remote") $ + head (hostAddresses he)) + openlog_generic s addr Datagram ident options fac sevs + +{- | The most powerful initialization mechanism. Takes an open datagram +socket. -} +openlog_generic :: Socket -- ^ A datagram socket + -> SockAddr -- ^ Address for transmissions + -> SocketType -- ^ socket connection mode (stream / datagram) + -> String -- ^ Program name + -> [Option] -- ^ 'Option's + -> Facility -- ^ Facility value + -> Severities -- ^ Severity limit + -> IO SyslogHandler +openlog_generic sock addr sock_t ident opt fac sevs = + return (SyslogHandler { options = opt, + facility = fac, + identity = ident, + logsocket = sock, + address = addr, + sock_type = sock_t, + severities = sevs, + formatter = syslogFormatter + }) + +syslogFormatter :: LogFormatter SyslogHandler +syslogFormatter sh lr logname = + let format = "[$loggername/$prio] $msg" + in varFormatter [] format sh lr logname + + +instance LogHandler SyslogHandler where + getTag = const $ HandlerOther "SyslogHandlerTag" + setLevel sh s = sh{severities = s} + getLevel sh = severities sh + setFormatter sh f = sh{formatter = f} + getFormatter sh = formatter sh + readBack _ _ = pure [] + emit sh bldr _ = liftIO $ do + when (elem PERROR (options sh)) (TIO.hPutStrLn stderr (B.toLazyText bldr)) + pidPart <- getPidPart + void $ sendstr (toSyslogFormat (toText $ B.toLazyText bldr) pidPart) + where + prio = getLevel sh + sendstr :: Text -> IO () + sendstr t | T.null t = pass + sendstr omsg = do + let omsg' = TE.encodeUtf8 omsg + sent <- case sock_type sh of + Datagram -> NBS.sendTo (logsocket sh) omsg' (address sh) + Stream -> NBS.send (logsocket sh) omsg' + sck -> + error $ "sysloghandler: unsupported socket type " <> show sck <> + " only datagram/stream sockets are supported" + sendstr $ T.drop (fromIntegral sent) omsg + toSyslogFormat m pidPart = + "<" <> code <> ">" <> T.pack identity' <> T.pack pidPart <> ": " <> m <> "\0" + code = show $ makeCode (facility sh) prio + identity' = identity sh + getPidPart = if elem PID (options sh) + then getPid >>= \pid -> return ("[" ++ pid ++ "]") + else return "" + getPid :: IO String + getPid = +#ifndef mingw32_HOST_OS + getProcessID >>= return . show +#else + return "windows" +#endif + + close = liftIO . S.close . logsocket diff --git a/src/System/Wlog/Logger.hs b/src/System/Wlog/Logger.hs deleted file mode 100644 --- a/src/System/Wlog/Logger.hs +++ /dev/null @@ -1,373 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -{- | - Module : System.Log.Logger - Copyright : Copyright (C) 2004-2011 John Goerzen - License : BSD3 - - Maintainer : John Goerzen - Stability : provisional - Portability: portable - -Haskell Logging Framework, Primary Interface - -Written by John Goerzen, jgoerzen\@complete.org - -This module is a modification of "System.Log.Logger" of 'hslogger' -library. Unless proper description is written here, please use the -original documentation available on hackage/hslogger. --} - -module System.Wlog.Logger - ( - -- * Basic Types - Logger - -- ** Re-Exported from System.Wlog - , Severity(..) - - -- * Logging Messages - -- ** Basic - , logM - , logMCond - -- ** Utility Functions - , debugM, infoM, noticeM, warningM, errorM - , removeAllHandlers - , traplogging - -- ** Logging to a particular Logger by object - , logL - , logLCond - - -- * Logger Manipulation - -- ** Finding ∨ Creating Loggers - , getLogger, getRootLogger, rootLoggerName - -- ** Modifying Loggers - , addHandler, removeHandler, setHandlers - , getLevel, setLevel, clearLevel - -- ** Saving Your Changes - , saveGlobalLogger - , updateGlobalLogger - , setPrefix - , retrieveLogContent - ) where - -import Universum - -import Control.Concurrent.MVar (modifyMVar, modifyMVar_, withMVar) -import Control.Lens (makeLenses) -import qualified Data.Map as M -import Data.Maybe (fromJust) -import qualified Data.Text as T -import qualified Data.Text.IO as TIO -import System.FilePath (()) -import System.IO.Unsafe (unsafePerformIO) - -import System.Wlog.Handler (LogHandler (getTag), - LogHandlerTag (HandlerFilelike), close, - readBack) -import qualified System.Wlog.Handler (handle) -import System.Wlog.LoggerName (LoggerName (..)) -import System.Wlog.Severity (LogRecord (..), Severity (..)) - - ---------------------------------------------------------------------------- --- Basic logger types ---------------------------------------------------------------------------- - -data HandlerT = forall a. LogHandler a => HandlerT a - -data Logger = Logger - { _lLevel :: Maybe Severity - , _lHandlers :: [HandlerT] - , _lName :: LoggerName - } deriving (Generic) - -makeLenses ''Logger - -type LogTree = Map LoggerName Logger - -data LogInternalState = LogInternalState - { liTree :: LogTree - , liPrefix :: Maybe FilePath - } deriving (Generic) - ---------------------------------------------------------------------------- --- Utilities ---------------------------------------------------------------------------- - --- | The name of the root logger, which is always defined and present --- on the system. -rootLoggerName :: LoggerName -rootLoggerName = mempty - ---------------------------------------------------------------------------- --- Logger Tree Storage ---------------------------------------------------------------------------- - --- | The log tree. Initialize it with a default root logger. -{-# NOINLINE logInternalState #-} -logInternalState :: MVar LogInternalState --- note: only kick up tree if handled locally -logInternalState = unsafePerformIO $ do - let liTree = M.singleton rootLoggerName $ - Logger { _lLevel = Just Warning - , _lName = "" - , _lHandlers = []} - liPrefix = Nothing - newMVar $ LogInternalState {..} - -{- | Given a name, return all components of it, starting from the root. -Example return value: - ->["", "MissingH", "System.Cmd.Utils", "System.Cmd.Utils.pOpen"] - --} -componentsOfName :: LoggerName -> [LoggerName] -componentsOfName (LoggerName name) = - rootLoggerName : (LoggerName <$> (joinComp (T.splitOn "." name) "")) - where - joinComp [] _ = [] - joinComp (x:xs) "" = x : joinComp xs x - joinComp (x:xs) accum = - let newlevel = accum <> "." <> x - in newlevel : joinComp xs newlevel - ---------------------------------------------------------------------------- --- Logging With Location ---------------------------------------------------------------------------- - --- | Log a message using the given logger at a given priority. -logM :: LoggerName -- ^ Name of the logger to use - -> Severity -- ^ Severity of this message - -> Text -- ^ The log text itself - -> IO () -logM logname pri msg = do - l <- getLogger logname - logL l pri msg - -logMCond :: LoggerName -> Severity -> Text -> (LogHandlerTag -> Bool) -> IO () -logMCond logname sev msg cond = do - l <- getLogger logname - logLCond l sev msg cond - ---------------------------------------------------------------------------- --- Utility functions ---------------------------------------------------------------------------- - -{- | Log a message at 'Debug' priority -} -debugM :: LoggerName -- ^ Logger name - -> Text -- ^ Log message - -> IO () -debugM s = logM s Debug - -{- | Log a message at 'Info' priority -} -infoM :: LoggerName -- ^ Logger name - -> Text -- ^ Log message - -> IO () -infoM s = logM s Info - -{- | Log a message at 'Notice' priority -} -noticeM :: LoggerName -- ^ Logger name - -> Text -- ^ Log message - -> IO () -noticeM s = logM s Notice - -{- | Log a message at 'Warning' priority -} -warningM :: LoggerName -- ^ Logger name - -> Text -- ^ Log message - -> IO () -warningM s = logM s Warning - -{- | Log a message at 'Error' priority -} -errorM :: LoggerName -- ^ Logger name - -> Text -- ^ Log message - -> IO () -errorM s = logM s Error - ---------------------------------------------------------------------------- --- Public Logger Interaction Support ---------------------------------------------------------------------------- - --- | Returns the logger for the given name. If no logger with that name --- exists, creates new loggers and any necessary parent loggers, with --- no connected handlers. -getLogger :: LoggerName -> IO Logger -getLogger lname = modifyMVar logInternalState $ \lt@LogInternalState{..} -> - case M.lookup lname liTree of - Just x -> return (lt, x) -- A logger exists; return it and leave tree - Nothing -> do - -- Add logger(s). Then call myself to retrieve it. - let newlt = createLoggers (componentsOfName lname) liTree - let result = fromJust $ M.lookup lname newlt - return (LogInternalState newlt liPrefix, result) - where - createLoggers :: [LoggerName] -> LogTree -> LogTree - createLoggers [] lt = lt -- No names to add; return tree unmodified - createLoggers (x:xs) lt = -- Add logger to tree - createLoggers xs $ - if M.member x lt - then lt - else M.insert x (defaultLogger & lName .~ x) lt - defaultLogger = Logger Nothing [] (error "log-warper has some strange code") -- ???!??! - --- | Returns the root logger. -getRootLogger :: IO Logger -getRootLogger = getLogger rootLoggerName - --- | Log a message, assuming the current logger's level permits it. -logL :: Logger -> Severity -> Text -> IO () -logL l pri msg = handle l (LR pri msg) (const True) - --- | Logs a message with condition. -logLCond :: Logger -> Severity -> Text -> (LogHandlerTag -> Bool) -> IO () -logLCond l pri msg = handle l (LR pri msg) - --- | Handle a log request. -handle :: Logger -> LogRecord -> (LogHandlerTag -> Bool) -> IO () -handle l lrecord@(LR sev _) handlerFilter = do - lp <- getLoggerSeverity nm - when (sev >= lp) $ do - ph <- concatMap (view lHandlers) <$> parentLoggers nm - forM_ ph $ callHandler lrecord nm - where - nm = view lName l - parentLoggers :: LoggerName -> IO [Logger] - parentLoggers = mapM getLogger . componentsOfName - -- Get the severity we should use. Find the first logger in the - -- tree, starting here, with a set severity. If even root doesn't - -- have one, assume "Debug". - getLoggerSeverity :: LoggerName -> IO Severity - getLoggerSeverity name = do - pl <- parentLoggers name - case catMaybes . map (view lLevel) $ (l : pl) of - [] -> pure Debug - (x:_) -> pure x - callHandler :: LogRecord -> LoggerName -> HandlerT -> IO () - callHandler lr loggername (HandlerT x) = - when (handlerFilter $ getTag x) $ - System.Wlog.Handler.handle x lr loggername - --- | Sets file prefix to 'LogInternalState'. -setPrefix :: Maybe FilePath -> IO () -setPrefix p = modifyMVar_ logInternalState $ \li -> pure $ li { liPrefix = p } - --- | Add handler to 'Logger'. Returns a new 'Logger'. -addHandler :: LogHandler a => a -> Logger -> Logger -addHandler h = lHandlers %~ (HandlerT h:) - --- | Remove a handler from the 'Logger'. Handlers are removed in the reverse --- order they were added, so the following property holds for any 'LogHandler' --- @h@: --- --- > removeHandler . addHandler h = id --- --- If no handlers are associated with the 'Logger', it is returned unchanged. --- --- The root logger's default handler that writes every message to stderr can --- be removed by using this function before any handlers have been added --- to the root logger: --- --- > updateGlobalLogger rootLoggerName removeHandler -removeHandler :: Logger -> Logger -removeHandler = lHandlers %~ drop 1 - --- | Set the 'Logger'\'s list of handlers to the list supplied. --- All existing handlers are removed first. -setHandlers :: LogHandler a => [a] -> Logger -> Logger -setHandlers hl = lHandlers .~ map HandlerT hl - --- | Returns the "level" of the logger. Items beneath this --- level will be ignored. -getLevel :: Logger -> Maybe Severity -getLevel = _lLevel - --- | Sets the "level" of the 'Logger'. Returns a new --- 'Logger' object with the new level. -setLevel :: Severity -> Logger -> Logger -setLevel p = lLevel .~ Just p - --- | Clears the "level" of the 'Logger'. It will now inherit the level of --- | its parent. -clearLevel :: Logger -> Logger -clearLevel = lLevel .~ Nothing - --- | Updates the global record for the given logger to take into --- account any changes you may have made. -saveGlobalLogger :: Logger -> IO () -saveGlobalLogger l = - modifyMVar_ logInternalState $ \LogInternalState{..} -> - pure $ LogInternalState (M.insert (view lName l) l liTree) liPrefix - --- | Helps you make changes on the given logger. Takes a function --- that makes changes and writes those changes back to the global --- database. Here's an example from above (\"s\" is a 'LogHandler'): --- --- > updateGlobalLogger "MyApp.BuggyComponent" --- > (setLevel DEBUG . setHandlers [s]) -updateGlobalLogger - :: LoggerName -- ^ Logger name - -> (Logger -> Logger) -- ^ Function to call - -> IO () -updateGlobalLogger ln func = - do l <- getLogger ln - saveGlobalLogger (func l) - --- | Allow graceful shutdown. Release all opened files/handlers/etc. -removeAllHandlers :: IO () -removeAllHandlers = - modifyMVar_ logInternalState $ \LogInternalState{..} -> do - let allHandlers = M.foldr (\l r -> concat [r, view lHandlers l]) [] liTree - mapM_ (\(HandlerT h) -> close h) allHandlers - let newTree = map (lHandlers .~ []) liTree - return $ LogInternalState newTree liPrefix - --- | Traps exceptions that may occur, logging them, then passing them on. --- --- Takes a logger name, priority, leading description text (you can set it to --- @\"\"@ if you don't want any), and action to run. -traplogging :: LoggerName -- ^ Logger name - -> Severity -- ^ Logging priority - -> Text -- ^ Descriptive text to prepend to logged messages - -> IO a -- ^ Action to run - -> IO a -- ^ Return value -traplogging logger priority desc action = action `catch` handler - where - realdesc = - case desc of - "" -> "" - x -> x <> ": " - handler :: SomeException -> IO a - handler e = do - logM logger priority (realdesc <> show e) - throwM e -- Re-raise it - ----------------------------------------------------------------------------- --- Retrieving logs ad-hoc ----------------------------------------------------------------------------- - --- | Retrieves content of log file(s) given path (w/o '_lcFilePrefix', --- as specified in your config). Example: there's @component.log@ in --- config, but this function will return @[component.log.122, --- component.log.123]@ if you want to. Content is file lines newest --- first. --- --- FYI: this function is implemented to avoid the following problem: --- log-warper holds open handles to files, so trying to open log file --- for read would result in 'IOException'. -retrieveLogContent :: (MonadIO m) => FilePath -> Maybe Int -> m [Text] -retrieveLogContent filePath linesNum = - liftIO $ withMVar logInternalState $ \LogInternalState{..} -> do - let filePathFull = fromMaybe "" liPrefix filePath - let appropriateHandlers = - filter (\(HandlerT h) -> getTag h == HandlerFilelike filePathFull) $ - concatMap _lHandlers $ - M.elems liTree - let takeMaybe = maybe identity take linesNum - case appropriateHandlers of - [HandlerT h] -> liftIO $ readBack h 12345 -- all of them - [] -> takeMaybe . reverse . T.lines <$> TIO.readFile filePathFull - xs -> error $ "Found more than one (" <> show (length xs) <> - "handle with the same filePath tag, impossible." diff --git a/src/System/Wlog/LoggerConfig.hs b/src/System/Wlog/LoggerConfig.hs --- a/src/System/Wlog/LoggerConfig.hs +++ b/src/System/Wlog/LoggerConfig.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} @@ -55,26 +54,26 @@ , termSeverityB ) where -import Universum +import Universum -import Control.Lens (at, makeLenses, zoom, _Just) -import Control.Monad.State (put) -import Data.Aeson (withObject) -import qualified Data.HashMap.Strict as HM hiding (HashMap) -import Data.Monoid (Any (..)) -import Data.Text (Text) -import qualified Data.Text.Buildable as Buildable -import Data.Traversable (for) -import Data.Word (Word64) -import Data.Yaml (FromJSON (..), ToJSON (..), Value (Object), - object, (.!=), (.:), (.:?), (.=)) -import Formatting (bprint, shown) -import GHC.Generics (Generic) -import System.FilePath (normalise) +import Control.Lens (at, makeLenses, zoom, _Just) +import Control.Monad.State (put) +import Data.Aeson (withObject) +import Data.Monoid (Any (..)) +import Data.Text (Text) +import Data.Traversable (for) +import Data.Word (Word64) +import Data.Yaml (FromJSON (..), ToJSON (..), Value (Object), object, (.!=), (.:), (.:?), (.=)) +import Formatting (bprint, shown) +import GHC.Generics (Generic) +import System.FilePath (normalise) -import System.Wlog.Handler.Simple (defaultHandleAction) -import System.Wlog.LoggerName (LoggerName) -import System.Wlog.Severity (Severity) +import System.Wlog.LoggerName (LoggerName) +import System.Wlog.LogHandler.Simple (defaultHandleAction) +import System.Wlog.Severity (Severity) + +import qualified Data.HashMap.Strict as HM hiding (HashMap) +import qualified Data.Text.Buildable as Buildable ---------------------------------------------------------------------------- -- Utilites & helpers diff --git a/src/System/Wlog/PureLogging.hs b/src/System/Wlog/PureLogging.hs --- a/src/System/Wlog/PureLogging.hs +++ b/src/System/Wlog/PureLogging.hs @@ -1,7 +1,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} @@ -25,18 +24,19 @@ , logPureAction ) where -import Universum +import Universum -import Control.Monad.Morph (MFunctor (..)) -import Control.Monad.State.Strict (modify') -import Control.Monad.Trans (MonadTrans (lift)) -import qualified Data.DList as DL (DList, snoc) +import Control.Monad.Morph (MFunctor (..)) +import Control.Monad.State.Strict (modify') +import Control.Monad.Trans (MonadTrans (lift)) -import System.Wlog.CanLog (CanLog (..), WithLogger) -import System.Wlog.HasLoggerName (HasLoggerName (..)) -import System.Wlog.LoggerName (LoggerName (..)) -import System.Wlog.LoggerNameBox (LoggerNameBox (..), usingLoggerName) -import System.Wlog.Severity (Severity (..)) +import System.Wlog.CanLog (CanLog (..), WithLogger) +import System.Wlog.HasLoggerName (HasLoggerName (..)) +import System.Wlog.LoggerName (LoggerName (..)) +import System.Wlog.LoggerNameBox (LoggerNameBox (..), usingLoggerName) +import System.Wlog.Severity (Severity (..)) + +import qualified Data.DList as DL (DList, snoc) -- | Holds all required information for 'dispatchLoggerName' function. data LogEvent = LogEvent diff --git a/src/System/Wlog/Severity.hs b/src/System/Wlog/Severity.hs --- a/src/System/Wlog/Severity.hs +++ b/src/System/Wlog/Severity.hs @@ -2,15 +2,25 @@ module System.Wlog.Severity ( Severity (..) + , Severities , LogRecord(..) + -- * Severity utilities + , allSeverities + , severityPlus + , debugPlus, infoPlus + , noticePlus + , warningPlus, errorPlus + , excludeError ) where -import Universum +import Universum -import Data.Typeable (Typeable) -import Data.Yaml (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Typeable (Typeable) +import Data.Yaml (FromJSON, ToJSON) +import GHC.Generics (Generic) +import qualified Data.Set as Set + -- | Severity is level of log message importance. It uniquely -- determines which messages to print. data Severity @@ -24,5 +34,40 @@ instance FromJSON Severity instance ToJSON Severity +-- | Set of 'Severity'. +type Severities = Set Severity + -- | Internal type of log records. data LogRecord = LR !Severity !Text deriving Show + +-- | 'Set' of all 'Severity's. +allSeverities :: Set Severity +allSeverities = Set.fromAscList [minBound .. maxBound] + +-- | Returns the 'Set' of 'Severity's of elements greater or equal to the given value. +severityPlus :: Severity -> Set Severity +severityPlus s = Set.fromAscList [s .. maxBound] + +-- | Returns 'Set' of 'Severity's not less than 'Debug'. +debugPlus :: Set Severity +debugPlus = severityPlus Debug + +-- | Returns 'Set' of 'Severity's not less than 'Info'. +infoPlus :: Set Severity +infoPlus = severityPlus Info + +-- | Returns 'Set' of 'Severity's not less than 'Notice'. +noticePlus :: Set Severity +noticePlus = severityPlus Notice + +-- | Returns 'Set' of 'Severity's not less than 'Warning'. +warningPlus :: Set Severity +warningPlus = severityPlus Warning + +-- | Returns 'Set' of 'Severity's not less than 'Error'. +errorPlus :: Set Severity +errorPlus = Set.singleton Error + +-- | Excludes 'Error' from the 'Set' of 'Severity's. +excludeError :: Set Severity -> Set Severity +excludeError = Set.delete Error diff --git a/src/System/Wlog/Terminal.hs b/src/System/Wlog/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/Terminal.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module : System.Wlog.Terminal +-- Copyright : (c) Serokell, 2016 +-- License : GPL-3 (see the file LICENSE) +-- Maintainer : Serokell +-- Stability : experimental +-- Portability : POSIX, GHC +-- +-- Logging functionality. This module is wrapper over +-- , +-- which allows to keep logger name in monadic context. + +module System.Wlog.Terminal + ( initTerminalLogging + ) where + +import Universum + +import Data.Time (UTCTime) +import System.IO (Handle, stderr, stdout) + +import System.Wlog.Formatter (stderrFormatter, stdoutFormatter) +import System.Wlog.IOLogger (rootLoggerName, setHandlers, setLevel, updateGlobalLogger) +import System.Wlog.LogHandler (LogHandler (setFormatter)) +import System.Wlog.LogHandler.Simple (streamHandler) +import System.Wlog.Severity (Severities, errorPlus, excludeError, warningPlus) + + +-- | This function initializes global logging system for terminal output. +-- At high level, it sets severity which will be used by all loggers by default, +-- sets default formatters and sets custom severity for given loggers (if any). +-- +-- NOTE: you probably don't want to use this function. +-- Consider 'System.Wlog.Launcher.setupLogging'. +-- +-- On a lower level it does the following: +-- 1. Removes default handler from root logger, sets two handlers such that: +-- 1.1. All messages are printed to /stdout/. +-- 1.2. Moreover messages with at least `Error` severity are +-- printed to /stderr/. +-- 2. Sets given Severity to root logger, so that it will be used by +-- descendant loggers by default. +-- 3. Applies `setSeverity` to given loggers. It can be done later using +-- `setSeverity` directly. +initTerminalLogging :: MonadIO m + => (UTCTime -> Text) + -> (Handle -> Text -> IO ()) + -> Bool -- ^ Show time? + -> Bool -- ^ Show ThreadId? + -> Maybe Severities + -> m () +initTerminalLogging + timeF + customConsoleAction + isShowTime + isShowTid + (fromMaybe (warningPlus) -> defaultSeverity) + = liftIO $ do + lock <- liftIO $ newMVar () + stdoutHandler <- setStdoutFormatter <$> + streamHandler stdout customConsoleAction lock (excludeError defaultSeverity) + stderrHandler <- setStderrFormatter <$> + streamHandler stderr customConsoleAction lock errorPlus + updateGlobalLogger rootLoggerName $ + setHandlers [stderrHandler, stdoutHandler] + updateGlobalLogger rootLoggerName $ + setLevel defaultSeverity + where + setStdoutFormatter = (`setFormatter` stdoutFormatter timeF isShowTime isShowTid) + setStderrFormatter = (`setFormatter` stderrFormatter timeF isShowTid) diff --git a/src/System/Wlog/Wrapper.hs b/src/System/Wlog/Wrapper.hs deleted file mode 100644 --- a/src/System/Wlog/Wrapper.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE ViewPatterns #-} - --- | --- Module : System.Wlog.Wrapper --- Copyright : (c) Serokell, 2016 --- License : GPL-3 (see the file LICENSE) --- Maintainer : Serokell --- Stability : experimental --- Portability : POSIX, GHC --- --- Logging functionality. This module is wrapper over --- , --- which allows to keep logger name in monadic context. - -module System.Wlog.Wrapper - ( Severity (..) - , initTerminalLogging - , releaseAllHandlers - , setSeverity - , setSeverityMaybe - ) where - -import Universum - -import Data.Time (UTCTime) -import System.IO (Handle, stderr, stdout) - -import System.Wlog.Formatter (stderrFormatter, stdoutFormatter) -import System.Wlog.Handler (LogHandler (setFormatter)) -import System.Wlog.Handler.Simple (GenericHandler (..), streamHandler) -import System.Wlog.Logger (clearLevel, removeAllHandlers, - rootLoggerName, setHandlers, setLevel, - updateGlobalLogger) -import System.Wlog.LoggerName (LoggerName (..)) -import System.Wlog.Severity (Severity (..)) - --- | Like `streamHandler`, but syncronized using given `MVar` as lock --- (it should be filled before this function call). -streamHandlerWithLock :: (Handle -> Text -> IO ()) - -> MVar () - -> Handle - -> Severity - -> IO (GenericHandler Handle) -streamHandlerWithLock customTerminalAction lock handle severity = - streamHandler handle customTerminalAction lock severity - --- | This function initializes global logging system for terminal output. --- At high level, it sets severity which will be used by all loggers by default, --- sets default formatters and sets custom severity for given loggers (if any). --- --- NOTE: you probably don't want to use this function. --- Consider 'System.Wlog.Launcher.setupLogging'. --- --- On a lower level it does the following: --- 1. Removes default handler from root logger, sets two handlers such that: --- 1.1. All messages are printed to /stdout/. --- 1.2. Moreover messages with at least `Error` severity are --- printed to /stderr/. --- 2. Sets given Severity to root logger, so that it will be used by --- descendant loggers by default. --- 3. Applies `setSeverity` to given loggers. It can be done later using --- `setSeverity` directly. -initTerminalLogging :: MonadIO m - => (UTCTime -> Text) - -> (Handle -> Text -> IO ()) - -> Bool -- ^ Show time? - -> Bool -- ^ Show ThreadId? - -> Maybe Severity - -> m () -initTerminalLogging - timeF - customConsoleAction - isShowTime - isShowTid - (fromMaybe Warning -> defaultSeverity) - = liftIO $ do - lock <- liftIO $ newMVar () - stdoutHandler <- setStdoutFormatter <$> - streamHandlerWithLock customConsoleAction lock stdout defaultSeverity - stderrHandler <- setStderrFormatter <$> - streamHandlerWithLock customConsoleAction lock stderr Error - updateGlobalLogger rootLoggerName $ - setHandlers [stderrHandler, stdoutHandler] - updateGlobalLogger rootLoggerName $ - setLevel defaultSeverity - where - setStdoutFormatter = (`setFormatter` stdoutFormatter timeF isShowTime isShowTid) - setStderrFormatter = (`setFormatter` stderrFormatter timeF isShowTid) - --- | Set severity for given logger. By default parent's severity is used. -setSeverity :: MonadIO m => LoggerName -> Severity -> m () -setSeverity name = - liftIO . updateGlobalLogger name . setLevel - --- | Set or clear severity. -setSeverityMaybe - :: MonadIO m - => LoggerName -> Maybe Severity -> m () -setSeverityMaybe name Nothing = - liftIO $ updateGlobalLogger name clearLevel -setSeverityMaybe n (Just x) = setSeverity n x - --- | Lifted alias to 'removeAllHandlers'. -releaseAllHandlers :: MonadIO m => m () -releaseAllHandlers = liftIO removeAllHandlers diff --git a/test/Test/Wlog/RollingSpec.hs b/test/Test/Wlog/RollingSpec.hs --- a/test/Test/Wlog/RollingSpec.hs +++ b/test/Test/Wlog/RollingSpec.hs @@ -4,29 +4,26 @@ ( spec ) where -import Universum +import Universum -import Control.Concurrent.Async (mapConcurrently) -import Control.Lens (zoom, (.=), (?=)) -import qualified Prelude (read) -import System.Directory (doesFileExist, removeFile) -import System.FilePath (takeExtension) -import System.IO (hFileSize) +import Control.Concurrent.Async (mapConcurrently) +import Control.Lens (zoom, (.=), (?=)) +import qualified Prelude (read) +import System.Directory (doesFileExist, removeFile) +import System.FilePath (takeExtension) +import System.IO (hFileSize) -import Test.Hspec (Spec, describe, it, shouldThrow) -import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) -import Test.HUnit.Base (assert) -import Test.QuickCheck (Arbitrary (..), Property, choose, (==>)) -import Test.QuickCheck.Monadic (PropertyM, monadicIO, run) +import Test.Hspec (Spec, describe, it, shouldThrow) +import Test.Hspec.QuickCheck (modifyMaxSuccess, prop) +import Test.HUnit.Base (assert) +import Test.QuickCheck (Arbitrary (..), Property, choose, (==>)) +import Test.QuickCheck.Monadic (PropertyM, monadicIO, run) -import System.Wlog (HandlerWrap (..), InvalidRotation (..), - LoggerConfig (..), RotationParameters (..), - Severity (..), fromScratch, isValidRotation, - lcFilePrefix, lcRotation, lcTree, logDebug, - logIndex, ltFiles, ltSeverity, - releaseAllHandlers, rotationFileHandler, - setupLogging, usingLoggerName, whenExist, - zoomLogger) +import System.Wlog (HandlerWrap (..), InvalidRotation (..), LoggerConfig (..), + RotationParameters (..), Severity (..), fromScratch, isValidRotation, + lcFilePrefix, lcRotation, lcTree, logDebug, logIndex, ltFiles, ltSeverity, + removeAllHandlers, rotationFileHandler, setupLogging, usingLoggerName, + whenExist, zoomLogger) spec :: Spec spec = do @@ -84,7 +81,7 @@ writeConcurrentLogs rp@RotationParameters{..} (getNumberOfLinesToLog -> linesNum) = bracket_ (setupLogging Nothing $ testLoggerConfig rp) - releaseAllHandlers + removeAllHandlers concurrentWriting where LoggerConfig{..} = testLoggerConfig rp