33a7ddf · typeable/wai

git.iko.soy/typeable/wai

on master help sign in

Add detailed custom formatter and JSON formatter

33a7ddfEric Easley11 years ago

wai-extra/Network/Wai/Middleware/RequestLogger.hs+62−27

compare with master

unifiedsplit

@@ -13,12 +13,14 @@ module Network.Wai.Middleware.RequestLogger

13 , destination

14 , OutputFormat (..)

15 , OutputFormatter

16+ , OutputFormatterWithDetails

16 , Destination (..)

17 , Destination (..)

17 , Callback

18 , Callback

18 , IPAddrSource (..)

19 , IPAddrSource (..)

19 ) where

20 ) where

21import System.IO (Handle, stdout)

22import System.IO (Handle, stdout)

23+import qualified Blaze.ByteString.Builder as B

22import qualified Data.ByteString as BS

24import qualified Data.ByteString as BS

23import Data.ByteString.Char8 (pack, unpack)

25import Data.ByteString.Char8 (pack, unpack)

24import Control.Monad.IO.Class (liftIO)

26import Control.Monad.IO.Class (liftIO)

@@ -27,7 +29,7 @@ import System.Log.FastLogger

27import Network.HTTP.Types as H

29import Network.HTTP.Types as H

28import Data.Maybe (fromMaybe)

30import Data.Maybe (fromMaybe)

29import Data.Monoid (mconcat, (<>))

31import Data.Monoid (mconcat, (<>))

30−import Data.Time (getCurrentTime, diffUTCTime)

32+import Data.Time (getCurrentTime, diffUTCTime, NominalDiffTime)

31import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File

33import Network.Wai.Parse (sinkRequestBody, lbsBackEnd, fileName, Param, File

32 , getRequestBodyType)

34 , getRequestBodyType)

33import qualified Data.ByteString.Lazy as LBS

35import qualified Data.ByteString.Lazy as LBS

@@ -35,7 +37,7 @@ import qualified Data.ByteString.Char8 as S8

35import System.Console.ANSI

37import System.Console.ANSI

36import Data.IORef.Lifted

38import Data.IORef.Lifted

37import System.IO.Unsafe

39import System.IO.Unsafe

38−import Network.Wai.Internal (Response (ResponseRaw))

40+import Network.Wai.Internal (Response (..))

39import Data.Default.Class (Default (def))

41import Data.Default.Class (Default (def))

40import Network.Wai.Logger

42import Network.Wai.Logger

41import Network.Wai.Middleware.RequestLogger.Internal

43import Network.Wai.Middleware.RequestLogger.Internal

