wai-extra 3.1.2 → 3.1.3

raw patch · 4 files changed

+167/−47 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• Network/Wai/Middleware/RequestLogger.hs +86/−46
• test/WaiExtraSpec.hs +76/−0
• wai-extra.cabal +1/−1

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

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

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

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