@@ -3,49 +3,53 @@
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PackageImports #-}
4{-# LANGUAGE PackageImports #-}
5{-# LANGUAGE PatternGuards #-}
5{-# LANGUAGE PatternGuards #-}
6+{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE TupleSections #-}
9+{-# LANGUAGE ViewPatterns #-}
8{-# OPTIONS_GHC -fno-warn-deprecations #-}
10{-# OPTIONS_GHC -fno-warn-deprecations #-}
10module Network.Wai.Handler.Warp.Run where
12module Network.Wai.Handler.Warp.Run where
12−#if __GLASGOW_HASKELL__ < 709
14+import "iproute" Data.IP (toHostAddress, toHostAddress6)
13−import Control.Applicative ((<$>))
15import Control.Arrow (first)
15import Control.Arrow (first)
16import qualified Control.Concurrent as Conc (yield)
16import qualified Control.Concurrent as Conc (yield)
17import Control.Exception as E
17import Control.Exception as E
18−import Control.Monad (when, unless, void)
19−import Data.ByteString (ByteString)
20import qualified Data.ByteString as S
18import qualified Data.ByteString as S
21import Data.Char (chr)
19import Data.Char (chr)
22−import "iproute" Data.IP (toHostAddress, toHostAddress6)
23import Data.IORef (IORef, newIORef, readIORef, writeIORef)
20import Data.IORef (IORef, newIORef, readIORef, writeIORef)
24import Data.Streaming.Network (bindPortTCP)
21import Data.Streaming.Network (bindPortTCP)
25import Foreign.C.Error (Errno(..), eCONNABORTED)
22import Foreign.C.Error (Errno(..), eCONNABORTED)
26import GHC.IO.Exception (IOException(..))
23import GHC.IO.Exception (IOException(..))
27−import Network (sClose, Socket)
24+import qualified Network.HTTP2 as H2
28−import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
25+import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
26+#if MIN_VERSION_network(3,1,1)
27+import Network.Socket (gracefulClose)
29import qualified Network.Socket.ByteString as Sock
29import qualified Network.Socket.ByteString as Sock
30import Network.Wai
30import Network.Wai
31+import Network.Wai.Internal (ResponseReceived (ResponseReceived))
32+import System.Environment (lookupEnv)
33+import qualified System.TimeManager as T
34+import System.Timeout (timeout)
31import Network.Wai.Handler.Warp.Buffer
36import Network.Wai.Handler.Warp.Buffer
32import Network.Wai.Handler.Warp.Counter
37import Network.Wai.Handler.Warp.Counter
33import qualified Network.Wai.Handler.Warp.Date as D
38import qualified Network.Wai.Handler.Warp.Date as D
34import qualified Network.Wai.Handler.Warp.FdCache as F
39import qualified Network.Wai.Handler.Warp.FdCache as F
35import qualified Network.Wai.Handler.Warp.FileInfoCache as I
40import qualified Network.Wai.Handler.Warp.FileInfoCache as I
36−import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)
41+import Network.Wai.Handler.Warp.HTTP2 (http2)
42+import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
37import Network.Wai.Handler.Warp.Header
43import Network.Wai.Handler.Warp.Header
44+import Network.Wai.Handler.Warp.Imports hiding (readInt)
38import Network.Wai.Handler.Warp.ReadInt
45import Network.Wai.Handler.Warp.ReadInt
39import Network.Wai.Handler.Warp.Recv
46import Network.Wai.Handler.Warp.Recv
40import Network.Wai.Handler.Warp.Request
47import Network.Wai.Handler.Warp.Request
41import Network.Wai.Handler.Warp.Response
48import Network.Wai.Handler.Warp.Response
42import Network.Wai.Handler.Warp.SendFile
49import Network.Wai.Handler.Warp.SendFile
43import Network.Wai.Handler.Warp.Settings
50import Network.Wai.Handler.Warp.Settings
44−import qualified Network.Wai.Handler.Warp.Timeout as T
45import Network.Wai.Handler.Warp.Types
51import Network.Wai.Handler.Warp.Types
46−import Network.Wai.Internal (ResponseReceived (ResponseReceived))
52+
47−import System.Environment (getEnvironment)
48−import System.Timeout (timeout)
50#if WINDOWS
54#if WINDOWS
51import Network.Wai.Handler.Warp.Windows
55import Network.Wai.Handler.Warp.Windows
@@ -54,27 +58,40 @@ import Network.Socket (fdSocket)
56-- | Creating 'Connection' for plain HTTP based on a given socket.
60-- | Creating 'Connection' for plain HTTP based on a given socket.
57−socketConnection :: Socket -> IO Connection
61+socketConnection :: Settings -> Socket -> IO Connection
62+#if MIN_VERSION_network(3,1,1)
63+socketConnection set s = do
58−socketConnection s = do
65+socketConnection _ s = do
59 bufferPool <- newBufferPool
67 bufferPool <- newBufferPool
60 writeBuf <- allocateBuffer bufferSize
68 writeBuf <- allocateBuffer bufferSize
61 let sendall = Sock.sendAll s
69 let sendall = Sock.sendAll s
70+ isH2 <- newIORef False -- HTTP/1.x
62 return Connection {
71 return Connection {
63 connSendMany = Sock.sendMany s
72 connSendMany = Sock.sendMany s
64 , connSendAll = sendall
73 , connSendAll = sendall
65 , connSendFile = sendFile s writeBuf bufferSize sendall
74 , connSendFile = sendFile s writeBuf bufferSize sendall
75+#if MIN_VERSION_network(3,1,1)
78+ let tm = if h2 then settingsGracefulCloseTimeout2 set
79+ else settingsGracefulCloseTimeout1 set
83+ gracefulClose s tm `E.catch` \(E.SomeException _) -> return ()
85+ , connClose = close s
66− , connClose = sClose s >> freeBuffer writeBuf
87+ , connFree = freeBuffer writeBuf
67 , connRecv = receive s bufferPool
88 , connRecv = receive s bufferPool
68 , connRecvBuf = receiveBuf s
89 , connRecvBuf = receiveBuf s
69 , connWriteBuffer = writeBuf
90 , connWriteBuffer = writeBuf
70 , connBufferSize = bufferSize
91 , connBufferSize = bufferSize
73−#if __GLASGOW_HASKELL__ < 702
74−allowInterrupt :: IO ()
75−allowInterrupt = unblock $ return ()
78-- | Run an 'Application' on the given port.
95-- | Run an 'Application' on the given port.
79-- This calls 'runSettings' with 'defaultSettings'.
96-- This calls 'runSettings' with 'defaultSettings'.
80run :: Port -> Application -> IO ()
97run :: Port -> Application -> IO ()
@@ -87,7 +104,7 @@ run p = runSettings defaultSettings { settingsPort = p }
87-- Since 3.0.9
104-- Since 3.0.9
88runEnv :: Port -> Application -> IO ()
105runEnv :: Port -> Application -> IO ()
89runEnv p app = do
106runEnv p app = do
90− mp <- lookup "PORT" <$> getEnvironment
107+ mp <- lookupEnv "PORT"
92 maybe (run p app) runReadPort mp
109 maybe (run p app) runReadPort mp
@@ -104,7 +121,7 @@ runSettings :: Settings -> Application -> IO ()
104runSettings set app = withSocketsDo $
121runSettings set app = withSocketsDo $
106 (bindPortTCP (settingsPort set) (settingsHost set))
123 (bindPortTCP (settingsPort set) (settingsHost set))
108 (\socket -> do
125 (\socket -> do
109 setSocketCloseOnExec socket
126 setSocketCloseOnExec socket
110 runSettingsSocket set socket app)
127 runSettingsSocket set socket app)
@@ -134,10 +151,10 @@ runSettingsSocket set socket app = do
134 setSocketCloseOnExec s
151 setSocketCloseOnExec s
135 -- NoDelay causes an error for AF_UNIX.
152 -- NoDelay causes an error for AF_UNIX.
136 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
137− conn <- socketConnection s
154+ conn <- socketConnection set s
138 return (conn, sa)
155 return (conn, sa)
140− closeListenSocket = sClose socket
157+ closeListenSocket = close socket
142-- | The connection setup action would be expensive. A good example
159-- | The connection setup action would be expensive. A good example
143-- is initialization of TLS.
160-- is initialization of TLS.
@@ -175,15 +192,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),
175runSettingsConnectionMakerSecure set getConnMaker app = do
192runSettingsConnectionMakerSecure set getConnMaker app = do
176 settingsBeforeMainLoop set
193 settingsBeforeMainLoop set
177 counter <- newCounter
194 counter <- newCounter
178− withII0 $ acceptConnection set getConnMaker app counter
195+ withII $ acceptConnection set getConnMaker app counter
180− withII0 action =
197+ withII action =
181 withTimeoutManager $ \tm ->
198 withTimeoutManager $ \tm ->
182 D.withDateCache $ \dc ->
199 D.withDateCache $ \dc ->
183 F.withFdCache fdCacheDurationInSeconds $ \fdc ->
200 F.withFdCache fdCacheDurationInSeconds $ \fdc ->
184 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do
201 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do
185− let ii0 = InternalInfo0 tm dc fdc fic
202+ let ii = InternalInfo tm dc fdc fic
186− action ii0
203+ action ii
188 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
205 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
189 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000
206 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000
@@ -212,13 +229,18 @@ acceptConnection :: Settings
212 -> IO (IO (Connection, Transport), SockAddr)
229 -> IO (IO (Connection, Transport), SockAddr)
213 -> Application
230 -> Application
214 -> Counter
231 -> Counter
215− -> InternalInfo0
232+ -> InternalInfo
217−acceptConnection set getConnMaker app counter ii0 = do
234+acceptConnection set getConnMaker app counter ii = do
218 -- First mask all exceptions in acceptLoop. This is necessary to
235 -- First mask all exceptions in acceptLoop. This is necessary to
219 -- ensure that no async exception is throw between the call to
236 -- ensure that no async exception is throw between the call to
220 -- acceptNewConnection and the registering of connClose.
237 -- acceptNewConnection and the registering of connClose.
239+ -- acceptLoop can be broken by closing the listing socket.
221 void $ mask_ acceptLoop
240 void $ mask_ acceptLoop
241+ -- In some cases, we want to stop Warp here without graceful shutdown.
242+ -- So, async exceptions are allowed here.
243+ -- That's why `finally` is not used.
222 gracefulShutdown set counter
244 gracefulShutdown set counter
224 acceptLoop = do
246 acceptLoop = do
@@ -236,7 +258,7 @@ acceptConnection set getConnMaker app counter ii0 = do
236 case mx of
258 case mx of
237 Nothing -> return ()
259 Nothing -> return ()
238 Just (mkConn, addr) -> do
260 Just (mkConn, addr) -> do
239− fork set mkConn addr app counter ii0
261+ fork set mkConn addr app counter ii
240 acceptLoop
262 acceptLoop
242 acceptNewConnection = do
264 acceptNewConnection = do
@@ -259,54 +281,55 @@ fork :: Settings
259 -> SockAddr
281 -> SockAddr
260 -> Application
282 -> Application
261 -> Counter
283 -> Counter
262− -> InternalInfo0
284+ -> InternalInfo
264−fork set mkConn addr app counter ii0 = settingsFork set $ \ unmask ->
286+fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
287+ -- Call the user-supplied on exception code if any
288+ -- exceptions are thrown.
289+ handle (settingsOnException set Nothing) $
265− -- Run the connection maker to get a new connection, and ensure
290+ -- Run the connection maker to get a new connection, and ensure
266− -- that the connection is closed. If the mkConn call throws an
291+ -- that the connection is closed. If the mkConn call throws an
267− -- exception, we will leak the connection. If the mkConn call is
292+ -- exception, we will leak the connection. If the mkConn call is
268− -- vulnerable to attacks (e.g., Slowloris), we do nothing to
293+ -- vulnerable to attacks (e.g., Slowloris), we do nothing to
269− -- protect the server. It is therefore vital that mkConn is well
294+ -- protect the server. It is therefore vital that mkConn is well
270− -- vetted.
295+ -- vetted.
272− -- We grab the connection before registering timeouts since the
297+ -- We grab the connection before registering timeouts since the
273− -- timeouts will be useless during connection creation, due to the
298+ -- timeouts will be useless during connection creation, due to the
274− -- fact that async exceptions are still masked.
299+ -- fact that async exceptions are still masked.
275− bracket mkConn closeConn $ \(conn, transport) ->
300+ bracket mkConn cleanUp (serve unmask)
302+ cleanUp (conn, _) = connClose conn `finally` connFree conn
277 -- We need to register a timeout handler for this thread, and
304 -- We need to register a timeout handler for this thread, and
278 -- cancel that handler as soon as we exit.
305 -- cancel that handler as soon as we exit.
279− bracket (T.registerKillThread (timeoutManager0 ii0)) T.cancel $ \th ->
306+ serve unmask (conn, transport) = bracket register cancel $ \th -> do
281− let ii1 = toInternalInfo1 ii0 th
282− -- We now have fully registered a connection close handler
307+ -- We now have fully registered a connection close handler in
283− -- in the case of all exceptions, so it is safe to one
308+ -- the case of all exceptions, so it is safe to once again
284− -- again allow async exceptions.
309+ -- allow async exceptions.
285− in unmask .
310+ unmask .
286− -- Call the user-supplied on exception code if any
287− -- exceptions are thrown.
288− handle (settingsOnException set Nothing) .
290− -- Call the user-supplied code for connection open and close events
311+ -- Call the user-supplied code for connection open and
291− bracket (onOpen addr) (onClose addr) $ \goingon ->
313+ bracket (onOpen addr) (onClose addr) $ \goingon ->
293− -- Actually serve this connection.
314+ -- Actually serve this connection. bracket with closeConn
294− -- bracket with closeConn above ensures the connection is closed.
315+ -- above ensures the connection is closed.
295− when goingon $ serveConnection conn ii1 addr transport set app
316+ when goingon $ serveConnection conn ii th addr transport set app
297− closeConn (conn, _transport) = connClose conn
318+ register = T.registerKillThread (timeoutManager ii) (connClose conn)
299 onOpen adr = increase counter >> settingsOnOpen set adr
321 onOpen adr = increase counter >> settingsOnOpen set adr
300 onClose adr _ = decrease counter >> settingsOnClose set adr
322 onClose adr _ = decrease counter >> settingsOnClose set adr
302serveConnection :: Connection
324serveConnection :: Connection
303− -> InternalInfo1
325+ -> InternalInfo
304 -> SockAddr
327 -> SockAddr
305 -> Transport
328 -> Transport
306 -> Settings
329 -> Settings
307 -> Application
330 -> Application
309−serveConnection conn ii1 origAddr transport settings app = do
332+serveConnection conn ii th origAddr transport settings app = do
310 -- fixme: Upgrading to HTTP/2 should be supported.
333 -- fixme: Upgrading to HTTP/2 should be supported.
311 (h2,bs) <- if isHTTP2 transport then
334 (h2,bs) <- if isHTTP2 transport then
312 return (True, "")
335 return (True, "")
@@ -316,19 +339,39 @@ serveConnection conn ii1 origAddr transport settings app = do
316 return (True, bs0)
339 return (True, bs0)
318 return (False, bs0)
341 return (False, bs0)
342+ istatus <- newIORef False
319 if settingsHTTP2Enabled settings && h2 then do
343 if settingsHTTP2Enabled settings && h2 then do
320− recvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
344+ rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
345+ -- This thread becomes the sender in http2 library.
346+ -- In the case of event source, one request comes and one
347+ -- worker gets busy. But it is likely that the receiver does
348+ -- not receive any data at all while the sender is sending
349+ -- output data from the worker. It's not good enough to tickle
350+ -- the time handler in the receiver only. So, we should tickle
351+ -- the time handler in both the receiver and the sender.
352+ let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
353+ sendBS x = connSendAll conn x >> T.tickle th
321 -- fixme: origAddr
354 -- fixme: origAddr
356+ setConnHTTP2 conn True
322− http2 conn ii1 origAddr transport settings recvN app
357+ http2 conn transport ii origAddr settings recvN sendBS app
324− istatus <- newIORef False
325 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
326 writeIORef istatus True
360 writeIORef istatus True
327 leftoverSource src bs
361 leftoverSource src bs
328 addr <- getProxyProtocolAddr src
362 addr <- getProxyProtocolAddr src
329− http1 addr istatus src `E.catch` \e -> do
363+ http1 True addr istatus src `E.catch` \e ->
366+ -- See comment below referencing
367+ -- https://github.com/yesodweb/wai/issues/618
368+ | Just NoKeepAliveRequest <- fromException e -> return ()
370+ | Just (BadFirstLine _) <- fromException e -> return ()
330− sendErrorResponse addr istatus e
372+ _ <- sendErrorResponse (dummyreq addr) istatus e
331− throwIO (e :: SomeException)
373+ throwIO e
333 getProxyProtocolAddr src =
376 getProxyProtocolAddr src =
334 case settingsProxyProtocol settings of
377 case settingsProxyProtocol settings of
@@ -370,36 +413,40 @@ serveConnection conn ii1 origAddr transport settings app = do
371 decodeAscii = map (chr . fromEnum) . S.unpack
414 decodeAscii = map (chr . fromEnum) . S.unpack
373− th = threadHandle1 ii1
375 shouldSendErrorResponse se
416 shouldSendErrorResponse se
376 | Just ConnectionClosedByPeer <- fromException se = False
417 | Just ConnectionClosedByPeer <- fromException se = False
377 | otherwise = True
418 | otherwise = True
379− sendErrorResponse addr istatus e = do
420+ sendErrorResponse req istatus e = do
380 status <- readIORef istatus
421 status <- readIORef istatus
381− when (shouldSendErrorResponse e && status) $ do
422+ if shouldSendErrorResponse e && status
382− let ii = toInternalInfo ii1 0 -- dummy
423+ then do
383− dreq = dummyreq addr
384− void $ sendResponse settings conn ii dreq defaultIndexRequestHeader (return S.empty) (errorResponse e)
424+ sendResponse settings conn ii th req defaultIndexRequestHeader (return S.empty) (errorResponse e)
386 dummyreq addr = defaultRequest { remoteHost = addr }
427 dummyreq addr = defaultRequest { remoteHost = addr }
388 errorResponse e = settingsOnExceptionResponse settings e
429 errorResponse e = settingsOnExceptionResponse settings e
390− http1 addr istatus src = do
431+ http1 firstRequest addr istatus src = do
391− (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest settings conn ii1 addr src
432+ (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport
392− let req = req' { isSecure = isTransportSecure transport }
393− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii
433+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
394 `E.catch` \e -> do
434 `E.catch` \e -> do
395− -- Call the user-supplied exception handlers, passing the request.
396− sendErrorResponse addr istatus e
397 settingsOnException settings (Just req) e
435 settingsOnException settings (Just req) e
398 -- Don't throw the error again to prevent calling settingsOnException twice.
436 -- Don't throw the error again to prevent calling settingsOnException twice.
399 return False
437 return False
400− when keepAlive $ http1 addr istatus src
439+ -- When doing a keep-alive connection, the other side may just
440+ -- close the connection. We don't want to treat that as an
441+ -- exceptional situation, so we pass in False to http1 (which
442+ -- in turn passes in False to recvRequest), indicating that
443+ -- this is not the first request. If, when trying to read the
444+ -- request headers, no data is available, recvRequest will
445+ -- throw a NoKeepAliveRequest exception, which we catch here
446+ -- and ignore. See: https://github.com/yesodweb/wai/issues/618
447+ when keepAlive $ http1 False addr istatus src
402− processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do
449+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do
403 -- Let the application run for as long as it wants
450 -- Let the application run for as long as it wants
404 T.pause th
451 T.pause th
@@ -407,30 +454,38 @@ serveConnection conn ii1 origAddr transport settings app = do
407 -- creating the request, we need to make sure that we don't get
454 -- creating the request, we need to make sure that we don't get
408 -- an async exception before calling the ResponseSource.
455 -- an async exception before calling the ResponseSource.
409 keepAliveRef <- newIORef $ error "keepAliveRef not filled"
456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"
410− _ <- app req $ \res -> do
457+ r <- E.try $ app req $ \res -> do
411 T.resume th
458 T.resume th
412 -- FIXME consider forcing evaluation of the res here to
459 -- FIXME consider forcing evaluation of the res here to
413 -- send more meaningful error messages to the user.
460 -- send more meaningful error messages to the user.
414 -- However, it may affect performance.
461 -- However, it may affect performance.
415 writeIORef istatus False
462 writeIORef istatus False
416− keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res
463+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res
417 writeIORef keepAliveRef keepAlive
464 writeIORef keepAliveRef keepAlive
418 return ResponseReceived
465 return ResponseReceived
467+ Right ResponseReceived -> return ()
468+ Left e@(SomeException _)
469+ | Just (ExceptionInsideResponseBody e') <- fromException e -> throwIO e'
471+ keepAlive <- sendErrorResponse req istatus e
472+ settingsOnException settings (Just req) e
473+ writeIORef keepAliveRef keepAlive
419 keepAlive <- readIORef keepAliveRef
475 keepAlive <- readIORef keepAliveRef
421 -- We just send a Response and it takes a time to
477 -- We just send a Response and it takes a time to
422 -- receive a Request again. If we immediately call recv,
478 -- receive a Request again. If we immediately call recv,
423− -- it is likely to fail and the IO manager works.
479+ -- it is likely to fail and cause the IO manager to do some work.
424− -- It is very costly. So, we yield to another Haskell
480+ -- It is very costly, so we yield to another Haskell
425 -- thread hoping that the next Request will arrive
481 -- thread hoping that the next Request will arrive
426 -- when this Haskell thread will be re-scheduled.
482 -- when this Haskell thread will be re-scheduled.
427 -- This improves performance at least when
483 -- This improves performance at least when
428 -- the number of cores is small.
484 -- the number of cores is small.
429 Conc.yield
485 Conc.yield
431− if not keepAlive then
487+ if keepAlive
432− return False
488+ then
434 -- If there is an unknown or large amount of data to still be read
489 -- If there is an unknown or large amount of data to still be read
435 -- from the request body, simple drop this connection instead of
490 -- from the request body, simple drop this connection instead of
436 -- reading it all in to satisfy a keep-alive request.
491 -- reading it all in to satisfy a keep-alive request.
@@ -456,6 +511,21 @@ serveConnection conn ii1 origAddr transport settings app = do
457 return False
512 return False
458 Nothing -> tryKeepAlive
513 Nothing -> tryKeepAlive
517+ checkTLS = case transport of
518+ TCP -> return () -- direct
519+ tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"
520+ tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3
522+-- connClose must not be called here since Run:fork calls it
523+goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()
524+goaway Connection{..} etype debugmsg = connSendAll bytestream
526+ einfo = H2.encodeInfo id 0
527+ frame = H2.GoAwayFrame 0 etype debugmsg
528+ bytestream = H2.encodeFrame einfo frame
460flushEntireBody :: IO ByteString -> IO ()
530flushEntireBody :: IO ByteString -> IO ()
461flushEntireBody src =
531flushEntireBody src =
@@ -488,12 +558,35 @@ wrappedRecv Connection { connRecv = recv } th istatus slowlorisSize = do
488 when (S.length bs >= slowlorisSize) $ T.tickle th
558 when (S.length bs >= slowlorisSize) $ T.tickle th
489 return bs
559 return bs
561+wrappedRecvN :: T.Handle -> IORef Bool -> Int -> (BufSize -> IO ByteString) -> (BufSize -> IO ByteString)
562+wrappedRecvN th istatus slowlorisSize readN bufsize = do
564+ unless (S.null bs) $ do
565+ writeIORef istatus True
566+ -- TODO: think about the slowloris protection in HTTP2: current code
567+ -- might open a slow-loris attack vector. Rather than timing we should
568+ -- consider limiting the per-client connections assuming that in HTTP2
569+ -- we should allow only few connections per host (real-world
570+ -- deployments with large NATs may be trickier).
571+ when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th
574+-- | Set flag FileCloseOnExec flag on a socket (on Unix)
491-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs
576-- Copied from: https://github.com/mzero/plush/blob/master/src/Plush/Server/Warp.hs
492setSocketCloseOnExec :: Socket -> IO ()
579setSocketCloseOnExec :: Socket -> IO ()
493#if WINDOWS
580#if WINDOWS
494setSocketCloseOnExec _ = return ()
581setSocketCloseOnExec _ = return ()
583+setSocketCloseOnExec socket = do
584+#if MIN_VERSION_network(3,0,0)
585+ fd <- fdSocket socket
587+ let fd = fdSocket socket
496−setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket
589+ F.setFileCloseOnExec $ fromIntegral fd
499gracefulShutdown :: Settings -> Counter -> IO ()
592gracefulShutdown :: Settings -> Counter -> IO ()