@@ -13,12 +13,14 @@ module Network.Wai.Middleware.RequestLogger
1313 , destination
1414 , OutputFormat (..)
1515 , OutputFormatter
16+ , OutputFormatterWithDetails
1617 , Destination (..)
1718 , Callback
1819 , IPAddrSource (..)
1920 ) where
2021
2122import System.IO (Handle, stdout)
23+import qualified Blaze.ByteString.Builder as B
2224import qualified Data.ByteString as BS
2325import Data.ByteString.Char8 (pack, unpack)
2426import Control.Monad.IO.Class (liftIO)
@@ -27,7 +29,7 @@ import System.Log.FastLogger
2729import Network.HTTP.Types as H
2830import Data.Maybe (fromMaybe)
2931import Data.Monoid (mconcat, (<>))
30−import Data.Time (getCurrentTime, diffUTCTime)
32+import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)
3133import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File
3234 , getRequestBodyType)
3335import qualified Data.ByteString.Lazy as LBS
@@ -35,7 +37,7 @@ import qualified Data.ByteString.Char8 as S8
3537import System.Console.ANSI
3638import Data.IORef.Lifted
3739import System.IO.Unsafe
38−import Network.Wai.Internal (Response (ResponseRaw))
40+import Network.Wai.Internal (Response (..))
3941import Data.Default.Class (Default (def))
4042import Network.Wai.Logger
4143import Network.Wai.Middleware.RequestLogger.Internal
@@ -44,8 +46,11 @@ import Data.Text.Encoding (decodeUtf8')
4446data OutputFormat = Apache IPAddrSource
4547 | Detailed Bool -- ^ use colors?
4648 | CustomOutputFormat OutputFormatter
49+ | CustomOutputFormatWithDetails OutputFormatterWithDetails
4750
4851type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr
52+type OutputFormatterWithDetails =
53+ ZonedDate -> Request -> Status -> Maybe Integer -> NominalDiffTime -> [S8.ByteString] -> B.Builder -> LogStr
4954
5055data Destination = Handle Handle
5156 | Logger LoggerSet
@@ -93,8 +98,11 @@ mkRequestLogger RequestLoggerSettings{..} = do
9398 (\str -> callback str >> flusher)
9499 useColors
95100 CustomOutputFormat formatter -> do
101+ getDate <- getDateGetter flusher
102+ return $ customMiddleware callback getDate formatter
103+ CustomOutputFormatWithDetails formatter -> do
96104 getdate <- getDateGetter flusher
97− return $ customMiddleware callback getdate formatter
105+ return $ customMiddlewareWithDetails callback getdate formatter
98106
99107apacheMiddleware :: ApacheLoggerActions -> Middleware
100108apacheMiddleware ala app req sendResponse = app req $ \res -> do
@@ -113,6 +121,22 @@ customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> d
113121 liftIO $ cb $ formatter date req (responseStatus res) Nothing
114122 sendResponse res
115123
124+customMiddlewareWithDetails :: Callback -> IO ZonedDate -> OutputFormatterWithDetails -> Middleware
125+customMiddlewareWithDetails cb getdate formatter app req sendResponse = do
126+ (req', reqBody) <- getRequestBody req
127+ t0 <- getCurrentTime
128+ app req' $ \res -> do
129+ t1 <- getCurrentTime
130+ date <- liftIO getdate
131+ -- We use Nothing for the response size since we generally don't know it
132+ builderIO <- newIORef ""
133+ res' <- recordChunks builderIO res
134+ rspRcv <- sendResponse res'
135+ _ <- liftIO . cb .
136+ formatter date req' (responseStatus res') Nothing (t1 `diffUTCTime` t0) reqBody =<<
137+ readIORef builderIO
138+ return rspRcv
139+
116140-- | Production request logger middleware.
117141{-# NOINLINE logStdout #-}
118142logStdout :: Middleware
@@ -182,6 +206,40 @@ ansiStatusCode' c t = case S8.take 1 c of
182206 "5" -> ansiColor' Magenta t
183207 _ -> ansiColor' Blue t
184208
209+recordChunks :: IORef B.Builder -> Response -> IO Response
210+recordChunks i (ResponseStream s h sb) =
211+ return . ResponseStream s h $ (\send flush -> sb (\b -> modifyIORef i (<> b) >> send b) flush)
212+recordChunks i (ResponseBuilder s h b) =
213+ modifyIORef i (<> b) >> (return $ ResponseBuilder s h b)
214+recordChunks _ r =
215+ return r
216+
217+getRequestBody :: Request -> IO (Request, [S8.ByteString])
218+getRequestBody req = do
219+ let loop front = do
220+ bs <- requestBody req
221+ if S8.null bs
222+ then return $ front []
223+ else loop $ front . (bs:)
224+ body <- loop id
225+ -- logging the body here consumes it, so fill it back up
226+ -- obviously not efficient, but this is the development logger
227+ --
228+ -- Note: previously, we simply used CL.sourceList. However,
229+ -- that meant that you could read the request body in twice.
230+ -- While that in itself is not a problem, the issue is that,
231+ -- in production, you wouldn't be able to do this, and
232+ -- therefore some bugs wouldn't show up during testing. This
233+ -- implementation ensures that each chunk is only returned
234+ -- once.
235+ ichunks <- newIORef body
236+ let rbody = atomicModifyIORef ichunks $ \chunks ->
237+ case chunks of
238+ [] -> ([], S8.empty)
239+ x:y -> (y, x)
240+ let req' = req { requestBody = rbody }
241+ return (req', body)
242+
185243detailedMiddleware' :: Callback
186244 -> (Color -> BS.ByteString -> [BS.ByteString])
187245 -> (BS.ByteString -> [BS.ByteString])
@@ -192,30 +250,7 @@ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse
192250 (req', body) <-
193251 case mlen of
194252 -- log the request body if it is small
195− Just len | len <= 2048 -> do
196− let loop front = do
197− bs <- requestBody req
198− if S8.null bs
199− then return $ front []
200− else loop $ front . (bs:)
201− body <- loop id
202− -- logging the body here consumes it, so fill it back up
203− -- obviously not efficient, but this is the development logger
204− --
205− -- Note: previously, we simply used CL.sourceList. However,
206− -- that meant that you could read the request body in twice.
207− -- While that in itself is not a problem, the issue is that,
208− -- in production, you wouldn't be able to do this, and
209− -- therefore some bugs wouldn't show up during testing. This
210− -- implementation ensures that each chunk is only returned
211− -- once.
212− ichunks <- newIORef body
213− let rbody = atomicModifyIORef ichunks $ \chunks ->
214− case chunks of
215− [] -> ([], S8.empty)
216− x:y -> (y, x)
217− let req' = req { requestBody = rbody }
218− return (req', body)
253+ Just len | len <= 2048 -> getRequestBody req
219254 _ -> return (req, [])
220255
221256 let reqbodylog _ = if null body then [""] else ansiColor White " Request Body: " <> body <> ["\n"]