{-# LANGUAGE CPP, ExistentialQuantification #-}

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

   Portability: portable

Haskell Logging Framework, Primary Interface

Written by John Goerzen, jgoerzen\@complete.org

Welcome to the error and information logging system for Haskell.

This system is patterned after Python\'s @logging@ module,
<http://www.python.org/doc/current/lib/module-logging.html> and some of
the documentation here was based on documentation there.

To log a message, you perform operations on 'Logger's.  Each 'Logger' has a
name, and they are arranged hierarchically.  Periods serve as separators.
Therefore, a 'Logger' named \"foo\" is the parent of loggers \"foo.printing\",
\"foo.html\", and \"foo.io\".  These names can be anything you want.  They're
used to indicate the area of an application or library in which a logged
message originates.  Later you will see how you can use this concept to
fine-tune logging behaviors based on specific application areas.

You can also tune logging behaviors based upon how important a message is.
Each message you log will have an importance associated with it.  The different
importance levels are given by the 'Priority' type.  I've also provided
some convenient functions that correspond to these importance levels:
'debugM' through 'emergencyM' log messages with the specified importance.

Now, an importance level (or 'Priority')
is associated not just with a particular message but also
with a 'Logger'.  If the 'Priority' of a given log message is lower than
the 'Priority' configured in the 'Logger', that message is ignored.  This
way, you can globally control how verbose your logging output is.

Now, let's follow what happens under the hood when you log a message.  We'll
assume for the moment that you are logging something with a high enough
'Priority' that it passes the test in your 'Logger'.  In your code, you'll
call 'logM' or something like 'debugM' to log the message.  Your 'Logger'
decides to accept the message.  What next?

Well, we also have a notion of /handlers/ ('LogHandler's, to be precise).
A 'LogHandler' is a thing that takes a message and sends it somewhere.
That \"somewhere\" may be your screen (via standard error), your system's
logging infrastructure (via syslog), a file, or other things.  Each
'Logger' can have zero or more 'LogHandler's associated with it.  When your
'Logger' has a message to log, it passes it to every 'LogHandler' it knows
of to process.  What's more, it is also passed to /all handlers of all
ancestors of the Logger/, regardless of whether those 'Logger's would
normally have passed on the message.

Each 'Logger' can /optionally/ store a 'Priority'.  If a given Logger does
not have a Priority, and you log a message to that logger, the system will
use the priority of the parent of the destination logger to find out whether
to log the message.  If the parent has no priority associated with it,
the system continues walking up the tree to figure out a priority until
it hits the root logger.  In this way, you can easily adjust the priority
of an entire subtree of loggers.  When a new logger is created, it has no
priority by default.  The exception is the root logger, which has a WARNING
priority by default.

To give you one extra little knob to turn, 'LogHandler's can also have
importance levels ('Priority') associated with them in the same way
that 'Logger's do.  They act just like the 'Priority' value in the
'Logger's -- as a filter.  It's useful, for instance, to make sure that
under no circumstances will a mere 'DEBUG' message show up in your syslog.

There are three built-in handlers given in two built-in modules:
"System.Log.Handler.Simple" and "System.Log.Handler.Syslog".

There is a special logger known as the /root logger/ that sits at the top
of the logger hierarchy.  It is always present, and handlers attached
there will be called for every message.  You can use 'getRootLogger' to get
it or 'rootLoggerName' to work with it by name.

The formatting of log messages may be customized by setting a 'LogFormatter'
on the desired 'LogHandler'.  There are a number of simple formatters defined
in "System.Log.Formatter", which may be used directly, or extend to create
your own formatter.

Here's an example to illustrate some of these concepts:

> import System.Log.Logger
> import System.Log.Handler.Syslog
> import System.Log.Handler.Simple
> import System.Log.Handler (setFormatter)
> import System.Log.Formatter
>
> -- By default, all messages of level WARNING and above are sent to stderr.
> -- Everything else is ignored.
>
> -- "MyApp.Component" is an arbitrary string; you can tune
> -- logging behavior based on it later.
> main = do
>        logger1 <- getLogger "MyApp.Component"
>        logger2 <- getLogger "MyApp.Component2"
>        loggerB <- getLogger "MyApp.BuggyComponent"
>        loggerW <- getLogger "MyApp.WorkingComponent"
>
>        logL logger1 DEBUG "This is a debug message -- never to be seen"
>        logL logger2 WARNING "Something Bad is about to happen."
>
>        -- Copy everything to syslog from here on out.
>        s <- openlog "SyslogStuff" [PID] USER DEBUG
>        saveGlobalLogger =<< addHandler s <$> getRootLogger
>
>        logL logger1 ERROR "This is going to stderr and syslog."
>
>        -- Now we'd like to see everything from BuggyComponent
>        -- at DEBUG or higher go to syslog and stderr.
>        -- Also, we'd like to still ignore things less than
>        -- WARNING in other areas.
>        --
>        -- So, we adjust the Logger for MyApp.BuggyComponent.
>
>        let loggerB' = setLevel DEBUG loggerB
>        saveGlobalLogger loggerB'
>
>        -- This message will go to syslog and stderr
>        logL loggerB' DEBUG "This buggy component is buggy"
>
>        -- This message will go to syslog and stderr too.
>        logL loggerB' WARNING "Still Buggy"
>
>        -- This message goes nowhere.
>        logL loggerW DEBUG "Hello"
>
>        -- Now we decide we'd also like to log everything from BuggyComponent at DEBUG
>        -- or higher to a file for later diagnostics.  We'd also like to customize the
>        -- format of the log message, so we use a 'simpleLogFormatter'
>
>        h <- fileHandler "debug.log" DEBUG >>= \lh -> return $
>                 setFormatter lh (simpleLogFormatter "[$time : $loggername : $prio] $msg")
>        let loggerB'' = addHandler h loggerB'
>        saveGlobalLogger loggerB''
>
>        -- This message will go to syslog and stderr,
>        -- and to the file "debug.log" with a format like :
>        -- [2010-05-23 16:47:28 : MyApp.BuggyComponent : DEBUG] Some useful diagnostics...
>        logL loggerB'' DEBUG "Some useful diagnostics..."
>
>
-}

