[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 15:20:34 UTC 2010
The following commit has been merged in the master branch:
commit 281129a4d42c60cbf8835c74428f92e15c4fa198
Author: John Goerzen <jgoerzen at complete.org>
Date: Thu Dec 7 02:44:02 2006 +0100
Removed System.Log.*; it's moving to hslogger
diff --git a/MissingH.cabal b/MissingH.cabal
index b334e2a..a904c40 100644
--- a/MissingH.cabal
+++ b/MissingH.cabal
@@ -11,9 +11,6 @@ Exposed-Modules: Data.String, System.IO.Utils, System.IO.Binary, Data.List.Utils
Text.ParserCombinators.Parsec.Utils,
Test.HUnit.Utils,
Network.Email.Mailbox,
- System.Log, System.Log.Handler,
- System.Log.Handler.Simple, System.Log.Handler.Syslog,
- System.Log.Logger,
Control.Concurrent.Thread.Utils,
Network.Email.Sendmail,
Data.CSV,
diff --git a/src/System/Log/Handler.hs b/src/System/Log/Handler.hs
deleted file mode 100644
index 8c27b7c..0000000
--- a/src/System/Log/Handler.hs
+++ /dev/null
@@ -1,72 +0,0 @@
-{- arch-tag: Log handlers main definition
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--}
-
-{- |
- Module : System.Log.Handler
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Definition of log handler support
-
-For some handlers, check out "System.Log.Handler.Simple" and
-"System.Log.Handler.Syslog".
-
-Please see "System.Log.Logger" for extensive documentation on the
-logging system.
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module System.Log.Handler(-- * Basic Types
- LogHandler(..)
- ) where
-import System.Log
-import IO
-
-{- | All log handlers should adhere to this. -}
-
-{- | This is the base class for the various log handlers. They should
-all adhere to this class. -}
-
-class LogHandler a where
- -- | Sets the log level. 'handle' will drop
- -- items beneath this level.
- setLevel :: a -> Priority -> a
- -- | Gets the current level.
- getLevel :: a -> Priority
- -- | 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 emit h (pri, msg) logname
- else return ()
- -- | Forces an event to be logged regardless of
- -- the configured level.
- emit :: a -> LogRecord -> String -> IO ()
- -- | Closes the logging system, causing it to close
- -- any open files, etc.
- close :: a -> IO ()
-
-
-
diff --git a/src/System/Log/Handler/Simple.hs b/src/System/Log/Handler/Simple.hs
deleted file mode 100644
index 6bd70fb..0000000
--- a/src/System/Log/Handler/Simple.hs
+++ /dev/null
@@ -1,97 +0,0 @@
-{- arch-tag: Simple log handlers
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--}
-
-{- |
- Module : System.Log.Handler.Simple
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Simple log handlers
-
-Written by John Goerzen, jgoerzen\@complete.org
--}
-
-module System.Log.Handler.Simple(streamHandler, fileHandler,
- verboseStreamHandler)
- where
-
-import System.Log
-import System.Log.Handler
-import IO
-import Control.Concurrent.MVar
-
-data GenericHandler a = GenericHandler {priority :: Priority,
- privData :: a,
- writeFunc :: a -> LogRecord -> String -> IO (),
- closeFunc :: a -> IO () }
-
-instance LogHandler (GenericHandler a) where
- setLevel sh p = sh{priority = p}
- getLevel sh = priority sh
- emit sh lr loggername = (writeFunc sh) (privData sh) lr loggername
- 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 -> Priority -> IO (GenericHandler Handle)
-streamHandler h pri =
- do lock <- newMVar ()
- let mywritefunc hdl (_, msg) _ =
- withMVar lock (\_ -> do hPutStrLn hdl msg
- hFlush hdl
- )
- return (GenericHandler {priority = pri,
- privData = h,
- writeFunc = mywritefunc,
- closeFunc = \x -> return ()})
-
-{- | 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 -> Priority -> IO (GenericHandler Handle)
-fileHandler fp pri = do
- h <- openFile fp AppendMode
- sh <- streamHandler h pri
- return (sh{closeFunc = hClose})
-
-{- | Like 'streamHandler', but note the priority and logger name along
-with each message. -}
-verboseStreamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
-verboseStreamHandler h pri =
- do lock <- newMVar ()
- let mywritefunc hdl (prio, msg) loggername =
- withMVar lock (\_ -> do hPutStrLn hdl ("[" ++ loggername
- ++ "/" ++
- show prio ++
- "] " ++ msg)
- hFlush hdl
- )
- return (GenericHandler {priority = pri,
- privData = h,
- writeFunc = mywritefunc,
- closeFunc = \x -> return ()})
diff --git a/src/System/Log/Handler/Syslog.hs b/src/System/Log/Handler/Syslog.hs
deleted file mode 100644
index e223eea..0000000
--- a/src/System/Log/Handler/Syslog.hs
+++ /dev/null
@@ -1,255 +0,0 @@
-{-# LANGUAGE CPP #-}
-{- arch-tag: Syslog handler
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--}
-
-{- |
- Module : System.Log.Handler.Syslog
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at 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.Log.Handler.Syslog(
- -- * Handler Initialization
- openlog,
- -- * Advanced handler initialization
-#ifndef mingw32_HOST_OS
- openlog_local,
-#endif
- openlog_remote,
- openlog_generic,
- -- * Data Types
- Facility(..),
- Option(..)
- ) where
-
-import System.Log
-import System.Log.Handler
-import Data.Bits
-import Network.Socket
-import Network.BSD
-import List
-#ifndef mingw32_HOST_OS
-import System.Posix.Process(getProcessID)
-#endif
-import IO
-
-code_of_pri :: Priority -> Int
-code_of_pri p = case p of
- EMERGENCY -> 0
- ALERT -> 1
- CRITICAL -> 2
- 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
- | 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
- LOCAL0 -> 16
- LOCAL1 -> 17
- LOCAL2 -> 18
- LOCAL3 -> 19
- LOCAL4 -> 20
- LOCAL5 -> 21
- LOCAL6 -> 22
- LOCAL7 -> 23
-
-makeCode :: Facility -> Priority -> 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,
- priority :: Priority}
-
-{- | 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
- -> Priority -- ^ 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
-#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
- -> Priority -- ^ Priority limit
- -> IO SyslogHandler
-openlog_local fifopath ident options fac pri =
- do
- s <- socket AF_UNIX Datagram 0
- openlog_generic s (SockAddrUnix "/dev/log") ident options fac pri
-#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
- -> Priority -- ^ Priority 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 (head (hostAddresses he))
- openlog_generic s addr ident options fac pri
-
-{- | The most powerful initialization mechanism. Takes an open datagram
-socket. -}
-openlog_generic :: Socket -- ^ A datagram socket
- -> SockAddr -- ^ Address for transmissions
- -> String -- ^ Program name
- -> [Option] -- ^ 'Option's
- -> Facility -- ^ Facility value
- -> Priority -- ^ Priority limit
- -> IO SyslogHandler
-openlog_generic sock addr ident opt fac pri =
- return (SyslogHandler {options = opt,
- facility = fac,
- identity = ident,
- logsocket = sock,
- address = addr,
- priority = pri})
-
-instance LogHandler SyslogHandler where
- setLevel sh p = sh{priority = p}
- getLevel sh = priority sh
- emit sh (p, msg) loggername =
- let code = makeCode (facility sh) p
- getpid :: IO String
- getpid = if (elem PID (options sh))
- then do
-#ifndef mingw32_HOST_OS
- pid <- getProcessID
-#else
- let pid = "windows"
-#endif
- return ("[" ++ show pid ++ "]")
- else return ""
-
- sendstr :: String -> IO String
- sendstr [] = return []
- sendstr omsg = do
- sent <- sendTo (logsocket sh) omsg (address sh)
- sendstr (genericDrop sent omsg)
- in
- do
- pidstr <- getpid
- let outstr = "<" ++ (show code) ++ ">"
- ++ (identity sh) ++ pidstr ++ ": "
- ++ "[" ++ loggername ++ "/" ++ (show p) ++ "] " ++ msg
- if (elem PERROR (options sh))
- then hPutStrLn stderr outstr
- else return ()
- sendstr (outstr ++ "\0")
- return ()
- close sh = sClose (logsocket sh)
-
diff --git a/src/System/Log/Logger.hs b/src/System/Log/Logger.hs
deleted file mode 100644
index e73e537..0000000
--- a/src/System/Log/Logger.hs
+++ /dev/null
@@ -1,460 +0,0 @@
-{- arch-tag: Logger main definition
-Copyright (C) 2004-2006 John Goerzen <jgoerzen at complete.org>
-
-This program is free software; you can redistribute it and/or modify
-it under the terms of the GNU General Public License as published by
-the Free Software Foundation; either version 2 of the License, or
-(at your option) any later version.
-
-This program is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
-
-You should have received a copy of the GNU General Public License
-along with this program; if not, write to the Free Software
-Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
--}
-
-{- |
- Module : System.Log.Logger
- Copyright : Copyright (C) 2004-2006 John Goerzen
- License : GNU GPL, version 2 or above
-
- Maintainer : John Goerzen <jgoerzen at complete.org>
- Stability : provisional
- Portability: portable
-
-Haskell Logging Framework, Primary Interface
-
-Written by John Goerzen, jgoerzen\@complete.org
-
-Welcome to the error and information logging system for Haskell.
-
-This system is patterned after Python\'s @logging@ module,
-<http://www.python.org/doc/current/lib/module-logging.html> and some of
-the documentation here was based on documentation there.
-
-To log a message, you perform operations on 'Logger's. Each 'Logger' has a
-name, and they are arranged hierarchically. Periods serve as separators.
-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
-fine-tune logging behaviors based on specific application areas.
-
-You can also tune logging behaviors based upon how important a message is.
-Each message you log will have an importance associated with it. The different
-importance levels are given by the 'Priority' type. I've also provided
-some convenient functions that correspond to these importance levels:
-'debugM' through 'emergencyM' log messages with the specified importance.
-
-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
-way, you can globally control how verbose your logging output is.
-
-Now, let's follow what happens under the hood when you log a message. We'll
-assume for the moment that you are logging something with a high enough
-'Priority' that it passes the test in your 'Logger'. In your code, you'll
-call 'logM' or something like 'debugM' to log the message. Your 'Logger'
-decides to accept the message. What next?
-
-Well, we also have a notion of /handlers/ ('LogHandler's, to be precise).
-A 'LogHandler' is a thing that takes a message and sends it somewhere.
-That \"somewhere\" may be your screen (via standard error), your system's
-logging infrastructure (via syslog), a file, or other things. Each
-'Logger' can have zero or more 'LogHandler's associated with it. When your
-'Logger' has a message to log, it passes it to every 'LogHandler' it knows
-of to process. What's more, it is also passed to /all handlers of all
-ancestors of the Logger/, regardless of whether those 'Logger's would
-normally have passed on the message.
-
-To give you one extra little knob to turn, 'LogHandler's can also have
-importance levels ('Priority') associated with them in the same way
-that 'Logger's do. They act just like the 'Priority' value in the
-'Logger's -- as a filter. It's useful, for instance, to make sure that
-under no circumstances will a mere 'DEBUG' message show up in your syslog.
-
-There are three built-in handlers given in two built-in modules:
-"System.Log.Handler.Simple" and "System.Log.Handler.Syslog".
-
-There is a special logger known as the /root logger/ that sits at the top
-of the logger hierarchy. It is always present, and handlers attached
-there will be called for every message. You can use 'getRootLogger' to get
-it or 'rootLoggerName' to work with it by name.
-
-Here's an example to illustrate some of these concepts:
-
-> import System.Log.Logger
-> import System.Log.Handler.Syslog
->
-> -- 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."
->
-> -- 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."
->
-> -- 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.Component.
->
-> updateGlobalLogger "MyApp.BuggyComponent"
-> (setLevel DEBUG)
->
-> -- This message will go to syslog and stderr
-> debugM "MyApp.BuggyComponent" "This buggy component is buggy"
->
-> -- This message will go to syslog and stderr too.
-> warningM "MyApp.BuggyComponent" "Still Buggy"
->
-> -- This message goes nowhere.
-> debugM "MyApp.WorkingComponent" "Hello"
-
--}
-
-module System.Log.Logger(
- -- * Basic Types
- Logger,
- -- ** Re-Exported from System.Log
- Priority(..),
- -- * Logging Messages
- -- ** Basic
- logM,
- -- ** Utility Functions
- -- These functions are wrappers for 'logM' to
- -- make your job easier.
- debugM, infoM, noticeM, warningM, errorM,
- criticalM, alertM, emergencyM,
- traplogging,
- -- ** Logging to a particular Logger by object
- logL,
- -- * Logger Manipulation
-{- | These functions help you work with loggers. There are some
-special things to be aware of.
-
-First of all, whenever you first access a given logger by name, it
-magically springs to life. It has a default 'Priority' of 'DEBUG'
-and an empty handler list -- which means that it will inherit whatever its
-parents do.
--}
- -- ** Finding \/ Creating Loggers
- getLogger, getRootLogger, rootLoggerName,
- -- ** Modifying Loggers
-{- | Keep in mind that \"modification\" here is modification in the Haskell
-sense. We do not actually cause mutation in a specific 'Logger'. Rather,
-we return you a new 'Logger' object with the change applied.
-
-Also, please note that these functions will not have an effect on the
-global 'Logger' hierarchy. You may use your new 'Logger's locally,
-but other functions won't see the changes. To make a change global,
-you'll need to use 'updateGlobalLogger' or 'saveGlobalLogger'.
--}
- addHandler, setHandlers,
- getLevel, setLevel,
- -- ** Saving Your Changes
-{- | These functions commit changes you've made to loggers to the global
-logger hierarchy. -}
- saveGlobalLogger,
- updateGlobalLogger
- ) where
-import Data.String
-import System.Log
-import System.Log.Handler(LogHandler)
-import qualified System.Log.Handler(handle)
-import System.Log.Handler.Simple
-import IO
-import System.IO.Unsafe
-import Control.Concurrent.MVar
-import Data.List(map)
-import qualified Data.Map as Map
-import qualified Control.Exception
-import Control.Monad.Error
----------------------------------------------------------------------------
--- Basic logger types
----------------------------------------------------------------------------
-data HandlerT = forall a. LogHandler a => HandlerT a
-
-data Logger = Logger { level :: Priority,
- handlers :: [HandlerT],
- name :: String}
-
-
-type LogTree = Map.Map String Logger
-
-{- | This is the base class for the various log handlers. They should
-all adhere to this class. -}
-
-
----------------------------------------------------------------------------
--- Utilities
----------------------------------------------------------------------------
-
--- | The name of the root logger, which is always defined and present
--- on the system.
-rootLoggerName = ""
-
-{- | Placeholders created when a new logger must be created. This is used
-only for the root logger default for now, as all others crawl up the tree
-to find a sensible default. -}
-placeholder :: Logger
-placeholder = Logger {level = WARNING, handlers = [], name = ""}
-
----------------------------------------------------------------------------
--- 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 = 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
- -> Priority -- ^ Priority of this message
- -> String -- ^ The log text itself
- -> IO ()
-
-logM logname pri msg = do
- l <- getLogger logname
- logL l pri msg
-
----------------------------------------------------------------------------
--- Utility functions
----------------------------------------------------------------------------
-
-{- | Log a message at 'DEBUG' priority -}
-debugM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-debugM s = logM s DEBUG
-
-{- | Log a message at 'INFO' priority -}
-infoM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-infoM s = logM s INFO
-
-{- | Log a message at 'NOTICE' priority -}
-noticeM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-noticeM s = logM s NOTICE
-
-{- | Log a message at 'WARNING' priority -}
-warningM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-warningM s = logM s WARNING
-
-{- | Log a message at 'ERROR' priority -}
-errorM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-errorM s = logM s ERROR
-
-{- | Log a message at 'CRITICAL' priority -}
-criticalM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-criticalM s = logM s CRITICAL
-
-{- | Log a message at 'ALERT' priority -}
-alertM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-alertM s = logM s ALERT
-
-{- | Log a message at 'EMERGENCY' priority -}
-emergencyM :: String -- ^ Logger name
- -> String -- ^ Log message
- -> IO ()
-emergencyM s = logM s EMERGENCY
-
----------------------------------------------------------------------------
--- 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
- result <- 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 ((modellogger lt) {name=x}) lt)
- modellogger :: LogTree -> Logger
- -- the modellogger is what we use for adding new loggers
- modellogger lt =
- findmodellogger lt (reverse $ componentsOfName lname)
- findmodellogger _ [] = error "findmodellogger: root logger does not exist?!"
- findmodellogger lt (x:xs) =
- case Map.lookup x lt of
- Left (_::String) -> findmodellogger lt xs
- Right logger -> logger {handlers = []}
-
--- | Returns the root logger.
-
-getRootLogger :: IO Logger
-getRootLogger = getLogger rootLoggerName
-
--- | Log a message, assuming the current logger's level permits it.
-logL :: Logger -> Priority -> String -> IO ()
-logL l pri msg = handle l (pri, msg)
-
--- | Handle a log request.
-handle :: Logger -> LogRecord -> IO ()
-handle l (pri, msg) =
- let parentHandlers [] = return []
- parentHandlers name =
- let pname = (head . drop 1 . reverse . componentsOfName) name
- in
- do
- --putStrLn (join "," foo)
- --putStrLn pname
- --putStrLn "1"
- parent <- getLogger pname
- --putStrLn "2"
- next <- parentHandlers pname
- --putStrLn "3"
- return ((handlers parent) ++ next)
- in
- if pri >= (level l)
- then do
- ph <- parentHandlers (name l)
- sequence_ (handlerActions (ph ++ (handlers l)) (pri, msg)
- (name l))
- else return ()
-
-
--- | Call a handler given a HandlerT.
-callHandler :: LogRecord -> String -> HandlerT -> IO ()
-callHandler lr loggername ht =
- case ht of
- HandlerT x -> System.Log.Handler.handle x lr loggername
-
--- | 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)}
-
--- | 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 -> Priority
-getLevel l = level l
-
--- | Sets the "level" of the 'Logger'. Returns a new
--- 'Logger' object with the new level.
-
-setLevel :: Priority -> Logger -> Logger
-setLevel p l = l{level = p}
-
--- | 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)
-
-{- | 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
- -> 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 e = do
- logM logger priority (realdesc ++ (show e))
- Control.Exception.throw e -- Re-raise it
- in
- Control.Exception.catch action handler
-
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list