{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Logging.Internal
( run
, log
, stderrHandler
, stdoutHandler
, defaultRoot
) where
import Control.Exception (SomeException, bracket_)
import Control.Lens (view)
import Control.Monad (forM_, void, when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Default
import Data.Generics.Product.Typed
import Data.IORef
import Data.List (dropWhileEnd, group)
import Data.Map.Lazy (elems, (!?))
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.LocalTime
import GHC.Conc (setUncaughtExceptionHandler)
import Prelude hiding (filter, log)
import System.FilePath
import System.IO (stderr, stdout)
import System.IO.Unsafe (unsafePerformIO)
import Logging.Types
import Logging.Utils
{-# 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 >> start) shutdown io
where
unknownLoc = ("unknown file", "unknown package", "unknown module", 0)
uceHandler :: SomeException -> IO ()
uceHandler e = log "" "ERROR" (show e) unknownLoc
allHandlers = map head $ group $
concat [ handlers s | s <- (root : (elems sinks)) ]
start :: IO ()
start = forM_ allHandlers open
shutdown :: IO ()
shutdown = forM_ allHandlers close
log :: MonadIO m
=> Logger -> Level -> String -> (String, String, String, Int) -> m ()
log logger level message location = liftIO $ do
mgr@Manager{..} <- readIORef _mgr
asctime <- getZonedTime
let (pathname, pkgname, modulename, lineno) = location
filename = takeFileName pathname
utctime = zonedTimeToUTC asctime
diffTime = utcTimeToPOSIXSeconds utctime
created = timestamp diffTime
msecs = microseconds diffTime
when (not disabled) $ process logger mgr $
LogRecord logger level message pathname filename pkgname modulename
lineno asctime utctime created msecs
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 :: [SomeHandler] -> LogRecord -> IO ()
callHandlers handlers rcd = forM_ handlers $ \hdl ->
when (isHandlerEnableFor hdl 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 :: SomeHandler -> LogRecord -> Bool
isHandlerEnableFor hdl rcd@LogRecord{level=level'}
| level' < (view (typed @Level) hdl) = False
| otherwise = filter (view (typed @Filterer) hdl) rcd
stderrHandler :: StreamHandler
stderrHandler = StreamHandler def [] "{message}" stderr
stdoutHandler :: StreamHandler
stdoutHandler = StreamHandler def [] "{message}" stdout
{-# NOINLINE defaultRoot #-}
defaultRoot :: Sink
defaultRoot = Sink "" "DEBUG" [] [toHandler stderrHandler] False False