← Back to branch summary

~ubuntu-branches/ubuntu/utopic/haskell-wai-extra/utopic-proposed

« back to all changes in this revision

Viewing changes to Network/Wai/Middleware/RequestLogger.hs

  • Committer: Package Import Robot
  • Author(s): Clint Adams
  • Date: 2014-06-06 11:40:45 UTC
  • mfrom: (15.1.1 sid)
  • Revision ID: package-import@ubuntu.com-20140606114045-cc7h7xuui844a1l0
Tags: 3.0.0-1
New upstream version.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Middleware/RequestLogger.hs
34
34
import qualified Data.ByteString.Lazy as LBS
35
35
import qualified Data.ByteString.Char8 as S8
36
36
 
37
 
import qualified Data.Conduit as C
38
 
import qualified Data.Conduit.List as CL
39
 
 
40
37
import System.Console.ANSI
41
38
import Data.IORef.Lifted
42
39
import System.IO.Unsafe
43
40
 
44
 
import Data.Default (Default (def))
 
41
import Data.Default.Class (Default (def))
45
42
import Network.Wai.Logger
46
43
import Network.Wai.Middleware.RequestLogger.Internal
47
44
 
96
93
            return $ customMiddleware callback getdate formatter
97
94
 
98
95
apacheMiddleware :: ApacheLoggerActions -> Middleware
99
 
apacheMiddleware ala app req = do
100
 
    res <- app req
 
96
apacheMiddleware ala app req sendResponse = app req $ \res -> do
101
97
    let msize = lookup "content-length" (responseHeaders res) >>= readInt'
102
98
        readInt' bs =
103
99
            case S8.readInteger bs of
104
100
                Just (i, "") -> Just i
105
101
                _ -> Nothing
106
102
    apacheLogger ala req (responseStatus res) msize
107
 
    return res
 
103
    sendResponse res
108
104
 
109
105
customMiddleware :: Callback -> IO ZonedDate -> OutputFormatter -> Middleware
110
 
customMiddleware cb getdate formatter app req = do
111
 
    res <- app req
 
106
customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> do
112
107
    date <- liftIO getdate
113
108
    -- We use Nothing for the response size since we generally don't know it
114
109
    liftIO $ cb $ formatter date req (responseStatus res) Nothing
115
 
    return res
 
110
    sendResponse res
116
111
 
117
112
-- | Production request logger middleware.
118
113
-- Implemented on top of "logCallback", but prints to 'stdout'
130
125
-- no black or white which are expected to be existing terminal colors.
131
126
colors0 :: [Color]
132
127
colors0 = [
133
 
    Red 
134
 
  , Green 
135
 
  , Yellow 
136
 
  , Blue 
137
 
  , Magenta 
 
128
    Green
 
129
  , Yellow
 
130
  , Blue
 
131
  , Magenta
138
132
  , Cyan
139
133
  ]
140
134
 
170
164
detailedMiddleware :: Callback -> Bool -> IO Middleware
171
165
detailedMiddleware cb useColors = do
172
166
    getAddColor <-
173
 
        if useColors
174
 
            then do
 
167
        if not useColors then return (return return) else do
175
168
                icolors <- newIORef colors0
176
169
                return $ do
177
170
                    color <- liftIO $ atomicModifyIORef icolors rotateColors
178
171
                    return $ ansiColor color
179
 
            else return (return return)
180
172
    return $ detailedMiddleware' cb getAddColor
181
173
 
182
174
ansiColor :: Color -> BS.ByteString -> [BS.ByteString]
189
181
detailedMiddleware' :: Callback
190
182
                    -> IO (BS.ByteString -> [BS.ByteString])
191
183
                    -> Middleware
192
 
detailedMiddleware' cb getAddColor app req = do
 
184
detailedMiddleware' cb getAddColor app req sendResponse = do
193
185
    let mlen = lookup "content-length" (requestHeaders req) >>= readInt
194
186
    (req', body) <-
195
187
        case mlen of
196
188
            -- log the request body if it is small
197
189
            Just len | len <= 2048 -> do
198
 
                 body <- requestBody req C.$$ CL.consume
 
190
                 let loop front = do
 
191
                        bs <- requestBody req
 
192
                        if S8.null bs
 
193
                            then return $ front []
 
194
                            else loop $ front . (bs:)
 
195
                 body <- loop id
199
196
                 -- logging the body here consumes it, so fill it back up
200
197
                 -- obviously not efficient, but this is the development logger
201
198
                 --
207
204
                 -- implementation ensures that each chunk is only returned
208
205
                 -- once.
209
206
                 ichunks <- newIORef body
210
 
                 let rbody = do
211
 
                        chunks <- readIORef ichunks
 
207
                 let rbody = atomicModifyIORef ichunks $ \chunks ->
212
208
                        case chunks of
213
 
                            [] -> return ()
214
 
                            x:xs -> do
215
 
                                writeIORef ichunks xs
216
 
                                C.yield x
217
 
                                rbody
 
209
                            [] -> ([], S8.empty)
 
210
                            x:y -> (y, x)
218
211
                 let req' = req { requestBody = rbody }
219
212
                 return (req', body)
220
213
            _ -> return (req, [])
240
233
        , "\n"
241
234
        ]
242
235
 
243
 
    rsp <- app req'
 
236
    app req' $ \rsp -> do
244
237
 
245
 
    -- 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
 
    liftIO $ cb $ mconcat $ map toLogStr $
249
 
        addColor "Status: " ++ statusBS rsp ++
250
 
        [ " "
251
 
        , msgBS rsp
252
 
        , ". "
253
 
        , rawPathInfo req -- if you need help matching the 2 logging statements
254
 
        , "\n"
255
 
        ]
256
 
    return rsp
 
238
        -- log the status of the response
 
239
        -- this is color coordinated with the request logging
 
240
        -- also includes the request path to connect it to the request
 
241
        liftIO $ cb $ mconcat $ map toLogStr $
 
242
            addColor "Status: " ++ statusBS rsp ++
 
243
            [ " "
 
244
            , msgBS rsp
 
245
            , ". "
 
246
            , rawPathInfo req -- if you need help matching the 2 logging statements
 
247
            , "\n"
 
248
            ]
 
249
        sendResponse rsp
257
250
  where
258
251
    paramsToBS prefix params =
259
252
      if null params then ""
262
255
    allPostParams body =
263
256
        case getRequestBodyType req of
264
257
            Nothing -> return ([], [])
265
 
            Just rbt -> CL.sourceList body C.$$ sinkRequestBody lbsBackEnd rbt
 
258
            Just rbt -> do
 
259
                ichunks <- newIORef body
 
260
                let rbody = atomicModifyIORef ichunks $ \chunks ->
 
261
                        case chunks of
 
262
                            [] -> ([], S8.empty)
 
263
                            x:y -> (y, x)
 
264
                sinkRequestBody lbsBackEnd rbt rbody
266
265
 
267
266
    emptyGetParam :: (BS.ByteString, Maybe BS.ByteString) -> (BS.ByteString, BS.ByteString)
268
267
    emptyGetParam (k, Just v) = (k,v)
279
278
 
280
279
statusBS :: Response -> [BS.ByteString]
281
280
statusBS rsp =
282
 
    if status > 400 then ansiColor Red bs else [bs]
 
281
    if status >= 400 then ansiColor Red bs else [bs]
283
282
  where
284
283
    bs = pack $ show status
285
284
    status = statusCode $ responseStatus rsp