@@ -1,12 +1,13 @@
11{-# LANGUAGE DeriveDataTypeable #-}
22{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
3+{-# LANGUAGE PatternGuards #-}
34
45module Network.Wai.Handler.Warp.HTTP2.Worker where
56
67import Control.Concurrent
78import Control.Concurrent.STM
89import Control.Exception as E
9−import Control.Monad (void, forever, when)
10+import Control.Monad (void, when)
1011import Data.Typeable
1112import qualified Network.HTTP.Types as H
1213import Network.HTTP2
@@ -18,7 +19,7 @@ import Network.Wai.Handler.Warp.IORef
1819import qualified Network.Wai.Handler.Warp.Response as R
1920import qualified Network.Wai.Handler.Warp.Settings as S
2021import qualified Network.Wai.Handler.Warp.Timeout as T
21−import Network.Wai.Internal (Response(..), ResponseReceived(..))
22+import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))
2223
2324----------------------------------------------------------------
2425
@@ -60,28 +61,35 @@ worker :: Context -> S.Settings -> T.Manager -> Application -> Responder -> IO (
6061worker ctx@Context{inputQ,outputQ} set tm app responder = do
6162 tid <- myThreadId
6263 ref <- newIORef Nothing
63− bracket (T.register tm (E.throwTo tid Break)) T.cancel $ \th ->
64− go th ref `E.catch` gonext th ref
64+ let setup = T.register tm $ E.throwTo tid Break
65+ bracket setup T.cancel $ go ref
6566 where
66− go th ref = forever $ do
67+ go ref th = do
68+ T.pause th
6769 Input strm req pri <- atomically $ readTQueue inputQ
70+ T.resume th
6871 T.tickle th
6972 writeIORef ref (Just strm)
70− -- catching IO errors.
71− E.handle (S.settingsOnException set Nothing)
72− (void $ app req $ responder strm pri req)
73− gonext th ref Break = handleErrorAndGo `E.catch` gonext th ref
74− where
75− handleErrorAndGo = do
76− m <- readIORef ref
77− case m of
78− Nothing -> return ()
79− Just strm -> do
80− let frame = resetFrame InternalError (streamNumber strm)
81− enqueue outputQ (OFrame frame) highestPriority
82− closed ctx strm Killed
83− writeIORef ref Nothing
84− go th ref
73+ ex <- E.try $ app req $ responder strm pri req
74+ case ex of
75+ Right ResponseReceived -> return ()
76+ Left e@(SomeException _)
77+ | Just Break <- fromException e -> cleanup ref
78+ -- killed by the sender
79+ | Just ThreadKilled <- fromException e -> cleanup ref
80+ | otherwise -> do
81+ cleanup ref
82+ S.settingsOnException set (Just req) e
83+ go ref th
84+ cleanup ref = do
85+ m <- readIORef ref
86+ case m of
87+ Nothing -> return ()
88+ Just strm -> do
89+ closed ctx strm Killed
90+ let frame = resetFrame InternalError (streamNumber strm)
91+ enqueue outputQ (OFrame frame) highestPriority
92+ writeIORef ref Nothing
8593
8694waiter :: TVar Sync -> TBQueue Sequence
8795 -> (Output -> Priority -> IO ()) -> Stream -> Priority