module Blammo.Logging.Logger
  ( Logger
  , HasLogger (..)
  , withLogger
  , newLogger
  , flushLogger
  , pushLogger
  , pushLoggerLn
  , getLoggerLogSettings
  , getLoggerReformat
  , setLoggerReformat
  , getLoggerShouldLog
  , getLoggerShouldColor
  , pushLogStrLn
  , flushLogStr
  , runLogAction

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

import Prelude

import Blammo.Logging.Colors (Colors, getColors)
import Blammo.Logging.Internal.Logger
import Blammo.Logging.LogSettings
import Blammo.Logging.Terminal
import Blammo.Logging.Test hiding (getLoggedMessages)
import qualified Blammo.Logging.Test as LoggedMessages
import Control.Lens (view)
import Control.Monad (unless, when)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Logger.Aeson
import Control.Monad.Reader (MonadReader)
import qualified Data.Aeson as Aeson
import Data.ByteString (ByteString)
import Data.Either (partitionEithers, rights)
import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import GHC.Stack (HasCallStack)
import System.IO (stderr, stdout)
import System.Log.FastLogger (LoggerSet, defaultBufSize)
import qualified System.Log.FastLogger as FastLogger
  ( flushLogStr
  , pushLogStr
  , pushLogStrLn
  )
import System.Log.FastLogger.Compat
  ( newFileLoggerSetN
  , newStderrLoggerSetN
  , newStdoutLoggerSetN
  )
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (finally, throwString)

-- | Initialize logging, pass a 'Logger' to the callback, and clean up at the end
--
-- Applications should avoid calling this more than once in their lifecycle.
withLogger :: MonadUnliftIO m => LogSettings -> (Logger -> m a) -> m a
withLogger :: forall (m :: * -> *) a.
MonadUnliftIO m =>
LogSettings -> (Logger -> m a) -> m a
withLogger LogSettings
settings Logger -> m a
f = do
  Logger
logger <- LogSettings -> m Logger
forall (m :: * -> *). MonadIO m => LogSettings -> m Logger
newLogger LogSettings
settings
  Logger -> m a
f Logger
logger m a -> m () -> m a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` Logger -> m ()
forall (m :: * -> *). MonadIO m => Logger -> m ()
flushLogStr Logger
logger

-- | Write a message to the 'Logger', unless the logger's filter options
--   reject it based on its 'LogSource' and 'LogLevel'
runLogAction
  :: (MonadIO m, ToLogStr msg)
  => Logger
  -> Loc
  -> LogSource
  -> LogLevel
  -> msg
  -> m ()
runLogAction :: forall (m :: * -> *) msg.
(MonadIO m, ToLogStr msg) =>
Logger -> Loc -> LogSource -> LogLevel -> msg -> m ()
runLogAction Logger
logger Loc
loc LogSource
source LogLevel
level msg
msg =
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> LogSource -> LogLevel -> Bool
lShouldLog Logger
logger LogSource
source LogLevel
level) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      OutputOptions -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
defaultOutputWith OutputOptions
options Loc
loc LogSource
source LogLevel
level (msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr msg
msg)
 where
  options :: OutputOptions
options = (LogLevel -> ByteString -> IO ()) -> OutputOptions
defaultOutputOptions ((LogLevel -> ByteString -> IO ()) -> OutputOptions)
-> (LogLevel -> ByteString -> IO ()) -> OutputOptions
forall a b. (a -> b) -> a -> b
$ \LogLevel
logLevel ByteString
bytes ->
    Logger -> LogStr -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> LogStr -> m ()
pushLogStrLn Logger
logger (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> LogStr) -> ByteString -> LogStr
forall a b. (a -> b) -> a -> b
$ Logger -> LogLevel -> ByteString -> ByteString
getLoggerReformat Logger
logger LogLevel
logLevel ByteString
bytes

getLoggerLogSettings :: Logger -> LogSettings
getLoggerLogSettings :: Logger -> LogSettings
getLoggerLogSettings = Logger -> LogSettings
lLogSettings

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

setLoggerReformat
  :: (LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString)
  -> Logger
  -> Logger
setLoggerReformat :: (LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString)
-> Logger -> Logger
setLoggerReformat LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString
f Logger
logger =
  Logger
logger
    { lReformat = \LogLevel
level ByteString
bytes -> ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
bytes (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        LoggedMessage
lm <- ByteString -> Maybe LoggedMessage
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decodeStrict ByteString
bytes
        ByteString -> Maybe ByteString
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe ByteString) -> ByteString -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString
f (Logger -> LogSettings
lLogSettings Logger
logger) (Bool -> Colors
getColors (Bool -> Colors) -> Bool -> Colors
forall a b. (a -> b) -> a -> b
$ Logger -> Bool
lShouldColor Logger
logger) LogLevel
level LoggedMessage
lm
    }

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

getLoggerShouldColor :: Logger -> Bool
getLoggerShouldColor :: Logger -> Bool
getLoggerShouldColor = Logger -> Bool
lShouldColor

pushLogStr :: MonadIO m => Logger -> LogStr -> m ()
pushLogStr :: forall (m :: * -> *). MonadIO m => Logger -> LogStr -> m ()
pushLogStr Logger
logger LogStr
str = case Logger -> Maybe LoggedMessages
lLoggedMessages Logger
logger of
  Maybe LoggedMessages
Nothing -> IO () -> m ()
forall a. IO a -> m a
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.pushLogStr 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

pushLogStrLn :: MonadIO m => Logger -> LogStr -> m ()
pushLogStrLn :: forall (m :: * -> *). MonadIO m => Logger -> LogStr -> m ()
pushLogStrLn Logger
logger LogStr
str = case Logger -> Maybe LoggedMessages
lLoggedMessages Logger
logger of
  Maybe LoggedMessages
Nothing -> IO () -> m ()
forall a. IO a -> m a
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 ()
appendLogStrLn LoggedMessages
lm LogStr
str
 where
  loggerSet :: LoggerSet
loggerSet = Logger -> LoggerSet
getLoggerLoggerSet Logger
logger

flushLogStr :: MonadIO m => Logger -> m ()
flushLogStr :: forall (m :: * -> *). MonadIO m => Logger -> m ()
flushLogStr Logger
logger = case Logger -> Maybe LoggedMessages
lLoggedMessages Logger
logger of
  Maybe LoggedMessages
Nothing -> IO () -> m ()
forall a. IO a -> m a
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 a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
 where
  loggerSet :: LoggerSet
loggerSet = Logger -> LoggerSet
getLoggerLoggerSet Logger
logger

newLogger :: MonadIO m => LogSettings -> m Logger
newLogger :: forall (m :: * -> *). MonadIO m => LogSettings -> m Logger
newLogger LogSettings
settings = do
  (LoggerSet
lLoggerSet, Bool
lShouldColor) <-
    IO (LoggerSet, Bool) -> m (LoggerSet, Bool)
forall a. IO a -> m a
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 -> Maybe BufSize -> IO LoggerSet
newStdoutLoggerSetN BufSize
defaultBufSize Maybe BufSize
concurrency
          IO (Bool -> (LoggerSet, Bool)) -> IO Bool -> IO (LoggerSet, Bool)
forall a b. IO (a -> b) -> IO a -> IO b
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 -> Maybe BufSize -> IO LoggerSet
newStderrLoggerSetN BufSize
defaultBufSize Maybe BufSize
concurrency
          IO (Bool -> (LoggerSet, Bool)) -> IO Bool -> IO (LoggerSet, Bool)
forall a b. IO (a -> b) -> IO a -> IO b
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 -> Maybe BufSize -> FilePath -> IO LoggerSet
newFileLoggerSetN BufSize
defaultBufSize Maybe BufSize
concurrency FilePath
path
          IO (Bool -> (LoggerSet, Bool)) -> IO Bool -> IO (LoggerSet, Bool)
forall a b. IO (a -> b) -> IO a -> IO b
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False)

  let logger :: Logger
logger =
        Logger
          { lLogSettings :: LogSettings
lLogSettings = LogSettings
settings
          , lLoggerSet :: LoggerSet
lLoggerSet = LoggerSet
lLoggerSet
          , lReformat :: LogLevel -> ByteString -> ByteString
lReformat = (ByteString -> ByteString) -> LogLevel -> ByteString -> ByteString
forall a b. a -> b -> a
const ByteString -> ByteString
forall a. a -> a
id -- By default render (JSON) bytestring as-is
          , lShouldLog :: LogSource -> LogLevel -> Bool
lShouldLog = LogSettings -> LogSource -> LogLevel -> Bool
shouldLogLevel LogSettings
settings
          , lShouldColor :: Bool
lShouldColor = Bool
lShouldColor
          , lLoggedMessages :: Maybe LoggedMessages
lLoggedMessages = Maybe LoggedMessages
forall a. Maybe a
Nothing
          }

  Logger -> m Logger
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Logger -> m Logger) -> Logger -> m Logger
forall a b. (a -> b) -> a -> b
$ case LogSettings -> LogFormat
getLogSettingsFormat LogSettings
settings of
    LogFormat
LogFormatJSON -> Logger
logger
    LogFormat
LogFormatTerminal -> (LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString)
-> Logger -> Logger
setLoggerReformat LogSettings -> Colors -> LogLevel -> LoggedMessage -> ByteString
reformatTerminal Logger
logger
 where
  concurrency :: Maybe BufSize
concurrency = LogSettings -> Maybe BufSize
getLogSettingsConcurrency LogSettings
settings

flushLogger :: (MonadIO m, MonadReader env m, HasLogger env) => m ()
flushLogger :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
m ()
flushLogger = 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
Lens' env Logger
loggerL
  Logger -> m ()
forall (m :: * -> *). MonadIO m => Logger -> m ()
flushLogStr Logger
logger

pushLogger :: (MonadIO m, MonadReader env m, HasLogger env) => Text -> m ()
pushLogger :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
LogSource -> m ()
pushLogger LogSource
msg = 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
Lens' env Logger
loggerL
  Logger -> LogStr -> m ()
forall (m :: * -> *). MonadIO m => Logger -> LogStr -> m ()
pushLogStr Logger
logger (LogStr -> m ()) -> LogStr -> m ()
forall a b. (a -> b) -> a -> b
$ LogSource -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogSource
msg

pushLoggerLn :: (MonadIO m, MonadReader env m, HasLogger env) => Text -> m ()
pushLoggerLn :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
LogSource -> m ()
pushLoggerLn LogSource
msg = 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
Lens' env Logger
loggerL
  Logger -> LogStr -> m ()
forall (m :: * -> *). MonadIO m => Logger -> LogStr -> m ()
pushLogStrLn Logger
logger (LogStr -> m ()) -> LogStr -> m ()
forall a b. (a -> b) -> a -> b
$ LogSource -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogSource
msg

-- | 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 :: forall (m :: * -> *). MonadIO m => 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 a b. m (a -> b) -> m a -> m b
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 = const id, lLoggedMessages = Just 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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
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
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 a. a -> m a
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 :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
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 :: forall (m :: * -> *) env.
(HasCallStack, MonadIO m, MonadReader env m, HasLogger env) =>
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 a b. a -> m b -> m a
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 a. [a] -> 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
      )