module System.Log.Logger(
                               -- * Basic Types
                               Logger,
                               -- ** Re-Exported from System.Log
                               Priority(..),
                               -- * Logging Messages
                               -- ** Basic
                               logM,
                               -- ** Utility Functions
                               -- These functions are wrappers for 'logM' to
                               -- make your job easier.
                               debugM, infoM, noticeM, warningM, errorM,
                               criticalM, alertM, emergencyM,
                               removeAllHandlers,
                               traplogging,
                               -- ** Logging to a particular Logger by object
                               logL,
                               -- * Logger Manipulation
{- | These functions help you work with loggers.  There are some
special things to be aware of.

First of all, whenever you first access a given logger by name, it
magically springs to life.  It has a default 'Priority' of Nothing
and an empty handler list -- which means that it will inherit whatever its
parents do.
-}
                               -- ** Finding \/ Creating Loggers
                               getLogger, getRootLogger, rootLoggerName,
                               -- ** Modifying Loggers
{- | Keep in mind that \"modification\" here is modification in the Haskell
sense.  We do not actually cause mutation in a specific 'Logger'.  Rather,
we return you a new 'Logger' object with the change applied.

Also, please note that these functions will not have an effect on the
global 'Logger' hierarchy.  You may use your new 'Logger's locally,
but other functions won't see the changes.  To make a change global,
you'll need to use 'updateGlobalLogger' or 'saveGlobalLogger'.
-}
                               addHandler, removeHandler, setHandlers,
                               getLevel, setLevel, clearLevel,
                               -- ** Saving Your Changes
{- | These functions commit changes you've made to loggers to the global
logger hierarchy. -}
                               saveGlobalLogger,
                               updateGlobalLogger
                               ) where
import System.Log
import System.Log.Handler(LogHandler, close)
import System.Log.Formatter(LogFormatter) -- for Haddock
import qualified System.Log.Handler(handle)
import System.Log.Handler.Simple
import System.IO
import System.IO.Unsafe
import Control.Concurrent.MVar
import Data.List(map, isPrefixOf)
import Data.Maybe
import qualified Data.Map as Map
import qualified Control.Exception

---------------------------------------------------------------------------
-- Basic logger types
---------------------------------------------------------------------------
data HandlerT = forall a. LogHandler a => HandlerT a

data Logger = Logger { Logger -> Maybe Priority
level :: Maybe Priority,
                       Logger -> [HandlerT]
handlers :: [HandlerT],
                       Logger -> String
name :: String}

