git.iko.soy/typeable/wai
on master help sign in
Respecting useColor setting, corrected params output, tests fix.
commit66da7321849e34b649266d95d18ead89e5f0bf07 authorAnte Salinovic <antes@qti.qualcomm.com> dateThu 21 Aug 2014, 12:56 (12 years ago) parent353e4c2
2 files changed+42−45
compare with master
unifiedsplit
wai-extra/Network/Wai/Middleware/RequestLogger.hs+38−42 wai-extra/test/WaiExtraTest.hs+4−3
wai-extra/Network/Wai/Middleware/RequestLogger.hs+38−42
@@ -150,39 +150,44 @@ logStdoutDev = unsafePerformIO $ mkRequestLogger def
150150
151151detailedMiddleware :: Callback -> Bool -> IO Middleware
152152detailedMiddleware cb useColors =
153− let colorMethod s = if useColors
154− then colorMethod' s
155− else [s]
156− in return $ detailedMiddleware' cb colorMethod
153+ let (ansiColor, ansiMethod, ansiStatusCode) =
154+ if useColors
155+ then (ansiColor', ansiMethod', ansiStatusCode')
156+ else (\_ t -> [t], (:[]), \_ t -> [t])
157157
158−ansiColor :: Color -> BS.ByteString -> [BS.ByteString]
159−ansiColor color bs =
158+ in return $ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode
159+
160+ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]
161+ansiColor' color bs =
160162 [ pack $ setSGRCode [SetColor Foreground Dull color]
161163 , bs
162164 , pack $ setSGRCode [Reset]
163165 ]
164166
165167-- | Tags http method with a unique color.
166−colorMethod' :: BS.ByteString -> [BS.ByteString]
167−colorMethod' m = case m of
168− "GET" -> ansiColor Cyan m
169− "PUT" -> ansiColor Green m
170− "POST" -> ansiColor Yellow m
171− "DELETE" -> ansiColor Red m
172− _ -> ansiColor Magenta m
173−
174−colorStatusCode :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
175−colorStatusCode c t = case S8.take 1 c of
176− "2" -> ansiColor Green t
177− "3" -> ansiColor Yellow t
178− "4" -> ansiColor Red t
179− "5" -> ansiColor Magenta t
180− _ -> ansiColor Blue t
168+ansiMethod' :: BS.ByteString -> [BS.ByteString]
169+ansiMethod' m = case m of
170+ "GET" -> ansiColor' Cyan m
171+ "HEAD" -> ansiColor' Cyan m
172+ "PUT" -> ansiColor' Green m
173+ "POST" -> ansiColor' Yellow m
174+ "DELETE" -> ansiColor' Red m
175+ _ -> ansiColor' Magenta m
176+
177+ansiStatusCode' :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
178+ansiStatusCode' c t = case S8.take 1 c of
179+ "2" -> ansiColor' Green t
180+ "3" -> ansiColor' Yellow t
181+ "4" -> ansiColor' Red t
182+ "5" -> ansiColor' Magenta t
183+ _ -> ansiColor' Blue t
181184
182185detailedMiddleware' :: Callback
186+ -> (Color -> BS.ByteString -> [BS.ByteString])
183187 -> (BS.ByteString -> [BS.ByteString])
188+ -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])
184189 -> Middleware
185−detailedMiddleware' cb colorMethod app req sendResponse = do
190+detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do
186191 let mlen = lookup "content-length" (requestHeaders req) >>= readInt
187192 (req', body) <-
188193 case mlen of
@@ -220,19 +225,16 @@ detailedMiddleware' cb colorMethod app req sendResponse = do
220225
221226 let getParams = map emptyGetParam $ queryString req
222227 accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req
228+ params = let par | not $ null postParams = [pack (show postParams)]
229+ | not $ null getParams = [pack (show getParams)]
230+ | otherwise = []
231+ in if null par then [""] else ansiColor White " Params: " <> par <> ["\n"]
223232
224233 -- log the request immediately.
225− liftIO $ cb $ mconcat $ map toLogStr $ colorMethod (requestMethod req) ++
226− [ " "
227− , rawPathInfo req
228− , "\n"
229− ]
230− ++ ansiColor White " Accept: " ++
231− [ accept
232− , paramsToBS "GET " getParams
233− , paramsToBS "POST " postParams
234− , "\n"
235− ]
234+ liftIO $ cb $ mconcat $ map toLogStr $
235+ ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++
236+ ansiColor White " Accept: " ++ [accept, "\n"] ++
237+ params
236238
237239 t0 <- getCurrentTime
238240 app req' $ \rsp -> do
@@ -249,17 +251,11 @@ detailedMiddleware' cb colorMethod app req sendResponse = do
249251 -- also includes the request path to connect it to the request
250252 unless isRaw $ cb $ mconcat $ map toLogStr $
251253 ansiColor White " Status: " ++
252− colorStatusCode stCode (stCode <> " " <> stMsg) ++
253− [ " "
254− , pack $ show $ diffUTCTime t1 t0
255− , "\n"
256− ]
254+ ansiStatusCode stCode (stCode <> " " <> stMsg) ++
255+ [" ", pack $ show $ diffUTCTime t1 t0, "\n"]
256+
257257 sendResponse rsp
258258 where
259− paramsToBS prefix params =
260− if null params then ""
261− else BS.concat ["\n", prefix, pack (show params)]
262−
263259 allPostParams body =
264260 case getRequestBodyType req of
265261 Nothing -> return ([], [])
wai-extra/test/WaiExtraTest.hs+4−3
@@ -547,10 +547,11 @@ caseDebugRequestBody = do
547547 }
548548 where
549549 params = [("foo", "bar"), ("baz", "bin")]
550− -- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)
550+ -- FIXME change back once we include post parameter output in logging
551+ -- postOutput = T.pack $ "POST \nAccept: \n Params: " ++ (show params)
551552 -- the time cannot be known, so match around it
552− postOutput = ("POST / :: \nStatus: 200 OK. 0", "s. /\n")
553− getOutput params' = ("GET /location :: \nGET " <> T.pack (show params') <> "\nStatus: 200 OK. 0", "s. /location\n")
553+ postOutput = ("POST /\n Accept: \n Status: 200 OK 0", "s\n")
554+ getOutput params' = ("GET /location\n Accept: \n Params: " <> T.pack (show params') <> "\n Status: 200 OK 0", "s\n")
554555
555556 debugApp (beginning, ending) req send = do
556557 iactual <- I.newIORef mempty