Internal.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}

module Logging.Monad.Internal
  ( LoggingT
  , runLoggingT
  , log
  ) where


import           Control.Exception           (SomeException, bracket_)
import           Control.Lens                (view)
import           Control.Monad
import           Control.Monad.IO.Class      (MonadIO (..))
import           Control.Monad.Reader
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.Prelude
import           Logging.Types


type LoggingT m a = ReaderT Manager m a


runLoggingT :: MonadIO m => LoggingT m a -> Manager -> m a
runLoggingT = runReaderT


log :: MonadIO m
    => Logger -> Level -> String -> (String, String, String, Int)
    -> LoggingT m ()
log logger level message location = do
    manager@Manager{..} <- ask
    asctime <- lift $ liftIO $ 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) $ lift $ liftIO $ process logger manager $
      LogRecord logger level message pathname filename pkgname modulename
                lineno asctime utctime created msecs
  where
    process :: Logger -> Manager -> LogRecord -> IO ()
    process logger manager rcd =
      case lookupSink logger manager of
        Just sink@Sink{..} -> do
          when (isSinkEnabledFor sink rcd) $ callHandlers handlers rcd
          let parentLogger = parent logger
              shouldPropagate = propagate && logger /= parentLogger
          when shouldPropagate $ process parentLogger manager rcd
        Nothing -> process (parent logger) manager rcd

    parent :: Logger -> Logger
    parent = dropWhileEnd (== '.') . dropWhileEnd (/= '.')

    lookupSink :: Logger -> Manager -> Maybe Sink
    lookupSink logger manager@Manager{root=root@Sink{logger=rootLogger}, ..}
      | logger `elem` ["", rootLogger] = Just root
      | otherwise = sinks !? logger

    callHandlers :: [SomeHandler] -> LogRecord -> IO ()
    callHandlers handlers rcd = forM_ handlers $ \hdl ->
      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