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

-- | This module contains generic types definition, along with some utilities.
module System.Log.Heavy.Types
  (
    -- * Data types
    LogSource, LogMessage (..), LogFilter, LogContextFrame (..), LogContext,
    IsLogBackend (..), LogBackendSettings (..), LoggingSettings (..),
    AnyLogBackend (..), LogContextFilter (..),
    include, exclude, noChange,
    Logger,SpecializedLogger, 
    HasLogBackend (..), HasLogContext (..), HasLogging,
    HasLogger (..),
    -- * Main functions
    logMessage',
    applyBackend,
    defaultLogFilter,
    withLogVariable,
    -- * Utility functions
    splitString, splitDots,
  ) where

import Control.Monad.Reader
import Control.Monad.Logger (MonadLogger (..))
#if MIN_VERSION_monad_logger(0,3,10)
import Control.Monad.Logger (MonadLoggerIO (..))
#endif
import Control.Monad.Trans.Control
import Control.Exception.Lifted (bracket)
import Language.Haskell.TH
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Format.Heavy as F
import System.Log.FastLogger

import System.Log.Heavy.Level

-- | Log message source. This is usually a list of program module names,
-- for example @[\"System\", \"Log\", \"Heavy\", \"Types\"]@.
type LogSource = [String]

-- | Log message structure. You usually will want to use some sort
-- of shortcut function to create messages. There are some provided
-- by this package:
--
-- * @System.Log.Heavy.Shortcuts@ module exports simple functions, that can be used
--   in simple cases, when you do not want to write or check message source.
--
-- * @System.Log.Heavy.TH@ module exports TH macros, which correctly fill message
--   source and location.
--
data LogMessage = forall vars. F.ClosedVarContainer vars => LogMessage {
    LogMessage -> Level
lmLevel :: Level    -- ^ Log message level
  , LogMessage -> LogSource
lmSource :: LogSource  -- ^ Log message source (module)
  , LogMessage -> Loc
lmLocation :: Loc      -- ^ Log message source (exact location). You usually
                           --   will want to use TH quotes to fill this.
  , LogMessage -> Text
lmFormatString :: TL.Text -- ^ Log message string format (in @Data.Text.Format.Heavy@ syntax)
  , ()
lmFormatVars :: vars   -- ^ Log message substitution variables. Use @()@ if you do not have variables.
  , LogMessage -> LogContext
lmContext :: LogContext -- ^ Logging context. Authomatically filled by @logMessage@.
  }

-- | Log messages filter by source and level.
--
-- Semantics under this is that @(source, severity)@ pair allows to write
-- messages from @source@ of @severity@ (and all more important messages) to log.
type LogFilter = [(LogSource, Level)]

-- | Default log messages filter. This says pass all messages
-- of level Info or higher.
defaultLogFilter :: LogFilter
defaultLogFilter :: LogFilter
defaultLogFilter = [([], Level
info_level)]

-- | One frame in logging context stack.
data LogContextFrame = LogContextFrame {
      LogContextFrame -> [(Text, Variable)]
lcfVariables :: [(TL.Text, F.Variable)] -- ^ Context variables
    , LogContextFrame -> LogContextFilter
lcfFilter :: LogContextFilter           -- ^ Context events filter
  }
  deriving (Int -> LogContextFrame -> ShowS
LogContext -> ShowS
LogContextFrame -> String
(Int -> LogContextFrame -> ShowS)
-> (LogContextFrame -> String)
-> (LogContext -> ShowS)
-> Show LogContextFrame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: LogContext -> ShowS
$cshowList :: LogContext -> ShowS
show :: LogContextFrame -> String
$cshow :: LogContextFrame -> String
showsPrec :: Int -> LogContextFrame -> ShowS
$cshowsPrec :: Int -> LogContextFrame -> ShowS
Show)

-- | Events filter for specific logging context.
data LogContextFilter =
  LogContextFilter {
      LogContextFilter -> Maybe LogFilter
setInclude :: Maybe LogFilter  -- ^ Positive filter (include specified messages)
    , LogContextFilter -> Maybe LogFilter
setExclude :: Maybe LogFilter  -- ^ Negative filter (exclude specified messages)
  }
  deriving (LogContextFilter -> LogContextFilter -> Bool
(LogContextFilter -> LogContextFilter -> Bool)
-> (LogContextFilter -> LogContextFilter -> Bool)
-> Eq LogContextFilter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LogContextFilter -> LogContextFilter -> Bool
$c/= :: LogContextFilter -> LogContextFilter -> Bool
== :: LogContextFilter -> LogContextFilter -> Bool
$c== :: LogContextFilter -> LogContextFilter -> Bool
Eq, Int -> LogContextFilter -> ShowS
[LogContextFilter] -> ShowS
LogContextFilter -> String
(Int -> LogContextFilter -> ShowS)
-> (LogContextFilter -> String)
-> ([LogContextFilter] -> ShowS)
-> Show LogContextFilter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogContextFilter] -> ShowS
$cshowList :: [LogContextFilter] -> ShowS
show :: LogContextFilter -> String
$cshow :: LogContextFilter -> String
showsPrec :: Int -> LogContextFilter -> ShowS
$cshowsPrec :: Int -> LogContextFilter -> ShowS
Show)

