    {-# LANGUAGE CPP #-}

    {-
    Copyright (c) 2005-2011 John Goerzen
    License: BSD3
    -}
    {- |

    Definition of log formatter support

    A few basic, and extendable formatters are defined.

    Please see "System.Log.Logger" for extensive documentation on the
    logging system.

    -}

    module System.Log.Formatter( LogFormatter
                               , nullFormatter
                               , simpleLogFormatter
                               , tfLogFormatter
                               , varFormatter
                               ) where
    import Data.List
    import Control.Applicative ((<$>))
    import Control.Concurrent (myThreadId)
    #ifndef mingw32_HOST_OS
    import System.Posix.Process (getProcessID)
    #endif

    import Data.Time.Format (defaultTimeLocale)
    import Data.Time (getZonedTime,getCurrentTime,formatTime)

    import System.Log

    -- | A LogFormatter is used to format log messages.  Note that it is paramterized on the
    -- 'Handler' to allow the formatter to use information specific to the handler
    -- (an example of can be seen in the formatter used in 'System.Log.Handler.Syslog')
    type LogFormatter a = a -- ^ The LogHandler that the passed message came from
                        -> LogRecord -- ^ The log message and priority
                        -> String -- ^ The logger name
                        -> IO String -- ^ The formatted log message

    -- | Returns the passed message as is, ie. no formatting is done.
    nullFormatter :: LogFormatter a
    nullFormatter :: forall a. LogFormatter a
    nullFormatter a
    _ (Priority
    _,String
    msg) String
    _ = String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    msg

    -- | Takes a format string, and returns a formatter that may be used to
    --   format log messages.  The format string may contain variables prefixed with
    --   a $-sign which will be replaced at runtime with corresponding values.  The
    --   currently supported variables are:
    --
    --    * @$msg@ - The actual log message
    --
    --    * @$loggername@ - The name of the logger
    --
    --    * @$prio@ - The priority level of the message
    --
    --    * @$tid@  - The thread ID
    --
    --    * @$pid@  - Process ID  (Not available on windows)
    --
    --    * @$time@ - The current time
    --
    --    * @$utcTime@ - The current time in UTC Time
    simpleLogFormatter :: String -> LogFormatter a
    simpleLogFormatter :: forall a. String -> LogFormatter a
    simpleLogFormatter String
    format a
    h (Priority
    prio, String
    msg) String
    loggername =
        String -> String -> LogFormatter a
    forall a. String -> String -> LogFormatter a
    tfLogFormatter String
    "%F %X %Z" String
    format a
    h (Priority
    prio,String
    msg) String
    loggername

    -- | Like 'simpleLogFormatter' but allow the time format to be specified in the first
    -- parameter (this is passed to 'Date.Time.Format.formatTime')
    tfLogFormatter :: String -> String -> LogFormatter a
    tfLogFormatter :: forall a. String -> String -> LogFormatter a
    tfLogFormatter String
    timeFormat String
    format = do
      [(String, IO String)] -> String -> LogFormatter a
    forall a. [(String, IO String)] -> String -> LogFormatter a
    varFormatter [(String
    "time", TimeLocale -> String -> ZonedTime -> String
    forall t. FormatTime t => TimeLocale -> String -> t -> String
    formatTime TimeLocale
    defaultTimeLocale String
    timeFormat (ZonedTime -> String) -> IO ZonedTime -> IO String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO ZonedTime
    getZonedTime)
                   ,(String
    "utcTime", TimeLocale -> String -> UTCTime -> String
    forall t. FormatTime t => TimeLocale -> String -> t -> String
    formatTime TimeLocale
    defaultTimeLocale String
    timeFormat (UTCTime -> String) -> IO UTCTime -> IO String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO UTCTime
    getCurrentTime)
                   ]
          String
    format

    -- | An extensible formatter that allows new substition /variables/ to be defined.
    -- Each variable has an associated IO action that is used to produce the
    -- string to substitute for the variable name.  The predefined variables are the same
    -- as for 'simpleLogFormatter' /excluding/ @$time@ and @$utcTime@.
    varFormatter :: [(String, IO String)] -> String -> LogFormatter a
    varFormatter :: forall a. [(String, IO String)] -> String -> LogFormatter a
    varFormatter [(String, IO String)]
    vars String
    format a
    _h (Priority
    prio,String
    msg) String
    loggername = do
        outmsg <- [(String, IO String)] -> String -> IO String
    replaceVarM ([(String, IO String)]
    vars[(String, IO String)]
    -> [(String, IO String)] -> [(String, IO String)]
    forall a. [a] -> [a] -> [a]
    ++[(String
    "msg", String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    msg)
                                     ,(String
    "prio", String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> IO String) -> String -> IO String
    forall a b. (a -> b) -> a -> b
    $ Priority -> String
    forall a. Show a => a -> String
    show Priority
    prio)
                                     ,(String
    "loggername", String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    loggername)
                                     ,(String
    "tid", ThreadId -> String
    forall a. Show a => a -> String
    show (ThreadId -> String) -> IO ThreadId -> IO String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO ThreadId
    myThreadId)
    #ifndef mingw32_HOST_OS
                                     ,(String
    "pid", ProcessID -> String
    forall a. Show a => a -> String
    show (ProcessID -> String) -> IO ProcessID -> IO String
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO ProcessID
    getProcessID)
    #endif
                                     ]
                              )
                      String
    format
        return outmsg

    -- | Replace some '$' variables in a string with supplied values
    replaceVarM :: [(String, IO String)] -- ^ A list of (variableName, action to get the replacement string) pairs
               -> String   -- ^ String to perform substitution on
               -> IO String   -- ^ Resulting string
    replaceVarM :: [(String, IO String)] -> String -> IO String
    replaceVarM [(String, IO String)]
    _ [] = String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
    replaceVarM [(String, IO String)]
    keyVals (Char
    s:String
    ss) | Char
    sChar -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    ==Char
    '$' = do (f,rest) <- [(String, IO String)] -> String -> IO (String, String)
    forall {m :: * -> *} {a}.
    (Monad m, Eq a) =>
    [([a], m String)] -> [a] -> m (String, [a])
    replaceStart [(String, IO String)]
    keyVals String
    ss
                                             repRest <- replaceVarM keyVals rest
                                             return $ f ++ repRest
                               | Bool
    otherwise = [(String, IO String)] -> String -> IO String
    replaceVarM [(String, IO String)]
    keyVals String
    ss IO String -> (String -> IO String) -> IO String
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= String -> IO String
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> IO String) -> (String -> String) -> String -> IO String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char
    sChar -> String -> String
    forall a. a -> [a] -> [a]
    :)
        where
          replaceStart :: [([a], m String)] -> [a] -> m (String, [a])
    replaceStart [] [a]
    str = (String, [a]) -> m (String, [a])
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String
    "$",[a]
    str)
          replaceStart (([a]
    k,m String
    v):[([a], m String)]
    kvs) [a]
    str | [a]
    k [a] -> [a] -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` [a]
    str = do vs <- m String
    v
                                                                 return (vs, drop (length k) str)
                                       | Bool
    otherwise = [([a], m String)] -> [a] -> m (String, [a])
    replaceStart [([a], m String)]
    kvs [a]
    str