module Blammo.Logging.Logger
( Logger
, HasLogger(..)
, newLogger
, flushLogger
, pushLogger
, pushLoggerLn
, getLoggerLogSettings
, getLoggerReformat
, getLoggerShouldLog
, getLoggerShouldColor
, pushLogStrLn
, flushLogStr
, newTestLogger
, LoggedMessage(..)
, getLoggedMessages
, getLoggedMessagesLenient
, getLoggedMessagesUnsafe
) 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 Data.Text (Text)
import GHC.Stack (HasCallStack)
import System.IO (stderr, stdout)
import qualified System.Log.FastLogger as FastLogger
(flushLogStr, pushLogStr, pushLogStrLn)
import System.Log.FastLogger (LoggerSet, defaultBufSize)
import System.Log.FastLogger.Compat
(newFileLoggerSetN, newStderrLoggerSetN, newStdoutLoggerSetN)
import UnliftIO.Exception (throwString)
data Logger = Logger
{ Logger -> LogSettings
lLogSettings :: LogSettings
, Logger -> LoggerSet
lLoggerSet :: LoggerSet
, Logger -> LogLevel -> ByteString -> ByteString
lReformat :: LogLevel -> ByteString -> ByteString
, Logger -> LogSource -> LogLevel -> Bool
lShouldLog :: LogSource -> LogLevel -> Bool
, Logger -> Bool
lShouldColor :: Bool
, Logger -> Maybe LoggedMessages
lLoggedMessages :: Maybe LoggedMessages
}
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
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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LoggerSet -> LogStr -> IO ()
FastLogger.pushLogStr LoggerSet
loggerSet LogStr
str
Just LoggedMessages
lm -> 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LoggerSet -> LogStr -> IO ()
FastLogger.pushLogStrLn LoggerSet
loggerSet LogStr
str
Just LoggedMessages
lm -> 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 -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LoggerSet -> IO ()
FastLogger.flushLogStr LoggerSet
loggerSet
Just LoggedMessages
_ -> 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 :: Lens' Logger Logger
loggerL = forall a. a -> a
id
newLogger :: MonadIO m => LogSettings -> m Logger
newLogger :: forall (m :: * -> *). MonadIO m => LogSettings -> m Logger
newLogger LogSettings
settings = do
(LoggerSet
lLoggerSet, Bool
lShouldColor) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ case LogSettings -> LogDestination
getLogSettingsDestination LogSettings
settings of
LogDestination
LogDestinationStdout ->
(,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufSize -> Maybe BufSize -> IO LoggerSet
newStdoutLoggerSetN BufSize
defaultBufSize Maybe BufSize
concurrency
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadIO m => LogSettings -> Handle -> m Bool
shouldColorHandle LogSettings
settings Handle
stdout
LogDestination
LogDestinationStderr ->
(,)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BufSize -> Maybe BufSize -> IO LoggerSet
newStderrLoggerSetN BufSize
defaultBufSize Maybe BufSize
concurrency
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadIO m => LogSettings -> Handle -> m Bool
shouldColorHandle LogSettings
settings Handle
stderr
LogDestinationFile FilePath
path ->
(,)
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
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
Applicative m =>
LogSettings -> m Bool -> m Bool
shouldColorAuto LogSettings
settings (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 -> forall a b. a -> b -> a
const forall a. a -> a
id
LogFormat
LogFormatTerminal -> BufSize -> Bool -> LogLevel -> ByteString -> ByteString
reformatTerminal BufSize
breakpoint Bool
lShouldColor
lShouldLog :: LogSource -> LogLevel -> Bool
lShouldLog = LogSettings -> LogSource -> LogLevel -> Bool
shouldLogLevel LogSettings
settings
lLoggedMessages :: Maybe a
lLoggedMessages = forall a. Maybe a
Nothing
lLogSettings :: LogSettings
lLogSettings = LogSettings
settings
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Logger { Bool
LoggerSet
LogSettings
LogSource -> LogLevel -> Bool
LogLevel -> ByteString -> ByteString
forall a. Maybe a
lLogSettings :: LogSettings
lLoggedMessages :: forall a. Maybe a
lShouldLog :: LogSource -> LogLevel -> Bool
lReformat :: LogLevel -> ByteString -> ByteString
lShouldColor :: Bool
lLoggerSet :: LoggerSet
lLoggedMessages :: Maybe LoggedMessages
lShouldColor :: Bool
lShouldLog :: LogSource -> LogLevel -> Bool
lReformat :: LogLevel -> ByteString -> ByteString
lLoggerSet :: LoggerSet
lLogSettings :: LogSettings
.. }
where
breakpoint :: BufSize
breakpoint = LogSettings -> BufSize
getLogSettingsBreakpoint LogSettings
settings
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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasLogger env => Lens' env Logger
loggerL
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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasLogger env => Lens' env Logger
loggerL
forall (m :: * -> *). MonadIO m => Logger -> LogStr -> m ()
pushLogStr Logger
logger forall a b. (a -> b) -> a -> b
$ 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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasLogger env => Lens' env Logger
loggerL
forall (m :: * -> *). MonadIO m => Logger -> LogStr -> m ()
pushLogStrLn Logger
logger forall a b. (a -> b) -> a -> b
$ forall msg. ToLogStr msg => msg -> LogStr
toLogStr LogSource
msg
newTestLogger :: MonadIO m => LogSettings -> m Logger
newTestLogger :: forall (m :: * -> *). MonadIO m => LogSettings -> m Logger
newTestLogger LogSettings
settings = Logger -> LoggedMessages -> Logger
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => LogSettings -> m Logger
newLogger LogSettings
settings forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *). MonadIO m => m LoggedMessages
newLoggedMessages
where
go :: Logger -> LoggedMessages -> Logger
go Logger
logger LoggedMessages
loggedMessages =
Logger
logger { lReformat :: LogLevel -> ByteString -> ByteString
lReformat = forall a b. a -> b -> a
const forall a. a -> a
id, lLoggedMessages :: Maybe LoggedMessages
lLoggedMessages = forall a. a -> Maybe a
Just LoggedMessages
loggedMessages }
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 <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall env. HasLogger env => Lens' env Logger
loggerL
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure []) forall (m :: * -> *).
MonadIO m =>
LoggedMessages -> m [Either FilePath LoggedMessage]
LoggedMessages.getLoggedMessages forall a b. (a -> b) -> a -> b
$ Logger -> Maybe LoggedMessages
lLoggedMessages Logger
logger
getLoggedMessagesLenient
:: (MonadIO m, MonadReader env m, HasLogger env) => m [LoggedMessage]
getLoggedMessagesLenient :: forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
m [LoggedMessage]
getLoggedMessagesLenient = forall a b. [Either a b] -> [b]
rights forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
m [Either FilePath LoggedMessage]
getLoggedMessages
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) <- forall a b. [Either a b] -> ([a], [b])
partitionEithers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogger env) =>
m [Either FilePath LoggedMessage]
getLoggedMessages
[LoggedMessage]
succeeded forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
(forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
failed)
(forall (m :: * -> *) a.
(MonadIO m, HasCallStack) =>
FilePath -> m a
throwString
forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\n"
forall a b. (a -> b) -> a -> b
$ FilePath
"Messages were logged that didn't parse as LoggedMessage:"
forall a. a -> [a] -> [a]
: [FilePath]
failed
)