{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-|
Description: Composable logging actions for monad-logger, with a few predefined loggers.
-}
module Control.Monad.Logger.Extras where

import Control.Monad.Logger

import Data.ByteString.Char8 as C8
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import System.IO
import qualified System.Posix.Syslog as Posix

import System.Console.ANSI

-- | Run a 'LoggingT' action using the provided 'Logger'
runLoggerLoggingT :: LoggingT m a -> Logger -> m a
runLoggerLoggingT :: forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT LoggingT m a
f Logger
logger = LoggingT m a
f LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
`runLoggingT` Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
unLogger Logger
logger

-- | Type synonym for a logging action. See 'defaultLogStr' for the default
-- formatting of this data.
type LogF = Loc -> LogSource -> LogLevel -> LogStr -> IO ()

-- | A composable logging action.
newtype Logger = Logger { Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
unLogger :: LogF }
  deriving (NonEmpty Logger -> Logger
Logger -> Logger -> Logger
(Logger -> Logger -> Logger)
-> (NonEmpty Logger -> Logger)
-> (forall b. Integral b => b -> Logger -> Logger)
-> Semigroup Logger
forall b. Integral b => b -> Logger -> Logger
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Logger -> Logger -> Logger
<> :: Logger -> Logger -> Logger
$csconcat :: NonEmpty Logger -> Logger
sconcat :: NonEmpty Logger -> Logger
$cstimes :: forall b. Integral b => b -> Logger -> Logger
stimes :: forall b. Integral b => b -> Logger -> Logger
Semigroup, Semigroup Logger
Logger
Semigroup Logger =>
Logger
-> (Logger -> Logger -> Logger)
-> ([Logger] -> Logger)
-> Monoid Logger
[Logger] -> Logger
Logger -> Logger -> Logger
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Logger
mempty :: Logger
$cmappend :: Logger -> Logger -> Logger
mappend :: Logger -> Logger -> Logger
$cmconcat :: [Logger] -> Logger
mconcat :: [Logger] -> Logger
Monoid)

