@@ -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
@@ -163,26 +149,40 @@ rotateColors (c:cs) = (cs ++ [c], c)
163149-- > Status: 304 Not Modified. static/css/normalize.css
164150
165151detailedMiddleware :: 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
152+detailedMiddleware cb useColors =
153+ let colorMethod s = if useColors
154+ then colorMethod' s
155+ else [s]
156+ in return $ detailedMiddleware' cb colorMethod
174157
175158ansiColor :: Color -> BS.ByteString -> [BS.ByteString]
176−ansiColor color bs = [
177− pack $ setSGRCode [SetColor Foreground Vivid color]
178− , bs
179− , pack $ setSGRCode [Reset]
180− ]
159+ansiColor color bs =
160+ [ pack $ setSGRCode [SetColor Foreground Dull color]
161+ , bs
162+ , pack $ setSGRCode [Reset]
163+ ]
164+
165+-- | 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
181181
182182detailedMiddleware' :: Callback
183− -> IO (BS.ByteString -> [BS.ByteString])
183+ -> (BS.ByteString -> [BS.ByteString])
184184 -> Middleware
185−detailedMiddleware' cb getAddColor app req sendResponse = do
185+detailedMiddleware' cb colorMethod app req sendResponse = do
186186 let mlen = lookup "content-length" (requestHeaders req) >>= readInt
187187 (req', body) <-
188188 case mlen of
@@ -214,21 +214,21 @@ detailedMiddleware' cb getAddColor app req sendResponse = do
214214 _ -> return (req, [])
215215
216216 postParams <- if requestMethod req `elem` ["GET", "HEAD"]
217− then return []
218− else do postParams <- liftIO $ allPostParams body
219− return $ collectPostParams postParams
217+ then return []
218+ else do postParams <- liftIO $ allPostParams body
219+ return $ collectPostParams postParams
220220
221221 let getParams = map emptyGetParam $ queryString req
222−
223− addColor <- getAddColor
224− let accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req
222+ accept = fromMaybe "" $ lookup "Accept" $ requestHeaders req
225223
226224 -- log the request immediately.
227− liftIO $ cb $ mconcat $ map toLogStr $ addColor (requestMethod req) ++
225+ liftIO $ cb $ mconcat $ map toLogStr $ colorMethod (requestMethod req) ++
228226 [ " "
229227 , rawPathInfo req
230− , " :: "
231− , accept
228+ , "\n"
229+ ]
230+ ++ ansiColor White " Accept: " ++
231+ [ accept
232232 , paramsToBS "GET " getParams
233233 , paramsToBS "POST " postParams
234234 , "\n"
@@ -240,19 +240,18 @@ detailedMiddleware' cb getAddColor app req sendResponse = do
240240 case rsp of
241241 ResponseRaw{} -> True
242242 _ -> False
243+ stCode = statusBS rsp
244+ stMsg = msgBS rsp
243245 t1 <- getCurrentTime
244246
245247 -- log the status of the response
246248 -- this is color coordinated with the request logging
247249 -- also includes the request path to connect it to the request
248250 unless isRaw $ cb $ mconcat $ map toLogStr $
249− addColor "Status: " ++ statusBS rsp ++
251+ ansiColor White " Status: " ++
252+ colorStatusCode stCode (stCode <> " " <> stMsg) ++
250253 [ " "
251− , msgBS rsp
252− , ". "
253254 , pack $ show $ diffUTCTime t1 t0
254− , ". "
255− , rawPathInfo req -- if you need help matching the 2 logging statements
256255 , "\n"
257256 ]
258257 sendResponse rsp
@@ -278,19 +277,15 @@ detailedMiddleware' cb getAddColor app req sendResponse = do
278277
279278 collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param]
280279 collectPostParams (postParams, files) = postParams ++
281− map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files
280+ map (\(k,v) -> (k, "FILE: " <> fileName v)) files
282281
283282 readInt bs =
284283 case reads $ unpack bs of
285284 (i, _):_ -> Just (i :: Int)
286285 [] -> Nothing
287286
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
287+statusBS :: Response -> BS.ByteString
288+statusBS = pack . show . statusCode . responseStatus
294289
295290msgBS :: Response -> BS.ByteString
296291msgBS = statusMessage . responseStatus