@@ -17,12 +17,15 @@ import qualified Control.Concurrent as Conc (yield)
17import Control.Exception as E
17import Control.Exception as E
18import qualified Data.ByteString as S
18import qualified Data.ByteString as S
19import Data.Char (chr)
19import Data.Char (chr)
20−import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')
20+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
21import Data.Streaming.Network (bindPortTCP)
21import Data.Streaming.Network (bindPortTCP)
22import Foreign.C.Error (Errno(..), eCONNABORTED)
22import Foreign.C.Error (Errno(..), eCONNABORTED)
23import GHC.IO.Exception (IOException(..))
23import GHC.IO.Exception (IOException(..))
24import qualified Network.HTTP2 as H2
24import qualified Network.HTTP2 as H2
25import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
25import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
26+#if MIN_VERSION_network(3,1,1)
27+import Network.Socket (gracefulClose)
26import qualified Network.Socket.ByteString as Sock
29import qualified Network.Socket.ByteString as Sock
27import Network.Wai
30import Network.Wai
28import Network.Wai.Internal (ResponseReceived (ResponseReceived))
31import Network.Wai.Internal (ResponseReceived (ResponseReceived))
@@ -55,21 +58,38 @@ 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-- | Run an 'Application' on the given port.
95-- | Run an 'Application' on the given port.
@@ -131,7 +151,7 @@ runSettingsSocket set socket app = do
131 setSocketCloseOnExec s
151 setSocketCloseOnExec s
132 -- NoDelay causes an error for AF_UNIX.
152 -- NoDelay causes an error for AF_UNIX.
133 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
134− conn <- socketConnection s
154+ conn <- socketConnection set s
135 return (conn, sa)
155 return (conn, sa)
137 closeListenSocket = close socket
157 closeListenSocket = close socket
@@ -266,10 +286,7 @@ fork :: Settings
266fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
286fork 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,21 +297,13 @@ fork set mkConn addr app counter ii = 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 -- We now have fully registered a connection close handler in
307 -- We now have fully registered a connection close handler in
299 -- the case of all exceptions, so it is safe to once again
308 -- the case of all exceptions, so it is safe to once again
300 -- allow async exceptions.
309 -- allow async exceptions.
@@ -306,8 +315,7 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
306 -- above ensures the connection is closed.
315 -- above ensures the connection is closed.
307 when goingon $ serveConnection conn ii th addr transport set app
316 when goingon $ serveConnection conn ii th addr transport set app
309− register = T.registerKillThread (timeoutManager ii)
318+ register = T.registerKillThread (timeoutManager ii) (connClose conn)
310− (closeConn ref conn)
311 cancel = T.cancel
319 cancel = T.cancel
313 onOpen adr = increase counter >> settingsOnOpen set adr
321 onOpen adr = increase counter >> settingsOnOpen set adr
@@ -334,10 +342,19 @@ serveConnection conn ii th 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
340− http2 conn ii origAddr settings recvN app
357+ http2 conn transport ii origAddr settings recvN sendBS app
342 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
343 writeIORef istatus True
360 writeIORef istatus True
@@ -412,8 +429,7 @@ serveConnection conn ii th origAddr transport settings app = do
412 errorResponse e = settingsOnExceptionResponse settings e
429 errorResponse e = settingsOnExceptionResponse settings e
414 http1 firstRequest addr istatus src = do
431 http1 firstRequest addr istatus src = do
415− (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src
432+ (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport
416− let req = req' { isSecure = isTransportSecure transport }
417 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
433 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
418 `E.catch` \e -> do
434 `E.catch` \e -> do
419 settingsOnException settings (Just req) e
435 settingsOnException settings (Just req) e