-- | Composable stderr logging action.
logToStderr :: Logger
logToStderr :: Logger
logToStderr = (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger
Logger ((Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
defaultOutput Handle
stderr

-- | Composable stdout logging action.
logToStdout :: Logger
logToStdout :: Logger
logToStdout = (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger
Logger ((Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ Handle -> Loc -> Text -> LogLevel -> LogStr -> IO ()
defaultOutput Handle
stdout

-- | This logger doesn't perform any logging action.
logToNowhere :: Logger
logToNowhere :: Logger
logToNowhere = Logger
forall a. Monoid a => a
mempty

-- | Log messages to a posix system log. The string argument is a tag that can
-- be used to identify log messages produced by this logger.
-- You can, for instance, run @journalctl --user -t mytag@ to see log messages
-- tagged with @"mytag"@.
logToSyslog :: String -> Logger
logToSyslog :: String -> Logger
logToSyslog String
tagstr = (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger
Logger ((Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Loc
loc Text
src LogLevel
lvl LogStr
str -> do
  let syslogPriority :: Priority
syslogPriority = case LogLevel
lvl of
        LogLevel
LevelDebug -> Priority
Posix.Debug
        LogLevel
LevelInfo -> Priority
Posix.Info
        LogLevel
LevelWarn -> Priority
Posix.Warning
        LogLevel
LevelError -> Priority
Posix.Error
        LevelOther Text
_ -> Priority
Posix.Info
      out :: LogStr
out = Loc -> Text -> LogLevel -> LogStr -> LogStr
defaultLogStr Loc
loc Text
src LogLevel
lvl LogStr
str
  String -> [Option] -> Facility -> IO () -> IO ()
forall a. String -> [Option] -> Facility -> IO a -> IO a
Posix.withSyslog String
tagstr [Option
Posix.DelayedOpen] Facility
Posix.User (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen (LogStr -> ByteString
fromLogStr LogStr
out) ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      Maybe Facility -> Priority -> CStringLen -> IO ()
Posix.syslog Maybe Facility
forall a. Maybe a
Nothing Priority
syslogPriority

-- | Add colors to your log output based on 'LogLevel'. Colors can be
-- customized by using 'colorizeWith' instead.
colorize :: Logger -> Logger
colorize :: Logger -> Logger
colorize = [(LogLevel, Color)] -> Logger -> Logger
colorizeWith [(LogLevel, Color)]
defaultColors

-- | Add a custom set of colors to your log output. See 'defaultColors' for an
-- example.
colorizeWith :: [(LogLevel, Color)] -> Logger -> Logger
colorizeWith :: [(LogLevel, Color)] -> Logger -> Logger
colorizeWith [(LogLevel, Color)]
colorMap Logger
f = (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger
Logger ((Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> Logger
forall a b. (a -> b) -> a -> b
$ \Loc
loc Text
src LogLevel
lvl LogStr
str ->
  let c :: LogStr -> LogStr
c LogStr
s = case LogLevel -> [(LogLevel, Color)] -> Maybe Color
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup LogLevel
lvl [(LogLevel, Color)]
colorMap of
        Maybe Color
Nothing -> LogStr
str
        Just Color
color -> (ByteString -> ByteString) -> LogStr -> LogStr
forall msg. ToLogStr msg => (ByteString -> msg) -> LogStr -> LogStr
mapLogStrBS (Color -> ByteString -> ByteString
wrapSGRColor Color
color) LogStr
s
  in Logger -> Loc -> Text -> LogLevel -> LogStr -> IO ()
unLogger Logger
f Loc
loc Text
src LogLevel
lvl (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr -> LogStr
c LogStr
str

-- | The default color mapping used by 'colorize'.
defaultColors :: [(LogLevel, Color)]
defaultColors :: [(LogLevel, Color)]
defaultColors =
  [ (LogLevel
LevelDebug, Color
Green)
  , (LogLevel
LevelInfo, Color
Blue)
  , (LogLevel
LevelWarn, Color
Yellow)
  , (LogLevel
LevelError, Color
Red)
  ]

-- | Map a function over a log string.
mapLogStrBS :: ToLogStr msg => (ByteString -> msg) -> LogStr -> LogStr
mapLogStrBS :: forall msg. ToLogStr msg => (ByteString -> msg) -> LogStr -> LogStr
mapLogStrBS ByteString -> msg
f = msg -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (msg -> LogStr) -> (LogStr -> msg) -> LogStr -> LogStr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> msg
f (ByteString -> msg) -> (LogStr -> ByteString) -> LogStr -> msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogStr -> ByteString
fromLogStr

-- | Apply 'SGR' codes to a string to modify its display attributes, resetting
-- SGR codes afterward.
wrapSGRCode :: [SGR] -> ByteString -> ByteString
wrapSGRCode :: [SGR] -> ByteString -> ByteString
wrapSGRCode [SGR]
codes ByteString
t = [ByteString] -> ByteString
forall a. Monoid a => [a] -> a
mconcat
  [ String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR]
codes
  , ByteString
t
  , String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [SGR] -> String
setSGRCode [SGR
Reset]
  ]

-- | Apply an SGR color code to a string, unsetting the color after the string.
wrapSGRColor :: Color -> ByteString -> ByteString
wrapSGRColor :: Color -> ByteString -> ByteString
wrapSGRColor Color
c = [SGR] -> ByteString -> ByteString
wrapSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Vivid Color
c]

-- | A handy test
test :: IO ()
test :: IO ()
test = do
  let logger :: Logger
logger = Logger -> Logger
colorize Logger
logToStderr Logger -> Logger -> Logger
forall a. Semigroup a => a -> a -> a
<> String -> Logger
logToSyslog String
"log-test"
  (LoggingT IO () -> Logger -> IO ())
-> Logger -> LoggingT IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO () -> Logger -> IO ()
forall (m :: * -> *) a. LoggingT m a -> Logger -> m a
runLoggerLoggingT Logger
logger (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Text -> LoggingT IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logDebugN Text
"This is a debug message."
    Text -> LoggingT IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logInfoN Text
"This is an info message."
    Text -> LoggingT IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logWarnN Text
"This is a warning."
    Text -> LoggingT IO ()
forall (m :: * -> *). MonadLogger m => Text -> m ()
logErrorN Text
"This is an error!"