diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,8 +22,26 @@ -## [Unreleased] + +## [0.2.0.0] - 2024-09-11 + +### Added + +- Added a `Request` type that contains all the info about a request including its trace id. +- Added a `Response` type that contains info about a response, including how long it took the server to respond. +- `traceRequest` to convert from a `Network.Wai.Request` to a `Request`. +- `traceResponse` to convert from a `Network.Wai.Response` to a `Response`. +- Added the `Options` type, which provides more flexibility to customize how the request and response are handled. +- Added more formatting options for both the request and response. +- Added `middlewareCustom` for full customization. + +### Changed +- The default formats used by `middleware` have been changed. See `defaultRequestFormat` and `defaultResponseFormat` for the new formats. + +### Removed +- `middlewareWithFormatter` has been removed. Please use `middlewareCustom` instead. + ## [0.1.2.4] - 2024-05-16 ### Fixed @@ -78,7 +96,8 @@ - Initial release -[unreleased]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.1.2.4...HEAD +[unreleased]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.2.0.0...HEAD +[0.2.0.0]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.1.2.4...releases/0.2.0.0 [0.1.2.4]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.1.2.3...releases/0.1.2.4 [0.1.2.3]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.1.2.2...releases/0.1.2.3 [0.1.2.2]: https://github.com/Disco-Dave/katip-wai/compare/releases/0.1.2.1...releases/0.1.2.2 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,51 +2,50 @@ [Middleware](https://hackage.haskell.org/package/wai-3.2.3/docs/Network-Wai.html#t:Middleware) for logging http request and response information through [Katip](https://hackage.haskell.org/package/katip). +You can find the full documentation on [Hackage](https://hackage.haskell.org/package/katip-wai/docs/Katip-Wai.html). + ## Example using Servant ([./example](./example)) ```haskell -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Main (main) where - import Control.Exception (bracket) -import Control.Monad.IO.Unlift (MonadUnliftIO (withRunInIO)) import Data.Proxy (Proxy (Proxy)) -import qualified Katip +import Katip qualified import Katip.Wai (ApplicationT, runApplication) -import qualified Katip.Wai -import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp -import qualified Servant +import Katip.Wai qualified +import Network.Wai.Handler.Warp qualified as Warp +import Servant qualified import System.IO (stdout) +import UnliftIO (MonadUnliftIO (withRunInIO)) + type Api = Servant.GetNoContent + server :: Servant.ServerT Api (Katip.KatipContextT Servant.Handler) server = do Katip.logLocM Katip.InfoS "This message should also have the request context" pure Servant.NoContent + mkApplication :: ApplicationT (Katip.KatipContextT IO) -mkApplication = Katip.Wai.middleware Katip.InfoS $ \request send -> do +mkApplication = Katip.Wai.middleware Katip.InfoS $ request send -> do logEnv <- Katip.getLogEnv context <- Katip.getKatipContext namespace <- Katip.getKatipNamespace let hoistedApp = let proxy = Proxy @Api - toHandler = Katip.runKatipContextT logEnv context namespace - hoistedServer = Servant.hoistServer proxy toHandler server + hoistedServer = Servant.hoistServer proxy (Katip.runKatipContextT logEnv context namespace) server in Servant.serve proxy hoistedServer - withRunInIO $ \toIO -> hoistedApp request (toIO . send) + withRunInIO $ toIO -> hoistedApp request (toIO . send) + withLogEnv :: (Katip.LogEnv -> IO a) -> IO a withLogEnv useLogEnv = do handleScribe <- Katip.mkHandleScribeWithFormatter - Katip.bracketFormat - (Katip.ColorLog True) + Katip.jsonFormat + (Katip.ColorLog False) stdout (Katip.permitItem minBound) Katip.V3 @@ -57,18 +56,18 @@ bracket makeLogEnv Katip.closeScribes useLogEnv + main :: IO () -main = withLogEnv $ \logEnv -> - let toIO = Katip.runKatipContextT logEnv () "main" - app = runApplication toIO mkApplication - in Warp.run 5555 app +main = withLogEnv $ logEnv -> + let + app = runApplication (Katip.runKatipContextT logEnv () "main") mkApplication + in + Warp.run 5555 app ``` ## Example output ``` -[2021-12-22 19:16:17][example-app.main][Info][compe][PID 559366][ThreadId 23][request.bodyLength:KnownLength 0][request.path:][request.remoteHost:127.0.0.1:40500][request.headers.range:null][request.headers.userAgent:curl/7.80.0][request.headers.host:localhost:5555][request.headers.referer:null][request.method:GET][request.Version:HTTP/1.1][request.isSecure:False][request.id:0d5e7c47-816f-402b-914a-9d6923b99508] Request received -[2021-12-22 19:16:17][example-app.main][Info][compe][PID 559366][ThreadId 23][request.bodyLength:KnownLength 0][request.path:][request.remoteHost:127.0.0.1:40500][request.headers.range:null][request.headers.userAgent:curl/7.80.0][request.headers.host:localhost:5555][request.headers.referer:null][request.method:GET][request.Version:HTTP/1.1][request.isSecure:False][request.id:0d5e7c47-816f-402b-914a-9d6923b99508][main:Main Main.hs:21:3] This message should also have the request context -[2021-12-22 19:16:17][example-app.main][Info][compe][PID 559366][ThreadId 23][response.status:204][response.elapsedTimeInNanoSeconds:205439][request.bodyLength:KnownLength 0][request.path:][request.remoteHost:127.0.0.1:40500][request.headers.range:null][request.headers.userAgent:curl/7.80.0][request.headers.host:localhost:5555][request.headers.referer:null][request.method:GET][request.Version:HTTP/1.1][request.isSecure:False][request.id:0d5e7c47-816f-402b-914a-9d6923b99508] Response sent -[2021-12-22 19:17:22][example-app.main][Info][compe][PID 560230][ThreadId 23][request.bodyLength:KnownLength 0][request.path:some/path][request.remoteHost:127.0.0.1:40502][request.headers.range:null][request.headers.userAgent:curl/7.80.0][request.headers.host:localhost:5555][request.headers.referer:null][request.method:GET][request.Version:HTTP/1.1][request.isSecure:False][request.id:b30f962e-32ff-4c05-9c5f-b60f487ea886] Request received -[2021-12-22 19:17:22][example-app.main][Info][compe][PID 560230][ThreadId 23][response.status:404][response.elapsedTimeInNanoSeconds:280937][request.bodyLength:KnownLength 0][request.path:some/path][request.remoteHost:127.0.0.1:40502][request.headers.range:null][request.headers.userAgent:curl/7.80.0][request.headers.host:localhost:5555][request.headers.referer:null][request.method:GET][request.Version:HTTP/1.1][request.isSecure:False][request.id:b30f962e-32ff-4c05-9c5f-b60f487ea886] Response sent +{"app":["example-app"],"at":"2024-09-07T18:44:10.411097829Z","data":{"request":{"headers":{Host:"localhost:5555","User-Agent":"curl8.9.1"},"httpVersion":"HTTP1.1","id":"7ec0fbc4-722c-4c70-a168-c2abe5c7b4fa","isSecure":false,"method":GET,"path":"/","queryString":[],"receivedAt":"2024-09-07T18:44:10.411057334Z","remoteHost":"127.0.0.1:51230"}},"env":"local-dev","host":"x1g11","loc":null,"msg":"Request received.","ns":["example-app","main"],"pid":"106249","sev":Info,"thread":"27"} +{"app":["example-app"],"at":"2024-09-07T18:44:10.411097829Z","data":{"request":{"headers":{Host:"localhost:5555","User-Agent":"curl8.9.1"},"httpVersion":"HTTP1.1","id":"7ec0fbc4-722c-4c70-a168-c2abe5c7b4fa","isSecure":false,"method":GET,"path":"","queryString":[],"receivedAt":"2024-09-07T18:44:10.411057334Z","remoteHost":"127.0.0.1:51230"}},"env":"local-dev","host":"x1g11","loc":{"loc_col":3,"loc_fn":"srcKatipWaiExample/Short.hs","loc_ln":19,"loc_mod":Katip.Wai.Example.Short,"loc_pkg":"my-katip-wai-example-0.1.0.0-inplace"},"msg":"This message should also have the request context","ns":["example-app","main"],"pid":"106249","sev":Info,"thread":"27"} +{"app":["example-app"],"at":"2024-09-07T18:44:10.411097829Z","data":{"request":{"headers":{Host:"localhost:5555","User-Agent":"curl8.9.1"},"httpVersion":"HTTP1.1","id":"7ec0fbc4-722c-4c70-a168-c2abe5c7b4fa","isSecure":false,"method":GET,"path":"/","queryString":[],"receivedAt":"2024-09-07T18:44:10.411057334Z","remoteHost":"127.0.0.1:51230"},"response":{"headers":{},"respondedAt":"2024-09-07T18:44:10.411199014Z","responseTime":{"time":0.137369,"unit":"ms"},"status":{"code":204,"message":"No Content"}}},"env":"local-dev","host":"x1g11","loc":null,"msg":"Response sent.","ns":["example-app","main"],"pid":"106249","sev":Info,"thread":"27"} ``` diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,4 +0,0 @@ -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.4 +version: 0.2.0.0 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 @@ -23,14 +23,27 @@ CHANGELOG.md CONTRIBUTING.md + flag pedantic default: False description: Enables @-Werror@, which turns warnings into errors. manual: True + common shared default-language: Haskell2010 + default-extensions: + DeriveGeneric + FlexibleContexts + GeneralizedNewtypeDeriving + NamedFieldPuns + NumericUnderscores + OverloadedStrings + RankNTypes + RecordWildCards + StrictData + ghc-options: -Weverything -Wno-implicit-prelude @@ -54,20 +67,18 @@ ghc-options: -Wno-missing-kind-signatures + if impl(ghc >= 9.8) + ghc-options: + -Wno-missing-role-annotations + if flag(pedantic) ghc-options: -Werror build-depends: - , aeson >=0.6 && <2.3 , base >=4.7 && <5 - , bytestring >=0.9 && <0.13 - , http-types >=0.12 && <0.13 - , katip >=0.8 && <0.9 - , text >=0.11 && <2.2 - , uuid >=1.3 && <1.4 - , wai >=3.0 && <3.3 + library import: shared @@ -75,11 +86,26 @@ exposed-modules: Katip.Wai + Katip.Wai.Middleware + Katip.Wai.Options + Katip.Wai.Request + Katip.Wai.Response build-depends: + , aeson >=0.6 && <2.3 + , bytestring >=0.9 && <0.13 + , case-insensitive >=1.2.1 && <1.3 , clock >=0.8 && <0.9 + , containers >=0.6.7 && <0.8 + , http-types >=0.12 && <0.13 + , katip >=0.8 && <0.9 , network >=3.0 && <3.3 + , text >=0.11 && <2.2 + , time >=1.12.2 && <1.15 + , uuid >=1.3 && <1.4 + , wai >=3.0 && <3.3 + test-suite katip-wai-test import: shared @@ -87,27 +113,31 @@ main-is: Main.hs hs-source-dirs: test + default-extensions: + DuplicateRecordFields + other-modules: - DebugApplication - DebugScribe + Katip.Wai.DebugApplication + Katip.Wai.DebugScribe + Katip.Wai.LogEntry Katip.WaiSpec - LogEntry Spec build-tool-depends: , hspec-discover:hspec-discover ==2.* build-depends: - , katip-wai - , async + , aeson + , async >=2.2 && <2.3 + , bytestring , containers - , hspec - , http-client - , stm - - if impl(ghc >= 9.2) - build-depends: - , warp >= 3.3.18 - else - build-depends: - , warp + , hspec >=2.10 && <2.12 + , http-client >=0.7 && <0.8 + , http-types + , katip + , katip-wai + , stm >=2.5 && <2.6 + , text + , uuid + , wai + , warp >=3.3 && <3.5 diff --git a/src/Katip/Wai.hs b/src/Katip/Wai.hs --- a/src/Katip/Wai.hs +++ b/src/Katip/Wai.hs @@ -1,222 +1,122 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE StrictData #-} - --- | --- Description: Middleware for logging request and response info through Katip. +-- | Add information about the 'Network.Wai.Request', 'Network.Wai.Response', +-- and the response time to Katip's 'Katip.LogContexts'. -- --- Add information about 'Wai.Request', 'Wai.Response', and the elapsed time to Katip's 'Katip.LogContexts'. +-- Example setup: -- --- The following is added to the context as \"response\": +-- @ +-- import Control.Exception (bracket) +-- import Data.Proxy (Proxy (Proxy)) +-- import Katip qualified +-- import Katip.Wai (ApplicationT, runApplication) +-- import Katip.Wai qualified +-- import Network.Wai.Handler.Warp qualified as Warp +-- import Servant qualified +-- import System.IO (stdout) +-- import UnliftIO (MonadUnliftIO (withRunInIO)) -- --- - \"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 - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Data.Aeson ((.=)) -import qualified Data.Aeson as Aeson -import Data.ByteString (ByteString) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Text.Encoding (decodeUtf8With) -import Data.Text.Encoding.Error (lenientDecode) -import Data.UUID (UUID) -import qualified Data.UUID as UUID -import qualified Data.UUID.V4 as UUID.V4 -import qualified Katip -import Network.HTTP.Types (Method) -import Network.HTTP.Types.Status (Status) -import Network.HTTP.Types.URI (Query, queryToQueryText) -import Network.HTTP.Types.Version (HttpVersion) -import Network.Socket (SockAddr) -import qualified Network.Wai as Wai -import qualified System.Clock as Clock - - -data Request = Request - { requestId :: UUID - , requestHttpVersion :: HttpVersion - , requestRemoteHost :: SockAddr - , requestIsSecure :: Bool - , requestMethod :: Method - , requestPathInfo :: [Text] - , requestQueryString :: Query - , requestBodyLength :: Wai.RequestBodyLength - , requestHeaderHost :: Maybe ByteString - , requestHeaderReferer :: Maybe ByteString - , requestHeaderUserAgent :: Maybe ByteString - , requestHeaderRange :: Maybe ByteString - } - -#if MIN_VERSION_aeson(2,2,0) -requestToKeyValues :: Aeson.KeyValue e kv => Request -> [kv] -#else -requestToKeyValues :: Aeson.KeyValue kv => Request -> [kv] -#endif - - -requestToKeyValues Request{..} = - let toText = decodeUtf8With lenientDecode - headers = - Aeson.object - [ "host" .= fmap toText requestHeaderHost - , "referer" .= fmap toText requestHeaderReferer - , "userAgent" .= fmap toText requestHeaderUserAgent - , "range" .= fmap toText requestHeaderRange - ] - in [ "id" .= UUID.toText requestId - , "httpVersion" .= show requestHttpVersion - , "remoteHost" .= show requestRemoteHost - , "isSecure" .= requestIsSecure - , "method" .= toText requestMethod - , "path" .= Text.intercalate "/" requestPathInfo - , "queryString" .= queryToQueryText requestQueryString - , "bodyLength" .= show requestBodyLength - , "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. +-- type Api = Servant.GetNoContent -- --- Current format: -- --- - \"id\": Uniquely generated string that can be used to correlate logs to a single request. +-- server :: Servant.ServerT Api (Katip.KatipContextT Servant.Handler) +-- server = do +-- Katip.logLocM Katip.InfoS "This message should also have the request context" +-- pure Servant.NoContent -- --- - \"httpVersion\": Version of the request. -- --- - \"remoteHost\": Address the request came from. +-- mkApplication :: ApplicationT (Katip.KatipContextT IO) +-- mkApplication = Katip.Wai.middleware Katip.InfoS $ \request send -> do +-- logEnv <- Katip.getLogEnv +-- context <- Katip.getKatipContext +-- namespace <- Katip.getKatipNamespace -- --- - \"isSecure\": True if the request was made over an SSL connection, otherwise false. +-- let hoistedApp = +-- let proxy = Proxy @Api +-- hoistedServer = Servant.hoistServer proxy (Katip.runKatipContextT logEnv context namespace) server +-- in Servant.serve proxy hoistedServer -- --- - \"method\": HTTP Method used for the request, ie. GET, POST, PUT, PATCH, DELETE, etc. +-- withRunInIO $ \toIO -> hoistedApp request (toIO . send) -- --- - \"path\": URL without a hostname, port, or querystring. -- --- - \"queryString\": Query string of the request if one was sent. +-- withLogEnv :: (Katip.LogEnv -> IO a) -> IO a +-- withLogEnv useLogEnv = do +-- handleScribe <- +-- Katip.mkHandleScribeWithFormatter +-- Katip.jsonFormat +-- (Katip.ColorLog False) +-- stdout +-- (Katip.permitItem minBound) +-- Katip.V3 -- --- - \"bodyLength\": Size of the body in the request. +-- let makeLogEnv = +-- Katip.initLogEnv "example-app" "local-dev" +-- >>= Katip.registerScribe "stdout" handleScribe Katip.defaultScribeSettings -- --- - \"headers.host\": Value of the \"Host\" header. +-- bracket makeLogEnv Katip.closeScribes useLogEnv -- --- - \"headers.referer\": Value of the \"Referer\" header. -- --- - \"headers.userAgent\": Value of the \"User-Agent\" header. +-- main :: IO () +-- main = withLogEnv $ \logEnv -> +-- let +-- app = runApplication (Katip.runKatipContextT logEnv () "main") mkApplication +-- in +-- Warp.run 5555 app +-- @ -- --- - \"headers.range\": Value of the \"Range\" header. -defaultFormat :: UUID -> Wai.Request -> Aeson.Value -defaultFormat requestId request = - Aeson.toJSON $ - Request - { requestId = requestId - , requestHttpVersion = Wai.httpVersion request - , requestRemoteHost = Wai.remoteHost request - , requestIsSecure = Wai.isSecure request - , requestMethod = Wai.requestMethod request - , requestPathInfo = Wai.pathInfo request - , requestQueryString = Wai.queryString request - , requestBodyLength = Wai.requestBodyLength request - , requestHeaderHost = Wai.requestHeaderHost request - , requestHeaderReferer = Wai.requestHeaderReferer request - , requestHeaderUserAgent = Wai.requestHeaderUserAgent request - , requestHeaderRange = Wai.requestHeaderRange request - } - - -data Response = Response - { responseElapsedTime :: Clock.TimeSpec - , responseStatus :: Status - } - -#if MIN_VERSION_aeson(2,2,0) -responseToKeyValues :: Aeson.KeyValue e kv => Response -> [kv] -#else -responseToKeyValues :: Aeson.KeyValue kv => Response -> [kv] -#endif - - -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 +-- Example output: +-- +-- @ +-- {"app":["example-app"],"at":"2024-09-07T18:44:10.411097829Z","data":{"request":{"headers":{"Host":"localhost:5555","User-Agent":"curl/8.9.1"},"httpVersion":"HTTP/1.1","id":"7ec0fbc4-722c-4c70-a168-c2abe5c7b4fa","isSecure":false,"method":"GET","path":"/","queryString":[],"receivedAt":"2024-09-07T18:44:10.411057334Z","remoteHost":"127.0.0.1:51230"}},"env":"local-dev","host":"x1g11","loc":null,"msg":"Request received.","ns":["example-app","main"],"pid":"106249","sev":"Info","thread":"27"} +-- {"app":["example-app"],"at":"2024-09-07T18:44:10.411097829Z","data":{"request":{"headers":{"Host":"localhost:5555","User-Agent":"curl/8.9.1"},"httpVersion":"HTTP/1.1","id":"7ec0fbc4-722c-4c70-a168-c2abe5c7b4fa","isSecure":false,"method":"GET","path":"/","queryString":[],"receivedAt":"2024-09-07T18:44:10.411057334Z","remoteHost":"127.0.0.1:51230"}},"env":"local-dev","host":"x1g11","loc":{"loc_col":3,"loc_fn":"src/Katip/Wai/Example/Short.hs","loc_ln":19,"loc_mod":"Katip.Wai.Example.Short","loc_pkg":"my-katip-wai-example-0.1.0.0-inplace"},"msg":"This message should also have the request context","ns":["example-app","main"],"pid":"106249","sev":"Info","thread":"27"} +-- {"app":["example-app"],"at":"2024-09-07T18:44:10.411097829Z","data":{"request":{"headers":{"Host":"localhost:5555","User-Agent":"curl/8.9.1"},"httpVersion":"HTTP/1.1","id":"7ec0fbc4-722c-4c70-a168-c2abe5c7b4fa","isSecure":false,"method":"GET","path":"/","queryString":[],"receivedAt":"2024-09-07T18:44:10.411057334Z","remoteHost":"127.0.0.1:51230"},"response":{"headers":{},"respondedAt":"2024-09-07T18:44:10.411199014Z","responseTime":{"time":0.137369,"unit":"ms"},"status":{"code":204,"message":"No Content"}}},"env":"local-dev","host":"x1g11","loc":null,"msg":"Response sent.","ns":["example-app","main"],"pid":"106249","sev":"Info","thread":"27"} +-- @ +module Katip.Wai + ( -- * Middleware + -- | 'Network.Wai.Middleware' for logging request and response information. + Middleware.middleware + , Middleware.middlewareCustom -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 + -- ** Helpers - end <- liftIO $ Clock.getTime Clock.Monotonic + -- | Since logging with @Katip@ is monadic, we need the ability to run an + -- 'Network.Wai.Application' or 'Network.Wai.Middleware' in a monad other + -- than @IO@. + , Middleware.ApplicationT + , Middleware.MiddlewareT + , Middleware.runApplication - let loggableResponse = - Response - { responseElapsedTime = end `Clock.diffTimeSpec` start - , responseStatus = Wai.responseStatus response - } + -- * Options - Katip.katipAddContext (Katip.sl "response" loggableResponse) $ do - Katip.logFM severity "Response sent" - pure responseReceived + -- | Options for customizing the way 'Middleware.middlewareCustom' handles the requests and responses. + , Options.Options (..) + , Options.addRequestAndResponseToContext + , Options.logRequestAndResponse + , Options.options + , Options.defaultOptions + -- ** Formatting --- | 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 + -- | Functions for formatting the 'Request.Request's and 'Response.Response's. + , Options.Formatter + , Options.TimeUnit (..) + , Options.IncludedHeaders + , Options.defaultIncludedHeaders + , Options.defaultRequestFormat + , Options.defaultResponseFormat - let jsonRequest = format requestId request + -- * Request + , Request.Request (..) + , Request.traceRequest - Katip.katipAddContext (Katip.sl "request" jsonRequest) $ do - Katip.logFM severity "Request received" - application request (withLoggedResponse severity start send) + -- * Response + , Response.Response (..) + , Response.traceResponse + ) +where +import qualified Katip.Wai.Middleware as Middleware +import qualified Katip.Wai.Options as Options +import qualified Katip.Wai.Request as Request +import qualified Katip.Wai.Response as Response --- | Logs the request, response, and elapsed time in Katip's context -middleware :: Katip.KatipContext m => Katip.Severity -> MiddlewareT m -middleware = - middlewareWithFormatter defaultFormat diff --git a/src/Katip/Wai/Middleware.hs b/src/Katip/Wai/Middleware.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Wai/Middleware.hs @@ -0,0 +1,56 @@ +module Katip.Wai.Middleware + ( ApplicationT + , MiddlewareT + , runApplication + , middlewareCustom + , middleware + ) where + +import Katip.Wai.Options (Options) +import qualified Katip.Wai.Options as Options +import qualified Katip.Wai.Request as Request +import qualified Katip.Wai.Response as Response + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Katip +import qualified Network.Wai as Wai + + +-- | 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 + + +-- | Just like 'Wai.Middleware' except it runs in @m@ instead of 'IO' +type MiddlewareT m = ApplicationT m -> ApplicationT m + + +-- | 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) + + +-- | Same as 'middleware', but allows you to customize how the 'Request.Request' +-- and 'Response.Response' are handled. +middlewareCustom + :: MonadIO m + => Options m + -> MiddlewareT m +middlewareCustom options application request send = do + tracedRequest <- Request.traceRequest request + Options.handleRequest options tracedRequest $ + application request $ \response -> do + tracedResponse <- Response.traceResponse tracedRequest response + Options.handleResponse options tracedResponse $ + send response + + +-- | Add the request and response to the 'Katip.LogContexts', and log a message +-- when a request is received and when a response is sent. +-- +-- This uses the default format: 'Options.defaultRequestFormat' and 'Options.defaultResponseFormat' with milliseconds for the response time. +-- +-- If you want more customization see 'middlewareCustom'. +middleware :: Katip.KatipContext m => Katip.Severity -> MiddlewareT m +middleware = + middlewareCustom . Options.defaultOptions diff --git a/src/Katip/Wai/Options.hs b/src/Katip/Wai/Options.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Wai/Options.hs @@ -0,0 +1,251 @@ +module Katip.Wai.Options + ( -- * Formatting + Formatter + , TimeUnit (..) + , IncludedHeaders + , defaultIncludedHeaders + , defaultRequestFormat + , defaultResponseFormat + + -- * Options + , Options (..) + , addRequestAndResponseToContext + , logRequestAndResponse + , options + , defaultOptions + ) +where + +import Katip.Wai.Request (Request) +import qualified Katip.Wai.Request as Request +import Katip.Wai.Response (Response) +import qualified Katip.Wai.Response as Response + +import qualified Data.Aeson as Aeson +import Data.Bifunctor (bimap) +import Data.ByteString (ByteString) +import qualified Data.CaseInsensitive as CI +import qualified Data.Map.Strict as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text.Encoding as TextEncoding +import qualified Data.Text.Encoding.Error as TextEncodingError +import qualified Data.UUID as UUID +import qualified Katip +import qualified Network.HTTP.Types as HttpTypes +import qualified System.Clock as Clock + + +-- * Formatting + + +-- | A formatter is a function that can convert 'a' into json. +type Formatter a = a -> Aeson.Value + + +-- | Unit of time to use when logging response times. +data TimeUnit + = Nanoseconds + | Microseconds + | Milliseconds + | Seconds + deriving (Show, Eq, Ord, Enum, Bounded) + + +-- | Headers to include in your logs. +type IncludedHeaders = Set HttpTypes.HeaderName + + +bsToText :: ByteString -> Text +bsToText = + TextEncoding.decodeUtf8With TextEncodingError.lenientDecode + + +filterHeaders :: IncludedHeaders -> [HttpTypes.Header] -> [HttpTypes.Header] +filterHeaders includedHeaders = + filter (flip Set.member includedHeaders . fst) + + +formatHeaders :: [HttpTypes.Header] -> Aeson.Value +formatHeaders headers = + Aeson.toJSON . Map.fromList $ fmap (bimap (CI.original . CI.map bsToText) bsToText) headers + + +formatTimeSpec :: TimeUnit -> Clock.TimeSpec -> Aeson.Value +formatTimeSpec timeUnit timeSpec = + let + (abbreviation, divisor) = + case timeUnit of + Nanoseconds -> ("ns" :: Text, 1 :: Double) + Microseconds -> ("μs", 1e+3) + Milliseconds -> ("ms", 1e+6) + Seconds -> ("s", 1e+9) + in + Aeson.object + [ "unit" Aeson..= abbreviation + , "time" Aeson..= (fromIntegral (Clock.toNanoSecs timeSpec) / divisor) + ] + + +-- | Default list of headers to include in logs: 'Host', 'Referer', 'User-Agent', and 'Range'. +defaultIncludedHeaders :: IncludedHeaders +defaultIncludedHeaders = + Set.fromList + [ "Host" + , "Referer" + , "User-Agent" + , "Range" + ] + + +-- | Default formatter for 'Request's. +-- +-- Example: +-- +-- @ +-- { +-- "headers": { +-- "Host": "localhost:4000", +-- "Referer": "http://localhost:4000/docs/", +-- "User-Agent": "Mozilla/5.0 (X11; Linux x86_64; rv:130.0) Gecko/20100101 Firefox/130.0" +-- }, +-- "httpVersion": "HTTP/1.1", +-- "id": "299b188e-f695-49ee-a92f-9078a29f2ec4", +-- "isSecure": false, +-- "method": "GET", +-- "path": "/openapi.json", +-- "queryString": [], +-- "receivedAt": "2024-09-07T18:22:50.943042066Z", +-- "remoteHost": "127.0.0.1:58046" +-- } +-- @ +defaultRequestFormat :: IncludedHeaders -> Formatter Request +defaultRequestFormat includedHeaders request = + Aeson.object + [ "id" Aeson..= UUID.toText (Request.traceId request) + , "method" Aeson..= bsToText (Request.method request) + , "httpVersion" Aeson..= show (Request.httpVersion request) + , "path" Aeson..= bsToText (Request.rawPathInfo request) + , "headers" Aeson..= formatHeaders (filterHeaders includedHeaders (Request.requestHeaders request)) + , "isSecure" Aeson..= Request.isSecure request + , "remoteHost" Aeson..= show (Request.remoteHost request) + , "queryString" Aeson..= fmap (bimap bsToText (fmap bsToText)) (Request.queryString request) + , "receivedAt" Aeson..= Request.receivedAt request + ] + + +-- | Default formatter for 'Response's. +-- +-- Example: +-- +-- @ +-- { +-- "headers": {}, +-- "respondedAt": "2024-09-07T18:22:50.943213512Z", +-- "responseTime": { +-- "time": 0.167463, +-- "unit": "ms" +-- }, +-- "status": { +-- "code": 200, +-- "message": "OK" +-- } +-- } +-- @ +defaultResponseFormat :: IncludedHeaders -> TimeUnit -> Formatter Response +defaultResponseFormat includedHeaders timeUnit response = + Aeson.object + [ "status" + Aeson..= Aeson.object + [ "code" Aeson..= HttpTypes.statusCode (Response.status response) + , "message" Aeson..= bsToText (HttpTypes.statusMessage (Response.status response)) + ] + , "headers" Aeson..= formatHeaders (filterHeaders includedHeaders (Response.responseHeaders response)) + , "respondedAt" Aeson..= Response.respondedAt response + , "responseTime" Aeson..= formatTimeSpec timeUnit (Response.responseTime response) + ] + + +-- * Options + + +-- | Options to customize how to handle the 'Request' and 'Response'. +-- +-- You can use 'Monoid' to combine 'Options': +-- +-- @ +-- mconcat +-- [ addRequestAndResponseToContext +-- requestFormatter +-- responseFormatter +-- , logRequestAndResponse severity +-- ] +-- @ +data Options m = Options + { handleRequest :: forall a. Request -> m a -> m a + , handleResponse :: forall a. Response -> m a -> m a + } + + +-- | Add the 'Request' to the 'Katip.LogContexts' under @"request"@, and add 'Response' to the 'Katip.LogContext' under @"response"@. +addRequestAndResponseToContext :: Katip.KatipContext m => Formatter Request -> Formatter Response -> Options m +addRequestAndResponseToContext requestFormatter responseFormatter = + Options + { handleRequest = \request action -> + Katip.katipAddContext (Katip.sl "request" (requestFormatter request)) $ do + action + , handleResponse = \response action -> + Katip.katipAddContext (Katip.sl "response" (responseFormatter response)) $ do + action + } + + +-- | Log @"Request received."@ when a request comes in, and log @"Response sent."@ when a response is sent back. +logRequestAndResponse :: Katip.KatipContext m => Katip.Severity -> Options m +logRequestAndResponse severity = + Options + { handleRequest = \_ action -> do + Katip.logFM severity "Request received." + action + , handleResponse = \_ action -> do + Katip.logFM severity "Response sent." + action + } + + +-- | Combines 'addRequestAndResponseToContext' and 'logRequestAndResponse' with the formatters and severity you provide. +options :: Katip.KatipContext m => Formatter Request -> Formatter Response -> Katip.Severity -> Options m +options requestFormatter responseFormatter severity = + mconcat + [ addRequestAndResponseToContext + requestFormatter + responseFormatter + , logRequestAndResponse severity + ] + + +-- | Same as 'options', but uses 'defaultRequestFormat','defaultResponseFormat', and 'Milliseconds'. +defaultOptions :: Katip.KatipContext m => Katip.Severity -> Options m +defaultOptions = + options + (defaultRequestFormat defaultIncludedHeaders) + (defaultResponseFormat defaultIncludedHeaders Milliseconds) + + +instance Semigroup (Options m) where + a <> b = + Options + { handleRequest = \request action -> + handleRequest a request $ handleRequest b request action + , handleResponse = \response action -> + handleResponse a response $ handleResponse b response action + } + + +instance Monoid (Options m) where + mempty = + Options + { handleRequest = const id + , handleResponse = const id + } diff --git a/src/Katip/Wai/Request.hs b/src/Katip/Wai/Request.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Wai/Request.hs @@ -0,0 +1,68 @@ +module Katip.Wai.Request + ( Request (..) + , traceRequest + ) where + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.ByteString (ByteString) +import Data.Text (Text) +import qualified Data.Time as Time +import Data.UUID (UUID) +import qualified Data.UUID.V4 as V4 +import qualified Network.HTTP.Types as HttpTypes +import qualified Network.Socket as Socket +import qualified Network.Wai as Wai +import qualified System.Clock as Clock + + +-- | An incoming http request. +data Request = Request + { traceId :: UUID + -- ^ Unique identifier for the request. + , method :: HttpTypes.Method + -- ^ HTTP request method, ie 'GET', 'HEAD', 'POST', 'PUT', 'DELETE', 'CONNECT', 'OPTIONS', 'TRACE', or 'PATCH'. + , httpVersion :: HttpTypes.HttpVersion + -- ^ HTTP version that was used for this request. + , rawPathInfo :: ByteString + -- ^ Raw path info for this request. + , requestHeaders :: HttpTypes.RequestHeaders + -- ^ All of the headers that were sent in this request. Be careful not log any sensitive headers, like API Keys. + , isSecure :: Bool + -- ^ Set to 'True' if the connection used https. + , remoteHost :: Socket.SockAddr + -- ^ The remote host the request was sent from. + , pathInfo :: [Text] + -- ^ Same as 'rawPathInfo' except this is broken up into a list. + , queryString :: HttpTypes.Query + -- ^ The query string from the request. + , receivedAt :: Time.UTCTime + -- ^ The time the request was received on the server. + , startedAt :: Clock.TimeSpec + -- ^ The time the server started processing the request. You can probably ignore this, it's only here so we can time how long it takes to respond. + } + deriving (Show, Eq) + + +-- | Trace a 'Wai.Request' by assigning it a unique 'UUID' and capture information about the request. +traceRequest :: MonadIO m => Wai.Request -> m Request +traceRequest waiRequest = do + traceId <- liftIO V4.nextRandom + receivedAt <- liftIO Time.getCurrentTime + startedAt <- liftIO $ Clock.getTime Clock.Monotonic + + let request = + Request + { traceId = traceId + , receivedAt = receivedAt + , startedAt = startedAt + , method = Wai.requestMethod waiRequest + , httpVersion = Wai.httpVersion waiRequest + , rawPathInfo = Wai.rawPathInfo waiRequest + , requestHeaders = Wai.requestHeaders waiRequest + , isSecure = Wai.isSecure waiRequest + , remoteHost = Wai.remoteHost waiRequest + , pathInfo = Wai.pathInfo waiRequest + , queryString = Wai.queryString waiRequest + } + + pure request diff --git a/src/Katip/Wai/Response.hs b/src/Katip/Wai/Response.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Wai/Response.hs @@ -0,0 +1,44 @@ +module Katip.Wai.Response + ( Response (..) + , traceResponse + ) where + +import Katip.Wai.Request (Request) +import qualified Katip.Wai.Request as Request + +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.Time as Time +import qualified Network.HTTP.Types as HttpTypes +import qualified Network.Wai as Wai +import qualified System.Clock as Clock + + +-- | Response that was sent back to client. +data Response = Response + { status :: HttpTypes.Status + -- ^ The HTTP status code of the response. + , responseHeaders :: HttpTypes.ResponseHeaders + -- ^ The headers in the response. Be careful not to log any sensntive headers. + , respondedAt :: Time.UTCTime + -- ^ The time server responded. + , responseTime :: Clock.TimeSpec + -- ^ How long it took the server to respond. + } + deriving (Show, Eq) + + +-- | Trace a response and time how long it took to process a request. +traceResponse :: MonadIO m => Request -> Wai.Response -> m Response +traceResponse request response = do + endedAt <- liftIO $ Clock.getTime Clock.Monotonic + respondedAt <- liftIO Time.getCurrentTime + + let responseTime = endedAt `Clock.diffTimeSpec` Request.startedAt request + + pure + Response + { status = Wai.responseStatus response + , responseHeaders = Wai.responseHeaders response + , respondedAt + , responseTime + } diff --git a/test/DebugApplication.hs b/test/DebugApplication.hs deleted file mode 100644 --- a/test/DebugApplication.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module DebugApplication - ( DebugApplication - , sendNoContentRequest - , sendLogRequest - , sendNotFoundRequest - , withDebugApplication - ) -where - -import Control.Exception (bracket) -import Control.Monad (join) -import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LazyByteString -import Data.Coerce (coerce) -import qualified Data.Maybe as Maybe -import Data.Text (Text) -import Data.Text.Encoding (decodeUtf8With, encodeUtf8) -import Data.Text.Encoding.Error (lenientDecode) -import DebugScribe (withDebugScribe) -import Katip (KatipContextT, runKatipContextT) -import qualified Katip -import Katip.Wai (ApplicationT, runApplication) -import qualified Katip.Wai -import qualified Network.HTTP.Client as Http -import Network.HTTP.Types.Method (Method) -import qualified Network.HTTP.Types.Status as Status -import qualified Network.Wai as Wai -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" - let request = - Http.setQueryString [("message", Just $ encodeUtf8 message)] $ - baseRequest{Http.method = method} - - response <- Http.httpLbs request manager - - let status = Http.responseStatus response - in status `shouldBe` Status.status202 - - let headers = Http.responseHeaders response - contentType = lookup "Content-Type" headers - in contentType `shouldBe` Just "text/plain; charset=UTF-8" - - let bytes = LazyByteString.toStrict $ Http.responseBody response - body = decodeUtf8With lenientDecode bytes - in body `shouldBe` message - - -sendNoContentRequest :: Http.Manager -> DebugApplication -> Method -> IO () -sendNoContentRequest manager app method = do - baseRequest <- Http.parseRequest $ toUrl app - let request = baseRequest{Http.method = method} - - response <- Http.httpLbs request manager - - let body = Http.responseBody response - body `shouldBe` mempty - - 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" - let request = baseRequest{Http.method = method} - - response <- Http.httpLbs request manager - - let body = Http.responseBody response - body `shouldBe` mempty - - let status = Http.responseStatus response - status `shouldBe` Status.status404 - - -mkApplication :: Katip.Severity -> ApplicationT (KatipContextT IO) -mkApplication severity = - let base request send = - case Wai.pathInfo request of - ["log"] -> - let queryString = Wai.queryString request - message = Maybe.fromMaybe "Example log message" $ do - bytes <- join $ lookup "message" queryString - pure $ decodeUtf8With lenientDecode bytes - in do - Katip.logFM Katip.InfoS (Katip.ls message) - send $ - Wai.responseLBS - (toEnum 202) - [("Content-Type", "text/plain; charset=UTF-8")] - (LazyByteString.fromStrict $ encodeUtf8 message) - [] -> - send $ Wai.responseLBS (toEnum 204) [] mempty - _ -> - 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 -> - let makeLogEnv = - 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 = - withLogEnv $ \logEnv -> - let toIO = runKatipContextT logEnv () "spec" - app = runApplication toIO (mkApplication severity) - in Warp.testWithApplication (pure app) (useApp . coerce) diff --git a/test/DebugScribe.hs b/test/DebugScribe.hs deleted file mode 100644 --- a/test/DebugScribe.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module DebugScribe - ( withDebugScribe - ) -where - -import qualified Control.Concurrent.Async as Async -import qualified Control.Concurrent.MVar as MVar -import qualified Control.Concurrent.STM as STM -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 - queue <- STM.newTQueueIO - - let push logItem = - let event = Just $ Katip.itemJson verbosity logItem - in STM.atomically (STM.writeTQueue queue event) - - allLogsVar <- MVar.newEmptyMVar - - let finalizer = do - STM.atomically $ STM.writeTQueue queue Nothing - void $ MVar.readMVar allLogsVar - - let handleEvents logs = do - event <- STM.atomically $ STM.readTQueue queue - case event of - Just logValue -> handleEvents (logValue : logs) - Nothing -> MVar.putMVar allLogsVar $ reverse logs - - let scribe = - Katip.Scribe - { Katip.liPush = push - , Katip.scribeFinalizer = finalizer - , Katip.scribePermitItem = permitFunc - } - - Async.withAsync (handleEvents []) $ \eventHandler -> do - _ <- useScribe scribe - Async.wait eventHandler - MVar.readMVar allLogsVar diff --git a/test/Katip/Wai/DebugApplication.hs b/test/Katip/Wai/DebugApplication.hs new file mode 100644 --- /dev/null +++ b/test/Katip/Wai/DebugApplication.hs @@ -0,0 +1,125 @@ +module Katip.Wai.DebugApplication + ( DebugApplication + , sendNoContentRequest + , sendLogRequest + , sendNotFoundRequest + , withDebugApplication + ) +where + +import Control.Exception (bracket) +import Control.Monad (join) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LazyByteString +import Data.Coerce (coerce) +import qualified Data.Maybe as Maybe +import Data.Text (Text) +import Data.Text.Encoding (decodeUtf8With, encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import Katip (KatipContextT, runKatipContextT) +import qualified Katip +import Katip.Wai (ApplicationT, runApplication) +import qualified Katip.Wai +import Katip.Wai.DebugScribe (withDebugScribe) +import qualified Network.HTTP.Client as Http +import Network.HTTP.Types.Method (Method) +import qualified Network.HTTP.Types.Status as Status +import qualified Network.Wai as Wai +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" + let request = + Http.setQueryString [("message", Just $ encodeUtf8 message)] $ + baseRequest{Http.method = method} + + response <- Http.httpLbs request manager + + let status = Http.responseStatus response + in status `shouldBe` Status.status202 + + let headers = Http.responseHeaders response + contentType = lookup "Content-Type" headers + in contentType `shouldBe` Just "text/plain; charset=UTF-8" + + let bytes = LazyByteString.toStrict $ Http.responseBody response + body = decodeUtf8With lenientDecode bytes + in body `shouldBe` message + + +sendNoContentRequest :: Http.Manager -> DebugApplication -> Method -> IO () +sendNoContentRequest manager app method = do + baseRequest <- Http.parseRequest $ toUrl app + let request = baseRequest{Http.method = method} + + response <- Http.httpLbs request manager + + let body = Http.responseBody response + body `shouldBe` mempty + + 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" + let request = baseRequest{Http.method = method} + + response <- Http.httpLbs request manager + + let body = Http.responseBody response + body `shouldBe` mempty + + let status = Http.responseStatus response + status `shouldBe` Status.status404 + + +mkApplication :: Katip.Severity -> ApplicationT (KatipContextT IO) +mkApplication severity = + let base request send = + case Wai.pathInfo request of + ["log"] -> + let queryString = Wai.queryString request + message = Maybe.fromMaybe "Example log message" $ do + bytes <- join $ lookup "message" queryString + pure $ decodeUtf8With lenientDecode bytes + in do + Katip.logFM severity (Katip.ls message) + send $ + Wai.responseLBS + (toEnum 202) + [("Content-Type", "text/plain; charset=UTF-8")] + (LazyByteString.fromStrict $ encodeUtf8 message) + [] -> + send $ Wai.responseLBS (toEnum 204) [] mempty + _ -> + 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 -> + let makeLogEnv = + 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 = + withLogEnv $ \logEnv -> + let toIO = runKatipContextT logEnv () "spec" + app = runApplication toIO (mkApplication severity) + in Warp.testWithApplication (pure app) (useApp . coerce) diff --git a/test/Katip/Wai/DebugScribe.hs b/test/Katip/Wai/DebugScribe.hs new file mode 100644 --- /dev/null +++ b/test/Katip/Wai/DebugScribe.hs @@ -0,0 +1,45 @@ +module Katip.Wai.DebugScribe + ( withDebugScribe + ) +where + +import qualified Control.Concurrent.Async as Async +import qualified Control.Concurrent.MVar as MVar +import qualified Control.Concurrent.STM as STM +import Control.Monad (void) +import qualified Data.Aeson as Aeson +import qualified Katip + + +-- | Collect all logs in memory and return a list of the json encoded logs when closed. +withDebugScribe :: Katip.PermitFunc -> Katip.Verbosity -> (Katip.Scribe -> IO a) -> IO [Aeson.Value] +withDebugScribe permitFunc verbosity useScribe = do + queue <- STM.newTQueueIO + + let push logItem = + let event = Just $ Katip.itemJson verbosity logItem + in STM.atomically (STM.writeTQueue queue event) + + allLogsVar <- MVar.newEmptyMVar + + let finalizer = do + STM.atomically $ STM.writeTQueue queue Nothing + void $ MVar.readMVar allLogsVar + + let handleEvents logs = do + event <- STM.atomically $ STM.readTQueue queue + case event of + Just logValue -> handleEvents (logValue : logs) + Nothing -> MVar.putMVar allLogsVar $ reverse logs + + let scribe = + Katip.Scribe + { Katip.liPush = push + , Katip.scribeFinalizer = finalizer + , Katip.scribePermitItem = permitFunc + } + + Async.withAsync (handleEvents []) $ \eventHandler -> do + _ <- useScribe scribe + Async.wait eventHandler + MVar.readMVar allLogsVar diff --git a/test/Katip/Wai/LogEntry.hs b/test/Katip/Wai/LogEntry.hs new file mode 100644 --- /dev/null +++ b/test/Katip/Wai/LogEntry.hs @@ -0,0 +1,129 @@ +module Katip.Wai.LogEntry + ( Request (..) + , Status (..) + , ResponseTime (..) + , Response (..) + , LogData (..) + , LogEntry (..) + , requestHeaders + , responseHeaders + , toLogEntry + , shouldBe + ) +where + +import Data.Aeson ((.:)) +import qualified Data.Aeson as Aeson +import Data.Function (on) +import Data.Map.Strict (Map) +import Data.Text (Text) +import Data.UUID (UUID) +import GHC.Generics (Generic) +import GHC.Natural (Natural) +import GHC.Stack (HasCallStack) +import qualified Katip +import qualified Test.Hspec as Hspec + + +data Request = Request + { id :: UUID + , method :: Text + , httpVersion :: Text + , path :: Text + , headers :: Map Text Text + , isSecure :: Bool + , remoteHost :: Text + , queryString :: [(Text, Maybe Text)] + , receivedAt :: Text + } + deriving (Show, Eq, Generic) + + +instance Aeson.FromJSON Request + + +requestHeaders :: Request -> Map Text Text +requestHeaders Request{headers} = + headers + + +data ResponseTime = ResponseTime + { unit :: Text + , time :: Double + } + deriving (Show, Eq, Generic) + + +instance Aeson.FromJSON ResponseTime + + +data Status = Status + { code :: Natural + , message :: Text + } + deriving (Show, Eq, Generic) + + +instance Aeson.FromJSON Status + + +data Response = Response + { status :: Status + , headers :: Map Text Text + , respondedAt :: Text + , responseTime :: ResponseTime + } + deriving (Show, Eq, Generic) + + +responseHeaders :: Response -> Map Text Text +responseHeaders Response{headers} = + headers + + +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 + , logSeverity :: Katip.Severity + } + 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 + + +shouldBe :: HasCallStack => LogEntry -> LogEntry -> IO () +shouldBe log1 log2 = do + on Hspec.shouldBe logMessage log1 log2 + + on Hspec.shouldBe (fmap method . request . logData) log1 log2 + on Hspec.shouldBe (fmap httpVersion . request . logData) log1 log2 + on Hspec.shouldBe (fmap path . request . logData) log1 log2 + on Hspec.shouldBe (fmap isSecure . request . logData) log1 log2 + on Hspec.shouldBe (fmap queryString . request . logData) log1 log2 + + on Hspec.shouldBe (fmap status . response . logData) log1 log2 + + on Hspec.shouldBe logSeverity log1 log2 diff --git a/test/Katip/WaiSpec.hs b/test/Katip/WaiSpec.hs --- a/test/Katip/WaiSpec.hs +++ b/test/Katip/WaiSpec.hs @@ -1,19 +1,16 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StrictData #-} - module Katip.WaiSpec (spec) where import Data.Foldable (for_) +import qualified Data.Map.Strict as Map import qualified Data.Maybe as Maybe import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.UUID as Uuid -import DebugApplication (withDebugApplication) -import qualified DebugApplication import qualified Katip -import LogEntry (LogEntry (LogEntry)) -import qualified LogEntry +import Katip.Wai.DebugApplication (withDebugApplication) +import qualified Katip.Wai.DebugApplication as DebugApplication +import Katip.Wai.LogEntry (LogEntry (LogEntry)) +import qualified Katip.Wai.LogEntry as LogEntry import qualified Network.HTTP.Client as Http import Test.Hspec (Spec, describe, it, runIO, shouldBe, shouldSatisfy) @@ -44,21 +41,15 @@ , remoteHost = "127.0.0.1:1234" , isSecure = False , method = "GET" - , path = "log" + , path = "/log" , queryString = [("message", Just message)] - , bodyLength = "KnownLength 0" - , headers = - LogEntry.Headers - { host = Just "localhost:1234" - , referer = Nothing - , userAgent = Nothing - , range = Nothing - } + , headers = Map.empty + , receivedAt = "dont care" } let expectedLog1 = LogEntry - { logMessage = "Request received" + { logMessage = "Request received." , logData = LogEntry.LogData { response = Nothing @@ -78,23 +69,29 @@ } expectedLog3 = LogEntry - { logMessage = "Response sent" + { logMessage = "Response sent." , logData = LogEntry.LogData { response = - Just $ + Just LogEntry.Response - { elapsedTimeInNanoSeconds = 123 - , status = 202 + { status = LogEntry.Status 202 "Accepted" + , headers = Map.empty + , respondedAt = "dont care" + , responseTime = + LogEntry.ResponseTime + { unit = "dont care" + , time = 0 + } } , LogEntry.request = Just expectedRequest } , logSeverity = severity } - log1 `shouldSatisfy` LogEntry.isMostlySameAs expectedLog1 - log2 `shouldSatisfy` LogEntry.isMostlySameAs expectedLog2 - log3 `shouldSatisfy` LogEntry.isMostlySameAs expectedLog3 + log1 `LogEntry.shouldBe` expectedLog1 + log2 `LogEntry.shouldBe` expectedLog2 + log3 `LogEntry.shouldBe` expectedLog3 it ("logs as " <> prettySeverity <> " and uses a different requestId for every request") $ do logs <- withDebugApplication severity $ \debugApp -> @@ -131,7 +128,7 @@ let elapsedTimes = flip Maybe.mapMaybe parsedLogs $ \entry -> do response <- LogEntry.response $ LogEntry.logData entry - pure $ LogEntry.elapsedTimeInNanoSeconds response + pure . LogEntry.time $ LogEntry.responseTime response length elapsedTimes `shouldBe` 15 diff --git a/test/LogEntry.hs b/test/LogEntry.hs deleted file mode 100644 --- a/test/LogEntry.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} - -module LogEntry - ( Headers (..) - , Request (..) - , Response (..) - , LogData (..) - , LogEntry (..) - , toLogEntry - , isMostlySameAs - ) -where - -import Data.Aeson ((.:)) -import qualified Data.Aeson as Aeson -import Data.Function (on) -import Data.Text (Text) -import Data.UUID (UUID) -import GHC.Generics (Generic) -import GHC.Natural (Natural) -import qualified Katip - - -data Headers = Headers - { host :: Maybe Text - , referer :: Maybe Text - , userAgent :: Maybe Text - , range :: Maybe Text - } - deriving (Show, Generic, Eq) - - -instance Aeson.FromJSON Headers - - -data Request = Request - { id :: UUID - , httpVersion :: Text - , remoteHost :: Text - , isSecure :: Bool - , method :: Text - , path :: Text - , queryString :: [(Text, Maybe Text)] - , bodyLength :: Text - , headers :: Headers - } - 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 - , logSeverity :: Katip.Severity - } - 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 = - on (==) (fmap status) - compareHeaders head1 head2 = - on (==) (fmap referer) head1 head2 - && on (==) (fmap userAgent) head1 head2 - && on (==) (fmap range) head1 head2 - compareRequest req1 req2 = - on (==) (fmap httpVersion) req1 req2 - && on (==) (fmap isSecure) req1 req2 - && on (==) (fmap method) req1 req2 - && on (==) (fmap path) req1 req2 - && on (==) (fmap queryString) req1 req2 - && on (==) (fmap bodyLength) req1 req2 - && on compareHeaders (fmap headers) req1 req2 - in on (==) logMessage log1 log2 - && on compareRequest (request . logData) log1 log2 - && on compareResponse (response . logData) log1 log2 - - -instance Eq LogEntry where - (==) = isMostlySameAs