diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for wai-extra +## 3.1.3 + +* Add a `DetailedWithSettings` output format for `RequestLogger` that allows to hide requests and modify query parameters [#826](https://github.com/yesodweb/wai/pull/826) + ## 3.1.2 * Remove an extraneous dot from the error message for `defaultRequestSizeLimitSettings` diff --git a/Network/Wai/Middleware/RequestLogger.hs b/Network/Wai/Middleware/RequestLogger.hs --- a/Network/Wai/Middleware/RequestLogger.hs +++ b/Network/Wai/Middleware/RequestLogger.hs @@ -12,6 +12,7 @@ , autoFlush , destination , OutputFormat (..) + , DetailedSettings(..) , OutputFormatter , OutputFormatterWithDetails , OutputFormatterWithDetailsAndHeaders @@ -33,7 +34,7 @@ ) import System.Log.FastLogger import Network.HTTP.Types as H -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Monoid (mconcat, (<>)) import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime) import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File @@ -50,13 +51,39 @@ import Network.Wai.Header (contentLength) import Data.Text.Encoding (decodeUtf8') +-- | The logging format. data OutputFormat = Apache IPAddrSource | Detailed Bool -- ^ use colors? + | DetailedWithSettings DetailedSettings -- ^ @since 3.1.3 | CustomOutputFormat OutputFormatter | CustomOutputFormatWithDetails OutputFormatterWithDetails | CustomOutputFormatWithDetailsAndHeaders OutputFormatterWithDetailsAndHeaders +-- | Settings for the `Detailed` `OutputFormat`. +-- +-- `mModifyParams` allows you to pass a function to hide confidential +-- information (such as passwords) from the logs. If result is `Nothing`, then +-- the parameter is hidden. For example: +-- > myformat = Detailed True (Just hidePasswords) +-- > where hidePasswords p@(k,v) = if k = "password" then (k, "***REDACTED***") else p +-- +-- `mFilterRequests` allows you to filter which requests are logged, based on +-- the request and response. +-- +-- @since 3.1.3 +data DetailedSettings = DetailedSettings + { useColors :: Bool + , mModifyParams :: Maybe (Param -> Maybe Param) + , mFilterRequests :: Maybe (Request -> Response -> Bool) + } +instance Default DetailedSettings where + def = DetailedSettings + { useColors = True + , mModifyParams = Nothing + , mFilterRequests = Nothing + } + type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr type OutputFormatterWithDetails @@ -130,7 +157,11 @@ getdate <- getDateGetter flusher apache <- initLogger ipsrc (LogCallback callback flusher) getdate return $ apacheMiddleware apache - Detailed useColors -> detailedMiddleware callbackAndFlush useColors + Detailed useColors -> + let settings = def { useColors = useColors} + in detailedMiddleware callbackAndFlush settings + DetailedWithSettings settings -> + detailedMiddleware callbackAndFlush settings CustomOutputFormat formatter -> do getDate <- getDateGetter flusher return $ customMiddleware callbackAndFlush getDate formatter @@ -225,14 +256,14 @@ -- > Accept: text/css,*/*;q=0.1 -- > Status: 304 Not Modified 0.010555s -detailedMiddleware :: Callback -> Bool -> IO Middleware -detailedMiddleware cb useColors = +detailedMiddleware :: Callback -> DetailedSettings -> IO Middleware +detailedMiddleware cb settings = let (ansiColor, ansiMethod, ansiStatusCode) = - if useColors + if useColors settings then (ansiColor', ansiMethod', ansiStatusCode') else (\_ t -> [t], (:[]), \_ t -> [t]) - in return $ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode + in return $ detailedMiddleware' cb settings ansiColor ansiMethod ansiStatusCode ansiColor' :: Color -> BS.ByteString -> [BS.ByteString] ansiColor' color bs = @@ -294,54 +325,63 @@ return (req', body) detailedMiddleware' :: Callback + -> DetailedSettings -> (Color -> BS.ByteString -> [BS.ByteString]) -> (BS.ByteString -> [BS.ByteString]) -> (BS.ByteString -> BS.ByteString -> [BS.ByteString]) -> Middleware -detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do - (req', body) <- - -- second tuple item should not be necessary, but a test runner might mess it up - case (requestBodyLength req, contentLength (requestHeaders req)) of - -- log the request body if it is small - (KnownLength len, _) | len <= 2048 -> getRequestBody req - (_, Just len) | len <= 2048 -> getRequestBody req - _ -> return (req, []) - - let reqbodylog _ = if null body then [""] else ansiColor White " Request Body: " <> body <> ["\n"] - reqbody = concatMap (either (const [""]) reqbodylog . decodeUtf8') body - postParams <- if requestMethod req `elem` ["GET", "HEAD"] - then return [] - else do postParams <- liftIO $ allPostParams body - return $ collectPostParams postParams +detailedMiddleware' cb DetailedSettings{..} ansiColor ansiMethod ansiStatusCode app req sendResponse = do + (req', body) <- + -- second tuple item should not be necessary, but a test runner might mess it up + case (requestBodyLength req, contentLength (requestHeaders req)) of + -- log the request body if it is small + (KnownLength len, _) | len <= 2048 -> getRequestBody req + (_, Just len) | len <= 2048 -> getRequestBody req + _ -> return (req, []) - let getParams = map emptyGetParam $ queryString req - accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req - params = let par | not $ null postParams = [pack (show postParams)] - | not $ null getParams = [pack (show getParams)] - | otherwise = [] - in if null par then [""] else ansiColor White " Params: " <> par <> ["\n"] + let reqbodylog _ = if null body || isJust mModifyParams + then [""] + else ansiColor White " Request Body: " <> body <> ["\n"] + reqbody = concatMap (either (const [""]) reqbodylog . decodeUtf8') body + postParams <- if requestMethod req `elem` ["GET", "HEAD"] + then return [] + else do (unmodifiedPostParams, files) <- liftIO $ allPostParams body + let postParams = + case mModifyParams of + Just modifyParams -> mapMaybe modifyParams unmodifiedPostParams + Nothing -> unmodifiedPostParams + return $ collectPostParams (postParams, files) - t0 <- getCurrentTime - app req' $ \rsp -> do - let isRaw = - case rsp of - ResponseRaw{} -> True - _ -> False - stCode = statusBS rsp - stMsg = msgBS rsp - t1 <- getCurrentTime + let getParams = map emptyGetParam $ queryString req + accept = fromMaybe "" $ lookup H.hAccept $ requestHeaders req + params = let par | not $ null postParams = [pack (show postParams)] + | not $ null getParams = [pack (show getParams)] + | otherwise = [] + in if null par then [""] else ansiColor White " Params: " <> par <> ["\n"] - -- log the status of the response - cb $ mconcat $ map toLogStr $ - ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++ - params ++ reqbody ++ - ansiColor White " Accept: " ++ [accept, "\n"] ++ - if isRaw then [] else - ansiColor White " Status: " ++ - ansiStatusCode stCode (stCode <> " " <> stMsg) ++ - [" ", pack $ show $ diffUTCTime t1 t0, "\n"] + t0 <- getCurrentTime + app req' $ \rsp -> do + case mFilterRequests of + Just f | not $ f req' rsp -> pure () + _ -> do + let isRaw = + case rsp of + ResponseRaw{} -> True + _ -> False + stCode = statusBS rsp + stMsg = msgBS rsp + t1 <- getCurrentTime - sendResponse rsp + -- log the status of the response + cb $ mconcat $ map toLogStr $ + ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++ + params ++ reqbody ++ + ansiColor White " Accept: " ++ [accept, "\n"] ++ + if isRaw then [] else + ansiColor White " Status: " ++ + ansiStatusCode stCode (stCode <> " " <> stMsg) ++ + [" ", pack $ show $ diffUTCTime t1 t0, "\n"] + sendResponse rsp where allPostParams body = case getRequestBodyType req of diff --git a/test/WaiExtraSpec.hs b/test/WaiExtraSpec.hs --- a/test/WaiExtraSpec.hs +++ b/test/WaiExtraSpec.hs @@ -65,6 +65,8 @@ it "debug request body" caseDebugRequestBody it "stream file" caseStreamFile it "stream LBS" caseStreamLBS + it "can modify POST params before logging" caseModifyPostParamsInLogs + it "can filter requests in logs" caseFilterRequestsInLogs toRequest :: S8.ByteString -> S8.ByteString -> SRequest toRequest ctype content = SRequest defaultRequest @@ -449,3 +451,77 @@ sres <- request defaultRequest assertStatus 200 sres assertBody "test" sres + +caseModifyPostParamsInLogs :: Assertion +caseModifyPostParamsInLogs = do + let formatUnredacted = DetailedWithSettings $ DetailedSettings False Nothing Nothing + outputUnredacted = [("username", "some_user"), ("password", "dont_show_me")] + formatRedacted = DetailedWithSettings $ DetailedSettings False (Just hidePasswords) Nothing + hidePasswords p@(k,_) = Just $ if k == "password" then (k, "***REDACTED***") else p + outputRedacted = [("username", "some_user"), ("password", "***REDACTED***")] + + testLogs formatUnredacted outputUnredacted + testLogs formatRedacted outputRedacted + where + testLogs :: OutputFormat -> [(String, String)] -> Assertion + testLogs format output = flip runSession (debugApp format output) $ do + let req = toRequest "application/x-www-form-urlencoded" "username=some_user&password=dont_show_me" + res <- srequest req + assertStatus 200 res + + postOutputStart params = TE.encodeUtf8 $ T.toStrict $ "POST /\n Params: " <> (T.pack . show $ params) + postOutputEnd = TE.encodeUtf8 $ T.toStrict "s\n" + + + debugApp format output req send = do + iactual <- I.newIORef mempty + middleware <- mkRequestLogger def + { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs) + , outputFormat = format + } + res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send + actual <- fromLogStr <$> I.readIORef iactual + actual `shouldSatisfy` S.isPrefixOf (postOutputStart output) + actual `shouldSatisfy` S.isSuffixOf postOutputEnd + + return res + +caseFilterRequestsInLogs :: Assertion +caseFilterRequestsInLogs = do + let formatUnfiltered = DetailedWithSettings $ DetailedSettings False Nothing Nothing + formatFiltered = DetailedWithSettings . DetailedSettings False Nothing $ Just hideHealthCheck + pathHidden = "/health-check" + pathNotHidden = "/foobar" + + -- filter is off + testLogs formatUnfiltered pathNotHidden True + testLogs formatUnfiltered pathHidden True + -- filter is on, path does not match + testLogs formatFiltered pathNotHidden True + -- filter is on, path matches + testLogs formatFiltered pathHidden False + where + testLogs :: OutputFormat -> S8.ByteString -> Bool -> Assertion + testLogs format rpath haslogs = flip runSession (debugApp format rpath haslogs) $ do + let req = flip SRequest "" $ setPath defaultRequest rpath + res <- srequest req + assertStatus 200 res + + hideHealthCheck req _res = pathInfo req /= ["health-check"] + + debugApp format rpath haslogs req send = do + iactual <- I.newIORef mempty + middleware <- mkRequestLogger def + { destination = Callback $ \strs -> I.modifyIORef iactual (`mappend` strs) + , outputFormat = format + } + res <- middleware (\_req f -> f $ responseLBS status200 [ ] "") req send + actual <- fromLogStr <$> I.readIORef iactual + if haslogs + then do + actual `shouldSatisfy` S.isPrefixOf ("GET " <> rpath <> "\n") + actual `shouldSatisfy` S.isSuffixOf "s\n" + else + actual `shouldBe` "" + + return res diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -1,5 +1,5 @@ Name: wai-extra -Version: 3.1.2 +Version: 3.1.3 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality: