@@ -70,7 +70,7 @@ logCallback cb app req = do
7070toBS :: H.Ascii -> BS.ByteString
7171toBS = id
7272
73−-- no black or white which are expected to be used already
73+-- no black or white which are expected to be existing terminal colors.
7474colors :: IORef [Color]
7575colors = unsafePerformIO $ newIORef $ [
7676 Red
@@ -81,34 +81,59 @@ colors = unsafePerformIO $ newIORef $ [
8181 , Cyan
8282 ]
8383
84+rotateColors :: [Color] -> ([Color], Color)
85+rotateColors [] = error "Impossible! There must be colors!"
86+rotateColors (c:cs) = (cs ++ [c], c)
87+
8488-- | Prints a message using the given callback function for each request.
8589-- This is not for serious production use- it is inefficient.
8690-- It immediately consumes a POST body and fills it back in and is otherwise inefficient
8791--
8892-- Note that it logs the request immediately when it is received.
89−-- This means if the app crashes you have still logged the request.
93+-- This meanst that you can accurately see the interleaving of requests.
94+-- And if the app crashes you have still logged the request.
9095-- However, if you are simulating 10 simultaneous users you may find this confusing.
96+-- The request and response are connected by color on Unix and also by the request path.
97+--
98+-- This is lower-level - use "logStdoutDev" unless you need greater control.
99+--
100+-- Example ouput:
101+--
102+-- GET search
103+-- Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8
91104--
92−-- This is lower-level - use "logStdoutDev" unless you need this greater control
105+-- Status: 200 OK. search
106+--
107+-- GET static/css/normalize.css
108+-- Accept: text/css,*/*;q=0.1
109+-- GET [("LXwioiBG","")]
110+--
111+-- Status: 304 Not Modified. static/css/normalize.css
93112logCallbackDev :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message.
94113 -> Middleware
95114logCallbackDev cb app req = do
96115 let mlen = lookup "content-length" (requestHeaders req) >>= readInt
97116 (req', body) <-
98117 case mlen of
118+ -- log the request body if it is small
99119 Just len | len <= 2048 -> do
100− body <- requestBody req C.$$ CL.consume
101− let req' = req { requestBody = CL.sourceList body }
102− return (req', body)
120+ body <- requestBody req C.$$ CL.consume
121+ -- logging the body here consumes it, so fill it back up
122+ -- obviously not efficient, but this is the development logger
123+ let req' = req { requestBody = CL.sourceList body }
124+ return (req', body)
103125 _ -> return (req, [])
126+
104127 postParams <- if any (requestMethod req ==) ["GET", "HEAD"]
105128 then return []
106129 else do postParams <- liftIO $ allPostParams body
107130 return $ collectPostParams postParams
131+
108132 let getParams = map emptyGetParam $ queryString req
109133
110− color <- liftIO $ atomicModifyIORef colors (\(c:cs) -> (cs ++ [c], c))
134+ color <- liftIO $ atomicModifyIORef colors rotateColors
111135
136+ -- log the request immediately.
112137 liftIO $ cb $ BS.concat $ ansiColor color (requestMethod req) ++
113138 [ " "
114139 , rawPathInfo req
@@ -120,9 +145,11 @@ logCallbackDev cb app req = do
120145 , "\n"
121146 ]
122147
123− -- The body was consumed. Fill it back up so it is available again
124148 rsp <- app req'
125149
150+ -- log the status of the response
151+ -- this is color coordinated with the request logging
152+ -- also includes the request path to connect it to the request
126153 liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [
127154 sCode rsp
128155 , " "
@@ -140,6 +167,7 @@ logCallbackDev cb app req = do
140167 ]
141168 sCode = pack . show . statusCode . responseStatus
142169 msg = statusMessage . responseStatus
170+
143171 paramsToBS prefix params =
144172 if null params then ""
145173 else BS.concat ["\n", prefix, pack (show params)]