{-# OPTIONS_GHC -Wno-overlapping-patterns #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-|
Module      : Yesod.Katip
Description : Wrappers for adding automatic Katip integration to Yesod sites.
Copyright   : (c) Isaac van Bakel, 2020
License     : BSD3
Maintainer  : ivb@vanbakel.io
Stability   : experimental
Portability : POSIX

Katip's structured logging is useful, but adding logging after-the-fact to a
Yesod site which already uses the Yesod-provided logging invocations can be a
lot of work.

This module provides several convenience wrappers for converting existing Yesod
sites into Katip-using versions without needing to modify any handlers.
Instead, the wrapped versions will add in HTTP structures like requests, etc.
automatically, and logs sent to Yesod will be intercepted and also sent to
Katip along with any structure.

These wrappers are configurable - they can be made to redirect logs, duplicate
them (sending both to Katip and the Yesod logger), or even ignore them, as
necessary. See 'KatipConfig' for more detail.

If your site has a 'Yesod' instance, so will the wrapped version - so using it
is as simple as passing the wrapped version along to WAI, or whichever server
you use.

There's also support for using Katip's API for more direct control over your
Katip logs inside Yesod handlers. This is based in 'SiteKatip', which is a
ytl-style site class.
-}
module Yesod.Katip
  ( KatipSite (..)
  , KatipContextSite (..)

  , KatipConfig (..)
  , LoggingApproach (..)
  ) where

import Yesod.Katip.Class

import qualified Katip as K
import Network.Wai (Request)
import Yesod.Core
  ( RenderRoute (..)
  , waiRequest
  , Yesod (..)
  )
import Yesod.Core.Types
import Yesod.Site.Class
import Yesod.Site.Util
import Yesod.Trans.Class as ST
import Yesod.Trans.Class.Reader
import Yesod.Trans.TH

import Control.Monad (guard)
import Control.Monad.Logger as L
  ( Loc
  , LogSource
  , LogLevel (..)
  , LogStr
  , fromLogStr
  )
import Data.Bifunctor (second)
import Data.Default
import Data.Maybe (fromMaybe)

-- | Control how the Katip wrapper directs logs that come from Yesod.
--
-- Regardless of the choice of approach, logs will only be sent when
-- @shouldLogIO@ says they should.
data LoggingApproach
  = YesodOnly
  -- ^ Send these logs only to the Yesod logger configured by the site's Yesod
  -- instance already. This is provided only for debugging convenience - it
  -- doesn't make sense to use it in production.
  | KatipOnly
  -- ^ Send these logs only to the Katip scribes, ignoring the Yesod
  -- logger.
  | Both
  -- ^ Send logs to both the Katip scribes and the Yesod logger. If Katip is
  -- configured to log structure as well, this structure *won't* be sent to the
  -- Yesod logger. This is the default.

-- | Configuration for how 'KatipSite' and 'KatipContextSite' turn Yesod logs
-- into Katip ones
data KatipConfig
  = KatipConfig
      { KatipConfig -> LoggingApproach
loggingApproach :: LoggingApproach
      -- ^ How logs should be sent between the Yesod logger and your Katip scribes.
      -- See 'LoggingApproach' for details.
      , KatipConfig -> LogLevel -> Severity
levelToSeverity :: LogLevel -> K.Severity
      -- ^ How a Yesod level should be translated into a Katip severity.
      , KatipConfig -> LogSource -> Namespace
sourceToNamespace :: LogSource -> K.Namespace
      -- ^ How a Yesod log source should modify the Katip namespace. By default,
      -- it is appended on.
      }

instance Default KatipConfig where
  def :: KatipConfig
def = KatipConfig :: LoggingApproach
-> (LogLevel -> Severity)
-> (LogSource -> Namespace)
-> KatipConfig
KatipConfig
          { loggingApproach :: LoggingApproach
loggingApproach = LoggingApproach
Both 
          , levelToSeverity :: LogLevel -> Severity
levelToSeverity = LogLevel -> Severity
defaultLevelToSeverity
          , sourceToNamespace :: LogSource -> Namespace
sourceToNamespace = [LogSource] -> Namespace
K.Namespace ([LogSource] -> Namespace)
-> (LogSource -> [LogSource]) -> LogSource -> Namespace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogSource -> [LogSource]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          }

