@@ -17,7 +17,7 @@ import qualified Control.Concurrent as Conc (yield)
1717import Control.Exception as E
1818import qualified Data.ByteString as S
1919import Data.Char (chr)
20−import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')
20+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
2121import Data.Streaming.Network (bindPortTCP)
2222import Foreign.C.Error (Errno(..), eCONNABORTED)
2323import GHC.IO.Exception (IOException(..))
@@ -58,17 +58,29 @@ import Network.Socket (fdSocket)
5858#endif
5959
6060-- | Creating 'Connection' for plain HTTP based on a given socket.
61−socketConnection :: Socket -> IO Connection
62−socketConnection s = do
61+socketConnection :: Settings -> Socket -> IO Connection
62+#if MIN_VERSION_network(3,1,1)
63+socketConnection set s = do
64+#else
65+socketConnection _ s = do
66+#endif
6367 bufferPool <- newBufferPool
6468 writeBuf <- allocateBuffer bufferSize
6569 let sendall = Sock.sendAll s
70+ isH2 <- newIORef False -- HTTP/1.x
6671 return Connection {
6772 connSendMany = Sock.sendMany s
6873 , connSendAll = sendall
6974 , connSendFile = sendFile s writeBuf bufferSize sendall
7075#if MIN_VERSION_network(3,1,1)
71− , connClose = gracefulClose s 5000
76+ , connClose = do
77+ h2 <- readIORef isH2
78+ let tm = if h2 then settingsGracefulCloseTimeout2 set
79+ else settingsGracefulCloseTimeout1 set
80+ if tm == 0 then
81+ close s
82+ else
83+ gracefulClose s tm `E.catch` \(E.SomeException _) -> return ()
7284#else
7385 , connClose = close s
7486#endif
@@ -77,6 +89,7 @@ socketConnection s = do
7789 , connRecvBuf = receiveBuf s
7890 , connWriteBuffer = writeBuf
7991 , connBufferSize = bufferSize
92+ , connHTTP2 = isH2
8093 }
8194
8295-- | Run an 'Application' on the given port.
@@ -138,7 +151,7 @@ runSettingsSocket set socket app = do
138151 setSocketCloseOnExec s
139152 -- NoDelay causes an error for AF_UNIX.
140153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
141− conn <- socketConnection s
154+ conn <- socketConnection set s
142155 return (conn, sa)
143156
144157 closeListenSocket = close socket
@@ -273,10 +286,7 @@ fork :: Settings
273286fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
274287 -- Call the user-supplied on exception code if any
275288 -- exceptions are thrown.
276− handle (settingsOnException set Nothing) .
277− -- Allocate a new IORef indicating whether the connection has been
278− -- closed, to avoid double-freeing a connection
279− withClosedRef $ \ref ->
289+ handle (settingsOnException set Nothing) $
280290 -- Run the connection maker to get a new connection, and ensure
281291 -- that the connection is closed. If the mkConn call throws an
282292 -- exception, we will leak the connection. If the mkConn call is
@@ -287,21 +297,13 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
287297 -- We grab the connection before registering timeouts since the
288298 -- timeouts will be useless during connection creation, due to the
289299 -- fact that async exceptions are still masked.
290− bracket mkConn (cleanUp ref) (serve unmask ref)
300+ bracket mkConn cleanUp (serve unmask)
291301 where
292− withClosedRef inner = newIORef False >>= inner
293−
294− closeConn ref conn = do
295− isClosed <- atomicModifyIORef' ref $ \x -> (True, x)
296− unless isClosed $ connClose conn
297−
298− cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn
302+ cleanUp (conn, _) = connClose conn `finally` connFree conn
299303
300304 -- We need to register a timeout handler for this thread, and
301− -- cancel that handler as soon as we exit. We additionally close
302− -- the connection immediately in case the child thread catches the
303− -- async exception or performs some long-running cleanup action.
304− serve unmask ref (conn, transport) = bracket register cancel $ \th -> do
305+ -- cancel that handler as soon as we exit.
306+ serve unmask (conn, transport) = bracket register cancel $ \th -> do
305307 -- We now have fully registered a connection close handler in
306308 -- the case of all exceptions, so it is safe to once again
307309 -- allow async exceptions.
@@ -313,8 +315,7 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
313315 -- above ensures the connection is closed.
314316 when goingon $ serveConnection conn ii th addr transport set app
315317 where
316− register = T.registerKillThread (timeoutManager ii)
317− (closeConn ref conn)
318+ register = T.registerKillThread (timeoutManager ii) (connClose conn)
318319 cancel = T.cancel
319320
320321 onOpen adr = increase counter >> settingsOnOpen set adr
@@ -341,10 +342,19 @@ serveConnection conn ii th origAddr transport settings app = do
341342 istatus <- newIORef False
342343 if settingsHTTP2Enabled settings && h2 then do
343344 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.
344352 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
353+ sendBS x = connSendAll conn x >> T.tickle th
345354 -- fixme: origAddr
346355 checkTLS
347− http2 conn ii origAddr settings recvN app
356+ setConnHTTP2 conn True
357+ http2 conn transport ii origAddr settings recvN sendBS app
348358 else do
349359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
350360 writeIORef istatus True
@@ -419,8 +429,7 @@ serveConnection conn ii th origAddr transport settings app = do
419429 errorResponse e = settingsOnExceptionResponse settings e
420430
421431 http1 firstRequest addr istatus src = do
422− (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src
423− let req = req' { isSecure = isTransportSecure transport }
432+ (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport
424433 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
425434 `E.catch` \e -> do
426435 settingsOnException settings (Just req) e