katip-wai 0.1.2.0 → 0.1.2.1
raw patch · 11 files changed
+213/−79 lines, 11 filesdep ~aesonsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: aeson
API changes (from Hackage documentation)
Files
- CHANGELOG.md +65/−0
- CONTRIBUTING.md +9/−0
- Setup.hs +2/−0
- katip-wai.cabal +16/−4
- src/Katip/Wai.hs +73/−56
- test/DebugApplication.hs +16/−7
- test/DebugScribe.hs +5/−3
- test/Katip/WaiSpec.hs +2/−0
- test/LogEntry.hs +23/−9
- test/Main.hs +1/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,65 @@+# Changelog++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to [Haskell Package Versioning Policy](https://pvp.haskell.org/).+++<!-- Guiding Principles -->+<!-- Changelogs are for humans, not machines. -->+<!-- There should be an entry for every single version. -->+<!-- The same types of changes should be grouped. -->+<!-- Versions and sections should be linkable. -->+<!-- The latest version comes first. -->+<!-- The release date of each version is displayed. -->++<!-- Types of changes -->+<!-- `Added` for new features.-->+<!-- `Changed` for changes in existing functionality. -->+<!-- `Deprecated` for soon-to-be removed features. -->+<!-- `Removed` for now removed features. -->+<!-- `Fixed` for any bug fixes. -->+<!-- `Security` in case of vulnerabilities. -->++## [Unreleased]+++## [0.1.2.1] - 2022-11-12++### Added ++- Added [CHANGELOG.md](./CHANGELOG.md)+- Added [CONTRIBUTING.md](./CONTRIBUTING.md)++### Fixed++- Adjusted version bounds +- Fixed haddock error+++## [0.1.2.0] - 2022-06-04++### Fixed++- Adjusted version bound for text.+++## [0.1.1.0] - 2022-02-02++### Added++- Added `middlewareWithFormatter` and `defaultFormat` so that you may customize the logging format.+++## [0.1.0.0] - 2021-12-29++### Added++- Initial release++[unreleased]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.1.2.1...HEAD+[0.1.2.1]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.1.2.0...releases/0.1.2.1+[0.1.2.0]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.1.1.0...releases/0.1.2.0+[0.1.1.0]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.1.0.0...releases/0.1.1.0+[0.1.0.0]: https://github.com/Disco-Dave/katip-wai/releases/tag/releases%2F0.1.0.0
+ CONTRIBUTING.md view
@@ -0,0 +1,9 @@+# Contributing to katip-wai+I welcome all changes to `katip-wai`.++When making a PR make sure you have done the following:+ - Fixed all warnings and hlint suggestions+ - Added or modified tests if necessary + - Formatted with `fourmulu`+ - Added entries to the unreleased section at the top of [CHANGELOG.md](./CHANGELOG.md)+ - Ran [./scripts/test.sh](./scripts/test.sh) to ensure the project still builds with different compilers
Setup.hs view
@@ -1,2 +1,4 @@ import Distribution.Simple++ main = defaultMain
katip-wai.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: katip-wai-version: 0.1.2.0+version: 0.1.2.1 synopsis: WAI middleware for logging request and response info through katip. description: WAI middleware for logging request and response info through katip. Please see the README on GitHub at <https://github.com/Disco-Dave/katip-wai#readme>@@ -14,13 +14,20 @@ author: David Burkett maintainer: David Burkett -copyright: 2021 David Burkett+copyright: 2022 David Burkett license: BSD-3-Clause license-file: LICENSE extra-source-files:- README.md+ README.md+ CHANGELOG.md+ CONTRIBUTING.md +flag pedantic+ default: False+ description: Enables @-Werror@, which turns warnings into errors.+ manual: True+ common shared default-language: Haskell2010 @@ -36,6 +43,7 @@ -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-deriving-strategies+ -Werror=incomplete-patterns if impl(ghc >= 8.10) ghc-options:@@ -46,8 +54,12 @@ ghc-options: -Wno-missing-kind-signatures + if flag(pedantic)+ ghc-options:+ -Werror+ build-depends:- , aeson >=0.6 && <2.1+ , aeson >=0.6 && <2.2 , base >=4.7 && <5 , bytestring >=0.9 && <0.12 , http-types >=0.12 && <0.13
src/Katip/Wai.hs view
@@ -3,28 +3,28 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StrictData #-} -{- |-Description: Middleware for logging request and response info through Katip.--Add information about 'Wai.Request', 'Wai.response', and the elapsed time to Katip's 'Katip.LogContexts'.--The following is added to the context as \"response\":-- - \"elapsedTimeInNanoSeconds\": Amount of time from receiving the request to sending the response in nano seconds.-- - \"status\": The status of the response, ie. 200, 202, 204, 400, 404, 500, etc.--}-module Katip.Wai (- -- * Middleware- defaultFormat,- middlewareWithFormatter,- middleware,+-- |+--Description: Middleware for logging request and response info through Katip.+--+--Add information about 'Wai.Request', 'Wai.response', and the elapsed time to Katip's 'Katip.LogContexts'.+--+--The following is added to the context as \"response\":+--+-- - \"elapsedTimeInNanoSeconds\": Amount of time from receiving the request to sending the response in nano seconds.+--+-- - \"status\": The status of the response, ie. 200, 202, 204, 400, 404, 500, etc.+module Katip.Wai+ ( -- * Middleware+ defaultFormat+ , middlewareWithFormatter+ , middleware - -- * Helpers for threading Katip's Context throughout the entire 'Wai.Application`- ApplicationT,- MiddlewareT,- runApplication,-) where+ -- * Helpers for threading Katip's Context throughout the entire 'Wai.Application`+ , ApplicationT+ , MiddlewareT+ , runApplication+ )+where import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson ((.=))@@ -46,6 +46,7 @@ import qualified Network.Wai as Wai import qualified System.Clock as Clock + data Request = Request { requestId :: UUID , requestHttpVersion :: HttpVersion@@ -61,6 +62,7 @@ , requestHeaderRange :: Maybe ByteString } + requestToKeyValues :: Aeson.KeyValue kv => Request -> [kv] requestToKeyValues Request{..} = let toText = decodeUtf8With lenientDecode@@ -82,39 +84,40 @@ , "headers" .= headers ] + instance Aeson.ToJSON Request where toJSON = Aeson.object . requestToKeyValues toEncoding = Aeson.pairs . mconcat . requestToKeyValues -{- | Default format for the request. The 'requestId' will be unique every time we- call this function, it's an id to correlate logs generated by the request. - Current format:-- - \"id\": Uniquely generated string that can be used to correlate logs to a single request.-- - \"httpVersion\": Version of the request.-- - \"remoteHost\": Address the request came from.-- - \"isSecure\": True if the request was made over an SSL connection, otherwise false.-- - \"method\": HTTP Method used for the request, ie. GET, POST, PUT, PATCH, DELETE, etc.-- - \"path\": URL without a hostname, port, or querystring.-- - \"queryString\": Query string of the request if one was sent.-- - \"bodyLength\": Size of the body in the request.-- - \"headers.host\": Value of the \"Host\" header.-- - \"headers.referer\": Value of the \"Referer\" header.-- - \"headers.userAgent\": Value of the \"User-Agent\" header.-- - \"headers.range\": Value of the \"Range\" header.--}+-- | Default format for the request. The requestId will be unique every time we+-- call this function, it's an id to correlate logs generated by the request.+--+-- Current format:+--+-- - \"id\": Uniquely generated string that can be used to correlate logs to a single request.+--+-- - \"httpVersion\": Version of the request.+--+-- - \"remoteHost\": Address the request came from.+--+-- - \"isSecure\": True if the request was made over an SSL connection, otherwise false.+--+-- - \"method\": HTTP Method used for the request, ie. GET, POST, PUT, PATCH, DELETE, etc.+--+-- - \"path\": URL without a hostname, port, or querystring.+--+-- - \"queryString\": Query string of the request if one was sent.+--+-- - \"bodyLength\": Size of the body in the request.+--+-- - \"headers.host\": Value of the \"Host\" header.+--+-- - \"headers.referer\": Value of the \"Referer\" header.+--+-- - \"headers.userAgent\": Value of the \"User-Agent\" header.+--+-- - \"headers.range\": Value of the \"Range\" header. defaultFormat :: UUID -> Wai.Request -> Aeson.Value defaultFormat requestId request = Aeson.toJSON $@@ -133,60 +136,74 @@ , requestHeaderRange = Wai.requestHeaderRange request } + data Response = Response { responseElapsedTime :: Clock.TimeSpec , responseStatus :: Status } + responseToKeyValues :: Aeson.KeyValue kv => Response -> [kv] responseToKeyValues Response{..} = [ "elapsedTimeInNanoSeconds" .= Clock.toNanoSecs responseElapsedTime , "status" .= fromEnum responseStatus ] + instance Aeson.ToJSON Response where toJSON = Aeson.object . responseToKeyValues toEncoding = Aeson.pairs . mconcat . responseToKeyValues + -- | Just like 'Wai.Application' except it runs in @m@ instead of 'IO' type ApplicationT m = Wai.Request -> (Wai.Response -> m Wai.ResponseReceived) -> m Wai.ResponseReceived + -- | Converts an 'ApplicationT' to a normal 'Wai.Application' runApplication :: MonadIO m => (forall a. m a -> IO a) -> ApplicationT m -> Wai.Application runApplication toIO application request send = toIO $ application request (liftIO . send) + -- | Just like 'Wai.Middleware' except it runs in @m@ instead of 'IO' type MiddlewareT m = ApplicationT m -> ApplicationT m -withLoggedResponse ::- Katip.KatipContext m =>- Katip.Severity ->- Clock.TimeSpec ->- (Wai.Response -> m Wai.ResponseReceived) ->- Wai.Response ->- m Wai.ResponseReceived++withLoggedResponse+ :: Katip.KatipContext m+ => Katip.Severity+ -> Clock.TimeSpec+ -> (Wai.Response -> m Wai.ResponseReceived)+ -> Wai.Response+ -> m Wai.ResponseReceived withLoggedResponse severity start send response = do responseReceived <- send response+ end <- liftIO $ Clock.getTime Clock.Monotonic+ let loggableResponse = Response { responseElapsedTime = end `Clock.diffTimeSpec` start , responseStatus = Wai.responseStatus response }+ Katip.katipAddContext (Katip.sl "response" loggableResponse) $ do Katip.logFM severity "Response sent" pure responseReceived + -- | Logs the request using the provided format, response, and elapsed time in Katip's context middlewareWithFormatter :: Katip.KatipContext m => (UUID -> Wai.Request -> Aeson.Value) -> Katip.Severity -> MiddlewareT m middlewareWithFormatter format severity application request send = do start <- liftIO $ Clock.getTime Clock.Monotonic requestId <- liftIO UUID.V4.nextRandom+ let jsonRequest = format requestId request+ Katip.katipAddContext (Katip.sl "request" jsonRequest) $ do Katip.logFM severity "Request received" application request (withLoggedResponse severity start send)+ -- | Logs the request, response, and elapsed time in Katip's context middleware :: Katip.KatipContext m => Katip.Severity -> MiddlewareT m
test/DebugApplication.hs view
@@ -1,12 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} -module DebugApplication (- DebugApplication,- sendNoContentRequest,- sendLogRequest,- sendNotFoundRequest,- withDebugApplication,-) where+module DebugApplication+ ( DebugApplication+ , sendNoContentRequest+ , sendLogRequest+ , sendNotFoundRequest+ , withDebugApplication+ )+where import Control.Exception (bracket) import Control.Monad (join)@@ -29,11 +30,14 @@ import qualified Network.Wai.Handler.Warp as Warp import Test.Hspec (shouldBe) + newtype DebugApplication = DebugApplication Warp.Port + toUrl :: DebugApplication -> String toUrl (DebugApplication port) = "http://localhost:" <> show port + sendLogRequest :: Http.Manager -> DebugApplication -> Method -> Text -> IO () sendLogRequest manager app method message = do baseRequest <- Http.parseRequest $ toUrl app <> "/log"@@ -54,6 +58,7 @@ body = decodeUtf8With lenientDecode bytes in body `shouldBe` message + sendNoContentRequest :: Http.Manager -> DebugApplication -> Method -> IO () sendNoContentRequest manager app method = do baseRequest <- Http.parseRequest $ toUrl app@@ -67,6 +72,7 @@ let status = Http.responseStatus response status `shouldBe` Status.status204 + sendNotFoundRequest :: Http.Manager -> DebugApplication -> Method -> IO () sendNotFoundRequest manager app method = do baseRequest <- Http.parseRequest $ toUrl app <> "/not-found"@@ -80,6 +86,7 @@ let status = Http.responseStatus response status `shouldBe` Status.status404 + mkApplication :: Katip.Severity -> ApplicationT (KatipContextT IO) mkApplication severity = let base request send =@@ -102,6 +109,7 @@ send $ Wai.responseLBS (toEnum 404) [] mempty in Katip.Wai.middleware severity base + withLogEnv :: (Katip.LogEnv -> IO a) -> IO [Aeson.Value] withLogEnv useLogEnv = do withDebugScribe (Katip.permitItem minBound) Katip.V3 $ \scribe ->@@ -109,6 +117,7 @@ Katip.initLogEnv "debug-app" "local-test" >>= Katip.registerScribe "debug" scribe Katip.defaultScribeSettings in bracket makeLogEnv Katip.closeScribes useLogEnv+ withDebugApplication :: Katip.Severity -> (DebugApplication -> IO a) -> IO [Aeson.Value] withDebugApplication severity useApp =
test/DebugScribe.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE RankNTypes #-} -module DebugScribe (- withDebugScribe,-) where+module DebugScribe+ ( withDebugScribe+ )+where import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.MVar as MVar@@ -10,6 +11,7 @@ import Control.Monad (void) import qualified Data.Aeson as Aeson import qualified Katip+ withDebugScribe :: Katip.PermitFunc -> Katip.Verbosity -> (Katip.Scribe -> IO a) -> IO [Aeson.Value] withDebugScribe permitFunc verbosity useScribe = do
test/Katip/WaiSpec.hs view
@@ -17,8 +17,10 @@ import qualified Network.HTTP.Client as Http import Test.Hspec (Spec, describe, it, runIO, shouldBe, shouldSatisfy) + allSeverities :: [Katip.Severity] allSeverities = [minBound ..]+ spec :: Spec spec = describe "middleware" $ do
test/LogEntry.hs view
@@ -1,15 +1,16 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} -module LogEntry (- Headers (..),- Request (..),- Response (..),- LogData (..),- LogEntry (..),- toLogEntry,- isMostlySameAs,-) where+module LogEntry+ ( Headers (..)+ , Request (..)+ , Response (..)+ , LogData (..)+ , LogEntry (..)+ , toLogEntry+ , isMostlySameAs+ )+where import Data.Aeson ((.:)) import qualified Data.Aeson as Aeson@@ -20,6 +21,7 @@ import GHC.Natural (Natural) import qualified Katip + data Headers = Headers { host :: Maybe Text , referer :: Maybe Text@@ -28,8 +30,10 @@ } deriving (Show, Generic, Eq) + instance Aeson.FromJSON Headers + data Request = Request { id :: UUID , httpVersion :: Text@@ -43,24 +47,30 @@ } deriving (Show, Generic) + instance Aeson.FromJSON Request + data Response = Response { elapsedTimeInNanoSeconds :: Natural , status :: Int } deriving (Show, Generic) + instance Aeson.FromJSON Response + data LogData = LogData { request :: Maybe Request , response :: Maybe Response } deriving (Generic, Show) + instance Aeson.FromJSON LogData + data LogEntry = LogEntry { logMessage :: Text , logData :: LogData@@ -68,16 +78,19 @@ } deriving (Show) + instance Aeson.FromJSON LogEntry where parseJSON = Aeson.withObject "LogEntry" $ \obj -> LogEntry <$> (obj .: "msg") <*> (obj .: "data") <*> (obj .: "sev") + toLogEntry :: Aeson.Value -> IO LogEntry toLogEntry value = case Aeson.fromJSON value of Aeson.Success entry -> pure entry Aeson.Error reason -> fail reason + isMostlySameAs :: LogEntry -> LogEntry -> Bool isMostlySameAs log1 log2 = let compareResponse =@@ -97,6 +110,7 @@ in on (==) logMessage log1 log2 && on compareRequest (request . logData) log1 log2 && on compareResponse (response . logData) log1 log2+ instance Eq LogEntry where (==) = isMostlySameAs
test/Main.hs view
@@ -3,5 +3,6 @@ import qualified Spec import Test.Hspec (hspec, parallel) + main :: IO () main = hspec $ parallel Spec.spec
test/Spec.hs view
@@ -1,1 +1,2 @@ {-# OPTIONS_GHC -Wno-missing-export-lists -F -pgmF hspec-discover -optF --module-name=Spec #-}+