@@ -3,50 +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 (Socket)
24+import qualified Network.HTTP2 as H2
28−import Network.Socket (close, 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
38−import Network.Wai.Handler.Warp.IORef
44+import Network.Wai.Handler.Warp.Imports hiding (readInt)
39import Network.Wai.Handler.Warp.ReadInt
45import Network.Wai.Handler.Warp.ReadInt
40import Network.Wai.Handler.Warp.Recv
46import Network.Wai.Handler.Warp.Recv
41import Network.Wai.Handler.Warp.Request
47import Network.Wai.Handler.Warp.Request
42import Network.Wai.Handler.Warp.Response
48import Network.Wai.Handler.Warp.Response
43import Network.Wai.Handler.Warp.SendFile
49import Network.Wai.Handler.Warp.SendFile
44import Network.Wai.Handler.Warp.Settings
50import Network.Wai.Handler.Warp.Settings
45−import qualified Network.Wai.Handler.Warp.Timeout as T
46import Network.Wai.Handler.Warp.Types
51import Network.Wai.Handler.Warp.Types
47−import Network.Wai.Internal (ResponseReceived (ResponseReceived))
52+
48−import System.Environment (getEnvironment)
49−import System.Timeout (timeout)
51#if WINDOWS
54#if WINDOWS
52import Network.Wai.Handler.Warp.Windows
55import Network.Wai.Handler.Warp.Windows
@@ -55,28 +58,40 @@ import Network.Socket (fdSocket)
57-- | Creating 'Connection' for plain HTTP based on a given socket.
60-- | Creating 'Connection' for plain HTTP based on a given socket.
58−socketConnection :: Socket -> IO Connection
61+socketConnection :: Settings -> Socket -> IO Connection
62+#if MIN_VERSION_network(3,1,1)
63+socketConnection set s = do
59−socketConnection s = do
65+socketConnection _ s = do
60 bufferPool <- newBufferPool
67 bufferPool <- newBufferPool
61 writeBuf <- allocateBuffer bufferSize
68 writeBuf <- allocateBuffer bufferSize
62 let sendall = Sock.sendAll s
69 let sendall = Sock.sendAll s
70+ isH2 <- newIORef False -- HTTP/1.x
63 return Connection {
71 return Connection {
64 connSendMany = Sock.sendMany s
72 connSendMany = Sock.sendMany s
65 , connSendAll = sendall
73 , connSendAll = sendall
66 , 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 ()
67 , connClose = close s
85 , connClose = close s
68 , connFree = freeBuffer writeBuf
87 , connFree = freeBuffer writeBuf
69 , connRecv = receive s bufferPool
88 , connRecv = receive s bufferPool
70 , connRecvBuf = receiveBuf s
89 , connRecvBuf = receiveBuf s
71 , connWriteBuffer = writeBuf
90 , connWriteBuffer = writeBuf
72 , connBufferSize = bufferSize
91 , connBufferSize = bufferSize
75−#if __GLASGOW_HASKELL__ < 702
76−allowInterrupt :: IO ()
77−allowInterrupt = unblock $ return ()
80-- | Run an 'Application' on the given port.
95-- | Run an 'Application' on the given port.
81-- This calls 'runSettings' with 'defaultSettings'.
96-- This calls 'runSettings' with 'defaultSettings'.
82run :: Port -> Application -> IO ()
97run :: Port -> Application -> IO ()
@@ -89,7 +104,7 @@ run p = runSettings defaultSettings { settingsPort = p }
89-- Since 3.0.9
104-- Since 3.0.9
90runEnv :: Port -> Application -> IO ()
105runEnv :: Port -> Application -> IO ()
91runEnv p app = do
106runEnv p app = do
92− mp <- lookup "PORT" <$> getEnvironment
107+ mp <- lookupEnv "PORT"
94 maybe (run p app) runReadPort mp
109 maybe (run p app) runReadPort mp
@@ -136,7 +151,7 @@ runSettingsSocket set socket app = do
136 setSocketCloseOnExec s
151 setSocketCloseOnExec s
137 -- NoDelay causes an error for AF_UNIX.
152 -- NoDelay causes an error for AF_UNIX.
138 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
139− conn <- socketConnection s
154+ conn <- socketConnection set s
140 return (conn, sa)
155 return (conn, sa)
142 closeListenSocket = close socket
157 closeListenSocket = close socket
@@ -177,15 +192,15 @@ runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport),
177runSettingsConnectionMakerSecure set getConnMaker app = do
192runSettingsConnectionMakerSecure set getConnMaker app = do
178 settingsBeforeMainLoop set
193 settingsBeforeMainLoop set
179 counter <- newCounter
194 counter <- newCounter
180− withII0 $ acceptConnection set getConnMaker app counter
195+ withII $ acceptConnection set getConnMaker app counter
182− withII0 action =
197+ withII action =
183 withTimeoutManager $ \tm ->
198 withTimeoutManager $ \tm ->
184 D.withDateCache $ \dc ->
199 D.withDateCache $ \dc ->
185 F.withFdCache fdCacheDurationInSeconds $ \fdc ->
200 F.withFdCache fdCacheDurationInSeconds $ \fdc ->
186 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do
201 I.withFileInfoCache fdFileInfoDurationInSeconds $ \fic -> do
187− let ii0 = InternalInfo0 tm dc fdc fic
202+ let ii = InternalInfo tm dc fdc fic
188− action ii0
203+ action ii
190 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
205 !fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
191 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000
206 !fdFileInfoDurationInSeconds = settingsFileInfoCacheDuration set * 1000000
@@ -214,13 +229,18 @@ acceptConnection :: Settings
214 -> IO (IO (Connection, Transport), SockAddr)
229 -> IO (IO (Connection, Transport), SockAddr)
215 -> Application
230 -> Application
216 -> Counter
231 -> Counter
217− -> InternalInfo0
232+ -> InternalInfo
219−acceptConnection set getConnMaker app counter ii0 = do
234+acceptConnection set getConnMaker app counter ii = do
220 -- First mask all exceptions in acceptLoop. This is necessary to
235 -- First mask all exceptions in acceptLoop. This is necessary to
221 -- ensure that no async exception is throw between the call to
236 -- ensure that no async exception is throw between the call to
222 -- acceptNewConnection and the registering of connClose.
237 -- acceptNewConnection and the registering of connClose.
239+ -- acceptLoop can be broken by closing the listing socket.
223 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.
224 gracefulShutdown set counter
244 gracefulShutdown set counter
226 acceptLoop = do
246 acceptLoop = do
@@ -238,7 +258,7 @@ acceptConnection set getConnMaker app counter ii0 = do
238 case mx of
258 case mx of
239 Nothing -> return ()
259 Nothing -> return ()
240 Just (mkConn, addr) -> do
260 Just (mkConn, addr) -> do
241− fork set mkConn addr app counter ii0
261+ fork set mkConn addr app counter ii
242 acceptLoop
262 acceptLoop
244 acceptNewConnection = do
264 acceptNewConnection = do
@@ -261,15 +281,12 @@ fork :: Settings
261 -> SockAddr
281 -> SockAddr
262 -> Application
282 -> Application
263 -> Counter
283 -> Counter
264− -> InternalInfo0
284+ -> InternalInfo
266−fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->
286+fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
267 -- Call the user-supplied on exception code if any
287 -- Call the user-supplied on exception code if any
268 -- exceptions are thrown.
288 -- exceptions are thrown.
269− handle (settingsOnException set Nothing) .
289+ handle (settingsOnException set Nothing) $
270− -- Allocate a new IORef indicating whether the connection has been
271− -- closed, to avoid double-freeing a connection
272− withClosedRef $ \ref ->
273 -- Run the connection maker to get a new connection, and ensure
290 -- Run the connection maker to get a new connection, and ensure
274 -- that the connection is closed. If the mkConn call throws an
291 -- that the connection is closed. If the mkConn call throws an
275 -- exception, we will leak the connection. If the mkConn call is
292 -- exception, we will leak the connection. If the mkConn call is
@@ -280,24 +297,15 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->
280 -- We grab the connection before registering timeouts since the
297 -- We grab the connection before registering timeouts since the
281 -- timeouts will be useless during connection creation, due to the
298 -- timeouts will be useless during connection creation, due to the
282 -- fact that async exceptions are still masked.
299 -- fact that async exceptions are still masked.
283− bracket mkConn (cleanUp ref) (serve unmask ref)
300+ bracket mkConn cleanUp (serve unmask)
285− withClosedRef inner = newIORef False >>= inner
287− closeConn ref conn = do
288− isClosed <- atomicModifyIORef' ref $ \x -> (True, x)
289− unless isClosed $ connClose conn
291− cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn
302+ cleanUp (conn, _) = connClose conn `finally` connFree conn
293 -- We need to register a timeout handler for this thread, and
304 -- We need to register a timeout handler for this thread, and
294− -- cancel that handler as soon as we exit. We additionally close
305+ -- cancel that handler as soon as we exit.
295− -- the connection immediately in case the child thread catches the
296− -- async exception or performs some long-running cleanup action.
297− serve unmask ref (conn, transport) = bracket register cancel $ \th -> do
306+ serve unmask (conn, transport) = bracket register cancel $ \th -> do
298− let ii1 = toInternalInfo1 ii0 th
299 -- We now have fully registered a connection close handler in
307 -- We now have fully registered a connection close handler in
300− -- the case of all exceptions, so it is safe to one again
308+ -- the case of all exceptions, so it is safe to once again
301 -- allow async exceptions.
309 -- allow async exceptions.
303 -- Call the user-supplied code for connection open and
311 -- Call the user-supplied code for connection open and
@@ -305,23 +313,23 @@ fork set mkConn addr app counter ii0 = settingsFork set $ \unmask ->
305 bracket (onOpen addr) (onClose addr) $ \goingon ->
313 bracket (onOpen addr) (onClose addr) $ \goingon ->
306 -- Actually serve this connection. bracket with closeConn
314 -- Actually serve this connection. bracket with closeConn
307 -- above ensures the connection is closed.
315 -- above ensures the connection is closed.
308− when goingon $ serveConnection conn ii1 addr transport set app
316+ when goingon $ serveConnection conn ii th addr transport set app
310− register = T.registerKillThread (timeoutManager0 ii0)
318+ register = T.registerKillThread (timeoutManager ii) (connClose conn)
311− (closeConn ref conn)
312 cancel = T.cancel
319 cancel = T.cancel
314 onOpen adr = increase counter >> settingsOnOpen set adr
321 onOpen adr = increase counter >> settingsOnOpen set adr
315 onClose adr _ = decrease counter >> settingsOnClose set adr
322 onClose adr _ = decrease counter >> settingsOnClose set adr
317serveConnection :: Connection
324serveConnection :: Connection
318− -> InternalInfo1
325+ -> InternalInfo
319 -> SockAddr
327 -> SockAddr
320 -> Transport
328 -> Transport
321 -> Settings
329 -> Settings
322 -> Application
330 -> Application
324−serveConnection conn ii1 origAddr transport settings app = do
332+serveConnection conn ii th origAddr transport settings app = do
325 -- fixme: Upgrading to HTTP/2 should be supported.
333 -- fixme: Upgrading to HTTP/2 should be supported.
326 (h2,bs) <- if isHTTP2 transport then
334 (h2,bs) <- if isHTTP2 transport then
327 return (True, "")
335 return (True, "")
@@ -334,17 +342,36 @@ serveConnection conn ii1 origAddr transport settings app = do
334 istatus <- newIORef False
342 istatus <- newIORef False
335 if settingsHTTP2Enabled settings && h2 then do
343 if settingsHTTP2Enabled settings && h2 then do
336 rawRecvN <- 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.
337 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
352 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
353+ sendBS x = connSendAll conn x >> T.tickle th
338 -- fixme: origAddr
354 -- fixme: origAddr
356+ setConnHTTP2 conn True
339− http2 conn ii1 origAddr transport settings recvN app
357+ http2 conn transport ii origAddr settings recvN sendBS app
341 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
342 writeIORef istatus True
360 writeIORef istatus True
343 leftoverSource src bs
361 leftoverSource src bs
344 addr <- getProxyProtocolAddr src
362 addr <- getProxyProtocolAddr src
345− http1 True 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 ()
346− sendErrorResponse addr istatus e
372+ _ <- sendErrorResponse (dummyreq addr) istatus e
347− throwIO (e :: SomeException)
373+ throwIO e
349 getProxyProtocolAddr src =
376 getProxyProtocolAddr src =
350 case settingsProxyProtocol settings of
377 case settingsProxyProtocol settings of
@@ -386,30 +413,25 @@ serveConnection conn ii1 origAddr transport settings app = do
387 decodeAscii = map (chr . fromEnum) . S.unpack
414 decodeAscii = map (chr . fromEnum) . S.unpack
389− th = threadHandle1 ii1
391 shouldSendErrorResponse se
416 shouldSendErrorResponse se
392 | Just ConnectionClosedByPeer <- fromException se = False
417 | Just ConnectionClosedByPeer <- fromException se = False
393 | otherwise = True
418 | otherwise = True
395− sendErrorResponse addr istatus e = do
420+ sendErrorResponse req istatus e = do
396 status <- readIORef istatus
421 status <- readIORef istatus
397− when (shouldSendErrorResponse e && status) $ do
422+ if shouldSendErrorResponse e && status
398− let ii = toInternalInfo ii1 0 -- dummy
423+ then do
399− dreq = dummyreq addr
400− 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)
402 dummyreq addr = defaultRequest { remoteHost = addr }
427 dummyreq addr = defaultRequest { remoteHost = addr }
404 errorResponse e = settingsOnExceptionResponse settings e
429 errorResponse e = settingsOnExceptionResponse settings e
406 http1 firstRequest addr istatus src = do
431 http1 firstRequest addr istatus src = do
407− (req', mremainingRef, idxhdr, nextBodyFlush, ii) <- recvRequest firstRequest settings conn ii1 addr src
432+ (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport
408− let req = req' { isSecure = isTransportSecure transport }
409− keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii
433+ keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
410 `E.catch` \e -> do
434 `E.catch` \e -> do
411− -- Call the user-supplied exception handlers, passing the request.
412− sendErrorResponse addr istatus e
413 settingsOnException settings (Just req) e
435 settingsOnException settings (Just req) e
414 -- Don't throw the error again to prevent calling settingsOnException twice.
436 -- Don't throw the error again to prevent calling settingsOnException twice.
415 return False
437 return False
@@ -422,9 +444,9 @@ serveConnection conn ii1 origAddr transport settings app = do
422 -- request headers, no data is available, recvRequest will
444 -- request headers, no data is available, recvRequest will
423 -- throw a NoKeepAliveRequest exception, which we catch here
445 -- throw a NoKeepAliveRequest exception, which we catch here
424 -- and ignore. See: https://github.com/yesodweb/wai/issues/618
446 -- and ignore. See: https://github.com/yesodweb/wai/issues/618
425− when keepAlive $ http1 False addr istatus src `E.catch` \NoKeepAliveRequest -> return ()
447+ when keepAlive $ http1 False addr istatus src
427− processRequest istatus src req mremainingRef idxhdr nextBodyFlush ii = do
449+ processRequest istatus src req mremainingRef idxhdr nextBodyFlush = do
428 -- Let the application run for as long as it wants
450 -- Let the application run for as long as it wants
429 T.pause th
451 T.pause th
@@ -432,30 +454,38 @@ serveConnection conn ii1 origAddr transport settings app = do
432 -- 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
433 -- an async exception before calling the ResponseSource.
455 -- an async exception before calling the ResponseSource.
434 keepAliveRef <- newIORef $ error "keepAliveRef not filled"
456 keepAliveRef <- newIORef $ error "keepAliveRef not filled"
435− _ <- app req $ \res -> do
457+ r <- E.try $ app req $ \res -> do
436 T.resume th
458 T.resume th
437 -- FIXME consider forcing evaluation of the res here to
459 -- FIXME consider forcing evaluation of the res here to
438 -- send more meaningful error messages to the user.
460 -- send more meaningful error messages to the user.
439 -- However, it may affect performance.
461 -- However, it may affect performance.
440 writeIORef istatus False
462 writeIORef istatus False
441− keepAlive <- sendResponse settings conn ii req idxhdr (readSource src) res
463+ keepAlive <- sendResponse settings conn ii th req idxhdr (readSource src) res
442 writeIORef keepAliveRef keepAlive
464 writeIORef keepAliveRef keepAlive
443 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
444 keepAlive <- readIORef keepAliveRef
475 keepAlive <- readIORef keepAliveRef
446 -- We just send a Response and it takes a time to
477 -- We just send a Response and it takes a time to
447 -- receive a Request again. If we immediately call recv,
478 -- receive a Request again. If we immediately call recv,
448− -- 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.
449− -- It is very costly. So, we yield to another Haskell
480+ -- It is very costly, so we yield to another Haskell
450 -- thread hoping that the next Request will arrive
481 -- thread hoping that the next Request will arrive
451 -- when this Haskell thread will be re-scheduled.
482 -- when this Haskell thread will be re-scheduled.
452 -- This improves performance at least when
483 -- This improves performance at least when
453 -- the number of cores is small.
484 -- the number of cores is small.
454 Conc.yield
485 Conc.yield
456− if not keepAlive then
487+ if keepAlive
457− return False
488+ then
459 -- 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
460 -- from the request body, simple drop this connection instead of
490 -- from the request body, simple drop this connection instead of
461 -- reading it all in to satisfy a keep-alive request.
491 -- reading it all in to satisfy a keep-alive request.
@@ -481,6 +511,21 @@ serveConnection conn ii1 origAddr transport settings app = do
482 return False
512 return False
483 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
485flushEntireBody :: IO ByteString -> IO ()
530flushEntireBody :: IO ByteString -> IO ()
486flushEntireBody src =
531flushEntireBody src =
@@ -526,12 +571,22 @@ wrappedRecvN th istatus slowlorisSize readN bufsize = do
526 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th
571 when (S.length bs >= slowlorisSize || bufsize <= slowlorisSize) $ T.tickle th
527 return bs
572 return bs
574+-- | Set flag FileCloseOnExec flag on a socket (on Unix)
529-- 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
530setSocketCloseOnExec :: Socket -> IO ()
579setSocketCloseOnExec :: Socket -> IO ()
531#if WINDOWS
580#if WINDOWS
532setSocketCloseOnExec _ = return ()
581setSocketCloseOnExec _ = return ()
583+setSocketCloseOnExec socket = do
584+#if MIN_VERSION_network(3,0,0)
585+ fd <- fdSocket socket
587+ let fd = fdSocket socket
534−setSocketCloseOnExec socket = F.setFileCloseOnExec $ fromIntegral $ fdSocket socket
589+ F.setFileCloseOnExec $ fromIntegral fd
537gracefulShutdown :: Settings -> Counter -> IO ()
592gracefulShutdown :: Settings -> Counter -> IO ()