{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-}
module System.Log.Heavy.Backends
(
FastLoggerBackend,
SyslogBackend,
ChanLoggerBackend,
ParallelBackend,
NullBackend,
Filtering, filtering, excluding,
LogBackendSettings (..),
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
defStdoutSettings :: LogBackendSettings FastLoggerBackend
defStdoutSettings :: LogBackendSettings FastLoggerBackend
defStdoutSettings = Format -> LogType -> LogBackendSettings FastLoggerBackend
FastLoggerSettings Format
defaultLogFormat (BufSize -> LogType
FL.LogStdout BufSize
FL.defaultBufSize)
defStderrSettings :: LogBackendSettings FastLoggerBackend
defStderrSettings :: LogBackendSettings FastLoggerBackend
defStderrSettings = Format -> LogType -> LogBackendSettings FastLoggerBackend
FastLoggerSettings Format
defaultLogFormat (BufSize -> LogType
FL.LogStderr BufSize
FL.defaultBufSize)
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
data FastLoggerBackend = FastLoggerBackend {
FastLoggerBackend -> LogBackendSettings FastLoggerBackend
flbSettings :: LogBackendSettings FastLoggerBackend,
FastLoggerBackend -> TimedFastLogger
flbTimedLogger :: TimedFastLogger,
FastLoggerBackend -> IO ()
flbCleanup :: IO ()
}
instance IsLogBackend FastLoggerBackend where
data LogBackendSettings FastLoggerBackend = FastLoggerSettings {
LogBackendSettings FastLoggerBackend -> Format
lsFormat :: F.Format
, LogBackendSettings FastLoggerBackend -> LogType
lsType :: FL.LogType
}
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
defaultSyslogSettings :: LogBackendSettings SyslogBackend
defaultSyslogSettings :: LogBackendSettings SyslogBackend
defaultSyslogSettings = Format
-> FilePath
-> [Option]
-> Facility
-> LogBackendSettings SyslogBackend
SyslogSettings Format
defaultSyslogFormat FilePath
"application" [] Facility
Syslog.User
defaultSyslogFormat :: F.Format
defaultSyslogFormat :: Format
defaultSyslogFormat = Format
"[{level}] {source}: {message}"
data SyslogBackend = SyslogBackend {
SyslogBackend -> LogBackendSettings SyslogBackend
sbSettings :: LogBackendSettings SyslogBackend,
SyslogBackend -> CString
sbIdent :: CString,
SyslogBackend -> IO FormattedTime
sbTimeCache :: IO FormattedTime
}
instance IsLogBackend SyslogBackend where
data LogBackendSettings SyslogBackend = SyslogSettings {
LogBackendSettings SyslogBackend -> Format
ssFormat :: F.Format
, LogBackendSettings SyslogBackend -> FilePath
ssIdent :: String
, LogBackendSettings SyslogBackend -> [Option]
ssOptions :: [Syslog.Option]
, LogBackendSettings SyslogBackend -> Facility
ssFacility :: Syslog.Facility
}
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)
data ChanLoggerBackend = ChanLoggerBackend {
ChanLoggerBackend -> Chan LogMessage
clChan :: Chan LogMessage
}
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
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
data Filtering b = FilteringBackend (LogMessage -> Bool) b
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
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
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 ()