git.iko.soy/typeable/wai
on master help sign in
Respecting useColor setting, corrected params output, tests fix.
66da732Ante Salinovic
wai-extra/Network/Wai/Middleware/RequestLogger.hs+38−42
compare with master
unifiedsplit
@@ -150,39 +150,44 @@ logStdoutDev = unsafePerformIO $ mkRequestLogger def
150
150
151detailedMiddleware :: Callback -> Bool -> IO Middleware
151detailedMiddleware :: Callback -> Bool -> IO Middleware
152detailedMiddleware cb useColors =
152detailedMiddleware cb useColors =
153+ let (ansiColor, ansiMethod, ansiStatusCode) =
153− let colorMethod s = if useColors
154+ if useColors
154− then colorMethod' s
155+ then (ansiColor', ansiMethod', ansiStatusCode')
155− else [s]
156+ else (\_ t -> [t], (:[]), \_ t -> [t])
156− in return $ detailedMiddleware' cb colorMethod
157
157
158+ in return $ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode
159+
158−ansiColor :: Color -> BS.ByteString -> [BS.ByteString]
160+ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]
159−ansiColor color bs =
161+ansiColor' color bs =
160 [ pack $ setSGRCode [SetColor Foreground Dull color]
162 [ pack $ setSGRCode [SetColor Foreground Dull color]
161 , bs
163 , bs
162 , pack $ setSGRCode [Reset]
164 , pack $ setSGRCode [Reset]
163 ]
165 ]
164
166
165-- | Tags http method with a unique color.
167-- | Tags http method with a unique color.
166−colorMethod' :: BS.ByteString -> [BS.ByteString]
168+ansiMethod' :: BS.ByteString -> [BS.ByteString]
167−colorMethod' m = case m of
169+ansiMethod' m = case m of
168− "GET" -> ansiColor Cyan m
170+ "GET" -> ansiColor' Cyan m
171+ "HEAD" -> ansiColor' Cyan m
169− "PUT" -> ansiColor Green m
172+ "PUT" -> ansiColor' Green m
170− "POST" -> ansiColor Yellow m
173+ "POST" -> ansiColor' Yellow m
171− "DELETE" -> ansiColor Red m
174+ "DELETE" -> ansiColor' Red m
172− _ -> ansiColor Magenta m
175+ _ -> ansiColor' Magenta m
173−
176+
174−colorStatusCode :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
177+ansiStatusCode' :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
175−colorStatusCode c t = case S8.take 1 c of
178+ansiStatusCode' c t = case S8.take 1 c of
176− "2" -> ansiColor Green t
179+ "2" -> ansiColor' Green t
177− "3" -> ansiColor Yellow t
180+ "3" -> ansiColor' Yellow t
178− "4" -> ansiColor Red t
181+ "4" -> ansiColor' Red t
179− "5" -> ansiColor Magenta t
182+ "5" -> ansiColor' Magenta t
180− _ -> ansiColor Blue t
183+ _ -> ansiColor' Blue t
181
184
182detailedMiddleware' :: Callback
185detailedMiddleware' :: Callback
186+ -> (Color -> BS.ByteString -> [BS.ByteString])
183 -> (BS.ByteString -> [BS.ByteString])
187 -> (BS.ByteString -> [BS.ByteString])
188+ -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])
184 -> Middleware
189 -> Middleware
185−detailedMiddleware' cb colorMethod app req sendResponse = do
190+detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do
186 let mlen = lookup "content-length" (requestHeaders req) >>= readInt
191 let mlen = lookup "content-length" (requestHeaders req) >>= readInt
187 (req', body) <-
192 (req', body) <-
188 case mlen of
193 case mlen of
@@ -220,19 +225,16 @@ detailedMiddleware' cb colorMethod app req sendResponse = do
220
225
221 let getParams = map emptyGetParam $ queryString req
226 let getParams = map emptyGetParam $ queryString req
222 accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req
227 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"]
223
232
224 -- log the request immediately.
233 -- log the request immediately.
225− liftIO $ cb $ mconcat $ map toLogStr $ colorMethod (requestMethod req) ++
234+ liftIO $ cb $ mconcat $ map toLogStr $
226− [ " "
227− , rawPathInfo req
235+ ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++
228− , "\n"
229− ]
230− ++ ansiColor White " Accept: " ++
236+ ansiColor White " Accept: " ++ [accept, "\n"] ++
231− [ accept
237+ params
232− , paramsToBS "GET " getParams
233− , paramsToBS "POST " postParams
234− , "\n"
235− ]
236
238
237 t0 <- getCurrentTime
239 t0 <- getCurrentTime
238 app req' $ \rsp -> do
240 app req' $ \rsp -> do
@@ -249,17 +251,11 @@ detailedMiddleware' cb colorMethod app req sendResponse = do
249 -- also includes the request path to connect it to the request
251 -- also includes the request path to connect it to the request
250 unless isRaw $ cb $ mconcat $ map toLogStr $
252 unless isRaw $ cb $ mconcat $ map toLogStr $
251 ansiColor White " Status: " ++
253 ansiColor White " Status: " ++
252− colorStatusCode stCode (stCode <> " " <> stMsg) ++
254+ ansiStatusCode stCode (stCode <> " " <> stMsg) ++
253− [ " "
254− , pack $ show $ diffUTCTime t1 t0
255+ [" ", pack $ show $ diffUTCTime t1 t0, "\n"]
255− , "\n"
256+
256− ]
257 sendResponse rsp
257 sendResponse rsp
258 where
258 where
259− paramsToBS prefix params =
260− if null params then ""
261− else BS.concat ["\n", prefix, pack (show params)]
262−
263 allPostParams body =
259 allPostParams body =
264 case getRequestBodyType req of
260 case getRequestBodyType req of
265 Nothing -> return ([], [])
261 Nothing -> return ([], [])
wai-extra/test/WaiExtraTest.hs+4−3
@@ -547,10 +547,11 @@ caseDebugRequestBody = do
547 }
547 }
548 where
548 where
549 params = [("foo", "bar"), ("baz", "bin")]
549 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)
551 -- the time cannot be known, so match around it
552 -- the time cannot be known, so match around it
552− postOutput = ("POST / :: \nStatus: 200 OK. 0", "s. /\n")
553+ postOutput = ("POST /\n Accept: \n Status: 200 OK 0", "s\n")
553− getOutput params' = ("GET /location :: \nGET " <> T.pack (show params') <> "\nStatus: 200 OK. 0", "s. /location\n")
554+ getOutput params' = ("GET /location\n Accept: \n Params: " <> T.pack (show params') <> "\n Status: 200 OK 0", "s\n")
554
555
555 debugApp (beginning, ending) req send = do
556 debugApp (beginning, ending) req send = do
556 iactual <- I.newIORef mempty
557 iactual <- I.newIORef mempty