Monadic.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

#if MIN_VERSION_base(4, 9, 0)
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
#endif

-- | Provides support for treating payloads and namespaces as
-- composable contexts. The common pattern would be to provide a
-- 'KatipContext' instance for your base monad.
module Katip.Monadic
  ( -- * Monadic variants of logging functions from "Katip.Core"
    logFM,
    logTM,
    logLocM,
    logItemM,
    logExceptionM,

    -- * Machinery for merging typed log payloads/contexts
    KatipContext (..),
    AnyLogContext,
    LogContexts,
    liftPayload,

    -- * KatipContextT - Utility transformer that provides Katip and KatipContext instances
    KatipContextT (..),
    runKatipContextT,
    katipAddNamespace,
    katipAddContext,
    KatipContextTState (..),
    NoLoggingT (..),
    askLoggerIO,
  )
where

-------------------------------------------------------------------------------
import Control.Applicative
import Control.Exception.Safe
import Control.Monad                               as CM
import Control.Monad.Base
import Control.Monad.Error.Class
#if MIN_VERSION_base(4, 9, 0)
import qualified Control.Monad.Fail                as MF
#endif
import Control.Monad.Fix                           as MFix
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift
import Control.Monad.Reader
import Control.Monad.State
import Control.Monad.Trans.Control
#if !MIN_VERSION_either(4, 5, 0)
import           Control.Monad.Trans.Either        (EitherT, mapEitherT)
#endif
import Control.Monad.Trans.Except (ExceptT, mapExceptT)
import Control.Monad.Trans.Identity (IdentityT, mapIdentityT)
import Control.Monad.Trans.Maybe (MaybeT, mapMaybeT)
import Control.Monad.Trans.RWS (RWST, mapRWST)
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST, mapRWST)
import Control.Monad.Trans.Resource
  ( MonadResource,
    ResourceT,
    transResourceT,
  )
import qualified Control.Monad.Trans.State.Strict as Strict (StateT, mapStateT)
import qualified Control.Monad.Trans.Writer.Strict as Strict
  ( WriterT,
    mapWriterT,
  )
import qualified Control.Monad.Writer as Lazy (WriterT, mapWriterT)
import Control.Monad.Writer.Class as WC
import Data.Aeson
#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as KM
import qualified Data.Aeson.Key as K
#endif
import qualified Data.Foldable as FT
#if !MIN_VERSION_aeson(2, 0, 0)
import qualified Data.HashMap.Strict as HM
#endif
import Data.Semigroup as Semi
import Data.Sequence as Seq
import Data.Text (Text)
#if MIN_VERSION_base(4, 8, 0)
#if !MIN_VERSION_base(4, 9, 0)
import           GHC.SrcLoc
#endif
import GHC.Stack
#endif

-------------------------------------------------------------------------------
import Katip.Core
import Language.Haskell.TH

-------------------------------------------------------------------------------

-- | A wrapper around a log context that erases type information so
-- that contexts from multiple layers can be combined intelligently.
data AnyLogContext where
  AnyLogContext :: (LogItem a) => a -> AnyLogContext

-------------------------------------------------------------------------------

-- | Heterogeneous list of log contexts that provides a smart
-- 'LogContext' instance for combining multiple payload policies. This
-- is critical for log contexts deep down in a stack to be able to
-- inject their own context without worrying about other context that
-- has already been set. Also note that contexts are treated as a
-- sequence and '<>' will be appended to the right hand side of the
-- sequence. If there are conflicting keys in the contexts, the /right
-- side will take precedence/, which is counter to how monoid works
-- for 'Map' and 'HashMap', so bear that in mind. The reasoning is
-- that if the user is /sequentially/ adding contexts to the right
-- side of the sequence, on conflict the intent is to overwrite with
-- the newer value (i.e. the rightmost value).
--
-- Additional note: you should not mappend LogContexts in any sort of
-- infinite loop, as it retains all data, so that would be a memory
-- leak.
newtype LogContexts = LogContexts (Seq AnyLogContext) deriving (Monoid, Semigroup)

instance ToJSON LogContexts where
  toJSON (LogContexts cs) =
    -- flip mappend to get right-biased merge
    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
      -- To ensure AllKeys doesn't leak keys from other values when
      -- combined, we resolve AllKeys to its equivalent SomeKeys
      -- representation first.
      payloadKeys' (AnyLogContext v) = case payloadKeys verb v of
        AllKeys -> SomeKeys $ toKeys $ toObject v
        x -> x

#if MIN_VERSION_aeson(2, 0, 0)
toKeys :: KM.KeyMap v -> [Text]
toKeys = fmap K.toText . KM.keys
#else
toKeys :: HM.HashMap k v -> [k]
toKeys = HM.keys
#endif

-------------------------------------------------------------------------------

-- | Lift a log context into the generic wrapper so that it can
-- combine with the existing log context.
liftPayload :: (LogItem a) => a -> LogContexts
liftPayload = LogContexts . Seq.singleton . AnyLogContext

