diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,36 @@ +### 1.3.2.0 + +_2025-08-30, Andreas Abel_ + +- Drop flag `network--GT-3_0_0` and support for `network < 3` +- Allow newer `time` +- Tested with GHC 8.0 - 9.14 alpha1 + +#### 1.3.1.2 + +_2025-03-11, Andreas Abel_ + +- Thoroughly drop support for GHC 7 +- Allow newer `containers` +- Tested with GHC 8.0 - 9.12.1 + +#### 1.3.1.1 + +_2024-04-15, Andreas Abel_ + +- Drop support for GHC 7 +- Tested with GHC 8.0 - 9.10 + +### 1.3.1.0 + +_2019-10-07, Herbert Valerio Riedel_ + +- Evaluate message before taking lock in simple handler ([#49](https://github.com/haskell-hvr/hslogger/pull/49)) +- Define `Typeable`, `Data`, `Generic` and `NFData` instances for `System.Log.Priority` ([#43](https://github.com/haskell-hvr/hslogger/pull/43)) + +## 1.3.0.0 + +_2019-04-15, Herbert Valerio Riedel_ + +- **[semantic change]** Messages are encoded as UTF-8 (previously the encoding was locale dependent) for the Syslog and Growl backends +- Add support for `network-3.0`; remove redundant dependency on `directory` and `process` diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,5 +0,0 @@ -#!/usr/bin/env runhaskell - -import Distribution.Simple - -main = defaultMain diff --git a/hslogger.cabal b/hslogger.cabal --- a/hslogger.cabal +++ b/hslogger.cabal @@ -1,64 +1,100 @@ -Name: hslogger -Version: 1.2.1 -License: BSD3 -Maintainer: John Goerzen -Author: John Goerzen -Stability: Stable -Copyright: Copyright (c) 2004-2012 John Goerzen -license-file: LICENSE +cabal-version: 1.18 build-type: Simple -Homepage: http://software.complete.org/hslogger -Synopsis: Versatile logging framework -Description: hslogger is a logging framework for Haskell, roughly similar to - Python's logging module. +name: hslogger +version: 1.3.2.0 + +maintainer: https://github.com/haskell-hvr/hslogger +author: John Goerzen +copyright: Copyright (c) 2004-2018 John Goerzen + , (c) 2019 Herbert Valerio Riedel +license: BSD3 +license-file: LICENSE +homepage: https://github.com/haskell-hvr/hslogger/wiki +bug-reports: https://github.com/haskell-hvr/hslogger/issues +category: Interfaces +synopsis: Versatile logging framework +description: + @hslogger@ is a logging framework for Haskell, roughly similar + to [Python's logging module](https://docs.python.org/2/library/logging.html). . - hslogger lets each log message have a priority and source be associated + @hslogger@ lets each log message have a priority and source be associated with it. The programmer can then define global handlers that route - or filter messages based on the priority and source. hslogger also - has a syslog handler built in. -Category: Interfaces -extra-source-files: LICENSE, - contrib/java/build.xml, - contrib/java/hslogger4j.jar, - contrib/java/hslogger4j-plugins.xml, - contrib/java/org/haskell/hslogger/HsloggerLevel.java, - contrib/java/org/haskell/hslogger/LogFileXMLReceiver.java, - contrib/java/org/haskell/hslogger/XMLDecoder.java, - testsrc/Tests.hs, - testsrc/runtests.hs, - winbuild.bat -Cabal-Version: >= 1.2 + or filter messages based on the priority and source. @hslogger@ also + has a [Syslog](https://tools.ietf.org/html/rfc5424) handler built in. -flag small_base - description: choose the new smaller, split-up base package. -flag buildtests - description: Build the executable to run unit tests - default: False +extra-doc-files: + LICENSE + CHANGELOG.md -Library - Exposed-Modules: - System.Log, System.Log.Handler, System.Log.Formatter, - System.Log.Handler.Simple, System.Log.Handler.Syslog, - System.Log.Handler.Growl, System.Log.Handler.Log4jXML, +extra-source-files: + contrib/java/build.xml + contrib/java/hslogger4j.jar + contrib/java/hslogger4j-plugins.xml + contrib/java/org/haskell/hslogger/HsloggerLevel.java + contrib/java/org/haskell/hslogger/LogFileXMLReceiver.java + contrib/java/org/haskell/hslogger/XMLDecoder.java + testsrc/Tests.hs + testsrc/runtests.hs + +tested-with: + GHC == 9.14.1 + GHC == 9.12.2 + GHC == 9.10.2 + GHC == 9.8.4 + GHC == 9.6.7 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 + +source-repository head + type: git + location: http://github.com/haskell-hvr/hslogger.git + +library + hs-source-dirs: src + exposed-modules: + System.Log + System.Log.Handler + System.Log.Formatter + System.Log.Handler.Simple + System.Log.Handler.Syslog + System.Log.Handler.Growl + System.Log.Handler.Log4jXML System.Log.Logger - Extensions: CPP, ExistentialQuantification - Build-Depends: network < 2.5, mtl + other-modules: + UTF8 + + default-language: Haskell2010 + other-extensions: CPP ExistentialQuantification DeriveDataTypeable + + build-depends: + -- Lower bounds are at least the ones from LTS 7.24 (GHC 8.0.1) + base >= 4.9 && < 5 + , bytestring >= 0.10.8.1 && < 0.13 + , containers >= 0.5.7.1 && < 1 + , deepseq >= 1.4.2.0 && < 1.6 + , time >= 1.6.0.1 && < 2 + , network-bsd >= 2.8.1 && <2.9 + , network >= 3.0 && <3.3 + if !os(windows) - Build-Depends: unix - if flag(small_base) - build-depends: base >= 4 && < 5, containers, directory, process, - time, old-locale - else - build-depends: base < 3, time - GHC-Options: -O2 - Hs-Source-Dirs: src + Build-Depends: unix >= 2.7.2.0 && < 2.9 -Executable runtests - if flag(buildtests) - Buildable: True - else - Buildable: False - Main-Is: runtests.hs - HS-Source-Dirs: testsrc, . - Extensions: ExistentialQuantification, OverlappingInstances, - UndecidableInstances, CPP +test-suite runtests + type: exitcode-stdio-1.0 + + hs-source-dirs: testsrc + main-is: runtests.hs + other-modules: Tests + + default-language: Haskell2010 + build-depends: + base + , HUnit == 1.6.* + , hslogger diff --git a/src/System/Log.hs b/src/System/Log.hs --- a/src/System/Log.hs +++ b/src/System/Log.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} + {- | Module : System.Log Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 - Maintainer : John Goerzen - Stability : experimental Portability: portable Haskell Logging Framework @@ -27,6 +29,10 @@ where +import Control.DeepSeq (NFData(rnf)) +import Data.Data (Data, Typeable) +import GHC.Generics (Generic) + {- | Priorities are used to define how important a log message is. Users can filter log messages based on priorities. @@ -35,7 +41,7 @@ like. They are listed here in ascending importance order. -} -data Priority = +data Priority = DEBUG -- ^ Debug messages | INFO -- ^ Information | NOTICE -- ^ Normal runtime conditions @@ -44,9 +50,11 @@ | CRITICAL -- ^ Severe situations | ALERT -- ^ Take immediate action | EMERGENCY -- ^ System is unusable - deriving (Eq, Ord, Show, Read) + deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Typeable, Generic) +-- | @since 1.3.1.0 +instance NFData Priority where rnf = (`seq` ()) + {- | Internal type of log records -} type LogRecord = (Priority, String) - diff --git a/src/System/Log/Formatter.hs b/src/System/Log/Formatter.hs --- a/src/System/Log/Formatter.hs +++ b/src/System/Log/Formatter.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + {- Copyright (c) 2005-2011 John Goerzen License: BSD3 @@ -28,7 +30,7 @@ import System.Posix.Process (getProcessID) #endif -import System.Locale (defaultTimeLocale) +import Data.Time.Format (defaultTimeLocale) import Data.Time (getZonedTime,getCurrentTime,formatTime) import System.Log @@ -36,7 +38,7 @@ -- | 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 +type LogFormatter a = a -- ^ The LogHandler that the passed message came from -> LogRecord -- ^ The log message and priority -> String -- ^ The logger name -> IO String -- ^ The formatted log message @@ -47,7 +49,7 @@ -- | 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 +-- a $-sign which will be replaced at runtime with corresponding values. The -- currently supported variables are: -- -- * @$msg@ - The actual log message @@ -60,11 +62,11 @@ -- -- * @$pid@ - Process ID (Not available on windows) -- --- * @$time@ - The current time +-- * @$time@ - The current time -- -- * @$utcTime@ - The current time in UTC Time simpleLogFormatter :: String -> LogFormatter a -simpleLogFormatter format h (prio, msg) loggername = +simpleLogFormatter format h (prio, msg) loggername = tfLogFormatter "%F %X %Z" format h (prio,msg) loggername -- | Like 'simpleLogFormatter' but allow the time format to be specified in the first @@ -81,7 +83,7 @@ -- string to substitute for the variable name. The predefined variables are the same -- as for 'simpleLogFormatter' /excluding/ @$time@ and @$utcTime@. varFormatter :: [(String, IO String)] -> String -> LogFormatter a -varFormatter vars format h (prio,msg) loggername = do +varFormatter vars format _h (prio,msg) loggername = do outmsg <- replaceVarM (vars++[("msg", return msg) ,("prio", return $ show prio) ,("loggername", return loggername) @@ -90,7 +92,7 @@ ,("pid", show <$> getProcessID) #endif ] - ) + ) format return outmsg @@ -109,5 +111,3 @@ replaceStart ((k,v):kvs) str | k `isPrefixOf` str = do vs <- v return (vs, drop (length k) str) | otherwise = replaceStart kvs str - - diff --git a/src/System/Log/Handler.hs b/src/System/Log/Handler.hs --- a/src/System/Log/Handler.hs +++ b/src/System/Log/Handler.hs @@ -3,8 +3,6 @@ Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 - Maintainer : John Goerzen - Stability : provisional Portability: portable Definition of log handler support @@ -23,7 +21,6 @@ ) where import System.Log import System.Log.Formatter -import System.IO {- | All log handlers should adhere to this. -} @@ -39,12 +36,12 @@ -- | Set a log formatter to customize the log format for this Handler setFormatter :: a -> LogFormatter a -> a getFormatter :: a -> LogFormatter a - getFormatter h = nullFormatter + getFormatter _ = 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 = + handle h (pri, msg) logname = if pri >= (getLevel h) then do formattedMsg <- (getFormatter h) h (pri,msg) logname emit h (pri, formattedMsg) logname @@ -55,7 +52,3 @@ -- | Closes the logging system, causing it to close -- any open files, etc. close :: a -> IO () - - - - diff --git a/src/System/Log/Handler/Growl.hs b/src/System/Log/Handler/Growl.hs --- a/src/System/Log/Handler/Growl.hs +++ b/src/System/Log/Handler/Growl.hs @@ -3,8 +3,6 @@ Copyright : Copyright (C) 2007-2011 John Goerzen License : BSD3 - Maintainer : Richard M. Neswold, Jr. - Stability : provisional Portability: portable Simple log handlers @@ -17,37 +15,43 @@ import Data.Char import Data.Word -import Network.Socket -import Network.BSD +import qualified Network.Socket as S +import qualified Network.Socket.ByteString as SBS +import qualified Network.BSD as S import System.Log import System.Log.Handler import System.Log.Formatter +import UTF8 + +sendTo :: S.Socket -> String -> S.SockAddr -> IO Int +sendTo s str = SBS.sendTo s (toUTF8BS str) + data GrowlHandler = GrowlHandler { priority :: Priority, formatter :: LogFormatter GrowlHandler, appName :: String, - skt :: Socket, - targets :: [HostAddress] } + skt :: S.Socket, + targets :: [S.HostAddress] } instance LogHandler GrowlHandler where setLevel gh p = gh { priority = p } getLevel = priority - + setFormatter gh f = gh { formatter = f } getFormatter = formatter emit gh lr _ = let pkt = buildNotification gh nmGeneralMsg lr - in mapM_ (sendNote (skt gh) pkt) (targets gh) + in mapM_ (sendNote (skt gh) pkt) (targets gh) close gh = let pkt = buildNotification gh nmClosingMsg - (WARNING, "Connection closing.") + (WARNING, "Connection closing.") s = skt gh - in mapM_ (sendNote s pkt) (targets gh) >> sClose s + in mapM_ (sendNote s pkt) (targets gh) >> S.close s -sendNote :: Socket -> String -> HostAddress -> IO Int -sendNote s pkt ha = sendTo s pkt (SockAddrInet 9887 ha) +sendNote :: S.Socket -> String -> S.HostAddress -> IO Int +sendNote s pkt ha = sendTo s pkt (S.SockAddrInet 9887 ha) -- Right now there are two "notification names": "message" and -- "disconnecting". All log messages are sent using the "message" @@ -67,7 +71,7 @@ -> Priority -- ^ Priority of handler -> IO GrowlHandler growlHandler nm pri = - do { s <- socket AF_INET Datagram 0 + do { s <- S.socket S.AF_INET S.Datagram 0 ; return GrowlHandler { priority = pri, appName = nm, formatter=nullFormatter, skt = s, targets = [] } } @@ -94,7 +98,7 @@ foldl packIt [] appNotes, ['\x0' .. (chr (length appNotes - 1))] ] packIt a b = a ++ (emitLen16 b) ++ b - appNotes = [ nmGeneralMsg, nmClosingMsg ] + appNotes = [ nmGeneralMsg, nmClosingMsg ] emitLen8 v = [chr $ length v] {- | Adds a remote machine's address to the list of targets that will @@ -102,11 +106,11 @@ packet to the machine. This function will throw an exception if the host name cannot be found. -} -addTarget :: HostName -> GrowlHandler -> IO GrowlHandler -addTarget hn gh = do { he <- getHostByName hn - ; let ha = hostAddress he - sa = SockAddrInet 9887 ha - in do { sendTo (skt gh) (buildRegistration gh) sa +addTarget :: S.HostName -> GrowlHandler -> IO GrowlHandler +addTarget hn gh = do { he <- S.getHostByName hn + ; let ha = S.hostAddress he + sa = S.SockAddrInet 9887 ha + in do { _ <- sendTo (skt gh) (buildRegistration gh) sa ; return gh { targets = ha:(targets gh) } } } -- Converts a Priority type into the subset of integers needed in the @@ -125,9 +129,9 @@ -- Creates a network packet containing a notification record. buildNotification :: GrowlHandler - -> String + -> String -> LogRecord - -> String + -> String buildNotification gh nm (p, msg) = concat fields where fields = [ ['\x1', '\x5'], emit16 (toFlags p), diff --git a/src/System/Log/Handler/Log4jXML.hs b/src/System/Log/Handler/Log4jXML.hs --- a/src/System/Log/Handler/Log4jXML.hs +++ b/src/System/Log/Handler/Log4jXML.hs @@ -1,10 +1,9 @@ +{-# LANGUAGE CPP #-} {- | Module : System.Log.Handler.Log4jXML Copyright : Copyright (C) 2007-2011 John Goerzen License : BSD3 - Maintainer : bjorn.buckwalter@gmail.com - Stability : experimental Portability: GHC only? log4j[1] XMLLayout log handlers. @@ -13,8 +12,8 @@ -} -module System.Log.Handler.Log4jXML ( - +module System.Log.Handler.Log4jXML ( + -- * Introduction {- | This module provides handlers for hslogger that are @@ -34,10 +33,10 @@ 'System.Log.Handler.Simple.FileHandler' in "System.Log.Handler.Simple". The following handlers are provided: -} - -- ** Handlers with hslogger levels + -- ** Handlers with hslogger levels log4jStreamHandler, log4jFileHandler, - + -- ** Handlers with log4j levels log4jStreamHandler', log4jFileHandler' @@ -105,11 +104,10 @@ ) where -import Control.Concurrent (ThreadId, myThreadId) -- myThreadId is GHC only! -import Control.Concurrent.MVar +import Control.Concurrent (myThreadId) -- myThreadId is GHC only! import Data.List (isPrefixOf) import System.IO -import System.Locale (defaultTimeLocale) +import Data.Time.Format (defaultTimeLocale) import Data.Time import System.Log import System.Log.Handler @@ -217,4 +215,3 @@ replace _ _ [ ] = [] replace from to xs@(a:as) = if isPrefixOf from xs then to ++ drop (length from) xs else a : replace from to as - diff --git a/src/System/Log/Handler/Simple.hs b/src/System/Log/Handler/Simple.hs --- a/src/System/Log/Handler/Simple.hs +++ b/src/System/Log/Handler/Simple.hs @@ -3,8 +3,6 @@ Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 - Maintainer : John Goerzen - Stability : provisional Portability: portable Simple log handlers @@ -17,16 +15,15 @@ verboseStreamHandler) where -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif -import Control.Exception (SomeException, catch) +import Control.Exception (tryJust) +import Control.DeepSeq import Data.Char (ord) import System.Log import System.Log.Handler import System.Log.Formatter import System.IO +import System.IO.Error import Control.Concurrent.MVar {- | A helper data type. -} @@ -55,6 +52,7 @@ streamHandler h pri = do lock <- newMVar () let mywritefunc hdl msg = + msg `deepseq` withMVar lock (\_ -> do writeToHandle hdl msg hFlush hdl ) @@ -62,11 +60,14 @@ formatter = nullFormatter, privData = h, writeFunc = mywritefunc, - closeFunc = \x -> return ()}) + closeFunc = \_ -> return ()}) where - writeToHandle hdl msg = - hPutStrLn hdl msg `catch` (handleWriteException hdl msg) - handleWriteException :: Handle -> String -> IOError -> IO () + writeToHandle hdl msg = do + rv <- tryJust myException (hPutStrLn hdl msg) + either (handleWriteException hdl msg) return rv + myException e + | isDoesNotExistError e = Just e + | otherwise = Nothing handleWriteException hdl msg e = let msg' = "Error writing log message: " ++ show e ++ " (original message: " ++ msg ++ ")" diff --git a/src/System/Log/Handler/Syslog.hs b/src/System/Log/Handler/Syslog.hs --- a/src/System/Log/Handler/Syslog.hs +++ b/src/System/Log/Handler/Syslog.hs @@ -5,8 +5,6 @@ Copyright : Copyright (C) 2004-2011 John Goerzen License : BSD3 - Maintainer : John Goerzen - Stability : provisional Portability: portable Syslog handler for the Haskell Logging Framework @@ -29,6 +27,7 @@ -} module System.Log.Handler.Syslog( + SyslogHandler, -- No constructors. -- * Handler Initialization openlog, -- * Advanced handler initialization @@ -42,18 +41,29 @@ Option(..) ) where +import qualified Control.Exception as E import System.Log import System.Log.Formatter import System.Log.Handler import Data.Bits -import Network.Socket -import Network.BSD -import Data.List +import qualified Network.Socket as S +import qualified Network.Socket.ByteString as SBS +import qualified Network.BSD as S +import Data.List (genericDrop) #ifndef mingw32_HOST_OS import System.Posix.Process(getProcessID) #endif import System.IO +import Control.Monad (void, when) +import UTF8 + +send :: S.Socket -> String -> IO Int +send s = SBS.send s . toUTF8BS + +sendTo :: S.Socket -> String -> S.SockAddr -> IO Int +sendTo s str = SBS.sendTo s (toUTF8BS str) + code_of_pri :: Priority -> Int code_of_pri p = case p of EMERGENCY -> 0 @@ -68,7 +78,7 @@ {- | Facilities are used by the system to determine where messages are sent. -} -data Facility = +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 @@ -129,8 +139,9 @@ data SyslogHandler = SyslogHandler {options :: [Option], facility :: Facility, identity :: String, - logsocket :: Socket, - address :: SockAddr, + logsocket :: S.Socket, + address :: S.SockAddr, + sock_type :: S.SocketType, priority :: Priority, formatter :: LogFormatter SyslogHandler } @@ -151,7 +162,7 @@ -> IO SyslogHandler -- ^ Returns the new handler #ifdef mingw32_HOST_OS -openlog = openlog_remote AF_INET "localhost" 514 +openlog = openlog_remote S.AF_INET "localhost" 514 #elif darwin_HOST_OS openlog = openlog_local "/var/run/syslog" #else @@ -170,63 +181,73 @@ -> Facility -- ^ Facility value -> Priority -- ^ Priority limit -> IO SyslogHandler -openlog_local fifopath ident options fac pri = - do - s <- socket AF_UNIX Datagram 0 - openlog_generic s (SockAddrUnix fifopath) ident options fac pri +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 <- S.socket S.AF_UNIX S.Stream 0 + tryStream s `E.catch` (onIOException (fallbackToDgram s)) + openlog_generic s (S.SockAddrUnix fifopath) t ident options' fac pri + + where onIOException :: IO a -> E.IOException -> IO a + onIOException a _ = a + + tryStream :: S.Socket -> IO (S.Socket, S.SocketType) + tryStream s = + do S.connect s (S.SockAddrUnix fifopath) + return (s, S.Stream) + + fallbackToDgram :: S.Socket -> IO (S.Socket, S.SocketType) + fallbackToDgram s = + do S.close s -- close Stream variant + d <- S.socket S.AF_UNIX S.Datagram 0 + return (d, S.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 +openlog_remote :: S.Family -- ^ Usually AF_INET or AF_INET6; see Network.Socket + -> S.HostName -- ^ Remote hostname. Some use @localhost@ + -> S.PortNumber -- ^ 514 is the default for syslog -> String -- ^ Program name -> [Option] -- ^ 'Option's -> Facility -- ^ Facility value -> Priority -- ^ Priority limit -> IO SyslogHandler -openlog_remote fam hostname port ident options fac pri = +openlog_remote fam hostname port ident options' fac pri = do - he <- getHostByName hostname - s <- socket fam Datagram 0 - let addr = SockAddrInet port (head (hostAddresses he)) - openlog_generic s addr ident options fac pri - + he <- S.getHostByName hostname + s <- S.socket fam S.Datagram 0 + let addr = S.SockAddrInet port (head (S.hostAddresses he)) + openlog_generic s addr S.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 +openlog_generic :: S.Socket -- ^ A datagram socket + -> S.SockAddr -- ^ Address for transmissions + -> S.SocketType -- ^ socket connection mode (stream / datagram) -> String -- ^ Program name -> [Option] -- ^ 'Option's -> Facility -- ^ Facility value -> Priority -- ^ Priority limit -> IO SyslogHandler -openlog_generic sock addr ident opt fac pri = +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 code = makeCode (facility sh) p - getpid :: IO String - getpid = -#ifndef mingw32_HOST_OS - getProcessID >>= return . show -#else - return "windows" -#endif - vars = [("code", return $ show code) - ,("identity", return $ identity sh) - ,("pid", getpid)] - withPid = if (elem PID (options sh)) then "[$pid]" else "" - format = "<$code>$identity"++withPid++": [$loggername/$prio] $msg" - in varFormatter vars format sh (p,msg) logname + let format = "[$loggername/$prio] $msg" + in varFormatter [] format sh (p,msg) logname instance LogHandler SyslogHandler where @@ -234,18 +255,32 @@ getLevel sh = priority sh setFormatter sh f = sh{formatter = f} getFormatter sh = formatter sh - emit sh (_, msg) _ = - let - sendstr :: String -> IO String - sendstr [] = return [] - sendstr omsg = do - sent <- sendTo (logsocket sh) omsg (address sh) - sendstr (genericDrop sent omsg) - in do - if (elem PERROR (options sh)) - then hPutStrLn stderr msg - else return () - sendstr (msg ++ "\0") - return () - close sh = sClose (logsocket sh) + emit sh (prio, msg) _ = do + when (elem PERROR (options sh)) (hPutStrLn stderr msg) + pidPart <- getPidPart + void $ sendstr (toSyslogFormat msg pidPart) + where + sendstr :: String -> IO String + sendstr [] = return [] + sendstr omsg = do + sent <- case sock_type sh of + S.Datagram -> sendTo (logsocket sh) omsg (address sh) + S.Stream -> send (logsocket sh) omsg + _ -> undefined + sendstr (genericDrop sent omsg) + toSyslogFormat msg' pidPart = + "<" ++ code ++ ">" ++ identity' ++ pidPart ++ ": " ++ msg' ++ "\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/Log/Logger.hs b/src/System/Log/Logger.hs --- a/src/System/Log/Logger.hs +++ b/src/System/Log/Logger.hs @@ -1,11 +1,10 @@ -{-# OPTIONS -fglasgow-exts #-} +{-# LANGUAGE CPP, ExistentialQuantification #-} + {- | 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 @@ -23,7 +22,7 @@ Therefore, a 'Logger' named \"foo\" is the parent of loggers \"foo.printing\", \"foo.html\", and \"foo.io\". These names can be anything you want. They're used to indicate the area of an application or library in which a logged -message originates. Later you will see how you can use this concept to +message originates. Later you will see how you can use this concept to fine-tune logging behaviors based on specific application areas. You can also tune logging behaviors based upon how important a message is. @@ -32,7 +31,7 @@ some convenient functions that correspond to these importance levels: 'debugM' through 'emergencyM' log messages with the specified importance. -Now, an importance level (or 'Priority') +Now, an importance level (or 'Priority') is associated not just with a particular message but also with a 'Logger'. If the 'Priority' of a given log message is lower than the 'Priority' configured in the 'Logger', that message is ignored. This @@ -79,7 +78,7 @@ it or 'rootLoggerName' to work with it by name. The formatting of log messages may be customized by setting a 'LogFormatter' -on the desired 'LogHandler'. There are a number of simple formatters defined +on the desired 'LogHandler'. There are a number of simple formatters defined in "System.Log.Formatter", which may be used directly, or extend to create your own formatter. @@ -90,40 +89,45 @@ > import System.Log.Handler.Simple > import System.Log.Handler (setFormatter) > import System.Log.Formatter -> +> > -- By default, all messages of level WARNING and above are sent to stderr. > -- Everything else is ignored. -> +> > -- "MyApp.Component" is an arbitrary string; you can tune > -- logging behavior based on it later. > main = do -> debugM "MyApp.Component" "This is a debug message -- never to be seen" -> warningM "MyApp.Component2" "Something Bad is about to happen." -> +> logger1 <- getLogger "MyApp.Component" +> logger2 <- getLogger "MyApp.Component2" +> loggerB <- getLogger "MyApp.BuggyComponent" +> loggerW <- getLogger "MyApp.WorkingComponent" +> +> logL logger1 DEBUG "This is a debug message -- never to be seen" +> logL logger2 WARNING "Something Bad is about to happen." +> > -- Copy everything to syslog from here on out. > s <- openlog "SyslogStuff" [PID] USER DEBUG -> updateGlobalLogger rootLoggerName (addHandler s) -> -> errorM "MyApp.Component" "This is going to stderr and syslog." +> saveGlobalLogger =<< addHandler s <$> getRootLogger > +> logL logger1 ERROR "This is going to stderr and syslog." +> > -- Now we'd like to see everything from BuggyComponent > -- at DEBUG or higher go to syslog and stderr. > -- Also, we'd like to still ignore things less than > -- WARNING in other areas. -> -- +> -- > -- So, we adjust the Logger for MyApp.BuggyComponent. > -> updateGlobalLogger "MyApp.BuggyComponent" -> (setLevel DEBUG) +> let loggerB' = setLevel DEBUG loggerB +> saveGlobalLogger loggerB' > > -- This message will go to syslog and stderr -> debugM "MyApp.BuggyComponent" "This buggy component is buggy" -> +> logL loggerB' DEBUG "This buggy component is buggy" +> > -- This message will go to syslog and stderr too. -> warningM "MyApp.BuggyComponent" "Still Buggy" -> +> logL loggerB' WARNING "Still Buggy" +> > -- This message goes nowhere. -> debugM "MyApp.WorkingComponent" "Hello" +> logL loggerW DEBUG "Hello" > > -- Now we decide we'd also like to log everything from BuggyComponent at DEBUG > -- or higher to a file for later diagnostics. We'd also like to customize the @@ -131,12 +135,13 @@ > > h <- fileHandler "debug.log" DEBUG >>= \lh -> return $ > setFormatter lh (simpleLogFormatter "[$time : $loggername : $prio] $msg") -> updateGlobalLogger "MyApp.BuggyComponent" (addHandler h) -> -> -- This message will go to syslog and stderr, +> let loggerB'' = addHandler h loggerB' +> saveGlobalLogger loggerB'' +> +> -- This message will go to syslog and stderr, > -- and to the file "debug.log" with a format like : > -- [2010-05-23 16:47:28 : MyApp.BuggyComponent : DEBUG] Some useful diagnostics... -> debugM "MyApp.BuggyComponent" "Some useful diagnostics..." +> logL loggerB'' DEBUG "Some useful diagnostics..." > > -} @@ -179,7 +184,7 @@ but other functions won't see the changes. To make a change global, you'll need to use 'updateGlobalLogger' or 'saveGlobalLogger'. -} - addHandler, setHandlers, + addHandler, removeHandler, setHandlers, getLevel, setLevel, clearLevel, -- ** Saving Your Changes {- | These functions commit changes you've made to loggers to the global @@ -189,7 +194,7 @@ ) where import System.Log import System.Log.Handler(LogHandler, close) -import System.Log.Formatter(LogFormatter) +import System.Log.Formatter(LogFormatter) -- for Haddock import qualified System.Log.Handler(handle) import System.Log.Handler.Simple import System.IO @@ -199,7 +204,7 @@ import Data.Maybe import qualified Data.Map as Map import qualified Control.Exception -import Control.Monad.Error + --------------------------------------------------------------------------- -- Basic logger types --------------------------------------------------------------------------- @@ -228,36 +233,36 @@ -- Logger Tree Storage --------------------------------------------------------------------------- --- | The log tree. Initialize it with a default root logger +-- | 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 = +logTree = unsafePerformIO $ do h <- streamHandler stderr DEBUG - newMVar (Map.singleton rootLoggerName (Logger + 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: +Example return value: >["", "MissingH", "System.Cmd.Utils", "System.Cmd.Utils.pOpen"] -} componentsOfName :: String -> [String] -componentsOfName name = +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) [] + rootLoggerName : joinComp (split "." name') [] --------------------------------------------------------------------------- -- Logging With Location @@ -348,7 +353,7 @@ createLoggers (x:xs) lt = -- Add logger to tree if Map.member x lt then createLoggers xs lt - else createLoggers xs + else createLoggers xs (Map.insert x (defaultLogger {name=x}) lt) defaultLogger = Logger Nothing [] undefined @@ -363,31 +368,31 @@ -- | Handle a log request. handle :: Logger -> LogRecord -> IO () -handle l (pri, msg) = +handle l (pri, msg) = let parentLoggers :: String -> IO [Logger] parentLoggers [] = return [] - parentLoggers name = - let pname = (head . drop 1 . reverse . componentsOfName) name - in + parentLoggers name' = + let pname = (head . drop 1 . reverse . componentsOfName) name' + in do parent <- getLogger pname next <- parentLoggers pname return (parent : next) parentHandlers :: String -> IO [HandlerT] - parentHandlers name = parentLoggers name >>= (return . concatMap handlers) + parentHandlers name' = parentLoggers name' >>= (return . concatMap handlers) -- Get the priority we should use. Find the first logger in the tree, -- starting here, with a set priority. If even root doesn't have one, -- assume DEBUG. getLoggerPriority :: String -> IO Priority - getLoggerPriority name = - do pl <- parentLoggers name + getLoggerPriority name' = + do pl <- parentLoggers name' case catMaybes . map level $ (l : pl) of [] -> return DEBUG (x:_) -> return x in do lp <- getLoggerPriority (name l) if pri >= lp - then do + then do ph <- parentHandlers (name l) sequence_ (handlerActions (ph ++ (handlers l)) (pri, msg) (name l)) @@ -402,15 +407,35 @@ -- | Generate IO actions for the handlers. handlerActions :: [HandlerT] -> LogRecord -> String -> [IO ()] handlerActions h lr loggername = map (callHandler lr loggername ) h - + -- | 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 = + case hs of [] -> l + _ -> l{handlers = tail hs} + where + hs = 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 = +setHandlers hl l = l{handlers = map (\h -> HandlerT h) hl} -- | Returns the "level" of the logger. Items beneath this @@ -435,7 +460,7 @@ -- account any changes you may have made. saveGlobalLogger :: Logger -> IO () -saveGlobalLogger l = modifyMVar_ logTree +saveGlobalLogger l = modifyMVar_ logTree (\lt -> return $ Map.insert (name l) l lt) {- | Helps you make changes on the given logger. Takes a function @@ -446,18 +471,18 @@ > (setLevel DEBUG . setHandlers [s]) -} -updateGlobalLogger :: String -- ^ Logger name - -> (Logger -> Logger) -- ^ Function to call - -> IO () +updateGlobalLogger :: String -- ^ Logger name + -> (Logger -> Logger) -- ^ Function to call + -> IO () updateGlobalLogger ln func = do l <- getLogger ln saveGlobalLogger (func l) --- | Allow gracefull shutdown. Release all opened files/handlers/etc. +-- | 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 + let allHandlers = Map.foldr (\l r -> concat [r, handlers l]) [] lt mapM_ (\(HandlerT h) -> close h) allHandlers return $ Map.map (\l -> l {handlers = []}) lt @@ -467,22 +492,22 @@ @\"\"@ if you don't want any), and action to run. -} -traplogging :: String -- Logger name - -> Priority -- Logging priority - -> String -- Descriptive text to prepend to logged messages - -> IO a -- Action to run - -> IO a -- Return value -traplogging logger priority desc action = +traplogging :: String -- ^ Logger name + -> Priority -- ^ Logging priority + -> String -- ^ Descriptive text to prepend to logged messages + -> IO a -- ^ Action to run + -> IO a -- ^ Return value +traplogging logger priority' desc action = let realdesc = case desc of "" -> "" x -> x ++ ": " handler :: Control.Exception.SomeException -> IO a handler e = do - logM logger priority (realdesc ++ (show e)) + logM logger priority' (realdesc ++ (show e)) Control.Exception.throw e -- Re-raise it in Control.Exception.catch action handler - + {- This function pulled in from MissingH to avoid a dep on it -} split :: Eq a => [a] -> [a] -> [[a]] split _ [] = [] @@ -509,4 +534,3 @@ then (x:ys,zs) else ([],list) where (ys,zs) = spanList func xs - diff --git a/src/UTF8.hs b/src/UTF8.hs new file mode 100644 --- /dev/null +++ b/src/UTF8.hs @@ -0,0 +1,44 @@ +-- Internal module to support UTF8 +module UTF8 (toUTF8BS) where + +import Data.Char (ord) +import Data.Bits +import Data.Word (Word8) +import qualified Data.ByteString as BS + +toUTF8BS :: String -> BS.ByteString +toUTF8BS = BS.pack . encodeStringUtf8 + +-- | Encode 'String' to a list of UTF8-encoded octets +-- +-- Code-points in the @U+D800@-@U+DFFF@ range will be encoded +-- as the replacement character (i.e. @U+FFFD@). +-- +-- The code is extracted from Cabal library, written originally HVR +encodeStringUtf8 :: String -> [Word8] +encodeStringUtf8 [] = [] +encodeStringUtf8 (c:cs) + | c <= '\x07F' = w8 + : encodeStringUtf8 cs + | c <= '\x7FF' = (0xC0 .|. w8ShiftR 6 ) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xD7FF'= (0xE0 .|. w8ShiftR 12 ) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | c <= '\xDFFF'= 0xEF : 0xBF : 0xBD -- U+FFFD + : encodeStringUtf8 cs + | c <= '\xFFFF'= (0xE0 .|. w8ShiftR 12 ) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + | otherwise = (0xf0 .|. w8ShiftR 18 ) + : (0x80 .|. (w8ShiftR 12 .&. 0x3F)) + : (0x80 .|. (w8ShiftR 6 .&. 0x3F)) + : (0x80 .|. (w8 .&. 0x3F)) + : encodeStringUtf8 cs + where + w8 = fromIntegral (ord c) :: Word8 + w8ShiftR :: Int -> Word8 + w8ShiftR = fromIntegral . shiftR (ord c) diff --git a/testsrc/Tests.hs b/testsrc/Tests.hs --- a/testsrc/Tests.hs +++ b/testsrc/Tests.hs @@ -1,14 +1,22 @@ {- arch-tag: Tests main file Copyright (C) 2004 John Goerzen License: BSD3 - -} - module Tests(tests) where + import Test.HUnit -test1 = TestCase ("x" @=? "x") +import System.Log -tests = TestList [TestLabel "test1" test1] +tests = TestList [TestLabel "priority levels" priorityLevels] +priorityLevels :: Test +priorityLevels = TestList [ + TestCase ( DEBUG <= DEBUG @=? True), + TestCase ( DEBUG <= INFO @=? True), + TestCase ( INFO <= WARNING @=? True), + TestCase ( WARNING <= ERROR @=? True), + TestCase ( INFO <= ERROR @=? True), + TestCase ( ERROR > INFO @=? True) + ] diff --git a/winbuild.bat b/winbuild.bat deleted file mode 100644 --- a/winbuild.bat +++ /dev/null @@ -1,4 +0,0 @@ -ghc -package Cabal Setup.hs -o setup.exe -setup configure -setup build -