@@ -31,6 +31,7 @@ import Network.Wai.Handler.Warp.Settings
3131import qualified Network.Wai.Handler.Warp.Timeout as T
3232import Network.Wai.Handler.Warp.Types
3333import Network.Wai.Internal (ResponseReceived (ResponseReceived))
34+import System.IO.Error (isFullErrorType, ioeGetErrorType)
3435
3536#if WINDOWS
3637import Network.Wai.Handler.Warp.Windows
@@ -115,6 +116,8 @@ runSettingsConnectionMaker x y =
115116 where
116117 go = fmap (first (fmap (, False)))
117118
119+----------------------------------------------------------------
120+
118121-- | Allows you to provide a function which will return a function
119122-- which will return 'Connection'.
120123--
@@ -129,13 +132,17 @@ runSettingsConnectionMakerSecure set getConnMaker app = do
129132 acceptConnection set getConnMaker app dc fc tm
130133 where
131134 fdCacheDurationInSeconds = settingsFdCacheDuration set * 1000000
132− withTimeoutManager f =
133− case settingsManager set of
134− Nothing -> bracket
135− (T.initialize $ settingsTimeout set * 1000000)
136− T.stopManager
137− f
138− Just tm -> f tm
135+ withTimeoutManager f = case settingsManager set of
136+ Just tm -> f tm
137+ Nothing -> bracket
138+ (T.initialize $ settingsTimeout set * 1000000)
139+ T.stopManager
140+ f
141+
142+onE :: Settings -> Maybe Request -> SomeException -> IO ()
143+onE set mreq e = case fromException e of
144+ Just (NotEnoughLines []) -> return ()
145+ _ -> settingsOnException set mreq e
139146
140147-- Note that there is a thorough discussion of the exception safety of the
141148-- following code at: https://github.com/yesodweb/wai/issues/146
@@ -159,7 +166,7 @@ acceptConnection :: Settings
159166-- First mask all exceptions in the main loop. This is necessary to ensure
160167-- that no async exception is throw between the call to getConnLoop and the
161168-- registering of connClose.
162−acceptConnection set getConnMaker app dc fc tm = mask_ $ do
169+acceptConnection set getConnMaker app dc fc tm = mask $ \restore -> do
163170 -- Allow async exceptions before receiving the next connection maker.
164171 allowInterrupt
165172
@@ -169,64 +176,72 @@ acceptConnection set getConnMaker app dc fc tm = mask_ $ do
169176 -- an expensive operation, and this expensive work should not be
170177 -- performed in the main event loop. An example of something expensive
171178 -- would be TLS negotiation.
172− (mkConn, addr) <- getConnLoop
173−
174− -- Fork a new worker thread for this connection maker, and ask for a
175− -- function to unmask (i.e., allow async exceptions to be thrown).
176− --
177− -- GHC 7.8 cannot infer the type of "void . forkIOWithUnmask"
178− void $ forkIOWithUnmask $ \unmask ->
179− -- Run the connection maker to get a new connection, and ensure
180− -- that the connection is closed. If the mkConn call throws an
181− -- exception, we will leak the connection. If the mkConn call is
182− -- vulnerable to attacks (e.g., Slowloris), we do nothing to
183− -- protect the server. It is therefore vital that mkConn is well
184− -- vetted.
185− --
186− -- We grab the connection before registering timeouts since the
187− -- timeouts will be useless during connection creation, due to the
188− -- fact that async exceptions are still masked.
189− bracket mkConn closeConn $ \(conn0, isSecure') ->
190−
191− -- We need to register a timeout handler for this thread, and
192− -- cancel that handler as soon as we exit.
193− bracket (T.registerKillThread tm) T.cancel $ \th ->
194− let ii = InternalInfo th fc dc
195− conn = setSendFile conn0 fc
196− -- We now have fully registered a connection close handler
197− -- in the case of all exceptions, so it is safe to one
198− -- again allow async exceptions.
199− in unmask .
200− -- Call the user-supplied on exception code if any
201− -- exceptions are thrown.
202− handle (onE Nothing) .
203−
204− -- Call the user-supplied code for connection open and close events
205− bracket (onOpen addr) (onClose addr) $ \goingon ->
206−
207− -- Actually serve this connection.
208− -- onnClose above ensures the termination of the connection.
209− when goingon $ serveConnection conn ii addr isSecure' set app
210−
211− acceptConnection set getConnMaker app dc fc tm
179+ em <- try getConnLoop
180+ case em of
181+ Left (_ :: IOException) -> restore gracefulShutdown
182+ Right (mkConn, addr) -> do
183+ fork set mkConn addr app dc fc tm
184+ restore $ acceptConnection set getConnMaker app dc fc tm
212185 where
213− -- FIXME: only IOEception is caught. What about other exceptions?
214186 getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do
215− onE Nothing (toException e)
216− -- "resource exhausted (Too many open files)" may happen by accept().
217− -- Wait a second hoping that resource will be available.
218− threadDelay 1000000
219− getConnLoop
220−
221− onE mreq e =
222− case fromException e of
223− Just (NotEnoughLines []) -> return ()
224− _ -> settingsOnException set mreq e
225−
187+ onE set Nothing (toException e)
188+ if isFullErrorType (ioeGetErrorType e) then do
189+ -- "resource exhausted (Too many open files)" may happen
190+ -- by accept().
191+ -- Wait a second hoping that resource will be available.
192+ threadDelay 1000000
193+ getConnLoop
194+ else
195+ throwIO e
196+
197+-- Fork a new worker thread for this connection maker, and ask for a
198+-- function to unmask (i.e., allow async exceptions to be thrown).
199+fork :: Settings
200+ -> IO (Connection, Bool)
201+ -> SockAddr
202+ -> Application
203+ -> D.DateCache
204+ -> Maybe F.MutableFdCache
205+ -> T.Manager
206+ -> IO ()
207+fork set mkConn addr app dc fc tm = void $ forkIOWithUnmask $ \unmask ->
208+ -- Run the connection maker to get a new connection, and ensure
209+ -- that the connection is closed. If the mkConn call throws an
210+ -- exception, we will leak the connection. If the mkConn call is
211+ -- vulnerable to attacks (e.g., Slowloris), we do nothing to
212+ -- protect the server. It is therefore vital that mkConn is well
213+ -- vetted.
214+ --
215+ -- We grab the connection before registering timeouts since the
216+ -- timeouts will be useless during connection creation, due to the
217+ -- fact that async exceptions are still masked.
218+ bracket mkConn closeConn $ \(conn0, isSecure') ->
219+
220+ -- We need to register a timeout handler for this thread, and
221+ -- cancel that handler as soon as we exit.
222+ bracket (T.registerKillThread tm) T.cancel $ \th ->
223+
224+ let ii = InternalInfo th fc dc
225+ conn = setSendFile conn0 fc
226+ -- We now have fully registered a connection close handler
227+ -- in the case of all exceptions, so it is safe to one
228+ -- again allow async exceptions.
229+ in unmask .
230+ -- Call the user-supplied on exception code if any
231+ -- exceptions are thrown.
232+ handle (onE set Nothing) .
233+
234+ -- Call the user-supplied code for connection open and close events
235+ bracket (onOpen addr) (onClose addr) $ \goingon ->
236+
237+ -- Actually serve this connection.
238+ -- onnClose above ensures the termination of the connection.
239+ when goingon $ serveConnection conn ii addr isSecure' set app
240+ where
226241 closeConn (conn, _isSecure) = connClose conn
227242
228243 onOpen = settingsOnOpen set
229− onClose addr _ = settingsOnClose set addr
244+ onClose adr _ = settingsOnClose set adr
230245
231246serveConnection :: Connection
232247 -> InternalInfo
@@ -315,3 +330,6 @@ setSocketCloseOnExec _ = return ()
315330setSocketCloseOnExec socket =
316331 setFdOption (fromIntegral $ fdSocket socket) CloseOnExec True
317332#endif
333+
334+gracefulShutdown :: IO ()
335+gracefulShutdown = return ()