{-# LANGUAGE CPP #-}
module Log.Monad (
Logger
, LoggerEnv(..)
, InnerLogT
, LogT(..)
, runLogT
, 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
newtype LogT m a = LogT { forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT :: InnerLogT m a }
deriving (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
many :: forall a. LogT m a -> LogT m [a]
$cmany :: forall (m :: * -> *) a. Alternative m => LogT m a -> LogT m [a]
some :: forall a. LogT m a -> LogT m [a]
$csome :: forall (m :: * -> *) a. Alternative m => LogT m a -> LogT m [a]
<|> :: forall a. LogT m a -> LogT m a -> LogT m a
$c<|> :: forall (m :: * -> *) a.
Alternative m =>
LogT m a -> LogT m a -> LogT m a
empty :: forall a. LogT m a
$cempty :: forall (m :: * -> *) a. Alternative m => LogT m a
Alternative, 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
<* :: forall a b. LogT m a -> LogT m b -> LogT m a
$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 b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
LogT m a -> LogT m b -> LogT m b
liftA2 :: forall a b c. (a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> LogT m a -> LogT m b -> LogT m c
<*> :: forall a b. LogT m (a -> b) -> LogT m a -> LogT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
LogT m (a -> b) -> LogT m a -> LogT m b
pure :: forall a. a -> LogT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> LogT m a
Applicative, 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
<$ :: forall a b. a -> LogT m b -> LogT m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> LogT m b -> LogT m a
fmap :: forall a b. (a -> b) -> LogT m a -> LogT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LogT m a -> LogT m b
Functor, 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
return :: forall a. a -> LogT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> LogT m a
>> :: forall a b. LogT m 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 -> (a -> LogT m b) -> LogT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
LogT m a -> (a -> LogT m b) -> LogT m b
Monad, MonadBase b, forall e a. Exception e => LogT m a -> (e -> LogT m a) -> LogT m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
forall {m :: * -> *}. MonadCatch m => MonadThrow (LogT m)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
LogT m a -> (e -> LogT m a) -> LogT m a
catch :: forall e a. Exception e => LogT m a -> (e -> LogT m a) -> LogT m a
$ccatch :: forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
LogT m a -> (e -> LogT m a) -> LogT m a
MonadCatch
,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
liftIO :: forall a. IO a -> LogT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> LogT m a
MonadIO, forall b.
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
forall a b c.
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 =>
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
forall (m :: * -> *) a b c.
MonadMask m =>
LogT m a
-> (a -> ExitCase b -> LogT m c)
-> (a -> LogT m b)
-> LogT m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
LogT m a
-> (a -> ExitCase b -> LogT m c)
-> (a -> LogT m b)
-> LogT m (b, c)
$cgeneralBracket :: forall (m :: * -> *) a b c.
MonadMask m =>
LogT m a
-> (a -> ExitCase b -> LogT m c)
-> (a -> LogT m b)
-> LogT m (b, c)
uninterruptibleMask :: forall b.
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
$cuninterruptibleMask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
mask :: forall b.
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
$cmask :: forall (m :: * -> *) b.
MonadMask m =>
((forall a. LogT m a -> LogT m a) -> LogT m b) -> LogT m b
MonadMask, 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
mplus :: forall a. LogT m a -> LogT m a -> LogT m a
$cmplus :: forall (m :: * -> *) a.
MonadPlus m =>
LogT m a -> LogT m a -> LogT m a
mzero :: forall a. LogT m a
$cmzero :: forall (m :: * -> *) a. MonadPlus m => LogT m a
MonadPlus, forall e a. Exception e => e -> LogT m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
forall {m :: * -> *}. MonadThrow m => Monad (LogT m)
forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> LogT m a
throwM :: forall e a. Exception e => e -> LogT m a
$cthrowM :: forall (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> LogT m a
MonadThrow, forall (m :: * -> *) a. Monad m => m a -> LogT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> LogT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> LogT m a
MonadTrans, 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
fail :: forall a. String -> LogT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => 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 = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall r (m :: * -> *). MonadReader r m => m r
ask
local :: forall a. (r -> r) -> LogT m a -> LogT m a
local = forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> LogT m a -> LogT n b
mapLogT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local
runLogT :: Text
-> Logger
-> LogLevel
-> LogT m a
-> 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 = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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
}
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 = forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a (n :: * -> *) b r.
(m a -> n b) -> ReaderT r m a -> ReaderT r n b
mapReaderT m a -> n b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT
logMessageIO :: LoggerEnv -> UTCTime -> LogLevel -> Text -> Value -> IO ()
logMessageIO :: LoggerEnv -> UTCTime -> LogLevel -> Text -> Value -> IO ()
logMessageIO LoggerEnv{[Pair]
[Text]
Text
LogLevel
Logger
leMaxLogLevel :: LogLevel
leData :: [Pair]
leDomain :: [Text]
leComponent :: Text
leLogger :: Logger
leMaxLogLevel :: LoggerEnv -> LogLevel
leData :: LoggerEnv -> [Pair]
leDomain :: LoggerEnv -> [Text]
leComponent :: LoggerEnv -> Text
leLogger :: LoggerEnv -> Logger
..} UTCTime
time LogLevel
level Text
message Value
data_ =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LogLevel
level forall a. Ord a => a -> a -> Bool
<= LogLevel
leMaxLogLevel) forall a b. (a -> b) -> a -> b
$
Logger -> LogMessage -> IO ()
execLogger Logger
leLogger forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. a -> IO a
E.evaluate (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
Object Object
obj -> Object -> Value
Object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. KeyMap v -> KeyMap v -> KeyMap v
AC.union Object
obj forall a b. (a -> b) -> a -> b
$ forall v. [(Key, v)] -> KeyMap v
AC.fromList [Pair]
leData
Value
_ | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pair]
leData -> [Pair] -> Value
object [Value -> Key
dataTyped Value
data_ forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
data_]
| Bool
otherwise -> [Pair] -> Value
object forall a b. (a -> b) -> a -> b
$ (Value -> Key
dataTyped Value
data_, Value
data_) 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"
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadLog m => m LoggerEnv
getLoggerEnv
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 = forall (m :: * -> *) a (n :: * -> *) b.
(m a -> n b) -> LogT m a -> LogT n b
mapLogT 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 (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 forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT
restoreT :: forall (m :: * -> *) a. Monad m => m (StT LogT a) -> LogT m a
restoreT = forall (m :: * -> *) (n :: (* -> *) -> * -> *) a
(t :: (* -> *) -> * -> *).
(Monad m, MonadTransControl n) =>
(n m a -> t m a) -> m (StT n a) -> t m a
defaultRestoreT 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 = 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 = 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 = forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO 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 (forall a. ReaderT LoggerEnv m a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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_ = forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \LoggerEnv
logEnv -> forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase 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_ =
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LoggerEnv
e -> LoggerEnv
e { leData :: [Pair]
leData = [Pair]
data_ forall a. [a] -> [a] -> [a]
++ LoggerEnv -> [Pair]
leData LoggerEnv
e }) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT
localDomain :: forall a. Text -> LogT m a -> LogT m a
localDomain Text
domain =
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LoggerEnv
e -> LoggerEnv
e { leDomain :: [Text]
leDomain = LoggerEnv -> [Text]
leDomain LoggerEnv
e forall a. [a] -> [a] -> [a]
++ [Text
domain] }) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT
localMaxLogLevel :: forall a. LogLevel -> LogT m a -> LogT m a
localMaxLogLevel LogLevel
level =
forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\LoggerEnv
e -> LoggerEnv
e { leMaxLogLevel :: LogLevel
leMaxLogLevel = LogLevel
level }) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. LogT m a -> InnerLogT m a
unLogT
getLoggerEnv :: LogT m LoggerEnv
getLoggerEnv = forall (m :: * -> *) a. InnerLogT m a -> LogT m a
LogT forall r (m :: * -> *). MonadReader r m => m r
ask