module Blammo.Logging.Logger
  ( Logger
  , HasLogger(..)
  , newLogger
  , getLoggerLoggerSet
  , getLoggerReformat
  , getLoggerShouldLog
  ) where

import Prelude

import Blammo.Logging.LogSettings
import Blammo.Logging.Terminal
import Control.Lens (Lens')
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Logger.Aeson
import Data.ByteString (ByteString)
import System.IO (stderr, stdout)
import System.Log.FastLogger
  ( LoggerSet
  , defaultBufSize
  , newFileLoggerSet
  , newStderrLoggerSet
  , newStdoutLoggerSet
  )

data Logger = Logger
  { Logger -> LoggerSet
lLoggerSet :: LoggerSet
  , Logger -> LogLevel -> ByteString -> ByteString
lReformat :: LogLevel -> ByteString -> ByteString
  , Logger -> LogSource -> LogLevel -> Bool
lShouldLog :: LogSource -> LogLevel -> Bool
  }

getLoggerLoggerSet :: Logger -> LoggerSet
getLoggerLoggerSet :: Logger -> LoggerSet
getLoggerLoggerSet = Logger -> LoggerSet
lLoggerSet

getLoggerReformat :: Logger -> LogLevel -> ByteString -> ByteString
getLoggerReformat :: Logger -> LogLevel -> ByteString -> ByteString
getLoggerReformat = Logger -> LogLevel -> ByteString -> ByteString
lReformat

getLoggerShouldLog :: Logger -> LogSource -> LogLevel -> Bool
getLoggerShouldLog :: Logger -> LogSource -> LogLevel -> Bool
getLoggerShouldLog = Logger -> LogSource -> LogLevel -> Bool
lShouldLog

class HasLogger env where
    loggerL :: Lens' env Logger

instance HasLogger Logger where
  loggerL :: (Logger -> f Logger) -> Logger -> f Logger
loggerL = (Logger -> f Logger) -> Logger -> f Logger
forall a. a -> a
id

newLogger :: MonadIO m => LogSettings -> m Logger
newLogger :: LogSettings -> m Logger
newLogger LogSettings
settings = do
  (LoggerSet
lLoggerSet, Bool
useColor) <- IO (LoggerSet, Bool) -> m (LoggerSet, Bool)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LoggerSet, Bool) -> m (LoggerSet, Bool))
-> IO (LoggerSet, Bool) -> m (LoggerSet, Bool)
forall a b. (a -> b) -> a -> b
$ case LogSettings -> LogDestination
getLogSettingsDestination LogSettings
settings of
    LogDestination
LogDestinationStdout ->
      (,)
        (LoggerSet -> Bool -> (LoggerSet, Bool))
-> IO LoggerSet -> IO (Bool -> (LoggerSet, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufSize -> IO LoggerSet
newStdoutLoggerSet BufSize
defaultBufSize
        IO (Bool -> (LoggerSet, Bool)) -> IO Bool -> IO (LoggerSet, Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LogSettings -> Handle -> IO Bool
forall (m :: * -> *). MonadIO m => LogSettings -> Handle -> m Bool
shouldColorHandle LogSettings
settings Handle
stdout
    LogDestination
LogDestinationStderr ->
      (,)
        (LoggerSet -> Bool -> (LoggerSet, Bool))
-> IO LoggerSet -> IO (Bool -> (LoggerSet, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufSize -> IO LoggerSet
newStderrLoggerSet BufSize
defaultBufSize
        IO (Bool -> (LoggerSet, Bool)) -> IO Bool -> IO (LoggerSet, Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LogSettings -> Handle -> IO Bool
forall (m :: * -> *). MonadIO m => LogSettings -> Handle -> m Bool
shouldColorHandle LogSettings
settings Handle
stderr
    LogDestinationFile FilePath
path ->
      (,) (LoggerSet -> Bool -> (LoggerSet, Bool))
-> IO LoggerSet -> IO (Bool -> (LoggerSet, Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufSize -> FilePath -> IO LoggerSet
newFileLoggerSet BufSize
defaultBufSize FilePath
path IO (Bool -> (LoggerSet, Bool)) -> IO Bool -> IO (LoggerSet, Bool)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> LogSettings -> IO Bool -> IO Bool
forall (m :: * -> *).
Applicative m =>
LogSettings -> m Bool -> m Bool
shouldColorAuto
        LogSettings
settings
        (Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

  let
    lReformat :: LogLevel -> ByteString -> ByteString
lReformat = case LogSettings -> LogFormat
getLogSettingsFormat LogSettings
settings of
      LogFormat
LogFormatJSON -> (ByteString -> ByteString) -> LogLevel -> ByteString -> ByteString
forall a b. a -> b -> a
const ByteString -> ByteString
forall a. a -> a
id -- Color is ignored
      LogFormat
LogFormatTerminal -> Bool -> LogLevel -> ByteString -> ByteString
reformatTerminal Bool
useColor

    lShouldLog :: LogSource -> LogLevel -> Bool
lShouldLog = LogSettings -> LogSource -> LogLevel -> Bool
shouldLogLevel LogSettings
settings

  Logger -> m Logger
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Logger -> m Logger) -> Logger -> m Logger
forall a b. (a -> b) -> a -> b
$ Logger :: LoggerSet
-> (LogLevel -> ByteString -> ByteString)
-> (LogSource -> LogLevel -> Bool)
-> Logger
Logger { LoggerSet
LogSource -> LogLevel -> Bool
LogLevel -> ByteString -> ByteString
lShouldLog :: LogSource -> LogLevel -> Bool
lReformat :: LogLevel -> ByteString -> ByteString
lLoggerSet :: LoggerSet
lShouldLog :: LogSource -> LogLevel -> Bool
lReformat :: LogLevel -> ByteString -> ByteString
lLoggerSet :: LoggerSet
.. }