@@ -28,7 +28,7 @@ import Network.Wai (Request(..), Middleware, responseStatus, Response, responseH
2828import System.Log.FastLogger
2929import Network.HTTP.Types as H
3030import Data.Maybe (fromMaybe)
31−import Data.Monoid (mconcat)
31+import Data.Monoid (mconcat, (<>))
3232import Data.Time (getCurrentTime, diffUTCTime)
3333
3434import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File, getRequestBodyType)
@@ -125,20 +125,6 @@ logStdout = unsafePerformIO $ mkRequestLogger def { outputFormat = Apache FromSo
125125logStdoutDev :: Middleware
126126logStdoutDev = unsafePerformIO $ mkRequestLogger def
127127
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−
142128-- | Prints a message using the given callback function for each request.
143129-- This is not for serious production use- it is inefficient.
144130-- 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)
147133-- This meanst that you can accurately see the interleaving of requests.
148134-- And if the app crashes you have still logged the request.
149135-- 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.
151136--
152137-- This is lower-level - use 'logStdoutDev' unless you need greater control.
153138--
154139-- Example ouput:
155140--
156−-- > GET search :: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
157−-- >
158−-- > Status: 200 OK. search
159−-- >
160−-- > GET static/css/normalize.css :: text/css,*/*;q=0.1
161−-- > GET [("LXwioiBG","")]
141+-- > GET search
142+-- > Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
143+-- > Status: 200 OK 0.010555s
162144-- >
163−-- > Status: 304 Not Modified. static/css/normalize.css
145+-- > GET static/css/normalize.css
146+-- > Params: [("LXwioiBG","")]
147+-- > Accept: text/css,*/*;q=0.1
148+-- > Status: 304 Not Modified 0.010555s
164149
165150detailedMiddleware :: Callback -> Bool -> IO Middleware
166−detailedMiddleware cb useColors = do
167− getAddColor <-
168− if not useColors then return (return return) else do
169− icolors <- newIORef colors0
170− return $ do
171− color <- liftIO $ atomicModifyIORef icolors rotateColors
172− return $ ansiColor color
173− return $ detailedMiddleware' cb getAddColor
174−
175−ansiColor :: Color -> BS.ByteString -> [BS.ByteString]
176−ansiColor color bs = [
177− pack $ setSGRCode [SetColor Foreground Vivid color]
178− , bs
179− , pack $ setSGRCode [Reset]
180− ]
151+detailedMiddleware cb useColors =
152+ let (ansiColor, ansiMethod, ansiStatusCode) =
153+ if useColors
154+ then (ansiColor', ansiMethod', ansiStatusCode')
155+ else (\_ t -> [t], (:[]), \_ t -> [t])
156+
157+ in return $ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode
158+
159+ansiColor' :: Color -> BS.ByteString -> [BS.ByteString]
160+ansiColor' color bs =
161+ [ pack $ setSGRCode [SetColor Foreground Dull color]
162+ , bs
163+ , pack $ setSGRCode [Reset]
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
181183
182184detailedMiddleware' :: Callback
183− -> IO (BS.ByteString -> [BS.ByteString])
185+ -> (Color -> BS.ByteString -> [BS.ByteString])
186+ -> (BS.ByteString -> [BS.ByteString])
187+ -> (BS.ByteString -> BS.ByteString -> [BS.ByteString])
184188 -> Middleware
185−detailedMiddleware' cb getAddColor app req sendResponse = do
189+detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do
186190 let mlen = lookup "content-length" (requestHeaders req) >>= readInt
187191 (req', body) <-
188192 case mlen of
@@ -214,25 +218,22 @@ detailedMiddleware' cb getAddColor app req sendResponse = do
214218 _ -> return (req, [])
215219
216220 postParams <- if requestMethod req `elem` ["GET", "HEAD"]
217− then return []
218− else do postParams <- liftIO $ allPostParams body
219− return $ collectPostParams postParams
221+ then return []
222+ else do postParams <- liftIO $ allPostParams body
223+ return $ collectPostParams postParams
220224
221225 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"]
225231
226232 -- log the request immediately.
227− liftIO $ cb $ mconcat $ map toLogStr $ addColor (requestMethod req) ++
228− [ " "
229− , rawPathInfo req
230− , " :: "
231− , accept
232− , paramsToBS "GET " getParams
233− , paramsToBS "POST " postParams
234− , "\n"
235− ]
233+ liftIO $ cb $ mconcat $ map toLogStr $
234+ ansiMethod (requestMethod req) ++ [" ", rawPathInfo req, "\n"] ++
235+ params ++
236+ ansiColor White " Accept: " ++ [accept, "\n"]
236237
237238 t0 <- getCurrentTime
238239 app req' $ \rsp -> do
@@ -240,27 +241,18 @@ detailedMiddleware' cb getAddColor app req sendResponse = do
240241 case rsp of
241242 ResponseRaw{} -> True
242243 _ -> False
244+ stCode = statusBS rsp
245+ stMsg = msgBS rsp
243246 t1 <- getCurrentTime
244247
245248 -- 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
248249 unless isRaw $ cb $ mconcat $ map toLogStr $
249− addColor "Status: " ++ statusBS rsp ++
250− [ " "
251− , msgBS rsp
252− , ". "
253− , pack $ show $ diffUTCTime t1 t0
254− , ". "
255− , rawPathInfo req -- if you need help matching the 2 logging statements
256− , "\n"
257− ]
250+ ansiColor White " Status: " ++
251+ ansiStatusCode stCode (stCode <> " " <> stMsg) ++
252+ [" ", pack $ show $ diffUTCTime t1 t0, "\n"]
253+
258254 sendResponse rsp
259255 where
260− paramsToBS prefix params =
261− if null params then ""
262− else BS.concat ["\n", prefix, pack (show params)]
263−
264256 allPostParams body =
265257 case getRequestBodyType req of
266258 Nothing -> return ([], [])
@@ -278,19 +270,15 @@ detailedMiddleware' cb getAddColor app req sendResponse = do
278270
279271 collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
280272 collectPostParams (postParams, files) = postParams ++
281− map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files
273+ map (\(k,v) -> (k, "FILE: " <> fileName v)) files
282274
283275 readInt bs =
284276 case reads $ unpack bs of
285277 (i, _):_ -> Just (i :: Int)
286278 [] -> Nothing
287279
288−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
280+statusBS :: Response -> BS.ByteString
281+statusBS = pack . show . statusCode . responseStatus
294282
295283msgBS :: Response -> BS.ByteString
296284msgBS = statusMessage . responseStatus