@@ -10,7 +10,7 @@ import Control.Arrow (first)
1010import Control.Concurrent (threadDelay, forkIOWithUnmask)
1111import qualified Control.Concurrent as Conc (yield)
1212import Control.Exception as E
13−import Control.Monad (forever, when, unless, void)
13+import Control.Monad (when, unless, void)
1414import Data.ByteString (ByteString)
1515import qualified Data.ByteString as S
1616import Data.IORef (IORef, newIORef, readIORef, writeIORef)
@@ -139,56 +139,76 @@ runSettingsConnectionMakerSecure set getConnMaker app = do
139139 -- First mask all exceptions in the main loop. This is necessary to ensure
140140 -- that no async exception is throw between the call to getConnLoop and the
141141 -- registering of connClose.
142− D.withDateCache $ \dc -> do
143− F.withFdCache (settingsFdCacheDuration set * 1000000) $ \fc -> do
144− withTimeoutManager $ \tm -> mask_ . forever $ do
145− -- Allow async exceptions before receiving the next connection maker.
146− allowInterrupt
147−
148− -- getConnLoop will try to receive the next incoming request. It
149− -- returns a /connection maker/, not a connection, since in some
150− -- circumstances creating a working connection from a raw socket may be
151− -- an expensive operation, and this expensive work should not be
152− -- performed in the main event loop. An example of something expensive
153− -- would be TLS negotiation.
154− (mkConn, addr) <- getConnLoop
155−
156− -- Fork a new worker thread for this connection maker, and ask for a
157− -- function to unmask (i.e., allow async exceptions to be thrown).
142+ D.withDateCache $ \dc ->
143+ F.withFdCache (settingsFdCacheDuration set * 1000000) $ \fc ->
144+ withTimeoutManager $ \tm ->
145+ mask_ $ acceptConnection set getConnMaker app dc fc tm
146+ where
147+ withTimeoutManager f =
148+ case settingsManager set of
149+ Nothing -> bracket
150+ (T.initialize $ settingsTimeout set * 1000000)
151+ T.stopManager
152+ f
153+ Just tm -> f tm
154+
155+acceptConnection :: Settings
156+ -> IO (IO (Connection, Bool), SockAddr)
157+ -> Application
158+ -> D.DateCache
159+ -> Maybe F.MutableFdCache
160+ -> T.Manager
161+ -> IO ()
162+acceptConnection set getConnMaker app dc fc tm = do
163+ -- Allow async exceptions before receiving the next connection maker.
164+ allowInterrupt
165+
166+ -- getConnLoop will try to receive the next incoming request. It
167+ -- returns a /connection maker/, not a connection, since in some
168+ -- circumstances creating a working connection from a raw socket may be
169+ -- an expensive operation, and this expensive work should not be
170+ -- performed in the main event loop. An example of something expensive
171+ -- 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.
158185 --
159− -- GHC 7.8 cannot infer the type of "void . forkIOWithUnmask"
160− void $ forkIOWithUnmask $ \unmask ->
161− -- Run the connection maker to get a new connection, and ensure
162− -- that the connection is closed. If the mkConn call throws an
163− -- exception, we will leak the connection. If the mkConn call is
164− -- vulnerable to attacks (e.g., Slowloris), we do nothing to
165− -- protect the server. It is therefore vital that mkConn is well
166− -- vetted.
167− --
168− -- We grab the connection before registering timeouts since the
169− -- timeouts will be useless during connection creation, due to the
170− -- fact that async exceptions are still masked.
171− bracket mkConn (connClose . fst) $ \(conn', isSecure') ->
172−
173− -- We need to register a timeout handler for this thread, and
174− -- cancel that handler as soon as we exit.
175− bracket (T.registerKillThread tm) T.cancel $ \th ->
176− let ii = InternalInfo th fc dc
177− conn = setSendFile conn' fc
178− -- We now have fully registered a connection close handler
179− -- in the case of all exceptions, so it is safe to one
180− -- again allow async exceptions.
181− in unmask .
182− -- Call the user-supplied on exception code if any
183− -- exceptions are thrown.
184− handle (onE Nothing) .
185−
186− -- Call the user-supplied code for connection open and close events
187− bracket (onOpen addr) (const $ onClose addr) $ \goingon ->
188−
189− -- Actually serve this connection.
190− -- onnClose above ensures the termination of the connection.
191− when goingon $ serveConnection conn ii addr isSecure' set app
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 (connClose . fst) $ \(conn', 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 conn' 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) (const $ 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
192212 where
193213 -- FIXME: only IOEception is caught. What about other exceptions?
194214 getConnLoop = getConnMaker `E.catch` \(e :: IOException) -> do
@@ -197,21 +217,15 @@ runSettingsConnectionMakerSecure set getConnMaker app = do
197217 -- Wait a second hoping that resource will be available.
198218 threadDelay 1000000
199219 getConnLoop
220+
200221 onE mreq e =
201222 case fromException e of
202223 Just (NotEnoughLines []) -> return ()
203224 _ -> settingsOnException set mreq e
225+
204226 onOpen = settingsOnOpen set
205227 onClose = settingsOnClose set
206228
207− withTimeoutManager f =
208− case settingsManager set of
209− Nothing -> bracket
210− (T.initialize $ settingsTimeout set * 1000000)
211− T.stopManager
212− f
213− Just tm -> f tm
214−
215229serveConnection :: Connection
216230 -> InternalInfo
217231 -> SockAddr