{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Logging.Internal
( run
, runJson
, jsonToManager
, log
, stderrHandler
, stdoutHandler
, defaultRoot
) where
import Control.Concurrent.MVar (MVar, newMVar)
import Control.Exception (SomeException, bracket_)
import Control.Monad (forM_, sequence, void, when)
import Control.Monad.IO.Class (MonadIO (..))
import Data.Aeson (Value (..))
import Data.Default
import qualified Data.HashMap.Strict as HM
import Data.IORef
import Data.List (dropWhileEnd)
import Data.Map.Lazy (Map, delete, fromList, (!?))
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.LocalTime
import GHC.Conc (setUncaughtExceptionHandler)
import Prelude hiding (filter, log)
import System.Directory (createDirectoryIfMissing,
makeAbsolute)
import System.FilePath
import System.IO (Handle, IOMode (..), hSetEncoding,
openFile, stderr, stdout, utf8)
import System.IO.Unsafe (unsafePerformIO)
import Data.Aeson.Extra
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
runJson :: Value -> IO a -> IO a
runJson val io = jsonToManager val >>= (`run` io)
jsonToFormatter :: Value -> Formatter
jsonToFormatter (Object obj) =
Formatter (lookupString fmt "fmt" obj) (lookupString datefmt "datefmt" obj)
where
Formatter{..} = def
jsonToFormatter (String fmt) = def {fmt = T.unpack fmt}
jsonToFormatter _ = def
jsonToFilter :: Value -> Filter
jsonToFilter (String s) = let s' = T.unpack s in Filter s' (length s')
jsonToFilter _ = error "Logging.Internal: no parse (Filter)"
jsonToHandler :: Value -> (String -> Formatter) -> IO HandlerT
jsonToHandler (Object obj) lookupFmt = jsonToHandler' type_
where
type_ = lookupString "" "type" obj
level = read $ lookupString "NOTSET" "level" obj
filterer = map jsonToFilter $ lookupArray "filterer" obj
formatter = lookupFmt $ lookupString "" "formatter" obj
lock :: IO (MVar ())
lock = newMVar ()
nameToStream :: String -> Handle
nameToStream "stderr" = stderr
nameToStream "stdout" = stdout
nameToStream _ = error "Logging.Internal: no parse (stream)"
jsonToHandler' :: String -> IO HandlerT
jsonToHandler' "StreamHandler" = do
let stream = nameToStream $ lookupString "stderr" "stream" obj
(HandlerT . (StreamHandler stream level filterer formatter)) <$> lock
jsonToHandler' "FileHandler" = do
file <- makeAbsolute $ lookupString "default.log" "file" obj
createDirectoryIfMissing True $ takeDirectory file
stream <- openFile file AppendMode
hSetEncoding stream utf8
(HandlerT . (StreamHandler stream level filterer formatter)) <$> lock
jsonToHandler' _ = error $ "Logging.Internal: no parse (Handler)"
jsonToHandler _ _ = undefined
jsonToSink :: (String, Value) -> (String -> HandlerT) -> Sink
jsonToSink (logger, Object obj) lookupHdl =
Sink logger' level filterer handlers disabled propagate
where
logger' = if logger == "root" then "" else logger
level = read $ lookupString "NOTSET" "level" obj
filterer = map jsonToFilter $ lookupArray "filterer" obj
handlers = [lookupHdl (T.unpack v) | (String v) <- lookupArray "handlers" obj]
disabled = lookupBool False "disabled" obj
propagate = lookupBool False "propagate" obj
jsonToSink _ _ = error "Logging.Internal: no parse (Logger)"
jsonToManager :: Value -> IO Manager
jsonToManager (Object obj) = do
let formatters = HM.map jsonToFormatter $ lookupObject "formatters" obj
lookupFmt k = HM.lookupDefault def k formatters
handlerNames = lookupObject "handlers" obj
handlers <- sequence $ HM.map (`jsonToHandler` lookupFmt) handlerNames
let lookupHdl = (HM.!) handlers
sinkVals = lookupObject "loggers" obj
sinks = HM.mapWithKey (curry (`jsonToSink` lookupHdl)) sinkVals
root = HM.lookupDefault defaultRoot "root" sinks
sinks' = delete "root" $ fromList $ HM.toList sinks
disabled = lookupBool False "disabled" obj
catchUncaughtException = lookupBool False "catchUncaughtException" obj
return $ Manager root sinks' disabled catchUncaughtException
jsonToManager _ = error "Logging.Internal: no parse (Manager)"
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