a74269c · typeable/wai

git.iko.soy/typeable/wai

implementing log functionality. (#475)

commita74269cac858c97fccff299667e81d5de35fbfa0 authorKazu Yamamoto <kazu@iij.ad.jp> dateThu 3 Dec 2015, 16:26 (11 years ago) parentfa1b1b1

4 files changed+34−13

compare with master

unifiedsplit

warp/Network/Wai/Handler/Warp.hs+10−1 warp/Network/Wai/Handler/Warp/Response.hs+17−6 warp/Network/Wai/Handler/Warp/Run.hs+2−6 warp/Network/Wai/Handler/Warp/Settings.hs+5

warp/Network/Wai/Handler/Warp.hs+10−1

@@ -78,6 +78,7 @@ module Network.Wai.Handler.Warp (

7878 , setProxyProtocolOptional

7979 , setSlowlorisSize

8080 , setHTTP2Disabled

81+ , setLogger

8182 -- ** Getters

8283 , getPort

8384 , getHost

@@ -144,12 +145,13 @@ import Data.ByteString (ByteString)

144145import Data.Maybe (fromMaybe)

145146import Data.Streaming.Network (HostPreference)

146147import qualified Data.Vault.Lazy as Vault

148+import qualified Network.HTTP.Types as H

147149import Network.Socket (SockAddr)

148150import Network.Wai (Request, Response, vault)

149151import Network.Wai.Handler.Warp.Buffer

150152import Network.Wai.Handler.Warp.Date

151−import Network.Wai.Handler.Warp.FileInfoCache

152153import Network.Wai.Handler.Warp.FdCache

154+import Network.Wai.Handler.Warp.FileInfoCache

153155import Network.Wai.Handler.Warp.Header

154156import Network.Wai.Handler.Warp.Request

155157import Network.Wai.Handler.Warp.Response

@@ -383,6 +385,13 @@ setSlowlorisSize x y = y { settingsSlowlorisSize = x }

383385setHTTP2Disabled :: Settings -> Settings

384386setHTTP2Disabled y = y { settingsHTTP2Enabled = False }

385387

388+-- | Setting a log function.

389+--

390+-- Since 3.X.X

391+setLogger :: (Request -> H.Status -> Maybe Integer -> IO ())

392+ -> Settings -> Settings

393+setLogger lgr y = y { settingsLogger = lgr }

394+

386395-- | Explicitly pause the slowloris timeout.

387396--

388397-- This is useful for cases where you partially consume a request body. For

warp/Network/Wai/Handler/Warp/Response.hs+17−6

@@ -61,6 +61,7 @@ import qualified Network.Wai.Handler.Warp.FileInfoCache as I

6161import Network.Wai.Handler.Warp.Header

6262import Network.Wai.Handler.Warp.IO (toBufIOWith)

6363import Network.Wai.Handler.Warp.ResponseHeader

64+import Network.Wai.Handler.Warp.Settings

6465import qualified Network.Wai.Handler.Warp.Timeout as T

6566import Network.Wai.Handler.Warp.Types

6667import Network.Wai.Internal

@@ -150,7 +151,7 @@ fileRangeSized s0 hs0 mPart mRange fileSize = (s, hs, beg, len)

150151-- ['responseRaw' :: ('IO' 'ByteString' -> ('ByteString' -> 'IO' ()) -> 'IO' ()) -> 'Response' -> 'Response']

151152-- No header is added and no Transfer-Encoding: is applied.

152153

153−sendResponse :: ByteString -- ^ default server value

154+sendResponse :: Settings

154155 -> Connection

155156 -> InternalInfo

156157 -> Request -- ^ HTTP request.

@@ -158,7 +159,7 @@ sendResponse :: ByteString -- ^ default server value

158159 -> IO ByteString -- ^ source from client, for raw response

159160 -> Response -- ^ HTTP response including status code and response header.

160161 -> IO Bool -- ^ Returing True if the connection is persistent.

161−sendResponse defServer conn ii req reqidxhdr src response = do

162+sendResponse settings conn ii req reqidxhdr src response = do

162163 hs <- addServerAndDate hs0

163164 if hasBody s then do

164165 -- The response to HEAD does not have body.

@@ -167,14 +168,20 @@ sendResponse defServer conn ii req reqidxhdr src response = do

167168 -- and status, the response to HEAD is processed here.

168169 --

169170 -- See definition of rsp below for proper body stripping.

170− sendRsp conn ii ver s hs rsp

171+ (ms, mlen) <- sendRsp conn ii ver s hs rsp

172+ case ms of

173+ Nothing -> return ()

174+ Just realStatus -> logger req realStatus mlen

171175 T.tickle th

172176 return ret

173177 else do

174178 sendResponseNoBody conn ver s hs

179+ logger req s Nothing

175180 T.tickle th

176181 return isPersist

177182 where

183+ defServer = settingsServerName settings

184+ logger = settingsLogger settings

178185 ver = httpVersion req

179186 s = responseStatus response

180187 hs0 = sanitizeHeaders $ responseHeaders response

@@ -242,7 +249,7 @@ sendRsp :: Connection

242249 -> H.Status

243250 -> H.ResponseHeaders

244251 -> Rsp

245− -> IO ()

252+ -> IO (Maybe H.Status, Maybe Integer)

246253sendRsp conn ii ver s0 hs0 (RspFile path mPart mRange isHead hook) = do

247254 ex <- fileRange s0 hs0 path mPart mRange get

248255 case ex of

@@ -270,7 +277,8 @@ sendRsp conn ii ver s0 hs0 (RspFile path mPart mRange isHead hook) = do

270277 let fid = FileId path mfd

271278#endif

272279 connSendFile conn fid beg len hook' [lheader]

273− | otherwise ->

280+ return (Just s, Just len)

281+ | otherwise -> do

274282 sendRsp conn ii ver H.status416

275283 (filter (\(k, _) -> k /= "content-length") hs)

276284 (RspBuilder mempty True)

@@ -292,6 +300,7 @@ sendRsp conn _ ver s hs (RspBuilder body needsChunked) = do

292300 buffer = connWriteBuffer conn

293301 size = connBufferSize conn

294302 toBufIOWith buffer size (connSendAll conn) hdrBdy

303+ return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?

295304

296305----------------------------------------------------------------

297306

@@ -315,11 +324,13 @@ sendRsp conn _ ver s hs (RspStream streamingBody needsChunked th) = do

315324 when needsChunked $ send chunkedTransferTerminator

316325 mbs <- finish

317326 maybe (return ()) (sendFragment conn th) mbs

327+ return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?

318328

319329----------------------------------------------------------------

320330

321−sendRsp conn _ _ _ _ (RspRaw withApp src tickle) =

331+sendRsp conn _ _ _ _ (RspRaw withApp src tickle) = do

322332 withApp recv send

333+ return (Nothing, Nothing)

323334 where

324335 recv = do

325336 bs <- src

warp/Network/Wai/Handler/Warp/Run.hs+2−6

@@ -448,9 +448,7 @@ serveHTTP2 app2 app conn ii origAddr transport settings = do

448448 sendErrorResponse addr istatus e = do

449449 status <- readIORef istatus

450450 when status $ void $

451− sendResponse

452− (settingsServerName settings)

453− conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e)

451+ sendResponse settings conn ii (dummyreq addr) defaultIndexRequestHeader (return S.empty) (errorResponse e)

454452

455453 dummyreq addr = defaultRequest { remoteHost = addr }

456454

@@ -482,9 +480,7 @@ serveHTTP2 app2 app conn ii origAddr transport settings = do

482480 -- send more meaningful error messages to the user.

483481 -- However, it may affect performance.

484482 writeIORef istatus False

485− keepAlive <- sendResponse

486− (settingsServerName settings)

487− conn ii req idxhdr (readSource src) res

483+ keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res

488484 writeIORef keepAliveRef keepAlive

489485 return ResponseReceived

490486 keepAlive <- readIORef keepAliveRef

warp/Network/Wai/Handler/Warp/Settings.hs+5

@@ -97,6 +97,10 @@ data Settings = Settings

9797 -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True

9898 --

9999 -- Since 3.1.7.

100+ , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()

101+ -- ^ A log function. Default: no action.

102+ --

103+ -- Since 3.X.X.

100104 }

101105

102106-- | Specify usage of the PROXY protocol.

@@ -130,6 +134,7 @@ defaultSettings = Settings

130134 , settingsProxyProtocol = ProxyProtocolNone

131135 , settingsSlowlorisSize = 2048

132136 , settingsHTTP2Enabled = True

137+ , settingsLogger = \_ _ _ -> return ()

133138 }

134139

135140-- | Apply the logic provided by 'defaultOnException' to determine if an