diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for katip-wai + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,74 @@ +# katip-wai [![ci](https://github.com/Disco-Dave/katip-wai/actions/workflows/ci.yaml/badge.svg)](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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/katip-wai.cabal b/katip-wai.cabal new file mode 100644 --- /dev/null +++ b/katip-wai.cabal @@ -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 + +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 diff --git a/src/Katip/Wai.hs b/src/Katip/Wai.hs new file mode 100644 --- /dev/null +++ b/src/Katip/Wai.hs @@ -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) diff --git a/test/DebugApplication.hs b/test/DebugApplication.hs new file mode 100644 --- /dev/null +++ b/test/DebugApplication.hs @@ -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) diff --git a/test/DebugScribe.hs b/test/DebugScribe.hs new file mode 100644 --- /dev/null +++ b/test/DebugScribe.hs @@ -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 diff --git a/test/Katip/WaiSpec.hs b/test/Katip/WaiSpec.hs new file mode 100644 --- /dev/null +++ b/test/Katip/WaiSpec.hs @@ -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) diff --git a/test/LogEntry.hs b/test/LogEntry.hs new file mode 100644 --- /dev/null +++ b/test/LogEntry.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,7 @@ +module Main (main) where + +import qualified Spec +import Test.Hspec (hspec, parallel) + +main :: IO () +main = hspec $ parallel Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -Wno-missing-export-lists -F -pgmF hspec-discover -optF --module-name=Spec #-}