module System.Log.Handler.Simple(streamHandler, fileHandler,
GenericHandler (..),
verboseStreamHandler)
where
import Prelude hiding (catch)
import Control.Exception (SomeException, catch)
import Data.Char (ord)
import System.Log
import System.Log.Handler
import System.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)
streamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
streamHandler h pri =
do lock <- newMVar ()
let mywritefunc hdl (_, msg) _ =
withMVar lock (\_ -> do writeToHandle hdl msg
hFlush hdl
)
return (GenericHandler {priority = pri,
privData = h,
writeFunc = mywritefunc,
closeFunc = \x -> return ()})
where
writeToHandle hdl msg =
hPutStrLn hdl msg `catch` (handleWriteException hdl msg)
handleWriteException :: Handle -> String -> SomeException -> IO ()
handleWriteException hdl msg e =
let msg' = "Error writing log message: " ++ show e ++
" (original message: " ++ msg ++ ")"
in hPutStrLn hdl (encodingSave msg')
encodingSave = concatMap (\c -> if ord c > 127
then "\\" ++ show (ord c)
else [c])
fileHandler :: FilePath -> Priority -> IO (GenericHandler Handle)
fileHandler fp pri = do
h <- openFile fp AppendMode
sh <- streamHandler h pri
return (sh{closeFunc = hClose})
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 ()})