{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-}
-- | This module contains implementation of most commonly used logging backends.
-- You can write your own backends, by implementing an instance of @IsLogBackend@
-- type class.
module System.Log.Heavy.Backends
  (
  -- $description
  -- * Backends
  FastLoggerBackend,
  SyslogBackend,
  ChanLoggerBackend,
  ParallelBackend,
  NullBackend,
  Filtering, filtering, excluding,
  LogBackendSettings (..),
  -- * Default settings
  defStdoutSettings,
  defStderrSettings,
  defFileSettings,
  defaultSyslogSettings,
  defaultSyslogFormat
  ) where

import Control.Monad
import Control.Monad.Trans (liftIO)
import Control.Concurrent
import qualified Data.ByteString.Unsafe as BSU
import qualified Data.Text.Format.Heavy as F
import qualified System.Posix.Syslog as Syslog
import System.Log.FastLogger as FL
import Foreign.C.String (CString, newCString)
import Foreign.Marshal.Alloc (free)

import System.Log.Heavy.Types
import System.Log.Heavy.Level
import System.Log.Heavy.Format
import System.Log.Heavy.Util

-- $description
--
-- This module contains several implementation of logging backend.
-- A backend is some kind of target, where your messages will go.
-- Each backend has its own specific settings.
--
-- Backends provided are:
--
-- * Fast-logger backend. It allows to write messages to stdout, stderr or arbitrary file.
--
-- * Syslog backend.
--
-- * Chan backend.
--
-- * Null backend. This discards all messages. Can be used to disable logging.
--
-- There are also some backend combinators:
--
-- * Filtering - passes messages, that match specified filter,
--   to underlying backend.
--
-- * FilteringM - similar to Filtering, but allows to change the filter in runtime.
--
-- * Parallel - writes messages to several backends in parallel.
--
-- * Dynamic - allows to change underlying backend or its settings in runtime.
--

-- | Default settings for fast-logger stdout output
defStdoutSettings :: LogBackendSettings FastLoggerBackend
defStdoutSettings :: LogBackendSettings FastLoggerBackend
defStdoutSettings = Format -> LogType -> LogBackendSettings FastLoggerBackend
FastLoggerSettings Format
defaultLogFormat (BufSize -> LogType
FL.LogStdout BufSize
FL.defaultBufSize)

-- | Default settings for fast-logger stderr output
defStderrSettings :: LogBackendSettings FastLoggerBackend
defStderrSettings :: LogBackendSettings FastLoggerBackend
defStderrSettings = Format -> LogType -> LogBackendSettings FastLoggerBackend
FastLoggerSettings Format
defaultLogFormat (BufSize -> LogType
FL.LogStderr BufSize
FL.defaultBufSize)

-- | Default settings for fast-logger file output.
-- This implies log rotation when log file size reaches 10Mb.
defFileSettings :: FilePath -> LogBackendSettings FastLoggerBackend
defFileSettings :: FilePath -> LogBackendSettings FastLoggerBackend
defFileSettings FilePath
path = Format -> LogType -> LogBackendSettings FastLoggerBackend
FastLoggerSettings Format
defaultLogFormat (FileLogSpec -> BufSize -> LogType
FL.LogFile FileLogSpec
spec BufSize
FL.defaultBufSize)
  where spec :: FileLogSpec
spec = FilePath -> Integer -> BufSize -> FileLogSpec
FL.FileLogSpec FilePath
path (Integer
10Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
1024Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
1024) BufSize
3

-- | Fast-logger logging backend.
data FastLoggerBackend = FastLoggerBackend {
    FastLoggerBackend -> LogBackendSettings FastLoggerBackend
flbSettings :: LogBackendSettings FastLoggerBackend,
    FastLoggerBackend -> TimedFastLogger
flbTimedLogger :: TimedFastLogger,
    FastLoggerBackend -> IO ()
flbCleanup :: IO ()
  }

instance IsLogBackend FastLoggerBackend where
    -- | Settings of fast-logger backend. This mostly reflects settings of fast-logger itself.
    data LogBackendSettings FastLoggerBackend = FastLoggerSettings {
        LogBackendSettings FastLoggerBackend -> Format
lsFormat :: F.Format -- ^ Log message format
      , LogBackendSettings FastLoggerBackend -> LogType
lsType :: FL.LogType   -- ^ Fast-logger target settings
      }

    initLogBackend :: LogBackendSettings FastLoggerBackend -> IO FastLoggerBackend