-------------------------------------------------------------------------------

-- | A monadic context that has an inherant way to get logging context
-- and namespace. Examples include a web application monad or database
-- monad. The @local@ variants are just like @local@ from Reader and
-- indeed you can easily implement them with @local@ if you happen to
-- be using a Reader in your monad. These give us 'katipAddNamespace'
-- and 'katipAddContext' that works with *any* 'KatipContext', as
-- opposed to making users have to implement these functions on their
-- own in each app.
class Katip m => KatipContext m where
  getKatipContext :: m LogContexts

  -- | Temporarily modify the current context for the duration of the
  -- supplied monad. Used in 'katipAddContext'
  localKatipContext :: (LogContexts -> LogContexts) -> m a -> m a

  getKatipNamespace :: m Namespace

  -- | Temporarily modify the current namespace for the duration of the
  -- supplied monad. Used in 'katipAddNamespace'
  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

#if !MIN_VERSION_either(4, 5, 0)
instance (KatipContext m, Katip (EitherT e m)) => KatipContext (EitherT e m) where
  getKatipContext = lift getKatipContext
  localKatipContext = mapEitherT . localKatipContext
  getKatipNamespace = lift getKatipNamespace
  localKatipNamespace = mapEitherT . localKatipNamespace
#endif

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 (Lazy.WriterT w m)) => KatipContext (Lazy.WriterT w m) where
  getKatipContext = lift getKatipContext
  localKatipContext = Lazy.mapWriterT . localKatipContext
  getKatipNamespace = lift getKatipNamespace
  localKatipNamespace = Lazy.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)

-------------------------------------------------------------------------------

-- | Log with everything, including a source code location. This is
-- very low level and you typically can use 'logTM' in its
-- place. Automatically supplies payload and namespace.
logItemM ::
  (Applicative m, KatipContext m, HasCallStack) =>
  Maybe Loc ->
  Severity ->
  LogStr ->
  m ()
logItemM loc sev msg = do
  ctx <- getKatipContext
  ns <- getKatipNamespace
  logItem ctx ns loc sev msg

-------------------------------------------------------------------------------

-- | Log with full context, but without any code
-- location. Automatically supplies payload and namespace.
logFM ::
  (Applicative m, KatipContext m) =>
  -- | Severity of the message
  Severity ->
  -- | The log message
  LogStr ->
  m ()
logFM sev msg = do
  ctx <- getKatipContext
  ns <- getKatipNamespace
  logF ctx ns sev msg

-------------------------------------------------------------------------------

-- | 'Loc'-tagged logging when using template-haskell. Automatically
-- supplies payload and namespace.
--
-- @$(logTM) InfoS "Hello world"@
logTM :: ExpQ
logTM = [|logItemM (Just $(getLocTH))|]

-------------------------------------------------------------------------------

-- | 'Loc'-tagged logging when using 'GHC.Stack.getCallStack' implicit-callstacks>.
--   Automatically supplies payload and namespace.
--
-- Same consideration as `logLoc` applies.
--
-- By default, location will be logged from the module that invokes 'logLocM'.
-- If you want to use 'logLocM' in a helper, wrap the entire helper in
-- 'withFrozenCallStack' to retain the callsite of the helper in the logs.
--
-- This function does not require template-haskell. Using GHC <= 7.8 will result
-- in the emission of a log line without any location information.
-- Users using GHC <= 7.8 may want to use the template-haskell function
-- `logTM` for maximum compatibility.
--
-- @logLocM InfoS "Hello world"@
logLocM ::
  (Applicative m, KatipContext m, HasCallStack) =>
  Severity ->
  LogStr ->
  m ()
logLocM sev item = withFrozenCallStack $ logItemM getLoc sev item

-------------------------------------------------------------------------------

-- | Perform an action while logging any exceptions that may occur.
-- Inspired by 'onException`.
--
-- >>>> error "foo" `logExceptionM` ErrorS
logExceptionM ::
  (KatipContext m, MonadCatch m, Applicative m) =>
  -- | Main action to run
  m a ->
  -- | Severity
  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 occurred: " :: Text) Semi.<> showLS e

-------------------------------------------------------------------------------

