{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-}
module System.Log.Heavy.Backends.Dynamic
(
DynamicBackend,
DynamicBackendHandle,
newDynamicBackendHandle,
updateDynamicBackendSettings,
LogBackendSettings (..),
FilteringM, filteringM, excludingM
) where
import Control.Monad (when)
import Control.Concurrent
import Control.Concurrent.STM
import System.Log.Heavy.Types
import System.Log.Heavy.Util
data DynamicBackendHandle = DynamicBackendHandle {
DynamicBackendHandle -> TChan LoggingSettings
dbhBroadcast :: TChan LoggingSettings
, DynamicBackendHandle -> LoggingSettings
dbhDefault :: LoggingSettings
}
newDynamicBackendHandle :: LoggingSettings
-> IO DynamicBackendHandle
newDynamicBackendHandle :: LoggingSettings -> IO DynamicBackendHandle
newDynamicBackendHandle LoggingSettings
settings = do
TChan LoggingSettings
broadcast <- IO (TChan LoggingSettings)
forall a. IO (TChan a)
newBroadcastTChanIO
DynamicBackendHandle -> IO DynamicBackendHandle
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicBackendHandle -> IO DynamicBackendHandle)
-> DynamicBackendHandle -> IO DynamicBackendHandle
forall a b. (a -> b) -> a -> b
$ TChan LoggingSettings -> LoggingSettings -> DynamicBackendHandle
DynamicBackendHandle TChan LoggingSettings
broadcast LoggingSettings
settings
updateDynamicBackendSettings :: DynamicBackendHandle
-> LoggingSettings
-> IO ()
updateDynamicBackendSettings :: DynamicBackendHandle -> LoggingSettings -> IO ()
updateDynamicBackendSettings DynamicBackendHandle
handle LoggingSettings
settings = do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan LoggingSettings -> LoggingSettings -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (DynamicBackendHandle -> TChan LoggingSettings
dbhBroadcast DynamicBackendHandle
handle) LoggingSettings
settings
data DynamicBackend = DynamicBackend {
DynamicBackend -> MVar AnyLogBackend
dbCurrentBackend :: MVar AnyLogBackend
, DynamicBackend -> TChan LoggingSettings
dbNewSettings :: TChan LoggingSettings
}
instance IsLogBackend DynamicBackend where
data LogBackendSettings DynamicBackend = DynamicSettings DynamicBackendHandle
initLogBackend :: LogBackendSettings DynamicBackend -> IO DynamicBackend
initLogBackend (DynamicSettings (DynamicBackendHandle broadcast (LoggingSettings dfltSettings))) = do
TChan LoggingSettings
mySettingsChan <- STM (TChan LoggingSettings) -> IO (TChan LoggingSettings)
forall a. STM a -> IO a
atomically (STM (TChan LoggingSettings) -> IO (TChan LoggingSettings))
-> STM (TChan LoggingSettings) -> IO (TChan LoggingSettings)
forall a b. (a -> b) -> a -> b
$ TChan LoggingSettings -> STM (TChan LoggingSettings)
forall a. TChan a -> STM (TChan a)
dupTChan TChan LoggingSettings
broadcast
b
backend <- LogBackendSettings b -> IO b
forall b. IsLogBackend b => LogBackendSettings b -> IO b
initLogBackend LogBackendSettings b
dfltSettings
MVar AnyLogBackend
backendVar <- AnyLogBackend -> IO (MVar AnyLogBackend)
forall a. a -> IO (MVar a)
newMVar (b -> AnyLogBackend
forall b. IsLogBackend b => b -> AnyLogBackend
AnyLogBackend b
backend)
DynamicBackend -> IO DynamicBackend
forall (m :: * -> *) a. Monad m => a -> m a
return (DynamicBackend -> IO DynamicBackend)
-> DynamicBackend -> IO DynamicBackend
forall a b. (a -> b) -> a -> b
$ MVar AnyLogBackend -> TChan LoggingSettings -> DynamicBackend
DynamicBackend MVar AnyLogBackend
backendVar TChan LoggingSettings
mySettingsChan
cleanupLogBackend :: DynamicBackend -> IO ()
cleanupLogBackend (DynamicBackend MVar AnyLogBackend
backendVar TChan LoggingSettings
_) = do
AnyLogBackend
backend <- MVar AnyLogBackend -> IO AnyLogBackend
forall a. MVar a -> IO a
takeMVar MVar AnyLogBackend
backendVar
AnyLogBackend -> IO ()
forall b. IsLogBackend b => b -> IO ()
cleanupLogBackend AnyLogBackend
backend
wouldWriteMessage :: DynamicBackend -> LogMessage -> IO Bool
wouldWriteMessage (DynamicBackend MVar AnyLogBackend
backendVar TChan LoggingSettings
_) LogMessage
msg = do
AnyLogBackend
backend <- MVar AnyLogBackend -> IO AnyLogBackend
forall a. MVar a -> IO a
readMVar MVar AnyLogBackend
backendVar
AnyLogBackend -> LogMessage -> IO Bool
forall b. IsLogBackend b => b -> LogMessage -> IO Bool
wouldWriteMessage AnyLogBackend
backend LogMessage
msg
makeLogger :: Logger DynamicBackend
makeLogger (DynamicBackend MVar AnyLogBackend
backendVar TChan LoggingSettings
settingsChan) LogMessage
msg = do
Maybe LoggingSettings
mbNewSettings <- STM (Maybe LoggingSettings) -> IO (Maybe LoggingSettings)
forall a. STM a -> IO a
atomically (STM (Maybe LoggingSettings) -> IO (Maybe LoggingSettings))
-> STM (Maybe LoggingSettings) -> IO (Maybe LoggingSettings)
forall a b. (a -> b) -> a -> b
$ TChan LoggingSettings -> STM (Maybe LoggingSettings)
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan LoggingSettings
settingsChan
case Maybe LoggingSettings
mbNewSettings of
Maybe LoggingSettings
Nothing -> do
AnyLogBackend
backend <- MVar AnyLogBackend -> IO AnyLogBackend
forall a. MVar a -> IO a
readMVar MVar AnyLogBackend
backendVar
Logger AnyLogBackend
forall b. IsLogBackend b => Logger b
makeLogger AnyLogBackend
backend LogMessage
msg
Just (LoggingSettings LogBackendSettings b
newSettings) -> do
AnyLogBackend
oldBackend <- MVar AnyLogBackend -> IO AnyLogBackend
forall a. MVar a -> IO a
takeMVar MVar AnyLogBackend
backendVar
AnyLogBackend -> IO ()
forall b. IsLogBackend b => b -> IO ()
cleanupLogBackend AnyLogBackend
oldBackend
b
newBackend <- LogBackendSettings b -> IO b
forall b. IsLogBackend b => LogBackendSettings b -> IO b
initLogBackend LogBackendSettings b
newSettings
MVar AnyLogBackend -> AnyLogBackend -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar AnyLogBackend
backendVar (b -> AnyLogBackend
forall b. IsLogBackend b => b -> AnyLogBackend
AnyLogBackend b
newBackend)
Logger b
forall b. IsLogBackend b => Logger b
makeLogger b
newBackend LogMessage
msg
data FilteringM b = FilteringBackendM (MVar (LogMessage -> Bool)) b
filteringM :: IsLogBackend b => LogFilter -> LogBackendSettings b -> IO (LogBackendSettings (FilteringM b))
filteringM :: LogFilter
-> LogBackendSettings b -> IO (LogBackendSettings (FilteringM b))
filteringM LogFilter
fltr LogBackendSettings b
b = do
MVar (LogMessage -> Bool)
fltrVar <- (LogMessage -> Bool) -> IO (MVar (LogMessage -> Bool))
forall a. a -> IO (MVar a)
newMVar (LogFilter -> LogMessage -> Bool
checkLogLevel LogFilter
fltr)
LogBackendSettings (FilteringM b)
-> IO (LogBackendSettings (FilteringM b))
forall (m :: * -> *) a. Monad m => a -> m a
return (LogBackendSettings (FilteringM b)
-> IO (LogBackendSettings (FilteringM b)))
-> LogBackendSettings (FilteringM b)
-> IO (LogBackendSettings (FilteringM b))
forall a b. (a -> b) -> a -> b
$ MVar (LogMessage -> Bool)
-> LogBackendSettings b -> LogBackendSettings (FilteringM b)
forall b.
MVar (LogMessage -> Bool)
-> LogBackendSettings b -> LogBackendSettings (FilteringM b)
FilteringM MVar (LogMessage -> Bool)
fltrVar LogBackendSettings b
b
excludingM :: IsLogBackend b => LogFilter -> LogBackendSettings b -> IO (LogBackendSettings (FilteringM b))
excludingM :: LogFilter
-> LogBackendSettings b -> IO (LogBackendSettings (FilteringM b))
excludingM LogFilter
fltr LogBackendSettings b
b = do
MVar (LogMessage -> Bool)
fltrVar <- (LogMessage -> Bool) -> IO (MVar (LogMessage -> Bool))
forall a. a -> IO (MVar a)
newMVar LogMessage -> Bool
ex
LogBackendSettings (FilteringM b)
-> IO (LogBackendSettings (FilteringM b))
forall (m :: * -> *) a. Monad m => a -> m a
return (LogBackendSettings (FilteringM b)
-> IO (LogBackendSettings (FilteringM b)))
-> LogBackendSettings (FilteringM b)
-> IO (LogBackendSettings (FilteringM b))
forall a b. (a -> b) -> a -> b
$ MVar (LogMessage -> Bool)
-> LogBackendSettings b -> LogBackendSettings (FilteringM b)
forall b.
MVar (LogMessage -> Bool)
-> LogBackendSettings b -> LogBackendSettings (FilteringM b)
FilteringM MVar (LogMessage -> Bool)
fltrVar 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 (FilteringM b) where
data LogBackendSettings (FilteringM b) =
FilteringM (MVar (LogMessage -> Bool)) (LogBackendSettings b)
wouldWriteMessage :: FilteringM b -> LogMessage -> IO Bool
wouldWriteMessage (FilteringBackendM MVar (LogMessage -> Bool)
fltrVar b
_) LogMessage
msg = do
LogMessage -> Bool
fltr <- MVar (LogMessage -> Bool) -> IO (LogMessage -> Bool)
forall a. MVar a -> IO a
readMVar MVar (LogMessage -> Bool)
fltrVar
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 (FilteringM b)
makeLogger (FilteringBackendM MVar (LogMessage -> Bool)
fltrVar b
backend) LogMessage
msg = do
LogMessage -> Bool
fltr <- MVar (LogMessage -> Bool) -> IO (LogMessage -> Bool)
forall a. MVar a -> IO a
readMVar MVar (LogMessage -> Bool)
fltrVar
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 (FilteringM b) -> IO (FilteringM b)
initLogBackend (FilteringM fltrVar settings) = do
b
backend <- LogBackendSettings b -> IO b
forall b. IsLogBackend b => LogBackendSettings b -> IO b
initLogBackend LogBackendSettings b
settings
FilteringM b -> IO (FilteringM b)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilteringM b -> IO (FilteringM b))
-> FilteringM b -> IO (FilteringM b)
forall a b. (a -> b) -> a -> b
$ MVar (LogMessage -> Bool) -> b -> FilteringM b
forall b. MVar (LogMessage -> Bool) -> b -> FilteringM b
FilteringBackendM MVar (LogMessage -> Bool)
fltrVar b
backend
cleanupLogBackend :: FilteringM b -> IO ()
cleanupLogBackend (FilteringBackendM MVar (LogMessage -> Bool)
_ b
backend) = b -> IO ()
forall b. IsLogBackend b => b -> IO ()
cleanupLogBackend b
backend