@@ -2,6 +2,8 @@
2{-# LANGUAGE NamedFieldPuns #-}
2{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE PatternGuards #-}
3{-# LANGUAGE PatternGuards #-}
4{-# LANGUAGE CPP #-}
4{-# LANGUAGE CPP #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
6+{-# LANGUAGE OverloadedStrings #-}
6module Network.Wai.Handler.Warp.HTTP2.Worker (
8module Network.Wai.Handler.Warp.HTTP2.Worker (
@@ -17,18 +19,23 @@ import Control.Concurrent.STM
17import Control.Exception (Exception, SomeException(..), AsyncException(..))
19import Control.Exception (Exception, SomeException(..), AsyncException(..))
18import qualified Control.Exception as E
20import qualified Control.Exception as E
19import Control.Monad (void, when)
21import Control.Monad (void, when)
22+import Data.ByteString.Builder (byteString)
20import Data.Typeable
23import Data.Typeable
21import qualified Network.HTTP.Types as H
24import qualified Network.HTTP.Types as H
22import Network.HTTP2
25import Network.HTTP2
23import Network.HTTP2.Priority
26import Network.HTTP2.Priority
24import Network.Wai
27import Network.Wai
28+import Network.Wai.Handler.Warp.File
29+import Network.Wai.Handler.Warp.FileInfoCache
25import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
30import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
26import Network.Wai.Handler.Warp.HTTP2.Manager
31import Network.Wai.Handler.Warp.HTTP2.Manager
27import Network.Wai.Handler.Warp.HTTP2.Types
32import Network.Wai.Handler.Warp.HTTP2.Types
33+import Network.Wai.Handler.Warp.Header
28import Network.Wai.Handler.Warp.IORef
34import Network.Wai.Handler.Warp.IORef
29import qualified Network.Wai.Handler.Warp.Response as R
35import qualified Network.Wai.Handler.Warp.Response as R
30import qualified Network.Wai.Handler.Warp.Settings as S
36import qualified Network.Wai.Handler.Warp.Settings as S
31import qualified Network.Wai.Handler.Warp.Timeout as T
37import qualified Network.Wai.Handler.Warp.Timeout as T
38+import Network.Wai.Handler.Warp.Types
32import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))
39import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..))
34----------------------------------------------------------------
41----------------------------------------------------------------
@@ -42,42 +49,88 @@ type Responder = ThreadContinue -> T.Handle -> Stream -> Request ->
42-- | This function is passed to workers.
49-- | This function is passed to workers.
43-- They also pass 'Response's from 'Application's to this function.
50-- They also pass 'Response's from 'Application's to this function.
44-- This function enqueues commands for the HTTP/2 sender.
51-- This function enqueues commands for the HTTP/2 sender.
45−response :: Context -> Manager -> Responder
52+response :: InternalInfo -> S.Settings -> Context -> Manager -> Responder
46−response Context{outputQ} mgr tconf th strm req rsp = do
53+response ii settings Context{outputQ} mgr tconf th strm req rsp
47− case rsp of
54+ | R.hasBody s0 = case rsp of
48− ResponseStream _ _ strmbdy -> do
55+ ResponseStream _ _ strmbdy
56+ | isHead -> responseNoBody s0 hs0
57+ | otherwise -> responseStreaming strmbdy
58+ ResponseBuilder _ _ b
59+ | isHead -> responseNoBody s0 hs0
60+ | otherwise -> responseBuilderBody s0 hs0 b
61+ ResponseFile _ _ p mp -> responseFileXXX p mp
62+ ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw"
63+ | otherwise = responseNoBody s0 hs0
65+ isHead = requestMethod req == H.methodHead
66+ s0 = responseStatus rsp
67+ hs0 = responseHeaders rsp
68+ logger = S.settingsLogger settings req
70+ responseNoBody s hs = responseBuilderBody s hs mempty
72+ responseBuilderBody s hs bdy = do
73+ writeIORef (streamLogger strm) (logger s Nothing)
74+ setThreadContinue tconf True
75+ let rsp' = ResponseBuilder s hs bdy
76+ out = OResponse strm rsp' (Oneshot True)
77+ enqueueOrSpawnTemporaryWaiter strm outputQ out
78+ return ResponseReceived
80+ responseFileXXX path Nothing = do
81+ efinfo <- E.try $ fileInfo ii path
83+ Left (_ex :: E.IOException) -> response404
84+ Right finfo -> case conditionalRequest finfo hs0 (indexRequestHeader (requestHeaders req)) of
85+ WithoutBody s -> responseNoBody s hs0
86+ WithBody s hs beg len -> responseFile2XX s hs path (Just (FilePart beg len (fileInfoSize finfo)))
88+ responseFileXXX path mpart = responseFile2XX s0 hs0 path mpart
90+ responseFile2XX s hs path mpart
91+ | isHead = responseNoBody s hs
93+ writeIORef (streamLogger strm) (logger s (filePartByteCount <$> mpart))
94+ setThreadContinue tconf True
95+ let rsp' = ResponseFile s hs path mpart
96+ out = OResponse strm rsp' (Oneshot True)
97+ enqueueOrSpawnTemporaryWaiter strm outputQ out
98+ return ResponseReceived
100+ response404 = responseBuilderBody s hs body
103+ hs = R.replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
104+ body = byteString "File not found"
106+ responseStreaming strmbdy = do
107+ writeIORef (streamLogger strm) (logger s0 Nothing)
49− -- We must not exit this WAI application.
108+ -- We must not exit this WAI application.
50− -- If the application exits, streaming would be also closed.
109+ -- If the application exits, streaming would be also closed.
51− -- So, this work occupies this thread.
110+ -- So, this work occupies this thread.
53− -- We need to increase the number of workers.
112+ -- We need to increase the number of workers.
54− myThreadId >>= replaceWithAction mgr
113+ myThreadId >>= replaceWithAction mgr
55− -- After this work, this thread stops to decease
114+ -- After this work, this thread stops to decease
56− -- the number of workers.
115+ -- the number of workers.
57− setThreadContinue tconf False
116+ setThreadContinue tconf False
58− -- Since 'StreamingBody' is loop, we cannot control it.
117+ -- Since 'StreamingBody' is loop, we cannot control it.
59− -- So, let's serialize 'Builder' with a designated queue.
118+ -- So, let's serialize 'Builder' with a designated queue.
60− sq <- newTBQueueIO 10 -- fixme: hard coding: 10
119+ sq <- newTBQueueIO 10 -- fixme: hard coding: 10
61− tvar <- newTVarIO SyncNone
120+ tvar <- newTVarIO SyncNone
62− let out = OResponse strm rsp (Persist sq tvar)
121+ let out = OResponse strm rsp (Persist sq tvar)
63− -- Since we must not enqueue an empty queue to the priority
122+ -- Since we must not enqueue an empty queue to the priority
64− -- queue, we spawn a thread to ensure that the designated
123+ -- queue, we spawn a thread to ensure that the designated
65− -- queue is not empty.
124+ -- queue is not empty.
66− void $ forkIO $ waiter tvar sq outputQ
125+ void $ forkIO $ waiter tvar sq outputQ
67− atomically $ writeTVar tvar (SyncNext out)
126+ atomically $ writeTVar tvar (SyncNext out)
68− let push b = do
127+ let push b = do
69− atomically $ writeTBQueue sq (SBuilder b)
128+ atomically $ writeTBQueue sq (SBuilder b)
70− T.tickle th
129+ T.tickle th
71− flush = atomically $ writeTBQueue sq SFlush
130+ flush = atomically $ writeTBQueue sq SFlush
72− strmbdy push flush
131+ _ <- strmbdy push flush
73− atomically $ writeTBQueue sq SFinish
132+ atomically $ writeTBQueue sq SFinish
75− setThreadContinue tconf True
76− let hasBody = requestMethod req /= H.methodHead
77− && R.hasBody (responseStatus rsp)
78− out = OResponse strm rsp (Oneshot hasBody)
79− enqueueOrSpawnTemporaryWaiter strm outputQ out
80− return ResponseReceived
133+ return ResponseReceived
82data Break = Break deriving (Show, Typeable)
135data Break = Break deriving (Show, Typeable)