type LogTree = Map.Map String Logger

{- | This is the base class for the various log handlers.  They should
all adhere to this class. -}


---------------------------------------------------------------------------
-- Utilities
---------------------------------------------------------------------------

-- | The name of the root logger, which is always defined and present
-- on the system.
rootLoggerName :: String
rootLoggerName :: String
rootLoggerName = String
""

---------------------------------------------------------------------------
-- Logger Tree Storage
---------------------------------------------------------------------------

-- | The log tree.  Initialize it with a default root logger
-- and (FIXME) a logger for MissingH itself.

{-# NOINLINE logTree #-}

logTree :: MVar LogTree
-- note: only kick up tree if handled locally
logTree :: MVar LogTree
logTree =
    IO (MVar LogTree) -> MVar LogTree
forall a. IO a -> a
unsafePerformIO (IO (MVar LogTree) -> MVar LogTree)
-> IO (MVar LogTree) -> MVar LogTree
forall a b. (a -> b) -> a -> b
$ do
                      GenericHandler Handle
h <- Handle -> Priority -> IO (GenericHandler Handle)
streamHandler Handle
stderr Priority
DEBUG
                      LogTree -> IO (MVar LogTree)
forall a. a -> IO (MVar a)
newMVar (String -> Logger -> LogTree
forall k a. k -> a -> Map k a
Map.singleton String
rootLoggerName (Logger
                                                   {level :: Maybe Priority
level = Priority -> Maybe Priority
forall a. a -> Maybe a
Just Priority
WARNING,
                                                    name :: String
name = String
"",
                                                    handlers :: [HandlerT]
handlers = [GenericHandler Handle -> HandlerT
forall a. LogHandler a => a -> HandlerT
HandlerT GenericHandler Handle
h]}))

{- | Given a name, return all components of it, starting from the root.
Example return value:

>["", "MissingH", "System.Cmd.Utils", "System.Cmd.Utils.pOpen"]

-}
componentsOfName :: String -> [String]
componentsOfName :: String -> [String]
componentsOfName String
name' =
    let joinComp :: [String] -> String -> [String]
joinComp [] String
_ = []
        joinComp (String
x:[String]
xs) [] = String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> String -> [String]
joinComp [String]
xs String
x
        joinComp (String
x:[String]
xs) String
accum =
            let newlevel :: String
newlevel = String
accum String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x in
                String
newlevel String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> String -> [String]
joinComp [String]
xs String
newlevel
        in
        String
rootLoggerName String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> String -> [String]
joinComp (String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
split String
"." String
name') []

---------------------------------------------------------------------------
-- Logging With Location
---------------------------------------------------------------------------

{- | Log a message using the given logger at a given priority. -}

logM :: String                           -- ^ Name of the logger to use
     -> Priority                         -- ^ Priority of this message
     -> String                           -- ^ The log text itself
     -> IO ()

logM :: String -> Priority -> String -> IO ()
logM String
logname Priority
pri String
msg = do
                       Logger
l <- String -> IO Logger
getLogger String
logname
                       Logger -> Priority -> String -> IO ()
logL Logger
l Priority
pri String
msg

---------------------------------------------------------------------------
-- Utility functions
---------------------------------------------------------------------------

{- | Log a message at 'DEBUG' priority -}
debugM :: String                         -- ^ Logger name
      -> String                         -- ^ Log message
      -> IO ()
debugM :: String -> String -> IO ()
debugM String
s = String -> Priority -> String -> IO ()
logM String
s Priority
DEBUG

{- | Log a message at 'INFO' priority -}
infoM :: String                         -- ^ Logger name
      -> String                         -- ^ Log message
      -> IO ()
infoM :: String -> String -> IO ()
infoM String
s = String -> Priority -> String -> IO ()
logM String
s Priority
INFO

{- | Log a message at 'NOTICE' priority -}
noticeM :: String                         -- ^ Logger name
      -> String                         -- ^ Log message
      -> IO ()
noticeM :: String -> String -> IO ()
noticeM String
s = String -> Priority -> String -> IO ()
logM String
s Priority
NOTICE

{- | Log a message at 'WARNING' priority -}
warningM :: String                         -- ^ Logger name
      -> String                         -- ^ Log message
      -> IO ()
warningM :: String -> String -> IO ()
warningM String
s = String -> Priority -> String -> IO ()
logM String
s Priority
WARNING

{- | Log a message at 'ERROR' priority -}
errorM :: String                         -- ^ Logger name
      -> String                         -- ^ Log message
      -> IO ()
errorM :: String -> String -> IO ()
errorM String
s = String -> Priority -> String -> IO ()
logM String
s Priority
ERROR

{- | Log a message at 'CRITICAL' priority -}
criticalM :: String                         -- ^ Logger name
      -> String                         -- ^ Log message
      -> IO ()
criticalM :: String -> String -> IO ()
criticalM String
s = String -> Priority -> String -> IO ()
logM String
s Priority
CRITICAL

{- | Log a message at 'ALERT' priority -}
alertM :: String                         -- ^ Logger name
      -> String                         -- ^ Log message
      -> IO ()
alertM :: String -> String -> IO ()
alertM String
s = String -> Priority -> String -> IO ()
logM String
s Priority
ALERT

{- | Log a message at 'EMERGENCY' priority -}
emergencyM :: String                         -- ^ Logger name
      -> String                         -- ^ Log message
      -> IO ()
emergencyM :: String -> String -> IO ()
emergencyM String
s = String -> Priority -> String -> IO ()
logM String
s Priority
EMERGENCY

---------------------------------------------------------------------------
-- Public Logger Interaction Support
---------------------------------------------------------------------------

-- | Returns the logger for the given name.  If no logger with that name
-- exists, creates new loggers and any necessary parent loggers, with
-- no connected handlers.

getLogger :: String -> IO Logger
getLogger :: String -> IO Logger
getLogger String
lname = MVar LogTree -> (LogTree -> IO (LogTree, Logger)) -> IO Logger
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar LogTree
logTree ((LogTree -> IO (LogTree, Logger)) -> IO Logger)
-> (LogTree -> IO (LogTree, Logger)) -> IO Logger
forall a b. (a -> b) -> a -> b
$ \LogTree
lt ->
    case String -> LogTree -> Maybe Logger
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
lname LogTree
lt of
         Just Logger
x ->  (LogTree, Logger) -> IO (LogTree, Logger)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogTree
lt, Logger
x) -- A logger exists; return it and leave tree
         Maybe Logger
Nothing -> do
                    -- Add logger(s).  Then call myself to retrieve it.
                    let newlt :: LogTree
newlt = [String] -> LogTree -> LogTree
createLoggers (String -> [String]
componentsOfName String
lname) LogTree
lt
                    let result :: Logger
result = Maybe Logger -> Logger
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Logger -> Logger) -> Maybe Logger -> Logger
forall a b. (a -> b) -> a -> b
$ String -> LogTree -> Maybe Logger
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
lname LogTree
newlt
                    (LogTree, Logger) -> IO (LogTree, Logger)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogTree
