katip-wai 0.1.2.4 → 0.2.0.0

raw patch · 16 files changed

+934/−564 lines, 16 filesdep +case-insensitivedep +timedep ~aesondep ~asyncdep ~bytestringsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: case-insensitive, time

Dependency ranges changed: aeson, async, bytestring, containers, hspec, http-client, http-types, katip, stm, text, uuid, wai, warp

API changes (from Hackage documentation)

Files

• CHANGELOG.md +21/−2
• README.md +25/−26
• Setup.hs +0/−4
• katip-wai.cabal +53/−23
• src/Katip/Wai.hs +94/−194
• src/Katip/Wai/Middleware.hs +56/−0
• src/Katip/Wai/Options.hs +251/−0
• src/Katip/Wai/Request.hs +68/−0
• src/Katip/Wai/Response.hs +44/−0
• test/DebugApplication.hs +0/−127
• test/DebugScribe.hs +0/−46
• test/Katip/Wai/DebugApplication.hs +125/−0
• test/Katip/Wai/DebugScribe.hs +45/−0
• test/Katip/Wai/LogEntry.hs +129/−0
• test/Katip/WaiSpec.hs +23/−26
• test/LogEntry.hs +0/−116

@@ -22,8 +22,26 @@ <!--   `Fixed` for any bug fixes. --> <!--   `Security` in case of vulnerabilities. --> -## [Unreleased]+<!-- ## [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

@@ -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"} ```

@@ -1,4 +0,0 @@-import Distribution.Simple---main = defaultMain

@@ -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 <https://github.com/Disco-Dave/katip-wai#readme>@@ -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

@@ -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

@@ -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

@@ -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+      }

@@ -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

@@ -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+      }

@@ -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)

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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 

@@ -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