diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,10 @@ +## 3.2.10 + +* Add `connFree` to `Connection`. Close socket connections on timeout triggered. Timeout exceptions extend from `SomeAsyncException`. [#602](https://github.com/yesodweb/wai/pull/602) [#605](https://github.com/yesodweb/wai/pull/605) + ## 3.2.9 -* Fixing a space leak. [#586] https://github.com/yesodweb/wai/pull/586 +* Fixing a space leak. [#586](https://github.com/yesodweb/wai/pull/586) ## 3.2.8 diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -286,6 +286,16 @@ -- handler. The handler should call the first argument, -- which closes the listen socket, at shutdown. -- +-- Example usage: +-- +-- @ +-- settings :: IO () -> 'Settings' +-- settings shutdownAction = 'setInstallShutdownHandler' shutdownHandler 'defaultSettings' +-- __where__ +-- shutdownHandler closeSocket = +-- void $ 'System.Posix.Signals.installHandler' 'System.Posix.Signals.sigTERM' ('System.Posix.Signals.Catch' $ shutdownAction >> closeSocket) 'Nothing' +-- @ +-- -- Default: does not install any code. -- -- Since 3.0.1 diff --git a/Network/Wai/Handler/Warp/HTTP2/Worker.hs b/Network/Wai/Handler/Warp/HTTP2/Worker.hs --- a/Network/Wai/Handler/Warp/HTTP2/Worker.hs +++ b/Network/Wai/Handler/Warp/HTTP2/Worker.hs @@ -236,7 +236,8 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do sinfo <- newStreamInfo tcont <- newThreadContinue - E.bracket (T.registerKillThread tm) T.cancel $ go sinfo tcont + let timeoutAction = return () -- cannot close the shared connection + E.bracket (T.registerKillThread tm timeoutAction) T.cancel $ go sinfo tcont where go sinfo tcont th = do setThreadContinue tcont True diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -24,8 +24,8 @@ import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno(..), eCONNABORTED) import GHC.IO.Exception (IOException(..)) -import Network (sClose, Socket) -import Network.Socket (accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..)) +import Network (Socket) +import Network.Socket (close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..)) import qualified Network.Socket.ByteString as Sock import Network.Wai import Network.Wai.Handler.Warp.Buffer @@ -35,6 +35,7 @@ import qualified Network.Wai.Handler.Warp.FileInfoCache as I import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2) import Network.Wai.Handler.Warp.Header +import Network.Wai.Handler.Warp.IORef import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.Recv import Network.Wai.Handler.Warp.Request @@ -63,7 +64,8 @@ connSendMany = Sock.sendMany s , connSendAll = sendall , connSendFile = sendFile s writeBuf bufferSize sendall - , connClose = sClose s >> freeBuffer writeBuf + , connClose = close s + , connFree = freeBuffer writeBuf , connRecv = receive s bufferPool , connRecvBuf = receiveBuf s , connWriteBuffer = writeBuf @@ -104,7 +106,7 @@ runSettings set app = withSocketsDo $ bracket (bindPortTCP (settingsPort set) (settingsHost set)) - sClose + close (\socket -> do setSocketCloseOnExec socket runSettingsSocket set socket app) @@ -137,7 +139,7 @@ conn <- socketConnection s return (conn, sa) - closeListenSocket = sClose socket + closeListenSocket = close socket -- | The connection setup action would be expensive. A good example -- is initialization of TLS. @@ -262,6 +264,10 @@ -> InternalInfo0 -> IO () fork set mkConn addr app counter ii0 = settingsFork set $ \ unmask -> + -- Allocate a new IORef indicating whether the connection has been + -- closed, to avoid double-freeing a connection + withClosedRef $ \ref -> + -- Run the connection maker to get a new connection, and ensure -- that the connection is closed. If the mkConn call throws an -- exception, we will leak the connection. If the mkConn call is @@ -272,11 +278,14 @@ -- We grab the connection before registering timeouts since the -- timeouts will be useless during connection creation, due to the -- fact that async exceptions are still masked. - bracket mkConn closeConn $ \(conn, transport) -> + bracket mkConn (\(conn, _) -> closeConn ref conn `finally` connFree conn) + $ \(conn, transport) -> -- We need to register a timeout handler for this thread, and - -- cancel that handler as soon as we exit. - bracket (T.registerKillThread (timeoutManager0 ii0)) T.cancel $ \th -> + -- cancel that handler as soon as we exit. We additionally close + -- the connection immediately in case the child thread catches the + -- async exception or performs some long-running cleanup action. + bracket (T.registerKillThread (timeoutManager0 ii0) (closeConn ref conn)) T.cancel $ \th -> let ii1 = toInternalInfo1 ii0 th -- We now have fully registered a connection close handler @@ -294,7 +303,11 @@ -- bracket with closeConn above ensures the connection is closed. when goingon $ serveConnection conn ii1 addr transport set app where - closeConn (conn, _transport) = connClose conn + withClosedRef inner = newIORef False >>= inner + + closeConn ref conn = do + isClosed <- atomicModifyIORef' ref $ \x -> (True, x) + unless isClosed $ connClose conn onOpen adr = increase counter >> settingsOnOpen set adr onClose adr _ = decrease counter >> settingsOnClose set adr diff --git a/Network/Wai/Handler/Warp/Timeout.hs b/Network/Wai/Handler/Warp/Timeout.hs --- a/Network/Wai/Handler/Warp/Timeout.hs +++ b/Network/Wai/Handler/Warp/Timeout.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} module Network.Wai.Handler.Warp.Timeout ( @@ -97,19 +98,24 @@ return h -- | Registering a timeout action of killing this thread. -registerKillThread :: Manager -> IO Handle -registerKillThread m = do +registerKillThread :: Manager -> TimeoutAction -> IO Handle +registerKillThread m onTimeout = do -- If we hold ThreadId, the stack and data of the thread is leaked. -- If we hold Weak ThreadId, the stack is released. However, its -- data is still leaked probably because of a bug of GHC. -- So, let's just use ThreadId and release ThreadId by -- overriding the timeout action by "cancel". tid <- myThreadId - register m $ E.throwTo tid TimeoutThread + -- First run the timeout action in case the child thread is masked. + register m $ onTimeout `E.finally` E.throwTo tid TimeoutThread data TimeoutThread = TimeoutThread deriving Typeable -instance E.Exception TimeoutThread +instance E.Exception TimeoutThread where +#if MIN_VERSION_base(4,7,0) + toException = E.asyncExceptionToException + fromException = E.asyncExceptionFromException +#endif instance Show TimeoutThread where show TimeoutThread = "Thread killed by Warp's timeout reaper" diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -92,8 +92,13 @@ , connSendAll :: ByteString -> IO () -- | The sending function for files in HTTP/1.1. , connSendFile :: SendFile - -- | The connection closing function. + -- | The connection closing function. Warp guarantees it will only be + -- called once. Other functions (like 'connRecv') may be called after + -- 'connClose' is called. , connClose :: IO () + -- | Free any buffers allocated. Warp guarantees it will only be + -- called once, and no other functions will be called after it. + , connFree :: IO () -- | The connection receiving function. This returns "" for EOF. , connRecv :: Recv -- | The connection receiving function. This tries to fill the buffer. diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,5 +1,5 @@ Name: warp -Version: 3.2.9 +Version: 3.2.10 Synopsis: A fast, light-weight web server for WAI applications. License: MIT License-file: LICENSE