newlt, Logger
result)
    where createLoggers :: [String] -> LogTree -> LogTree
          createLoggers :: [String] -> LogTree -> LogTree
createLoggers [] LogTree
lt = LogTree
lt -- No names to add; return tree unmodified
          createLoggers (String
x:[String]
xs) LogTree
lt = -- Add logger to tree
              if String -> LogTree -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member String
x LogTree
lt
                 then [String] -> LogTree -> LogTree
createLoggers [String]
xs LogTree
lt
                 else [String] -> LogTree -> LogTree
createLoggers [String]
xs
                          (String -> Logger -> LogTree -> LogTree
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert String
x (Logger
defaultLogger {name=x}) LogTree
lt)
          defaultLogger :: Logger
defaultLogger = Maybe Priority -> [HandlerT] -> String -> Logger
Logger Maybe Priority
forall a. Maybe a
Nothing [] String
forall a. HasCallStack => a
undefined

-- | Returns the root logger.

getRootLogger :: IO Logger
getRootLogger :: IO Logger
getRootLogger = String -> IO Logger
getLogger String
rootLoggerName

-- | Log a message, assuming the current logger's level permits it.
logL :: Logger -> Priority -> String -> IO ()
logL :: Logger -> Priority -> String -> IO ()
logL Logger
l Priority
pri String
msg = Logger -> LogRecord -> IO ()
handle Logger
l (Priority
pri, String
msg)

