{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances, ExistentialQuantification, TypeFamilies, GeneralizedNewtypeDeriving, StandaloneDeriving, MultiParamTypeClasses, UndecidableInstances, AllowAmbiguousTypes, ScopedTypeVariables, FunctionalDependencies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE CPP #-}
module System.Log.Heavy.Types
(
LogSource, LogMessage (..), LogFilter, LogContextFrame (..), LogContext,
IsLogBackend (..), LogBackendSettings (..), LoggingSettings (..),
AnyLogBackend (..), LogContextFilter (..),
include, exclude, noChange,
Logger,SpecializedLogger,
HasLogBackend (..), HasLogContext (..), HasLogging,
HasLogger (..),
logMessage',
applyBackend,
defaultLogFilter,
withLogVariable,
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
type LogSource = [String]
data LogMessage = forall vars. F.ClosedVarContainer vars => LogMessage {
LogMessage -> Level
lmLevel :: Level
, LogMessage -> LogSource
lmSource :: LogSource
, LogMessage -> Loc
lmLocation :: Loc
, LogMessage -> Text
lmFormatString :: TL.Text
, ()
lmFormatVars :: vars
, LogMessage -> LogContext
lmContext :: LogContext
}
type LogFilter = [(LogSource, Level)]
defaultLogFilter :: LogFilter
defaultLogFilter :: LogFilter
defaultLogFilter = [([], Level
info_level)]
data LogContextFrame = LogContextFrame {
LogContextFrame -> [(Text, Variable)]
lcfVariables :: [(TL.Text, F.Variable)]
, LogContextFrame -> LogContextFilter
lcfFilter :: LogContextFilter
}
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)
data LogContextFilter =
LogContextFilter {
LogContextFilter -> Maybe LogFilter
setInclude :: Maybe LogFilter
, LogContextFilter -> Maybe LogFilter
setExclude :: Maybe LogFilter
}
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)
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
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
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)
type LogContext = [LogContextFrame]
class IsLogBackend b where
data LogBackendSettings b
makeLogger :: Logger b
initLogBackend :: LogBackendSettings b -> IO b
wouldWriteMessage :: b -> LogMessage -> IO Bool
wouldWriteMessage b
_ LogMessage
_ = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
cleanupLogBackend :: b -> IO ()
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)
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
class IsLogBackend b => HasLogBackend b m where
getLogBackend :: m b
data LoggingSettings = forall b. IsLogBackend b => LoggingSettings (LogBackendSettings b)
type Logger backend = backend -> LogMessage -> IO ()
type SpecializedLogger = LogMessage -> IO ()
class Monad m => HasLogger m where
getLogger :: m SpecializedLogger
localLogger :: SpecializedLogger -> m a -> m a
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
class Monad m => HasLogContext m where
withLogContext :: LogContextFrame -> m a -> m a
getLogContext :: m LogContext
type HasLogging m = (HasLogger m, HasLogContext m)
withLogVariable :: (HasLogContext m, F.Formatable v)
=> TL.Text
-> v
-> m a
-> 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)
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)
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
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''
splitDots :: String -> [String]
splitDots :: String -> LogSource
splitDots = Char -> String -> LogSource
splitString Char
'.'
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