diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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/). + + + + + + + + + + + + + + + + + + +## [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 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,4 @@ import Distribution.Simple + + main = defaultMain diff --git a/katip-wai.cabal b/katip-wai.cabal --- a/katip-wai.cabal +++ b/katip-wai.cabal @@ -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 @@ -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 diff --git a/src/Katip/Wai.hs b/src/Katip/Wai.hs --- a/src/Katip/Wai.hs +++ b/src/Katip/Wai.hs @@ -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 diff --git a/test/DebugApplication.hs b/test/DebugApplication.hs --- a/test/DebugApplication.hs +++ b/test/DebugApplication.hs @@ -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 = diff --git a/test/DebugScribe.hs b/test/DebugScribe.hs --- a/test/DebugScribe.hs +++ b/test/DebugScribe.hs @@ -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 diff --git a/test/Katip/WaiSpec.hs b/test/Katip/WaiSpec.hs --- a/test/Katip/WaiSpec.hs +++ b/test/Katip/WaiSpec.hs @@ -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 diff --git a/test/LogEntry.hs b/test/LogEntry.hs --- a/test/LogEntry.hs +++ b/test/LogEntry.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -3,5 +3,6 @@ import qualified Spec import Test.Hspec (hspec, parallel) + main :: IO () main = hspec $ parallel Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,1 +1,2 @@ {-# OPTIONS_GHC -Wno-missing-export-lists -F -pgmF hspec-discover -optF --module-name=Spec #-} +