-- | The 'LogT' monad transformer for adding logging capabilities to any monad.
{-# LANGUAGE CPP #-}
module Log.Monad (
    Logger
  , LoggerEnv(..)
  , InnerLogT
  , LogT(..)
  , runLogT
  , logExceptions
  , mapLogT
  , logMessageIO
  , getLoggerIO
  ) where

import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Error.Class
import Control.Monad.IO.Unlift
import Control.Monad.Morph (MFunctor (..))
import Control.Monad.Reader
import Control.Monad.State.Class
import Control.Monad.Trans.Control
import Control.Monad.Writer.Class
import Data.Aeson
import Data.Text (Text)
import Data.Time
import qualified Control.Monad.Fail as MF
import qualified Control.Exception as E

import Log.Class
import Log.Data
import Log.Logger
import qualified Log.Internal.Aeson.Compat as AC

type InnerLogT = ReaderT LoggerEnv

-- | Monad transformer that adds logging capabilities to the underlying monad.
newtype LogT m a = LogT { forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT :: InnerLogT m a }
  deriving (Applicative (LogT m)
Applicative (LogT m) =>
(forall a. LogT m a)
-> (forall a. LogT m a -> LogT m a -> LogT m a)
-> (forall a. LogT m a -> LogT m [a])
-> (forall a. LogT m a -> LogT m [a])
-> Alternative (LogT m)
forall a. LogT m a
forall a. LogT m a -> LogT m [a]
forall a. LogT m a -> LogT m a -> LogT m a
forall (f :: * -> *).
Applicative f =>
(forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
forall (m :: * -> *). Alternative m => Applicative (LogT m)
forall (m :: * -> *) a. Alternative m => LogT m a
forall (m :: * -> *) a. Alternative m => LogT m a -> LogT m [a]
forall (m :: * -> *) a.
Alternative m =>
LogT m a -> LogT m a -> LogT m a
$cempty :: forall (m :: * -> *) a. Alternative m => LogT m a
empty :: forall a. LogT m a
$c<|> :: forall (m :: * -> *) a.
Alternative m =>
LogT m a -> LogT m a -> LogT m a
<|> :: forall a. LogT m a -> LogT m a -> LogT m a
$csome :: forall (m :: * -> *) a. Alternative m => LogT m a -> LogT m [a]
some :: forall a. LogT m a -> LogT m [a]
$cmany :: forall (m :: * -> *) a. Alternative m => LogT m a -> LogT m [a]
many :: forall a. LogT m a -> LogT m [a]
Alternative, Functor (LogT m)
Functor (LogT m) =>
(forall a. a -> LogT m a)
-> (forall a b. LogT m (a -> b) -> LogT m a -> LogT m b)
-> (forall a b c.
    (a -> b -> c) -> LogT m a -> LogT m b -> LogT m c)
-> (forall a b. LogT m a -> LogT m b -> LogT m b)
-> (forall a b. LogT m a -> LogT m b -> LogT m a)
-> Applicative (LogT m)
forall a. a -> LogT m a
forall a b. LogT m a -> LogT m b -> LogT m a
forall a b. LogT m a -> LogT m b -> LogT m b
forall a b. LogT m (a -> b) -> LogT m a -> LogT m b
forall a b c. (a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (LogT m)
forall (m :: * -> *) a. Applicative m => a -> LogT m a
forall (m :: * -> *) a b.
Applicative m =>
LogT m a -> LogT m b -> LogT m a
forall (m :: * -> *) a b.
Applicative m =>
LogT m a -> LogT m b -> LogT m b
forall (m :: * -> *) a b.
Applicative m =>
LogT m (a -> b) -> LogT m a -> LogT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> LogT m a
pure :: forall a. a -> LogT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
LogT m (a -> b) -> LogT m a -> LogT m b
<*> :: forall a b. LogT m (a -> b) -> LogT m a -> LogT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
liftA2 :: forall a b c. (a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
LogT m a -> LogT m b -> LogT m b
*> :: forall a b. LogT m a -> LogT m b -> LogT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
LogT m a -> LogT m b -> LogT m a
<* :: forall a b. LogT m a -> LogT m b -> LogT m a
Applicative, (forall a b. (a -> b) -> LogT m a -> LogT m b)
-> (forall a b. a -> LogT m b -> LogT m a) -> Functor (LogT m)
forall a b. a -> LogT m b -> LogT m a
forall a b. (a -> b) -> LogT m a -> LogT m b
forall (m :: * -> *) a b. Functor m => a -> LogT m b -> LogT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LogT m a -> LogT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LogT m a -> LogT m b
fmap :: forall a b. (a -> b) -> LogT m a -> LogT m b
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> LogT m b -> LogT m a
<$ :: forall a b. a -> LogT m b -> LogT m a
Functor, Applicative (LogT m)
Applicative (LogT m) =>
(forall a b. LogT m a -> (a -> LogT m b) -> LogT m b)
-> (forall a b. LogT m a -> LogT m b -> LogT m b)
-> (forall a. a -> LogT m a)
-> Monad (LogT m)
forall a. a -> LogT m a
forall a b. LogT m a -> LogT m b -> LogT m b
forall a b. LogT m a -> (a -> LogT m b) -> LogT m b
forall (m :: * -> *). Monad m => Applicative (LogT m)
forall (m :: * -> *) a. Monad m => a -> LogT m a
forall (m :: * -> *) a b.
Monad m =>
LogT m a -> LogT m b -> LogT m b
forall (m :: * -> *) a b.
Monad m =>
LogT m a -> (a -> LogT m b) -> LogT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
LogT m a -> (a -> LogT m b) -> LogT m b
>>= :: forall a b. LogT m a -> (a -> LogT m b) -> LogT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
LogT m a -> LogT m b -> LogT m b
>> :: forall a b. LogT m a -> LogT m b -> LogT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> LogT m a
return :: forall a. a -> LogT m a
Monad, MonadBase b, MonadThrow (LogT m)
MonadThrow (LogT m) =>
(forall e a.
 (HasCallStack, Exception e) =>
 LogT m a -> (e -> LogT m a) -> LogT m a)
-> MonadCatch (LogT m)
forall e a.
(HasCallStack, Exception e) =>
LogT m a -> (e -> LogT m a) -> LogT m a
forall (m :: * -> *). MonadCatch m => MonadThrow (LogT m)
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
LogT m a -> (e -> LogT m a) -> LogT m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
LogT m a -> (e -> LogT m a) -> LogT m a
catch :: forall e a.
(HasCallStack, Exception e) =>
LogT m a -> (e -> LogT m a) -> LogT m a
MonadCatch
           ,Monad (LogT m)
Monad (LogT m) => (forall a. IO a -> LogT m a) -> MonadIO (LogT m)
forall a. IO a -> LogT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (LogT m)
forall (m :: * -> *) a. MonadIO m => IO a -> LogT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> LogT m a
liftIO :: forall a. IO a -> LogT m a
MonadIO, MonadCatch (LogT m)
MonadCatch (LogT m) =>
(forall b.
 HasCallStack =>
 ((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b)
-> (forall b.
    HasCallStack =>
    ((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b)
-> (forall a b c.
    HasCallStack =>
    LogT m a
    -> (a -> ExitCase b -> LogT m c)
    -> (a -> LogT m b)
    -> LogT m (b, c))
-> MonadMask (LogT m)
forall b.
HasCallStack =>
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
forall a b c.
HasCallStack =>
LogT m a
-> (a -> ExitCase b -> LogT m c)
-> (a -> LogT m b)
-> LogT m (b, c)
forall (m :: * -> *). MonadMask m => MonadCatch (LogT m)
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
LogT m a
-> (a -> ExitCase b -> LogT m c)
-> (a -> LogT m b)
-> LogT m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
mask :: forall b.
HasCallStack =>
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
$cgeneralBracket :: forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
LogT m a
-> (a -> ExitCase b -> LogT m c)
-> (a -> LogT m b)
-> LogT m (b, c)
generalBracket :: forall a b c.
HasCallStack =>
LogT m a
-> (a -> ExitCase b -> LogT m c)
-> (a -> LogT m b)
-> LogT m (b, c)
MonadMask, Monad (LogT m)
Alternative (LogT m)
(Alternative (LogT m), Monad (LogT m)) =>
(forall a. LogT m a)
-> (forall a. LogT m a -> LogT m a -> LogT m a)
-> MonadPlus (LogT m)
forall a. LogT m a
forall a. LogT m a -> LogT m a -> LogT m a
forall (m :: * -> *).
(Alternative m, Monad m) =>
(forall a. m a) -> (forall a. m a -> m a -> m a) -> MonadPlus m
forall (m :: * -> *). MonadPlus m => Monad (LogT m)
forall (m :: * -> *). MonadPlus m => Alternative (LogT m)
forall (m :: * -> *) a. MonadPlus m => LogT m a
forall (m :: * -> *) a.
MonadPlus m =>
LogT m a -> LogT m a -> LogT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => LogT m a
mzero :: forall a. LogT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
LogT m a -> LogT m a -> LogT m a
mplus :: forall a. LogT m a -> LogT m a -> LogT m a
MonadPlus, Monad (LogT m)
Monad (LogT m) =>
(forall e a. (HasCallStack, Exception e) => e -> LogT m a)
-> MonadThrow (LogT m)
forall e a. (HasCallStack, Exception e) => e -> LogT m a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
forall (m :: * -> *). MonadThrow m => Monad (LogT m)
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> LogT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> LogT m a
throwM :: forall e a. (HasCallStack, Exception e) => e -> LogT m a
MonadThrow, (forall (m :: * -> *). Monad m => Monad (LogT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> LogT m a)
-> MonadTrans LogT
forall (m :: * -> *). Monad m => Monad (LogT m)
forall (m :: * -> *) a. Monad m => m a -> LogT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> LogT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> LogT m a
MonadTrans, Monad (LogT m)
Monad (LogT m) =>
(forall a. String -> LogT m a) -> MonadFail (LogT m)
forall a. String -> LogT m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (LogT m)
forall (m :: * -> *) a. MonadFail m => String -> LogT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => String -> LogT m a
fail :: forall a. String -> LogT m a
MF.MonadFail
           ,MonadError e, MonadWriter w, MonadState s)

instance MonadReader r m => MonadReader r (LogT m) where
    ask :: LogT m r
ask   = m r -> LogT m r
forall (m :: * -> *) a. Monad m => m a -> LogT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
    local :: forall a. (r -> r) -> LogT m a -> LogT m a
local = (m a -> m a) -> LogT m a -> LogT m a
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> LogT m a -> LogT n b
mapLogT ((m a -> m a) -> LogT m a -> LogT m a)
-> ((r -> r) -> m a -> m a) -> (r -> r) -> LogT m a -> LogT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (r -> r) -> m a -> m a
forall a. (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local

-- | Run a 'LogT' computation.
--
-- Note that in the case of asynchronous/bulk loggers 'runLogT'
-- doesn't guarantee that all messages are actually written to the log
-- once it finishes. Use 'withPGLogger' or 'withElasticSearchLogger'
-- for that.
runLogT :: Text     -- ^ Application component name to use.
        -> Logger   -- ^ The logging back-end to use.
        -> LogLevel -- ^ The maximum log level allowed to be logged.
                    --   Only messages less or equal than this level with be logged.
        -> LogT m a -- ^ The 'LogT' computation to run.
        -> m a
runLogT :: forall (m :: * -> *) a.
Text -> Logger -> LogLevel -> LogT m a -> m a
runLogT Text
component Logger
logger LogLevel
maxLogLevel LogT m a
m = ReaderT LoggerEnv m a -> LoggerEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (LogT m a -> ReaderT LoggerEnv m a
forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT LogT m a
m) LoggerEnv {
  leLogger :: Logger
leLogger = Logger
logger
, leComponent :: Text
leComponent = Text
component
, leDomain :: [Text]
leDomain = []
, leData :: [Pair]
leData = []
, leMaxLogLevel :: LogLevel
leMaxLogLevel = LogLevel
maxLogLevel
} -- We can't do synchronisation here, since 'runLogT' can be invoked
  -- quite often from the application (e.g. on every request).

-- | Ensure uncaught exceptions get logged.
-- Convenient to compose right after `runLogT` so any exception
-- will show up.
logExceptions :: (MonadBaseControl IO m, MonadLog m) => m a -> m a
logExceptions :: forall (m :: * -> *) a.
(MonadBaseControl IO m, MonadLog m) =>
m a -> m a
logExceptions m a
f =
  m a -> (SomeException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
liftedCatch m a
f ((SomeException -> m a) -> m a) -> (SomeException -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \(SomeException e
e) -> do
      Text -> Value -> m ()
forall (m :: * -> *) a. (MonadLog m, ToJSON a) => Text -> a -> m ()
logAttention Text
"Uncaught exception" (Value -> m ()) -> Value -> m ()
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object [Key
"exception" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= e -> String
forall a. Show a => a -> String
show e
e]
      IO a -> m a
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ e -> IO a
forall e a. Exception e => e -> IO a
E.throwIO e
e

-- Generalized version of catch taken from `lifted-base`.
liftedCatch :: (MonadBaseControl IO m, Exception e)
      => m a       -- ^ The computation to run.
      -> (e -> m a) -- ^ Handler to invoke if an exception is raised.
      -> m a
liftedCatch :: forall (m :: * -> *) e a.
(MonadBaseControl IO m, Exception e) =>
m a -> (e -> m a) -> m a
liftedCatch m a
a e -> m a
handler = (RunInBase m IO -> IO (StM m a)) -> m a
forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b (StM m a)) -> m a
control ((RunInBase m IO -> IO (StM m a)) -> m a)
-> (RunInBase m IO -> IO (StM m a)) -> m a
forall a b. (a -> b) -> a -> b
$ \RunInBase m IO
runInIO ->
  IO (StM m a) -> (e -> IO (StM m a)) -> IO (StM m a)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
E.catch
    (m a -> IO (StM m a)
RunInBase m IO
runInIO m a
a)
    (m a -> IO (StM m a)
RunInBase m IO
runInIO (m a -> IO (StM m a)) -> (e -> m a) -> e -> IO (StM m a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
handler)

-- | Transform the computation inside a 'LogT'.
mapLogT :: (m a -> n b) -> LogT m a -> LogT n b
mapLogT :: forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> LogT m a -> LogT n b
mapLogT m a -> n b
f = InnerLogT n b -> LogT n b
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT (InnerLogT n b -> LogT n b)
-> (LogT m a -> InnerLogT n b) -> LogT m a -> LogT n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m a -> n b) -> ReaderT LoggerEnv m a -> InnerLogT n b
forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT m a -> n b
f (ReaderT LoggerEnv m a -> InnerLogT n b)
-> (LogT m a -> ReaderT LoggerEnv m a) -> LogT m a -> InnerLogT n b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogT m a -> ReaderT LoggerEnv m a
forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT

-- | Base implementation of 'logMessage' for use with a specific
-- 'LoggerEnv'. Useful for reimplementation of 'MonadLog' instance.
logMessageIO :: LoggerEnv -> UTCTime -> LogLevel -> Text -> Value -> IO ()
logMessageIO :: LoggerEnv -> UTCTime -> LogLevel -> Text -> Value -> IO ()
logMessageIO LoggerEnv{[Pair]
[Text]
Text
LogLevel
Logger
leLogger :: LoggerEnv -> Logger
leComponent :: LoggerEnv -> Text
leDomain :: LoggerEnv -> [Text]
leData :: LoggerEnv -> [Pair]
leMaxLogLevel :: LoggerEnv -> LogLevel
leLogger :: Logger
leComponent :: Text
leDomain :: [Text]
leData :: [Pair]
leMaxLogLevel :: LogLevel
..} UTCTime
time LogLevel
level Text
message Value
data_ =
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
level LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
<= LogLevel
leMaxLogLevel) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Logger -> LogMessage -> IO ()
execLogger Logger
leLogger (LogMessage -> IO ()) -> IO LogMessage -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LogMessage -> IO LogMessage
forall a. a -> IO a
E.evaluate (LogMessage -> LogMessage
forall a. NFData a => a -> a
force LogMessage
lm)
  where
    lm :: LogMessage
lm = LogMessage
      { lmComponent :: Text
lmComponent = Text
leComponent
      , lmDomain :: [Text]
lmDomain = [Text]
leDomain
      , lmTime :: UTCTime
lmTime = UTCTime
time
      , lmLevel :: LogLevel
lmLevel = LogLevel
level
      , lmMessage :: Text
lmMessage = Text
message
      , lmData :: Value
lmData = case Value
data_ of
          -- If lmData is not an object, we make it so and put previous data as
          -- the singleton value with key reflecting its type. It's required for
          -- ElasticSearch as ES needs fields with the same name to be of the
          -- same type in all log messages.
          Object Object
obj      -> Object -> Value
Object (Object -> Value) -> (Object -> Object) -> Object -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
AC.union Object
obj (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ [Pair] -> Object
forall v. [(Key, v)] -> KeyMap v
AC.fromList [Pair]
leData
          Value
_ | [Pair] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
leData -> [Pair] -> Value
object [Value -> Key
dataTyped Value
data_ Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Value
data_]
            | Bool
otherwise   -> [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Key
dataTyped Value
data_, Value
data_) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
leData
      }

    dataTyped :: Value -> Key
dataTyped = \case
      Object{} -> Key
"__data_object"
      Array{}  -> Key
"__data_array"
      String{} -> Key
"__data_string"
      Number{} -> Key
"__data_number"
      Bool{}   -> Key
"__data_bool"
      Null{}   -> Key
"__data_null"

-- | Return an IO action that logs messages using the current 'MonadLog'
-- context. Useful for interfacing with libraries such as @aws@ or @amazonka@
-- that accept logging callbacks operating in IO.
getLoggerIO :: MonadLog m => m (UTCTime -> LogLevel -> Text -> Value -> IO ())
getLoggerIO :: forall (m :: * -> *).
MonadLog m =>
m (UTCTime -> LogLevel -> Text -> Value -> IO ())
getLoggerIO = LoggerEnv -> UTCTime -> LogLevel -> Text -> Value -> IO ()
logMessageIO (LoggerEnv -> UTCTime -> LogLevel -> Text -> Value -> IO ())
-> m LoggerEnv -> m (UTCTime -> LogLevel -> Text -> Value -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m LoggerEnv
forall (m :: * -> *). MonadLog m => m LoggerEnv
getLoggerEnv

-- | @'hoist' = 'mapLogT'@
--
-- @since 0.7.2
instance MFunctor LogT where
    hoist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> LogT m b -> LogT n b
hoist forall a. m a -> n a
f = (m b -> n b) -> LogT m b -> LogT n b
forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> LogT m a -> LogT n b
mapLogT m b -> n b
forall a. m a -> n a
f

instance MonadTransControl LogT where
  type StT LogT m = StT InnerLogT m
  liftWith :: forall (m :: * -> *) a. Monad m => (Run LogT -> m a) -> LogT m a
liftWith = (forall b. ReaderT LoggerEnv m b -> LogT m b)
-> (forall (m :: * -> *) a. LogT m a -> InnerLogT m a)
-> (RunDefault LogT (ReaderT LoggerEnv) -> m a)
-> LogT m a
forall (m :: * -> *) (n :: (* -> *) -> * -> *)
       (t :: (* -> *) -> * -> *) a.
(Monad m, MonadTransControl n) =>
(forall b. n m b -> t m b)
-> (forall (o :: * -> *) b. t o b -> n o b)
-> (RunDefault t n -> m a)
-> t m a
defaultLiftWith InnerLogT m b -> LogT m b
forall b. ReaderT LoggerEnv m b -> LogT m b
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT LogT o b -> InnerLogT o b
forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT
  restoreT :: forall (m :: * -> *) a. Monad m => m (StT LogT a) -> LogT m a
restoreT = (ReaderT LoggerEnv m a -> LogT m a)
-> m (StT (ReaderT LoggerEnv) a) -> LogT m a
forall (m :: * -> *) (n :: (* -> *) -> * -> *) a
       (t :: (* -> *) -> * -> *).
(Monad m, MonadTransControl n) =>
(n m a -> t m a) -> m (StT n a) -> t m a
defaultRestoreT ReaderT LoggerEnv m a -> LogT m a
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT

instance MonadBaseControl b m => MonadBaseControl b (LogT m) where
  type StM (LogT m) a = ComposeSt LogT m a
  liftBaseWith :: forall a. (RunInBase (LogT m) b -> b a) -> LogT m a
liftBaseWith = (RunInBaseDefault LogT m b -> b a) -> LogT m a
(RunInBase (LogT m) b -> b a) -> LogT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
  restoreM :: forall a. StM (LogT m) a -> LogT m a
restoreM     = ComposeSt LogT m a -> LogT m a
StM (LogT m) a -> LogT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
defaultRestoreM

instance MonadUnliftIO m => MonadUnliftIO (LogT m) where
  withRunInIO :: forall b. ((forall a. LogT m a -> IO a) -> IO b) -> LogT m b
withRunInIO (forall a. LogT m a -> IO a) -> IO b
inner = InnerLogT m b -> LogT m b
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT (InnerLogT m b -> LogT m b) -> InnerLogT m b -> LogT m b
forall a b. (a -> b) -> a -> b
$ ((forall a. ReaderT LoggerEnv m a -> IO a) -> IO b)
-> InnerLogT m b
forall b.
((forall a. ReaderT LoggerEnv m a -> IO a) -> IO b)
-> ReaderT LoggerEnv m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. ReaderT LoggerEnv m a -> IO a) -> IO b)
 -> InnerLogT m b)
-> ((forall a. ReaderT LoggerEnv m a -> IO a) -> IO b)
-> InnerLogT m b
forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT LoggerEnv m a -> IO a
run -> (forall a. LogT m a -> IO a) -> IO b
inner (ReaderT LoggerEnv m a -> IO a
forall a. ReaderT LoggerEnv m a -> IO a
run (ReaderT LoggerEnv m a -> IO a)
-> (LogT m a -> ReaderT LoggerEnv m a) -> LogT m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogT m a -> ReaderT LoggerEnv m a
forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT)

instance MonadBase IO m => MonadLog (LogT m) where
  logMessage :: LogLevel -> Text -> Value -> LogT m ()
logMessage LogLevel
level Text
message Value
data_ = InnerLogT m () -> LogT m ()
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT (InnerLogT m () -> LogT m ())
-> ((LoggerEnv -> m ()) -> InnerLogT m ())
-> (LoggerEnv -> m ())
-> LogT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LoggerEnv -> m ()) -> InnerLogT m ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((LoggerEnv -> m ()) -> LogT m ())
-> (LoggerEnv -> m ()) -> LogT m ()
forall a b. (a -> b) -> a -> b
$ \LoggerEnv
logEnv -> IO () -> m ()
forall α. IO α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
time <- IO UTCTime
getCurrentTime
    LoggerEnv -> UTCTime -> LogLevel -> Text -> Value -> IO ()
logMessageIO LoggerEnv
logEnv UTCTime
time LogLevel
level Text
message Value
data_

  localData :: forall a. [Pair] -> LogT m a -> LogT m a
localData [Pair]
data_ =
    InnerLogT m a -> LogT m a
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT (InnerLogT m a -> LogT m a)
-> (LogT m a -> InnerLogT m a) -> LogT m a -> LogT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LoggerEnv -> LoggerEnv) -> InnerLogT m a -> InnerLogT m a
forall a.
(LoggerEnv -> LoggerEnv)
-> ReaderT LoggerEnv m a -> ReaderT LoggerEnv m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LoggerEnv
e -> LoggerEnv
e { leData = data_ ++ leData e }) (InnerLogT m a -> InnerLogT m a)
-> (LogT m a -> InnerLogT m a) -> LogT m a -> InnerLogT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogT m a -> InnerLogT m a
forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT

  localDomain :: forall a. Text -> LogT m a -> LogT m a
localDomain Text
domain =
    InnerLogT m a -> LogT m a
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT (InnerLogT m a -> LogT m a)
-> (LogT m a -> InnerLogT m a) -> LogT m a -> LogT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LoggerEnv -> LoggerEnv) -> InnerLogT m a -> InnerLogT m a
forall a.
(LoggerEnv -> LoggerEnv)
-> ReaderT LoggerEnv m a -> ReaderT LoggerEnv m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LoggerEnv
e -> LoggerEnv
e { leDomain = leDomain e ++ [domain] }) (InnerLogT m a -> InnerLogT m a)
-> (LogT m a -> InnerLogT m a) -> LogT m a -> InnerLogT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogT m a -> InnerLogT m a
forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT

  localMaxLogLevel :: forall a. LogLevel -> LogT m a -> LogT m a
localMaxLogLevel LogLevel
level =
    InnerLogT m a -> LogT m a
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT (InnerLogT m a -> LogT m a)
-> (LogT m a -> InnerLogT m a) -> LogT m a -> LogT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LoggerEnv -> LoggerEnv) -> InnerLogT m a -> InnerLogT m a
forall a.
(LoggerEnv -> LoggerEnv)
-> ReaderT LoggerEnv m a -> ReaderT LoggerEnv m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LoggerEnv
e -> LoggerEnv
e { leMaxLogLevel = level }) (InnerLogT m a -> InnerLogT m a)
-> (LogT m a -> InnerLogT m a) -> LogT m a -> InnerLogT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogT m a -> InnerLogT m a
forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT

  getLoggerEnv :: LogT m LoggerEnv
getLoggerEnv = InnerLogT m LoggerEnv -> LogT m LoggerEnv
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT InnerLogT m LoggerEnv
forall r (m :: * -> *). MonadReader r m => m r
ask