module Blammo.Logging.Logger
  ( Logger
  , HasLogger(..)
  , newLogger
  , getLoggerReformat
  , getLoggerShouldLog
  , pushLogStrLn
  , flushLogStr

  -- * Testing
  , newTestLogger
  , LoggedMessage(..)
  , getLoggedMessages
  , getLoggedMessagesLenient
  , getLoggedMessagesUnsafe

  -- * Deprecated
  , getLoggerLoggerSet
  ) where

import Prelude

import Blammo.Logging.LogSettings
import Blammo.Logging.Terminal
import Blammo.Logging.Test hiding (getLoggedMessages)
import qualified Blammo.Logging.Test as LoggedMessages
import Control.Lens (Lens', view)
import Control.Monad (unless)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Logger.Aeson
import Control.Monad.Reader (MonadReader)
import Data.ByteString (ByteString)
import Data.Either (partitionEithers, rights)
import Data.List (intercalate)
import GHC.Stack (HasCallStack)
import System.IO (stderr, stdout)
import System.Log.FastLogger
  ( LoggerSet
  , defaultBufSize
  , newFileLoggerSet
  , newStderrLoggerSet
  , newStdoutLoggerSet
  )
import qualified System.Log.FastLogger as FastLogger (flushLogStr, pushLogStrLn)
import UnliftIO.Exception (throwString)

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

getLoggerLoggerSet :: Logger -> LoggerSet
getLoggerLoggerSet :: Logger -> LoggerSet
getLoggerLoggerSet = Logger -> LoggerSet
lLoggerSet
{-# DEPRECATED getLoggerLoggerSet "Internal function, will be removed in a future version" #-}

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

pushLogStrLn :: MonadIO m => Logger -> LogStr -> m ()
pushLogStrLn :: Logger -> LogStr -> m ()
pushLogStrLn Logger
logger LogStr
str = case Logger -> Maybe LoggedMessages
lLoggedMessages Logger
logger of
  Maybe LoggedMessages
Nothing -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LoggerSet -> LogStr -> IO ()
FastLogger.pushLogStrLn LoggerSet
loggerSet LogStr
str
  Just LoggedMessages
lm -> LoggedMessages -> LogStr -> m ()
forall (m :: * -> *). MonadIO m => LoggedMessages -> LogStr -> m ()
appendLogStr LoggedMessages
lm LogStr
str
  where loggerSet :: LoggerSet
loggerSet = Logger -> LoggerSet
getLoggerLoggerSet Logger
logger

flushLogStr :: MonadIO m => Logger -> m ()
flushLogStr :: Logger -> m ()
flushLogStr Logger
logger = case Logger -> Maybe LoggedMessages
lLoggedMessages Logger
logger of
  Maybe LoggedMessages
Nothing -> IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LoggerSet -> IO ()
FastLogger.flushLogStr LoggerSet
loggerSet
  Just LoggedMessages
_ -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where loggerSet :: LoggerSet
loggerSet = Logger -> LoggerSet
getLoggerLoggerSet Logger
logger

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
    lLoggedMessages :: Maybe a
lLoggedMessages = Maybe a
forall a. Maybe a
Nothing

  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)
-> Maybe LoggedMessages
-> Logger
Logger { Maybe LoggedMessages
LoggerSet
LogSource -> LogLevel -> Bool
LogLevel -> ByteString -> ByteString
forall a. Maybe a
lLoggedMessages :: forall a. Maybe a
lShouldLog :: LogSource -> LogLevel -> Bool
lReformat :: LogLevel -> ByteString -> ByteString
lLoggerSet :: LoggerSet
lLoggedMessages :: Maybe LoggedMessages
lShouldLog :: LogSource -> LogLevel -> Bool
lReformat :: LogLevel -> ByteString -> ByteString
lLoggerSet :: LoggerSet
.. }

-- | Create a 'Logger' that will capture log messages instead of logging them
--
-- See "Blammo.Logging.LoggedMessages" for more details.
--
newTestLogger :: MonadIO m => LogSettings -> m Logger
newTestLogger :: LogSettings -> m Logger
newTestLogger LogSettings
settings = Logger -> LoggedMessages -> Logger
go (Logger -> LoggedMessages -> Logger)
-> m Logger -> m (LoggedMessages -> Logger)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogSettings -> m Logger
forall (m :: * -> *). MonadIO m => LogSettings -> m Logger
newLogger LogSettings
settings m (LoggedMessages -> Logger) -> m LoggedMessages -> m Logger
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m LoggedMessages
forall (m :: * -> *). MonadIO m => m LoggedMessages
newLoggedMessages
 where
  go :: Logger -> LoggedMessages -> Logger
go Logger
logger LoggedMessages
loggedMessages =
    Logger
logger { lReformat :: LogLevel -> ByteString -> ByteString
lReformat = (ByteString -> ByteString) -> LogLevel -> ByteString -> ByteString
forall a b. a -> b -> a
const ByteString -> ByteString
forall a. a -> a
id, lLoggedMessages :: Maybe LoggedMessages
lLoggedMessages = LoggedMessages -> Maybe LoggedMessages
forall a. a -> Maybe a
Just LoggedMessages
loggedMessages }

-- | Return the logged messages if 'newTestLogger' was used
--
-- If not, the empty list is returned.
--
getLoggedMessages
  :: (MonadIO m, MonadReader env m, HasLogger env)
  => m [Either String LoggedMessage]
getLoggedMessages :: m [Either FilePath LoggedMessage]
getLoggedMessages = do
  Logger
logger <- Getting Logger env Logger -> m Logger
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Logger env Logger
forall env. HasLogger env => Lens' env Logger
loggerL
  m [Either FilePath LoggedMessage]
-> (LoggedMessages -> m [Either FilePath LoggedMessage])
-> Maybe LoggedMessages
-> m [Either FilePath LoggedMessage]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Either FilePath LoggedMessage]
-> m [Either FilePath LoggedMessage]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) LoggedMessages -> m [Either FilePath LoggedMessage]
forall (m :: * -> *).
MonadIO m =>
LoggedMessages -> m [Either FilePath LoggedMessage]
LoggedMessages.getLoggedMessages (Maybe LoggedMessages -> m [Either FilePath LoggedMessage])
-> Maybe LoggedMessages -> m [Either FilePath LoggedMessage]
forall a b. (a -> b) -> a -> b
$ Logger -> Maybe LoggedMessages
lLoggedMessages Logger
logger