-- | Handle a log request.
handle :: Logger -> LogRecord -> IO ()
handle :: Logger -> LogRecord -> IO ()
handle Logger
l (Priority
pri, String
msg) =
    let parentLoggers :: String -> IO [Logger]
        parentLoggers :: String -> IO [Logger]
parentLoggers [] = [Logger] -> IO [Logger]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
        parentLoggers String
name' =
            let pname :: String
pname = ([String] -> String
forall a. HasCallStack => [a] -> a
head ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
componentsOfName) String
name'
                in
                do Logger
parent <- String -> IO Logger
getLogger String
pname
                   [Logger]
next <- String -> IO [Logger]
parentLoggers String
pname
                   [Logger] -> IO [Logger]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger
parent Logger -> [Logger] -> [Logger]
forall a. a -> [a] -> [a]
: [Logger]
next)
        parentHandlers :: String -> IO [HandlerT]
        parentHandlers :: String -> IO [HandlerT]
parentHandlers String
name' = String -> IO [Logger]
parentLoggers String
name' IO [Logger] -> ([Logger] -> IO [HandlerT]) -> IO [HandlerT]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([HandlerT] -> IO [HandlerT]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([HandlerT] -> IO [HandlerT])
-> ([Logger] -> [HandlerT]) -> [Logger] -> IO [HandlerT]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Logger -> [HandlerT]) -> [Logger] -> [HandlerT]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Logger -> [HandlerT]
handlers)

        -- Get the priority we should use.  Find the first logger in the tree,
        -- starting here, with a set priority.  If even root doesn't have one,
        -- assume DEBUG.
        getLoggerPriority :: String -> IO Priority
        getLoggerPriority :: String -> IO Priority
getLoggerPriority String
name' =
            do [Logger]
pl <- String -> IO [Logger]
parentLoggers String
name'
               case [Maybe Priority] -> [Priority]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Priority] -> [Priority])
-> ([Logger] -> [Maybe Priority]) -> [Logger] -> [Priority]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Logger -> Maybe Priority) -> [Logger] -> [Maybe Priority]
forall a b. (a -> b) -> [a] -> [b]
map Logger -> Maybe Priority
level ([Logger] -> [Priority]) -> [Logger] -> [Priority]
forall a b. (a -> b) -> a -> b
$ (Logger
l Logger -> [Logger] -> [Logger]
forall a. a -> [a] -> [a]
: [Logger]
pl) of
                 [] -> Priority -> IO Priority
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Priority
DEBUG
                 (Priority
x:[Priority]
_) -> Priority -> IO Priority
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Priority
x
        in
        do Priority
lp <- String -> IO Priority
getLoggerPriority (Logger -> String
name Logger
l)
           if Priority
pri Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
>= Priority
lp
              then do
                [HandlerT]