defaultLevelToSeverity :: LogLevel -> K.Severity
defaultLevelToSeverity :: LogLevel -> Severity
defaultLevelToSeverity LogLevel
LevelDebug = Severity
K.DebugS
defaultLevelToSeverity LogLevel
LevelInfo = Severity
K.InfoS
defaultLevelToSeverity LogLevel
LevelWarn = Severity
K.WarningS
defaultLevelToSeverity LogLevel
LevelError = Severity
K.ErrorS
defaultLevelToSeverity (LevelOther LogSource
other) = Severity -> Maybe Severity -> Severity
forall a. a -> Maybe a -> a
fromMaybe Severity
K.ErrorS (Maybe Severity -> Severity) -> Maybe Severity -> Severity
forall a b. (a -> b) -> a -> b
$ LogSource -> Maybe Severity
K.textToSeverity LogSource
other

-------------------
--- CONVERSIONS ---
-------------------

-- Bridge between Yesod-style logging and Katip-style

katipLog :: KatipConfig -> K.LogEnv -> Loc -> LogSource -> LogLevel -> L.LogStr -> IO ()
katipLog :: KatipConfig
-> LogEnv -> Loc -> LogSource -> LogLevel -> LogStr -> IO ()
katipLog KatipConfig{LoggingApproach
LogSource -> Namespace
LogLevel -> Severity
sourceToNamespace :: LogSource -> Namespace
levelToSeverity :: LogLevel -> Severity
loggingApproach :: LoggingApproach
sourceToNamespace :: KatipConfig -> LogSource -> Namespace
levelToSeverity :: KatipConfig -> LogLevel -> Severity
loggingApproach :: KatipConfig -> LoggingApproach
..} LogEnv
logEnv Loc
loc LogSource
source LogLevel
level LogStr
str = do
  LogEnv -> KatipT IO () -> IO ()
forall (m :: * -> *) a. LogEnv -> KatipT m a -> m a
K.runKatipT LogEnv
logEnv do
    () -> Namespace -> Maybe Loc -> Severity -> LogStr -> KatipT IO ()
forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
K.logItem () (LogSource -> Namespace
sourceToNamespace LogSource
source) (Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc) (LogLevel -> Severity
levelToSeverity LogLevel
level) (ByteString -> LogStr
forall a. StringConv a LogSource => a -> LogStr
K.logStr (ByteString -> LogStr) -> ByteString -> LogStr
forall a b. (a -> b) -> a -> b
$ LogStr -> ByteString
L.fromLogStr LogStr
str)

katipLogWithContexts
  :: KatipConfig -> K.LogEnv -> K.LogContexts -> K.Namespace
  -> Loc -> LogSource -> LogLevel -> L.LogStr -> IO ()
katipLogWithContexts :: KatipConfig
-> LogEnv
-> LogContexts
-> Namespace
-> Loc
-> LogSource
-> LogLevel
-> LogStr
-> IO ()
katipLogWithContexts KatipConfig{LoggingApproach
LogSource -> Namespace
LogLevel -> Severity
sourceToNamespace :: LogSource -> Namespace
levelToSeverity :: LogLevel -> Severity
loggingApproach :: LoggingApproach
sourceToNamespace :: KatipConfig -> LogSource -> Namespace
levelToSeverity :: KatipConfig -> LogLevel -> Severity
loggingApproach :: KatipConfig -> LoggingApproach
..} LogEnv
logEnv LogContexts
logCtxts Namespace
namespace Loc
loc LogSource
source LogLevel
level LogStr
str = do
  LogEnv -> LogContexts -> Namespace -> KatipContextT IO () -> IO ()
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
K.runKatipContextT LogEnv
logEnv LogContexts
logCtxts Namespace
namespace do
    LogContexts