initLogBackend LogBackendSettings FastLoggerBackend
settings = do
        IO FormattedTime
tcache <- FormattedTime -> IO (IO FormattedTime)
newTimeCache FormattedTime
simpleTimeFormat'
        (TimedFastLogger
logger, IO ()
cleanup) <- IO FormattedTime -> LogType -> IO (TimedFastLogger, IO ())
newTimedFastLogger IO FormattedTime
tcache (LogBackendSettings FastLoggerBackend -> LogType
lsType LogBackendSettings FastLoggerBackend
settings)
        FastLoggerBackend -> IO FastLoggerBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (FastLoggerBackend -> IO FastLoggerBackend)
-> FastLoggerBackend -> IO FastLoggerBackend
forall a b. (a -> b) -> a -> b
$ LogBackendSettings FastLoggerBackend
-> TimedFastLogger -> IO () -> FastLoggerBackend
FastLoggerBackend LogBackendSettings FastLoggerBackend
settings TimedFastLogger
logger IO ()
cleanup

    cleanupLogBackend :: FastLoggerBackend -> IO ()
cleanupLogBackend FastLoggerBackend
b = do
        FastLoggerBackend -> IO ()
flbCleanup FastLoggerBackend
b

    makeLogger :: Logger FastLoggerBackend
makeLogger FastLoggerBackend
backend LogMessage
msg = do
      let settings :: LogBackendSettings FastLoggerBackend
settings = FastLoggerBackend -> LogBackendSettings FastLoggerBackend
flbSettings FastLoggerBackend
backend
      let format :: Format
format = LogBackendSettings FastLoggerBackend -> Format
lsFormat LogBackendSettings FastLoggerBackend
settings
      let logger :: TimedFastLogger
logger = FastLoggerBackend -> TimedFastLogger
flbTimedLogger FastLoggerBackend
backend
      TimedFastLogger
logger TimedFastLogger -> TimedFastLogger
forall a b. (a -> b) -> a -> b
$ Format -> LogMessage -> FormattedTime -> LogStr
formatLogMessage Format
format LogMessage
msg

-- | Default settings for syslog backend
defaultSyslogSettings :: LogBackendSettings SyslogBackend
defaultSyslogSettings :: LogBackendSettings SyslogBackend
defaultSyslogSettings = Format
-> FilePath
-> [Option]
-> Facility
-> LogBackendSettings SyslogBackend
SyslogSettings Format
defaultSyslogFormat FilePath
"application" [] Facility
Syslog.User

-- | Default log message format fof syslog backend:
-- @[{level}] {source}: {message}@
defaultSyslogFormat :: F.Format
defaultSyslogFormat :: Format
defaultSyslogFormat = Format
"[{level}] {source}: {message}"

-- | Syslog logging backend.
data SyslogBackend = SyslogBackend {
    SyslogBackend -> LogBackendSettings SyslogBackend
sbSettings :: LogBackendSettings SyslogBackend,
    SyslogBackend -> CString
sbIdent :: CString,
    SyslogBackend -> IO FormattedTime
sbTimeCache :: IO FormattedTime
  }

instance IsLogBackend SyslogBackend where
    -- | Settings for syslog backend. This mostly reflects syslog API.
    data LogBackendSettings SyslogBackend = SyslogSettings {
        LogBackendSettings SyslogBackend -> Format
ssFormat :: F.Format         -- ^ Log message format. Usually you do not want to put time here,
                                      --   because syslog writes time to log by itself by default.
      , LogBackendSettings SyslogBackend -> FilePath
ssIdent :: String             -- ^ Syslog source identifier. Usually the name of your program.
      , LogBackendSettings SyslogBackend -> [Option]
ssOptions :: [Syslog.Option]  -- ^ Syslog options
      , LogBackendSettings SyslogBackend -> Facility
ssFacility :: Syslog.Facility -- ^ Syslog facility. It is usally User, if you are writing user-space
                                      --   program.
      }

    initLogBackend :: LogBackendSettings SyslogBackend -> IO SyslogBackend