ph <- String -> IO [HandlerT]
parentHandlers (Logger -> String
name Logger
l)
                [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([HandlerT] -> LogRecord -> String -> [IO ()]
handlerActions ([HandlerT]
ph [HandlerT] -> [HandlerT] -> [HandlerT]
forall a. [a] -> [a] -> [a]
++ (Logger -> [HandlerT]
handlers Logger
l)) (Priority
pri, String
msg)
                                          (Logger -> String
name Logger
l))
              else () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Call a handler given a HandlerT.
callHandler :: LogRecord -> String -> HandlerT -> IO ()
callHandler :: LogRecord -> String -> HandlerT -> IO ()
callHandler LogRecord
lr String
loggername HandlerT
ht =
    case HandlerT
ht of
            HandlerT a
x -> a -> LogRecord -> String -> IO ()
forall a. LogHandler a => a -> LogRecord -> String -> IO ()
System.Log.Handler.handle a
x LogRecord
lr String
loggername

-- | Generate IO actions for the handlers.
handlerActions :: [HandlerT] -> LogRecord -> String -> [IO ()]
handlerActions :: [HandlerT] -> LogRecord -> String -> [IO ()]
handlerActions [HandlerT]
h LogRecord
lr String
loggername = (HandlerT -> IO ()) -> [HandlerT] -> [IO ()]
forall a b. (a -> b) -> [a] -> [b]
map (LogRecord -> String -> HandlerT -> IO ()
callHandler LogRecord
lr String
loggername ) [HandlerT]
h

-- | Add handler to 'Logger'.  Returns a new 'Logger'.
addHandler :: LogHandler a => a -> Logger -> Logger
addHandler :: forall a. LogHandler a => a -> Logger -> Logger
addHandler a
h Logger
l= Logger
l{handlers = (HandlerT h) : (handlers l)}

-- | Remove a handler from the 'Logger'.  Handlers are removed in the reverse
-- order they were added, so the following property holds for any 'LogHandler'
-- @h@:
--
-- > removeHandler . addHandler h = id
--
-- If no handlers are associated with the 'Logger', it is returned unchanged.
--
-- The root logger's default handler that writes every message to stderr can
-- be removed by using this function before any handlers have been added
-- to the root logger:
--
-- > updateGlobalLogger rootLoggerName removeHandler
removeHandler :: Logger -> Logger
removeHandler :: Logger -> Logger
removeHandler Logger
l =
    case [HandlerT]
hs of [] -> Logger
l
               [HandlerT]
_  -> Logger
l{handlers = tail hs}
  where
    hs :: [HandlerT]
hs = Logger -> [HandlerT]
handlers Logger
l

-- | Set the 'Logger'\'s list of handlers to the list supplied.
-- All existing handlers are removed first.
setHandlers :: LogHandler a => [a] -> Logger -> Logger
setHandlers :: forall a. LogHandler a => [a] -> Logger -> Logger
setHandlers [a]
hl Logger
l =
    Logger
l{handlers = map (\a
h -> a -> HandlerT
forall a. LogHandler a => a -> HandlerT
HandlerT a
h) hl}

-- | Returns the "level" of the logger.  Items beneath this
-- level will be ignored.

getLevel :: Logger -> Maybe Priority
getLevel :: Logger -> Maybe Priority
getLevel Logger
l = Logger -> Maybe Priority
level Logger
l

-- | Sets the "level" of the 'Logger'.  Returns a new
-- 'Logger' object with the new level.

setLevel :: Priority -> Logger -> Logger
setLevel :: Priority -> Logger -> Logger
setLevel Priority
p Logger
l = Logger
l{level = Just p}

-- | Clears the "level" of the 'Logger'.  It will now inherit the level of
-- | its parent.

clearLevel :: Logger -> Logger
clearLevel :: Logger -> Logger
clearLevel Logger
l = Logger
l {level = Nothing}

-- | Updates the global record for the given logger to take into
-- account any changes you may have made.

saveGlobalLogger :: Logger -> IO ()
saveGlobalLogger :: Logger -> IO ()
saveGlobalLogger Logger
l = MVar LogTree -> (LogTree -> IO LogTree) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar LogTree
logTree
                     (\LogTree
lt -> LogTree -> IO LogTree
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogTree -> IO LogTree) -> LogTree -> IO LogTree
forall a b. (a -> b) -> a -> b
$ String -> Logger -> LogTree -> LogTree
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Logger -> String
name Logger
l) Logger
l LogTree
lt)

{- | Helps you make changes on the given logger.  Takes a function
that makes changes and writes those changes back to the global
database.  Here's an example from above (\"s\" is a 'LogHandler'):

> updateGlobalLogger "MyApp.BuggyComponent"
>                    (setLevel DEBUG . setHandlers [s])
-}

updateGlobalLogger :: String            -- ^ Logger name
                      -> (Logger -> Logger) -- ^ Function to call
                      -> IO ()
updateGlobalLogger :: String -> (Logger -> Logger) -> IO ()
updateGlobalLogger String
ln Logger -> Logger
func =
    do Logger
l <- String -> IO Logger
getLogger String
ln
       Logger -> IO ()
saveGlobalLogger (Logger -> Logger
func Logger
l)

-- | Allow graceful shutdown. Release all opened files, handlers, etc.
removeAllHandlers :: IO ()
removeAllHandlers :: IO ()
removeAllHandlers =
    MVar LogTree -> (LogTree -> IO LogTree) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar LogTree
logTree ((LogTree -> IO LogTree) -> IO ())
-> (LogTree -> IO LogTree) -> IO ()
forall a b. (a -> b) -> a -> b
$ \LogTree
lt -> do
        let allHandlers :: [HandlerT]
