{- |
   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 {GenericHandler a -> Priority
priority :: Priority,
                                        GenericHandler a -> LogFormatter (GenericHandler a)
formatter :: LogFormatter (GenericHandler a),
                                        GenericHandler a -> a
privData :: a,
                                        GenericHandler a -> a -> String -> IO ()
writeFunc :: a -> String -> IO (),
                                        GenericHandler a -> a -> IO ()
closeFunc :: a -> IO () }

instance LogHandler (GenericHandler a) where
    setLevel :: GenericHandler a -> Priority -> GenericHandler a
setLevel sh :: GenericHandler a
sh p :: Priority
p = GenericHandler a
sh{priority :: Priority
priority = Priority
p}
    getLevel :: GenericHandler a -> Priority
getLevel sh :: GenericHandler a
sh = GenericHandler a -> Priority
forall a. GenericHandler a -> Priority
priority GenericHandler a
sh
    setFormatter :: GenericHandler a
-> LogFormatter (GenericHandler a) -> GenericHandler a
setFormatter sh :: GenericHandler a
sh f :: LogFormatter (GenericHandler a)
f = GenericHandler a
sh{formatter :: LogFormatter (GenericHandler a)
formatter = LogFormatter (GenericHandler a)
f}
    getFormatter :: GenericHandler a -> LogFormatter (GenericHandler a)
getFormatter sh :: 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 sh :: GenericHandler a
sh (_,msg :: String
msg) _ = (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 sh :: 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 h :: Handle
h pri :: Priority
pri =
    do MVar ()
lock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
       let mywritefunc :: Handle -> String -> IO ()
mywritefunc hdl :: Handle
hdl msg :: 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 (m :: * -> *) a. Monad m => a -> m a
return (GenericHandler :: forall a.
Priority
-> LogFormatter (GenericHandler a)
-> a
-> (a -> String -> IO ())
-> (a -> IO ())
-> GenericHandler a
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 = \_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()})
    where
      writeToHandle :: Handle -> String -> IO ()
writeToHandle hdl :: Handle
hdl msg :: 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 a. Show a => Handle -> String -> a -> IO ()
handleWriteException Handle
hdl String
msg) () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return Either IOError ()
rv
      myException :: IOError -> Maybe IOError
myException e :: 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 -> a -> IO ()
handleWriteException hdl :: Handle
hdl msg :: String
msg e :: a
e =
          let msg' :: String
msg' = "Error writing log message: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
e String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     " (original message: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
          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 (\c :: Char
c -> if Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 127
                                         then "\\" 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 fp :: String
fp pri :: 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 (m :: * -> *) a. Monad m => a -> m a
return (GenericHandler Handle
sh{closeFunc :: Handle -> IO ()
closeFunc = Handle -> IO ()
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 h :: Handle
h pri :: Priority
pri = let fmt :: LogFormatter a
fmt = String -> LogFormatter a
forall a. String -> LogFormatter a
simpleLogFormatter "[$loggername/$prio] $msg"
                             in do GenericHandler Handle
hndlr <- Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
h Priority
pri
                                   GenericHandler Handle -> IO (GenericHandler Handle)
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