git.iko.soy/typeable/wai
on master help sign in
Merge pull request #283 from nikuda/master
47d960cGreg Weber
wai-extra/Network/Wai/Middleware/RequestLogger.hs+65−77
compare with master
unifiedsplit
@@ -28,7 +28,7 @@ import Network.Wai (Request(..), Middleware, responseStatus, Response, responseH
28import System.Log.FastLogger
28import System.Log.FastLogger
29import Network.HTTP.Types as H
29import Network.HTTP.Types as H
30import Data.Maybe (fromMaybe)
30import Data.Maybe (fromMaybe)
31−import Data.Monoid (mconcat)
31+import Data.Monoid (mconcat, (<>))
32import Data.Time (getCurrentTime, diffUTCTime)
32import Data.Time (getCurrentTime, diffUTCTime)
33
33
34import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
34import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
@@ -125,20 +125,6 @@ logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSo
125logStdoutDev :: Middleware
125logStdoutDev :: Middleware
126logStdoutDev = unsafePerformIO $ mkRequestLogger def
126logStdoutDev = unsafePerformIO $ mkRequestLogger def
127
127
128−-- no black or white which are expected to be existing terminal colors.
129−colors0 :: [Color]
130−colors0 = [
131− Green
132− , Yellow
133− , Blue
134− , Magenta
135− , Cyan
136− ]
137−
138−rotateColors :: [Color] -> ([Color], Color)
139−rotateColors [] = error "Impossible! There must be colors!"
140−rotateColors (c:cs) = (cs ++ [c], c)
141−
142-- | Prints a message using the given callback function for each request.
128-- | Prints a message using the given callback function for each request.
143-- This is not for serious production use- it is inefficient.
129-- This is not for serious production use- it is inefficient.
144-- It immediately consumes a POST body and fills it back in and is otherwise inefficient
130-- It immediately consumes a POST body and fills it back in and is otherwise inefficient
@@ -147,42 +133,60 @@ rotateColors (c:cs) = (cs ++ [c], c)
147-- This meanst that you can accurately see the interleaving of requests.
133-- This meanst that you can accurately see the interleaving of requests.
148-- And if the app crashes you have still logged the request.
134-- And if the app crashes you have still logged the request.
149-- However, if you are simulating 10 simultaneous users you may find this confusing.
135-- However, if you are simulating 10 simultaneous users you may find this confusing.
150−-- The request and response are connected by color on Unix and also by the request path.
151--
136--
152-- This is lower-level - use 'logStdoutDev' unless you need greater control.
137-- This is lower-level - use 'logStdoutDev' unless you need greater control.
153--
138--
154-- Example ouput:
139-- Example ouput:
155--
140--
141+-- > GET search
156−-- > GET search :: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
142+-- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
157−-- >
158−-- > Status: 200 OK. search
143+-- > Status: 200 OK 0.010555s
159−-- >
160−-- > GET static/css/normalize.css :: text/css,*/*;q=0.1
161−-- > GET [("LXwioiBG","")]
162-- >
144-- >
145+-- > GET static/css/normalize.css
146+-- > Params: [("LXwioiBG","")]
147+-- > Accept: text/css,*/*;q=0.1
163−-- > Status: 304 Not Modified. static/css/normalize.css
148+-- > Status: 304 Not Modified 0.010555s
164
149
165detailedMiddleware :: Callback -> Bool -> IO Middleware
150detailedMiddleware :: Callback -> Bool -> IO Middleware
166−detailedMiddleware cb useColors = do
151+detailedMiddleware cb useColors =
167− getAddColor <-
152+ let (ansiColor, ansiMethod, ansiStatusCode) =
168− if not useColors then return (return return) else do
153+ if useColors
169− icolors <- newIORef colors0
154+ then (ansiColor', ansiMethod', ansiStatusCode')
170− return $ do
155+ else (\_ t -> [t], (:[]), \_ t -> [t])
171− color <- liftIO $ atomicModifyIORef icolors rotateColors
156+
172− return $ ansiColor color
173− return $ detailedMiddleware' cb getAddColor
157+ in return $ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode
174−
158+
175−ansiColor :: Color -> BS.ByteString -> [BS.ByteString]
159+ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]
176−ansiColor color bs = [
160+ansiColor' color bs =
177− pack $ setSGRCode [SetColor Foreground Vivid color]
161+ [ pack $ setSGRCode [SetColor Foreground Dull color]
178− , bs
162+ , bs
179− , pack $ setSGRCode [Reset]
163+ , pack $ setSGRCode [Reset]
180− ]
164+ ]
165+
166+-- | Tags http method with a unique color.
167+ansiMethod' :: BS.ByteString -> [BS.ByteString]
168+ansiMethod' m = case m of
169+ "GET" -> ansiColor' Cyan m
170+ "HEAD" -> ansiColor' Cyan m
171+ "PUT" -> ansiColor' Green m
172+ "POST" -> ansiColor' Yellow m
173+ "DELETE" -> ansiColor' Red m
174+ _ -> ansiColor' Magenta m
175+
176+ansiStatusCode' :: BS.ByteString -> BS.ByteString -> [BS.ByteString]
177+ansiStatusCode' c t = case S8.take 1 c of
178+ "2" -> ansiColor' Green t
179+ "3" -> ansiColor' Yellow t
180+ "4" -> ansiColor' Red t
181+ "5" -> ansiColor' Magenta t
182+ _ -> ansiColor' Blue t
181
183
182detailedMiddleware' :: Callback
184detailedMiddleware' :: Callback
185+ -> (Color -> BS.ByteString -> [BS.ByteString])
186+ -> (BS.ByteString -> [BS.ByteString])
183− -> IO (BS.ByteString -> [BS.ByteString])
187+ -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])
184 -> Middleware
188 -> Middleware
185−detailedMiddleware' cb getAddColor app req sendResponse = do
189+detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do
186 let mlen = lookup "content-length" (requestHeaders req) >>= readInt
190 let mlen = lookup "content-length" (requestHeaders req) >>= readInt
187 (req', body) <-
191 (req', body) <-
188 case mlen of
192 case mlen of
@@ -214,25 +218,22 @@ detailedMiddleware' cb getAddColor app req sendResponse = do
214 _ -> return (req, [])
218 _ -> return (req, [])
215
219
216 postParams <- if requestMethod req `elem` ["GET", "HEAD"]
220 postParams <- if requestMethod req `elem` ["GET", "HEAD"]
217− then return []
221+ then return []
218− else do postParams <- liftIO $ allPostParams body
222+ else do postParams <- liftIO $ allPostParams body
219− return $ collectPostParams postParams
223+ return $ collectPostParams postParams
220
224
221 let getParams = map emptyGetParam $ queryString req
225 let getParams = map emptyGetParam $ queryString req
222−
223− addColor <- getAddColor
224− let accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req
226+ accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req
227+ params = let par | not $ null postParams = [pack (show postParams)]
228+ | not $ null getParams = [pack (show getParams)]
229+ | otherwise = []
230+ in if null par then [""] else ansiColor White " Params: " <> par <> ["\n"]
225
231
226 -- log the request immediately.
232 -- log the request immediately.
227− liftIO $ cb $ mconcat $ map toLogStr $ addColor (requestMethod req) ++
233+ liftIO $ cb $ mconcat $ map toLogStr $
228− [ " "
229− , rawPathInfo req
234+ ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++
230− , " :: "
235+ params ++
231− , accept
236+ ansiColor White " Accept: " ++ [accept, "\n"]
232− , paramsToBS "GET " getParams
233− , paramsToBS "POST " postParams
234− , "\n"
235− ]
236
237
237 t0 <- getCurrentTime
238 t0 <- getCurrentTime
238 app req' $ \rsp -> do
239 app req' $ \rsp -> do
@@ -240,27 +241,18 @@ detailedMiddleware' cb getAddColor app req sendResponse = do
240 case rsp of
241 case rsp of
241 ResponseRaw{} -> True
242 ResponseRaw{} -> True
242 _ -> False
243 _ -> False
244+ stCode = statusBS rsp
245+ stMsg = msgBS rsp
243 t1 <- getCurrentTime
246 t1 <- getCurrentTime
244
247
245 -- log the status of the response
248 -- log the status of the response
246− -- this is color coordinated with the request logging
247− -- also includes the request path to connect it to the request
248 unless isRaw $ cb $ mconcat $ map toLogStr $
249 unless isRaw $ cb $ mconcat $ map toLogStr $
249− addColor "Status: " ++ statusBS rsp ++
250+ ansiColor White " Status: " ++
250− [ " "
251+ ansiStatusCode stCode (stCode <> " " <> stMsg) ++
251− , msgBS rsp
252− , ". "
253− , pack $ show $ diffUTCTime t1 t0
252+ [" ", pack $ show $ diffUTCTime t1 t0, "\n"]
254− , ". "
253+
255− , rawPathInfo req -- if you need help matching the 2 logging statements
256− , "\n"
257− ]
258 sendResponse rsp
254 sendResponse rsp
259 where
255 where
260− paramsToBS prefix params =
261− if null params then ""
262− else BS.concat ["\n", prefix, pack (show params)]
263−
264 allPostParams body =
256 allPostParams body =
265 case getRequestBodyType req of
257 case getRequestBodyType req of
266 Nothing -> return ([], [])
258 Nothing -> return ([], [])
@@ -278,19 +270,15 @@ detailedMiddleware' cb getAddColor app req sendResponse = do
278
270
279 collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
271 collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
280 collectPostParams (postParams, files) = postParams ++
272 collectPostParams (postParams, files) = postParams ++
281− map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files
273+ map (\(k,v) -> (k, "FILE: " <> fileName v)) files
282
274
283 readInt bs =
275 readInt bs =
284 case reads $ unpack bs of
276 case reads $ unpack bs of
285 (i, _):_ -> Just (i :: Int)
277 (i, _):_ -> Just (i :: Int)
286 [] -> Nothing
278 [] -> Nothing
287
279
288−statusBS :: Response -> [BS.ByteString]
280+statusBS :: Response -> BS.ByteString
289−statusBS rsp =
290− if status >= 400 then ansiColor Red bs else [bs]
291− where
292− bs = pack $ show status
293− status = statusCode $ responseStatus rsp
281+statusBS = pack . show . statusCode . responseStatus
294
282
295msgBS :: Response -> BS.ByteString
283msgBS :: Response -> BS.ByteString
296msgBS = statusMessage . responseStatus
284msgBS = statusMessage . responseStatus
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 Params: " <> T.pack (show params') <> "\n Accept: \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