{- |
   Module     : System.Log.Handler.Simple
   Copyright  : Copyright (C) 2004-2011 John Goerzen
   License    : BSD3

   Portability: portable

Simple log handlers

Written by John Goerzen, jgoerzen\@complete.org
-}

module System.Log.Handler.Simple(streamHandler, fileHandler,
                                      GenericHandler (..),
                                      verboseStreamHandler)
    where

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. -}

data GenericHandler a = GenericHandler {forall a. GenericHandler a -> Priority
priority :: Priority,
                                        forall a. GenericHandler a -> LogFormatter (GenericHandler a)
formatter :: LogFormatter (GenericHandler a),
                                        forall a. GenericHandler a -> a
privData :: a,
                                        forall a. GenericHandler a -> a -> String -> IO ()
writeFunc :: a -> String -> IO (),
                                        forall a. GenericHandler a -> a -> IO ()
closeFunc :: a -> IO () }

instance LogHandler (GenericHandler a) where
    setLevel :: GenericHandler a -> Priority -> GenericHandler a
setLevel GenericHandler a
sh Priority
p = GenericHandler a
sh{priority = p}
    getLevel :: GenericHandler a -> Priority
getLevel GenericHandler a
sh = GenericHandler a -> Priority
forall a. GenericHandler a -> Priority
priority GenericHandler a
sh
    setFormatter :: GenericHandler a
-> LogFormatter (GenericHandler a) -> GenericHandler a
setFormatter GenericHandler a
sh LogFormatter (GenericHandler a)
f = GenericHandler a
sh{formatter = f}
    getFormatter :: GenericHandler a -> LogFormatter (GenericHandler a)
getFormatter GenericHandler a
sh = GenericHandler a -> LogFormatter (GenericHandler a)
forall a. GenericHandler a -> LogFormatter (GenericHandler a)
formatter GenericHandler a
sh
    emit :: GenericHandler a -> LogRecord -> String -> IO ()
emit GenericHandler a
sh (Priority
_,String
msg) String
_ = (GenericHandler a -> a -> String -> IO ()
forall a. GenericHandler a -> a -> String -> IO ()
writeFunc GenericHandler a
sh) (GenericHandler a -> a
forall a. GenericHandler a -> a
privData GenericHandler a
sh) String
msg
    close :: GenericHandler a -> IO ()
close GenericHandler a
sh = (GenericHandler a -> a -> IO ()
forall a. GenericHandler a -> a -> IO ()
closeFunc GenericHandler a
sh) (GenericHandler a -> a
forall a. GenericHandler a -> a
privData GenericHandler a
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 :: Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
h Priority
pri =
    do MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
       let mywritefunc :: Handle -> String -> IO ()
mywritefunc Handle
hdl String
msg =
               String
msg String -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq`
               MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
lock (\()
_ -> do Handle -> String -> IO ()
writeToHandle Handle
hdl String
msg
                                       Handle -> IO ()
hFlush Handle
hdl
                             )
       GenericHandler Handle -> IO (GenericHandler Handle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericHandler {priority :: Priority
priority = Priority
pri,
                               formatter :: LogFormatter (GenericHandler Handle)
formatter = LogFormatter (GenericHandler Handle)
forall a. LogFormatter a
nullFormatter,
                               privData :: Handle
privData = Handle
h,
                               writeFunc :: Handle -> String -> IO ()
writeFunc = Handle -> String -> IO ()
mywritefunc,
                               closeFunc :: Handle -> IO ()
closeFunc = \Handle
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()})
    where
      writeToHandle :: Handle -> String -> IO ()
writeToHandle Handle
hdl String
msg = do
          Either IOError ()
rv <- (IOError -> Maybe IOError) -> IO () -> IO (Either IOError ())
forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> IO (Either b a)
tryJust IOError -> Maybe IOError
myException (Handle -> String -> IO ()
hPutStrLn Handle
hdl String
msg)
          (IOError -> IO ()) -> (() -> IO ()) -> Either IOError () -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Handle -> String -> IOError -> IO ()
forall {p}. Show p => Handle -> String -> p -> IO ()
handleWriteException Handle
hdl String
msg) () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Either IOError ()
rv
      myException :: IOError -> Maybe IOError
myException IOError
e
          | IOError -> Bool
isDoesNotExistError IOError
e = IOError -> Maybe IOError
forall a. a -> Maybe a
Just IOError
e
          | Bool
otherwise = Maybe IOError
forall a. Maybe a
Nothing
      handleWriteException :: Handle -> String -> p -> IO ()
handleWriteException Handle
hdl String
msg p
e =
          let msg' :: String
msg' = String
"Error writing log message: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ p -> String
forall a. Show a => a -> String
show p
e String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
" (original message: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
          in Handle -> String -> IO ()
hPutStrLn Handle
hdl (String -> String
encodingSave String
msg')
      encodingSave :: String -> String
encodingSave = (Char -> String) -> String -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\Char
c -> if Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
127
                                         then String
"\\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Char -> Int
ord Char
c)
                                         else [Char
c])

{- | 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 :: String -> Priority -> IO (GenericHandler Handle)
fileHandler String
fp Priority
pri = do
                     Handle
h <- String -> IOMode -> IO Handle
openFile String
fp IOMode
AppendMode
                     GenericHandler Handle
sh <- Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
h Priority
pri
                     GenericHandler Handle -> IO (GenericHandler Handle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericHandler Handle
sh{closeFunc = hClose})

{- | Like 'streamHandler', but note the priority and logger name along
with each message. -}
verboseStreamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
verboseStreamHandler :: Handle -> Priority -> IO (GenericHandler Handle)
verboseStreamHandler Handle
h Priority
pri = let fmt :: LogFormatter a
fmt = String -> LogFormatter a
forall a. String -> LogFormatter a
simpleLogFormatter String
"[$loggername/$prio] $msg"
                             in do GenericHandler Handle
hndlr <- Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
h Priority
pri
                                   GenericHandler Handle -> IO (GenericHandler Handle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GenericHandler Handle -> IO (GenericHandler Handle))
-> GenericHandler Handle -> IO (GenericHandler Handle)
forall a b. (a -> b) -> a -> b
$ GenericHandler Handle
-> LogFormatter (GenericHandler Handle) -> GenericHandler Handle
forall a. LogHandler a => a -> LogFormatter a -> a
setFormatter GenericHandler Handle
hndlr LogFormatter (GenericHandler Handle)
forall a. LogFormatter a
fmt