@@ -44,8 +46,11 @@ import Data.Text.Encoding (decodeUtf8')

44data OutputFormat = Apache IPAddrSource

46data OutputFormat = Apache IPAddrSource

45 | Detailed Bool -- ^ use colors?

47 | Detailed Bool -- ^ use colors?

46 | CustomOutputFormat OutputFormatter

48 | CustomOutputFormat OutputFormatter

49+ | CustomOutputFormatWithDetails OutputFormatterWithDetails

48type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr

51type OutputFormatter = ZonedDate -> Request -> Status -> Maybe Integer -> LogStr

52+type OutputFormatterWithDetails =

53+ ZonedDate -> Request -> Status -> Maybe Integer -> NominalDiffTime -> [S8.ByteString] -> B.Builder -> LogStr

50data Destination = Handle Handle

55data Destination = Handle Handle

51 | Logger LoggerSet

56 | Logger LoggerSet

@@ -93,8 +98,11 @@ mkRequestLogger RequestLoggerSettings{..} = do

93 (\str -> callback str >> flusher)

98 (\str -> callback str >> flusher)

94 useColors

99 useColors

95 CustomOutputFormat formatter -> do

100 CustomOutputFormat formatter -> do

101+ getDate <- getDateGetter flusher

102+ return $ customMiddleware callback getDate formatter

103+ CustomOutputFormatWithDetails formatter -> do

96 getdate <- getDateGetter flusher

104 getdate <- getDateGetter flusher

97− return $ customMiddleware callback getdate formatter

105+ return $ customMiddlewareWithDetails callback getdate formatter

106

99apacheMiddleware :: ApacheLoggerActions -> Middleware

107apacheMiddleware :: ApacheLoggerActions -> Middleware

100apacheMiddleware ala app req sendResponse = app req $ \res -> do

108apacheMiddleware ala app req sendResponse = app req $ \res -> do

@@ -113,6 +121,22 @@ customMiddleware cb getdate formatter app req sendResponse = app req $ \res -> d

113 liftIO $ cb $ formatter date req (responseStatus res) Nothing

121 liftIO $ cb $ formatter date req (responseStatus res) Nothing

114 sendResponse res

122 sendResponse res

115

123

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+

116-- | Production request logger middleware.

140-- | Production request logger middleware.

117{-# NOINLINE logStdout #-}

141{-# NOINLINE logStdout #-}

118logStdout :: Middleware

142logStdout :: Middleware

@@ -182,6 +206,40 @@ ansiStatusCode' c t = case S8.take 1 c of

182 "5" -> ansiColor' Magenta t

206 "5" -> ansiColor' Magenta t

183 _ -> ansiColor' Blue t

207 _ -> ansiColor' Blue t

184

208

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+

185detailedMiddleware' :: Callback

243detailedMiddleware' :: Callback

186 -> (Color -> BS.ByteString -> [BS.ByteString])

244 -> (Color -> BS.ByteString -> [BS.ByteString])

187 -> (BS.ByteString -> [BS.ByteString])

245 -> (BS.ByteString -> [BS.ByteString])

@@ -192,30 +250,7 @@ detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse

192 (req', body) <-

250 (req', body) <-

193 case mlen of

251 case mlen of

194 -- log the request body if it is small

252 -- log the request body if it is small

195− Just len | len <= 2048 -> do

253+ Just len | len <= 2048 -> getRequestBody req

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)

219 _ -> return (req, [])

254 _ -> return (req, [])

220

255

221 let reqbodylog _ = if null body then [""] else ansiColor White " Request Body: " <> body <> ["\n"]

256 let reqbodylog _ = if null body then [""] else ansiColor White " Request Body: " <> body <> ["\n"]

wai-extra/Network/Wai/Middleware/RequestLogger/JSON.hsnew file+99

@@ -0,0 +1,99 @@

1+{-# LANGUAGE RecordWildCards #-}

3+module Network.Wai.Middleware.RequestLogger.JSON (formatAsJSON) where

5+import qualified Blaze.ByteString.Builder as BB

6+import Data.Aeson

7+import Data.CaseInsensitive (original)

8+import Data.Monoid ((<>))

9+import qualified Data.ByteString.Char8 as S8

10+import Data.IP

11+import qualified Data.Text as T

12+import Data.Text (Text)

13+import Data.Text.Encoding (decodeUtf8)

14+import Data.Time (NominalDiffTime)

15+import Data.Word (Word32)

16+import Network.HTTP.Types as H

17+import Network.Socket (SockAddr (..), PortNumber)

18+import Network.Wai

19+import Network.Wai.Middleware.RequestLogger

20+import System.Log.FastLogger (toLogStr)

21+import Text.Printf (printf)

22+

23+formatAsJSON :: OutputFormatterWithDetails

24+formatAsJSON date req status responseSize duration reqBody response =

25+ toLogStr (encode $

26+ object

27+ [ "request" .= requestToJSON duration req reqBody

28+ , "response" .=

29+ object

30+ [ "status" .= statusCode status

31+ , "size" .= responseSize

32+ , "body" .=

33+ if statusCode status >= 400

34+ then Just . decodeUtf8 . BB.toByteString $ response

35+ else Nothing

36+ ]

37+ , "time" .= decodeUtf8 date

38+ ]) <> "\n"

39+

40+word32ToHostAddress :: Word32 -> Text

41+word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress

42+

43+readAsDouble :: String -> Double

44+readAsDouble = read

45+

46+requestToJSON :: NominalDiffTime -> Request -> [S8.ByteString] -> Value

47+requestToJSON duration req reqBody =

48+ object

49+ [ "method" .= decodeUtf8 (requestMethod req)

50+ , "path" .= decodeUtf8 (rawPathInfo req)

51+ , "queryString" .= map queryItemToJSON (queryString req)

52+ , "durationMs" .= (readAsDouble . printf "%.2f" . rationalToDouble $ toRational duration * 1000)

53+ , "size" .= requestBodyLengthToJSON (requestBodyLength req)

54+ , "body" .= decodeUtf8 (S8.concat reqBody)

55+ , "remoteHost" .= sockToJSON (remoteHost req)

56+ , "httpVersion" .= httpVersionToJSON (httpVersion req)

57+ , "headers" .= requestHeadersToJSON (requestHeaders req)

58+ ]

59+ where

60+ rationalToDouble :: Rational -> Double

61+ rationalToDouble = fromRational

62+

63+sockToJSON :: SockAddr -> Value

64+sockToJSON (SockAddrInet pn ha) =

65+ object

66+ [ "port" .= portToJSON pn

67+ , "hostAddress" .= word32ToHostAddress ha

68+ ]

69+sockToJSON (SockAddrInet6 pn _ ha _) =

70+ object

71+ [ "port" .= portToJSON pn

72+ , "hostAddress" .= ha

73+ ]

74+sockToJSON (SockAddrUnix sock) =

75+ object [ "unix" .= sock ]

76+sockToJSON (SockAddrCan i) =

77+ object [ "can" .= i ]

78+

79+queryItemToJSON :: QueryItem -> Value

80+queryItemToJSON (name, mValue) = toJSON (decodeUtf8 name, fmap decodeUtf8 mValue)

81+

82+requestHeadersToJSON :: RequestHeaders -> Value

83+requestHeadersToJSON = toJSON . map hToJ where

84+ -- Redact cookies

85+ hToJ ("Cookie", _) = toJSON ("Cookie" :: Text, "-RDCT-" :: Text)

86+ hToJ hd = headerToJSON hd

87+

88+headerToJSON :: Header -> Value

89+headerToJSON (headerName, header) = toJSON (decodeUtf8 . original $ headerName, decodeUtf8 header)

90+

91+portToJSON :: PortNumber -> Value

92+portToJSON = toJSON . toInteger

93+

94+httpVersionToJSON :: HttpVersion -> Value

95+httpVersionToJSON (HttpVersion major minor) = String $ T.pack (show major) <> "." <> T.pack (show minor)

96+

97+requestBodyLengthToJSON :: RequestBodyLength -> Value

98+requestBodyLengthToJSON ChunkedBody = String "Unknown"

99+requestBodyLengthToJSON (KnownLength l) = toJSON l

wai-extra/wai-extra.cabal+4

@@ -110,6 +110,9 @@ Library

110 , unix-compat

111 , cookie

112 , vault

113+ , zlib

114+ , aeson

115+ , iproute

113

116

114 if os(windows)

117 if os(windows)

115 cpp-options: -DWINDOWS

118 cpp-options: -DWINDOWS

@@ -127,6 +130,7 @@ Library

127 Network.Wai.Middleware.CleanPath

130 Network.Wai.Middleware.CleanPath

128 Network.Wai.Middleware.Local

131 Network.Wai.Middleware.Local

129 Network.Wai.Middleware.RequestLogger

132 Network.Wai.Middleware.RequestLogger

133+ Network.Wai.Middleware.RequestLogger.JSON

130 Network.Wai.Middleware.Gzip

134 Network.Wai.Middleware.Gzip

131 Network.Wai.Middleware.Jsonp

135 Network.Wai.Middleware.Jsonp

132 Network.Wai.Middleware.MethodOverride

136 Network.Wai.Middleware.MethodOverride