» A Simple Asynchronous Handler for hslogger #
The hslogger
package provides a few handlers, e.g., for files and for Syslog, but
the implementation of the file logger uses an MVar as a
lock for writing log events. This isn't a bad thing, per se, since the
GHC runtime will do a good job of queuing waiters for that lock, but
it had a noticable impact on performance for perpubplat when I added
some initial logging.
To decouple the log event dispatch and disk access, I whipped up a
quick AsyncLogHandler (source)
that does the job. Here is a quick tour in snippets, starting with a
base data structure:
type Timestamp = String
type LogMessage = String
data AsyncLogHandler
= AsyncLogHandler { channel :: Chan (LogRecord, LogMessage, Timestamp)
, level :: Priority }
An admittedly imperfect instantiation for the LogHandler type class:
instance LogHandler AsyncLogHandler where
setLevel alh p = alh { level = p }
getLevel alh = level alh
emit alh lr msg = do { n <- now
; writeChan (channel alh) $! (lr,msg,n) }
close _ = return () -- make this better
This is less than perfect because it doesn't deal with altering the
priority level or closing the stream on the fly, but I'm not concerned
with either of those things for the moment. (To make that work, I'd
need an additional level of encapsulation on the Chan
that wraps log messages and control requests.) I'm on the fence with
the necessity of making the writeChan strict in the
second argument, but I believe it's necessary to ensure that the
timestamp is computed when the message is dispatched as opposed to
when it's output.
Setup just requires forking a lightweight thread to pull log messages out of the channel:
asyncHandler :: Int -> Handle -> Priority -> IO AsyncLogHandler
asyncHandler n h pri = do { c <- newChan
; forkIO $ append n 0 h c
; return $ AsyncLogHandler { channel = c
, level = pri } }
And then a tail-recursive function to pull the events, format output, and
periodically (every n messages) flush the stream:
append :: Int -> Int -> Handle -> Chan (LogRecord, LogMessage, Timestamp) -> IO ()
append n i h c = do { ((p,m),l,ts) <- readChan c
; (hPutStrLn h $ ts ++ " [" ++ (show p) ++ "] " ++ l ++ " - " ++ m)
`CE.catch` (printex h)
; if i == n then
do { (hFlush h) `CE.catch` (printex h)
; append n 0 h c }
else
append n (i+1) h c }
printex :: Handle -> CE.Exception -> IO ()
printex h e = hPutStrLn System.IO.stderr $ "Error writing to log handle "
++ (show h) ++ ": " ++ show e
And that's it.
