#if MIN_VERSION_base(4, 9, 0)
#endif
module Katip.Monadic
(
logFM
, logTM
, logLocM
, logItemM
, logExceptionM
, KatipContext(..)
, AnyLogContext
, LogContexts
, liftPayload
, KatipContextT(..)
, runKatipContextT
, katipAddNamespace
, katipAddContext
, KatipContextTState(..)
) where
import Control.Applicative
import Control.Exception.Safe
import Control.Monad.Base
import Control.Monad.Error.Class
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control
import Control.Monad.Trans.Either (EitherT, mapEitherT)
import Control.Monad.Trans.Except (ExceptT, mapExceptT)
import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
import Control.Monad.Trans.List (ListT, mapListT)
import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
import Control.Monad.Trans.Resource (ResourceT, transResourceT)
import Control.Monad.Trans.RWS (RWST, mapRWST)
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT,
mapWriterT)
import Control.Monad.Writer hiding ((<>))
import Data.Aeson
import qualified Data.Foldable as FT
import qualified Data.HashMap.Strict as HM
import Data.Semigroup as Semi
import Data.Sequence as Seq
import Data.Text (Text)
import Language.Haskell.TH
import Katip.Core
data AnyLogContext where
AnyLogContext :: (LogItem a) => a -> AnyLogContext
newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid, Semigroup)
instance ToJSON LogContexts where
toJSON (LogContexts cs) =
Object $ FT.foldr (flip mappend) mempty $ fmap (\(AnyLogContext v) -> toObject v) cs
instance ToObject LogContexts
instance LogItem LogContexts where
payloadKeys verb (LogContexts vs) = FT.foldr (flip mappend) mempty $ fmap payloadKeys' vs
where
payloadKeys' (AnyLogContext v) = case payloadKeys verb v of
AllKeys -> SomeKeys $ HM.keys $ toObject v
x -> x
liftPayload :: (LogItem a) => a -> LogContexts
liftPayload = LogContexts . Seq.singleton . AnyLogContext
class Katip m => KatipContext m where
getKatipContext :: m LogContexts
localKatipContext :: (LogContexts -> LogContexts) -> m a -> m a
getKatipNamespace :: m Namespace
localKatipNamespace :: (Namespace -> Namespace) -> m a -> m a
instance (KatipContext m, Katip (IdentityT m)) => KatipContext (IdentityT m) where
getKatipContext = lift getKatipContext
localKatipContext = mapIdentityT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = mapIdentityT . localKatipNamespace
instance (KatipContext m, Katip (MaybeT m)) => KatipContext (MaybeT m) where
getKatipContext = lift getKatipContext
localKatipContext = mapMaybeT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = mapMaybeT . localKatipNamespace
instance (KatipContext m, Katip (EitherT e m)) => KatipContext (EitherT e m) where
getKatipContext = lift getKatipContext
localKatipContext = mapEitherT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = mapEitherT . localKatipNamespace
instance (KatipContext m, Katip (ListT m)) => KatipContext (ListT m) where
getKatipContext = lift getKatipContext
localKatipContext = mapListT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = mapListT . localKatipNamespace
instance (KatipContext m, Katip (ReaderT r m)) => KatipContext (ReaderT r m) where
getKatipContext = lift getKatipContext
localKatipContext = mapReaderT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = mapReaderT . localKatipNamespace
instance (KatipContext m, Katip (ResourceT m)) => KatipContext (ResourceT m) where
getKatipContext = lift getKatipContext
localKatipContext = transResourceT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = transResourceT . localKatipNamespace
instance (KatipContext m, Katip (Strict.StateT s m)) => KatipContext (Strict.StateT s m) where
getKatipContext = lift getKatipContext
localKatipContext = Strict.mapStateT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = Strict.mapStateT . localKatipNamespace
instance (KatipContext m, Katip (StateT s m)) => KatipContext (StateT s m) where
getKatipContext = lift getKatipContext
localKatipContext = mapStateT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = mapStateT . localKatipNamespace
instance (KatipContext m, Katip (ExceptT e m)) => KatipContext (ExceptT e m) where
getKatipContext = lift getKatipContext
localKatipContext = mapExceptT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = mapExceptT . localKatipNamespace
instance (Monoid w, KatipContext m, Katip (Strict.WriterT w m)) => KatipContext (Strict.WriterT w m) where
getKatipContext = lift getKatipContext
localKatipContext = Strict.mapWriterT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = Strict.mapWriterT . localKatipNamespace
instance (Monoid w, KatipContext m, Katip (WriterT w m)) => KatipContext (WriterT w m) where
getKatipContext = lift getKatipContext
localKatipContext = mapWriterT . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = mapWriterT . localKatipNamespace
instance (Monoid w, KatipContext m, Katip (Strict.RWST r w s m)) => KatipContext (Strict.RWST r w s m) where
getKatipContext = lift getKatipContext
localKatipContext = Strict.mapRWST . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = Strict.mapRWST . localKatipNamespace
instance (Monoid w, KatipContext m, Katip (RWST r w s m)) => KatipContext (RWST r w s m) where
getKatipContext = lift getKatipContext
localKatipContext = mapRWST . localKatipContext
getKatipNamespace = lift getKatipNamespace
localKatipNamespace = mapRWST . localKatipNamespace
deriving instance (Monad m, KatipContext m) => KatipContext (KatipT m)
logItemM
:: (Applicative m, KatipContext m)
=> Maybe Loc
-> Severity
-> LogStr
-> m ()
logItemM loc sev msg = do
ctx <- getKatipContext
ns <- getKatipNamespace
logItem ctx ns loc sev msg
logFM
:: (Applicative m, KatipContext m)
=> Severity
-> LogStr
-> m ()
logFM sev msg = do
ctx <- getKatipContext
ns <- getKatipNamespace
logF ctx ns sev msg
logTM :: ExpQ
logTM = [| logItemM (Just $(getLocTH)) |]
logLocM :: (Applicative m, KatipContext m)
=> Severity
-> LogStr
-> m ()
logLocM = logItemM getLoc
logExceptionM
:: (KatipContext m, MonadCatch m, Applicative m)
=> m a
-> Severity
-> m a
logExceptionM action sev = action `catchAny` \e -> f e >> throwM e
where
f e = logFM sev (msg e)
msg e = ls ("An exception has occured: " :: Text) Semi.<> showLS e
newtype KatipContextT m a = KatipContextT {
unKatipContextT :: ReaderT KatipContextTState m a
} deriving ( Functor
, Applicative
, Monad
, MonadIO
, MonadThrow
, MonadCatch
, MonadMask
, MonadBase b
, MonadState s
, MonadWriter w
, MonadError e
, MonadPlus
, Alternative
, MonadFix
, MonadTrans
)
data KatipContextTState = KatipContextTState {
ltsLogEnv :: !LogEnv
, ltsContext :: !LogContexts
, ltsNamespace :: !Namespace
}
instance MonadTransControl KatipContextT where
type StT KatipContextT a = StT (ReaderT KatipContextTState) a
liftWith = defaultLiftWith KatipContextT unKatipContextT
restoreT = defaultRestoreT KatipContextT
instance (MonadBaseControl b m) => MonadBaseControl b (KatipContextT m) where
type StM (KatipContextT m) a = ComposeSt KatipContextT m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
instance (MonadReader r m) => MonadReader r (KatipContextT m) where
ask = lift ask
local f (KatipContextT (ReaderT m)) = KatipContextT $ ReaderT $ \r ->
local f (m r)
instance (MonadIO m) => Katip (KatipContextT m) where
getLogEnv = KatipContextT $ ReaderT $ \lts -> return (ltsLogEnv lts)
localLogEnv f (KatipContextT m) = KatipContextT (local (\s -> s { ltsLogEnv = f (ltsLogEnv s)}) m)
instance (MonadIO m) => KatipContext (KatipContextT m) where
getKatipContext = KatipContextT $ ReaderT $ \lts -> return (ltsContext lts)
localKatipContext f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsContext = f (ltsContext s)}) m
getKatipNamespace = KatipContextT $ ReaderT $ \lts -> return (ltsNamespace lts)
localKatipNamespace f (KatipContextT m) = KatipContextT $ local (\s -> s { ltsNamespace = f (ltsNamespace s)}) m
runKatipContextT :: (LogItem c) => LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT le ctx ns = flip runReaderT lts . unKatipContextT
where
lts = KatipContextTState le (liftPayload ctx) ns
katipAddNamespace
:: (KatipContext m)
=> Namespace
-> m a
-> m a
katipAddNamespace ns = localKatipNamespace (<> ns)
katipAddContext
:: ( LogItem i
, KatipContext m
)
=> i
-> m a
-> m a
katipAddContext i = localKatipContext (<> (liftPayload i))