-- | Do not affect context filter settings
noChange :: LogContextFilter
noChange :: LogContextFilter
noChange = Maybe LogFilter -> Maybe LogFilter -> LogContextFilter
LogContextFilter Maybe LogFilter
forall a. Maybe a
Nothing Maybe LogFilter
forall a. Maybe a
Nothing

-- | Create filter which includes only specified messages
include :: LogFilter -> LogContextFilter
include :: LogFilter -> LogContextFilter
include LogFilter
f = Maybe LogFilter -> Maybe LogFilter -> LogContextFilter
LogContextFilter (LogFilter -> Maybe LogFilter
forall a. a -> Maybe a
Just LogFilter
f) Maybe LogFilter
forall a. Maybe a
Nothing

-- | Create filter which just excludes specified messages
exclude :: LogFilter -> LogContextFilter
exclude :: LogFilter -> LogContextFilter
exclude LogFilter
f = Maybe LogFilter -> Maybe LogFilter -> LogContextFilter
LogContextFilter Maybe LogFilter
forall a. Maybe a
Nothing (LogFilter -> Maybe LogFilter
forall a. a -> Maybe a
Just LogFilter
f)

-- | Logging context stack
type LogContext = [LogContextFrame]

-- | Logging backend class.
class IsLogBackend b where
  -- | Logging backend settings data type
  data LogBackendSettings b

  -- | Create logger from backend
  makeLogger :: Logger b

  -- | Initialize logging backend from settings
  initLogBackend :: LogBackendSettings b -> IO b

  -- | Should return True if the specified message would be
  -- actually written to the log. Default implementation 
  -- always returns True.
  wouldWriteMessage :: b -> LogMessage -> IO Bool
  wouldWriteMessage b
_ LogMessage
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  -- | Cleanup logging backend (release resources and so on)
  cleanupLogBackend :: b -> IO ()

  -- | Bracket function. Concrete implementations usually
  -- do not have to override default implementation.
  withLoggingB :: (MonadBaseControl IO m, MonadIO m)
            => LogBackendSettings b
            -> (b -> m a)
            -> m a
  withLoggingB LogBackendSettings b
settings b -> m a
actions = do
    m b -> (b -> m ()) -> (b -> m a) -> m a
forall (m :: * -> *) a b c.
MonadBaseControl IO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket (IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b) -> IO b -> m b
forall a b. (a -> b) -> a -> b
$ LogBackendSettings b -> IO b
forall b. IsLogBackend b => LogBackendSettings b -> IO b
initLogBackend LogBackendSettings b
settings)
            (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (b -> IO ()) -> b -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> IO ()
forall b. IsLogBackend b => b -> IO ()
cleanupLogBackend)
            (b -> m a
actions)

-- | Container data type for representing arbitrary logging backend.
data AnyLogBackend = forall b. IsLogBackend b => AnyLogBackend b

instance IsLogBackend AnyLogBackend where
  data LogBackendSettings AnyLogBackend =
    AnyLogBackendSettings LoggingSettings

  makeLogger :: Logger AnyLogBackend
makeLogger (AnyLogBackend b
backend) = Logger b
forall b. IsLogBackend b => Logger b
makeLogger b
backend

  wouldWriteMessage :: AnyLogBackend -> LogMessage -> IO Bool
wouldWriteMessage (AnyLogBackend b
backend) LogMessage
msg =
    b -> LogMessage -> IO Bool
forall b. IsLogBackend b => b -> LogMessage -> IO Bool
wouldWriteMessage b
backend LogMessage
msg

  initLogBackend :: LogBackendSettings AnyLogBackend -> IO AnyLogBackend
initLogBackend (AnyLogBackendSettings (LoggingSettings settings)) =
    b -> AnyLogBackend