-- | Provides a simple transformer that defines a 'KatipContext'
-- instance for a fixed namespace and context. Just like 'KatipT', you
-- should use this if you prefer an explicit transformer stack and
-- don't want to (or cannot) define 'KatipContext' for your monad
-- . This is the slightly more powerful version of KatipT in that it
-- provides KatipContext instead of just Katip. For instance:
--
-- @
--   threadWithLogging = do
--     le <- getLogEnv
--     ctx <- getKatipContext
--     ns <- getKatipNamespace
--     forkIO $ runKatipContextT le ctx ns $ do
--       $(logTM) InfoS "Look, I can log in IO and retain context!"
--       doOtherStuff
-- @
newtype KatipContextT m a = KatipContextT
  { unKatipContextT :: ReaderT KatipContextTState m a
  }
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadThrow,
      MonadCatch,
      MonadMask,
      MonadBase b,
      MonadState s,
      WC.MonadWriter w,
      MonadError e,
      CM.MonadPlus,
      MonadResource,
      Alternative,
      MFix.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
  {-# INLINE liftWith #-}
  {-# INLINE restoreT #-}

instance (MonadBaseControl b m) => MonadBaseControl b (KatipContextT m) where
  type StM (KatipContextT m) a = ComposeSt KatipContextT m a
  liftBaseWith = defaultLiftBaseWith
  restoreM = defaultRestoreM

-- Reader is a passthrough. We don't expose our internal reader so as not to conflict
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

#if MIN_VERSION_unliftio_core(0, 2, 0)
instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where
  withRunInIO inner = KatipContextT $ ReaderT $ \lts -> withRunInIO $ \run ->
    inner (run . runKatipContextT (ltsLogEnv lts) (ltsContext lts) (ltsNamespace lts))
#else
instance MonadUnliftIO m => MonadUnliftIO (KatipContextT m) where
  askUnliftIO = KatipContextT $
    withUnliftIO $ \u ->
      pure (UnliftIO (unliftIO u . unKatipContextT))
#endif

#if MIN_VERSION_base(4, 9, 0)
instance MF.MonadFail m => MF.MonadFail (KatipContextT m) where
    fail msg = lift (MF.fail msg)
    {-# INLINE fail #-}
#endif

-------------------------------------------------------------------------------
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

-------------------------------------------------------------------------------

-- | Append a namespace segment to the current namespace for the given
-- monadic action, then restore the previous state
-- afterwards. Works with anything implementing KatipContext.
katipAddNamespace ::
  (KatipContext m) =>
  Namespace ->
  m a ->
  m a
katipAddNamespace ns = localKatipNamespace (<> ns)

-------------------------------------------------------------------------------

-- | Append some context to the current context for the given monadic
-- action, then restore the previous state afterwards. Important note:
-- be careful using this in a loop. If you're using something like
-- 'forever' or 'replicateM_' that does explicit sharing to avoid a
-- memory leak, youll be fine as it will *sequence* calls to
-- 'katipAddNamespace', so each loop will get the same context
-- added. If you instead roll your own recursion and you're recursing
-- in the action you provide, you'll instead accumulate tons of
-- redundant contexts and even if they all merge on log, they are
-- stored in a sequence and will leak memory. Works with anything
-- implementing KatipContext.
katipAddContext ::
  ( LogItem i,
    KatipContext m
  ) =>
  i ->
  m a ->
  m a
katipAddContext i = localKatipContext (<> (liftPayload i))

newtype NoLoggingT m a = NoLoggingT
  { runNoLoggingT :: m a
  }
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadThrow,
      MonadCatch,
      MonadMask,
      MonadBase b,
      MonadState s,
      WC.MonadWriter w,
      MonadError e,
      CM.MonadPlus,
      Alternative,
      MFix.MonadFix,
      MonadReader r
    )

instance MonadTrans NoLoggingT where
  lift = NoLoggingT

instance MonadTransControl NoLoggingT where
  type StT NoLoggingT a = a
  liftWith f = NoLoggingT $ f runNoLoggingT
  restoreT = NoLoggingT
  {-# INLINE liftWith #-}
  {-# INLINE restoreT #-}

instance MonadBaseControl b m => MonadBaseControl b (NoLoggingT m) where
  type StM (NoLoggingT m) a = StM m a
  liftBaseWith f = NoLoggingT $
    liftBaseWith $ \runInBase ->
      f $ runInBase . runNoLoggingT
  restoreM = NoLoggingT . restoreM



#if MIN_VERSION_unliftio_core(0, 2, 0)
instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where
  withRunInIO inner = NoLoggingT $ withRunInIO $ \run ->
    inner (run . runNoLoggingT)
#else
instance MonadUnliftIO m => MonadUnliftIO (NoLoggingT m) where
  askUnliftIO = NoLoggingT $
    withUnliftIO $ \u ->
      pure (UnliftIO (unliftIO u . runNoLoggingT))
#endif

instance MonadIO m => Katip (NoLoggingT m) where
  getLogEnv = liftIO (initLogEnv "NoLoggingT" "no-logging")
  localLogEnv = const id

instance MonadIO m => KatipContext (NoLoggingT m) where
  getKatipContext = pure mempty
  localKatipContext = const id
  getKatipNamespace = pure mempty
  localKatipNamespace = const id

-- | Convenience function for when you have to integrate with a third
-- party API that takes a generic logging function as an argument.
askLoggerIO :: (Applicative m, KatipContext m) => m (Severity -> LogStr -> IO ())
askLoggerIO = do
  ctx <- getKatipContext
  ns <- getKatipNamespace
  logEnv <- getLogEnv
  pure (\sev msg -> runKatipT logEnv $ logF ctx ns sev msg)