diff --git a/log-warper.cabal b/log-warper.cabal --- a/log-warper.cabal +++ b/log-warper.cabal @@ -1,142 +1,123 @@ -name: log-warper -version: 0.5.1 -synopsis: Flexible, configurable, monadic and pretty logging -homepage: https://github.com/serokell/log-warper -license: MIT -license-file: LICENSE -author: Serokell -maintainer: Serokell -copyright: 2016-2016 Serokell -category: Interfaces -stability: experimental -build-type: Simple -cabal-version: >=1.18 +name: log-warper +version: 1.0.0 +cabal-version: >=1.18 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: 2016-2016 Serokell +maintainer: Serokell +stability: experimental +homepage: https://github.com/serokell/log-warper +synopsis: Flexible, configurable, monadic and pretty logging description: This package contains nice wrapper around hslogger library. +category: Interfaces +author: Serokell -Flag PatakDebugSkovorodaBARDAQ - default: False - description: Enable debug support +flag patakdebugskovorodabardaq + description: + Enable debug support + default: False library - exposed-modules: System.Wlog - System.Wlog.CanLog - System.Wlog.FileUtils - System.Wlog.Launcher - System.Wlog.LoggerConfig - System.Wlog.LoggerName - System.Wlog.LoggerNameBox - System.Wlog.Roller - System.Wlog.Severity - System.Wlog.Wrapper - - other-modules: System.Wlog.Color - System.Wlog.Formatter - System.Wlog.MemoryQueue - - build-depends: aeson >= 0.11.2.1 - , ansi-terminal >= 0.6.2.3 - , base >= 4.7 && < 5 - , bytestring >= 0.10.8.1 - , containers - , directory >= 1.2.6.2 - , dlist >= 0.8.0.2 - , errors >= 2.1.2 - , exceptions >= 0.8.3 - , extra >= 1.4.10 - , filepath >= 1.4.1 - , formatting >= 6.2.2 - , hashable >= 1.2.4.0 - , hslogger >= 1.3.0 - , lens >= 4.14 - , monad-control >= 1.0.1.0 - , monad-loops - , mtl >= 2.2.1 - , safecopy >= 0.9.1 - , text >= 1.2.2.0 - , text-format >= 0.3.1.1 - , time >= 1.6.0.1 - , transformers >= 0.5.2 - , transformers-base >= 0.4.4 - , universum - , unordered-containers >= 0.2.7.1 - , yaml >= 0.8.20 - - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -fno-warn-orphans - - default-extensions: GeneralizedNewtypeDeriving - DeriveDataTypeable - DeriveGeneric - OverloadedStrings - TypeApplications - RecordWildCards - - if flag(PatakDebugSkovorodaBARDAQ) - cpp-options: -DPatakDebugSkovorodaBARDAQ + + if !os(windows) + build-depends: + unix >=2.7.2.0 && <2.8 + + if flag(patakdebugskovorodabardaq) + cpp-options: -DPatakDebugSkovorodaBARDAQ + exposed-modules: + System.Wlog + System.Wlog.CanLog + System.Wlog.FileUtils + System.Wlog.Formatter + System.Wlog.Handler + System.Wlog.Handler.Simple + System.Wlog.Handler.Syslog + System.Wlog.Launcher + System.Wlog.Logger + System.Wlog.LoggerConfig + System.Wlog.LoggerName + System.Wlog.LoggerNameBox + System.Wlog.Roller + System.Wlog.Severity + System.Wlog.Wrapper + build-depends: + aeson >=0.11.2.1 && <0.12, + ansi-terminal >=0.6.2.3 && <0.7, + base >=4.7 && <5, + bytestring >=0.10.8.1 && <0.11, + containers >=0.5.7.0 && <0.6, + directory >=1.2.6.2 && <1.3, + dlist >=0.8.0.2 && <0.9, + errors >=2.1.2 && <2.2, + exceptions >=0.8.3 && <0.9, + extra >=1.4.10 && <1.5, + filepath >=1.4.1 && <1.5, + formatting >=6.2.2 && <6.3, + hashable >=1.2.4.0 && <1.3, + lens ==4.14.*, + monad-control >=1.0.1.0 && <1.1, + monad-loops >=0.4.3 && <0.5, + mtl >=2.2.1 && <2.3, + network >=2.6.3.1 && <2.7, + safecopy >=0.9.1 && <0.10, + text >=1.2.2.0 && <1.3, + text-format >=0.3.1.1 && <0.4, + time >=1.6.0.1 && <1.7, + transformers >=0.5.2 && <0.6, + transformers-base >=0.4.4 && <0.5, + universum ==0.2.*, + unordered-containers >=0.2.7.1 && <0.3, + yaml >=0.8.20 && <0.9 + default-language: Haskell2010 + default-extensions: GeneralizedNewtypeDeriving DeriveDataTypeable + DeriveGeneric OverloadedStrings TypeApplications RecordWildCards + hs-source-dirs: src + other-modules: + System.Wlog.Color + System.Wlog.MemoryQueue + ghc-options: -Wall -fno-warn-orphans executable play-log - main-is: Playground.hs - - build-depends: base >= 4.7 && < 5 - , exceptions >= 0.8.2.1 - , hslogger >= 1.3.0 - , log-warper - , text >= 1.2.2.1 - - hs-source-dirs: examples - default-language: Haskell2010 - ghc-options: -threaded -Wall -fno-warn-orphans - - default-extensions: GeneralizedNewtypeDeriving - DeriveDataTypeable - DeriveGeneric - OverloadedStrings - TypeApplications - RecordWildCards + main-is: Playground.hs + build-depends: + base >=4.7 && <5, + exceptions >=0.8.2.1 && <0.9, + log-warper >=1.0.0 && <1.1, + text >=1.2.2.1 && <1.3 + default-language: Haskell2010 + default-extensions: GeneralizedNewtypeDeriving DeriveDataTypeable + DeriveGeneric OverloadedStrings TypeApplications RecordWildCards + hs-source-dirs: examples + ghc-options: -threaded -Wall -fno-warn-orphans test-suite log-test - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Test.hs - other-modules: Spec - Test.Wlog.RollingSpec - - build-depends: async - , base - , data-default - , directory - , filepath - , hspec - , HUnit - , lens - , log-warper - , QuickCheck - , universum - , unordered-containers - - default-language: Haskell2010 - ghc-options: -threaded - -rtsopts - -Wall - -fno-warn-orphans - -with-rtsopts=-N - - default-extensions: DeriveDataTypeable - DeriveGeneric - GeneralizedNewtypeDeriving - StandaloneDeriving - FlexibleContexts - FlexibleInstances - MultiParamTypeClasses - FunctionalDependencies - DefaultSignatures - NoImplicitPrelude - OverloadedStrings - RecordWildCards - TypeApplications - TupleSections - ViewPatterns - LambdaCase - MultiWayIf + type: exitcode-stdio-1.0 + main-is: Test.hs + build-depends: + async >=2.1.1 && <2.2, + base >=4.9.1.0 && <4.10, + data-default >=0.7.1.1 && <0.8, + directory >=1.2.6.2 && <1.3, + filepath >=1.4.1.0 && <1.5, + hspec >=2.2.4 && <2.3, + HUnit >=1.3.1.2 && <1.4, + lens ==4.14.*, + log-warper >=1.0.0 && <1.1, + QuickCheck >=2.8.2 && <2.9, + universum >=0.2.1 && <0.3, + unordered-containers >=0.2.7.2 && <0.3 + default-language: Haskell2010 + default-extensions: DeriveDataTypeable DeriveGeneric + GeneralizedNewtypeDeriving StandaloneDeriving FlexibleContexts + FlexibleInstances MultiParamTypeClasses FunctionalDependencies + DefaultSignatures NoImplicitPrelude OverloadedStrings + RecordWildCards TypeApplications TupleSections ViewPatterns + LambdaCase MultiWayIf + hs-source-dirs: test + other-modules: + Spec + Test.Wlog.RollingSpec + ghc-options: -threaded -rtsopts -Wall -fno-warn-orphans -with-rtsopts=-N diff --git a/src/System/Wlog.hs b/src/System/Wlog.hs --- a/src/System/Wlog.hs +++ b/src/System/Wlog.hs @@ -15,6 +15,7 @@ ( module System.Wlog.CanLog , module System.Wlog.FileUtils , module System.Wlog.Launcher + , module System.Wlog.Logger , module System.Wlog.LoggerConfig , module System.Wlog.LoggerName , module System.Wlog.LoggerNameBox @@ -26,6 +27,7 @@ import System.Wlog.CanLog import System.Wlog.FileUtils import System.Wlog.Launcher +import System.Wlog.Logger import System.Wlog.LoggerConfig import System.Wlog.LoggerName import System.Wlog.LoggerNameBox 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 @@ -13,7 +13,6 @@ -- | Type class that add ability to log messages. -- Supports pure and IO logging. - module System.Wlog.CanLog ( CanLog (..) , WithLogger @@ -35,34 +34,25 @@ , logMessage ) where -import Control.Concurrent (MVar, modifyMVar_, newMVar) import Control.Monad.Base (MonadBase) import Control.Monad.Except (ExceptT, MonadError) -import Control.Monad.Reader (MonadReader, ReaderT) import qualified Control.Monad.RWS as RWSLazy import qualified Control.Monad.RWS.Strict as RWSStrict -import Control.Monad.State (MonadState, StateT) import Control.Monad.Trans (MonadTrans (lift)) import Control.Monad.Writer (MonadWriter (tell), WriterT (runWriterT)) - -import Data.Bifunctor (second) import qualified Data.DList as DL (DList) import Data.SafeCopy (base, deriveSafeCopySimple) -import Data.Text (Text) -import qualified Data.Text as T import Data.Time (getCurrentTime) - import System.IO.Unsafe (unsafePerformIO) -import System.Log.Logger (logM) - import Universum import System.Wlog.Formatter (formatLogMessageColors, getRoundedTime) +import System.Wlog.Logger (logM) import System.Wlog.LoggerName (LoggerName (..)) import System.Wlog.LoggerNameBox (HasLoggerName (..), LoggerNameBox (..)) import System.Wlog.MemoryQueue (MemoryQueue) import qualified System.Wlog.MemoryQueue as MQ -import System.Wlog.Severity (Severity (..), convertSeverity) +import System.Wlog.Severity (Severity (..)) -- | Type alias for constraints 'CanLog' and 'HasLoggerName'. @@ -97,11 +87,7 @@ liftIO (readMVar memoryLogs) <&> maybe (pure []) (MQ.toList . fst) instance CanLog IO where - dispatchMessage - (loggerName -> name) - (convertSeverity -> prior) - msg - = logM name prior (T.unpack msg) + dispatchMessage (loggerName -> name) prior msg = logM name prior msg instance CanLog m => CanLog (LoggerNameBox m) instance CanLog m => CanLog (ReaderT r m) diff --git a/src/System/Wlog/Color.hs b/src/System/Wlog/Color.hs --- a/src/System/Wlog/Color.hs +++ b/src/System/Wlog/Color.hs @@ -11,29 +11,35 @@ module System.Wlog.Color ( colorizer + , colorizerT ) where -import System.Console.ANSI (Color (Blue, Green, Magenta, Red, Yellow), - ColorIntensity (Vivid), ConsoleLayer (Foreground), - SGR (Reset, SetColor), setSGRCode) +import qualified Data.Text as T +import System.Console.ANSI (Color (Blue, Green, Magenta, Red, Yellow), + ColorIntensity (Vivid), ConsoleLayer (Foreground), + SGR (Reset, SetColor), setSGRCode) +import Universum -import System.Log.Logger (Priority (DEBUG, ERROR, INFO, NOTICE, WARNING)) +import System.Wlog.Severity (Severity (..)) -- | Defines pre- and post-printed characters for printing colorized text. -table :: Priority -> (String, String) -table priority = case priority of - ERROR -> (setColor Red , reset) - DEBUG -> (setColor Green , reset) - NOTICE -> (setColor Magenta , reset) - WARNING -> (setColor Yellow , reset) - INFO -> (setColor Blue , reset) - _ -> ("", "") +table :: Severity -> (String, String) +table severity = case severity of + Error -> (setColor Red , reset) + Debug -> (setColor Green , reset) + Notice -> (setColor Magenta , reset) + Warning -> (setColor Yellow , reset) + Info -> (setColor Blue , reset) where setColor color = setSGRCode [SetColor Foreground Vivid color] reset = setSGRCode [Reset] --- | Colorizes text. -colorizer :: Priority -> String -> String -colorizer pr s = before ++ s ++ after - where - (before, after) = table pr +-- | Colorizes string text. +colorizer :: Severity -> String -> String +colorizer pr s = + let (before, after) = table pr in before <> s <> after + +-- | Colorizes "Text". +colorizerT :: Severity -> Text -> Text +colorizerT pr s = + let (before, after) = table pr in T.pack before <> s <> T.pack after 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,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : System.Wlog.Formatter @@ -8,34 +10,145 @@ -- Stability : experimental -- Portability : POSIX, GHC -- --- This module contains pretty looking formatters for logger. - +-- Pretty looking formatters for logger. +-- +-- Please see "System.WLog.Logger" for extensive documentation on the +-- logging system. module System.Wlog.Formatter ( formatLogMessage , formatLogMessageColors - , setStderrFormatter - , setStdoutFormatter + , stdoutFormatter + , stderrFormatter , stdoutFormatterTimeRounded , getRoundedTime + + -- * Taken from @hslogger@. + , LogFormatter + , nullFormatter + , simpleLogFormatter + , tfLogFormatter + , varFormatter ) where +import Data.List (span) import Data.Monoid (mconcat) import Data.String (IsString) -import Data.Text (Text, pack, unpack) -import Data.Time.Clock (UTCTime (..), getCurrentTime) -import Data.Time.Format (defaultTimeLocale, formatTime) +import qualified Data.Text as T +import Data.Time (formatTime, getCurrentTime, getZonedTime) +import Data.Time.Clock (UTCTime (..)) +import Data.Time.Format (FormatTime) import Formatting (Format, sformat, shown, stext, (%)) - -import System.Log.Formatter (LogFormatter, simpleLogFormatter) -import System.Log.Handler (LogHandler (setFormatter)) -import System.Log.Logger (Priority (ERROR)) +import Universum +#ifndef mingw32_HOST_OS +import System.Posix.Process (getProcessID) +#endif +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (defaultTimeLocale) +#else +import System.Locale (defaultTimeLocale) +#endif -import System.Wlog.Color (colorizer) +import System.Wlog.Color (colorizer, colorizerT) import System.Wlog.LoggerName (LoggerName, loggerNameF) -import System.Wlog.Severity (Severity, convertSeverity) +import System.Wlog.Severity (LogRecord, Severity (..)) -import Universum +---------------------------------------------------------------------------- +-- Basic formatting functionality (initially taken from hslogger) +---------------------------------------------------------------------------- + +-- | A LogFormatter is used to format log messages. Note that it is +-- paramterized on the 'Handler' to allow the formatter to use +-- information specific to the handler (an example of can be seen in +-- the formatter used in 'System.Log.Handler.Syslog') +type LogFormatter a + = a -- ^ The LogHandler that the passed message came from + -> LogRecord -- ^ The log message and priority + -> String -- ^ The logger name + -> IO Text -- ^ The formatted log message + +-- | Returns the passed message as is, ie. no formatting is done. +nullFormatter :: LogFormatter a +nullFormatter _ (_,msg) _ = pure msg + +-- | Replace some '$' variables in a string with supplied values +replaceVarM + :: [(String, IO Text)] -- ^ A list of (variableName, action to + -- get the replacement string) pairs + -> String -- ^ String to perform substitution on + -> IO Text -- ^ Resulting string +replaceVarM _ [] = pure "" +replaceVarM keyVals (span (/= '$') -> (before,after)) = do + if null after then pure $ T.pack before + else do + (f, rest) <- replaceStart keyVals $ drop 1 after + repRest <- replaceVarM keyVals rest + pure $ T.pack before <> f <> repRest + where + replaceStart [] str = return ("$", str) + replaceStart ((k, v):kvs) str + | k `isPrefixOf` str = do + vs <- v + return (vs, drop (length k) str) + | otherwise = replaceStart kvs str + +-- | An extensible formatter that allows new substition /variables/ to +-- be defined. Each variable has an associated IO action that is used +-- to produce the string to substitute for the variable name. The +-- predefined variables are the same as for 'simpleLogFormatter' +-- /excluding/ @$time@ and @$utcTime@. +varFormatter :: [(String, IO Text)] -> String -> LogFormatter a +varFormatter vars format _h (prio,msg) loggername = do + replaceVarM (vars ++ predefinedVars) format + where + predefinedVars = [ ("msg", pure msg) + , ("prio", pure $ show prio) + , ("loggername", pure $ T.pack loggername) + , ("tid", show <$> myThreadId) +#ifndef mingw32_HOST_OS + , ("pid", show <$> getProcessID) +#endif + ] + + +-- | Like 'simpleLogFormatter' but allow the time format to be +-- specified in the first parameter (this is passed to +-- 'Date.Time.Format.formatTime') +tfLogFormatter :: String -> String -> LogFormatter a +tfLogFormatter timeFormat format = do + let ftime :: FormatTime t => t -> Text + ftime = T.pack . formatTime defaultTimeLocale timeFormat + varFormatter [ ("time", ftime <$> getZonedTime) + , ("utcTime", ftime <$> getCurrentTime) + ] + format + +-- | Takes a format string, and returns a formatter that may be used +-- to format log messages. The format string may contain variables +-- prefixed with a $-sign which will be replaced at runtime with +-- corresponding values. The currently supported variables are: +-- +-- * @$msg@ - The actual log message +-- +-- * @$loggername@ - The name of the logger +-- +-- * @$prio@ - The priority level of the message +-- +-- * @$tid@ - The thread ID +-- +-- * @$pid@ - Process ID (Not available on windows) +-- +-- * @$time@ - The current time +-- +-- * @$utcTime@ - The current time in UTC Time +simpleLogFormatter :: String -> LogFormatter a +simpleLogFormatter format h (prio, msg) loggername = + tfLogFormatter "%F %X %Z" format h (prio,msg) loggername + +---------------------------------------------------------------------------- +-- Log-warper functionality +---------------------------------------------------------------------------- + timeFmt :: IsString s => s timeFmt = "[$time] " @@ -54,9 +167,9 @@ stderrFormatter :: LogFormatter a stderrFormatter = simpleLogFormatter $ - mconcat [colorizer ERROR "[$loggername:$prio:$tid] ", timeFmt, "$msg"] + mconcat [colorizer Error "[$loggername:$prio:$tid] ", timeFmt, "$msg"] -stdoutFmt :: Priority -> Bool -> String +stdoutFmt :: Severity -> Bool -> String stdoutFmt pr isShowTime = mconcat [colorizer pr "[$loggername:$prio:$tid] ", timeFmtStdout isShowTime, "$msg"] @@ -74,12 +187,6 @@ , formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S %Z" time , "] $msg"] -setStdoutFormatter :: LogHandler h => Bool -> h -> h -setStdoutFormatter isShowTime = (`setFormatter` stdoutFormatter isShowTime) - -setStderrFormatter :: LogHandler h => h -> h -setStderrFormatter = (`setFormatter` stderrFormatter) - -- TODO: do we need coloring here? formatLogMessage :: LoggerName -> Severity -> UTCTime -> Text -> Text formatLogMessage = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"] "%stext) @@ -90,9 +197,8 @@ -- | Same as 'formatLogMessage', but with colorful output formatLogMessageColors :: LoggerName -> Severity -> UTCTime -> Text -> Text formatLogMessageColors lname severity time msg = - pack (colorizer pr $ unpack prefix) <> " " <> msg + colorizerT severity prefix <> " " <> msg where - pr = convertSeverity severity prefix = sformat ("["%loggerNameF%":"%shown%"] ["%utcTimeF%"]") lname severity time utcTimeF :: Format r (UTCTime -> r) utcTimeF = shown diff --git a/src/System/Wlog/Handler.hs b/src/System/Wlog/Handler.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/Handler.hs @@ -0,0 +1,65 @@ +{-# 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 + LogHandler(..) + ) where + +import System.Wlog.Formatter (LogFormatter, nullFormatter) +import System.Wlog.Severity (LogRecord, Severity) + +-- | 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 identication. + getTag :: a -> String + + -- | 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 -> String -> IO () + handle h (pri, msg) logname = + if pri >= (getLevel h) + then do formattedMsg <- (getFormatter h) h (pri,msg) logname + emit h (pri, formattedMsg) logname + else return () + + -- | Forces an event to be logged regardless of + -- the configured level. + emit :: a -> LogRecord -> String -> IO () + + -- | Closes the logging system, causing it to close + -- any open files, etc. + close :: a -> IO () diff --git a/src/System/Wlog/Handler/Simple.hs b/src/System/Wlog/Handler/Simple.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/Handler/Simple.hs @@ -0,0 +1,100 @@ +{-# 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 + ( streamHandler + , fileHandler + , GenericHandler(..) + , verboseStreamHandler + ) where + +import Control.Exception (SomeException) +import Data.Maybe (fromMaybe) +import qualified Data.Text.IO as TIO +import Data.Typeable (Typeable) +import System.IO (hClose, hFlush) +import Universum + +import System.Wlog.Formatter (LogFormatter, nullFormatter, simpleLogFormatter) +import System.Wlog.Handler (LogHandler (..)) +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 () + , ghTag :: Maybe String + } deriving Typeable + +instance Typeable a => LogHandler (GenericHandler a) where + getTag = fromMaybe "GenericHandler" . ghTag + setLevel sh s = sh {severity = s} + getLevel sh = severity sh + setFormatter sh f = sh{formatter = f} + getFormatter sh = formatter sh + emit sh (_,msg) _ = (writeFunc sh) (privData sh) msg + close sh = (closeFunc sh) (privData sh) + +-- | 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 -> Severity -> IO (GenericHandler Handle) +streamHandler h sev = do + lock <- newMVar () + let mywritefunc hdl msg = + withMVar lock (const $ writeToHandle hdl msg >> hFlush hdl) + return + GenericHandler + { severity = sev + , formatter = nullFormatter + , privData = h + , writeFunc = mywritefunc + , closeFunc = const $ pure () + , ghTag = Just "streamHandler" + } + where + writeToHandle hdl msg = + TIO.hPutStrLn hdl msg `catch` (handleWriteException hdl msg) + handleWriteException :: Handle -> Text -> SomeException -> IO () + handleWriteException hdl msg e = + let msg' = + "Error writing log message: " <> + show e <> " (original message: " <> msg <> ")" + in TIO.hPutStrLn hdl msg' + +-- | 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 + h <- openFile fp AppendMode + sh <- streamHandler h sev + return (sh {closeFunc = hClose, ghTag = Just ("fileHandler:" ++ fp)}) + +-- | Like 'streamHandler', but note the priority and logger name along +-- with each message. +verboseStreamHandler :: Handle -> Severity -> IO (GenericHandler Handle) +verboseStreamHandler h sev = + let fmt = simpleLogFormatter "[$loggername/$prio] $msg" + in do hndlr <- streamHandler h sev + return $ setFormatter hndlr fmt diff --git a/src/System/Wlog/Handler/Syslog.hs b/src/System/Wlog/Handler/Syslog.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/Handler/Syslog.hs @@ -0,0 +1,302 @@ +{-# 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 () +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +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.IO as TIO +import System.IO () +import Universum hiding (Option, identity) + +import System.Wlog.Formatter (LogFormatter, varFormatter) +import System.Wlog.Handler (LogHandler (..)) +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 (panic "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 (p,msg) logname = + let format = "[$loggername/$prio] $msg" + in varFormatter [] format sh (p,msg) logname + + +instance LogHandler SyslogHandler where + getTag = const "SyslogHandlerTag" + setLevel sh p = sh{priority = p} + getLevel sh = priority sh + setFormatter sh f = sh{formatter = f} + getFormatter sh = formatter sh + emit sh (prio, msg) _ = do + when (elem PERROR (options sh)) (TIO.hPutStrLn stderr msg) + pidPart <- getPidPart + void $ sendstr (toSyslogFormat msg pidPart) + where + 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 -> + panic $ "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/Launcher.hs b/src/System/Wlog/Launcher.hs --- a/src/System/Wlog/Launcher.hs +++ b/src/System/Wlog/Launcher.hs @@ -32,43 +32,34 @@ , setupLogging ) where -import Universum - #if PatakDebugSkovorodaBARDAQ -import qualified Data.ByteString.Char8 as BS (putStrLn) -import Data.Yaml.Pretty (defConfig, encodePretty) +import qualified Data.ByteString.Char8 as BS (putStrLn) +import Data.Yaml.Pretty (defConfig, encodePretty) #endif - -import Control.Error.Util ((?:)) -import Control.Exception (throwIO) -import Control.Monad (join, when) -import Control.Monad.IO.Class (MonadIO (liftIO)) - -import qualified Data.HashMap.Strict as HM hiding (HashMap) -import Data.List (isSuffixOf) -import Data.Monoid ((<>)) -import Data.Text (unpack) -import Data.Yaml (decodeFileEither) - -import System.Directory (createDirectoryIfMissing) -import System.FilePath (()) -import System.Log (Priority) -import System.Log.Handler (LogHandler (setFormatter)) -import System.Log.Handler.Simple (fileHandler) -import System.Log.Logger (addHandler, updateGlobalLogger) +import Control.Error.Util ((?:)) +import Control.Exception (throwIO) +import qualified Data.HashMap.Strict as HM hiding (HashMap) +import Data.List (isSuffixOf) +import qualified Data.Text as T +import Data.Yaml (decodeFileEither) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (()) +import Universum -import System.Wlog.CanLog (memoryLogs) -import System.Wlog.Formatter (setStdoutFormatter, - stdoutFormatterTimeRounded) -import System.Wlog.LoggerConfig (LoggerConfig (..), LoggerTree (..)) -import System.Wlog.LoggerName (LoggerName (..)) -import System.Wlog.MemoryQueue (newMemoryQueue) -import System.Wlog.Roller (rotationFileHandler) -import System.Wlog.Wrapper (Severity (Debug), convertSeverity, - initTerminalLogging, setSeverityMaybe) +import System.Wlog.CanLog (memoryLogs) +import System.Wlog.Formatter (stdoutFormatter, stdoutFormatterTimeRounded) +import System.Wlog.Handler (LogHandler (setFormatter)) +import System.Wlog.Handler.Simple (fileHandler) +import System.Wlog.Logger (addHandler, updateGlobalLogger) +import System.Wlog.LoggerConfig (LoggerConfig (..), LoggerTree (..)) +import System.Wlog.LoggerName (LoggerName (..)) +import System.Wlog.MemoryQueue (newMemoryQueue) +import System.Wlog.Roller (rotationFileHandler) +import System.Wlog.Wrapper (Severity (Debug), initTerminalLogging, + setSeverityMaybe) data HandlerFabric - = forall h . LogHandler h => HandlerFabric (FilePath -> Priority -> IO h) + = forall h . LogHandler h => HandlerFabric (FilePath -> Severity -> IO h) -- | This function traverses 'LoggerConfig' initializing all subloggers -- with 'Severity' and redirecting output in file handlers. @@ -101,12 +92,12 @@ setSeverityMaybe parent _ltSeverity forM_ _ltFiles $ \fileName -> liftIO $ do - let filePriority = convertSeverity $ _ltSeverity ?: Debug + let fileSeverity = _ltSeverity ?: Debug let handlerPath = handlerPrefix fileName case handlerFabric of HandlerFabric fabric -> do - let handlerCreator = fabric handlerPath filePriority - let defFmt = setStdoutFormatter isShowTime + let handlerCreator = fabric handlerPath fileSeverity + let defFmt = (`setFormatter` stdoutFormatter isShowTime) let roundFmt r = (`setFormatter` stdoutFormatterTimeRounded r) let fmt = maybe defFmt (\r -> if ".pub" `isSuffixOf` fileName then roundFmt r @@ -115,7 +106,7 @@ updateGlobalLogger (loggerName parent) $ addHandler thisLoggerHandler for_ (HM.toList _ltSubloggers) $ \(name, loggerConfig) -> do - let thisLoggerName = LoggerName $ unpack name + let thisLoggerName = LoggerName $ T.unpack name let thisLogger = parent <> logMapper thisLoggerName processLoggers thisLogger loggerConfig diff --git a/src/System/Wlog/Logger.hs b/src/System/Wlog/Logger.hs new file mode 100644 --- /dev/null +++ b/src/System/Wlog/Logger.hs @@ -0,0 +1,353 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE NoImplicitPrelude #-} + +{- | + 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 + ) where + +import Data.List (isPrefixOf) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +--import System.IO +import System.IO.Unsafe (unsafePerformIO) +import System.Wlog.Handler (LogHandler (getTag), close) +import qualified System.Wlog.Handler (handle) +import System.Wlog.Handler.Simple (streamHandler) +import System.Wlog.Severity (LogRecord, Severity (..)) +import Universum + + +--------------------------------------------------------------------------- +-- Basic logger types +--------------------------------------------------------------------------- + +data HandlerT = forall a. LogHandler a => HandlerT a + +data Logger = Logger + { level :: Maybe Severity + , handlers :: [HandlerT] + , name :: String + } + +type LogTree = Map.Map String Logger + +--------------------------------------------------------------------------- +-- Utilities +--------------------------------------------------------------------------- + +-- | The name of the root logger, which is always defined and present +-- on the system. +rootLoggerName :: String +rootLoggerName = "" + +--------------------------------------------------------------------------- +-- Logger Tree Storage +--------------------------------------------------------------------------- + +-- | The log tree. Initialize it with a default root logger +-- and (FIXME) a logger for MissingH itself. +{-# NOINLINE logTree #-} +logTree :: MVar LogTree +-- note: only kick up tree if handled locally +logTree = unsafePerformIO $ do + h <- streamHandler stderr Debug + newMVar $ + Map.singleton rootLoggerName $ + Logger {level = Just Warning, name = "", handlers = [HandlerT h]} + + +{- | Given a name, return all components of it, starting from the root. +Example return value: + +>["", "MissingH", "System.Cmd.Utils", "System.Cmd.Utils.pOpen"] + +-} +componentsOfName :: String -> [String] +componentsOfName name = + let joinComp [] _ = [] + joinComp (x:xs) [] = x : joinComp xs x + joinComp (x:xs) accum = + let newlevel = accum ++ "." ++ x + in newlevel : joinComp xs newlevel + in rootLoggerName : joinComp (split "." name) [] + +--------------------------------------------------------------------------- +-- Logging With Location +--------------------------------------------------------------------------- + +-- | Log a message using the given logger at a given priority. +logM :: String -- ^ 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 :: String -> Severity -> Text -> (String -> 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 :: String -- ^ Logger name + -> Text -- ^ Log message + -> IO () +debugM s = logM s Debug + +{- | Log a message at 'INFO' priority -} +infoM :: String -- ^ Logger name + -> Text -- ^ Log message + -> IO () +infoM s = logM s Info + +{- | Log a message at 'NOTICE' priority -} +noticeM :: String -- ^ Logger name + -> Text -- ^ Log message + -> IO () +noticeM s = logM s Notice + +{- | Log a message at 'WARNING' priority -} +warningM :: String -- ^ Logger name + -> Text -- ^ Log message + -> IO () +warningM s = logM s Warning + +{- | Log a message at 'ERROR' priority -} +errorM :: String -- ^ 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 :: String -> IO Logger +getLogger lname = modifyMVar logTree $ \lt -> case Map.lookup lname lt 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) lt + let result = fromJust $ Map.lookup lname newlt + return (newlt, result) + where + createLoggers :: [String] -> LogTree -> LogTree + createLoggers [] lt = lt -- No names to add; return tree unmodified + createLoggers (x:xs) lt = -- Add logger to tree + if Map.member x lt + then createLoggers xs lt + else createLoggers xs + (Map.insert x (defaultLogger {name=x}) lt) + defaultLogger = Logger Nothing [] undefined -- ???!??! + +-- | 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 (pri, msg) (const True) + +-- | Logs a message with condition. +logLCond :: Logger -> Severity -> Text -> (String -> Bool) -> IO () +logLCond l pri msg = handle l (pri, msg) + +-- | Handle a log request. +handle :: Logger -> LogRecord -> (String -> Bool) -> IO () +handle l lrecord@(sev, _) handlerFilter = do + lp <- getLoggerSeverity (name l) + if sev >= lp then do + ph <- parentHandlers (name l) + forM_ ph $ callHandler lrecord (name l) + else return () + where + parentLoggers :: String -> IO [Logger] + parentLoggers [] = return [] + parentLoggers name = + let pname0 = (head . drop 1 . reverse . componentsOfName) name + pname = fromMaybe (panic "Logger.handle.parentLoggers: pname head failed") pname0 + in do parent <- getLogger pname + next <- parentLoggers pname + return (parent : next) + parentHandlers :: String -> IO [HandlerT] + parentHandlers name = do + parentLoggers name >>= (return . concatMap handlers) + -- 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 :: String -> IO Severity + getLoggerSeverity name = do + pl <- parentLoggers name + case catMaybes . map level $ (l : pl) of + [] -> pure Debug + (x:_) -> pure x + callHandler :: LogRecord -> String -> HandlerT -> IO () + callHandler lr loggername (HandlerT x) = + when (handlerFilter $ getTag x) $ + System.Wlog.Handler.handle x lr loggername + + +-- | Add handler to 'Logger'. Returns a new 'Logger'. +addHandler :: LogHandler a => a -> Logger -> Logger +addHandler h l= l{handlers = (HandlerT h) : (handlers l)} + +-- | 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 l = l { handlers = drop 1 $ handlers l } + +-- | 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 l = + l{handlers = map (\h -> HandlerT h) hl} + +-- | Returns the "level" of the logger. Items beneath this +-- level will be ignored. +getLevel :: Logger -> Maybe Severity +getLevel = level + +-- | Sets the "level" of the 'Logger'. Returns a new +-- 'Logger' object with the new level. +setLevel :: Severity -> Logger -> Logger +setLevel p l = l {level = Just p} + +-- | Clears the "level" of the 'Logger'. It will now inherit the level of +-- | its parent. +clearLevel :: Logger -> Logger +clearLevel l = l {level = 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_ logTree + (\lt -> return $ Map.insert (name l) l lt) + +-- | 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 + :: String -- ^ 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_ logTree $ \lt -> do + let allHandlers = Map.fold (\l r -> concat [r, handlers l]) [] lt + mapM_ (\(HandlerT h) -> close h) allHandlers + return $ Map.map (\l -> l {handlers = []}) lt + +-- | 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 :: String -- ^ 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 + +-- | This function pulled in from MissingH to avoid a dep on it +split :: Eq a => [a] -> [a] -> [[a]] +split _ [] = [] +split delim str = + let (firstline, remainder) = breakList (isPrefixOf delim) str + in firstline : + case remainder of + [] -> [] + x | x == delim -> [] : [] + | otherwise -> split delim (drop (length delim) x) + +-- This function also pulled from MissingH +breakList :: ([a] -> Bool) -> [a] -> ([a], [a]) +breakList func = spanList (not . func) + +-- This function also pulled from MissingH +spanList :: ([a] -> Bool) -> [a] -> ([a], [a]) +spanList _ [] = ([],[]) +spanList func l@(x:xs) = + let (ys, zs) = spanList func xs + in if func l + then (x : ys, zs) + else ([], l) 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 @@ -219,7 +219,7 @@ topLevelParams :: [Text] topLevelParams = - ["rotation", "showTime", "printOutput", "filePrefix", "memModeLimit"] + ["rotation", "showTime", "printOutput", "filePrefix", "memModeLimit", "roundTime"] instance FromJSON LoggerConfig where parseJSON = withObject "rotation params" $ \o -> do diff --git a/src/System/Wlog/Roller.hs b/src/System/Wlog/Roller.hs --- a/src/System/Wlog/Roller.hs +++ b/src/System/Wlog/Roller.hs @@ -12,38 +12,37 @@ import Universum -import Control.Concurrent (MVar, modifyMVar_, newMVar) -import Formatting (sformat, shown, (%)) -import qualified Prelude (show) - -import System.Directory (removeFile, renameFile) -import System.FilePath ((<.>)) -import System.IO (Handle, IOMode (AppendMode), hClose, - hFileSize) -import System.Log (Priority) -import System.Log.Formatter (LogFormatter, nullFormatter) -import System.Log.Handler (LogHandler (..)) -import System.Log.Handler.Simple (GenericHandler (..), fileHandler) +import Control.Concurrent (MVar, modifyMVar_, newMVar) +import Formatting (sformat, shown, (%)) +import qualified Prelude (show) -import System.Wlog.FileUtils (whenExist) -import System.Wlog.LoggerConfig (RotationParameters (..), isValidRotation) +import System.Directory (removeFile, renameFile) +import System.FilePath ((<.>)) +import System.IO (Handle, IOMode (AppendMode), hClose, + hFileSize) +import System.Wlog.FileUtils (whenExist) +import System.Wlog.Formatter (LogFormatter, nullFormatter) +import System.Wlog.Handler (LogHandler (..)) +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 - { rhPriority :: Priority + { rhSeverity :: Severity , rhFormatter :: LogFormatter RollerHandler , rhFileHandle :: MVar Handle - , rhWriteAction :: Handle -> String -> IO () + , rhWriteAction :: Handle -> Text -> IO () , rhCloseAction :: Handle -> IO () , rhFileName :: FilePath } instance LogHandler RollerHandler where getTag rh = "rollerHandler:" <> rhFileName rh - setLevel rh p = rh { rhPriority = p } + setLevel rh p = rh { rhSeverity = p } setFormatter rh f = rh { rhFormatter = f } - getLevel = rhPriority + getLevel = rhSeverity getFormatter = rhFormatter emit rh (_, msg) _ = rhWriteAction rh (panic "Handler is used internally") msg @@ -57,50 +56,51 @@ logIndex :: FilePath -> Int -> FilePath logIndex handlerPath i = handlerPath <.> Prelude.show i +-- 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 + openFile handlerPath AppendMode + -- | Create rotation logging handler. rotationFileHandler :: MonadIO m => RotationParameters -> FilePath - -> Priority + -> Severity -> m RollerHandler rotationFileHandler rp@RotationParameters{..} _ _ | not $ isValidRotation rp = liftIO $ throwM $ InvalidRotation $ sformat ("Rotation parameters must be positive: "%shown) rp -rotationFileHandler RotationParameters{..} handlerPath rhPriority = liftIO $ do - GenericHandler{..} <- fileHandler handlerPath rhPriority +rotationFileHandler rp@RotationParameters{..} handlerPath rhSeverity = liftIO $ do + GenericHandler{..} <- fileHandler handlerPath rhSeverity rhFileHandle <- newMVar privData - let rhWriteAction = rollerWriting writeFunc rhFileHandle - return RollerHandler{ rhFormatter = nullFormatter - , rhCloseAction = closeFunc - , rhFileName = handlerPath - , .. - } - where - -- TODO: correct exceptions handling here is too smart for me - rollerWriting - :: (Handle -> String -> IO ()) - -> MVar Handle - -> Handle - -> String - -> IO () - rollerWriting loggingAction varHandle _ msg = modifyMVar_ varHandle $ \landle -> do - loggingAction landle msg - logFileSize <- fromIntegral <$> hFileSize landle - if logFileSize < rpLogLimit then - return landle - else do -- otherwise should rename all files and create new handle putting in MVar - 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 - openFile handlerPath AppendMode + let rhWriteAction = rollerWriting rp handlerPath writeFunc rhFileHandle + pure RollerHandler { rhFormatter = nullFormatter + , rhCloseAction = closeFunc + , rhFileName = handlerPath + , .. + } 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 @@ -4,33 +4,29 @@ module System.Wlog.Severity ( Severity (..) - , convertSeverity + , LogRecord ) where -import Data.SafeCopy (base, deriveSafeCopySimple) -import Data.Typeable (Typeable) -import Data.Yaml (FromJSON, ToJSON) -import GHC.Generics (Generic) -import System.Log.Logger (Priority (DEBUG, ERROR, INFO, NOTICE, WARNING)) +import Data.SafeCopy (base, deriveSafeCopySimple) +import Data.Typeable (Typeable) +import Data.Yaml (FromJSON, ToJSON) +import GHC.Generics (Generic) +import Universum --- | This type specifies which messages to print. +-- | Severity is level of log message importance. It uniquely +-- determines which messages to print. data Severity - = Debug - | Info - | Notice - | Warning - | Error - deriving (Generic, Typeable, Show, Read, Eq) + = Debug -- ^ Debug messages + | Info -- ^ Information + | Notice -- ^ Important (more than average) information + | Warning -- ^ General warnings + | Error -- ^ General errors/severe errors + deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) instance FromJSON Severity instance ToJSON Severity deriveSafeCopySimple 0 'base ''Severity --- | Maps 'Severity' into 'Priority'. -convertSeverity :: Severity -> Priority -convertSeverity Debug = DEBUG -convertSeverity Info = INFO -convertSeverity Notice = NOTICE -convertSeverity Warning = WARNING -convertSeverity Error = ERROR +-- | Internal type of log records. +type LogRecord = (Severity, Text) diff --git a/src/System/Wlog/Wrapper.hs b/src/System/Wlog/Wrapper.hs --- a/src/System/Wlog/Wrapper.hs +++ b/src/System/Wlog/Wrapper.hs @@ -15,33 +15,32 @@ module System.Wlog.Wrapper ( Severity (..) - , convertSeverity , initTerminalLogging , releaseAllHandlers , setSeverity , setSeverityMaybe ) where +import Control.Concurrent.MVar (MVar, newMVar, withMVar) +import System.IO (Handle, stderr, stdout) import Universum -import Control.Concurrent.MVar (MVar, newMVar, withMVar) -import System.IO (Handle, stderr, stdout) -import System.Log.Handler.Simple (GenericHandler (..), streamHandler) -import System.Log.Logger (Priority (DEBUG, ERROR), clearLevel, - removeAllHandlers, rootLoggerName, - setHandlers, setLevel, updateGlobalLogger) - -import System.Wlog.Formatter (setStderrFormatter, setStdoutFormatter) -import System.Wlog.LoggerName (LoggerName (..)) -import System.Wlog.Severity (Severity (..), convertSeverity) +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 :: MVar () -> Handle -> Priority -> IO (GenericHandler Handle) -streamHandlerWithLock lock h p = do - GenericHandler{..} <- streamHandler h p +streamHandlerWithLock :: MVar () -> Handle -> Severity -> IO (GenericHandler Handle) +streamHandlerWithLock lock h sev = do + GenericHandler{..} <- streamHandler h sev return GenericHandler - { priority = priority + { severity = severity , formatter = formatter , privData = privData , writeFunc = \a s -> withMVar lock $ const $ writeFunc a s @@ -68,21 +67,24 @@ initTerminalLogging :: MonadIO m => Bool -> Maybe Severity -> m () initTerminalLogging isShowTime (fromMaybe Warning -> defaultSeverity) = liftIO $ do lock <- liftIO $ newMVar () - -- We set DEBUG here, to allow all messages by stdout handler. + -- We set Debug here, to allow all messages by stdout handler. -- They will be filtered by loggers. - stdoutHandler <- setStdoutFormatter isShowTime <$> - streamHandlerWithLock lock stdout DEBUG + stdoutHandler <- setStdoutFormatter <$> + streamHandlerWithLock lock stdout Debug stderrHandler <- setStderrFormatter <$> - streamHandlerWithLock lock stderr ERROR + streamHandlerWithLock lock stderr Error updateGlobalLogger rootLoggerName $ setHandlers [stderrHandler, stdoutHandler] updateGlobalLogger rootLoggerName $ - setLevel (convertSeverity defaultSeverity) + setLevel defaultSeverity + where + setStdoutFormatter = (`setFormatter` stdoutFormatter isShowTime) + setStderrFormatter = (`setFormatter` stderrFormatter) -- | Set severity for given logger. By default parent's severity is used. setSeverity :: MonadIO m => LoggerName -> Severity -> m () setSeverity (LoggerName name) = - liftIO . updateGlobalLogger name . setLevel . convertSeverity + liftIO . updateGlobalLogger name . setLevel -- | Set or clear severity. setSeverityMaybe