    {- |
       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 lock <- () -> IO (MVar ())
    forall a. a -> IO (MVar a)
    newMVar ()
           let 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
                                 )
           return (GenericHandler {priority = pri,
                                   formatter = nullFormatter,
                                   privData = h,
                                   writeFunc = mywritefunc,
                                   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
              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)
              either (handleWriteException hdl msg) return 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
                         h <- String -> IOMode -> IO Handle
    openFile String
    fp IOMode
    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 :: 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 hndlr <- Handle -> Priority -> IO (GenericHandler Handle)
    streamHandler Handle
    h Priority
    pri
                                       return $ setFormatter hndlr fmt