allHandlers = (Logger -> [HandlerT] -> [HandlerT])
-> [HandlerT] -> LogTree -> [HandlerT]
forall a b k. (a -> b -> b) -> b -> Map k a -> b
mapFoldr (\Logger
l [HandlerT]
r -> [[HandlerT]] -> [HandlerT]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[HandlerT]
r, Logger -> [HandlerT]
handlers Logger
l]) [] LogTree
lt
        (HandlerT -> IO ()) -> [HandlerT] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(HandlerT a
h) -> a -> IO ()
forall a. LogHandler a => a -> IO ()
close a
h) [HandlerT]
allHandlers
        LogTree -> IO LogTree
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (LogTree -> IO LogTree) -> LogTree -> IO LogTree
forall a b. (a -> b) -> a -> b
$ (Logger -> Logger) -> LogTree -> LogTree
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (\Logger
l -> Logger
l {handlers = []}) LogTree
lt

mapFoldr :: (a -> b -> b) -> b -> Map.Map k a -> b
#if MIN_VERSION_containers(0,4,2)
mapFoldr :: forall a b k. (a -> b -> b) -> b -> Map k a -> b
mapFoldr = (a -> b -> b) -> b -> Map k a -> b
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr
#else
mapFoldr f z = foldr f z . Map.elems
#endif

{- | Traps exceptions that may occur, logging them, then passing them on.

Takes a logger name, priority, leading description text (you can set it to
@\"\"@ if you don't want any), and action to run.
-}

traplogging :: String                   -- Logger name
            -> Priority                 -- Logging priority
            -> String                   -- Descriptive text to prepend to logged messages
            -> IO a                     -- Action to run
            -> IO a                     -- Return value
traplogging :: forall a. String -> Priority -> String -> IO a -> IO a
traplogging String
logger Priority
priority' String
desc IO a
action =
    let realdesc :: String
realdesc = case String
desc of
                             String
"" -> String
""
                             String
x -> String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
        handler :: Control.Exception.SomeException -> IO a
        handler :: forall a. SomeException -> IO a
handler SomeException
e = do
                    String -> Priority -> String -> IO ()
logM String
logger Priority
priority' (String
realdesc String -> String -> String
forall a. [a] -> [a] -> [a]
++ (SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
                    SomeException -> IO a
forall a e. Exception e => e -> a
Control.Exception.throw SomeException
e             -- Re-raise it
        in
        IO a -> (SomeException -> IO a) -> IO a
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch IO a
action SomeException -> IO a
forall a. SomeException -> IO a
handler

{- This function pulled in from MissingH to avoid a dep on it -}
split :: Eq a => [a] -> [a] -> [[a]]
split :: forall a. Eq a => [a] -> [a] -> [[a]]
split [a]
_ [] = []
split [a]
delim [a]
str =
    let ([a]
firstline, [a]
remainder) = ([a] -> Bool) -> [a] -> ([a], [a])
forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breakList ([a] -> [a] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [a]
delim) [a]
str
        in
        [a]
firstline [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: case [a]
remainder of
                                   [] -> []
                                   [a]
x -> if [a]
x [a] -> [a] -> Bool
forall a. Eq a => a -> a -> Bool
== [a]
delim
                                        then [] [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: []
                                        else [a] -> [a] -> [[a]]
forall a. Eq a => [a] -> [a] -> [[a]]
split [a]
delim
                                                 (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]
delim) [a]
x)

-- This function also pulled from MissingH
breakList :: ([a] -> Bool) -> [a] -> ([a], [a])
breakList :: forall a. ([a] -> Bool) -> [a] -> ([a], [a])
breakList [a] -> Bool
func = ([a] -> Bool) -> [a] -> ([a], [a])
forall a. ([a] -> Bool) -> [a] -> ([a], [a])
spanList (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
func)

-- This function also pulled from MissingH
spanList :: ([a] -> Bool) -> [a] -> ([a], [a])

spanList :: forall a. ([a] -> Bool) -> [a] -> ([a], [a])
spanList [a] -> Bool
_ [] = ([],[])
spanList [a] -> Bool
func list :: [a]
list@(a
x:[a]
xs) =
    if [a] -> Bool
func [a]
list
       then (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
ys,[a]
zs)
       else ([],[a]
list)
    where ([a]
ys,[a]
zs) = ([a] -> Bool) -> [a] -> ([a], [a])
forall a. ([a] -> Bool) -> [a] -> ([a], [a])
spanList [a] -> Bool
func [a]
xs