Internal.hs

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

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


import           Control.Concurrent
import           Control.Exception           (SomeException, bracket_)
import           Control.Monad
import           Control.Monad.IO.Class      (MonadIO (..))
import           Control.Monad.Reader
import           Data.Aeson
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           Lens.Micro.Extras           (view)
import           Prelude                     hiding (filter, log)
import           System.FilePath
import           System.IO                   (stderr, stdout)
import           System.IO.Unsafe            (unsafePerformIO)

import           Logging.Class
import           Logging.Level
import           Logging.Logger
import           Logging.Manager
import           Logging.Prelude
import           Logging.Record
import           Logging.Sink


type LoggingT m a = ReaderT Manager m a


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


runIO :: MonadIO m => IO a -> ReaderT Manager m a
runIO = lift . liftIO


log :: (MonadIO m, IsMessage s, ToJSON c)
    => Logger -> Level -> s -> c -> (String, String, String, Int)
    -> LoggingT m ()
log logger level msg ctx location = do
    manager@Manager{..} <- ask
    utctime <- runIO getCurrentTime
    thread <- runIO myThreadId

    let (pathname, pkgname, modulename, lineno) = location
        filename = takeFileName pathname
        asctime = utcToZonedTime timezone utctime
        diffTime = utcTimeToPOSIXSeconds utctime
        created = timestamp diffTime
        msecs = milliseconds diffTime - (seconds diffTime * 1000)
        message = toMessage msg
        context = toJSON ctx

    when (not disabled) $ runIO $ process logger manager LogRecord{..}
  where
    process :: Logger -> Manager -> LogRecord -> IO ()
    process logger manager rcd =
      case lookupSink logger manager of
        Just sink@Sink{..} -> do
          when (filter 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 (`handle` rcd)