{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Logging.Internal
( run
, log
, stderrHandler
, stdoutHandler
, defaultRoot
) where
import Control.Concurrent.MVar
import Control.Exception (SomeException, bracket_)
import Control.Monad (forM_, void, when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Default
import Data.IORef
import Data.List (dropWhileEnd)
import Data.Map.Lazy ((!?))
import Data.Time.Clock
import Data.Time.LocalTime
import GHC.Conc (setUncaughtExceptionHandler)
import Prelude hiding (filter, log)
import System.IO (Handle, stderr, stdout)
import System.IO.Unsafe (unsafePerformIO)
import Logging.Types
{-# NOINLINE _mgr #-}
_mgr :: IORef Manager
_mgr = unsafePerformIO $ newIORef undefined
run :: Manager -> IO a -> IO a
run mgr@Manager{..} io = do
when catchUncaughtException $ setUncaughtExceptionHandler uceHandler
bracket_ (atomicWriteIORef _mgr mgr) shutdown io
where
unknownLoc = ("unknown file", "unknown package", "unknown module", 0)
uceHandler :: SomeException -> IO ()
uceHandler e = log "" "ERROR" (show e) unknownLoc
shutdown :: IO ()
shutdown = closeHandlers root >> forM_ sinks closeHandlers
closeHandlers :: Sink -> IO ()
closeHandlers Sink{..} = forM_ handlers $ \(HandlerT hdl) -> close hdl
log :: MonadIO m
=> Logger -> Level -> String -> (String, String, String, Int) -> m ()
log logger level message location = liftIO $ do
mgr@Manager{..} <- readIORef _mgr
created <- getZonedTime
let (file, package, modulename, lineno) = location
when (not disabled) $ process logger mgr $
LogRecord logger level message file package modulename lineno created
where
process :: Logger -> Manager -> LogRecord -> IO ()
process logger mgr rcd =
case lookupSink logger mgr of
Just sink@Sink{..} -> do
when (isSinkEnabledFor sink rcd) $ callHandlers handlers rcd
let parentLogger = parent logger
shouldPropagate = propagate && logger /= parentLogger
when shouldPropagate $ process parentLogger mgr rcd
Nothing -> process (parent logger) mgr rcd
parent :: Logger -> Logger
parent = dropWhileEnd (== '.') . dropWhileEnd (/= '.')
lookupSink :: Logger -> Manager -> Maybe Sink
lookupSink logger mgr@Manager{root=root@Sink{logger=rootLogger}, ..}
| logger `elem` ["", rootLogger] = Just root
| otherwise = sinks !? logger
callHandlers :: [HandlerT] -> LogRecord -> IO ()
callHandlers handlers rcd = forM_ handlers $ \hdlt@(HandlerT hdl) ->
when (isHandlerEnableFor hdlt rcd) $ void $ Logging.Types.handle hdl rcd
isSinkEnabledFor :: Sink -> LogRecord -> Bool
isSinkEnabledFor sink@Sink{..} rcd@LogRecord{level=level'}
| disabled = False
| level' < level = False
| otherwise = filter sink rcd
isHandlerEnableFor :: HandlerT -> LogRecord -> Bool
isHandlerEnableFor (HandlerT hdl) rcd@LogRecord{level=level'}
| level' < getLevel hdl = False
| otherwise = filter (getFilterer hdl) rcd
makeStreamHandler :: Handle -> IO StreamHandler
makeStreamHandler stream = StreamHandler stream def [] def <$> newMVar ()
{-# NOINLINE stderrHandler #-}
stderrHandler :: StreamHandler
stderrHandler = unsafePerformIO $ makeStreamHandler stderr
{-# NOINLINE stdoutHandler #-}
stdoutHandler :: StreamHandler
stdoutHandler = unsafePerformIO $ makeStreamHandler stdout
{-# NOINLINE defaultRoot #-}
defaultRoot :: Sink
defaultRoot = Sink "" "DEBUG" [] [HandlerT stderrHandler] False False