log-warper 0.5.1 → 1.0.0
raw patch · 14 files changed
+1214/−324 lines, 14 filesdep +networkdep +unixdep −hsloggerdep ~HUnitdep ~QuickCheckdep ~ansi-terminal
Dependencies added: network, unix
Dependencies removed: hslogger
Dependency ranges changed: HUnit, QuickCheck, ansi-terminal, async, base, bytestring, containers, data-default, directory, dlist, errors, exceptions, filepath, formatting, hashable, hspec, lens, log-warper, monad-control, monad-loops, mtl, safecopy, text, text-format, time, transformers, transformers-base, universum, unordered-containers, yaml
Files
- log-warper.cabal +114/−133
- src/System/Wlog.hs +2/−0
- src/System/Wlog/CanLog.hs +3/−17
- src/System/Wlog/Color.hs +23/−17
- src/System/Wlog/Formatter.hs +130/−24
- src/System/Wlog/Handler.hs +65/−0
- src/System/Wlog/Handler/Simple.hs +100/−0
- src/System/Wlog/Handler/Syslog.hs +302/−0
- src/System/Wlog/Launcher.hs +27/−36
- src/System/Wlog/Logger.hs +353/−0
- src/System/Wlog/LoggerConfig.hs +1/−1
- src/System/Wlog/Roller.hs +55/−55
- src/System/Wlog/Severity.hs +16/−20
- src/System/Wlog/Wrapper.hs +23/−21
log-warper.cabal view
@@ -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 <hi@serokell.io>-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 <hi@serokell.io>+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
src/System/Wlog.hs view
@@ -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
src/System/Wlog/CanLog.hs view
@@ -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)
src/System/Wlog/Color.hs view
@@ -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
src/System/Wlog/Formatter.hs view
@@ -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
+ src/System/Wlog/Handler.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{- |+ Module : System.Log.Handler+ Copyright : Copyright (C) 2004-2011 John Goerzen+ License : BSD3++ Maintainer : John Goerzen <jgoerzen@complete.org>+ 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 ()
+ src/System/Wlog/Handler/Simple.hs view
@@ -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 <jgoerzen@complete.org>+ 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
+ src/System/Wlog/Handler/Syslog.hs view
@@ -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 <jgoerzen@complete.org>+ 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)
src/System/Wlog/Launcher.hs view
@@ -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
+ src/System/Wlog/Logger.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NoImplicitPrelude #-}++{- |+ Module : System.Log.Logger+ Copyright : Copyright (C) 2004-2011 John Goerzen+ License : BSD3++ Maintainer : John Goerzen <jgoerzen@complete.org>+ 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)
src/System/Wlog/LoggerConfig.hs view
@@ -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
src/System/Wlog/Roller.hs view
@@ -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+ , ..+ }
src/System/Wlog/Severity.hs view
@@ -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)
src/System/Wlog/Wrapper.hs view
@@ -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