initLogBackend LogBackendSettings SyslogBackend
settings = do
        CString
ident <- FilePath -> IO CString
newCString (LogBackendSettings SyslogBackend -> FilePath
ssIdent LogBackendSettings SyslogBackend
settings)
        IO FormattedTime
tcache <- FormattedTime -> IO (IO FormattedTime)
newTimeCache FormattedTime
simpleTimeFormat'
        CString -> [Option] -> Facility -> IO ()
Syslog.openlog CString
ident (LogBackendSettings SyslogBackend -> [Option]
ssOptions LogBackendSettings SyslogBackend
settings) (LogBackendSettings SyslogBackend -> Facility
ssFacility LogBackendSettings SyslogBackend
settings)
        SyslogBackend -> IO SyslogBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (SyslogBackend -> IO SyslogBackend)
-> SyslogBackend -> IO SyslogBackend
forall a b. (a -> b) -> a -> b
$ LogBackendSettings SyslogBackend
-> CString -> IO FormattedTime -> SyslogBackend
SyslogBackend LogBackendSettings SyslogBackend
settings CString
ident IO FormattedTime
tcache

    cleanupLogBackend :: SyslogBackend -> IO ()
cleanupLogBackend SyslogBackend
backend = do
        CString -> IO ()
forall a. Ptr a -> IO ()
free (CString -> IO ()) -> CString -> IO ()
forall a b. (a -> b) -> a -> b
$ SyslogBackend -> CString
sbIdent SyslogBackend
backend
        IO ()
Syslog.closelog

    makeLogger :: Logger SyslogBackend
makeLogger SyslogBackend
backend LogMessage
msg = do
        let settings :: LogBackendSettings SyslogBackend
settings = SyslogBackend -> LogBackendSettings SyslogBackend
sbSettings SyslogBackend
backend
        let format :: Format
format = LogBackendSettings SyslogBackend -> Format
ssFormat LogBackendSettings SyslogBackend
settings
            facility :: Facility
facility = LogBackendSettings SyslogBackend -> Facility
ssFacility LogBackendSettings SyslogBackend
settings
            tcache :: IO FormattedTime
tcache = SyslogBackend -> IO FormattedTime
sbTimeCache SyslogBackend
backend
        FormattedTime
time <- IO FormattedTime
tcache
        let str :: LogStr
str = Format -> LogMessage -> FormattedTime -> LogStr
formatLogMessage Format
format LogMessage
msg FormattedTime
time
        FormattedTime -> (CStringLen -> IO ()) -> IO ()
forall a. FormattedTime -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen (LogStr -> FormattedTime
fromLogStr LogStr
str) ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
            Maybe Facility -> Priority -> CStringLen -> IO ()
Syslog.syslog (Facility -> Maybe Facility
forall a. a -> Maybe a
Just Facility
facility) (Level -> Priority
levelToPriority (Level -> Priority) -> Level -> Priority
forall a b. (a -> b) -> a -> b
$ LogMessage -> Level
lmLevel LogMessage
msg)

-- | Logging backend which writes all messages to the @Chan@
data ChanLoggerBackend = ChanLoggerBackend {
       ChanLoggerBackend -> Chan LogMessage
clChan :: Chan LogMessage  -- ^ @Chan@ where write messages to
     }

instance IsLogBackend ChanLoggerBackend where
  data LogBackendSettings ChanLoggerBackend =
    ChanLoggerSettings (Chan LogMessage)

  initLogBackend :: LogBackendSettings ChanLoggerBackend -> IO ChanLoggerBackend
initLogBackend (ChanLoggerSettings chan) =
    ChanLoggerBackend -> IO ChanLoggerBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (ChanLoggerBackend -> IO ChanLoggerBackend)
-> ChanLoggerBackend -> IO ChanLoggerBackend
forall a b. (a -> b) -> a -> b
$ Chan LogMessage -> ChanLoggerBackend
ChanLoggerBackend Chan LogMessage
chan

  cleanupLogBackend :: ChanLoggerBackend -> IO ()
