katip-wai (empty) → 0.1.0.0
raw patch · 12 files changed
+806/−0 lines, 12 filesdep +aesondep +asyncdep +basesetup-changed
Dependencies added: aeson, async, base, bytestring, clock, containers, hspec, http-client, http-types, katip, katip-wai, network, stm, text, uuid, wai, warp
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +74/−0
- Setup.hs +2/−0
- katip-wai.cabal +106/−0
- src/Katip/Wai.hs +183/−0
- test/DebugApplication.hs +118/−0
- test/DebugScribe.hs +44/−0
- test/Katip/WaiSpec.hs +136/−0
- test/LogEntry.hs +102/−0
- test/Main.hs +7/−0
- test/Spec.hs +1/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for katip-wai++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,74 @@+# katip-wai [](https://github.com/Disco-Dave/katip-wai/actions/workflows/ci.yaml)++[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). ++## 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.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 System.IO (stdout)++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+ 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+ in Servant.serve proxy hoistedServer++ withRunInIO $ \toIO -> hoistedApp request (toIO . send)++withLogEnv :: (Katip.LogEnv -> IO a) -> IO a+withLogEnv useLogEnv = do+ handleScribe <-+ Katip.mkHandleScribeWithFormatter+ Katip.bracketFormat+ (Katip.ColorLog True)+ stdout+ (Katip.permitItem minBound)+ Katip.V3++ let makeLogEnv =+ Katip.initLogEnv "example-app" "local-dev"+ >>= Katip.registerScribe "stdout" handleScribe Katip.defaultScribeSettings++ 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+```++## 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+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ katip-wai.cabal view
@@ -0,0 +1,106 @@+cabal-version: 2.2++name: katip-wai+version: 0.1.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>++build-type: Simple+category: Web, Logging+homepage: https://github.com/Disco-Dave/katip-wai#readme+bug-reports:https://github.com/Disco-Dave/katip-wai/issues++author: David Burkett+maintainer: David Burkett++copyright: 2021 David Burkett+license: BSD-3-Clause+license-file: LICENSE++extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/Disco-Dave/katip-wai++common shared+ default-language: Haskell2010++ ghc-options:+ -Weverything + -Wno-implicit-prelude + -Wno-safe + -Wno-unsafe + -Wno-missing-exported-signatures + -Wno-missing-import-lists + -Wno-missed-specialisations + -Wno-all-missed-specialisations + -Wno-missing-local-signatures + -Wno-monomorphism-restriction + -Wno-missing-deriving-strategies++ if impl(ghc >= 8.10)+ ghc-options:+ -Wno-missing-safe-haskell-mode+ -Wno-prepositive-qualified-module++ if impl(ghc >= 9.2)+ ghc-options:+ -Wno-missing-kind-signatures++ build-depends:+ , aeson >=0.6 && <2.1+ , base >=4.7 && <5+ , bytestring >=0.9 && <0.12+ , http-types >=0.12 && <0.13+ , katip >=0.8 && <0.9+ , text >=0.11 && <1.3+ , uuid >=1.3 && <1.4+ , wai >=3.0 && <3.3++library+ import: shared++ hs-source-dirs: src++ exposed-modules:+ Katip.Wai++ build-depends:+ , clock >=0.8 && <0.9+ , network >=3.0 && <3.2++test-suite katip-wai-test+ import: shared++ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: test++ other-modules:+ DebugApplication+ DebugScribe+ Katip.WaiSpec+ LogEntry+ Spec++ build-tool-depends:+ , hspec-discover:hspec-discover ==2.*++ build-depends:+ , katip-wai+ , async+ , containers+ , hspec+ , http-client+ , stm++ if impl(ghc >= 9.2)+ build-depends:+ , warp >= 3.3.18+ else+ build-depends:+ , warp
+ src/Katip/Wai.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE StrictData #-}++{- |+Description: Middleware for logging request and response info through Katip.++Add information about 'Wai.Request', 'Wai.response', and the elapsed time to Katip's 'Katip.LogContexts'.++The following is added to the context as \"request\":++ - \"id\": Uniquely generated string that can be used to correlate logs to a single request.++ - \"httpVersion\": Version of the request.++ - \"remoteHost\": Address the request came from.++ - \"isSecure\": True if the request was made over an SSL connection, otherwise false.++ - \"method\": HTTP Method used for the request, ie. GET, POST, PUT, PATCH, DELETE, etc.++ - \"path\": URL without a hostname, port, or querystring.++ - \"queryString\": Query string of the request if one was sent.++ - \"bodyLength\": Size of the body in the request.++ - \"headers.host\": Value of the \"Host\" header.++ - \"headers.referer\": Value of the \"Referer\" header.++ - \"headers.userAgent\": Value of the \"User-Agent\" header.++ - \"headers.range\": Value of the \"Range\" header.++The following is added to the context as \"response\":++ - \"elapsedTimeInNanoSeconds\": Amount of time from receiving the request to sending the response in nano seconds.++ - \"status\": The status of the response, ie. 200, 202, 204, 400, 404, 500, etc.+-}+module Katip.Wai (+ middleware,++ -- * 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+ }++requestToKeyValues :: Aeson.KeyValue kv => Request -> [kv]+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++toLoggableRequest :: Wai.Request -> IO Request+toLoggableRequest request = do+ requestId <- UUID.V4.nextRandom+ pure+ 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+ }++responseToKeyValues :: Aeson.KeyValue kv => Response -> [kv]+responseToKeyValues Response{..} =+ [ "elapsedTimeInNanoSeconds" .= Clock.toNanoSecs responseElapsedTime+ , "status" .= fromEnum responseStatus+ ]++instance Aeson.ToJSON Response where+ toJSON = Aeson.object . responseToKeyValues+ toEncoding = Aeson.pairs . mconcat . responseToKeyValues++-- | Just like 'Wai.Application' except it runs in @m@ instead of 'IO'+type ApplicationT m = Wai.Request -> (Wai.Response -> m Wai.ResponseReceived) -> m Wai.ResponseReceived++-- | Converts an 'ApplicationT' to a normal 'Wai.Application'+runApplication :: MonadIO m => (forall a. m a -> IO a) -> ApplicationT m -> Wai.Application+runApplication toIO application request send =+ toIO $ application request (liftIO . send)++-- | Just like 'Wai.Middleware' except it runs in @m@ instead of 'IO'+type MiddlewareT m = ApplicationT m -> ApplicationT m++withLoggedResponse ::+ Katip.KatipContext m =>+ Katip.Severity ->+ Clock.TimeSpec ->+ (Wai.Response -> m Wai.ResponseReceived) ->+ Wai.Response ->+ m Wai.ResponseReceived+withLoggedResponse severity start send response = do+ responseReceived <- send response+ end <- liftIO $ Clock.getTime Clock.Monotonic+ let loggableResponse =+ Response+ { responseElapsedTime = end `Clock.diffTimeSpec` start+ , responseStatus = Wai.responseStatus response+ }+ Katip.katipAddContext (Katip.sl "response" loggableResponse) $ do+ Katip.logFM severity "Response sent"+ pure responseReceived++-- | Logs the request, response, and elapsed time in Katip's context+middleware :: Katip.KatipContext m => Katip.Severity -> MiddlewareT m+middleware severity application request send = do+ start <- liftIO $ Clock.getTime Clock.Monotonic+ loggableRequest <- liftIO $ toLoggableRequest request+ Katip.katipAddContext (Katip.sl "request" loggableRequest) $ do+ Katip.logFM severity "Request received"+ application request (withLoggedResponse severity start send)
+ test/DebugApplication.hs view
@@ -0,0 +1,118 @@+{-# 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)
+ test/DebugScribe.hs view
@@ -0,0 +1,44 @@+{-# 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
+ test/Katip/WaiSpec.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++module Katip.WaiSpec (spec) where++import Data.Foldable (for_)+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 qualified Network.HTTP.Client as Http+import Test.Hspec (Spec, describe, it, runIO, shouldBe, shouldSatisfy)++allSeverities :: [Katip.Severity]+allSeverities = [minBound ..]++spec :: Spec+spec = describe "middleware" $ do+ manager <- runIO $ Http.newManager Http.defaultManagerSettings++ for_ allSeverities $ \severity -> do+ let prettySeverity = Text.unpack . Text.toLower $ Katip.renderSeverity severity++ it ("logs as " <> prettySeverity <> " and adds the request information to the context") $ do+ let message = "Context should be added when severity is " <> Text.pack prettySeverity++ logs <- withDebugApplication severity $ \debugApp ->+ DebugApplication.sendLogRequest manager debugApp "GET" message++ [log1, log2, log3] <- traverse LogEntry.toLogEntry logs++ let expectedRequest =+ LogEntry.Request+ { id = Uuid.nil+ , httpVersion = "HTTP/1.1"+ , remoteHost = "127.0.0.1:1234"+ , isSecure = False+ , method = "GET"+ , path = "log"+ , queryString = [("message", Just message)]+ , bodyLength = "KnownLength 0"+ , headers =+ LogEntry.Headers+ { host = Just "localhost:1234"+ , referer = Nothing+ , userAgent = Nothing+ , range = Nothing+ }+ }++ let expectedLog1 =+ LogEntry+ { logMessage = "Request received"+ , logData =+ LogEntry.LogData+ { response = Nothing+ , request = Just expectedRequest+ }+ , logSeverity = severity+ }+ expectedLog2 =+ LogEntry+ { logMessage = message+ , logData =+ LogEntry.LogData+ { response = Nothing+ , request = Just expectedRequest+ }+ , logSeverity = severity+ }+ expectedLog3 =+ LogEntry+ { logMessage = "Response sent"+ , logData =+ LogEntry.LogData+ { response =+ Just $+ LogEntry.Response+ { elapsedTimeInNanoSeconds = 123+ , status = 202+ }+ , LogEntry.request = Just expectedRequest+ }+ , logSeverity = severity+ }++ log1 `shouldSatisfy` LogEntry.isMostlySameAs expectedLog1+ log2 `shouldSatisfy` LogEntry.isMostlySameAs expectedLog2+ log3 `shouldSatisfy` LogEntry.isMostlySameAs expectedLog3++ it ("logs as " <> prettySeverity <> " and uses a different requestId for every request") $ do+ logs <- withDebugApplication severity $ \debugApp ->+ for_ ["GET", "POST", "PATCH", "PUT", "DELETE"] $ \method -> do+ DebugApplication.sendNoContentRequest manager debugApp method+ DebugApplication.sendNotFoundRequest manager debugApp method+ DebugApplication.sendLogRequest manager debugApp method "Some example log message"++ parsedLogs <- traverse LogEntry.toLogEntry logs++ let requestIds =+ flip Maybe.mapMaybe parsedLogs $ \entry -> do+ _response <- LogEntry.response $ LogEntry.logData entry+ request <- LogEntry.request $ LogEntry.logData entry+ pure $ LogEntry.id request++ originalLength = length requestIds++ uniqueLength = Set.size $ Set.fromList requestIds++ originalLength `shouldBe` 15++ uniqueLength `shouldBe` originalLength++ it ("logs as " <> prettySeverity <> " and has non zero elapsed time") $ do+ logs <- withDebugApplication severity $ \debugApp ->+ for_ ["GET", "POST", "PATCH", "PUT", "DELETE"] $ \method -> do+ DebugApplication.sendNoContentRequest manager debugApp method+ DebugApplication.sendNotFoundRequest manager debugApp method+ DebugApplication.sendLogRequest manager debugApp method "Some example log message"++ parsedLogs <- traverse LogEntry.toLogEntry logs++ let elapsedTimes =+ flip Maybe.mapMaybe parsedLogs $ \entry -> do+ response <- LogEntry.response $ LogEntry.logData entry+ pure $ LogEntry.elapsedTimeInNanoSeconds response++ length elapsedTimes `shouldBe` 15++ elapsedTimes `shouldSatisfy` all (> 0)
+ test/LogEntry.hs view
@@ -0,0 +1,102 @@+{-# 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 resp1 resp2 =+ on (==) (fmap status) resp1 resp2+ 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
+ test/Main.hs view
@@ -0,0 +1,7 @@+module Main (main) where++import qualified Spec+import Test.Hspec (hspec, parallel)++main :: IO ()+main = hspec $ parallel Spec.spec
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -Wno-missing-export-lists -F -pgmF hspec-discover -optF --module-name=Spec #-}