{-# 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 a logging environment. -- -- You should always write you application inside a logging environment. -- -- 1. rename "main" function to "originMain" (or whatever you call it) -- 2. write "main" as below -- -- > main :: IO () -- > main = run manager originMain -- > ... -- 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 -- |Run a logging environment from JSON 'Value'. -- -- A combinator of 'run' and 'jsonToManager'. -- runJson :: Value -> IO a -> IO a runJson val io = jsonToManager val >>= (`run` io) -- | Parse JSON to Formatter 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 -- | Parse JSON to Filter jsonToFilter :: Value -> Filter jsonToFilter (String s) = let s' = T.unpack s in Filter s' (length s') jsonToFilter _ = error "Logging.Internal: no parse (Filter)" -- | Parse JSON to Handler(T) 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 -- | Parse JSON to Sink 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)" -- |Make a 'Manager' from JSON 'Value'. 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)" -- |Low-level logging routine which creates a LogRecord and then calls -- all the handlers of this logger to handle the record. 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 -- |A ultility function for creating 'StreamHandler' makeStreamHandler :: Handle -> IO StreamHandler makeStreamHandler stream = StreamHandler stream def [] def <$> newMVar () {-# NOINLINE stderrHandler #-} -- |A 'StreamHandler' bound to 'stderr' stderrHandler :: StreamHandler stderrHandler = unsafePerformIO $ makeStreamHandler stderr {-# NOINLINE stdoutHandler #-} -- |A 'StreamHandler' bound to 'stdout' stdoutHandler :: StreamHandler stdoutHandler = unsafePerformIO $ makeStreamHandler stdout {-# NOINLINE defaultRoot #-} -- |Default root sink which is used by 'jsonToManager' when __root__ is missed. -- -- You can use it when you make 'Manager' manually. defaultRoot :: Sink defaultRoot = Sink "" "DEBUG" [] [HandlerT stderrHandler] False False