wai-extra 3.0.2 → 3.0.2.1
raw patch · 3 files changed
+69/−80 lines, 3 files
Files
- Network/Wai/Middleware/RequestLogger.hs +64/−76
- test/WaiExtraTest.hs +4/−3
- wai-extra.cabal +1/−1
Network/Wai/Middleware/RequestLogger.hs view
@@ -28,7 +28,7 @@ import System.Log.FastLogger import Network.HTTP.Types as H import Data.Maybe (fromMaybe)-import Data.Monoid (mconcat)+import Data.Monoid (mconcat, (<>)) import Data.Time (getCurrentTime, diffUTCTime) import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)@@ -125,20 +125,6 @@ logStdoutDev :: Middleware logStdoutDev = unsafePerformIO $ mkRequestLogger def --- no black or white which are expected to be existing terminal colors.-colors0 :: [Color]-colors0 = [- Green- , Yellow- , Blue- , Magenta- , Cyan- ]--rotateColors :: [Color] -> ([Color], Color)-rotateColors [] = error "Impossible! There must be colors!"-rotateColors (c:cs) = (cs ++ [c], c)- -- | Prints a message using the given callback function for each request. -- This is not for serious production use- it is inefficient. -- It immediately consumes a POST body and fills it back in and is otherwise inefficient@@ -147,42 +133,60 @@ -- This meanst that you can accurately see the interleaving of requests. -- And if the app crashes you have still logged the request. -- However, if you are simulating 10 simultaneous users you may find this confusing.--- The request and response are connected by color on Unix and also by the request path. -- -- This is lower-level - use 'logStdoutDev' unless you need greater control. -- -- Example ouput: ----- > GET search :: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8--- >--- > Status: 200 OK. search--- >--- > GET static/css/normalize.css :: text/css,*/*;q=0.1--- > GET [("LXwioiBG","")]+-- > GET search+-- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8+-- > Status: 200 OK 0.010555s -- >--- > Status: 304 Not Modified. static/css/normalize.css+-- > GET static/css/normalize.css+-- > Params: [("LXwioiBG","")]+-- > Accept: text/css,*/*;q=0.1+-- > Status: 304 Not Modified 0.010555s detailedMiddleware :: Callback -> Bool -> IO Middleware-detailedMiddleware cb useColors = do- getAddColor <-- if not useColors then return (return return) else do- icolors <- newIORef colors0- return $ do- color <- liftIO $ atomicModifyIORef icolors rotateColors- return $ ansiColor color- return $ detailedMiddleware' cb getAddColor+detailedMiddleware cb useColors =+ let (ansiColor, ansiMethod, ansiStatusCode) =+ if useColors+ then (ansiColor', ansiMethod', ansiStatusCode')+ else (\_ t -> [t], (:[]), \_ t -> [t]) -ansiColor :: Color -> BS.ByteString -> [BS.ByteString]-ansiColor color bs = [- pack $ setSGRCode [SetColor Foreground Vivid color]- , bs- , pack $ setSGRCode [Reset]- ]+ in return $ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode +ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]+ansiColor' color bs =+ [ pack $ setSGRCode [SetColor Foreground Dull color]+ , bs+ , pack $ setSGRCode [Reset]+ ]++-- | Tags http method with a unique color.+ansiMethod' :: BS.ByteString -> [BS.ByteString]+ansiMethod' m = case m of+ "GET" -> ansiColor' Cyan m+ "HEAD" -> ansiColor' Cyan m+ "PUT" -> ansiColor' Green m+ "POST" -> ansiColor' Yellow m+ "DELETE" -> ansiColor' Red m+ _ -> ansiColor' Magenta m++ansiStatusCode' :: BS.ByteString -> BS.ByteString -> [BS.ByteString]+ansiStatusCode' c t = case S8.take 1 c of+ "2" -> ansiColor' Green t+ "3" -> ansiColor' Yellow t+ "4" -> ansiColor' Red t+ "5" -> ansiColor' Magenta t+ _ -> ansiColor' Blue t+ detailedMiddleware' :: Callback- -> IO (BS.ByteString -> [BS.ByteString])+ -> (Color -> BS.ByteString -> [BS.ByteString])+ -> (BS.ByteString -> [BS.ByteString])+ -> (BS.ByteString -> BS.ByteString -> [BS.ByteString]) -> Middleware-detailedMiddleware' cb getAddColor app req sendResponse = do+detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do let mlen = lookup "content-length" (requestHeaders req) >>= readInt (req', body) <- case mlen of@@ -214,25 +218,22 @@ _ -> return (req, []) postParams <- if requestMethod req `elem` ["GET", "HEAD"]- then return []- else do postParams <- liftIO $ allPostParams body- return $ collectPostParams postParams+ then return []+ else do postParams <- liftIO $ allPostParams body+ return $ collectPostParams postParams let getParams = map emptyGetParam $ queryString req-- addColor <- getAddColor- let accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req+ accept = fromMaybe "" $ lookup "Accept" $ 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 request immediately.- liftIO $ cb $ mconcat $ map toLogStr $ addColor (requestMethod req) ++- [ " "- , rawPathInfo req- , " :: "- , accept- , paramsToBS "GET " getParams- , paramsToBS "POST " postParams- , "\n"- ]+ liftIO $ cb $ mconcat $ map toLogStr $+ ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] +++ params +++ ansiColor White " Accept: " ++ [accept, "\n"] t0 <- getCurrentTime app req' $ \rsp -> do@@ -240,27 +241,18 @@ case rsp of ResponseRaw{} -> True _ -> False+ stCode = statusBS rsp+ stMsg = msgBS rsp t1 <- getCurrentTime -- log the status of the response- -- this is color coordinated with the request logging- -- also includes the request path to connect it to the request unless isRaw $ cb $ mconcat $ map toLogStr $- addColor "Status: " ++ statusBS rsp ++- [ " "- , msgBS rsp- , ". "- , pack $ show $ diffUTCTime t1 t0- , ". "- , rawPathInfo req -- if you need help matching the 2 logging statements- , "\n"- ]+ ansiColor White " Status: " +++ ansiStatusCode stCode (stCode <> " " <> stMsg) +++ [" ", pack $ show $ diffUTCTime t1 t0, "\n"]+ sendResponse rsp where- paramsToBS prefix params =- if null params then ""- else BS.concat ["\n", prefix, pack (show params)]- allPostParams body = case getRequestBodyType req of Nothing -> return ([], [])@@ -278,19 +270,15 @@ collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param] collectPostParams (postParams, files) = postParams ++- map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files+ map (\(k,v) -> (k, "FILE: " <> fileName v)) files readInt bs = case reads $ unpack bs of (i, _):_ -> Just (i :: Int) [] -> Nothing -statusBS :: Response -> [BS.ByteString]-statusBS rsp =- if status >= 400 then ansiColor Red bs else [bs]- where- bs = pack $ show status- status = statusCode $ responseStatus rsp+statusBS :: Response -> BS.ByteString+statusBS = pack . show . statusCode . responseStatus msgBS :: Response -> BS.ByteString msgBS = statusMessage . responseStatus
test/WaiExtraTest.hs view
@@ -547,10 +547,11 @@ } where params = [("foo", "bar"), ("baz", "bin")]- -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)+ -- FIXME change back once we include post parameter output in logging+ -- postOutput = T.pack $ "POST \nAccept: \n Params: " ++ (show params) -- the time cannot be known, so match around it- postOutput = ("POST / :: \nStatus: 200 OK. 0", "s. /\n")- getOutput params' = ("GET /location :: \nGET " <> T.pack (show params') <> "\nStatus: 200 OK. 0", "s. /location\n")+ postOutput = ("POST /\n Accept: \n Status: 200 OK 0", "s\n")+ getOutput params' = ("GET /location\n Params: " <> T.pack (show params') <> "\n Accept: \n Status: 200 OK 0", "s\n") debugApp (beginning, ending) req send = do iactual <- I.newIORef mempty
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 3.0.2+Version: 3.0.2.1 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: MIT