{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, FlexibleContexts #-}

module System.Log.Heavy.Util
  (
    -- * Functions of common use
    logMessage,
    -- * Utilities for backends implementation
    checkLogLevel, checkLogLevel',
    checkContextFilter, checkContextFilter', checkContextFilterM
  ) where

import Control.Monad (when)
import Control.Monad.Trans
import Data.List (isPrefixOf)

import System.Log.Heavy.Types
import System.Log.Heavy.Level

-- | Check if message source and level passes specified filters.
--
-- The message is passed if:
--
-- * No @include@ filters are defined in context stack, OR the message conforms to ANY of @include@ filters;
--
-- * AND the message does not conform to any of @exclude@ filters in the stack.
--
checkContextFilter' :: [LogContextFilter] -> LogSource -> Level -> Bool
checkContextFilter' :: [LogContextFilter] -> LogSource -> Level -> Bool
checkContextFilter' [LogContextFilter]
filters LogSource
source Level
level =
  let includeFilters :: [LogFilter]
includeFilters = [LogFilter
fltr | LogContextFilter (Just LogFilter
fltr) Maybe LogFilter
_ <- [LogContextFilter]
filters]
      excludeFilters :: [LogFilter]
excludeFilters = [LogFilter
fltr | LogContextFilter Maybe LogFilter
_ (Just LogFilter
fltr) <- [LogContextFilter]
filters]
      includeOk :: Bool
includeOk = [LogFilter] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LogFilter]
includeFilters Bool -> Bool -> Bool
|| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [LogFilter -> LogSource -> Level -> Bool
checkLogLevel' LogFilter
fltr LogSource
source Level
level | LogFilter
fltr <- [LogFilter]
includeFilters]
      excludeOk :: Bool
excludeOk = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [LogFilter -> LogSource -> Level -> Bool
checkLogLevel' LogFilter
fltr LogSource
source Level
level | LogFilter
fltr <- [LogFilter]
excludeFilters]
  in  Bool
includeOk Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
excludeOk

-- | Check if message matches filters from logging context.
--
-- The message is passed if:
--
-- * No @include@ filters are defined in context stack, OR the message conforms to ANY of @include@ filters;
--
-- * AND the message does not conform to any of @exclude@ filters in the stack.
--
checkContextFilter :: LogContext -> LogMessage -> Bool
checkContextFilter :: LogContext -> LogMessage -> Bool
checkContextFilter LogContext
context LogMessage
msg =
  [LogContextFilter] -> LogSource -> Level -> Bool
checkContextFilter' ((LogContextFrame -> LogContextFilter)
-> LogContext -> [LogContextFilter]
forall a b. (a -> b) -> [a] -> [b]
map LogContextFrame -> LogContextFilter
lcfFilter LogContext
context) (LogMessage -> LogSource
lmSource LogMessage
msg) (LogMessage -> Level
lmLevel LogMessage
msg)

-- | Check if message matches filters from logging context.
-- This function is similar to @checkContextFilter@, but uses current context
-- from monadic state.
checkContextFilterM :: HasLogContext m => LogMessage -> m Bool
checkContextFilterM :: LogMessage -> m Bool
checkContextFilterM LogMessage
msg = do
  LogContext
context <- m LogContext
forall (m :: * -> *). HasLogContext m => m LogContext
getLogContext
  Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ LogContext -> LogMessage -> Bool
checkContextFilter LogContext
context LogMessage
msg

-- | Check if message level matches given filter.
checkLogLevel :: LogFilter -> LogMessage -> Bool
checkLogLevel :: LogFilter -> LogMessage -> Bool
checkLogLevel LogFilter
fltr LogMessage
m =
    LogFilter -> LogSource -> Level -> Bool
checkLogLevel' LogFilter
fltr (LogMessage -> LogSource
lmSource LogMessage
m) (LogMessage -> Level
lmLevel LogMessage
m)

-- | Check if message level matches given filter.
checkLogLevel' :: LogFilter -> LogSource -> Level -> Bool
checkLogLevel' :: LogFilter -> LogSource -> Level -> Bool
checkLogLevel' LogFilter
fltr LogSource
source Level
level =
    case LogSource -> LogFilter -> Maybe Level
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (LogSource -> [LogSource] -> LogSource
bestMatch LogSource
source (((LogSource, Level) -> LogSource) -> LogFilter -> [LogSource]
forall a b. (a -> b) -> [a] -> [b]
map (LogSource, Level) -> LogSource
forall a b. (a, b) -> a
fst LogFilter
fltr)) LogFilter
fltr of
      Maybe Level
Nothing -> Bool
False
      Just Level
min -> Level
level Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
<= Level
min
  where
    bestMatch :: LogSource -> [LogSource] -> LogSource
    bestMatch :: LogSource -> [LogSource] -> LogSource
bestMatch LogSource
src [LogSource]
list = LogSource -> LogSource -> [LogSource] -> LogSource
go [] LogSource
src [LogSource]
list

    go :: LogSource -> LogSource -> [LogSource] -> LogSource
    go :: LogSource -> LogSource -> [LogSource] -> LogSource
go LogSource
best LogSource
src [] = LogSource
best
    go LogSource
best LogSource
src (LogSource
x:[LogSource]
xs)
      | LogSource
src LogSource -> LogSource -> Bool
forall a. Eq a => a -> a -> Bool
== LogSource
x = LogSource
x
      | (LogSource
x LogSource -> LogSource -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` LogSource
src) Bool -> Bool -> Bool
&& (LogSource -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length LogSource
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> LogSource -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length LogSource
best) = LogSource -> LogSource -> [LogSource] -> LogSource
go LogSource
x LogSource
src [LogSource]
xs
      | Bool
otherwise = LogSource -> LogSource -> [LogSource] -> LogSource
go LogSource
best LogSource
src [LogSource]
xs

-- | Log a message. This will add current context to context specified
-- in the message.
-- This function checks current context filter.
logMessage :: forall m. (HasLogging m, MonadIO m) => LogMessage -> m ()
logMessage :: LogMessage -> m ()
logMessage LogMessage
msg = do
  Bool
ok <- LogMessage -> m Bool
forall (m :: * -> *). HasLogContext m => LogMessage -> m Bool
checkContextFilterM LogMessage
msg
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ok (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    LogContext
context <- m LogContext
forall (m :: * -> *). HasLogContext m => m LogContext
getLogContext
    SpecializedLogger
logger <- m SpecializedLogger
forall (m :: * -> *). HasLogger m => m SpecializedLogger
getLogger
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SpecializedLogger
logger SpecializedLogger -> SpecializedLogger
forall a b. (a -> b) -> a -> b
$ LogMessage
msg {lmContext :: LogContext
lmContext = LogContext
context LogContext -> LogContext -> LogContext
forall a. [a] -> [a] -> [a]
++ LogMessage -> LogContext
lmContext LogMessage
msg}