-- | 'getLoggedMessages' but ignore any messages that fail to parse
getLoggedMessagesLenient
  :: (MonadIO m, MonadReader env m, HasLogger env) => m [LoggedMessage]
getLoggedMessagesLenient :: m [LoggedMessage]
getLoggedMessagesLenient = [Either FilePath LoggedMessage] -> [LoggedMessage]
forall a b. [Either a b] -> [b]
rights ([Either FilePath LoggedMessage] -> [LoggedMessage])
-> m [Either FilePath LoggedMessage] -> m [LoggedMessage]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Either FilePath LoggedMessage]
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
m [Either FilePath LoggedMessage]
getLoggedMessages

-- | 'getLoggedMessages' but 'throwString' if any messages failed to parse
getLoggedMessagesUnsafe
  :: (HasCallStack, MonadIO m, MonadReader env m, HasLogger env)
  => m [LoggedMessage]
getLoggedMessagesUnsafe :: m [LoggedMessage]
getLoggedMessagesUnsafe = do
  ([FilePath]
failed, [LoggedMessage]
succeeded) <- [Either FilePath LoggedMessage] -> ([FilePath], [LoggedMessage])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either FilePath LoggedMessage] -> ([FilePath], [LoggedMessage]))
-> m [Either FilePath LoggedMessage]
-> m ([FilePath], [LoggedMessage])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m [Either FilePath LoggedMessage]
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
m [Either FilePath LoggedMessage]
getLoggedMessages

  [LoggedMessage]
succeeded [LoggedMessage] -> m () -> m [LoggedMessage]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
    ([FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
failed)
    (FilePath -> m ()
forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString
    (FilePath -> m ()) -> FilePath -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n"
    ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Messages were logged that didn't parse as LoggedMessage:"
    FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
failed
    )