@@ -17,15 +17,12 @@ 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)
20+import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')
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)
29import qualified Network.Socket.ByteString as Sock
26import qualified Network.Socket.ByteString as Sock
30import Network.Wai
27import Network.Wai
31import Network.Wai.Internal (ResponseReceived (ResponseReceived))
28import Network.Wai.Internal (ResponseReceived (ResponseReceived))
@@ -58,38 +55,21 @@ import Network.Socket (fdSocket)
60-- | Creating 'Connection' for plain HTTP based on a given socket.
57-- | Creating 'Connection' for plain HTTP based on a given socket.
61−socketConnection :: Settings -> Socket -> IO Connection
58+socketConnection :: Socket -> IO Connection
62−#if MIN_VERSION_network(3,1,1)
63−socketConnection set s = do
65−socketConnection _ s = do
59+socketConnection s = do
67 bufferPool <- newBufferPool
60 bufferPool <- newBufferPool
68 writeBuf <- allocateBuffer bufferSize
61 writeBuf <- allocateBuffer bufferSize
69 let sendall = Sock.sendAll s
62 let sendall = Sock.sendAll s
70− isH2 <- newIORef False -- HTTP/1.x
71 return Connection {
63 return Connection {
72 connSendMany = Sock.sendMany s
64 connSendMany = Sock.sendMany s
73 , connSendAll = sendall
65 , connSendAll = sendall
74 , connSendFile = sendFile s writeBuf bufferSize sendall
66 , 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
67 , connClose = close s
87 , connFree = freeBuffer writeBuf
68 , connFree = freeBuffer writeBuf
88 , connRecv = receive s bufferPool
69 , connRecv = receive s bufferPool
89 , connRecvBuf = receiveBuf s
70 , connRecvBuf = receiveBuf s
90 , connWriteBuffer = writeBuf
71 , connWriteBuffer = writeBuf
91 , connBufferSize = bufferSize
72 , connBufferSize = bufferSize
95-- | Run an 'Application' on the given port.
75-- | Run an 'Application' on the given port.
@@ -151,7 +131,7 @@ runSettingsSocket set socket app = do
151 setSocketCloseOnExec s
131 setSocketCloseOnExec s
152 -- NoDelay causes an error for AF_UNIX.
132 -- NoDelay causes an error for AF_UNIX.
153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
133 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
154− conn <- socketConnection set s
134+ conn <- socketConnection s
155 return (conn, sa)
135 return (conn, sa)
157 closeListenSocket = close socket
137 closeListenSocket = close socket
@@ -286,7 +266,10 @@ fork :: Settings
286fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
266fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
287 -- Call the user-supplied on exception code if any
267 -- Call the user-supplied on exception code if any
288 -- exceptions are thrown.
268 -- exceptions are thrown.
289− handle (settingsOnException set Nothing) $
269+ 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 ->
290 -- Run the connection maker to get a new connection, and ensure
273 -- Run the connection maker to get a new connection, and ensure
291 -- that the connection is closed. If the mkConn call throws an
274 -- that the connection is closed. If the mkConn call throws an
292 -- exception, we will leak the connection. If the mkConn call is
275 -- exception, we will leak the connection. If the mkConn call is
@@ -297,13 +280,21 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
297 -- We grab the connection before registering timeouts since the
280 -- We grab the connection before registering timeouts since the
298 -- timeouts will be useless during connection creation, due to the
281 -- timeouts will be useless during connection creation, due to the
299 -- fact that async exceptions are still masked.
282 -- fact that async exceptions are still masked.
300− bracket mkConn cleanUp (serve unmask)
283+ bracket mkConn (cleanUp ref) (serve unmask ref)
285+ withClosedRef inner = newIORef False >>= inner
287+ closeConn ref conn = do
288+ isClosed <- atomicModifyIORef' ref $ \x -> (True, x)
289+ unless isClosed $ connClose conn
302− cleanUp (conn, _) = connClose conn `finally` connFree conn
291+ cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn
304 -- We need to register a timeout handler for this thread, and
293 -- We need to register a timeout handler for this thread, and
305− -- cancel that handler as soon as we exit.
294+ -- cancel that handler as soon as we exit. We additionally close
295+ -- the connection immediately in case the child thread catches the
296+ -- async exception or performs some long-running cleanup action.
306− serve unmask (conn, transport) = bracket register cancel $ \th -> do
297+ serve unmask ref (conn, transport) = bracket register cancel $ \th -> do
307 -- We now have fully registered a connection close handler in
298 -- We now have fully registered a connection close handler in
308 -- the case of all exceptions, so it is safe to once again
299 -- the case of all exceptions, so it is safe to once again
309 -- allow async exceptions.
300 -- allow async exceptions.
@@ -315,7 +306,8 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
315 -- above ensures the connection is closed.
306 -- above ensures the connection is closed.
316 when goingon $ serveConnection conn ii th addr transport set app
307 when goingon $ serveConnection conn ii th addr transport set app
318− register = T.registerKillThread (timeoutManager ii) (connClose conn)
309+ register = T.registerKillThread (timeoutManager ii)
310+ (closeConn ref conn)
319 cancel = T.cancel
311 cancel = T.cancel
321 onOpen adr = increase counter >> settingsOnOpen set adr
313 onOpen adr = increase counter >> settingsOnOpen set adr
@@ -342,19 +334,10 @@ serveConnection conn ii th origAddr transport settings app = do
342 istatus <- newIORef False
334 istatus <- newIORef False
343 if settingsHTTP2Enabled settings && h2 then do
335 if settingsHTTP2Enabled settings && h2 then do
344 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
336 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
337 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
353− sendBS x = connSendAll conn x >> T.tickle th
354 -- fixme: origAddr
338 -- fixme: origAddr
356− setConnHTTP2 conn True
357− http2 conn transport ii origAddr settings recvN sendBS app
340+ http2 conn ii origAddr settings recvN app
359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
342 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
360 writeIORef istatus True
343 writeIORef istatus True
@@ -429,7 +412,8 @@ serveConnection conn ii th origAddr transport settings app = do
429 errorResponse e = settingsOnExceptionResponse settings e
412 errorResponse e = settingsOnExceptionResponse settings e
431 http1 firstRequest addr istatus src = do
414 http1 firstRequest addr istatus src = do
432− (req, mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src transport
415+ (req', mremainingRef, idxhdr, nextBodyFlush) <- recvRequest firstRequest settings conn ii th addr src
416+ let req = req' { isSecure = isTransportSecure transport }
433 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
417 keepAlive <- processRequest istatus src req mremainingRef idxhdr nextBodyFlush
434 `E.catch` \e -> do
418 `E.catch` \e -> do
435 settingsOnException settings (Just req) e
419 settingsOnException settings (Just req) e