-> Namespace
-> Maybe Loc
-> Severity
-> LogStr
-> KatipContextT IO ()
forall (m :: * -> *) a.
(Applicative m, LogItem a, Katip m) =>
a -> Namespace -> Maybe Loc -> Severity -> LogStr -> m ()
K.logItem LogContexts
logCtxts (Namespace
namespace Namespace -> Namespace -> Namespace
forall a. Semigroup a => a -> a -> a
<> LogSource -> Namespace
sourceToNamespace LogSource
source) (Loc -> Maybe Loc
forall a. a -> Maybe a
Just Loc
loc)
      (LogLevel -> Severity
levelToSeverity LogLevel
level) (ByteString -> LogStr
forall a. StringConv a LogSource => a -> LogStr
K.logStr (ByteString -> LogStr) -> ByteString -> LogStr
forall a b. (a -> b) -> a -> b
$ LogStr -> ByteString
L.fromLogStr LogStr
str)

---------------
--- LOGGING ---
---------------

-- A Katip wrapper for logging to Katip from Yesod

-- | A wrapper for adding Katip functionality to a site.
--
-- This is the most basic wrapper. It will allow you to redirect logs from
-- Yesod to Katip, as configured.  It will not include HTTP structures in the
-- output - for that, look at 'KatipContextSite' instead.
newtype KatipSite site
  = KatipSite
      { KatipSite site -> ReaderSite (KatipConfig, LogEnv) site
unKatipSite :: ReaderSite (KatipConfig, K.LogEnv) site
      }

instance SiteTrans KatipSite where
  lift :: m site a -> m (KatipSite site) a
