Blammo-wai 0.0.0.0 → 0.0.0.1
raw patch · 3 files changed
+62/−32 lines, 3 filesdep +monad-logger-aesonPVP ok
version bump matches the API change (PVP)
Dependencies added: monad-logger-aeson
API changes (from Hackage documentation)
Files
- Blammo-wai.cabal +2/−1
- CHANGELOG.md +4/−4
- src/Network/Wai/Middleware/Logging.hs +56/−27
Blammo-wai.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.18 name: Blammo-wai-version: 0.0.0.0+version: 0.0.0.1 license: MIT license-file: LICENSE maintainer: Freckle Education@@ -42,6 +42,7 @@ case-insensitive >=1.2.1.0, clock >=0.8, http-types >=0.12.3,+ monad-logger-aeson >=0.4.0.3, text >=1.2.4.0, unliftio-core >=0.1.2.0, wai >=3.2.2.1
CHANGELOG.md view
@@ -1,9 +1,9 @@-## [_Unreleased_](https://github.com/freckle/blammo/compare/v0.0.0.1...main)+## [_Unreleased_](https://github.com/freckle/blammo/compare/Blammo-wai-v0.0.0.1..main) -## [v0.0.0.1](https://github.com/freckle/blammo/compare/0.0.0.0...v0.0.0.1)+## [v0.0.0.1](https://github.com/freckle/blammo/compare/Blammo-wai-v0.0.0.0...Blammo-wai-v0.0.0.1) -...+- Don't show invalid details when logging raw responses -## [v0.0.0.0](https://github.com/freckle/blammo/tree/v0.0.0.0)+## [v0.0.0.0](https://github.com/freckle/blammo/tree/Blammo-wai-v0.0.0.0/Blammo-wai) First release
src/Network/Wai/Middleware/Logging.hs view
@@ -18,6 +18,7 @@ import Control.Applicative ((<|>)) import Control.Arrow ((***)) import Control.Monad.IO.Unlift (withRunInIO)+import Control.Monad.Logger.Aeson (SeriesElem) import Data.Aeson import qualified Data.Aeson.Compat as Key import qualified Data.Aeson.Compat as KeyMap@@ -34,7 +35,6 @@ import Network.Wai ( Middleware , Request- , Response , rawPathInfo , rawQueryString , remoteHost@@ -43,6 +43,7 @@ , responseHeaders , responseStatus )+import Network.Wai.Internal (Response (..)) import qualified System.Clock as Clock -- | Add context to any logging done from the request-handling thread@@ -144,44 +145,72 @@ app req $ \resp -> do recvd <- respond resp duration <- toMillis . subtract begin <$> getTime- recvd <$ runInIO (runWithLogger env $ logResponse config duration req resp)+ runInIO $+ runWithLogger env $+ if isRaw resp+ then logRawResponse config duration req+ else logResponse config duration req resp+ pure recvd where getTime = Clock.getTime Clock.Monotonic toMillis x = fromIntegral (Clock.toNanoSecs x) / nsPerMs+ isRaw = \case+ ResponseFile {} -> False+ ResponseBuilder {} -> False+ ResponseStream {} -> False+ ResponseRaw {} -> True +logRawResponse :: MonadLogger m => Config -> Double -> Request -> m ()+logRawResponse config@Config {..} duration req =+ logDebugNS cLogSource $ message :# details+ where+ message = requestMessage req "<raw response>"+ details = requestDetails config req <> ["durationMs" .= duration]+ logResponse :: MonadLogger m => Config -> Double -> Request -> Response -> m ()-logResponse Config {..} duration req resp+logResponse config@Config {..} duration req resp | statusCode status >= 500 = logErrorNS cLogSource $ message :# details | statusCode status == 404 = logDebugNS cLogSource $ message :# details | statusCode status >= 400 = logWarnNS cLogSource $ message :# details | otherwise = logDebugNS cLogSource $ message :# details where- message =- decodeUtf8 (requestMethod req)- <> " "- <> decodeUtf8 (rawPathInfo req)- <> " => "- <> pack (show $ statusCode status)- <> " "- <> decodeUtf8 (statusMessage status)-+ message = requestMessage req $ decodeUtf8 (statusMessage status) details =- [ "method" .= decodeUtf8 (requestMethod req)- , "path" .= decodeUtf8 (rawPathInfo req)- , "query" .= decodeUtf8 (rawQueryString req)- , "status"- .= object- [ "code" .= statusCode status- , "message" .= decodeUtf8 (statusMessage status)- ]- , "clientIp" .= cGetClientIp req- , "destinationIp" .= cGetDestinationIp req- , "durationMs" .= duration- , "requestHeaders"- .= headerObject ["authorization", "cookie"] (requestHeaders req)- , "responseHeaders" .= headerObject ["set-cookie"] (responseHeaders resp)- ]+ requestDetails config req+ <> responseDetails resp+ <> ["durationMs" .= duration] + status = responseStatus resp++requestMessage :: Request -> Text -> Text+requestMessage req suffix =+ decodeUtf8 (requestMethod req)+ <> " "+ <> decodeUtf8 (rawPathInfo req)+ <> " => "+ <> suffix++requestDetails :: Config -> Request -> [SeriesElem]+requestDetails Config {..} req =+ [ "method" .= decodeUtf8 (requestMethod req)+ , "path" .= decodeUtf8 (rawPathInfo req)+ , "query" .= decodeUtf8 (rawQueryString req)+ , "clientIp" .= cGetClientIp req+ , "destinationIp" .= cGetDestinationIp req+ , "requestHeaders"+ .= headerObject ["authorization", "cookie"] (requestHeaders req)+ ]++responseDetails :: Response -> [SeriesElem]+responseDetails resp =+ [ "status"+ .= object+ [ "code" .= statusCode status+ , "message" .= decodeUtf8 (statusMessage status)+ ]+ , "responseHeaders" .= headerObject ["set-cookie"] (responseHeaders resp)+ ]+ where status = responseStatus resp headerObject :: [HeaderName] -> [Header] -> Value