{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances #-}
-- | This module incldues logging backend combinators that allow to change
-- underlying backend or it's settings in runtime.
module System.Log.Heavy.Backends.Dynamic
  (
    -- * Dynamic backend
    DynamicBackend,
    DynamicBackendHandle,
    newDynamicBackendHandle,
    updateDynamicBackendSettings,
    LogBackendSettings (..),
    -- * Dynamic filtering
    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

-- | Abstract handle, that is used to control @DynamicBackend@.
data DynamicBackendHandle = DynamicBackendHandle {
    DynamicBackendHandle -> TChan LoggingSettings
dbhBroadcast :: TChan LoggingSettings -- ^ Broadcast TChan. It is write-only.
  , DynamicBackendHandle -> LoggingSettings
dbhDefault :: LoggingSettings         -- ^ Initial logging settings. Used only before first update in TChan.
                                          --   We cannot put this into TChan at beginning, because after dupTChan
                                          --   newly created TChan's will be empty anyway.
  }
-- I put these data into special Handle type, to hide the implementation detail
-- that it uses TChan inside. This detail can be changed in later versions.

-- | Create an instance of @DynamicBackendHandle@.
newDynamicBackendHandle :: LoggingSettings         -- ^ Initial logging settings. This can be changed later with @updateDynamicBackendSettings@.
                     -> 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

-- | Update settings of @DynamicBackend@, which was created by provided handle.
updateDynamicBackendSettings :: DynamicBackendHandle     -- ^ Handle of @DynamicBackend@.
                             -> LoggingSettings          -- ^ New logging settings.
                             -> 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

-- | Dynamic logging backend allows to change logging backend or it's settings
-- in runtime. When it sees new backend settings, it deinitializes old backend
-- and initializes new one.
--
-- How to use it:
--
-- * Before creating @DynamicSettings@, you have to select some initial
--   @LoggingSettings@ and create @DynamicBackendHandle@ with it.
-- * When you decide that you want to use new backend settings, call
--   @updateDynamicBackendSettings@ on existing @DynamicBackendHandle@.
--   @DynamicBackend@ will use new settings for the next logging function call.
-- * It is responsibility of caller code to do not change backends too frequently;
--   for example, if you are checking your config file for updates of logging
--   settings each 10s, you have to check that settings actually changed since
--   last time.
-- 
-- It is possible to create one instance of @DynamicBackendHandle@ and pass it
-- to multiple threads.
--
data DynamicBackend = DynamicBackend {
    DynamicBackend -> MVar AnyLogBackend
dbCurrentBackend :: MVar AnyLogBackend -- ^ Currently used logging backend
  , DynamicBackend -> TChan LoggingSettings
dbNewSettings :: TChan LoggingSettings -- ^ TChan with updates of settings. This is read only.
  }

-- Implementation is based on idea that Backend instances theirself are thread-safe;
-- i.e. it is safe to create several instances of any IsLogBackend data type in several threads
-- and they will coexist without problems (they do not use any shared state).
-- So, we can have one TChan, in which we can push updated settings when we want;
-- Each instance of DynamicBackend will have its own instance of underlying backend.
instance IsLogBackend DynamicBackend where
  data LogBackendSettings DynamicBackend = DynamicSettings DynamicBackendHandle

  initLogBackend :: LogBackendSettings DynamicBackend -> IO DynamicBackend
initLogBackend (DynamicSettings (DynamicBackendHandle broadcast (LoggingSettings dfltSettings))) = do
    -- Duplicate broadcast TChan - create "own copy".
    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
    -- Initialize default backend
    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
    -- Cleanup currently used backend
    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
    -- Delegate the call to currently used backend.
    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
    -- See if there is an update of settings queued.
    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
    -- Note: tryReadTChan will remove element from channel, if there is any.
    -- But, it will affect only "our own copy" of TChan. If there are other
    -- instances of DynamicBackend living in other threads with the same
    -- Handle, they will still see settings update in their own copies of
    -- TChan.
    case Maybe LoggingSettings
mbNewSettings of
      Maybe LoggingSettings
Nothing -> do
          -- No updates. Use current backend.
          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
          -- New settings came. We have to switch backends.
          AnyLogBackend
oldBackend <- MVar AnyLogBackend -> IO AnyLogBackend
forall a. MVar a -> IO a
takeMVar MVar AnyLogBackend
backendVar
          -- Cleanup old backend
          AnyLogBackend -> IO ()
forall b. IsLogBackend b => b -> IO ()
cleanupLogBackend AnyLogBackend
oldBackend
          -- Initialize new backend
          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)
          -- Delegate call to new backend
          Logger b
forall b. IsLogBackend b => Logger b
makeLogger b
newBackend LogMessage
msg

-- | Filtering backend with mutable filter.
data FilteringM b = FilteringBackendM (MVar (LogMessage -> Bool)) b

-- | Specify filter as @LogFilter@. This filter can be changed later.
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

-- | Exclude messages by filter. This filter can be changed later.
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