yesod-katip (empty) → 0.1.0.0
raw patch · 6 files changed
+539/−0 lines, 6 filesdep +aesondep +basedep +case-insensitive
Dependencies added: aeson, base, case-insensitive, data-default, http-types, iproute, katip, monad-logger, network, text, wai, wai-extra, yesod-core, ytl
Files
- LICENSE +30/−0
- README.md +5/−0
- src/Yesod/Katip.hs +277/−0
- src/Yesod/Katip/Class.hs +70/−0
- src/Yesod/Katip/Orphans.hs +102/−0
- yesod-katip.cabal +55/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Isaac van Bakel (c) 2020++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac van Bakel nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# yesod-katip - Use Katip in your Yesod site++`yesod-katip` is a utility library for easily adding [`katip`](https://hackage.haskell.org/package/katip) operability to your [`yesod`](https://hackage.haskell.org/package/yesod) site. It provides class instances for logging to Katip scribes directly from a Yesod `HandlerFor`; as well as utility wrappers for augmenting a Yesod site with useful Katip behaviours, like pulling in HTTP context automatically, and making the Yesod logger output to Katip.++For more information, have a look at the module documentation.
+ src/Yesod/Katip.hs view
@@ -0,0 +1,277 @@+{-# 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+ { loggingApproach :: LoggingApproach+ -- ^ How logs should be sent between the Yesod logger and your Katip scribes.+ -- See 'LoggingApproach' for details.+ , levelToSeverity :: LogLevel -> K.Severity+ -- ^ How a Yesod level should be translated into a Katip severity.+ , 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+ { loggingApproach = Both + , levelToSeverity = defaultLevelToSeverity+ , sourceToNamespace = K.Namespace . pure+ }++defaultLevelToSeverity :: LogLevel -> K.Severity+defaultLevelToSeverity LevelDebug = K.DebugS+defaultLevelToSeverity LevelInfo = K.InfoS+defaultLevelToSeverity LevelWarn = K.WarningS+defaultLevelToSeverity LevelError = K.ErrorS+defaultLevelToSeverity (LevelOther other) = fromMaybe K.ErrorS $ K.textToSeverity other++-------------------+--- CONVERSIONS ---+-------------------++-- Bridge between Yesod-style logging and Katip-style++katipLog :: KatipConfig -> K.LogEnv -> Loc -> LogSource -> LogLevel -> L.LogStr -> IO ()+katipLog KatipConfig{..} logEnv loc source level str = do+ K.runKatipT logEnv do+ K.logItem () (sourceToNamespace source) (Just loc) (levelToSeverity level) (K.logStr $ L.fromLogStr str)++katipLogWithContexts+ :: KatipConfig -> K.LogEnv -> K.LogContexts -> K.Namespace+ -> Loc -> LogSource -> LogLevel -> L.LogStr -> IO ()+katipLogWithContexts KatipConfig{..} logEnv logCtxts namespace loc source level str = do+ K.runKatipContextT logEnv logCtxts namespace do+ K.logItem logCtxts (namespace <> sourceToNamespace source) (Just loc)+ (levelToSeverity level) (K.logStr $ L.fromLogStr 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+ { unKatipSite :: ReaderSite (KatipConfig, K.LogEnv) site+ }++instance SiteTrans KatipSite where+ lift = withSiteT unKatipSite . lift++ mapSiteT runner = withSiteT unKatipSite . mapSiteT runner . withSiteT KatipSite++instance (RenderRoute site, Eq (Route site)) => RenderRoute (KatipSite site) where+ newtype Route (KatipSite site) = KRoute (Route (ReaderSite (KatipConfig, K.LogEnv) site))+ renderRoute (KRoute route) = renderRoute route++instance SiteKatip (KatipSite site) where+ getLogEnv = withSiteT unKatipSite $ snd <$> ask++ localLogEnv f = withSiteT unKatipSite . (local $ second f) . withSiteT 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+ { unKatipContextSite :: ReaderSite (KatipConfig, K.LogEnv, K.LogContexts, K.Namespace) site+ }++instance SiteTrans KatipContextSite where+ lift = withSiteT unKatipContextSite . lift++ mapSiteT runner = withSiteT unKatipContextSite . mapSiteT runner . withSiteT KatipContextSite++instance SiteKatip (KatipContextSite site) where+ getLogEnv = withSiteT unKatipContextSite $ do+ (_, env, _, _) <- ask+ pure env++ localLogEnv f = withSiteT unKatipContextSite . local (\(a, env, c, d) -> (a, f env, c, d)) . withSiteT KatipContextSite++instance SiteKatipContext (KatipContextSite site) where+ getKatipContext = withSiteT unKatipContextSite $ do+ (_, _, ctxt, _) <- ask+ pure ctxt++ localKatipContext f = withSiteT unKatipContextSite . local (\(a, b, ctxt, d) -> (a, b, f ctxt, d)) . withSiteT KatipContextSite++ getKatipNamespace = withSiteT unKatipContextSite $ do+ (_, _, _, ns) <- ask+ pure ns+ localKatipNamespace f = withSiteT unKatipContextSite . local (\(a, b, c, ns) -> (a, b, c, f ns)) . withSiteT 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 (KCRoute route) = renderRoute 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+ |]+
+ src/Yesod/Katip/Class.hs view
@@ -0,0 +1,70 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{-|+Module : Yesod.Katip.Class+Description : Class and instances for Katip logging in Yesod handlers+Copyright : (c) Isaac van Bakel, 2020+License : BSD3+Maintainer : ivb@vanbakel.io+Stability : experimental+Portability : POSIX++This module defines the classes associated with the site transformers @KatipSite@+and @KatipContextSite@.++It also includes instances for 'Katip' and 'KatipContext' (the Katip classes)+which let you invoke the Katip logging APIs in your handlers, provided the site+itself satisfies the 'SiteKatip' or 'SiteKatipContext' class respectively.++By default, you won't need to use any of these APIs directly. While the classes+defined here have APIs identical to their Katip counterparts, it's always better+to rely on the Katip APIs.+-}++module Yesod.Katip.Class+ ( SiteKatip (..)+ , SiteKatipContext (..)+ ) where++import qualified Katip as K+import Yesod.Site.Class+import Yesod.Trans.Class++-- | A class for sites which provide a 'Katip'-equivalent API+class SiteKatip site where+ getLogEnv :: (MonadSite m) => m site K.LogEnv+ localLogEnv :: (MonadSite m) => (K.LogEnv -> K.LogEnv) -> m site a -> m site a++-- | A class for sites which provide a 'KatipContext'-equivalent API+class SiteKatip site => SiteKatipContext site where+ getKatipContext :: (MonadSite m) => m site K.LogContexts+ localKatipContext :: (MonadSite m) => (K.LogContexts -> K.LogContexts) -> m site a -> m site a++ getKatipNamespace :: (MonadSite m) => m site K.Namespace+ localKatipNamespace :: (MonadSite m) => (K.Namespace -> K.Namespace) -> m site a -> m site a++instance {-# OVERLAPPABLE #-}+ (SiteTrans t, SiteKatip site) => SiteKatip (t site) where+ getLogEnv = lift getLogEnv+ localLogEnv = mapSiteT . localLogEnv++instance {-# OVERLAPPABLE #-}+ (SiteTrans t, SiteKatipContext site) => SiteKatipContext (t site) where+ getKatipContext = lift getKatipContext+ localKatipContext = mapSiteT . localKatipContext+ + getKatipNamespace = lift getKatipNamespace+ localKatipNamespace = mapSiteT . localKatipNamespace++instance (MonadSite m, SiteKatip site) => K.Katip (m site) where+ getLogEnv = getLogEnv+ localLogEnv = localLogEnv++instance (MonadSite m, SiteKatipContext site) => K.KatipContext (m site) where+ getKatipContext = getKatipContext+ localKatipContext = localKatipContext++ getKatipNamespace = getKatipNamespace+ localKatipNamespace = localKatipNamespace
+ src/Yesod/Katip/Orphans.hs view
@@ -0,0 +1,102 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++{-|+Module : Yesod.Katip.Orphans+Description : Orphan instances for logging HTTP structures in Katip contexts+Copyright : (c) Isaac van Bakel, 2020+License : BSD3+Maintainer : ivb@vanbakel.io+Stability : experimental+Portability : POSIX++If you configure your Yesod site to log HTTP structures to Yesod, you will need+instances of 'ToObject' and 'LogItem' for the structures you want to log.++By default, @KatipContextSite@ will add the WAI request to the context - which+is why its @Yesod@ instance requires those classes on the 'Request' type. This+module contains simple implementations for those classes on 'Request', to help+set up a quick and easy use of @KatipContextSite@.+-}++module Yesod.Katip.Orphans () where++import Data.Aeson+import Katip (LogItem (..), PayloadSelection (..), ToObject (..), Verbosity (..))+import Network.Wai++#if MIN_VERSION_wai_extra(3, 1, 4)+import Network.Wai.Middleware.RequestLogger.JSON (requestToJSON)+#else+-- Because the exposure of this particular API in Wai is relatively recent+-- (December 2020), this polyfills the implementation+import Data.CaseInsensitive (original)+import Data.IP (fromHostAddress, fromIPv4)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Network.HTTP.Types+import Network.Socket (SockAddr (..))++requestToJSON :: Request -> [String] -> Maybe () -> Value+requestToJSON req body _duration+ = object+ [ "method" .= decodeUtf8With lenientDecode (requestMethod req)+ , "path" .= decodeUtf8With lenientDecode (rawPathInfo req)+ , "queryString" .= map queryItemToJSON (queryString req)+ , "size" .= requestBodyLengthToJSON (requestBodyLength req)+ , "body" .= concat body+ , "remoteHost" .= sockToJSON (remoteHost req)+ , "httpVersion" .= httpVersionToJSON (httpVersion req)+ , "headers" .= requestHeadersToJSON (requestHeaders req)+ ]+ where+ requestHeadersToJSON = toJSON . map hToJ where+ -- Redact cookies+ hToJ ("Cookie", _) = toJSON ("Cookie" :: T.Text, "-RDCT-" :: T.Text)+ hToJ hd = headerToJSON hd++ queryItemToJSON (name, mValue) = toJSON (decodeUtf8With lenientDecode name, fmap (decodeUtf8With lenientDecode) mValue)++ requestBodyLengthToJSON ChunkedBody = String "Unknown"+ requestBodyLengthToJSON (KnownLength l) = toJSON l++ sockToJSON (SockAddrInet pn ha) =+ object+ [ "port" .= portToJSON pn+ , "hostAddress" .= word32ToHostAddress ha+ ]+ sockToJSON (SockAddrInet6 pn _ ha _) =+ object+ [ "port" .= portToJSON pn+ , "hostAddress" .= ha+ ]+ sockToJSON (SockAddrUnix sock) =+ object [ "unix" .= sock ]+#if !MIN_VERSION_network(3, 0, 0)+ sockToJSON (SockAddrCan i) =+ object [ "can" .= i ]+#endif++ headerToJSON (headerName, header) = toJSON (decodeUtf8With lenientDecode . original $ headerName, decodeUtf8With lenientDecode header)++ word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress++ portToJSON = toJSON . toInteger++ httpVersionToJSON (HttpVersion major minor) = String $ T.pack (show major) <> "." <> T.pack (show minor)+#endif++instance ToObject Request where+ toObject req+ = case requestToJSON req ["<omitted by default>"] Nothing of+ Object obj -> obj+ _ -> error "`requestToJSON` produced a JSON representation for `Request` that wasn't an object!"++instance LogItem Request where+ payloadKeys verbosity _req = case verbosity of+ V0 -> SomeKeys ["method", "path", "queryString", "remotehost"]+ V1 -> SomeKeys ["size", "body"]+ V2 -> SomeKeys ["headers", "httpVersion"]+ V3 -> AllKeys
+ yesod-katip.cabal view
@@ -0,0 +1,55 @@+cabal-version: 2.0+name: yesod-katip+version: 0.1.0.0+synopsis: Logging bridge between Yesod and Katip+description: A library of ytl-style site transformers for adding Katip+ logging functionality to Yesod monads, as well as capturing+ and redirectly Yesod-style logging to Katip scribes.+ .+ This package supports two workflows:+ .+ * Taking an existing Yesod website and making its logs also+ go to Katip, without changing any of the handlers, by+ wrapping the foundation site in a site transformer.+ .+ * Using the Katip logging API inside Yesod handlers and+ widgets through constraints on the foundation site. In+ this workflow, the site transformers are an easy way to+ give an existing foundation site Katip functionality and+ sensible default behaviours.+homepage: https://github.com/ivanbakel/yesod-katip#readme+license: BSD3+license-file: LICENSE+author: Isaac van Bakel+maintainer: ivb@vanbakel.io+copyright: 2020 Isaac van Bakel+category: Logging,Web+build-type: Simple+extra-source-files: README.md++library+ hs-source-dirs: src+ exposed-modules: Yesod.Katip+ , Yesod.Katip.Class+ , Yesod.Katip.Orphans+ build-depends: base >= 4.7 && < 5+ , aeson >= 1 && < 2+ , data-default ^>= 0.7+ , katip ^>= 0.8+ , monad-logger ^>= 0.3+ , wai >= 3 && < 4+ , wai-extra >= 3 && < 4+ , yesod-core ^>= 1.6+ , ytl ^>= 0.1+ -- Required only by a polyfill, so whatever version gets+ -- pulled in by the user's build system is probably fine+ , case-insensitive+ , http-types+ , iproute+ , network+ , text+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/ivanbakel/yesod-katip