git.iko.soy/typeable/wai
on master help sign in
Using Network.HTTP2.Server.
2e21fe3Kazu Yamamoto
warp/Network/Wai/Handler/Warp/HTTP2.hs+61−54
compare with master
unifiedsplit
@@ -1,69 +1,76 @@
1−{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE BangPatterns #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE PatternGuards #-}
5+{-# LANGUAGE ScopedTypeVariables #-}
3
6
4−module Network.Wai.Handler.Warp.HTTP2 (isHTTP2, http2) where
7+module Network.Wai.Handler.Warp.HTTP2 (http2) where
5
8
6−import Control.Concurrent (forkIO, killThread)
7import qualified Control.Exception as E
9import qualified Control.Exception as E
8−import Network.HTTP2
10+import qualified Network.HTTP2.Server as H2
9import Network.Socket (SockAddr)
11import Network.Socket (SockAddr)
10import Network.Wai
12import Network.Wai
13+import Network.Wai.Internal (ResponseReceived(..))
14+import qualified System.TimeManager as T
11
15
12−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
16+import Network.Wai.Handler.Warp.HTTP2.File
13−import Network.Wai.Handler.Warp.HTTP2.Manager
17+import Network.Wai.Handler.Warp.HTTP2.PushPromise
14−import Network.Wai.Handler.Warp.HTTP2.Receiver
15import Network.Wai.Handler.Warp.HTTP2.Request
18import Network.Wai.Handler.Warp.HTTP2.Request
16−import Network.Wai.Handler.Warp.HTTP2.Sender
19+import Network.Wai.Handler.Warp.HTTP2.Response
17−import Network.Wai.Handler.Warp.HTTP2.Types
18−import Network.Wai.Handler.Warp.HTTP2.Worker
19import Network.Wai.Handler.Warp.Imports
20import Network.Wai.Handler.Warp.Imports
20−import qualified Network.Wai.Handler.Warp.Settings as S (Settings)
21+import qualified Network.Wai.Handler.Warp.Settings as S
21import Network.Wai.Handler.Warp.Types
22import Network.Wai.Handler.Warp.Types
22
23
23----------------------------------------------------------------
24----------------------------------------------------------------
24
25
25−http2 :: Connection -> InternalInfo -> SockAddr -> Transport -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()
26+http2 :: Connection -> InternalInfo -> SockAddr -> S.Settings -> (BufSize -> IO ByteString) -> Application -> IO ()
26−http2 conn ii addr transport settings readN app = do
27+http2 conn ii addr settings readN app =
27− checkTLS
28+ H2.run conf http2server
28− ok <- checkPreface
29− when ok $ do
30− ctx <- newContext
31− -- Workers, worker manager and timer manager
32− mgr <- start settings
33− let responder = response settings ctx mgr
34− action = worker ctx settings app responder
35− setAction mgr action
36− -- The number of workers is 3.
37− -- This was carefully chosen based on a lot of benchmarks.
38− -- If it is 1, we cannot avoid head-of-line blocking.
39− -- If it is large, huge memory is consumed and many
40− -- context switches happen.
41− replicateM_ 3 $ spawnAction mgr
42− -- Receiver
43− let mkreq = mkRequest ii settings addr
44− tid <- forkIO $ frameReceiver ctx ii mkreq readN
45− -- Sender
46− -- frameSender is the main thread because it ensures to send
47− -- a goway frame.
48− frameSender ctx conn settings mgr `E.finally` do
49− clearContext ctx
50− stop mgr
51− killThread tid
52 where
29 where
53− checkTLS = case transport of
30+ conf = H2.Config {
54− TCP -> return () -- direct
31+ confWriteBuffer = connWriteBuffer conn
55− tls -> unless (tls12orLater tls) $ goaway conn InadequateSecurity "Weak TLS"
32+ , confBufferSize = connBufferSize conn
56− tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3
33+ , confSendAll = connSendAll conn
57− checkPreface = do
34+ , confReadN = readN
58− preface <- readN connectionPrefaceLength
35+ , confPositionReadMaker = pReadMaker ii
59− if connectionPreface /= preface then do
36+ }
60− goaway conn ProtocolError "Preface mismatch"
61− return False
62− else
63− return True
64
37
65−-- connClose must not be called here since Run:fork calls it
38+ http2server h2req aux response = do
66−goaway :: Connection -> ErrorCodeId -> ByteString -> IO ()
39+ req <- toWAIRequest h2req aux
67−goaway Connection{..} etype debugmsg = connSendAll bytestream
40+ ResponseReceived <- app req $ \rsp -> do
41+ h2rsp <- fromResponse settings ii req rsp
42+ pps <- fromPushPromises ii req
43+ ex <- E.try $ response h2rsp pps
44+ case ex of
45+ Right () -> do
46+ logResponse h2rsp req
47+ mapM_ (logPushPromise req) pps
48+ Left e@(E.SomeException _)
49+ -- killed by the local worker manager
50+ | Just E.ThreadKilled <- E.fromException e -> return ()
51+ -- killed by the local timeout manager
52+ | Just T.TimeoutThread <- E.fromException e -> return ()
53+ | otherwise -> S.settingsOnException settings (Just req) e
54+ return ResponseReceived
55+ return ()
56+
57+ toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th
58+ where
59+ !hdr = H2.requestHeaders h2req
60+ !bdy = H2.getRequestBodyChunk h2req
61+ !bdylen = H2.requestBodySize h2req
62+ !th = H2.auxTimeHandle aux
63+
64+ logResponse h2rsp req = logger req st msiz
68− where
65+ where
69− bytestream = goawayFrame 0 etype debugmsg
66+ !logger = S.settingsLogger settings
67+ !st = H2.responseStatus h2rsp
68+ !msiz = fromIntegral <$> H2.responseBodySize h2rsp
69+
70+ logPushPromise req pp = logger req path siz
71+ where
72+ !logger = S.settingsServerPushLogger settings
73+ !path = H2.promiseRequestPath pp
74+ !siz = case H2.responseBodySize $ H2.promiseResponse pp of
75+ Nothing -> 0
76+ Just s -> fromIntegral s
warp/Network/Wai/Handler/Warp/HTTP2/EncodeFrame.hsdeleted−34
@@ -1,34 +0,0 @@
1−module Network.Wai.Handler.Warp.HTTP2.EncodeFrame where
2−
3−import Network.HTTP2
4−
5−import Network.Wai.Handler.Warp.Imports
6−
7−----------------------------------------------------------------
8−
9−goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString
10−goawayFrame sid etype debugmsg = encodeFrame einfo frame
11− where
12− einfo = encodeInfo id 0
13− frame = GoAwayFrame sid etype debugmsg
14−
15−resetFrame :: ErrorCodeId -> StreamId -> ByteString
16−resetFrame etype sid = encodeFrame einfo frame
17− where
18− einfo = encodeInfo id sid
19− frame = RSTStreamFrame etype
20−
21−settingsFrame :: (FrameFlags -> FrameFlags) -> SettingsList -> ByteString
22−settingsFrame func alist = encodeFrame einfo $ SettingsFrame alist
23− where
24− einfo = encodeInfo func 0
25−
26−pingFrame :: ByteString -> ByteString
27−pingFrame bs = encodeFrame einfo $ PingFrame bs
28− where
29− einfo = encodeInfo setAck 0
30−
31−windowUpdateFrame :: StreamId -> WindowSize -> ByteString
32−windowUpdateFrame sid winsiz = encodeFrame einfo $ WindowUpdateFrame winsiz
33− where
34− einfo = encodeInfo id sid
warp/Network/Wai/Handler/Warp/HTTP2/File.hs+19−151
@@ -1,157 +1,25 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE BangPatterns #-}
4
2
5−module Network.Wai.Handler.Warp.HTTP2.File (
3+module Network.Wai.Handler.Warp.HTTP2.File where
6− RspFileInfo(..)
7− , conditionalRequest
8− , addContentHeadersForFilePart
9− , H.parseByteRanges
10− ) where
11
4
12−import qualified Data.ByteString.Char8 as C8 (pack)
5+import Network.HTTP2.Server
13−import Network.HPACK
14−import Network.HPACK.Token
15−import Network.HTTP.Date
16−import qualified Network.HTTP.Types as H
17−import Network.Wai
18
6
7+#ifdef WINDOWS
8+pReadMaker :: InternalInfo -> PositionReadMaker
9+pReadMaker = defaultPositionReadMaker
10+#else
19−import qualified Network.Wai.Handler.Warp.FileInfoCache as I
11+import Network.Wai.Handler.Warp.FdCache
20−import Network.Wai.Handler.Warp.Imports
12+import Network.Wai.Handler.Warp.Types
21−import Network.Wai.Handler.Warp.PackInt
13+import Network.Wai.Handler.Warp.SendFile (positionRead)
22
14
23−-- $setup
15+pReadMaker :: InternalInfo -> PositionReadMaker
24−-- >>> import Test.QuickCheck
16+pReadMaker ii path = do
25−
17+ (Just fd, refresh) <- getFd ii path
26−----------------------------------------------------------------
18+ return (pread fd, Refresher refresh)
27−
28−data RspFileInfo = WithoutBody !H.Status
29− | WithBody !H.Status !TokenHeaderList !Integer !Integer
30− deriving (Eq,Show)
31−
32−----------------------------------------------------------------
33−
34−conditionalRequest :: I.FileInfo
35− -> TokenHeaderList -- Response
36− -> ValueTable -- Request
37− -> RspFileInfo
38−conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of
39− nobody@(WithoutBody _) -> nobody
40− WithBody s _ off len -> let !hs = (tokenLastModified,date) :
41− addContentHeaders ths0 off len size
42− in WithBody s hs off len
43− where
44− !mcondition = ifmodified reqtbl size mtime
45− <|> ifunmodified reqtbl size mtime
46− <|> ifrange reqtbl size mtime
47− !condition = fromMaybe (unconditional reqtbl size) mcondition
48−
49−----------------------------------------------------------------
50−
51−{-# INLINE ifModifiedSince #-}
52−ifModifiedSince :: ValueTable -> Maybe HTTPDate
53−ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate
54−
55−{-# INLINE ifUnmodifiedSince #-}
56−ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate
57−ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate
58−
59−{-# INLINE ifRange #-}
60−ifRange :: ValueTable -> Maybe HTTPDate
61−ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate
62−
63−----------------------------------------------------------------
64−
65−{-# INLINE ifmodified #-}
66−ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
67−ifmodified reqtbl size mtime = do
68− date <- ifModifiedSince reqtbl
69− return $ if date /= mtime
70− then unconditional reqtbl size
71− else WithoutBody H.notModified304
72−
73−{-# INLINE ifunmodified #-}
74−ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
75−ifunmodified reqtbl size mtime = do
76− date <- ifUnmodifiedSince reqtbl
77− return $ if date == mtime
78− then unconditional reqtbl size
79− else WithoutBody H.preconditionFailed412
80−
81−{-# INLINE ifrange #-}
82−ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
83−ifrange reqtbl size mtime = do
84− date <- ifRange reqtbl
85− rng <- getHeaderValue tokenRange reqtbl
86− return $ if date == mtime
87− then parseRange rng size
88− else WithBody H.ok200 [] 0 size
89−
90−{-# INLINE unconditional #-}
91−unconditional :: ValueTable -> Integer -> RspFileInfo
92−unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of
93− Nothing -> WithBody H.ok200 [] 0 size
94− Just rng -> parseRange rng size
95−
96−----------------------------------------------------------------
97−
98−{-# INLINE parseRange #-}
99−parseRange :: ByteString -> Integer -> RspFileInfo
100−parseRange rng size = case H.parseByteRanges rng of
101− Nothing -> WithoutBody H.requestedRangeNotSatisfiable416
102− Just [] -> WithoutBody H.requestedRangeNotSatisfiable416
103− Just (r:_) -> let (!beg, !end) = checkRange r size
104− !len = end - beg + 1
105− s = if beg == 0 && end == size - 1 then
106− H.ok200
107− else
108− H.partialContent206
109− in WithBody s [] beg len
110−
111−{-# INLINE checkRange #-}
112−checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
113−checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)
114−checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)
115−checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)
116−
117−----------------------------------------------------------------
118−
119−{-# INLINE contentRangeHeader #-}
120−-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
121−-- for the range specified.
122−contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader
123−contentRangeHeader beg end total = (tokenContentRange, range)
124− where
125− range = C8.pack
126− -- building with ShowS
127− $ 'b' : 'y': 't' : 'e' : 's' : ' '
128− : (if beg > end then ('*':) else
129− showInt beg
130− . ('-' :)
131− . showInt end)
132− ( '/'
133− : showInt total "")
134−
135−{-# INLINE addContentHeaders #-}
136−addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList
137−addContentHeaders ths off len size
138− | len == size = ths'
139− | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size
140− in ctrng:ths'
141− where
142− !lengthBS = packIntegral len
143− !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths
144−
145−{-# INLINE addContentHeadersForFilePart #-}
146−-- |
147−--
148−-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
149−-- [(Token {ix = 20, shouldBeIndexed = True, isPseudo = False, tokenKey = "Content-Range"},"bytes 2-11/16"),(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"10"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]
150−-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
151−-- [(Token {ix = 18, shouldBeIndexed = False, isPseudo = False, tokenKey = "Content-Length"},"16"),(Token {ix = 8, shouldBeIndexed = True, isPseudo = False, tokenKey = "Accept-Ranges"},"bytes")]
152−addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList
153−addContentHeadersForFilePart hs part = addContentHeaders hs off len size
154 where
19 where
155− off = filePartOffset part
20+ pread :: Fd -> PositionRead
156− len = filePartByteCount part
21+ pread fd off bytes buf = fromIntegral <$> positionRead fd buf bytes' off'
157− size = filePartFileSize part
22+ where
23+ bytes' = fromIntegral bytes
24+ off' = fromIntegral off
25+#endif
warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hsdeleted−130
@@ -1,130 +0,0 @@
1−{-# LANGUAGE OverloadedStrings, BangPatterns #-}
2−{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
3−
4−module Network.Wai.Handler.Warp.HTTP2.HPACK (
5− hpackEncodeHeader
6− , hpackEncodeHeaderLoop
7− , hpackDecodeHeader
8− , just
9− , fixHeaders
10− , addHeader -- testing
11− , deleteUnnecessaryHeaders
12− ) where
13−
14−import qualified Control.Exception as E
15−import Network.HPACK hiding (Buffer)
16−import Network.HPACK.Token
17−import Network.HTTP2
18−
19−import Network.Wai.Handler.Warp.HTTP2.Types
20−import Network.Wai.Handler.Warp.Imports
21−import Network.Wai.Handler.Warp.PackInt
22−import qualified Network.Wai.Handler.Warp.Settings as S
23−import Network.Wai.Handler.Warp.Types
24−
25−-- $setup
26−-- >>> :set -XOverloadedStrings
27−
28−----------------------------------------------------------------
29−
30−{-# INLINE addHeader #-}
31−addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList
32−addHeader t "" _ ths
33− | t == tokenServer = filter ((/= tokenServer) . fst) ths
34−addHeader t v tbl ths = case getHeaderValue t tbl of
35− Nothing -> (t,v) : ths
36− _ -> ths
37−
38−fixHeaders :: Context
39− -> Rspn
40− -> InternalInfo
41− -> S.Settings
42− -> IO TokenHeaderList
43−fixHeaders Context{..} rspn ii settings = do
44− date <- getDate ii
45− let !s = rspnStatus rspn
46− !status = packStatus s
47− !defServer = S.settingsServerName settings
48− (!ths0,tbl) = rspnHeaders rspn
49− !ths1 = addHeader tokenServer defServer tbl ths0
50− !ths2 = addHeader tokenDate date tbl ths1
51− !ths3 = (tokenStatus, status) : ths2
52− !ths4 = deleteUnnecessaryHeaders ths3 tbl
53− return ths4
54−
55−deleteUnnecessaryHeaders :: TokenHeaderList -> ValueTable -> TokenHeaderList
56−deleteUnnecessaryHeaders htl0 tbl0 = loop headersToBeRemoved htl0
57− where
58− loop [] thl = thl
59− loop (t:ts) thl = case getHeaderValue t tbl0 of
60− Nothing -> thl
61− _ -> let !thl' = filter ((/= t) . fst) thl
62− in loop ts thl'
63−
64−headersToBeRemoved :: [Token]
65−headersToBeRemoved = [ tokenConnection
66− , tokenTransferEncoding
67− -- Keep-Alive:
68− -- Proxy-Connection:
69− -- Upgrade:
70− ]
71−
72−----------------------------------------------------------------
73−
74−strategy :: EncodeStrategy
75−strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }
76−
77−-- Set-Cookie: contains only one cookie value.
78−-- So, we don't need to split it.
79−hpackEncodeHeader :: Context -> Buffer -> BufSize
80− -> TokenHeaderList
81− -> IO (TokenHeaderList, Int)
82−hpackEncodeHeader Context{..} buf siz ths =
83− encodeTokenHeader buf siz strategy True encodeDynamicTable ths
84−
85−hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize
86− -> TokenHeaderList
87− -> IO (TokenHeaderList, Int)
88−hpackEncodeHeaderLoop Context{..} buf siz hs =
89− encodeTokenHeader buf siz strategy False encodeDynamicTable hs
90−
91−----------------------------------------------------------------
92−
93−hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable)
94−hpackDecodeHeader hdrblk Context{..} = do
95− tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl
96− unless (checkRequestHeader vt) $
97− E.throwIO $ ConnectionError ProtocolError "the header key is illegal"
98− return tbl
99− where
100− handl IllegalHeaderName =
101− E.throwIO $ ConnectionError ProtocolError "the header key is illegal"
102− handl _ =
103− E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
104−
105−{-# INLINE checkRequestHeader #-}
106−checkRequestHeader :: ValueTable -> Bool
107−checkRequestHeader reqvt
108− | just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme
109− | isJust mStatus = False
110− | isNothing mMethod = False
111− | isNothing mScheme = False
112− | isNothing mPath = False
113− | mPath == Just "" = False
114− | isJust mConnection = False
115− | just mTE (/= "trailers") = False
116− | otherwise = True
117− where
118− mStatus = getHeaderValue tokenStatus reqvt
119− mScheme = getHeaderValue tokenScheme reqvt
120− mPath = getHeaderValue tokenPath reqvt
121− mMethod = getHeaderValue tokenMethod reqvt
122− mConnection = getHeaderValue tokenConnection reqvt
123− mTE = getHeaderValue tokenTE reqvt
124−
125−{-# INLINE just #-}
126−just :: Maybe a -> (a -> Bool) -> Bool
127−just Nothing _ = False
128−just (Just x) p
129− | p x = True
130− | otherwise = False
warp/Network/Wai/Handler/Warp/HTTP2/Manager.hsdeleted−95
@@ -1,95 +0,0 @@
1−{-# LANGUAGE CPP, BangPatterns #-}
2−
3−-- | A thread pool manager.
4−-- The manager has responsibility to spawn and kill
5−-- worker threads.
6−module Network.Wai.Handler.Warp.HTTP2.Manager (
7− Manager
8− , start
9− , setAction
10− , stop
11− , spawnAction
12− , addMyId
13− , deleteMyId
14− ) where
15−
16−import Control.Concurrent
17−import Control.Concurrent.STM
18−import Data.Foldable
19−import Data.IORef
20−import Data.Set (Set)
21−import qualified Data.Set as Set
22−import qualified System.TimeManager as T
23−
24−import Network.Wai.Handler.Warp.Imports
25−import Network.Wai.Handler.Warp.Settings
26−
27−----------------------------------------------------------------
28−
29−type Action = T.Manager -> IO ()
30−
31−data Command = Stop | Spawn | Add ThreadId | Delete ThreadId
32−
33−data Manager = Manager (TQueue Command) (IORef Action)
34−
35−-- | Starting a thread pool manager.
36−-- Its action is initially set to 'return ()' and should be set
37−-- by 'setAction'. This allows that the action can include
38−-- the manager itself.
39−start :: Settings -> IO Manager
40−start set = do
41− q <- newTQueueIO
42− ref <- newIORef (\_ -> return ())
43− timmgr <- T.initialize $ settingsTimeout set * 1000000
44− void $ forkIO $ go q Set.empty ref timmgr
45− return $ Manager q ref
46− where
47− go q !tset0 ref timmgr = do
48− x <- atomically $ readTQueue q
49− case x of
50− Stop -> kill tset0 >> T.killManager timmgr
51− Spawn -> next tset0
52− Add newtid -> let !tset = add newtid tset0
53− in go q tset ref timmgr
54− Delete oldtid -> let !tset = del oldtid tset0
55− in go q tset ref timmgr
56− where
57− next tset = do
58− action <- readIORef ref
59− newtid <- forkIO (action timmgr)
60− let !tset' = add newtid tset
61− go q tset' ref timmgr
62−
63−setAction :: Manager -> Action -> IO ()
64−setAction (Manager _ ref) action = writeIORef ref action
65−
66−stop :: Manager -> IO ()
67−stop (Manager q _) = atomically $ writeTQueue q Stop
68−
69−spawnAction :: Manager -> IO ()
70−spawnAction (Manager q _) = atomically $ writeTQueue q Spawn
71−
72−addMyId :: Manager -> IO ()
73−addMyId (Manager q _) = do
74− tid <- myThreadId
75− atomically $ writeTQueue q $ Add tid
76−
77−deleteMyId :: Manager -> IO ()
78−deleteMyId (Manager q _) = do
79− tid <- myThreadId
80− atomically $ writeTQueue q $ Delete tid
81−
82−----------------------------------------------------------------
83−
84−add :: ThreadId -> Set ThreadId -> Set ThreadId
85−add tid set = set'
86− where
87− !set' = Set.insert tid set
88−
89−del :: ThreadId -> Set ThreadId -> Set ThreadId
90−del tid set = set'
91− where
92− !set' = Set.delete tid set
93−
94−kill :: Set ThreadId -> IO ()
95−kill set = traverse_ killThread set
warp/Network/Wai/Handler/Warp/HTTP2/PushPromise.hsnew file+36
@@ -0,0 +1,36 @@
1+{-# LANGUAGE BangPatterns #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+module Network.Wai.Handler.Warp.HTTP2.PushPromise where
6+
7+import qualified Control.Exception as E
8+import qualified Network.HTTP.Types as H
9+import qualified Network.HTTP2.Server as H2
10+
11+import Network.Wai
12+import Network.Wai.Handler.Warp.FileInfoCache
13+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)
14+import Network.Wai.Handler.Warp.HTTP2.Types
15+import Network.Wai.Handler.Warp.Imports
16+import Network.Wai.Handler.Warp.Types
17+
18+fromPushPromises :: InternalInfo -> Request -> IO [H2.PushPromise]
19+fromPushPromises ii req = do
20+ mh2data <- getHTTP2Data req
21+ let pp = case mh2data of
22+ Nothing -> []
23+ Just h2data -> http2dataPushPromise h2data
24+ catMaybes <$> mapM (fromPushPromise ii) pp
25+
26+fromPushPromise :: InternalInfo -> PushPromise -> IO (Maybe H2.PushPromise)
27+fromPushPromise ii (PushPromise path file rsphdr w) = do
28+ efinfo <- E.try $ getFileInfo ii file
29+ case efinfo of
30+ Left (_ex :: E.IOException) -> return Nothing
31+ Right finfo -> do
32+ let !siz = fromIntegral $ fileInfoSize finfo
33+ !fileSpec = H2.FileSpec file 0 siz
34+ !rsp = H2.responseFile H.ok200 rsphdr fileSpec
35+ !pp = H2.pushPromise path rsp w
36+ return $ Just pp
warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hsdeleted−418
@@ -1,418 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE NamedFieldPuns #-}
3−{-# LANGUAGE BangPatterns #-}
4−{-# LANGUAGE CPP #-}
5−{-# LANGUAGE PatternGuards #-}
6−
7−module Network.Wai.Handler.Warp.HTTP2.Receiver (frameReceiver) where
8−
9−import Control.Concurrent
10−import Control.Concurrent.STM
11−import qualified Control.Exception as E
12−import qualified Data.ByteString as BS
13−import qualified Data.ByteString.Char8 as C8
14−import Data.IORef
15−import Network.HPACK
16−import Network.HPACK.Token
17−import Network.HTTP2
18−import Network.HTTP2.Priority (toPrecedence, delete, prepare)
19−
20−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
21−import Network.Wai.Handler.Warp.HTTP2.HPACK
22−import Network.Wai.Handler.Warp.HTTP2.Request
23−import Network.Wai.Handler.Warp.HTTP2.Types
24−import Network.Wai.Handler.Warp.Imports hiding (delete, insert, readInt)
25−import Network.Wai.Handler.Warp.ReadInt
26−import Network.Wai.Handler.Warp.Types
27−
28−----------------------------------------------------------------
29−
30−frameReceiver :: Context -> InternalInfo -> MkReq -> (BufSize -> IO ByteString) -> IO ()
31−frameReceiver ctx ii mkreq recvN = loop 0 `E.catch` sendGoaway
32− where
33− Context{ http2settings
34− , streamTable
35− , concurrency
36− , continued
37− , clientStreamId
38− , inputQ
39− , controlQ
40− } = ctx
41− sendGoaway e
42− | Just (ConnectionError err msg) <- E.fromException e = do
43− csid <- readIORef clientStreamId
44− let !frame = goawayFrame csid err msg
45− enqueueControl controlQ $ CGoaway frame
46− | otherwise = return ()
47−
48− sendReset err sid = do
49− let !frame = resetFrame err sid
50− enqueueControl controlQ $ CFrame frame
51−
52− loop :: Int -> IO ()
53− loop !n
54− | n == 6 = do
55− yield
56− loop 0
57− | otherwise = do
58− hd <- recvN frameHeaderLength
59− if BS.null hd then
60− enqueueControl controlQ CFinish
61− else do
62− cont <- processStreamGuardingError $ decodeFrameHeader hd
63− when cont $ loop (n + 1)
64−
65− processStreamGuardingError (fid, FrameHeader{streamId})
66− | isResponse streamId &&
67− (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =
68− E.throwIO $ ConnectionError ProtocolError "stream id should be odd"
69− processStreamGuardingError (FrameUnknown _, FrameHeader{payloadLength}) = do
70− mx <- readIORef continued
71− case mx of
72− Nothing -> do
73− -- ignoring unknown frame
74− consume payloadLength
75− return True
76− Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"
77− processStreamGuardingError (FramePushPromise, _) =
78− E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"
79− processStreamGuardingError typhdr@(ftyp, header@FrameHeader{payloadLength}) = do
80− settings <- readIORef http2settings
81− case checkFrameHeader settings typhdr of
82− Left h2err -> case h2err of
83− StreamError err sid -> do
84− sendReset err sid
85− consume payloadLength
86− return True
87− connErr -> E.throwIO connErr
88− Right _ -> do
89− ex <- E.try $ controlOrStream ftyp header
90− case ex of
91− Left (StreamError err sid) -> do
92− sendReset err sid
93− return True
94− Left connErr -> E.throw connErr
95− Right cont -> return cont
96−
97− controlOrStream ftyp header@FrameHeader{streamId, payloadLength}
98− | isControl streamId = do
99− pl <- recvN payloadLength
100− control ftyp header pl ctx
101− | otherwise = do
102− checkContinued
103− !mstrm <- getStream
104− pl <- recvN payloadLength
105− case mstrm of
106− Nothing -> do
107− -- for h2spec only
108− when (ftyp == FramePriority) $ do
109− PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl
110− checkPriority newpri streamId
111− return True -- just ignore this frame
112− Just strm@Stream{streamPrecedence} -> do
113− state <- readStreamState strm
114− state' <- stream ftyp header pl ctx state strm
115− case state' of
116− Open (NoBody tbl@(_,reqvt) pri) -> do
117− resetContinued
118− let mcl = readInt <$> getHeaderValue tokenContentLength reqvt
119− when (just mcl (/= (0 :: Int))) $
120− E.throwIO $ StreamError ProtocolError streamId
121− writeIORef streamPrecedence $ toPrecedence pri
122− halfClosedRemote ctx strm
123− !req <- mkreq tbl (Just 0, return "")
124− atomically $ writeTQueue inputQ $ Input strm req reqvt ii
125− Open (HasBody tbl@(_,reqvt) pri) -> do
126− resetContinued
127− q <- newTQueueIO
128− let !mcl = readInt <$> getHeaderValue tokenContentLength reqvt
129− writeIORef streamPrecedence $ toPrecedence pri
130− bodyLength <- newIORef 0
131− setStreamState ctx strm $ Open (Body q mcl bodyLength)
132− readQ <- newReadBody q
133− bodySource <- mkSource readQ
134− !req <- mkreq tbl (mcl, readSource bodySource)
135− atomically $ writeTQueue inputQ $ Input strm req reqvt ii
136− s@(Open Continued{}) -> do
137− setContinued
138− setStreamState ctx strm s
139− HalfClosedRemote -> do
140− resetContinued
141− halfClosedRemote ctx strm
142− s -> do -- Idle, Open Body, Closed
143− resetContinued
144− setStreamState ctx strm s
145− return True
146− where
147− setContinued = writeIORef continued (Just streamId)
148− resetContinued = writeIORef continued Nothing
149− checkContinued = do
150− mx <- readIORef continued
151− case mx of
152− Nothing -> return ()
153− Just sid
154− | sid == streamId && ftyp == FrameContinuation -> return ()
155− | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"
156− getStream = do
157− mstrm0 <- search streamTable streamId
158− case mstrm0 of
159− js@(Just strm0) -> do
160− when (ftyp == FrameHeaders) $ do
161− st <- readStreamState strm0
162− when (isHalfClosedRemote st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half or fully closed stream"
163− -- Priority made an idele stream
164− when (isIdle st) $ opened ctx strm0
165− return js
166− Nothing
167− | isResponse streamId -> return Nothing
168− | otherwise -> do
169− csid <- readIORef clientStreamId
170− if streamId <= csid then -- consider the stream closed
171− if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority] then
172− return Nothing -- will be ignored
173− else
174− E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"
175− else do -- consider the stream idle
176− when (ftyp `notElem` [FrameHeaders,FramePriority]) $
177− E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idle stream: " `BS.append` C8.pack (show ftyp)
178− when (ftyp == FrameHeaders) $ do
179− writeIORef clientStreamId streamId
180− cnt <- readIORef concurrency
181− -- Checking the limitation of concurrency
182− when (cnt >= maxConcurrency) $
183− E.throwIO $ StreamError RefusedStream streamId
184− ws <- initialWindowSize <$> readIORef http2settings
185− newstrm <- newStream streamId (fromIntegral ws)
186− when (ftyp == FrameHeaders) $ opened ctx newstrm
187− insert streamTable streamId newstrm
188− return $ Just newstrm
189−
190− consume = void . recvN
191−
192−maxConcurrency :: Int
193−maxConcurrency = recommendedConcurrency
194−
195−initialFrame :: ByteString
196−initialFrame = settingsFrame id [(SettingsMaxConcurrentStreams,maxConcurrency)]
197−
198−----------------------------------------------------------------
199−
200−control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool
201−control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable} = do
202− SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs
203− case checkSettingsList alist of
204− Just x -> E.throwIO x
205− Nothing -> return ()
206− -- HTTP/2 Setting from a browser
207− unless (testAck flags) $ do
208− oldws <- initialWindowSize <$> readIORef http2settings
209− modifyIORef' http2settings $ \old -> updateSettings old alist
210− newws <- initialWindowSize <$> readIORef http2settings
211− let diff = newws - oldws
212− when (diff /= 0) $ updateAllStreamWindow (+ diff) streamTable
213− let !frame = settingsFrame setAck []
214− sent <- readIORef firstSettings
215− let !setframe
216− | sent = CSettings frame alist
217− | otherwise = CSettings0 initialFrame frame alist
218− unless sent $ writeIORef firstSettings True
219− enqueueControl controlQ setframe
220− return True
221−
222−control FramePing FrameHeader{flags} bs Context{controlQ} =
223− if testAck flags then
224− return True -- just ignore
225− else do
226− let !frame = pingFrame bs
227− enqueueControl controlQ $ CFrame frame
228− return True
229−
230−control FrameGoAway _ _ Context{controlQ} = do
231− enqueueControl controlQ CFinish
232− return False
233−
234−control FrameWindowUpdate header bs Context{connectionWindow} = do
235− WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs
236− !w <- atomically $ do
237− w0 <- readTVar connectionWindow
238− let !w1 = w0 + n
239− writeTVar connectionWindow w1
240− return w1
241− when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"
242− return True
243−
244−control _ _ _ _ =
245− -- must not reach here
246− return False
247−
248−----------------------------------------------------------------
249−
250−{-# INLINE guardIt #-}
251−guardIt :: Either HTTP2Error a -> IO a
252−guardIt x = case x of
253− Left err -> E.throwIO err
254− Right frame -> return frame
255−
256−
257−{-# INLINE checkPriority #-}
258−checkPriority :: Priority -> StreamId -> IO ()
259−checkPriority p me
260− | dep == me = E.throwIO $ StreamError ProtocolError me
261− | otherwise = return ()
262− where
263− dep = streamDependency p
264−
265−stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState
266−stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{streamNumber} = do
267− HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs
268− pri <- case mp of
269− Nothing -> return defaultPriority
270− Just p -> do
271− checkPriority p streamNumber
272− return p
273− let !endOfStream = testEndStream flags
274− !endOfHeader = testEndHeader flags
275− if endOfHeader then do
276− tbl <- hpackDecodeHeader frag ctx -- fixme
277− return $ if endOfStream then
278− Open (NoBody tbl pri)
279− else
280− Open (HasBody tbl pri)
281− else do
282− let !siz = BS.length frag
283− return $ Open $ Continued [frag] siz 1 endOfStream pri
284−
285−stream FrameHeaders header@FrameHeader{flags} bs _ (Open (Body q _ _)) _ = do
286− -- trailer is not supported.
287− -- let's read and ignore it.
288− HeadersFrame _ _ <- guardIt $ decodeHeadersFrame header bs
289− let !endOfStream = testEndStream flags
290− if endOfStream then do
291− atomically $ writeTQueue q ""
292− return HalfClosedRemote
293− else
294− -- we don't support continuation here.
295− E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"
296−
297−-- ignore data-frame except for flow-control when we're done locally
298−stream FrameData
299− FrameHeader{flags,payloadLength}
300− _bs
301− Context{controlQ} s@(HalfClosedLocal _)
302− Stream{streamNumber} = do
303− let !endOfStream = testEndStream flags
304− when (payloadLength /= 0) $ do
305− let !frame1 = windowUpdateFrame 0 payloadLength
306− !frame2 = windowUpdateFrame streamNumber payloadLength
307− !frame = frame1 `BS.append` frame2
308− enqueueControl controlQ $ CFrame frame
309− if endOfStream then do
310− return HalfClosedRemote
311− else
312− return s
313−
314−stream FrameData
315− header@FrameHeader{flags,payloadLength,streamId}
316− bs
317− Context{controlQ} s@(Open (Body q mcl bodyLength))
318− Stream{streamNumber} = do
319− DataFrame body <- guardIt $ decodeDataFrame header bs
320− let !endOfStream = testEndStream flags
321− len0 <- readIORef bodyLength
322− let !len = len0 + payloadLength
323− writeIORef bodyLength len
324− when (payloadLength /= 0) $ do
325− let !frame1 = windowUpdateFrame 0 payloadLength
326− !frame2 = windowUpdateFrame streamNumber payloadLength
327− !frame = frame1 `BS.append` frame2
328− enqueueControl controlQ $ CFrame frame
329− atomically $ writeTQueue q body
330− if endOfStream then do
331− case mcl of
332− Nothing -> return ()
333− Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId
334− atomically $ writeTQueue q ""
335− return HalfClosedRemote
336− else
337− return s
338−
339−stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz n endOfStream pri)) _ = do
340− let !endOfHeader = testEndHeader flags
341− !rfrags' = frag : rfrags
342− !siz' = siz + BS.length frag
343− !n' = n + 1
344− when (siz' > 51200) $ -- fixme: hard coding: 50K
345− E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"
346− when (n' > 10) $ -- fixme: hard coding
347− E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"
348− if endOfHeader then do
349− let !hdrblk = BS.concat $ reverse rfrags'
350− tbl <- hpackDecodeHeader hdrblk ctx
351− return $ if endOfStream then
352− Open (NoBody tbl pri)
353− else
354− Open (HasBody tbl pri)
355− else
356− return $ Open $ Continued rfrags' siz' n' endOfStream pri
357−
358−stream FrameWindowUpdate header@FrameHeader{streamId} bs _ s Stream{streamWindow} = do
359− WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs
360− !w <- atomically $ do
361− w0 <- readTVar streamWindow
362− let !w1 = w0 + n
363− writeTVar streamWindow w1
364− return w1
365− when (isWindowOverflow w) $
366− E.throwIO $ StreamError FlowControlError streamId
367− return s
368−
369−stream FrameRSTStream header bs ctx _ strm = do
370− RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs
371− let !cc = Reset e
372− closed ctx strm cc
373− return $ Closed cc -- will be written to streamState again
374−
375−stream FramePriority header bs Context{outputQ,priorityTreeSize} s Stream{streamNumber,streamPrecedence} = do
376− PriorityFrame newpri <- guardIt $ decodePriorityFrame header bs
377− checkPriority newpri streamNumber
378− oldpre <- readIORef streamPrecedence
379− let !newpre = toPrecedence newpri
380− writeIORef streamPrecedence newpre
381− if isIdle s then do
382− n <- atomicModifyIORef' priorityTreeSize (\x -> (x+1,x+1))
383− -- fixme hard coding
384− when (n >= 20) $ E.throwIO $ ConnectionError EnhanceYourCalm "too many idle priority frames"
385− prepare outputQ streamNumber newpri
386− else do
387− mx <- delete outputQ streamNumber oldpre
388− case mx of
389− Nothing -> return ()
390− Just out -> enqueueOutput outputQ out
391− return s
392−
393−-- this ordering is important
394−stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"
395−stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"
396−-- Ignore frames to streams we have just reset, per section 5.1.
397−stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st
398−stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId
399−stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId
400−
401−----------------------------------------------------------------
402−
403−{-# INLINE newReadBody #-}
404−newReadBody :: TQueue ByteString -> IO (IO ByteString)
405−newReadBody q = do
406− ref <- newIORef False
407− return $ readBody q ref
408−
409−{-# INLINE readBody #-}
410−readBody :: TQueue ByteString -> IORef Bool -> IO ByteString
411−readBody q ref = do
412− eof <- readIORef ref
413− if eof then
414− return ""
415− else do
416− bs <- atomically $ readTQueue q
417− when (bs == "") $ writeIORef ref True
418− return bs
warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+15−12
@@ -1,9 +1,7 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
3
2
4module Network.Wai.Handler.Warp.HTTP2.Request (
3module Network.Wai.Handler.Warp.HTTP2.Request (
5− mkRequest
4+ toRequest
6− , MkReq
7 , getHTTP2Data
5 , getHTTP2Data
8 , setHTTP2Data
6 , setHTTP2Data
9 , modifyHTTP2Data
7 , modifyHTTP2Data
@@ -20,28 +18,31 @@ import Network.Socket (SockAddr)
20import Network.Wai
18import Network.Wai
21import Network.Wai.Internal (Request(..))
19import Network.Wai.Internal (Request(..))
22import System.IO.Unsafe (unsafePerformIO)
20import System.IO.Unsafe (unsafePerformIO)
21+import qualified System.TimeManager as T
23
22
24import Network.Wai.Handler.Warp.HTTP2.Types
23import Network.Wai.Handler.Warp.HTTP2.Types
25import Network.Wai.Handler.Warp.Imports
24import Network.Wai.Handler.Warp.Imports
26−import Network.Wai.Handler.Warp.Request (getFileInfoKey)
25+import Network.Wai.Handler.Warp.Request (getFileInfoKey, pauseTimeoutKey)
27import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)
26import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)
28import Network.Wai.Handler.Warp.Types
27import Network.Wai.Handler.Warp.Types
29
28
30−type MkReq = (TokenHeaderList,ValueTable) -> (Maybe Int,IO ByteString) -> IO (Request)
29+type ToReq = (TokenHeaderList,ValueTable) -> Maybe Int -> IO ByteString -> T.Handle -> IO Request
31
30
31+----------------------------------------------------------------
32+
32−mkRequest :: InternalInfo -> S.Settings -> SockAddr -> MkReq
33+toRequest :: InternalInfo -> S.Settings -> SockAddr -> ToReq
33−mkRequest ii1 settings addr (reqths,reqvt) (bodylen,body) = do
34+toRequest ii settings addr ht bodylen body th = do
34 ref <- newIORef Nothing
35 ref <- newIORef Nothing
35− mkRequest' ii1 settings addr ref (reqths,reqvt) (bodylen,body)
36+ toRequest' ii settings addr ref ht bodylen body th
36
37
37−mkRequest' :: InternalInfo -> S.Settings -> SockAddr
38+toRequest' :: InternalInfo -> S.Settings -> SockAddr
38 -> IORef (Maybe HTTP2Data)
39 -> IORef (Maybe HTTP2Data)
39− -> MkReq
40+ -> ToReq
40−mkRequest' ii settings addr ref (reqths,reqvt) (bodylen,body) = return req
41+toRequest' ii settings addr ref (reqths,reqvt) bodylen body th = return req
41 where
42 where
42 !req = Request {
43 !req = Request {
43 requestMethod = colonMethod
44 requestMethod = colonMethod
44− , httpVersion = http2ver
45+ , httpVersion = H.http20
45 , rawPathInfo = rawPath
46 , rawPathInfo = rawPath
46 , pathInfo = H.decodePathSegments path
47 , pathInfo = H.decodePathSegments path
47 , rawQueryString = query
48 , rawQueryString = query
@@ -76,10 +77,12 @@ mkRequest' ii settings addr ref (reqths,reqvt) (bodylen,body) = return req
76 (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)
77 (unparsedPath,query) = C8.break (=='?') $ fromJust (mPath <|> mAuth)
77 !path = H.extractPath unparsedPath
78 !path = H.extractPath unparsedPath
78 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
79 !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
80+ -- fixme: pauseTimeout. th is not available here.
79 !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)
81 !vaultValue = Vault.insert getFileInfoKey (getFileInfo ii)
80 $ Vault.insert getHTTP2DataKey (readIORef ref)
82 $ Vault.insert getHTTP2DataKey (readIORef ref)
81 $ Vault.insert setHTTP2DataKey (writeIORef ref)
83 $ Vault.insert setHTTP2DataKey (writeIORef ref)
82 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)
84 $ Vault.insert modifyHTTP2DataKey (modifyIORef' ref)
85+ $ Vault.insert pauseTimeoutKey (T.pause th)
83 Vault.empty
86 Vault.empty
84
87
85getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))
88getHTTP2DataKey :: Vault.Key (IO (Maybe HTTP2Data))
warp/Network/Wai/Handler/Warp/HTTP2/Response.hsnew file+126
@@ -0,0 +1,126 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE BangPatterns #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+
6+module Network.Wai.Handler.Warp.HTTP2.Response (
7+ fromResponse
8+ ) where
9+
10+import qualified Control.Exception as E
11+import qualified Data.ByteString.Builder as BB
12+import qualified Network.HTTP.Types as H
13+import qualified Network.HTTP2.Server as H2
14+import Network.Wai hiding (responseFile, responseBuilder, responseStream)
15+import Network.Wai.Internal (Response(..))
16+
17+import Network.Wai.Handler.Warp.File
18+import Network.Wai.Handler.Warp.HTTP2.Request (getHTTP2Data)
19+import Network.Wai.Handler.Warp.HTTP2.Types
20+import Network.Wai.Handler.Warp.Header
21+import qualified Network.Wai.Handler.Warp.Response as R
22+import qualified Network.Wai.Handler.Warp.Settings as S
23+import Network.Wai.Handler.Warp.Types
24+
25+----------------------------------------------------------------
26+
27+fromResponse :: S.Settings -> InternalInfo -> Request -> Response -> IO H2.Response
28+fromResponse settings ii req rsp = do
29+ date <- getDate ii
30+ h2rsp <- case rsp of
31+ ResponseFile st rsphdr path mpart -> do
32+ let rsphdr' = add date svr rsphdr
33+ responseFile st rsphdr' isHead path mpart ii reqhdr
34+ ResponseBuilder st rsphdr builder -> do
35+ let rsphdr' = add date svr rsphdr
36+ return $ responseBuilder st rsphdr' isHead builder
37+ ResponseStream st rsphdr strmbdy -> do
38+ let rsphdr' = add date svr rsphdr
39+ return $ responseStream st rsphdr' isHead strmbdy
40+ _ -> error "ResponseRaw is not supported in HTTP/2"
41+ mh2data <- getHTTP2Data req
42+ case mh2data of
43+ Nothing -> return h2rsp
44+ Just h2data -> do
45+ let !trailers = http2dataTrailers h2data
46+ return $ H2.setResponseTrailersMaker h2rsp trailers
47+ where
48+ !isHead = requestMethod req == H.methodHead
49+ !reqhdr = requestHeaders req
50+ !svr = S.settingsServerName settings
51+ add date server rsphdr = (H.hDate, date) : (H.hServer, server) : rsphdr
52+ -- fixme: not adding svr if already exists
53+
54+----------------------------------------------------------------
55+
56+responseFile :: H.Status -> H.ResponseHeaders -> Bool
57+ -> FilePath -> Maybe FilePart -> InternalInfo -> H.RequestHeaders
58+ -> IO H2.Response
59+responseFile st rsphdr _ _ _ _ _
60+ | noBody st = return $ responseNoBody st rsphdr
61+
62+responseFile st rsphdr isHead path (Just fp) _ _ =
63+ return $ responseFile2XX st rsphdr isHead fileSpec
64+ where
65+ !off' = fromIntegral $ filePartOffset fp
66+ !bytes' = fromIntegral $ filePartByteCount fp
67+ !fileSpec = H2.FileSpec path off' bytes'
68+
69+responseFile _ rsphdr isHead path Nothing ii reqhdr = do
70+ efinfo <- E.try $ getFileInfo ii path
71+ case efinfo of
72+ Left (_ex :: E.IOException) -> return $ response404 rsphdr
73+ Right finfo -> do
74+ let reqidx = indexRequestHeader reqhdr
75+ case conditionalRequest finfo rsphdr reqidx of
76+ WithoutBody s -> return $ responseNoBody s rsphdr
77+ WithBody s rsphdr' off bytes -> do
78+ let !off' = fromIntegral off
79+ !bytes' = fromIntegral bytes
80+ !fileSpec = H2.FileSpec path off' bytes'
81+ return $ responseFile2XX s rsphdr' isHead fileSpec
82+
83+----------------------------------------------------------------
84+
85+responseFile2XX :: H.Status -> H.ResponseHeaders -> Bool -> H2.FileSpec -> H2.Response
86+responseFile2XX st rsphdr isHead fileSpec
87+ | isHead = responseNoBody st rsphdr
88+ | otherwise = H2.responseFile st rsphdr fileSpec
89+
90+----------------------------------------------------------------
91+
92+responseBuilder :: H.Status -> H.ResponseHeaders -> Bool
93+ -> BB.Builder
94+ -> H2.Response
95+responseBuilder st rsphdr isHead builder
96+ | noBody st = responseNoBody st rsphdr
97+ | isHead = responseNoBody st rsphdr
98+ | otherwise = H2.responseBuilder st rsphdr builder
99+
100+----------------------------------------------------------------
101+
102+responseStream :: H.Status -> H.ResponseHeaders -> Bool
103+ -> StreamingBody
104+ -> H2.Response
105+responseStream st rsphdr isHead strmbdy
106+ | noBody st = responseNoBody st rsphdr
107+ | isHead = responseNoBody st rsphdr
108+ | otherwise = H2.responseStreaming st rsphdr strmbdy
109+
110+----------------------------------------------------------------
111+
112+responseNoBody :: H.Status -> H.ResponseHeaders -> H2.Response
113+responseNoBody st rsphdr = H2.responseNoBody st rsphdr
114+
115+----------------------------------------------------------------
116+
117+response404 :: H.ResponseHeaders -> H2.Response
118+response404 rsphdr = H2.responseBuilder H.notFound404 rsphdr' body
119+ where
120+ !rsphdr' = R.replaceHeader H.hContentType "text/plain; charset=utf-8" rsphdr
121+ !body = BB.byteString "File not found"
122+
123+----------------------------------------------------------------
124+
125+noBody :: H.Status -> Bool
126+noBody = not . R.hasBody
warp/Network/Wai/Handler/Warp/HTTP2/Sender.hsdeleted−536
@@ -1,536 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE BangPatterns, CPP #-}
3−{-# LANGUAGE NamedFieldPuns #-}
4−
5−module Network.Wai.Handler.Warp.HTTP2.Sender (frameSender) where
6−
7−import Control.Concurrent.STM
8−import qualified Control.Exception as E
9−import qualified Data.ByteString as BS
10−import Data.ByteString.Builder (Builder)
11−import qualified Data.ByteString.Builder.Extra as B
12−import Data.IORef
13−import Foreign.Ptr (Ptr, plusPtr)
14−import Foreign.Storable (poke)
15−import Network.HPACK (setLimitForEncoding, toHeaderTable)
16−import Network.HTTP2
17−import Network.HTTP2.Priority (isEmptySTM, dequeueSTM, Precedence)
18−import Network.Wai
19−
20−#ifdef WINDOWS
21−import qualified System.IO as IO
22−#else
23−import Network.Wai.Handler.Warp.FdCache
24−import Network.Wai.Handler.Warp.SendFile (positionRead)
25−import qualified System.TimeManager as T
26−#endif
27−
28−import Network.Wai.Handler.Warp.Buffer
29−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
30−import Network.Wai.Handler.Warp.HTTP2.HPACK
31−import Network.Wai.Handler.Warp.HTTP2.Manager (Manager)
32−import Network.Wai.Handler.Warp.HTTP2.Types
33−import Network.Wai.Handler.Warp.Imports hiding (readInt)
34−import qualified Network.Wai.Handler.Warp.Settings as S
35−import Network.Wai.Handler.Warp.Types
36−
37−----------------------------------------------------------------
38−
39−data Leftover = LZero
40− | LOne B.BufferWriter
41− | LTwo ByteString B.BufferWriter
42−
43−----------------------------------------------------------------
44−
45−{-# INLINE getStreamWindowSize #-}
46−getStreamWindowSize :: Stream -> IO WindowSize
47−getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow
48−
49−{-# INLINE waitStreamWindowSize #-}
50−waitStreamWindowSize :: Stream -> IO ()
51−waitStreamWindowSize Stream{streamWindow} = atomically $ do
52− w <- readTVar streamWindow
53− check (w > 0)
54−
55−{-# INLINE waitStreaming #-}
56−waitStreaming :: TBQueue a -> IO ()
57−waitStreaming tbq = atomically $ do
58− isEmpty <- isEmptyTBQueue tbq
59− check (not isEmpty)
60−
61−data Switch = C Control
62− | O (StreamId,Precedence,Output)
63− | Flush
64−
65−frameSender :: Context -> Connection -> S.Settings -> Manager -> IO ()
66−frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
67− conn@Connection{connWriteBuffer,connBufferSize,connSendAll}
68− settings mgr = loop 0 `E.catch` ignore
69− where
70− dequeue off = do
71− isEmpty <- isEmptyTQueue controlQ
72− if isEmpty then do
73− w <- readTVar connectionWindow
74− check (w > 0)
75− emp <- isEmptySTM outputQ
76− if emp then
77− if off /= 0 then return Flush else retry
78− else
79− O <$> dequeueSTM outputQ
80− else
81− C <$> readTQueue controlQ
82−
83− loop off = do
84− x <- atomically $ dequeue off
85− case x of
86− C ctl -> do
87− when (off /= 0) $ flushN off
88− off' <- control ctl off
89− when (off' >= 0) $ loop off'
90− O (_,pre,out) -> do
91− let strm = outputStream out
92− writeIORef (streamPrecedence strm) pre
93− off' <- outputOrEnqueueAgain out off
94− case off' of
95− 0 -> loop 0
96− _ | off' > 15872 -> flushN off' >> loop 0 -- fixme: hard-coding
97− | otherwise -> loop off'
98− Flush -> flushN off >> loop 0
99−
100− control CFinish _ = return (-1)
101− control (CGoaway frame) _ = connSendAll frame >> return (-1)
102− control (CFrame frame) _ = connSendAll frame >> return 0
103− control (CSettings frame alist) _ = do
104− connSendAll frame
105− setLimit alist
106− return 0
107− control (CSettings0 frame1 frame2 alist) off = do -- off == 0, just in case
108− let !buf = connWriteBuffer `plusPtr` off
109− !off' = off + BS.length frame1 + BS.length frame2
110− buf' <- copy buf frame1
111− void $ copy buf' frame2
112− setLimit alist
113− return off'
114−
115− {-# INLINE setLimit #-}
116− setLimit alist = case lookup SettingsHeaderTableSize alist of
117− Nothing -> return ()
118− Just siz -> setLimitForEncoding siz encodeDynamicTable
119−
120− output out@(Output strm _ _ tell getH2D (ONext curr)) off0 lim = do
121− -- Data frame payload
122− let !buf = connWriteBuffer `plusPtr` off0
123− !siz = connBufferSize - off0
124− Next datPayloadLen mnext <- curr buf siz lim
125− off <- fillDataHeader strm off0 datPayloadLen mnext tell getH2D
126− maybeEnqueueNext out mnext
127− return off
128−
129− output out@(Output strm rspn ii tell getH2D ORspn) off0 lim = do
130− -- Header frame and Continuation frame
131− let !sid = streamNumber strm
132− !endOfStream = case rspn of
133− RspnNobody _ _ -> True
134− _ -> False
135− ths <- fixHeaders ctx rspn ii settings
136− kvlen <- headerContinue sid ths endOfStream off0
137− off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen
138− case rspn of
139− RspnNobody _ _ -> do
140− halfClosedLocal ctx strm Finished
141− return off
142− RspnFile _ _ path mpart -> do
143− -- Data frame payload
144− let payloadOff = off + frameHeaderLength
145− Next datPayloadLen mnext <-
146− fillFileBodyGetNext conn ii payloadOff lim path mpart
147− off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D
148− maybeEnqueueNext out mnext
149− return off'
150− RspnBuilder _ _ builder -> do
151− -- Data frame payload
152− let payloadOff = off + frameHeaderLength
153− Next datPayloadLen mnext <-
154− fillBuilderBodyGetNext conn ii payloadOff lim builder
155− off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D
156− maybeEnqueueNext out mnext
157− return off'
158− RspnStreaming _ _ tbq -> do
159− let payloadOff = off + frameHeaderLength
160− Next datPayloadLen mnext <-
161− fillStreamBodyGetNext conn payloadOff lim tbq strm
162− off' <- fillDataHeader strm off datPayloadLen mnext tell getH2D
163− maybeEnqueueNext out mnext
164− return off'
165−
166− output out@(Output strm _ _ _ _ (OPush ths pid)) off0 lim = do
167− -- Creating a push promise header
168− -- Frame id should be associated stream id from the client.
169− let !sid = streamNumber strm
170− len <- pushPromise pid sid ths off0
171− off <- sendHeadersIfNecessary $ off0 + frameHeaderLength + len
172− output out{ outputType = ORspn } off lim
173−
174− output _ _ _ = undefined -- never reach
175−
176− outputOrEnqueueAgain out off = E.handle resetStream $ do
177− state <- readStreamState strm
178− if isHalfClosedLocal state then
179− return off
180− else case out of
181− Output _ _ _ wait _ OWait -> do
182− -- Checking if all push are done.
183− let out' = out {
184− outputHook = return ()
185− , outputType = ORspn
186− }
187− forkAndEnqueueWhenReady wait outputQ out' mgr
188− return off
189− _ -> case mtbq of
190− Just tbq -> checkStreaming tbq
191− _ -> checkStreamWindowSize
192− where
193− strm = outputStream out
194− mtbq = outputMaybeTBQueue out
195− checkStreaming tbq = do
196− isEmpty <- atomically $ isEmptyTBQueue tbq
197− if isEmpty then do
198− forkAndEnqueueWhenReady (waitStreaming tbq) outputQ out mgr
199− return off
200− else
201− checkStreamWindowSize
202− checkStreamWindowSize = do
203− sws <- getStreamWindowSize strm
204− if sws == 0 then do
205− forkAndEnqueueWhenReady (waitStreamWindowSize strm) outputQ out mgr
206− return off
207− else do
208− cws <- atomically $ readTVar connectionWindow -- not 0
209− let !lim = min cws sws
210− output out off lim
211− resetStream e = do
212− closed ctx strm (ResetByMe e)
213− let !rst = resetFrame InternalError $ streamNumber strm
214− enqueueControl controlQ $ CFrame rst
215− return off
216−
217− {-# INLINE flushN #-}
218− -- Flush the connection buffer to the socket, where the first 'n' bytes of
219− -- the buffer are filled.
220− flushN :: Int -> IO ()
221− flushN n = bufferIO connWriteBuffer n connSendAll
222−
223− headerContinue sid ths endOfStream off = do
224− let !offkv = off + frameHeaderLength
225− let !bufkv = connWriteBuffer `plusPtr` offkv
226− !limkv = connBufferSize - offkv
227− (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths
228− let flag0 = case hs of
229− [] -> setEndHeader defaultFlags
230− _ -> defaultFlags
231− flag = if endOfStream then setEndStream flag0 else flag0
232− let buf = connWriteBuffer `plusPtr` off
233− fillFrameHeader FrameHeaders kvlen sid flag buf
234− continue sid kvlen hs
235−
236− !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
237− !headerPayloadLim = connBufferSize - frameHeaderLength
238−
239− continue _ kvlen [] = return kvlen
240− continue sid kvlen ths = do
241− flushN $ kvlen + frameHeaderLength
242− -- Now off is 0
243− (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths
244− when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"
245− let flag = case ths' of
246− [] -> setEndHeader defaultFlags
247− _ -> defaultFlags
248− fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer
249− continue sid kvlen' ths'
250−
251− {-# INLINE maybeEnqueueNext #-}
252− -- Re-enqueue the stream in the output queue.
253− maybeEnqueueNext :: Output -> Maybe DynaNext -> IO ()
254− maybeEnqueueNext _ Nothing = return ()
255− maybeEnqueueNext out (Just next) = enqueueOutput outputQ out'
256− where
257− !out' = out { outputType = ONext next }
258−
259− {-# INLINE sendHeadersIfNecessary #-}
260− -- Send headers if there is not room for a 1-byte data frame, and return
261− -- the offset of the next frame's first header byte.
262− sendHeadersIfNecessary off
263− -- True if the connection buffer has room for a 1-byte data frame.
264− | off + frameHeaderLength < connBufferSize = return off
265− | otherwise = do
266− flushN off
267− return 0
268−
269− fillDataHeader strm@Stream{streamWindow,streamNumber}
270− off datPayloadLen mnext tell getH2D = do
271− -- Data frame header
272− mh2d <- getH2D
273− let (!trailers,!noTrailers) = case http2dataTrailers <$> mh2d of
274− Nothing -> ([], True)
275− Just ts -> (ts, null ts)
276− !buf = connWriteBuffer `plusPtr` off
277− !off' = off + frameHeaderLength + datPayloadLen
278− !noMoreBody = isNothing mnext
279− flag | noMoreBody && noTrailers = setEndStream defaultFlags
280− | otherwise = defaultFlags
281− fillFrameHeader FrameData datPayloadLen streamNumber flag buf
282− off'' <- handleEndOfBody noMoreBody off' noTrailers trailers
283− atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)
284− atomically $ modifyTVar' streamWindow (subtract datPayloadLen)
285− return off''
286− where
287− handleTrailers True off0 _ = return off0
288− handleTrailers _ off0 trailers = do
289− (ths,_) <- toHeaderTable trailers
290− kvlen <- headerContinue streamNumber ths True off0
291− sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen
292− handleEndOfBody True off0 noTrailers trailers = do
293− off1 <- handleTrailers noTrailers off0 trailers
294− void tell
295− halfClosedLocal ctx strm Finished
296− return off1
297− handleEndOfBody False off0 _ _ = return off0
298−
299−
300− pushPromise pid sid ths off = do
301− let !offsid = off + frameHeaderLength
302− !bufsid = connWriteBuffer `plusPtr` offsid
303− poke32 bufsid $ fromIntegral sid
304− let !offkv = offsid + 4
305− !bufkv = connWriteBuffer `plusPtr` offkv
306− !limkv = connBufferSize - offkv
307− (_,kvlen) <- hpackEncodeHeader ctx bufkv limkv ths
308− let !flag = setEndHeader defaultFlags -- No EndStream flag
309− !buf = connWriteBuffer `plusPtr` off
310− !len = kvlen + 4
311− fillFrameHeader FramePushPromise len pid flag buf
312− return len
313−
314− {-# INLINE fillFrameHeader #-}
315− fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf
316− where
317− hinfo = FrameHeader len flag sid
318−
319− {-# INLINE ignore #-}
320− ignore :: E.SomeException -> IO ()
321− ignore _ = return ()
322−
323−----------------------------------------------------------------
324−
325−{-
326−ResponseFile Status ResponseHeaders FilePath (Maybe FilePart)
327−ResponseBuilder Status ResponseHeaders Builder
328−ResponseStream Status ResponseHeaders StreamingBody
329−ResponseRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) Response
330−-}
331−
332−fillBuilderBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> Builder -> IO Next
333−fillBuilderBodyGetNext Connection{connWriteBuffer,connBufferSize}
334− _ off lim bb = do
335− let datBuf = connWriteBuffer `plusPtr` off
336− room = min (connBufferSize - off) lim
337− (len, signal) <- B.runBuilder bb datBuf room
338− return $ nextForBuilder len signal
339−
340−fillFileBodyGetNext :: Connection -> InternalInfo -> Int -> WindowSize -> FilePath -> Maybe FilePart -> IO Next
341−#ifdef WINDOWS
342−fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}
343− _ off lim path mpart = do
344− let datBuf = connWriteBuffer `plusPtr` off
345− room = min (connBufferSize - off) lim
346− (start, bytes) <- fileStartEnd path mpart
347− -- fixme: how to close Handle? GC does it at this moment.
348− hdl <- IO.openBinaryFile path IO.ReadMode
349− IO.hSeek hdl IO.AbsoluteSeek start
350− len <- IO.hGetBufSome hdl datBuf (mini room bytes)
351− let bytes' = bytes - fromIntegral len
352− -- fixme: connWriteBuffer connBufferSize
353− return $ nextForFile len hdl bytes' (return ())
354−#else
355−fillFileBodyGetNext Connection{connWriteBuffer,connBufferSize}
356− ii off lim path mpart = do
357− (mfd, refresh') <- getFd ii path
358− (fd, refresh) <- case mfd of
359− Nothing -> do
360− fd' <- openFile path
361− th <- T.register (timeoutManager ii) (closeFile fd')
362− return (fd', T.tickle th)
363− Just fd -> return (fd, refresh')
364− let datBuf = connWriteBuffer `plusPtr` off
365− room = min (connBufferSize - off) lim
366− (start, bytes) <- fileStartEnd path mpart
367− len <- positionRead fd datBuf (mini room bytes) start
368− refresh
369− let len' = fromIntegral len
370− return $ nextForFile len fd (start + len') (bytes - len') refresh
371−#endif
372−
373−fileStartEnd :: FilePath -> Maybe FilePart -> IO (Integer, Integer)
374−fileStartEnd _ (Just part) =
375− return (filePartOffset part, filePartByteCount part)
376−fileStartEnd _ _ = error "fileStartEnd"
377−
378−----------------------------------------------------------------
379−
380−fillStreamBodyGetNext :: Connection -> Int -> WindowSize -> TBQueue Sequence -> Stream -> IO Next
381−fillStreamBodyGetNext Connection{connWriteBuffer,connBufferSize}
382− off lim sq strm = do
383− let datBuf = connWriteBuffer `plusPtr` off
384− room = min (connBufferSize - off) lim
385− (leftover, cont, len) <- runStreamBuilder datBuf room sq
386− return $ nextForStream sq strm leftover cont len
387−
388−----------------------------------------------------------------
389−
390−fillBufBuilder :: Leftover -> DynaNext
391−fillBufBuilder leftover buf0 siz0 lim = do
392− let payloadBuf = buf0 `plusPtr` frameHeaderLength
393− room = min (siz0 - frameHeaderLength) lim
394− case leftover of
395− LZero -> error "fillBufBuilder: LZero"
396− LOne writer -> do
397− (len, signal) <- writer payloadBuf room
398− getNext len signal
399− LTwo bs writer
400− | BS.length bs <= room -> do
401− buf1 <- copy payloadBuf bs
402− let len1 = BS.length bs
403− (len2, signal) <- writer buf1 (room - len1)
404− getNext (len1 + len2) signal
405− | otherwise -> do
406− let (bs1,bs2) = BS.splitAt room bs
407− void $ copy payloadBuf bs1
408− getNext room (B.Chunk bs2 writer)
409− where
410− getNext l s = return $ nextForBuilder l s
411−
412−nextForBuilder :: BytesFilled -> B.Next -> Next
413−nextForBuilder len B.Done
414− = Next len Nothing
415−nextForBuilder len (B.More _ writer)
416− = Next len $ Just (fillBufBuilder (LOne writer))
417−nextForBuilder len (B.Chunk bs writer)
418− = Next len $ Just (fillBufBuilder (LTwo bs writer))
419−
420−----------------------------------------------------------------
421−
422−runStreamBuilder :: Buffer -> BufSize -> TBQueue Sequence
423− -> IO (Leftover, Bool, BytesFilled)
424−runStreamBuilder buf0 room0 sq = loop buf0 room0 0
425− where
426− loop !buf !room !total = do
427− mbuilder <- atomically $ tryReadTBQueue sq
428− case mbuilder of
429− Nothing -> return (LZero, True, total)
430− Just (SBuilder builder) -> do
431− (len, signal) <- B.runBuilder builder buf room
432− let !total' = total + len
433− case signal of
434− B.Done -> loop (buf `plusPtr` len) (room - len) total'
435− B.More _ writer -> return (LOne writer, True, total')
436− B.Chunk bs writer -> return (LTwo bs writer, True, total')
437− Just SFlush -> return (LZero, True, total)
438− Just SFinish -> return (LZero, False, total)
439−
440−fillBufStream :: Leftover -> TBQueue Sequence -> Stream -> DynaNext
441−fillBufStream leftover0 sq strm buf0 siz0 lim0 = do
442− let payloadBuf = buf0 `plusPtr` frameHeaderLength
443− room0 = min (siz0 - frameHeaderLength) lim0
444− case leftover0 of
445− LZero -> do
446− (leftover, cont, len) <- runStreamBuilder payloadBuf room0 sq
447− getNext leftover cont len
448− LOne writer -> write writer payloadBuf room0 0
449− LTwo bs writer
450− | BS.length bs <= room0 -> do
451− buf1 <- copy payloadBuf bs
452− let len = BS.length bs
453− write writer buf1 (room0 - len) len
454− | otherwise -> do
455− let (bs1,bs2) = BS.splitAt room0 bs
456− void $ copy payloadBuf bs1
457− getNext (LTwo bs2 writer) True room0
458− where
459− getNext l b r = return $ nextForStream sq strm l b r
460− write writer1 buf room sofar = do
461− (len, signal) <- writer1 buf room
462− case signal of
463− B.Done -> do
464− (leftover, cont, extra) <- runStreamBuilder (buf `plusPtr` len) (room - len) sq
465− let !total = sofar + len + extra
466− getNext leftover cont total
467− B.More _ writer -> do
468− let !total = sofar + len
469− getNext (LOne writer) True total
470− B.Chunk bs writer -> do
471− let !total = sofar + len
472− getNext (LTwo bs writer) True total
473−
474−nextForStream :: TBQueue Sequence -> Stream
475− -> Leftover -> Bool -> BytesFilled
476− -> Next
477−nextForStream _ _ _ False len = Next len Nothing
478−nextForStream sq strm leftOrZero True len =
479− Next len $ Just (fillBufStream leftOrZero sq strm)
480−
481−----------------------------------------------------------------
482−
483−#ifdef WINDOWS
484−fillBufFile :: IO.Handle -> Integer -> IO () -> DynaNext
485−fillBufFile h bytes refresh buf siz lim = do
486− let payloadBuf = buf `plusPtr` frameHeaderLength
487− room = min (siz - frameHeaderLength) lim
488− len <- IO.hGetBufSome h payloadBuf room
489− refresh
490− let bytes' = bytes - fromIntegral len
491− return $ nextForFile len h bytes' refresh
492−
493−nextForFile :: BytesFilled -> IO.Handle -> Integer -> IO () -> Next
494−nextForFile 0 _ _ _ = Next 0 Nothing
495−nextForFile len _ 0 _ = Next len Nothing
496−nextForFile len h bytes refresh =
497− Next len $ Just (fillBufFile h bytes refresh)
498−#else
499−fillBufFile :: Fd -> Integer -> Integer -> IO () -> DynaNext
500−fillBufFile fd start bytes refresh buf siz lim = do
501− let payloadBuf = buf `plusPtr` frameHeaderLength
502− room = min (siz - frameHeaderLength) lim
503− len <- positionRead fd payloadBuf (mini room bytes) start
504− let len' = fromIntegral len
505− refresh
506− return $ nextForFile len fd (start + len') (bytes - len') refresh
507−
508−nextForFile :: BytesFilled -> Fd -> Integer -> Integer -> IO () -> Next
509−nextForFile 0 _ _ _ _ = Next 0 Nothing
510−nextForFile len _ _ 0 _ = Next len Nothing
511−nextForFile len fd start bytes refresh =
512− Next len $ Just (fillBufFile fd start bytes refresh)
513−#endif
514−
515−{-# INLINE mini #-}
516−mini :: Int -> Integer -> Int
517−mini i n
518− | fromIntegral i < n = i
519− | otherwise = fromIntegral n
520−
521−
522−----------------------------------------------------------------
523−
524−poke32 :: Ptr Word8 -> Word32 -> IO ()
525−poke32 ptr i = do
526− poke ptr w0
527− poke8 ptr 1 w1
528− poke8 ptr 2 w2
529− poke8 ptr 3 w3
530− where
531− w0 = fromIntegral ((i `shiftR` 24) .&. 0xff)
532− w1 = fromIntegral ((i `shiftR` 16) .&. 0xff)
533− w2 = fromIntegral ((i `shiftR` 8) .&. 0xff)
534− w3 = fromIntegral (i .&. 0xff)
535− poke8 :: Ptr Word8 -> Int -> Word8 -> IO ()
536− poke8 ptr0 n w = poke (ptr0 `plusPtr` n) w
warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+7−304
@@ -1,32 +1,19 @@
1+{-# LANGUAGE NamedFieldPuns #-}
1−{-# LANGUAGE OverloadedStrings, CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
3+{-# LANGUAGE RecordWildCards #-}
3−{-# LANGUAGE BangPatterns #-}
4
4
5module Network.Wai.Handler.Warp.HTTP2.Types where
5module Network.Wai.Handler.Warp.HTTP2.Types where
6
6
7−import Control.Concurrent (forkIO)
8−import Control.Concurrent.STM
9−import Control.Exception (SomeException, bracket)
10import qualified Data.ByteString as BS
7import qualified Data.ByteString as BS
11−import Data.ByteString.Builder (Builder)
12−import Data.IORef
13−import Data.IntMap.Strict (IntMap, IntMap)
14−import qualified Data.IntMap.Strict as M
15−import Network.HPACK hiding (Buffer)
16import qualified Network.HTTP.Types as H
8import qualified Network.HTTP.Types as H
17import Network.HTTP2
9import Network.HTTP2
18−import Network.HTTP2.Priority
10+import qualified Network.HTTP2.Server as H2
19−import Network.Wai (Request, FilePart)
20
11
21−import Network.Wai.Handler.Warp.HTTP2.Manager
22import Network.Wai.Handler.Warp.Imports
12import Network.Wai.Handler.Warp.Imports
23import Network.Wai.Handler.Warp.Types
13import Network.Wai.Handler.Warp.Types
24
14
25----------------------------------------------------------------
15----------------------------------------------------------------
26
16
27−http2ver :: H.HttpVersion
28−http2ver = H.HttpVersion 2 0
29−
30isHTTP2 :: Transport -> Bool
17isHTTP2 :: Transport -> Bool
31isHTTP2 TCP = False
18isHTTP2 TCP = False
32isHTTP2 tls = useHTTP2
19isHTTP2 tls = useHTTP2
@@ -37,290 +24,6 @@ isHTTP2 tls = useHTTP2
37
24
38----------------------------------------------------------------
25----------------------------------------------------------------
39
26
40−data Input = Input Stream Request ValueTable InternalInfo
41−
42−----------------------------------------------------------------
43−
44−type DynaNext = Buffer -> BufSize -> WindowSize -> IO Next
45−
46−type BytesFilled = Int
47−
48−data Next = Next !BytesFilled (Maybe DynaNext)
49−
50−data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable)
51− | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence)
52− | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder
53− | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart)
54−
55−rspnStatus :: Rspn -> H.Status
56−rspnStatus (RspnNobody s _) = s
57−rspnStatus (RspnStreaming s _ _) = s
58−rspnStatus (RspnBuilder s _ _) = s
59−rspnStatus (RspnFile s _ _ _ ) = s
60−
61−rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable)
62−rspnHeaders (RspnNobody _ t) = t
63−rspnHeaders (RspnStreaming _ t _) = t
64−rspnHeaders (RspnBuilder _ t _) = t
65−rspnHeaders (RspnFile _ t _ _ ) = t
66−
67−data Output = Output {
68− outputStream :: !Stream
69− , outputRspn :: !Rspn
70− , outputII :: !InternalInfo
71− , outputHook :: IO () -- OPush: wait for done, O*: telling done
72− , outputH2Data :: IO (Maybe HTTP2Data)
73− , outputType :: !OutputType
74− }
75−
76−data OutputType = ORspn
77− | OWait
78− | OPush !TokenHeaderList !StreamId -- associated stream id from client
79− | ONext !DynaNext
80−
81−outputMaybeTBQueue :: Output -> Maybe (TBQueue Sequence)
82−outputMaybeTBQueue (Output _ (RspnStreaming _ _ tbq) _ _ _ _) = Just tbq
83−outputMaybeTBQueue _ = Nothing
84−
85−data Control = CFinish
86− | CGoaway !ByteString
87− | CFrame !ByteString
88− | CSettings !ByteString !SettingsList
89− | CSettings0 !ByteString !ByteString !SettingsList
90−
91−----------------------------------------------------------------
92−
93−data Sequence = SFinish
94− | SFlush
95− | SBuilder Builder
96−
97−----------------------------------------------------------------
98−
99−-- | The context for HTTP/2 connection.
100−data Context = Context {
101− -- HTTP/2 settings received from a browser
102− http2settings :: !(IORef Settings)
103− , firstSettings :: !(IORef Bool)
104− , streamTable :: !StreamTable
105− , concurrency :: !(IORef Int)
106− , priorityTreeSize :: !(IORef Int)
107− -- | RFC 7540 says "Other frames (from any stream) MUST NOT
108− -- occur between the HEADERS frame and any CONTINUATION
109− -- frames that might follow". This field is used to implement
110− -- this requirement.
111− , continued :: !(IORef (Maybe StreamId))
112− , clientStreamId :: !(IORef StreamId)
113− , serverStreamId :: !(IORef StreamId)
114− , inputQ :: !(TQueue Input)
115− , outputQ :: !(PriorityTree Output)
116− , controlQ :: !(TQueue Control)
117− , encodeDynamicTable :: !DynamicTable
118− , decodeDynamicTable :: !DynamicTable
119− -- the connection window for data from a server to a browser.
120− , connectionWindow :: !(TVar WindowSize)
121− }
122−
123−----------------------------------------------------------------
124−
125−newContext :: IO Context
126−newContext = Context <$> newIORef defaultSettings
127− <*> newIORef False
128− <*> newStreamTable
129− <*> newIORef 0
130− <*> newIORef 0
131− <*> newIORef Nothing
132− <*> newIORef 0
133− <*> newIORef 0
134− <*> newTQueueIO
135− <*> newPriorityTree
136− <*> newTQueueIO
137− <*> newDynamicTableForEncoding defaultDynamicTableSize
138− <*> newDynamicTableForDecoding defaultDynamicTableSize 4096
139− <*> newTVarIO defaultInitialWindowSize
140−
141−clearContext :: Context -> IO ()
142−clearContext _ctx = return ()
143−
144−----------------------------------------------------------------
145−
146−data OpenState =
147− JustOpened
148− | Continued [HeaderBlockFragment]
149− !Int -- Total size
150− !Int -- The number of continuation frames
151− !Bool -- End of stream
152− !Priority
153− | NoBody (TokenHeaderList,ValueTable) !Priority
154− | HasBody (TokenHeaderList,ValueTable) !Priority
155− | Body !(TQueue ByteString)
156− !(Maybe Int) -- received Content-Length
157− -- compared the body length for error checking
158− !(IORef Int) -- actual body length
159−
160−data ClosedCode = Finished
161− | Killed
162− | Reset !ErrorCodeId
163− | ResetByMe SomeException
164− deriving Show
165−
166−data StreamState =
167− Idle
168− | Open !OpenState
169− | HalfClosedRemote
170− | HalfClosedLocal !ClosedCode
171− | Closed !ClosedCode
172− | Reserved
173−
174−isIdle :: StreamState -> Bool
175−isIdle Idle = True
176−isIdle _ = False
177−
178−isOpen :: StreamState -> Bool
179−isOpen Open{} = True
180−isOpen _ = False
181−
182−isHalfClosedRemote :: StreamState -> Bool
183−isHalfClosedRemote HalfClosedRemote = True
184−isHalfClosedRemote (Closed _) = True
185−isHalfClosedRemote _ = False
186−
187−isHalfClosedLocal :: StreamState -> Bool
188−isHalfClosedLocal (HalfClosedLocal _) = True
189−isHalfClosedLocal (Closed _) = True
190−isHalfClosedLocal _ = False
191−
192−isClosed :: StreamState -> Bool
193−isClosed Closed{} = True
194−isClosed _ = False
195−
196−instance Show StreamState where
197− show Idle = "Idle"
198− show Open{} = "Open"
199− show HalfClosedRemote = "HalfClosedRemote"
200− show (HalfClosedLocal e) = "HalfClosedLocal: " ++ show e
201− show (Closed e) = "Closed: " ++ show e
202− show Reserved = "Reserved"
203−
204−----------------------------------------------------------------
205−
206−data Stream = Stream {
207− streamNumber :: !StreamId
208− , streamState :: !(IORef StreamState)
209− , streamWindow :: !(TVar WindowSize)
210− , streamPrecedence :: !(IORef Precedence)
211− }
212−
213−instance Show Stream where
214− show s = show (streamNumber s)
215−
216−newStream :: StreamId -> WindowSize -> IO Stream
217−newStream sid win = Stream sid <$> newIORef Idle
218− <*> newTVarIO win
219− <*> newIORef defaultPrecedence
220−
221−newPushStream :: Context -> WindowSize -> Precedence -> IO Stream
222−newPushStream Context{serverStreamId} win pre = do
223− sid <- atomicModifyIORef' serverStreamId inc2
224− Stream sid <$> newIORef Reserved
225− <*> newTVarIO win
226− <*> newIORef pre
227− where
228− inc2 x = let !x' = x + 2 in (x', x')
229−
230−----------------------------------------------------------------
231−
232−{-# INLINE readStreamState #-}
233−readStreamState :: Stream -> IO StreamState
234−readStreamState Stream{streamState} =
235− readIORef streamState
236−
237−{-# INLINE setStreamState #-}
238−setStreamState :: Context -> Stream -> StreamState -> IO ()
239−setStreamState _ Stream{streamState} val = writeIORef streamState val
240−
241−opened :: Context -> Stream -> IO ()
242−opened ctx@Context{concurrency} strm = do
243− atomicModifyIORef' concurrency (\x -> (x+1,()))
244− setStreamState ctx strm (Open JustOpened)
245−
246−halfClosedRemote :: Context -> Stream -> IO ()
247−halfClosedRemote ctx stream@Stream{streamState} = do
248− !closingCode <- atomicModifyIORef streamState closeHalf
249− case closingCode of
250− Nothing -> return ()
251− Just cc -> closed ctx stream cc
252− where
253− closeHalf :: StreamState -> (StreamState, Maybe ClosedCode)
254− closeHalf x@(Closed _) = (x, Nothing)
255− closeHalf (HalfClosedLocal cc) = (Closed cc, Just cc)
256− closeHalf _ = (HalfClosedRemote, Nothing)
257−
258−halfClosedLocal :: Context -> Stream -> ClosedCode -> IO ()
259−halfClosedLocal ctx stream@Stream{streamState} cc = do
260− shouldFinalize <- atomicModifyIORef streamState closeHalf
261− when shouldFinalize $
262− closed ctx stream cc
263− where
264− closeHalf :: StreamState -> (StreamState, Bool)
265− closeHalf x@(Closed _) = (x, False)
266− closeHalf HalfClosedRemote = (Closed cc, True)
267− closeHalf _ = (HalfClosedLocal cc, False)
268−
269−closed :: Context -> Stream -> ClosedCode -> IO ()
270−closed ctx@Context{concurrency,streamTable} strm@Stream{streamNumber} cc = do
271− remove streamTable streamNumber
272− -- TODO: prevent double-counting
273− atomicModifyIORef' concurrency (\x -> (x-1,()))
274− setStreamState ctx strm (Closed cc) -- anyway
275−
276−----------------------------------------------------------------
277−
278−newtype StreamTable = StreamTable (IORef (IntMap Stream))
279−
280−newStreamTable :: IO StreamTable
281−newStreamTable = StreamTable <$> newIORef M.empty
282−
283−insert :: StreamTable -> M.Key -> Stream -> IO ()
284−insert (StreamTable ref) k v = atomicModifyIORef' ref $ \m ->
285− let !m' = M.insert k v m
286− in (m', ())
287−
288−remove :: StreamTable -> M.Key -> IO ()
289−remove (StreamTable ref) k = atomicModifyIORef' ref $ \m ->
290− let !m' = M.delete k m
291− in (m', ())
292−
293−search :: StreamTable -> M.Key -> IO (Maybe Stream)
294−search (StreamTable ref) k = M.lookup k <$> readIORef ref
295−
296−updateAllStreamWindow :: (WindowSize -> WindowSize) -> StreamTable -> IO ()
297−updateAllStreamWindow adst (StreamTable ref) = do
298− strms <- M.elems <$> readIORef ref
299− forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst
300−
301−{-# INLINE forkAndEnqueueWhenReady #-}
302−forkAndEnqueueWhenReady :: IO () -> PriorityTree Output -> Output -> Manager -> IO ()
303−forkAndEnqueueWhenReady wait outQ out mgr = bracket setup teardown $ \_ ->
304− void . forkIO $ do
305− wait
306− enqueueOutput outQ out
307− where
308− setup = addMyId mgr
309− teardown _ = deleteMyId mgr
310−
311−{-# INLINE enqueueOutput #-}
312−enqueueOutput :: PriorityTree Output -> Output -> IO ()
313−enqueueOutput outQ out = do
314− let Stream{..} = outputStream out
315− pre <- readIORef streamPrecedence
316− enqueue outQ streamNumber pre out
317−
318−{-# INLINE enqueueControl #-}
319−enqueueControl :: TQueue Control -> Control -> IO ()
320−enqueueControl ctlQ ctl = atomically $ writeTQueue ctlQ ctl
321−
322−----------------------------------------------------------------
323−
324-- | HTTP/2 specific data.
27-- | HTTP/2 specific data.
325--
28--
326-- Since: 3.2.7
29-- Since: 3.2.7
@@ -330,14 +33,14 @@ data HTTP2Data = HTTP2Data {
330 -- Since: 3.2.7
33 -- Since: 3.2.7
331 http2dataPushPromise :: [PushPromise]
34 http2dataPushPromise :: [PushPromise]
332 -- Since: 3.2.8
35 -- Since: 3.2.8
333− , http2dataTrailers :: H.ResponseHeaders
36+ , http2dataTrailers :: H2.TrailersMaker
334− } deriving (Eq,Show)
37+ }
335
38
336-- | Default HTTP/2 specific data.
39-- | Default HTTP/2 specific data.
337--
40--
338-- Since: 3.2.7
41-- Since: 3.2.7
339defaultHTTP2Data :: HTTP2Data
42defaultHTTP2Data :: HTTP2Data
340−defaultHTTP2Data = HTTP2Data [] []
43+defaultHTTP2Data = HTTP2Data [] H2.defaultTrailersMaker
341
44
342-- | HTTP/2 push promise or sever push.
45-- | HTTP/2 push promise or sever push.
343--
46--
warp/Network/Wai/Handler/Warp/HTTP2/Worker.hsdeleted−331
@@ -1,331 +0,0 @@
1−{-# LANGUAGE NamedFieldPuns #-}
2−{-# LANGUAGE PatternGuards #-}
3−{-# LANGUAGE CPP #-}
4−{-# LANGUAGE ScopedTypeVariables #-}
5−{-# LANGUAGE OverloadedStrings #-}
6−{-# LANGUAGE BangPatterns #-}
7−
8−module Network.Wai.Handler.Warp.HTTP2.Worker (
9− Responder
10− , response
11− , worker
12− ) where
13−
14−import Control.Concurrent.STM
15−import Control.Exception (SomeException(..), AsyncException(..))
16−import qualified Control.Exception as E
17−import Data.ByteString.Builder (byteString)
18−import Data.IORef
19−import qualified Data.Vault.Lazy as Vault
20−import Network.HPACK
21−import Network.HPACK.Token
22−import qualified Network.HTTP.Types as H
23−import Network.HTTP2
24−import Network.HTTP2.Priority
25−import Network.Wai
26−import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceived(..), getRequestBodyChunk)
27−import qualified System.TimeManager as T
28−
29−import Network.Wai.Handler.Warp.FileInfoCache
30−import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
31−import Network.Wai.Handler.Warp.HTTP2.File
32−import Network.Wai.Handler.Warp.HTTP2.Manager
33−import Network.Wai.Handler.Warp.HTTP2.Request
34−import Network.Wai.Handler.Warp.HTTP2.Types
35−import Network.Wai.Handler.Warp.Imports hiding (insert)
36−import Network.Wai.Handler.Warp.Request (pauseTimeoutKey)
37−import qualified Network.Wai.Handler.Warp.Response as R
38−import qualified Network.Wai.Handler.Warp.Settings as S
39−import Network.Wai.Handler.Warp.Types
40−
41−----------------------------------------------------------------
42−
43−-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.
44−-- This type implements the second argument (Response -> IO ResponseReceived)
45−-- with extra arguments.
46−type Responder = InternalInfo
47− -> T.Handle
48− -> ValueTable -- for Request
49− -> ThreadContinue
50− -> Stream
51− -> Request
52− -> Response
53− -> IO ResponseReceived
54−
55−pushStream :: Context -> S.Settings
56− -> StreamId -> ValueTable -> Request -> InternalInfo
57− -> Maybe HTTP2Data
58− -> IO (OutputType, IO ())
59−pushStream _ _ _ _ _ _ Nothing = return (ORspn, return ())
60−pushStream ctx@Context{http2settings,outputQ,streamTable}
61− settings pid reqvt req ii (Just h2d)
62− | len == 0 = return (ORspn, return ())
63− | otherwise = do
64− pushable <- enablePush <$> readIORef http2settings
65− if pushable then do
66− tvar <- newTVarIO 0
67− lim <- push tvar pps0 0
68− if lim == 0 then
69− return (ORspn, return ())
70− else
71− return (OWait, waiter lim tvar)
72− else
73− return (ORspn, return ())
74− where
75− !pps0 = http2dataPushPromise h2d
76− !len = length pps0
77− !pushLogger = S.settingsServerPushLogger settings
78− increment tvar = atomically $ modifyTVar' tvar (+1)
79− waiter lim tvar = atomically $ do
80− n <- readTVar tvar
81− check (n >= lim)
82− !h2data = getHTTP2Data req
83− push _ [] !n = return (n :: Int)
84− push tvar (pp:pps) !n = do
85− let !file = promisedFile pp
86− efinfo <- E.try $ getFileInfo ii file
87− case efinfo of
88− Left (_ex :: E.IOException) -> push tvar pps n
89− Right (FileInfo _ size _ date) -> do
90− ws <- initialWindowSize <$> readIORef http2settings
91− let !w = promisedWeight pp
92− !pri = defaultPriority { weight = w }
93− !pre = toPrecedence pri
94− strm <- newPushStream ctx ws pre
95− let !sid = streamNumber strm
96− insert streamTable sid strm
97− (ths0, vt) <- toHeaderTable (promisedResponseHeaders pp)
98− let !scheme = fromJust $ getHeaderValue tokenScheme reqvt
99− -- fixme: this value can be Nothing
100− !auth = fromJust (getHeaderValue tokenHost reqvt
101− <|> getHeaderValue tokenAuthority reqvt)
102− !path = promisedPath pp
103− !promisedRequest = [(tokenMethod, H.methodGet)
104− ,(tokenScheme, scheme)
105− ,(tokenAuthority, auth)
106− ,(tokenPath, path)]
107− !part = FilePart 0 size size
108− !rsp = RspnFile H.ok200 (ths,vt) file (Just part)
109− !ths = (tokenLastModified,date) :
110− addContentHeadersForFilePart ths0 part
111− pushLogger req path size
112− let !ot = OPush promisedRequest pid
113− !out = Output strm rsp ii (increment tvar) h2data ot
114− enqueueOutput outputQ out
115− push tvar pps (n + 1)
116−
117−
118−-- | This function is passed to workers.
119−-- They also pass 'Response's from 'Application's to this function.
120−-- This function enqueues commands for the HTTP/2 sender.
121−response :: S.Settings -> Context -> Manager -> Responder
122−response settings ctx@Context{outputQ} mgr ii th reqvt tconf strm req rsp = E.handle (E.throwIO . ExceptionInsideResponseBody) $ case rsp of
123− ResponseStream s0 hs0 strmbdy
124− | noBody s0 -> responseNoBody s0 hs0
125− | isHead -> responseNoBody s0 hs0
126− | otherwise -> getHTTP2Data req
127− >>= pushStream ctx settings sid reqvt req ii
128− >>= responseStreaming s0 hs0 strmbdy
129− ResponseBuilder s0 hs0 b
130− | noBody s0 -> responseNoBody s0 hs0
131− | isHead -> responseNoBody s0 hs0
132− | otherwise -> getHTTP2Data req
133− >>= pushStream ctx settings sid reqvt req ii
134− >>= responseBuilderBody s0 hs0 b
135− ResponseFile s0 hs0 p mp
136− | noBody s0 -> responseNoBody s0 hs0
137− | otherwise -> getHTTP2Data req
138− >>= pushStream ctx settings sid reqvt req ii
139− >>= responseFileXXX s0 hs0 p mp
140− ResponseRaw _ _ -> error "HTTP/2 does not support ResponseRaw"
141− where
142− noBody = not . R.hasBody
143− !isHead = requestMethod req == H.methodHead
144− !logger = S.settingsLogger settings
145− sid = streamNumber strm
146− !h2data = getHTTP2Data req
147−
148− -- Ideally, log messages should be written when responses are
149− -- actually sent. But there is no way to keep good memory usage
150− -- (resist to Request leak) and throughput. By compromise,
151− -- log message are written here even the window size of streams
152− -- is 0.
153−
154− responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s
155−
156− responseNoBody' s tbl = do
157− logger req s Nothing
158− setThreadContinue tconf True
159− let !rspn = RspnNobody s tbl
160− !out = Output strm rspn ii (return ()) h2data ORspn
161− enqueueOutput outputQ out
162− return ResponseReceived
163−
164− responseBuilderBody s hs0 bdy (rspnOrWait,tell) = do
165− logger req s Nothing
166− setThreadContinue tconf True
167− tbl <- toHeaderTable hs0
168− let !rspn = RspnBuilder s tbl bdy
169− !out = Output strm rspn ii tell h2data rspnOrWait
170− enqueueOutput outputQ out
171− return ResponseReceived
172−
173− responseFileXXX _ hs0 path Nothing aux = do
174− efinfo <- E.try $ getFileInfo ii path
175− case efinfo of
176− Left (_ex :: E.IOException) -> response404 hs0
177− Right finfo -> do
178− (rspths0,vt) <- toHeaderTable hs0
179− case conditionalRequest finfo rspths0 reqvt of
180− WithoutBody s -> responseNoBody s hs0
181− WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo))) aux
182−
183− responseFileXXX s0 hs0 path mpart aux = do
184− tbl <- toHeaderTable hs0
185− responseFile2XX s0 tbl path mpart aux
186−
187− responseFile2XX s tbl path mpart (rspnOrWait,tell)
188− | isHead = do
189− logger req s Nothing
190− responseNoBody' s tbl
191− | otherwise = do
192− logger req s (filePartByteCount <$> mpart)
193− setThreadContinue tconf True
194− let !rspn = RspnFile s tbl path mpart
195− !out = Output strm rspn ii tell h2data rspnOrWait
196− enqueueOutput outputQ out
197− return ResponseReceived
198−
199− response404 hs0 = responseBuilderBody s hs body (ORspn, return ())
200− where
201− s = H.notFound404
202− hs = R.replaceHeader H.hContentType "text/plain; charset=utf-8" hs0
203− body = byteString "File not found"
204−
205− responseStreaming s0 hs0 strmbdy (rspnOrWait,tell) = do
206− logger req s0 Nothing
207− -- We must not exit this WAI application.
208− -- If the application exits, streaming would be also closed.
209− -- So, this work occupies this thread.
210− --
211− -- We need to increase the number of workers.
212− spawnAction mgr
213− -- After this work, this thread stops to decease
214− -- the number of workers.
215− setThreadContinue tconf False
216− -- Since 'StreamingBody' is loop, we cannot control it.
217− -- So, let's serialize 'Builder' with a designated queue.
218− tbq <- newTBQueueIO 10 -- fixme: hard coding: 10
219− tbl <- toHeaderTable hs0
220− let !rspn = RspnStreaming s0 tbl tbq
221− !out = Output strm rspn ii tell h2data rspnOrWait
222− enqueueOutput outputQ out
223− let push b = do
224− T.pause th
225− atomically $ writeTBQueue tbq (SBuilder b)
226− T.resume th
227− flush = atomically $ writeTBQueue tbq SFlush
228− _ <- strmbdy push flush
229− atomically $ writeTBQueue tbq SFinish
230− deleteMyId mgr
231− return ResponseReceived
232−
233−worker :: Context -> S.Settings -> Application -> Responder -> T.Manager -> IO ()
234−worker ctx@Context{inputQ,controlQ} set app responder tm = do
235− sinfo <- newStreamInfo
236− tcont <- newThreadContinue
237− let timeoutAction = return () -- cannot close the shared connection
238− E.bracket (T.registerKillThread tm timeoutAction) T.cancel $ go sinfo tcont
239− where
240− go sinfo tcont th = do
241− setThreadContinue tcont True
242− ex <- E.try $ do
243− T.pause th
244− inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ
245− setStreamInfo sinfo inp
246− T.resume th
247− T.tickle th
248− let !body = getRequestBodyChunk req
249− !body' = do
250− T.pause th
251− bs <- body
252− T.resume th
253− return bs
254− !vaultValue = Vault.insert pauseTimeoutKey (T.pause th) $ vault req
255− !req' = req { vault = vaultValue, requestBody = body' }
256− mr <- E.try $ app req' $ responder ii th reqvt tcont strm req'
257− case mr of
258− Right ok -> return ok
259− Left e@(SomeException _)
260− | Just (ExceptionInsideResponseBody e') <- E.fromException e -> E.throwIO e'
261− | otherwise -> responder ii th reqvt tcont strm req' (S.settingsOnExceptionResponse set e)
262− cont1 <- case ex of
263− Right ResponseReceived -> return True
264− Left e@(SomeException _)
265− -- killed by the local worker manager
266− | Just ThreadKilled <- E.fromException e -> return False
267− -- killed by the local timeout manager
268− | Just T.TimeoutThread <- E.fromException e -> do
269− cleanup sinfo Nothing
270− return True
271− | otherwise -> do
272− cleanup sinfo $ Just e
273− return True
274− cont2 <- getThreadContinue tcont
275− clearStreamInfo sinfo
276− when (cont1 && cont2) $ go sinfo tcont th
277− cleanup sinfo me = do
278− minp <- getStreamInfo sinfo
279− case minp of
280− Nothing -> return ()
281− Just (Input strm req _reqvt _ii) -> do
282− closed ctx strm Killed
283− let !frame = resetFrame InternalError (streamNumber strm)
284− enqueueControl controlQ $ CFrame frame
285− case me of
286− Nothing -> return ()
287− Just e -> S.settingsOnException set (Just req) e
288−
289−----------------------------------------------------------------
290−
291−-- | It would nice if responders could return values to workers.
292−-- Unfortunately, 'ResponseReceived' is already defined in WAI 2.0.
293−-- It is not wise to change this type.
294−-- So, a reference is shared by a responder and its worker.
295−-- The reference refers a value of this type as a return value.
296−-- If 'True', the worker continue to serve requests.
297−-- Otherwise, the worker get finished.
298−newtype ThreadContinue = ThreadContinue (IORef Bool)
299−
300−{-# INLINE newThreadContinue #-}
301−newThreadContinue :: IO ThreadContinue
302−newThreadContinue = ThreadContinue <$> newIORef True
303−
304−{-# INLINE setThreadContinue #-}
305−setThreadContinue :: ThreadContinue -> Bool -> IO ()
306−setThreadContinue (ThreadContinue ref) x = writeIORef ref x
307−
308−{-# INLINE getThreadContinue #-}
309−getThreadContinue :: ThreadContinue -> IO Bool
310−getThreadContinue (ThreadContinue ref) = readIORef ref
311−
312−----------------------------------------------------------------
313−
314−-- | The type to store enough information for 'settingsOnException'.
315−newtype StreamInfo = StreamInfo (IORef (Maybe Input))
316−
317−{-# INLINE newStreamInfo #-}
318−newStreamInfo :: IO StreamInfo
319−newStreamInfo = StreamInfo <$> newIORef Nothing
320−
321−{-# INLINE clearStreamInfo #-}
322−clearStreamInfo :: StreamInfo -> IO ()
323−clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing
324−
325−{-# INLINE setStreamInfo #-}
326−setStreamInfo :: StreamInfo -> Input -> IO ()
327−setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp
328−
329−{-# INLINE getStreamInfo #-}
330−getStreamInfo :: StreamInfo -> IO (Maybe Input)
331−getStreamInfo (StreamInfo ref) = readIORef ref
warp/Network/Wai/Handler/Warp/Run.hs+20−3
@@ -3,6 +3,7 @@
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE PackageImports #-}
4{-# LANGUAGE PackageImports #-}
5{-# LANGUAGE PatternGuards #-}
5{-# LANGUAGE PatternGuards #-}
6+{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TupleSections #-}
8{-# LANGUAGE TupleSections #-}
8{-# OPTIONS_GHC -fno-warn-deprecations #-}
9{-# OPTIONS_GHC -fno-warn-deprecations #-}
@@ -19,20 +20,22 @@ import Data.IORef (IORef, newIORef, readIORef, writeIORef, atomicModifyIORef')
19import Data.Streaming.Network (bindPortTCP)
20import Data.Streaming.Network (bindPortTCP)
20import Foreign.C.Error (Errno(..), eCONNABORTED)
21import Foreign.C.Error (Errno(..), eCONNABORTED)
21import GHC.IO.Exception (IOException(..))
22import GHC.IO.Exception (IOException(..))
23+import qualified Network.HTTP2 as H2
22import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
24import Network.Socket (Socket, close, accept, withSocketsDo, SockAddr(SockAddrInet, SockAddrInet6), setSocketOption, SocketOption(..))
23import qualified Network.Socket.ByteString as Sock
25import qualified Network.Socket.ByteString as Sock
24import Network.Wai
26import Network.Wai
25import Network.Wai.Internal (ResponseReceived (ResponseReceived))
27import Network.Wai.Internal (ResponseReceived (ResponseReceived))
26import System.Environment (lookupEnv)
28import System.Environment (lookupEnv)
27−import System.Timeout (timeout)
28import qualified System.TimeManager as T
29import qualified System.TimeManager as T
30+import System.Timeout (timeout)
29
31
30import Network.Wai.Handler.Warp.Buffer
32import Network.Wai.Handler.Warp.Buffer
31import Network.Wai.Handler.Warp.Counter
33import Network.Wai.Handler.Warp.Counter
32import qualified Network.Wai.Handler.Warp.Date as D
34import qualified Network.Wai.Handler.Warp.Date as D
33import qualified Network.Wai.Handler.Warp.FdCache as F
35import qualified Network.Wai.Handler.Warp.FdCache as F
34import qualified Network.Wai.Handler.Warp.FileInfoCache as I
36import qualified Network.Wai.Handler.Warp.FileInfoCache as I
35−import Network.Wai.Handler.Warp.HTTP2 (http2, isHTTP2)
37+import Network.Wai.Handler.Warp.HTTP2 (http2)
38+import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2)
36import Network.Wai.Handler.Warp.Header
39import Network.Wai.Handler.Warp.Header
37import Network.Wai.Handler.Warp.Imports hiding (readInt)
40import Network.Wai.Handler.Warp.Imports hiding (readInt)
38import Network.Wai.Handler.Warp.ReadInt
41import Network.Wai.Handler.Warp.ReadInt
@@ -332,7 +335,8 @@ serveConnection conn ii th origAddr transport settings app = do
332 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
335 rawRecvN <- makeReceiveN bs (connRecv conn) (connRecvBuf conn)
333 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
336 let recvN = wrappedRecvN th istatus (settingsSlowlorisSize settings) rawRecvN
334 -- fixme: origAddr
337 -- fixme: origAddr
338+ checkTLS
335− http2 conn ii origAddr transport settings recvN app
339+ http2 conn ii origAddr settings recvN app
336 else do
340 else do
337 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
341 src <- mkSource (wrappedRecv conn th istatus (settingsSlowlorisSize settings))
338 writeIORef istatus True
342 writeIORef istatus True
@@ -490,6 +494,19 @@ serveConnection conn ii th origAddr transport settings app = do
490 else
494 else
491 return False
495 return False
492
496
497+ checkTLS = case transport of
498+ TCP -> return () -- direct
499+ tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"
500+ tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3
501+
502+-- connClose must not be called here since Run:fork calls it
503+goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()
504+goaway Connection{..} etype debugmsg = connSendAll bytestream
505+ where
506+ einfo = H2.encodeInfo id 0
507+ frame = H2.GoAwayFrame 0 etype debugmsg
508+ bytestream = H2.encodeFrame einfo frame
509+
493flushEntireBody :: IO ByteString -> IO ()
510flushEntireBody :: IO ByteString -> IO ()
494flushEntireBody src =
511flushEntireBody src =
495 loop
512 loop
warp/test/ResponseHeaderSpec.hs−33
@@ -7,9 +7,6 @@ import qualified Network.HTTP.Types as H
7import Network.Wai.Handler.Warp.ResponseHeader
7import Network.Wai.Handler.Warp.ResponseHeader
8import Network.Wai.Handler.Warp.Response
8import Network.Wai.Handler.Warp.Response
9import Network.Wai.Handler.Warp.Header
9import Network.Wai.Handler.Warp.Header
10−import Network.Wai.Handler.Warp.HTTP2.HPACK
11−import Network.HPACK
12−import Network.HPACK.Token
13import Test.Hspec
10import Test.Hspec
14
11
15main :: IO ()
12main :: IO ()
@@ -37,36 +34,6 @@ spec = do
37 let hdrs = [("Server","MyServer")]
34 let hdrs = [("Server","MyServer")]
38 rspidxhdr = indexResponseHeader hdrs
35 rspidxhdr = indexResponseHeader hdrs
39 addServer "" rspidxhdr hdrs `shouldBe` []
36 addServer "" rspidxhdr hdrs `shouldBe` []
40− describe "addHeader" $ do
41− it "adds Server if not exist" $ do
42− let v = "MyServer"
43− hdrs = []
44− hdrs1 = [("Server",v)]
45− (thl, vt) <- toHeaderTable hdrs
46− (thl1, _) <- toHeaderTable hdrs1
47− addHeader tokenServer v vt thl `shouldBe` thl1
48− it "does not add Server if exists" $ do
49− let v = "MyServer2"
50− hdrs = [("Server","MyServer")]
51− (thl, vt) <- toHeaderTable hdrs
52− addHeader tokenServer v vt thl `shouldBe` thl
53− it "does not add Server if empty" $ do
54− let v = ""
55− hdrs = []
56− (thl, vt) <- toHeaderTable hdrs
57− addHeader tokenServer v vt thl `shouldBe` thl
58− it "deletes Server" $ do
59− let v = ""
60− hdrs = [("Server","MyServer")]
61− hdrs1 = []
62− (thl, vt) <- toHeaderTable hdrs
63− (thl1, _) <- toHeaderTable hdrs1
64− addHeader tokenServer v vt thl `shouldBe` thl1
65− it "keeps Server" $ do
66− let v = ""
67− hdrs = [("Server","MyServer"),("Content-Type","Text/HTML")]
68− (thl, vt) <- toHeaderTable hdrs
69− addHeader tokenContentType v vt thl `shouldBe` thl
70
37
71headers :: H.ResponseHeaders
38headers :: H.ResponseHeaders
72headers = [
39headers = [
warp/warp.cabal+8−16
@@ -44,8 +44,8 @@ Library
44 , ghc-prim
44 , ghc-prim
45 , hashable
45 , hashable
46 , http-date
46 , http-date
47− , http-types >= 0.11
47+ , http-types >= 0.12
48− , http2 >= 1.6 && < 1.7
48+ , http2 >= 2.0 && < 2.1
49 , iproute >= 1.3.1
49 , iproute >= 1.3.1
50 , simple-sendfile >= 0.2.7 && < 0.3
50 , simple-sendfile >= 0.2.7 && < 0.3
51 , stm >= 2.3
51 , stm >= 2.3
@@ -74,15 +74,11 @@ Library
74 Network.Wai.Handler.Warp.FileInfoCache
74 Network.Wai.Handler.Warp.FileInfoCache
75 Network.Wai.Handler.Warp.HashMap
75 Network.Wai.Handler.Warp.HashMap
76 Network.Wai.Handler.Warp.HTTP2
76 Network.Wai.Handler.Warp.HTTP2
77− Network.Wai.Handler.Warp.HTTP2.EncodeFrame
78 Network.Wai.Handler.Warp.HTTP2.File
77 Network.Wai.Handler.Warp.HTTP2.File
79− Network.Wai.Handler.Warp.HTTP2.HPACK
78+ Network.Wai.Handler.Warp.HTTP2.PushPromise
80− Network.Wai.Handler.Warp.HTTP2.Manager
81− Network.Wai.Handler.Warp.HTTP2.Receiver
82 Network.Wai.Handler.Warp.HTTP2.Request
79 Network.Wai.Handler.Warp.HTTP2.Request
83− Network.Wai.Handler.Warp.HTTP2.Sender
80+ Network.Wai.Handler.Warp.HTTP2.Response
84 Network.Wai.Handler.Warp.HTTP2.Types
81 Network.Wai.Handler.Warp.HTTP2.Types
85− Network.Wai.Handler.Warp.HTTP2.Worker
86 Network.Wai.Handler.Warp.Header
82 Network.Wai.Handler.Warp.Header
87 Network.Wai.Handler.Warp.IO
83 Network.Wai.Handler.Warp.IO
88 Network.Wai.Handler.Warp.Imports
84 Network.Wai.Handler.Warp.Imports
@@ -153,15 +149,11 @@ Test-Suite spec
153 Network.Wai.Handler.Warp.File
149 Network.Wai.Handler.Warp.File
154 Network.Wai.Handler.Warp.FileInfoCache
150 Network.Wai.Handler.Warp.FileInfoCache
155 Network.Wai.Handler.Warp.HTTP2
151 Network.Wai.Handler.Warp.HTTP2
156− Network.Wai.Handler.Warp.HTTP2.EncodeFrame
157 Network.Wai.Handler.Warp.HTTP2.File
152 Network.Wai.Handler.Warp.HTTP2.File
158− Network.Wai.Handler.Warp.HTTP2.HPACK
153+ Network.Wai.Handler.Warp.HTTP2.PushPromise
159− Network.Wai.Handler.Warp.HTTP2.Manager
160− Network.Wai.Handler.Warp.HTTP2.Receiver
161 Network.Wai.Handler.Warp.HTTP2.Request
154 Network.Wai.Handler.Warp.HTTP2.Request
162− Network.Wai.Handler.Warp.HTTP2.Sender
155+ Network.Wai.Handler.Warp.HTTP2.Response
163 Network.Wai.Handler.Warp.HTTP2.Types
156 Network.Wai.Handler.Warp.HTTP2.Types
164− Network.Wai.Handler.Warp.HTTP2.Worker
165 Network.Wai.Handler.Warp.HashMap
157 Network.Wai.Handler.Warp.HashMap
166 Network.Wai.Handler.Warp.Header
158 Network.Wai.Handler.Warp.Header
167 Network.Wai.Handler.Warp.IO
159 Network.Wai.Handler.Warp.IO
@@ -202,8 +194,8 @@ Test-Suite spec
202 , hspec >= 1.3
194 , hspec >= 1.3
203 , http-client
195 , http-client
204 , http-date
196 , http-date
205− , http-types >= 0.8.5
197+ , http-types >= 0.12
206− , http2 >= 1.6 && < 1.7
198+ , http2 >= 2.0 && < 2.1
207 , iproute >= 1.3.1
199 , iproute >= 1.3.1
208 , lifted-base >= 0.1
200 , lifted-base >= 0.1
209 , network
201 , network