@@ -17,7 +17,7 @@ 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(..))
@@ -58,29 +58,17 @@ import Network.Socket (fdSocket)
60-- | Creating 'Connection' for plain HTTP based on a given socket.
60-- | Creating 'Connection' for plain HTTP based on a given socket.
61−socketConnection :: Settings -> Socket -> IO Connection
61+socketConnection :: Socket -> IO Connection
62−#if MIN_VERSION_network(3,1,1)
63−socketConnection set s = do
65−socketConnection _ s = do
62+socketConnection s = do
67 bufferPool <- newBufferPool
63 bufferPool <- newBufferPool
68 writeBuf <- allocateBuffer bufferSize
64 writeBuf <- allocateBuffer bufferSize
69 let sendall = Sock.sendAll s
65 let sendall = Sock.sendAll s
70− isH2 <- newIORef False -- HTTP/1.x
71 return Connection {
66 return Connection {
72 connSendMany = Sock.sendMany s
67 connSendMany = Sock.sendMany s
73 , connSendAll = sendall
68 , connSendAll = sendall
74 , connSendFile = sendFile s writeBuf bufferSize sendall
69 , connSendFile = sendFile s writeBuf bufferSize sendall
75#if MIN_VERSION_network(3,1,1)
70#if MIN_VERSION_network(3,1,1)
76− , connClose = do
71+ , connClose = gracefulClose s 5000
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
73 , connClose = close s
@@ -89,7 +77,6 @@ socketConnection _ s = do
89 , connRecvBuf = receiveBuf s
77 , connRecvBuf = receiveBuf s
90 , connWriteBuffer = writeBuf
78 , connWriteBuffer = writeBuf
91 , connBufferSize = bufferSize
79 , connBufferSize = bufferSize
95-- | Run an 'Application' on the given port.
82-- | Run an 'Application' on the given port.
@@ -151,7 +138,7 @@ runSettingsSocket set socket app = do
151 setSocketCloseOnExec s
138 setSocketCloseOnExec s
152 -- NoDelay causes an error for AF_UNIX.
139 -- NoDelay causes an error for AF_UNIX.
153 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
140 setSocketOption s NoDelay 1 `E.catch` \(E.SomeException _) -> return ()
154− conn <- socketConnection set s
141+ conn <- socketConnection s
155 return (conn, sa)
142 return (conn, sa)
157 closeListenSocket = close socket
144 closeListenSocket = close socket
@@ -286,7 +273,10 @@ fork :: Settings
286fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
273fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
287 -- Call the user-supplied on exception code if any
274 -- Call the user-supplied on exception code if any
288 -- exceptions are thrown.
275 -- exceptions are thrown.
289− handle (settingsOnException set Nothing) $
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 ->
290 -- Run the connection maker to get a new connection, and ensure
280 -- Run the connection maker to get a new connection, and ensure
291 -- that the connection is closed. If the mkConn call throws an
281 -- that the connection is closed. If the mkConn call throws an
292 -- exception, we will leak the connection. If the mkConn call is
282 -- exception, we will leak the connection. If the mkConn call is
@@ -297,13 +287,21 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
297 -- We grab the connection before registering timeouts since the
287 -- We grab the connection before registering timeouts since the
298 -- timeouts will be useless during connection creation, due to the
288 -- timeouts will be useless during connection creation, due to the
299 -- fact that async exceptions are still masked.
289 -- fact that async exceptions are still masked.
300− bracket mkConn cleanUp (serve unmask)
290+ bracket mkConn (cleanUp ref) (serve unmask ref)
292+ withClosedRef inner = newIORef False >>= inner
294+ closeConn ref conn = do
295+ isClosed <- atomicModifyIORef' ref $ \x -> (True, x)
296+ unless isClosed $ connClose conn
302− cleanUp (conn, _) = connClose conn `finally` connFree conn
298+ cleanUp ref (conn, _) = closeConn ref conn `finally` connFree conn
304 -- We need to register a timeout handler for this thread, and
300 -- We need to register a timeout handler for this thread, and
305− -- cancel that handler as soon as we exit.
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.
306− serve unmask (conn, transport) = bracket register cancel $ \th -> do
304+ serve unmask ref (conn, transport) = bracket register cancel $ \th -> do
307 -- We now have fully registered a connection close handler in
305 -- We now have fully registered a connection close handler in
308 -- the case of all exceptions, so it is safe to once again
306 -- the case of all exceptions, so it is safe to once again
309 -- allow async exceptions.
307 -- allow async exceptions.
@@ -315,7 +313,8 @@ fork set mkConn addr app counter ii = settingsFork set $ \unmask ->
315 -- above ensures the connection is closed.
313 -- above ensures the connection is closed.
316 when goingon $ serveConnection conn ii th addr transport set app
314 when goingon $ serveConnection conn ii th addr transport set app
318− register = T.registerKillThread (timeoutManager ii) (connClose conn)
316+ register = T.registerKillThread (timeoutManager ii)
317+ (closeConn ref conn)
319 cancel = T.cancel
318 cancel = T.cancel
321 onOpen adr = increase counter >> settingsOnOpen set adr
320 onOpen adr = increase counter >> settingsOnOpen set adr
@@ -342,19 +341,10 @@ serveConnection conn ii th origAddr transport settings app = do
342 istatus <- newIORef False
341 istatus <- newIORef False
343 if settingsHTTP2Enabled settings && h2 then do
342 if settingsHTTP2Enabled settings && h2 then do
344 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
343 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
344 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
353− sendBS x = connSendAll conn x >> T.tickle th
354 -- fixme: origAddr
345 -- fixme: origAddr
356− setConnHTTP2 conn True
357− http2 conn transport ii origAddr settings recvN sendBS app
347+ http2 conn transport ii origAddr settings recvN app
359 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
349 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
360 writeIORef istatus True
350 writeIORef istatus True