lift = (KatipSite site -> ReaderSite (KatipConfig, LogEnv) site)
-> m (ReaderSite (KatipConfig, LogEnv) site) a
-> m (KatipSite site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipSite site -> ReaderSite (KatipConfig, LogEnv) site
forall site.
KatipSite site -> ReaderSite (KatipConfig, LogEnv) site
unKatipSite (m (ReaderSite (KatipConfig, LogEnv) site) a
 -> m (KatipSite site) a)
-> (m site a -> m (ReaderSite (KatipConfig, LogEnv) site) a)
-> m site a
-> m (KatipSite site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m site a -> m (ReaderSite (KatipConfig, LogEnv) site) a
forall (t :: * -> *) (m :: * -> * -> *) site a.
(SiteTrans t, MonadSite m) =>
m site a -> m (t site) a
lift

  mapSiteT :: (m site a -> n site' b)
-> m (KatipSite site) a -> n (KatipSite site') b
mapSiteT m site a -> n site' b
runner = (KatipSite site' -> ReaderSite (KatipConfig, LogEnv) site')
-> n (ReaderSite (KatipConfig, LogEnv) site') b
-> n (KatipSite site') b
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipSite site' -> ReaderSite (KatipConfig, LogEnv) site'
forall site.
KatipSite site -> ReaderSite (KatipConfig, LogEnv) site
unKatipSite (n (ReaderSite (KatipConfig, LogEnv) site') b
 -> n (KatipSite site') b)
-> (m (KatipSite site) a
    -> n (ReaderSite (KatipConfig, LogEnv) site') b)
-> m (KatipSite site) a
-> n (KatipSite site') b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m site a -> n site' b)
-> m (ReaderSite (KatipConfig, LogEnv) site) a
-> n (ReaderSite (KatipConfig, LogEnv) site') b
forall (t :: * -> *) (m :: * -> * -> *) (n :: * -> * -> *) site
       site' a b.
(SiteTrans t, MonadSite m, MonadSite n,
 SiteCompatible site site') =>
(m site a -> n site' b) -> m (t site) a -> n (t site') b
mapSiteT m site a -> n site' b
runner (m (ReaderSite (KatipConfig, LogEnv) site) a
 -> n (ReaderSite (KatipConfig, LogEnv) site') b)
-> (m (KatipSite site) a
    -> m (ReaderSite (KatipConfig, LogEnv) site) a)
-> m (KatipSite site) a
-> n (ReaderSite (KatipConfig, LogEnv) site') b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderSite (KatipConfig, LogEnv) site -> KatipSite site)
-> m (KatipSite site) a
-> m (ReaderSite (KatipConfig, LogEnv) site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite (KatipConfig, LogEnv) site -> KatipSite site
forall site.
ReaderSite (KatipConfig, LogEnv) site -> KatipSite site
KatipSite

instance (RenderRoute site, Eq (Route site)) => RenderRoute (KatipSite site) where
  newtype Route (KatipSite site) = KRoute (Route (ReaderSite (KatipConfig, K.LogEnv) site))
  renderRoute :: Route (KatipSite site) -> ([LogSource], [(LogSource, LogSource)])
renderRoute (KRoute route) = Route (ReaderSite (KatipConfig, LogEnv) site)
-> ([LogSource], [(LogSource, LogSource)])
forall a.
RenderRoute a =>
Route a -> ([LogSource], [(LogSource, LogSource)])
renderRoute Route (ReaderSite (KatipConfig, LogEnv) site)
route

instance SiteKatip (KatipSite site) where
  getLogEnv :: m (KatipSite site) LogEnv
getLogEnv = (KatipSite site -> ReaderSite (KatipConfig, LogEnv) site)
-> m (ReaderSite (KatipConfig, LogEnv) site) LogEnv
-> m (KatipSite site) LogEnv
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipSite site -> ReaderSite (KatipConfig, LogEnv) site
forall site.
KatipSite site -> ReaderSite (KatipConfig, LogEnv) site
unKatipSite (m (ReaderSite (KatipConfig, LogEnv) site) LogEnv
 -> m (KatipSite site) LogEnv)
-> m (ReaderSite (KatipConfig, LogEnv) site) LogEnv
-> m (KatipSite site) LogEnv
forall a b. (a -> b) -> a -> b
$ (KatipConfig, LogEnv) -> LogEnv
forall a b. (a, b) -> b
snd ((KatipConfig, LogEnv) -> LogEnv)
-> m (ReaderSite (KatipConfig, LogEnv) site) (KatipConfig, LogEnv)
-> m (ReaderSite (KatipConfig, LogEnv) site) LogEnv
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (ReaderSite (KatipConfig, LogEnv) site) (KatipConfig, LogEnv)
forall r site (m :: * -> * -> *).
(SiteReader r site, MonadSite m) =>
m site r
ask

  localLogEnv :: (LogEnv -> LogEnv) -> m (KatipSite site) a -> m (KatipSite site) a
localLogEnv LogEnv -> LogEnv
f = (KatipSite site -> ReaderSite (KatipConfig, LogEnv) site)
-> m (ReaderSite (KatipConfig, LogEnv) site) a
-> m (KatipSite site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipSite site -> ReaderSite (KatipConfig, LogEnv) site
forall site.
KatipSite site -> ReaderSite (KatipConfig, LogEnv) site
unKatipSite (m (ReaderSite (KatipConfig, LogEnv) site) a
 -> m (KatipSite site) a)
-> (m (KatipSite site) a
    -> m (ReaderSite (KatipConfig, LogEnv) site) a)
-> m (KatipSite site) a
-> m (KatipSite site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((KatipConfig, LogEnv) -> (KatipConfig, LogEnv))
-> m (ReaderSite (KatipConfig, LogEnv) site) a
-> m (ReaderSite (KatipConfig, LogEnv) site) a
forall r site (m :: * -> * -> *) a.
(SiteReader r site, MonadSite m) =>
(r -> r) -> m site a -> m site a
local (((KatipConfig, LogEnv) -> (KatipConfig, LogEnv))
 -> m (ReaderSite (KatipConfig, LogEnv) site) a
 -> m (ReaderSite (KatipConfig, LogEnv) site) a)
-> ((KatipConfig, LogEnv) -> (KatipConfig, LogEnv))
-> m (ReaderSite (KatipConfig, LogEnv) site) a
-> m (ReaderSite (KatipConfig, LogEnv) site) a
forall a b. (a -> b) -> a -> b
$ (LogEnv -> LogEnv)
-> (KatipConfig, LogEnv) -> (KatipConfig, LogEnv)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second LogEnv -> LogEnv
f) (m (ReaderSite (KatipConfig, LogEnv) site) a
 -> m (ReaderSite (KatipConfig, LogEnv) site) a)
-> (m (KatipSite site) a
    -> m (ReaderSite (KatipConfig, LogEnv) site) a)
-> m (KatipSite site) a
-> m (ReaderSite (KatipConfig, LogEnv) site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderSite (KatipConfig, LogEnv) site -> KatipSite site)
-> m (KatipSite site) a
-> m (ReaderSite (KatipConfig, LogEnv) site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite (KatipConfig, LogEnv) site -> KatipSite site
forall site.
ReaderSite (KatipConfig, LogEnv) site -> KatipSite site
KatipSite

deriving instance Eq (Route site) => Eq (Route (KatipSite site))

defaultYesodInstanceExcept [| unReaderSite . unKatipSite |] [d|
    instance (SiteCompatible site (KatipSite site), Yesod site, Eq (Route site)) => Yesod (KatipSite site) where
      messageLoggerSource (KatipSite (ReaderSite (config, env) site)) logger loc source level str = do
        shouldLog <- shouldLogIO site source level

        let KatipConfig { loggingApproach } = config
            logYesod = messageLoggerSource site logger loc source level str
            logKatip = do
              guard shouldLog
              katipLog config env loc source level str

        case loggingApproach of
          KatipOnly ->
            logKatip

          YesodOnly ->
            logYesod

          Both -> do
            logKatip
            logYesod
  |]

----------------------------
--- LOGGING WITH CONTEXT ---
----------------------------

-- The same thing again, only this one logs the context

-- | A wrapper for adding Katip functionality to a site.
--
-- This is the more featureful wrapper. It can redirect logs, just like
-- 'KatipSite', but will also augment them with useful HTTP structure from
-- Yesod.
data KatipContextSite site
  = KatipContextSite
      { KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
unKatipContextSite :: ReaderSite (KatipConfig, K.LogEnv, K.LogContexts, K.Namespace) site
      }

instance SiteTrans KatipContextSite where
  lift :: m site a -> m (KatipContextSite site) a
lift = (KatipContextSite site
 -> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
-> m (KatipContextSite site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
forall site.
KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
unKatipContextSite (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   a
 -> m (KatipContextSite site) a)
-> (m site a
    -> m (ReaderSite
            (KatipConfig, LogEnv, LogContexts, Namespace) site)
         a)
-> m site a
-> m (KatipContextSite site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m site a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall (t :: * -> *) (m :: * -> * -> *) site a.
(SiteTrans t, MonadSite m) =>
m site a -> m (t site) a
lift

  mapSiteT :: (m site a -> n site' b)
-> m (KatipContextSite site) a -> n (KatipContextSite site') b
mapSiteT m site a -> n site' b
runner = (KatipContextSite site'
 -> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site')
-> n (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site')
     b
-> n (KatipContextSite site') b
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipContextSite site'
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site'
forall site.
KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
unKatipContextSite (n (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site')
   b
 -> n (KatipContextSite site') b)
-> (m (KatipContextSite site) a
    -> n (ReaderSite
            (KatipConfig, LogEnv, LogContexts, Namespace) site')
         b)
-> m (KatipContextSite site) a
-> n (KatipContextSite site') b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (m site a -> n site' b)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
-> n (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site')
     b
forall (t :: * -> *) (m :: * -> * -> *) (n :: * -> * -> *) site
       site' a b.
(SiteTrans t, MonadSite m, MonadSite n,
 SiteCompatible site site') =>
(m site a -> n site' b) -> m (t site) a -> n (t site') b
mapSiteT m site a -> n site' b
runner (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   a
 -> n (ReaderSite
         (KatipConfig, LogEnv, LogContexts, Namespace) site')
      b)
-> (m (KatipContextSite site) a
    -> m (ReaderSite
            (KatipConfig, LogEnv, LogContexts, Namespace) site)
         a)
-> m (KatipContextSite site) a
-> n (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site')
     b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
 -> KatipContextSite site)
-> m (KatipContextSite site) a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
-> KatipContextSite site
forall site.
ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
-> KatipContextSite site
KatipContextSite

instance SiteKatip (KatipContextSite site) where
  getLogEnv :: m (KatipContextSite site) LogEnv
getLogEnv = (KatipContextSite site
 -> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     LogEnv
-> m (KatipContextSite site) LogEnv
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
forall site.
KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
unKatipContextSite (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   LogEnv
 -> m (KatipContextSite site) LogEnv)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     LogEnv
-> m (KatipContextSite site) LogEnv
forall a b. (a -> b) -> a -> b
$ do
    (KatipConfig
_, LogEnv
env, LogContexts
_, Namespace
_) <- m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
  (KatipConfig, LogEnv, LogContexts, Namespace)
forall r site (m :: * -> * -> *).
(SiteReader r site, MonadSite m) =>
m site r
ask
    LogEnv
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     LogEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogEnv
env

  localLogEnv :: (LogEnv -> LogEnv)
-> m (KatipContextSite site) a -> m (KatipContextSite site) a
localLogEnv LogEnv -> LogEnv
f = (KatipContextSite site
 -> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
-> m (KatipContextSite site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
forall site.
KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
unKatipContextSite (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   a
 -> m (KatipContextSite site) a)
-> (m (KatipContextSite site) a
    -> m (ReaderSite
            (KatipConfig, LogEnv, LogContexts, Namespace) site)
         a)
-> m (KatipContextSite site) a
-> m (KatipContextSite site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((KatipConfig, LogEnv, LogContexts, Namespace)
 -> (KatipConfig, LogEnv, LogContexts, Namespace))
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall r site (m :: * -> * -> *) a.
(SiteReader r site, MonadSite m) =>
(r -> r) -> m site a -> m site a
local (\(KatipConfig
a, LogEnv
env, LogContexts
c, Namespace
d) -> (KatipConfig
a, LogEnv -> LogEnv
f LogEnv
env, LogContexts
c, Namespace
d)) (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   a
 -> m (ReaderSite
         (KatipConfig, LogEnv, LogContexts, Namespace) site)
      a)
-> (m (KatipContextSite site) a
    -> m (ReaderSite
            (KatipConfig, LogEnv, LogContexts, Namespace) site)
         a)
-> m (KatipContextSite site) a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
 -> KatipContextSite site)
-> m (KatipContextSite site) a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
-> KatipContextSite site
forall site.
ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
-> KatipContextSite site
KatipContextSite

instance SiteKatipContext (KatipContextSite site) where
  getKatipContext :: m (KatipContextSite site) LogContexts
getKatipContext = (KatipContextSite site
 -> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     LogContexts
-> m (KatipContextSite site) LogContexts
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
forall site.
KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
unKatipContextSite (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   LogContexts
 -> m (KatipContextSite site) LogContexts)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     LogContexts
-> m (KatipContextSite site) LogContexts
forall a b. (a -> b) -> a -> b
$ do
    (KatipConfig
_, LogEnv
_, LogContexts
ctxt, Namespace
_) <- m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
  (KatipConfig, LogEnv, LogContexts, Namespace)
forall r site (m :: * -> * -> *).
(SiteReader r site, MonadSite m) =>
m site r
ask
    LogContexts
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     LogContexts
forall (f :: * -> *) a. Applicative f => a -> f a
pure LogContexts
ctxt

  localKatipContext :: (LogContexts -> LogContexts)
-> m (KatipContextSite site) a -> m (KatipContextSite site) a
localKatipContext LogContexts -> LogContexts
f = (KatipContextSite site
 -> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
-> m (KatipContextSite site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
forall site.
KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
unKatipContextSite (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   a
 -> m (KatipContextSite site) a)
-> (m (KatipContextSite site) a
    -> m (ReaderSite
            (KatipConfig, LogEnv, LogContexts, Namespace) site)
         a)
-> m (KatipContextSite site) a
-> m (KatipContextSite site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((KatipConfig, LogEnv, LogContexts, Namespace)
 -> (KatipConfig, LogEnv, LogContexts, Namespace))
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall r site (m :: * -> * -> *) a.
(SiteReader r site, MonadSite m) =>
(r -> r) -> m site a -> m site a
local (\(KatipConfig
a, LogEnv
b, LogContexts
ctxt, Namespace
d) -> (KatipConfig
a, LogEnv
b, LogContexts -> LogContexts
f LogContexts
ctxt, Namespace
d)) (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   a
 -> m (ReaderSite
         (KatipConfig, LogEnv, LogContexts, Namespace) site)
      a)
-> (m (KatipContextSite site) a
    -> m (ReaderSite
            (KatipConfig, LogEnv, LogContexts, Namespace) site)
         a)
-> m (KatipContextSite site) a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
 -> KatipContextSite site)
-> m (KatipContextSite site) a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
-> KatipContextSite site
forall site.
ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
-> KatipContextSite site
KatipContextSite

  getKatipNamespace :: m (KatipContextSite site) Namespace
getKatipNamespace = (KatipContextSite site
 -> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     Namespace
-> m (KatipContextSite site) Namespace
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
forall site.
KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
unKatipContextSite (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   Namespace
 -> m (KatipContextSite site) Namespace)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     Namespace
-> m (KatipContextSite site) Namespace
forall a b. (a -> b) -> a -> b
$ do
    (KatipConfig
_, LogEnv
_, LogContexts
_, Namespace
ns) <- m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
  (KatipConfig, LogEnv, LogContexts, Namespace)
forall r site (m :: * -> * -> *).
(SiteReader r site, MonadSite m) =>
m site r
ask
    Namespace
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     Namespace
forall (f :: * -> *) a. Applicative f => a -> f a
pure Namespace
ns
  localKatipNamespace :: (Namespace -> Namespace)
-> m (KatipContextSite site) a -> m (KatipContextSite site) a
localKatipNamespace Namespace -> Namespace
f = (KatipContextSite site
 -> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
-> m (KatipContextSite site) a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
forall site.
KatipContextSite site
-> ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
unKatipContextSite (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   a
 -> m (KatipContextSite site) a)
-> (m (KatipContextSite site) a
    -> m (ReaderSite
            (KatipConfig, LogEnv, LogContexts, Namespace) site)
         a)
-> m (KatipContextSite site) a
-> m (KatipContextSite site) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((KatipConfig, LogEnv, LogContexts, Namespace)
 -> (KatipConfig, LogEnv, LogContexts, Namespace))
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall r site (m :: * -> * -> *) a.
(SiteReader r site, MonadSite m) =>
(r -> r) -> m site a -> m site a
local (\(KatipConfig
a, LogEnv
b, LogContexts
c, Namespace
ns) -> (KatipConfig
a, LogEnv
b, LogContexts
c, Namespace -> Namespace
f Namespace
ns)) (m (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
   a
 -> m (ReaderSite
         (KatipConfig, LogEnv, LogContexts, Namespace) site)
      a)
-> (m (KatipContextSite site) a
    -> m (ReaderSite
            (KatipConfig, LogEnv, LogContexts, Namespace) site)
         a)
-> m (KatipContextSite site) a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
 -> KatipContextSite site)
-> m (KatipContextSite site) a
-> m (ReaderSite
        (KatipConfig, LogEnv, LogContexts, Namespace) site)
     a
forall (m :: * -> * -> *) site site' a.
(MonadSite m, SiteCompatible site site') =>
(site -> site') -> m site' a -> m site a
withSiteT ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
-> KatipContextSite site
forall site.
ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site
-> KatipContextSite site
KatipContextSite

instance (RenderRoute site, Eq (Route site)) => RenderRoute (KatipContextSite site) where
  newtype Route (KatipContextSite site) = KCRoute (Route (ReaderSite (KatipConfig, K.LogEnv, K.LogContexts, K.Namespace) site))
  renderRoute :: Route (KatipContextSite site)
-> ([LogSource], [(LogSource, LogSource)])
renderRoute (KCRoute route) = Route
  (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
-> ([LogSource], [(LogSource, LogSource)])
forall a.
RenderRoute a =>
Route a -> ([LogSource], [(LogSource, LogSource)])
renderRoute Route
  (ReaderSite (KatipConfig, LogEnv, LogContexts, Namespace) site)
route

deriving instance Eq (Route site) => Eq (Route (KatipContextSite site))

defaultYesodInstanceExcept [| unReaderSite . unKatipContextSite |] [d|
    instance (K.LogItem Request, SiteCompatible site (KatipContextSite site), Yesod site, Eq (Route site))
      => Yesod (KatipContextSite site) where
      messageLoggerSource (KatipContextSite (ReaderSite (config, env, context, namespace) site)) logger loc source level str = do
        shouldLog <- shouldLogIO site source level

        let KatipConfig { loggingApproach } = config
            logYesod = messageLoggerSource site logger loc source level str
            logKatip = do
              guard shouldLog
              katipLogWithContexts config env context namespace loc source level str

        case loggingApproach of
          KatipOnly ->
            logKatip

          YesodOnly ->
            logYesod

          Both -> do
            logKatip
            logYesod

      yesodMiddleware argM = do
        req <- waiRequest
        K.katipAddContext req $ mapSiteT yesodMiddleware argM
  |]