cleanupLogBackend ChanLoggerBackend
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  makeLogger :: Logger ChanLoggerBackend
makeLogger ChanLoggerBackend
backend LogMessage
msg = do
    IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Chan LogMessage -> LogMessage -> IO ()
forall a. Chan a -> a -> IO ()
writeChan (ChanLoggerBackend -> Chan LogMessage
clChan ChanLoggerBackend
backend) LogMessage
msg

-- | Logging backend that writes log messages to several other backends in parallel.
data ParallelBackend = ParallelBackend ![AnyLogBackend]

instance IsLogBackend ParallelBackend where
  data LogBackendSettings ParallelBackend = ParallelLogSettings [LoggingSettings]

  wouldWriteMessage :: ParallelBackend -> LogMessage -> IO Bool
wouldWriteMessage (ParallelBackend [AnyLogBackend]
list) LogMessage
msg = do
    [Bool]
results <- [IO Bool] -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [AnyLogBackend -> LogMessage -> IO Bool
forall b. IsLogBackend b => b -> LogMessage -> IO Bool
wouldWriteMessage AnyLogBackend
backend LogMessage
msg | AnyLogBackend
backend <- [AnyLogBackend]
list]
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
results

  makeLogger :: Logger ParallelBackend
makeLogger (ParallelBackend [AnyLogBackend]
list) LogMessage
msg =
    [AnyLogBackend] -> (AnyLogBackend -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [AnyLogBackend]
list ((AnyLogBackend -> IO ()) -> IO ())
-> (AnyLogBackend -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(AnyLogBackend b
backend) -> Logger b
forall b. IsLogBackend b => Logger b
makeLogger b
backend LogMessage
msg

  initLogBackend :: LogBackendSettings ParallelBackend -> IO ParallelBackend
initLogBackend (ParallelLogSettings list) = do
    [AnyLogBackend]
backends <- do 
                [LoggingSettings]
-> (LoggingSettings -> IO AnyLogBackend) -> IO [AnyLogBackend]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [LoggingSettings]
list ((LoggingSettings -> IO AnyLogBackend) -> IO [AnyLogBackend])
-> (LoggingSettings -> IO AnyLogBackend) -> IO [AnyLogBackend]
forall a b. (a -> b) -> a -> b
$ \(LoggingSettings LogBackendSettings b
settings) -> do
                  b
backend <- LogBackendSettings b -> IO b
forall b. IsLogBackend b => LogBackendSettings b -> IO b
initLogBackend LogBackendSettings b
settings
                  AnyLogBackend -> IO AnyLogBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (AnyLogBackend -> IO AnyLogBackend)
-> AnyLogBackend -> IO AnyLogBackend
forall a b. (a -> b) -> a -> b
$ b -> AnyLogBackend
forall b. IsLogBackend b => b -> AnyLogBackend
AnyLogBackend b
backend
    ParallelBackend -> IO ParallelBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (ParallelBackend -> IO ParallelBackend)
-> ParallelBackend -> IO ParallelBackend
forall a b. (a -> b) -> a -> b
$ [AnyLogBackend] -> ParallelBackend
ParallelBackend [AnyLogBackend]
backends
      
  cleanupLogBackend :: ParallelBackend -> IO ()
cleanupLogBackend (ParallelBackend [AnyLogBackend]
list) =
    [AnyLogBackend] -> (AnyLogBackend -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([AnyLogBackend] -> [AnyLogBackend]
forall a. [a] -> [a]
reverse [AnyLogBackend]
list) ((AnyLogBackend -> IO ()) -> IO ())
-> (AnyLogBackend -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(AnyLogBackend b
backend) -> b -> IO ()
forall b. IsLogBackend b => b -> IO ()
cleanupLogBackend b
backend

-- | Messages filtering backend. This backend passes a message to underlying backend,
-- if this message conforms to specified filter.
data Filtering b = FilteringBackend (LogMessage -> Bool) b

-- | Specify filter as @LogFilter@.
filtering :: IsLogBackend b => LogFilter -> LogBackendSettings b -> LogBackendSettings (Filtering b)
filtering :: LogFilter
-> LogBackendSettings b -> LogBackendSettings (Filtering b)
filtering LogFilter
fltr LogBackendSettings b
b = (LogMessage -> Bool)
-> LogBackendSettings b -> LogBackendSettings (Filtering b)
forall b.
(LogMessage -> Bool)
-> LogBackendSettings b -> LogBackendSettings (Filtering b)
Filtering (LogFilter -> LogMessage -> Bool
checkLogLevel LogFilter
fltr) LogBackendSettings b
b

-- | Exclude messages by filter.
excluding :: IsLogBackend b => LogFilter -> LogBackendSettings b -> LogBackendSettings (Filtering b)
excluding :: LogFilter
-> LogBackendSettings b -> LogBackendSettings (Filtering b)
excluding LogFilter
fltr LogBackendSettings b
b = (LogMessage -> Bool)
-> LogBackendSettings b -> LogBackendSettings (Filtering b)
forall b.
(LogMessage -> Bool)
-> LogBackendSettings b -> LogBackendSettings (Filtering b)
Filtering LogMessage -> Bool
ex LogBackendSettings b
b
  where
    ex :: LogMessage -> Bool
ex LogMessage
msg = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [LogContextFilter] -> LogSource -> Level -> Bool
checkContextFilter' [Maybe LogFilter -> Maybe LogFilter -> LogContextFilter
LogContextFilter Maybe LogFilter
forall a. Maybe a
Nothing (LogFilter -> Maybe LogFilter
forall a. a -> Maybe a
Just LogFilter
fltr)] (LogMessage -> LogSource
lmSource LogMessage
msg) (LogMessage -> Level
lmLevel LogMessage
msg)

instance IsLogBackend b => IsLogBackend (Filtering b) where
  data LogBackendSettings (Filtering b) = Filtering (LogMessage -> Bool) (LogBackendSettings b)

  wouldWriteMessage :: Filtering b -> LogMessage -> IO Bool
wouldWriteMessage (FilteringBackend LogMessage -> Bool
fltr b
_) LogMessage
msg = do
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ LogMessage -> Bool
fltr LogMessage
msg

  makeLogger :: Logger (Filtering b)
makeLogger (FilteringBackend LogMessage -> Bool
fltr b
backend) LogMessage
msg = do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogMessage -> Bool
fltr LogMessage
msg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      Logger b
forall b. IsLogBackend b => Logger b
makeLogger b
backend LogMessage
msg

  initLogBackend :: LogBackendSettings (Filtering b) -> IO (Filtering b)
initLogBackend (Filtering fltr settings) = do
    b
backend <- LogBackendSettings b -> IO b
forall b. IsLogBackend b => LogBackendSettings b -> IO b
initLogBackend LogBackendSettings b
settings
    Filtering b -> IO (Filtering b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Filtering b -> IO (Filtering b))
-> Filtering b -> IO (Filtering b)
forall a b. (a -> b) -> a -> b
$ (LogMessage -> Bool) -> b -> Filtering b
forall b. (LogMessage -> Bool) -> b -> Filtering b
FilteringBackend LogMessage -> Bool
fltr b
backend

  cleanupLogBackend :: Filtering b -> IO ()
cleanupLogBackend (FilteringBackend LogMessage -> Bool
_ b
b) = b -> IO ()
forall b. IsLogBackend b => b -> IO ()
cleanupLogBackend b
b

-- | Null logging backend, which discards all messages
-- (passes them to @/dev/null@, if you wish).
-- This can be used to disable logging.
data NullBackend = NullBackend

instance IsLogBackend NullBackend where
  data LogBackendSettings NullBackend = NullLogSettings

  wouldWriteMessage :: NullBackend -> LogMessage -> IO Bool
wouldWriteMessage NullBackend
_ LogMessage
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  makeLogger :: Logger NullBackend
makeLogger NullBackend
_ LogMessage
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  initLogBackend :: LogBackendSettings NullBackend -> IO NullBackend
initLogBackend LogBackendSettings NullBackend
_ = NullBackend -> IO NullBackend
forall (m :: * -> *) a. Monad m => a -> m a
return NullBackend
NullBackend

  cleanupLogBackend :: NullBackend -> IO ()
cleanupLogBackend NullBackend
_ = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()