[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:08:27 UTC 2010
The following commit has been merged in the master branch:
commit 28c4bb49a8dd510fb2bd74444eccf5396d55c486
Author: John Goerzen <jgoerzen at complete.org>
Date: Thu Apr 6 02:11:05 2006 +0100
Pass calling logger name to handlers and create new verboseStreamHAndler
diff --git a/MissingH/Logging/Handler.hs b/MissingH/Logging/Handler.hs
index 4e1a368..8ff6597 100644
--- a/MissingH/Logging/Handler.hs
+++ b/MissingH/Logging/Handler.hs
@@ -55,15 +55,15 @@ class LogHandler a where
getLevel :: a -> Priority
-- | Logs an event if it meets the requirements
-- given by the most recent call to 'setLevel'.
- handle :: a -> LogRecord -> IO ()
+ handle :: a -> LogRecord -> String-> IO ()
- handle h (pri, msg) =
+ handle h (pri, msg) logname =
if pri >= (getLevel h)
- then emit h (pri, msg)
+ then emit h (pri, msg) logname
else return ()
-- | Forces an event to be logged regardless of
-- the configured level.
- emit :: a -> LogRecord -> IO ()
+ emit :: a -> LogRecord -> String -> IO ()
-- | Closes the logging system, causing it to close
-- any open files, etc.
close :: a -> IO ()
diff --git a/MissingH/Logging/Handler/Simple.hs b/MissingH/Logging/Handler/Simple.hs
index c5e6db9..98017d9 100644
--- a/MissingH/Logging/Handler/Simple.hs
+++ b/MissingH/Logging/Handler/Simple.hs
@@ -1,5 +1,5 @@
{- arch-tag: Simple log handlers
-Copyright (C) 2004-2005 John Goerzen <jgoerzen at complete.org>
+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
@@ -18,7 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
{- |
Module : MissingH.Logging.Handler.Simple
- Copyright : Copyright (C) 2004-2005 John Goerzen
+ Copyright : Copyright (C) 2004-2006 John Goerzen
License : GNU GPL, version 2 or above
Maintainer : John Goerzen <jgoerzen at complete.org>
@@ -30,7 +30,8 @@ Simple log handlers
Written by John Goerzen, jgoerzen\@complete.org
-}
-module MissingH.Logging.Handler.Simple(streamHandler, fileHandler)
+module MissingH.Logging.Handler.Simple(streamHandler, fileHandler,
+ verboseStreamHandler)
where
import MissingH.Logging
@@ -38,16 +39,15 @@ import MissingH.Logging.Handler
import IO
import Control.Concurrent.MVar
-
data GenericHandler a = GenericHandler {priority :: Priority,
privData :: a,
- writeFunc :: a -> String -> IO (),
+ 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 = (writeFunc sh) (privData sh) (snd lr)
+ emit sh lr loggername = (writeFunc sh) (privData sh) lr loggername
close sh = (closeFunc sh) (privData sh)
@@ -59,9 +59,10 @@ instance LogHandler (GenericHandler a) where
streamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
streamHandler h pri =
do lock <- newMVar ()
- let mywritefunc hdl msg = withMVar lock (\_ -> do hPutStrLn hdl msg
- hFlush hdl
- )
+ let mywritefunc hdl (_, msg) _ =
+ withMVar lock (\_ -> do hPutStrLn hdl msg
+ hFlush hdl
+ )
return (GenericHandler {priority = pri,
privData = h,
writeFunc = mywritefunc,
@@ -77,3 +78,20 @@ 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/MissingH/Logging/Handler/Syslog.hs b/MissingH/Logging/Handler/Syslog.hs
index 1e9db19..049aa08 100644
--- a/MissingH/Logging/Handler/Syslog.hs
+++ b/MissingH/Logging/Handler/Syslog.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE CPP #-}
{- arch-tag: Syslog handler
-Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
+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
@@ -19,7 +19,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
{- |
Module : MissingH.Logging.Handler.Syslog
- Copyright : Copyright (C) 2004 John Goerzen
+ Copyright : Copyright (C) 2004-2006 John Goerzen
License : GNU GPL, version 2 or above
Maintainer : John Goerzen <jgoerzen at complete.org>
@@ -222,7 +222,7 @@ openlog_generic sock addr ident opt fac pri =
instance LogHandler SyslogHandler where
setLevel sh p = sh{priority = p}
getLevel sh = priority sh
- emit sh (p, msg) =
+ emit sh (p, msg) loggername =
let code = makeCode (facility sh) p
getpid :: IO String
getpid = if (elem PID (options sh))
@@ -244,7 +244,8 @@ instance LogHandler SyslogHandler where
do
pidstr <- getpid
let outstr = "<" ++ (show code) ++ ">"
- ++ (identity sh) ++ pidstr ++ ": " ++ msg
+ ++ (identity sh) ++ pidstr ++ ": "
+ ++ "[" ++ loggername ++ "/" ++ (show p) ++ "]" ++ msg
if (elem PERROR (options sh))
then hPutStrLn stderr outstr
else return ()
diff --git a/MissingH/Logging/Logger.hs b/MissingH/Logging/Logger.hs
index fea8052..2409976 100644
--- a/MissingH/Logging/Logger.hs
+++ b/MissingH/Logging/Logger.hs
@@ -377,19 +377,20 @@ handle l (pri, msg) =
if pri >= (level l)
then do
ph <- parentHandlers (name l)
- sequence_ (handlerActions (ph ++ (handlers l)) (pri, msg))
+ sequence_ (handlerActions (ph ++ (handlers l)) (pri, msg)
+ (name l))
else return ()
-- | Call a handler given a HandlerT.
-callHandler :: LogRecord -> HandlerT -> IO ()
-callHandler lr ht =
+callHandler :: LogRecord -> String -> HandlerT -> IO ()
+callHandler lr loggername ht =
case ht of
- HandlerT x -> MissingH.Logging.Handler.handle x lr
+ HandlerT x -> MissingH.Logging.Handler.handle x lr loggername
-- | Generate IO actions for the handlers.
-handlerActions :: [HandlerT] -> LogRecord -> [IO ()]
-handlerActions h lr = map (callHandler lr) h
+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
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list