{-# 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

#if MIN_VERSION_time(1,5,0)
import Data.Time.Format (defaultTimeLocale)
#else
import System.Locale (defaultTimeLocale)
#endif
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
    String
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
    String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
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 (String
f,String
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
                                         String
repRest <- [(String, IO String)] -> String -> IO String
replaceVarM [(String, IO String)]
keyVals String
rest
                                         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
$ String
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
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 String
vs <- m String
v
                                                             (String, [a]) -> m (String, [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
vs, Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
k) [a]
str)
                                   | Bool
otherwise = [([a], m String)] -> [a] -> m (String, [a])
replaceStart [([a], m String)]
kvs [a]
str