forall b. IsLogBackend b => b -> AnyLogBackend
AnyLogBackend (b -> AnyLogBackend) -> IO b -> IO AnyLogBackend
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` LogBackendSettings b -> IO b
forall b. IsLogBackend b => LogBackendSettings b -> IO b
initLogBackend LogBackendSettings b
settings

  cleanupLogBackend :: AnyLogBackend -> IO ()
cleanupLogBackend (AnyLogBackend b
backend) = b -> IO ()
forall b. IsLogBackend b => b -> IO ()
cleanupLogBackend b
backend

-- | Constraint for monads in which it is possible to obtain logging backend.
class IsLogBackend b => HasLogBackend b m where
  getLogBackend :: m b

-- | A container for arbitrary logging backend.
-- You usually will use this similar to:
--
-- @
--  getLoggingSettings :: String -> LoggingSettings
--  getLoggingSettings "syslog" = LoggingSettings defaultsyslogsettings
-- @
data LoggingSettings = forall b. IsLogBackend b => LoggingSettings (LogBackendSettings b)

-- | Logging function
type Logger backend = backend -> LogMessage -> IO ()

-- | Logging function applied to concrete backend
type SpecializedLogger = LogMessage -> IO ()

-- | Type class for monads that can write logs
class Monad m => HasLogger m where
  getLogger :: m SpecializedLogger
  
  -- | Change logger to specified one locally
  localLogger :: SpecializedLogger -> m a -> m a

-- instance (Monad m, MonadReader SpecializedLogger m) => HasLogger m where
--   getLogger = ask
--   localLogger l = local (const l)

-- | Apply logging backend locally.
applyBackend :: (IsLogBackend b, HasLogger m) => b -> m a -> m a
applyBackend :: b -> m a -> m a
applyBackend b
b m a
actions = do
  let logger :: LogMessage -> IO ()
logger = Logger b
forall b. IsLogBackend b => Logger b
makeLogger b
b
  (LogMessage -> IO ()) -> m a -> m a
forall (m :: * -> *) a.
HasLogger m =>
(LogMessage -> IO ()) -> m a -> m a
localLogger LogMessage -> IO ()
logger m a
actions

-- | Type class for monads that store logging context
class Monad m => HasLogContext m where
  -- | Execute actions within logging context frame
  withLogContext :: LogContextFrame -> m a -> m a

  -- | Obtain currently active logging context stack
  getLogContext :: m LogContext

-- GHC will not be able to select instance for LoggingT.
-- instance (Monad m, HasLogBackend b m) => HasLogBackend AnyLogBackend m where
--   getLogBackend = do
--     backend <- getLogBackend :: m b
--     return $ AnyLogBackend backend

-- | Convinience constraint synonym.
type HasLogging m = (HasLogger m, HasLogContext m)

-- | Shortcut function to execute actions within logging context frame,
-- which contains only one variable
withLogVariable :: (HasLogContext m, F.Formatable v)
                => TL.Text -- ^ Variable name
                -> v       -- ^ Variable value
                -> m a     -- ^ Actions to execute within context frame
                -> m a
withLogVariable :: Text -> v -> m a -> m a
withLogVariable Text
name v
value =
  LogContextFrame -> m a -> m a
forall (m :: * -> *) a.
HasLogContext m =>
LogContextFrame -> m a -> m a
withLogContext ([(Text, Variable)] -> LogContextFilter -> LogContextFrame
LogContextFrame [(Text
name, v -> Variable
forall a. Formatable a => a -> Variable
F.Variable v
value)] LogContextFilter
noChange)

-- | Compatibility instance.
instance (Monad m, MonadIO m, HasLogging m) => MonadLogger m where
  monadLoggerLog :: Loc -> LogSource -> LogLevel -> msg -> m ()
monadLoggerLog Loc
loc LogSource
src LogLevel
level msg
msg = do
      LogMessage -> IO ()
logger <- m (LogMessage -> IO ())
forall (m :: * -> *). HasLogger m => m (LogMessage -> IO ())
getLogger
      LogContext
context <- m LogContext
forall (m :: * -> *). HasLogContext m => m LogContext
getLogContext
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LogMessage -> IO ()
logger (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ LogMessage :: forall vars.
ClosedVarContainer vars =>
Level
-> LogSource -> Loc -> Text -> vars -> LogContext -> LogMessage
LogMessage {
                          lmLevel :: Level
lmLevel = LogLevel -> Level
logLevelToLevel LogLevel
level,
                          lmSource :: LogSource
lmSource = LogSource
src',
                          lmLocation :: Loc
lmLocation = Loc
loc,
                          lmFormatString :: Text
lmFormatString = msg -> Text
forall str. ToLogStr str => str -> Text
textFromLogStr msg
msg,
                          lmFormatVars :: ()
lmFormatVars = (),
                          lmContext :: LogContext
lmContext = LogContext
context
                        }
    where
      src' :: LogSource
src' = String -> LogSource
splitDots (String -> LogSource) -> String -> LogSource
forall a b. (a -> b) -> a -> b
$ LogSource -> String
T.unpack LogSource
src

      textFromLogStr :: ToLogStr str => str -> TL.Text
      textFromLogStr :: str -> Text
textFromLogStr str
str = LogSource -> Text
TL.fromStrict (LogSource -> Text) -> LogSource -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> LogSource
TE.decodeUtf8 (ByteString -> LogSource) -> ByteString -> LogSource
forall a b. (a -> b) -> a -> b
$ LogStr -> ByteString
fromLogStr (LogStr -> ByteString) -> LogStr -> ByteString
forall a b. (a -> b) -> a -> b
$ str -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr str
str

#if MIN_VERSION_monad_logger(0,3,10)
-- | Another compatibility instance.
instance (Monad m, MonadIO m, HasLogging m) => MonadLoggerIO m where
  askLoggerIO :: m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
askLoggerIO = do
      LogMessage -> IO ()
logger <- m (LogMessage -> IO ())
forall (m :: * -> *). HasLogger m => m (LogMessage -> IO ())
getLogger
      LogContext
context <- m LogContext
forall (m :: * -> *). HasLogContext m => m LogContext
getLogContext
      (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((Loc -> LogSource -> LogLevel -> LogStr -> IO ())
 -> m (Loc -> LogSource -> LogLevel -> LogStr -> IO ()))
-> (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall a b. (a -> b) -> a -> b
$ \Loc
loc LogSource
src LogLevel
level LogStr
msg ->
                  LogMessage -> IO ()
logger (LogMessage -> IO ()) -> LogMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ LogMessage :: forall vars.
ClosedVarContainer vars =>
Level
-> LogSource -> Loc -> Text -> vars -> LogContext -> LogMessage
LogMessage {
                          lmLevel :: Level
lmLevel = LogLevel -> Level
logLevelToLevel LogLevel
level,
                          lmSource :: LogSource
lmSource = (String -> LogSource
splitDots (String -> LogSource) -> String -> LogSource
forall a b. (a -> b) -> a -> b
$ LogSource -> String
T.unpack LogSource
src),
                          lmLocation :: Loc
lmLocation = Loc
loc,
                          lmFormatString :: Text
lmFormatString = LogStr -> Text
forall str. ToLogStr str => str -> Text
textFromLogStr LogStr
msg,
                          lmFormatVars :: ()
lmFormatVars = (),
                          lmContext :: LogContext
lmContext = LogContext
context
                        }
    where
      textFromLogStr :: ToLogStr str => str -> TL.Text
      textFromLogStr :: str -> Text
textFromLogStr str
str = LogSource -> Text
TL.fromStrict (LogSource -> Text) -> LogSource -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> LogSource
TE.decodeUtf8 (ByteString -> LogSource) -> ByteString -> LogSource
forall a b. (a -> b) -> a -> b
$ LogStr -> ByteString
fromLogStr (LogStr -> ByteString) -> LogStr -> ByteString
forall a b. (a -> b) -> a -> b
$ str -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr str
str
#endif

instance F.Formatable LogStr where
  formatVar :: VarFormat -> LogStr -> Either String Builder
formatVar VarFormat
fmt LogStr
str = VarFormat -> ByteString -> Either String Builder
forall a. Formatable a => VarFormat -> a -> Either String Builder
F.formatVar VarFormat
fmt (ByteString -> Either String Builder)
-> ByteString -> Either String Builder
forall a b. (a -> b) -> a -> b
$ LogStr -> ByteString
fromLogStr LogStr
str

-- | Simple implementation of splitting string by character.
splitString       :: Char -> String -> [String]
splitString :: Char -> String -> LogSource
splitString Char
_ String
""  =  []
splitString Char
c String
s   =  let (String
l, String
s') = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c) String
s
                 in  String
l String -> LogSource -> LogSource
forall a. a -> [a] -> [a]
: case String
s' of
                           []      -> []
                           (Char
_:String
s'') -> Char -> String -> LogSource
splitString Char
c String
s''

-- | Split string by dots
splitDots :: String -> [String]
splitDots :: String -> LogSource
splitDots = Char -> String -> LogSource
splitString Char
'.'

-- | Log a message. This version is for monads that do not know about logging contexts.
logMessage' :: forall m. (HasLogger m, MonadIO m) => LogMessage -> m ()
logMessage' :: LogMessage -> m ()
logMessage' LogMessage
msg = do
  LogMessage -> IO ()
logger <- m (LogMessage -> IO ())
forall (m :: * -> *). HasLogger m => m (LogMessage -> IO ())
getLogger
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ LogMessage -> IO ()
logger LogMessage
msg