git.iko.soy/typeable/wai
on master help sign in
Using http2's new APIs: token based headers.
7c24409Kazu Yamamoto
warp/Network/Wai/Handler/Warp/File.hs+3−26
compare with master
unifiedsplit
@@ -7,25 +7,21 @@ module Network.Wai.Handler.Warp.File (
7 , conditionalRequest
7 , conditionalRequest
8 , addContentHeadersForFilePart
8 , addContentHeadersForFilePart
9 , parseByteRanges
9 , parseByteRanges
10− , packInteger -- testing
11 ) where
10 ) where
12
11
13import Control.Applicative ((<|>))
12import Control.Applicative ((<|>))
14−import Control.Monad
15import Data.Array ((!))
13import Data.Array ((!))
16import qualified Data.ByteString as B hiding (pack)
14import qualified Data.ByteString as B hiding (pack)
17import qualified Data.ByteString.Char8 as B (pack, readInteger)
15import qualified Data.ByteString.Char8 as B (pack, readInteger)
18−import Data.ByteString.Internal (ByteString(..), unsafeCreate)
16+import Data.ByteString (ByteString)
19import Data.Maybe (fromMaybe)
17import Data.Maybe (fromMaybe)
20−import Data.Word8 (Word8)
21−import Foreign.Ptr (Ptr, plusPtr)
22−import Foreign.Storable (poke)
23import Network.HTTP.Date
18import Network.HTTP.Date
24import qualified Network.HTTP.Types as H
19import qualified Network.HTTP.Types as H
25import qualified Network.HTTP.Types.Header as H
20import qualified Network.HTTP.Types.Header as H
26import Network.Wai
21import Network.Wai
27import qualified Network.Wai.Handler.Warp.FileInfoCache as I
22import qualified Network.Wai.Handler.Warp.FileInfoCache as I
28import Network.Wai.Handler.Warp.Header
23import Network.Wai.Handler.Warp.Header
24+import Network.Wai.Handler.Warp.PackInt
29import Numeric (showInt)
25import Numeric (showInt)
30
26
31#ifndef MIN_VERSION_http_types
27#ifndef MIN_VERSION_http_types
@@ -183,28 +179,9 @@ addContentHeaders hs off len size
183 | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size
179 | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size
184 in ctrng:hs'
180 in ctrng:hs'
185 where
181 where
186− !lengthBS = packInteger len
182+ !lengthBS = packIntegral len
187 !hs' = (H.hContentLength, lengthBS) : (acceptRange,"bytes") : hs
183 !hs' = (H.hContentLength, lengthBS) : (acceptRange,"bytes") : hs
188
184
189−-- |
190−--
191−-- prop> packInteger (abs n) == B.pack (show (abs n))
192−-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packInteger n' == B.pack (show n')
193−
194−packInteger :: Integer -> ByteString
195−packInteger 0 = "0"
196−packInteger n | n < 0 = error "packInteger"
197−packInteger n = unsafeCreate len go0
198− where
199− n' = fromIntegral n + 1 :: Double
200− len = ceiling $ logBase 10 n'
201− go0 p = go n $ p `plusPtr` (len - 1)
202− go :: Integer -> Ptr Word8 -> IO ()
203− go i p = do
204− let (d,r) = i `divMod` 10
205− poke p (48 + fromIntegral r)
206− when (d /= 0) $ go d (p `plusPtr` (-1))
207−
208-- |
185-- |
209--
186--
210-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
187-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
warp/Network/Wai/Handler/Warp/HTTP2/File.hsnew file+192
@@ -0,0 +1,192 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE BangPatterns, RecordWildCards #-}
4+
5+module Network.Wai.Handler.Warp.HTTP2.File (
6+ RspFileInfo(..)
7+ , conditionalRequest
8+ , addContentHeadersForFilePart
9+ , parseByteRanges
10+ ) where
11+
12+import Control.Applicative ((<|>))
13+import qualified Data.ByteString as B hiding (pack)
14+import qualified Data.ByteString.Char8 as B (pack, readInteger)
15+import Data.ByteString (ByteString)
16+import Data.Maybe (fromMaybe)
17+import Network.HTTP.Date
18+import qualified Network.HTTP.Types as H
19+import Network.Wai
20+import qualified Network.Wai.Handler.Warp.FileInfoCache as I
21+import Network.Wai.Handler.Warp.PackInt
22+import Numeric (showInt)
23+import Network.HPACK
24+import Network.HPACK.Token
25+
26+#ifndef MIN_VERSION_http_types
27+#define MIN_VERSION_http_types(x,y,z) 1
28+#endif
29+
30+-- $setup
31+-- >>> import Test.QuickCheck
32+
33+----------------------------------------------------------------
34+
35+data RspFileInfo = WithoutBody !H.Status
36+ | WithBody !H.Status !TokenHeaderList !Integer !Integer
37+ deriving (Eq,Show)
38+
39+----------------------------------------------------------------
40+
41+conditionalRequest :: I.FileInfo
42+ -> TokenHeaderList -- Response
43+ -> ValueTable -- Request
44+ -> RspFileInfo
45+conditionalRequest (I.FileInfo _ size mtime date) ths0 reqtbl = case condition of
46+ nobody@(WithoutBody _) -> nobody
47+ WithBody s _ off len -> let !hs = (tokenLastModified,date) :
48+ addContentHeaders ths0 off len size
49+ in WithBody s hs off len
50+ where
51+ !mcondition = ifmodified reqtbl size mtime
52+ <|> ifunmodified reqtbl size mtime
53+ <|> ifrange reqtbl size mtime
54+ !condition = fromMaybe (unconditional reqtbl size) mcondition
55+
56+----------------------------------------------------------------
57+
58+{-# INLINE ifModifiedSince #-}
59+ifModifiedSince :: ValueTable -> Maybe HTTPDate
60+ifModifiedSince reqtbl = getHeaderValue tokenIfModifiedSince reqtbl >>= parseHTTPDate
61+
62+{-# INLINE ifUnmodifiedSince #-}
63+ifUnmodifiedSince :: ValueTable -> Maybe HTTPDate
64+ifUnmodifiedSince reqtbl = getHeaderValue tokenIfUnmodifiedSince reqtbl >>= parseHTTPDate
65+
66+{-# INLINE ifRange #-}
67+ifRange :: ValueTable -> Maybe HTTPDate
68+ifRange reqtbl = getHeaderValue tokenIfRange reqtbl >>= parseHTTPDate
69+
70+----------------------------------------------------------------
71+
72+{-# INLINE ifmodified #-}
73+ifmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
74+ifmodified reqtbl size mtime = do
75+ date <- ifModifiedSince reqtbl
76+ return $ if date /= mtime
77+ then unconditional reqtbl size
78+ else WithoutBody H.notModified304
79+
80+{-# INLINE ifunmodified #-}
81+ifunmodified :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
82+ifunmodified reqtbl size mtime = do
83+ date <- ifUnmodifiedSince reqtbl
84+ return $ if date == mtime
85+ then unconditional reqtbl size
86+ else WithoutBody H.preconditionFailed412
87+
88+{-# INLINE ifrange #-}
89+ifrange :: ValueTable -> Integer -> HTTPDate -> Maybe RspFileInfo
90+ifrange reqtbl size mtime = do
91+ date <- ifRange reqtbl
92+ rng <- getHeaderValue tokenRange reqtbl
93+ return $ if date == mtime
94+ then parseRange rng size
95+ else WithBody H.ok200 [] 0 size
96+
97+{-# INLINE unconditional #-}
98+unconditional :: ValueTable -> Integer -> RspFileInfo
99+unconditional reqtbl size = case getHeaderValue tokenRange reqtbl of
100+ Nothing -> WithBody H.ok200 [] 0 size
101+ Just rng -> parseRange rng size
102+
103+----------------------------------------------------------------
104+
105+{-# INLINE parseRange #-}
106+parseRange :: ByteString -> Integer -> RspFileInfo
107+parseRange rng size = case parseByteRanges rng of
108+ Nothing -> WithoutBody H.requestedRangeNotSatisfiable416
109+ Just [] -> WithoutBody H.requestedRangeNotSatisfiable416
110+ Just (r:_) -> let (!beg, !end) = checkRange r size
111+ !len = end - beg + 1
112+ s = if beg == 0 && end == size - 1 then
113+ H.ok200
114+ else
115+ H.partialContent206
116+ in WithBody s [] beg len
117+
118+{-# INLINE checkRange #-}
119+checkRange :: H.ByteRange -> Integer -> (Integer, Integer)
120+checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)
121+checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)
122+checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)
123+
124+{-# INLINE parseByteRanges #-}
125+-- | Parse the value of a Range header into a 'H.ByteRanges'.
126+parseByteRanges :: B.ByteString -> Maybe H.ByteRanges
127+parseByteRanges bs1 = do
128+ bs2 <- stripPrefix "bytes=" bs1
129+ (r, bs3) <- range bs2
130+ ranges (r:) bs3
131+ where
132+ range bs2 = do
133+ (i, bs3) <- B.readInteger bs2
134+ if i < 0 -- has prefix "-" ("-0" is not valid, but here treated as "0-")
135+ then Just (H.ByteRangeSuffix (negate i), bs3)
136+ else do
137+ bs4 <- stripPrefix "-" bs3
138+ case B.readInteger bs4 of
139+ Just (j, bs5) | j >= i -> Just (H.ByteRangeFromTo i j, bs5)
140+ _ -> Just (H.ByteRangeFrom i, bs4)
141+ ranges front bs3
142+ | B.null bs3 = Just (front [])
143+ | otherwise = do
144+ bs4 <- stripPrefix "," bs3
145+ (r, bs5) <- range bs4
146+ ranges (front . (r:)) bs5
147+
148+ stripPrefix x y
149+ | x `B.isPrefixOf` y = Just (B.drop (B.length x) y)
150+ | otherwise = Nothing
151+
152+----------------------------------------------------------------
153+
154+{-# INLINE contentRangeHeader #-}
155+-- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header'
156+-- for the range specified.
157+contentRangeHeader :: Integer -> Integer -> Integer -> TokenHeader
158+contentRangeHeader beg end total = (tokenContentRange, range)
159+ where
160+ range = B.pack
161+ -- building with ShowS
162+ $ 'b' : 'y': 't' : 'e' : 's' : ' '
163+ : (if beg > end then ('*':) else
164+ showInt beg
165+ . ('-' :)
166+ . showInt end)
167+ ( '/'
168+ : showInt total "")
169+
170+{-# INLINE addContentHeaders #-}
171+addContentHeaders :: TokenHeaderList -> Integer -> Integer -> Integer -> TokenHeaderList
172+addContentHeaders ths off len size
173+ | len == size = ths'
174+ | otherwise = let !ctrng = contentRangeHeader off (off + len - 1) size
175+ in ctrng:ths'
176+ where
177+ !lengthBS = packIntegral len
178+ !ths' = (tokenContentLength, lengthBS) : (tokenAcceptRanges,"bytes") : ths
179+
180+{-# INLINE addContentHeadersForFilePart #-}
181+-- |
182+--
183+-- >>> addContentHeadersForFilePart [] (FilePart 2 10 16)
184+-- [("Content-Range","bytes 2-11/16"),("Content-Length","10"),("Accept-Ranges","bytes")]
185+-- >>> addContentHeadersForFilePart [] (FilePart 0 16 16)
186+-- [("Content-Length","16"),("Accept-Ranges","bytes")]
187+addContentHeadersForFilePart :: TokenHeaderList -> FilePart -> TokenHeaderList
188+addContentHeadersForFilePart hs part = addContentHeaders hs off len size
189+ where
190+ off = filePartOffset part
191+ len = filePartByteCount part
192+ size = filePartFileSize part
warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hs+59−26
@@ -1,18 +1,22 @@
1−{-# LANGUAGE OverloadedStrings #-}
1+{-# LANGUAGE OverloadedStrings, BangPatterns #-}
2{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
2{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
3
3
4−module Network.Wai.Handler.Warp.HTTP2.HPACK where
4+module Network.Wai.Handler.Warp.HTTP2.HPACK (
5+ hpackEncodeHeader
6+ , hpackEncodeHeaderLoop
7+ , hpackDecodeHeader
8+ , just
9+ ) where
5
10
6−import Control.Arrow (first)
7import qualified Control.Exception as E
11import qualified Control.Exception as E
8−import qualified Data.ByteString.Char8 as B8
12+import Control.Monad (unless)
9−import Data.CaseInsensitive (foldedCase)
13+import Data.ByteString (ByteString)
10import Network.HPACK hiding (Buffer)
14import Network.HPACK hiding (Buffer)
15+import Network.HPACK.Token
11import qualified Network.HTTP.Types as H
16import qualified Network.HTTP.Types as H
12import Network.HTTP2
17import Network.HTTP2
13import Network.Wai.Handler.Warp.HTTP2.Types
18import Network.Wai.Handler.Warp.HTTP2.Types
14−import Network.Wai.Handler.Warp.Header
19+import Network.Wai.Handler.Warp.PackInt
15−import Network.Wai.Handler.Warp.Response
16import qualified Network.Wai.Handler.Warp.Settings as S
20import qualified Network.Wai.Handler.Warp.Settings as S
17import Network.Wai.Handler.Warp.Types
21import Network.Wai.Handler.Warp.Types
18
22
@@ -26,27 +30,56 @@ strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }
26-- So, we don't need to split it.
30-- So, we don't need to split it.
27hpackEncodeHeader :: Context -> Buffer -> BufSize
31hpackEncodeHeader :: Context -> Buffer -> BufSize
28 -> InternalInfo -> S.Settings
32 -> InternalInfo -> S.Settings
29− -> H.Status -> H.ResponseHeaders
33+ -> H.Status -> (TokenHeaderList,ValueTable)
30− -> IO (HeaderList, Int)
34+ -> IO (TokenHeaderList, Int)
31−hpackEncodeHeader Context{..} buf siz ii settings s hdr0 = do
35+hpackEncodeHeader Context{..} buf siz ii settings s (ths0,tbl) = do
32− hdr1 <- addServerAndDate hdr0
36+ let !defServer = S.settingsServerName settings
33− let hs = (":status", status) : map (first foldedCase) hdr1
37+ !ths1 = addHeader tokenServer defServer tbl ths0
38+ date <- getDate ii
39+ let !ths2 = addHeader tokenDate date tbl ths1
40+ !status = packIntegral $ H.statusCode s
41+ !ths3 = (tokenStatus, status) : ths2
34− encodeHeaderBuffer buf siz strategy True encodeDynamicTable hs
42+ encodeTokenHeader buf siz strategy True encodeDynamicTable ths3
35− where
43+
36− status = B8.pack $ show $ H.statusCode s
44+{-# INLINE addHeader #-}
37− getdate = getDate ii
45+addHeader :: Token -> ByteString -> ValueTable -> TokenHeaderList -> TokenHeaderList
38− rspidxhdr = indexResponseHeader hdr0
46+addHeader t v tbl ths = case getHeaderValue t tbl of
39− defServer = S.settingsServerName settings
47+ Nothing -> (t,v) : ths
40− addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr
48+ Just _ -> ths
41−
49+
42−hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> HeaderList
50+hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> TokenHeaderList
43− -> IO (HeaderList, Int)
51+ -> IO (TokenHeaderList, Int)
44hpackEncodeHeaderLoop Context{..} buf siz hs =
52hpackEncodeHeaderLoop Context{..} buf siz hs =
45− encodeHeaderBuffer buf siz strategy False encodeDynamicTable hs
53+ encodeTokenHeader buf siz strategy False encodeDynamicTable hs
46
54
47----------------------------------------------------------------
55----------------------------------------------------------------
48
56
49−hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderList
57+hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO (TokenHeaderList, ValueTable)
50−hpackDecodeHeader hdrblk Context{..} =
58+hpackDecodeHeader hdrblk Context{..} = do
51− decodeHeader decodeDynamicTable hdrblk `E.catch` \(E.SomeException _) ->
59+ tbl@(_,vt) <- decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl
60+ unless (checkRequestHeader vt) $
61+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"
62+ return tbl
63+ where
64+ handl IllegalHeaderName =
65+ E.throwIO $ ConnectionError ProtocolError "the header key is illegal"
66+ handl _ =
52 E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
67 E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
68+
69+{-# INLINE checkRequestHeader #-}
70+checkRequestHeader :: ValueTable -> Bool
71+checkRequestHeader reqvt
72+ | getHeaderValue tokenStatus reqvt /= Nothing = False
73+ | getHeaderValue tokenPath reqvt == Nothing = False
74+ | getHeaderValue tokenMethod reqvt == Nothing = False
75+ | getHeaderValue tokenAuthority reqvt == Nothing = False
76+ | getHeaderValue tokenConnection reqvt /= Nothing = False
77+ | just (getHeaderValue tokenTE reqvt) (/= "trailers") = False
78+ | otherwise = True
79+
80+{-# INLINE just #-}
81+just :: Maybe a -> (a -> Bool) -> Bool
82+just Nothing _ = False
83+just (Just x) p
84+ | p x = True
85+ | otherwise = False
warp/Network/Wai/Handler/Warp/HTTP2/Receiver.hs+32−29
@@ -15,7 +15,8 @@ import qualified Control.Exception as E
15import Control.Monad (when, unless, void)
15import Control.Monad (when, unless, void)
16import Data.ByteString (ByteString)
16import Data.ByteString (ByteString)
17import qualified Data.ByteString as BS
17import qualified Data.ByteString as BS
18−import Data.Maybe (isJust)
18+import Network.HPACK
19+import Network.HPACK.Token
19import Network.HTTP2
20import Network.HTTP2
20import Network.HTTP2.Priority (toPrecedence, delete, prepare)
21import Network.HTTP2.Priority (toPrecedence, delete, prepare)
21import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
22import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
@@ -23,6 +24,7 @@ import Network.Wai.Handler.Warp.HTTP2.HPACK
23import Network.Wai.Handler.Warp.HTTP2.Request
24import Network.Wai.Handler.Warp.HTTP2.Request
24import Network.Wai.Handler.Warp.HTTP2.Types
25import Network.Wai.Handler.Warp.HTTP2.Types
25import Network.Wai.Handler.Warp.IORef
26import Network.Wai.Handler.Warp.IORef
27+import Network.Wai.Handler.Warp.ReadInt
26import Network.Wai.Handler.Warp.Types
28import Network.Wai.Handler.Warp.Types
27
29
28----------------------------------------------------------------
30----------------------------------------------------------------
@@ -103,30 +105,26 @@ frameReceiver ctx mkreq recvN = loop 0 `E.catch` sendGoaway
103 state <- readIORef streamState
105 state <- readIORef streamState
104 state' <- stream ftyp header pl ctx state strm
106 state' <- stream ftyp header pl ctx state strm
105 case state' of
107 case state' of
106− Open (NoBody hdr pri) -> do
108+ Open (NoBody tbl@(_,reqvt) pri) -> do
107 resetContinued
109 resetContinued
108− case validateHeaders hdr of
110+ let mcl = readInt <$> getHeaderValue tokenContentLength reqvt
109− Just vh -> do
111+ when (just mcl (== (0 :: Int))) $
110− when (isJust (vhCL vh) && vhCL vh /= Just 0) $
111− E.throwIO $ StreamError ProtocolError streamId
112+ E.throwIO $ StreamError ProtocolError streamId
112− writeIORef streamPrecedence $ toPrecedence pri
113+ writeIORef streamPrecedence $ toPrecedence pri
113− writeIORef streamState HalfClosed
114+ writeIORef streamState HalfClosed
114− let (!req, !ii) = mkreq vh (return "")
115+ let (!req, !ii) = mkreq tbl (return "")
115− atomically $ writeTQueue inputQ $ Input strm req ii
116+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii
116− Nothing -> E.throwIO $ StreamError ProtocolError streamId
117− Open (HasBody hdr pri) -> do
117+ Open (HasBody tbl@(_,reqvt) pri) -> do
118 resetContinued
118 resetContinued
119− case validateHeaders hdr of
120− Just vh -> do
121− q <- newTQueueIO
119+ q <- newTQueueIO
122− writeIORef streamPrecedence $ toPrecedence pri
120+ writeIORef streamPrecedence $ toPrecedence pri
123− writeIORef streamState (Open (Body q))
121+ writeIORef streamState (Open (Body q))
122+ let mcl = readInt <$> getHeaderValue tokenContentLength reqvt
124− writeIORef streamContentLength $ vhCL vh
123+ writeIORef streamContentLength mcl
125− readQ <- newReadBody q
124+ readQ <- newReadBody q
126− bodySource <- mkSource readQ
125+ bodySource <- mkSource readQ
127− let (!req, !ii) = mkreq vh (readSource bodySource)
126+ let (!req, !ii) = mkreq tbl (readSource bodySource)
128− atomically $ writeTQueue inputQ $ Input strm req ii
127+ atomically $ writeTQueue inputQ $ Input strm req reqvt ii
129− Nothing -> E.throwIO $ StreamError ProtocolError streamId
130 s@(Open Continued{}) -> do
128 s@(Open Continued{}) -> do
131 setContinued
129 setContinued
132 writeIORef streamState s
130 writeIORef streamState s
@@ -219,11 +217,14 @@ control _ _ _ _ =
219
217
220----------------------------------------------------------------
218----------------------------------------------------------------
221
219
220+{-# INLINE guardIt #-}
222guardIt :: Either HTTP2Error a -> IO a
221guardIt :: Either HTTP2Error a -> IO a
223guardIt x = case x of
222guardIt x = case x of
224 Left err -> E.throwIO err
223 Left err -> E.throwIO err
225 Right frame -> return frame
224 Right frame -> return frame
226
225
226+
227+{-# INLINE checkPriority #-}
227checkPriority :: Priority -> StreamId -> IO ()
228checkPriority :: Priority -> StreamId -> IO ()
228checkPriority p me
229checkPriority p me
229 | dep == me = E.throwIO $ StreamError ProtocolError me
230 | dep == me = E.throwIO $ StreamError ProtocolError me
@@ -242,11 +243,11 @@ stream FrameHeaders header@FrameHeader{flags} bs ctx (Open JustOpened) Stream{st
242 let !endOfStream = testEndStream flags
243 let !endOfStream = testEndStream flags
243 !endOfHeader = testEndHeader flags
244 !endOfHeader = testEndHeader flags
244 if endOfHeader then do
245 if endOfHeader then do
245− hdr <- hpackDecodeHeader frag ctx
246+ tbl <- hpackDecodeHeader frag ctx -- fixme
246 return $ if endOfStream then
247 return $ if endOfStream then
247− Open (NoBody hdr pri)
248+ Open (NoBody tbl pri)
248 else
249 else
249− Open (HasBody hdr pri)
250+ Open (HasBody tbl pri)
250 else do
251 else do
251 let !siz = BS.length frag
252 let !siz = BS.length frag
252 return $ Open $ Continued [frag] siz 1 endOfStream pri
253 return $ Open $ Continued [frag] siz 1 endOfStream pri
@@ -300,11 +301,11 @@ stream FrameContinuation FrameHeader{flags} frag ctx (Open (Continued rfrags siz
300 E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"
301 E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"
301 if endOfHeader then do
302 if endOfHeader then do
302 let !hdrblk = BS.concat $ reverse rfrags'
303 let !hdrblk = BS.concat $ reverse rfrags'
303− hdr <- hpackDecodeHeader hdrblk ctx
304+ tbl <- hpackDecodeHeader hdrblk ctx
304 return $ if endOfStream then
305 return $ if endOfStream then
305− Open (NoBody hdr pri)
306+ Open (NoBody tbl pri)
306 else
307 else
307− Open (HasBody hdr pri)
308+ Open (HasBody tbl pri)
308 else
309 else
309 return $ Open $ Continued rfrags' siz' n' endOfStream pri
310 return $ Open $ Continued rfrags' siz' n' endOfStream pri
310
311
@@ -350,11 +351,13 @@ stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError s
350
351
351----------------------------------------------------------------
352----------------------------------------------------------------
352
353
354+{-# INLINE newReadBody #-}
353newReadBody :: TQueue ByteString -> IO (IO ByteString)
355newReadBody :: TQueue ByteString -> IO (IO ByteString)
354newReadBody q = do
356newReadBody q = do
355 ref <- newIORef False
357 ref <- newIORef False
356 return $ readBody q ref
358 return $ readBody q ref
357
359
360+{-# INLINE readBody #-}
358readBody :: TQueue ByteString -> IORef Bool -> IO ByteString
361readBody :: TQueue ByteString -> IORef Bool -> IO ByteString
359readBody q ref = do
362readBody q ref = do
360 eof <- readIORef ref
363 eof <- readIORef ref
warp/Network/Wai/Handler/Warp/HTTP2/Request.hs+31−125
@@ -4,163 +4,69 @@
4module Network.Wai.Handler.Warp.HTTP2.Request (
4module Network.Wai.Handler.Warp.HTTP2.Request (
5 mkRequest
5 mkRequest
6 , MkReq
6 , MkReq
7− , ValidHeaders(..)
8− , validateHeaders
9 ) where
7 ) where
10
8
11−#if __GLASGOW_HASKELL__ < 709
12−import Control.Applicative ((<$>))
9+import Control.Applicative ((<|>))
13−#endif
10+import Control.Arrow (first)
14import Data.ByteString (ByteString)
11import Data.ByteString (ByteString)
15−import qualified Data.ByteString as BS
16import qualified Data.ByteString.Char8 as B8
12import qualified Data.ByteString.Char8 as B8
17−import Data.CaseInsensitive (mk)
13+import Data.Maybe (fromJust)
18−import Data.Maybe (isJust)
19import qualified Data.Vault.Lazy as Vault
14import qualified Data.Vault.Lazy as Vault
20−#if __GLASGOW_HASKELL__ < 709
21−import Data.Monoid (mempty)
22−#endif
23−import Data.Word8 (isUpper,_colon)
24import Network.HPACK
15import Network.HPACK
25−import Network.HTTP.Types (RequestHeaders)
16+import Network.HPACK.Token
26import qualified Network.HTTP.Types as H
17import qualified Network.HTTP.Types as H
27import Network.Socket (SockAddr)
18import Network.Socket (SockAddr)
28import Network.Wai
19import Network.Wai
29import Network.Wai.Handler.Warp.HTTP2.Types
20import Network.Wai.Handler.Warp.HTTP2.Types
30import Network.Wai.Handler.Warp.HashMap (hashByteString)
21import Network.Wai.Handler.Warp.HashMap (hashByteString)
31−import Network.Wai.Handler.Warp.ReadInt
32import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey)
22import Network.Wai.Handler.Warp.Request (pauseTimeoutKey, getFileInfoKey)
33−import Network.Wai.Handler.Warp.Types
34−import Network.Wai.Internal (Request(..))
35import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)
23import qualified Network.Wai.Handler.Warp.Settings as S (Settings, settingsNoParsePath)
36import qualified Network.Wai.Handler.Warp.Timeout as Timeout
24import qualified Network.Wai.Handler.Warp.Timeout as Timeout
25+import Network.Wai.Handler.Warp.Types
26+import Network.Wai.Internal (Request(..))
37
27
38−data ValidHeaders = ValidHeaders {
39− vhMethod :: !ByteString
40− , vhPath :: !ByteString
41− , vhAuth :: !(Maybe ByteString)
42− , vhRange :: !(Maybe ByteString)
43− , vhReferer :: !(Maybe ByteString)
44− , vhUA :: !(Maybe ByteString)
45− , vhCL :: !(Maybe Int)
46− , vhHeader :: !RequestHeaders
47− } deriving Show
48−
49−type MkReq = ValidHeaders -> IO ByteString -> (Request,InternalInfo)
28+type MkReq = (TokenHeaderList,ValueTable) -> IO ByteString -> (Request,InternalInfo)
50
29
51mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq
30mkRequest :: InternalInfo1 -> S.Settings -> SockAddr -> MkReq
52−mkRequest ii1 settings addr (ValidHeaders m p ma mrng mrr mua _ hdr) body =
31+mkRequest ii1 settings addr (reqths,reqvt) body = (req,ii)
53− (req,ii)
54 where
32 where
55− (unparsedPath,query) = B8.break (=='?') p
56− !path = H.extractPath unparsedPath
57− !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
58− !h = hashByteString rawPath
59 !req = Request {
33 !req = Request {
60− requestMethod = m
34+ requestMethod = colonMethod
61 , httpVersion = http2ver
35 , httpVersion = http2ver
62 , rawPathInfo = rawPath
36 , rawPathInfo = rawPath
63 , pathInfo = H.decodePathSegments path
37 , pathInfo = H.decodePathSegments path
64 , rawQueryString = query
38 , rawQueryString = query
65 , queryString = H.parseQuery query
39 , queryString = H.parseQuery query
66− , requestHeaders = case ma of
40+ , requestHeaders = headers
67− Nothing -> hdr
68− Just hv -> (mk "host", hv) : hdr
69 , isSecure = True
41 , isSecure = True
70 , remoteHost = addr
42 , remoteHost = addr
71 , requestBody = body
43 , requestBody = body
72 , vault = vaultValue
44 , vault = vaultValue
73 , requestBodyLength = ChunkedBody -- fixme
45 , requestBodyLength = ChunkedBody -- fixme
74− , requestHeaderHost = ma
46+ , requestHeaderHost = mHost
75− , requestHeaderRange = mrng
47+ , requestHeaderRange = mRange
76− , requestHeaderReferer = mrr
48+ , requestHeaderReferer = mReferer
77− , requestHeaderUserAgent = mua
49+ , requestHeaderUserAgent = mUserAgent
78 }
50 }
51+ headers = map (first tokenKey) ths
52+ where
53+ ths = case mHost of
54+ Nothing -> (tokenHost, colonAuth) : reqths
55+ Just _ -> reqths
56+ !colonPath = fromJust $ getHeaderValue tokenPath reqvt
57+ !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt
58+ !mAuth = getHeaderValue tokenAuthority reqvt
59+ !colonAuth = fromJust $ mAuth
60+ !mHost = getHeaderValue tokenHost reqvt <|> mAuth
61+ !mRange = getHeaderValue tokenRange reqvt
62+ !mReferer = getHeaderValue tokenReferer reqvt
63+ !mUserAgent = getHeaderValue tokenUserAgent reqvt
64+ (unparsedPath,query) = B8.break (=='?') colonPath
65+ !path = H.extractPath unparsedPath
66+ !rawPath = if S.settingsNoParsePath settings then unparsedPath else path
67+ !h = hashByteString rawPath
79 !ii = toInternalInfo ii1 h
68 !ii = toInternalInfo ii1 h
80 !th = threadHandle ii
69 !th = threadHandle ii
81 !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
70 !vaultValue = Vault.insert pauseTimeoutKey (Timeout.pause th)
82 $ Vault.insert getFileInfoKey (getFileInfo ii)
71 $ Vault.insert getFileInfoKey (getFileInfo ii)
83 Vault.empty
72 Vault.empty
84−
85−----------------------------------------------------------------
86−
87−data Special = Special {
88− colonMethod :: !(Maybe ByteString)
89− , colonPath :: !(Maybe ByteString)
90− , colonAuth :: !(Maybe ByteString)
91− , sRange :: !(Maybe ByteString)
92− , sReferer :: !(Maybe ByteString)
93− , sUA :: !(Maybe ByteString)
94− , contentLen :: !(Maybe ByteString)
95− } deriving Show
96−
97−emptySpecial :: Special
98−emptySpecial = Special Nothing Nothing Nothing Nothing Nothing Nothing Nothing
99−
100−-- |
101−--
102−-- >>> validateHeaders [(":method","GET"),(":path","path")]
103−-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Nothing, vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = []})
104−-- >>> validateHeaders [(":method","GET"),(":path","path"),(":authority","authority"),("accept-language","en")]
105−-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Just "authority", vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = [("accept-language","en")]})
106−-- >>> validateHeaders [(":method","GET"),(":path","path"),("cookie","a=b"),("accept-language","en"),("cookie","c=d"),("cookie","e=f")]
107−-- Just (ValidHeaders {vhMethod = "GET", vhPath = "path", vhAuth = Nothing, vhRange = Nothing, vhReferer = Nothing, vhUA = Nothing, vhCL = Nothing, vhHeader = [("accept-language","en"),("cookie","a=b; c=d; e=f")]})
108−validateHeaders :: HeaderList -> Maybe ValidHeaders
109−validateHeaders hs = case pseudo hs emptySpecial of
110− Just (Special (Just m) (Just p) ma mrng mrr mua mcl, !h)
111− -> Just $! ValidHeaders m p ma mrng mrr mua (readInt <$> mcl) h
112− _ -> Nothing
113− where
114− pseudo [] !s = Just (s,[])
115− pseudo h@((k,v):kvs) !s
116− | k == ":method" = if isJust (colonMethod s) then
117− Nothing
118− else
119− pseudo kvs (s { colonMethod = Just v })
120− | k == ":path" = if isJust (colonPath s) then
121− Nothing
122− else
123− pseudo kvs (s { colonPath = Just v })
124− | k == ":authority" = if isJust (colonAuth s) then
125− Nothing
126− else
127− pseudo kvs (s { colonAuth = Just v })
128− | k == ":scheme" = pseudo kvs s -- fixme: how to store :scheme?
129− | isPseudo k = Nothing
130− | otherwise = normal h (s,id,id)
131−
132− normal [] (!s,b,c) = Just (s, mkH b c)
133− normal ((k,v):kvs) (!s,b,c)
134− | isPseudo k = Nothing
135− | k == "connection" = Nothing
136− | k == "te" = if v == "trailers" then
137− normal kvs (s, b . ((mk k,v) :), c)
138− else
139− Nothing
140− | k == "range"
141− = normal kvs (s {sRange = Just v }, b . ((mk k,v) :), c)
142− | k == "referer"
143− = normal kvs (s { sReferer = Just v }, b . ((mk k,v) :), c)
144− | k == "user-agent"
145− = normal kvs (s { sUA = Just v }, b . ((mk k,v) :), c)
146− | k == "content-length"
147− = normal kvs (s { contentLen = Just v }, b . ((mk k,v) :), c)
148− | k == "host" = if isJust (colonAuth s) then
149− normal kvs (s, b, c)
150− else
151− normal kvs (s { colonAuth = Just v }, b, c)
152− | k == "cookie" = normal kvs (s, b, c . (v:))
153− | otherwise = case BS.find isUpper k of
154− Nothing -> normal kvs (s, b . ((mk k,v) :), c)
155− Just _ -> Nothing
156−
157− mkH b c = h
158− where
159− !h = b anchor
160− !cookieList = c []
161− !anchor
162− | null cookieList = []
163− | otherwise = let !v = BS.intercalate "; " cookieList
164− in [("cookie",v)]
165− isPseudo "" = False
166− isPseudo k = BS.head k == _colon
warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+16−6
@@ -44,14 +44,17 @@ data Leftover = LZero
44
44
45----------------------------------------------------------------
45----------------------------------------------------------------
46
46
47+{-# INLINE getStreamWindowSize #-}
47getStreamWindowSize :: Stream -> IO WindowSize
48getStreamWindowSize :: Stream -> IO WindowSize
48getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow
49getStreamWindowSize Stream{streamWindow} = atomically $ readTVar streamWindow
49
50
51+{-# INLINE waitStreamWindowSize #-}
50waitStreamWindowSize :: Stream -> STM ()
52waitStreamWindowSize :: Stream -> STM ()
51waitStreamWindowSize Stream{streamWindow} = do
53waitStreamWindowSize Stream{streamWindow} = do
52 w <- readTVar streamWindow
54 w <- readTVar streamWindow
53 check (w > 0)
55 check (w > 0)
54
56
57+{-# INLINE waitStreaming #-}
55waitStreaming :: TBQueue a -> STM ()
58waitStreaming :: TBQueue a -> STM ()
56waitStreaming tbq = do
59waitStreaming tbq = do
57 isEmpty <- isEmptyTBQueue tbq
60 isEmpty <- isEmptyTBQueue tbq
@@ -111,6 +114,7 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
111 setLimit alist
114 setLimit alist
112 return off'
115 return off'
113
116
117+ {-# INLINE setLimit #-}
114 setLimit alist = case lookup SettingsHeaderTableSize alist of
118 setLimit alist = case lookup SettingsHeaderTableSize alist of
115 Nothing -> return ()
119 Nothing -> return ()
116 Just siz -> setLimitForEncoding siz encodeDynamicTable
120 Just siz -> setLimitForEncoding siz encodeDynamicTable
@@ -192,6 +196,7 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
192 enqueueControl controlQ $ CFrame rst
196 enqueueControl controlQ $ CFrame rst
193 return off
197 return off
194
198
199+ {-# INLINE flushN #-}
195 -- Flush the connection buffer to the socket, where the first 'n' bytes of
200 -- Flush the connection buffer to the socket, where the first 'n' bytes of
196 -- the buffer are filled.
201 -- the buffer are filled.
197 flushN :: Int -> IO ()
202 flushN :: Int -> IO ()
@@ -212,8 +217,8 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
212 fillFrameHeader FrameHeaders kvlen sid flag buf
217 fillFrameHeader FrameHeaders kvlen sid flag buf
213 continue sid kvlen hs
218 continue sid kvlen hs
214
219
215− bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
220+ !bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
216− headerPayloadLim = connBufferSize - frameHeaderLength
221+ !headerPayloadLim = connBufferSize - frameHeaderLength
217
222
218 continue _ kvlen [] = return kvlen
223 continue _ kvlen [] = return kvlen
219 continue sid kvlen hs = do
224 continue sid kvlen hs = do
@@ -227,6 +232,7 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
227 fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer
232 fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer
228 continue sid kvlen' hs'
233 continue sid kvlen' hs'
229
234
235+ {-# INLINE maybeEnqueueNext #-}
230 -- Re-enqueue the stream in the output queue.
236 -- Re-enqueue the stream in the output queue.
231 maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence) -> Maybe DynaNext -> IO ()
237 maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence) -> Maybe DynaNext -> IO ()
232 maybeEnqueueNext _ _ Nothing = return ()
238 maybeEnqueueNext _ _ Nothing = return ()
@@ -234,6 +240,7 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
234 where
240 where
235 !out = ONext strm next mtbq
241 !out = ONext strm next mtbq
236
242
243+ {-# INLINE sendHeadersIfNecessary #-}
237 -- Send headers if there is not room for a 1-byte data frame, and return
244 -- Send headers if there is not room for a 1-byte data frame, and return
238 -- the offset of the next frame's first header byte.
245 -- the offset of the next frame's first header byte.
239 sendHeadersIfNecessary off
246 sendHeadersIfNecessary off
@@ -248,19 +255,21 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
248 let !sid = streamNumber strm
255 let !sid = streamNumber strm
249 !buf = connWriteBuffer `plusPtr` off
256 !buf = connWriteBuffer `plusPtr` off
250 !off' = off + frameHeaderLength + datPayloadLen
257 !off' = off + frameHeaderLength + datPayloadLen
251− flag = case mnext of
258+ !done = isNothing mnext
252− Nothing -> setEndStream defaultFlags
259+ flag | done = setEndStream defaultFlags
253− _ -> defaultFlags
260+ | otherwise = defaultFlags
254 fillFrameHeader FrameData datPayloadLen sid flag buf
261 fillFrameHeader FrameData datPayloadLen sid flag buf
255− when (isNothing mnext) $ closed ctx strm Finished
262+ when done $ closed ctx strm Finished
256 atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)
263 atomically $ modifyTVar' connectionWindow (subtract datPayloadLen)
257 atomically $ modifyTVar' (streamWindow strm) (subtract datPayloadLen)
264 atomically $ modifyTVar' (streamWindow strm) (subtract datPayloadLen)
258 return off'
265 return off'
259
266
267+ {-# INLINE fillFrameHeader #-}
260 fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf
268 fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf
261 where
269 where
262 hinfo = FrameHeader len flag sid
270 hinfo = FrameHeader len flag sid
263
271
272+ {-# INLINE ignore #-}
264 ignore :: E.SomeException -> IO ()
273 ignore :: E.SomeException -> IO ()
265 ignore _ = return ()
274 ignore _ = return ()
266
275
@@ -456,6 +465,7 @@ nextForFile len fd start bytes refresh =
456 Next len $ Just (fillBufFile fd start bytes refresh)
465 Next len $ Just (fillBufFile fd start bytes refresh)
457#endif
466#endif
458
467
468+{-# INLINE mini #-}
459mini :: Int -> Integer -> Int
469mini :: Int -> Integer -> Int
460mini i n
470mini i n
461 | fromIntegral i < n = i
471 | fromIntegral i < n = i
warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+12−12
@@ -41,7 +41,7 @@ isHTTP2 tls = useHTTP2
41
41
42----------------------------------------------------------------
42----------------------------------------------------------------
43
43
44−data Input = Input Stream Request InternalInfo
44+data Input = Input Stream Request ValueTable InternalInfo
45
45
46----------------------------------------------------------------
46----------------------------------------------------------------
47
47
@@ -51,10 +51,10 @@ type BytesFilled = Int
51
51
52data Next = Next !BytesFilled (Maybe DynaNext)
52data Next = Next !BytesFilled (Maybe DynaNext)
53
53
54−data Rspn = RspnNobody H.Status H.ResponseHeaders
54+data Rspn = RspnNobody H.Status (TokenHeaderList, ValueTable)
55− | RspnStreaming H.Status H.ResponseHeaders (TBQueue Sequence)
55+ | RspnStreaming H.Status (TokenHeaderList, ValueTable) (TBQueue Sequence)
56− | RspnBuilder H.Status H.ResponseHeaders Builder
56+ | RspnBuilder H.Status (TokenHeaderList, ValueTable) Builder
57− | RspnFile H.Status H.ResponseHeaders FilePath (Maybe FilePart)
57+ | RspnFile H.Status (TokenHeaderList, ValueTable) FilePath (Maybe FilePart)
58
58
59rspnStatus :: Rspn -> H.Status
59rspnStatus :: Rspn -> H.Status
60rspnStatus (RspnNobody s _) = s
60rspnStatus (RspnNobody s _) = s
@@ -62,11 +62,11 @@ rspnStatus (RspnStreaming s _ _) = s
62rspnStatus (RspnBuilder s _ _) = s
62rspnStatus (RspnBuilder s _ _) = s
63rspnStatus (RspnFile s _ _ _ ) = s
63rspnStatus (RspnFile s _ _ _ ) = s
64
64
65−rspnHeaders :: Rspn -> H.ResponseHeaders
65+rspnHeaders :: Rspn -> (TokenHeaderList, ValueTable)
66−rspnHeaders (RspnNobody _ h) = h
66+rspnHeaders (RspnNobody _ t) = t
67−rspnHeaders (RspnStreaming _ h _) = h
67+rspnHeaders (RspnStreaming _ t _) = t
68−rspnHeaders (RspnBuilder _ h _) = h
68+rspnHeaders (RspnBuilder _ t _) = t
69−rspnHeaders (RspnFile _ h _ _ ) = h
69+rspnHeaders (RspnFile _ t _ _ ) = t
70
70
71data Output = ORspn !Stream !Rspn !InternalInfo
71data Output = ORspn !Stream !Rspn !InternalInfo
72 | ONext !Stream !DynaNext !(Maybe (TBQueue Sequence))
72 | ONext !Stream !DynaNext !(Maybe (TBQueue Sequence))
@@ -144,8 +144,8 @@ data OpenState =
144 !Int -- The number of continuation frames
144 !Int -- The number of continuation frames
145 !Bool -- End of stream
145 !Bool -- End of stream
146 !Priority
146 !Priority
147− | NoBody HeaderList !Priority
147+ | NoBody (TokenHeaderList,ValueTable) !Priority
148− | HasBody HeaderList !Priority
148+ | HasBody (TokenHeaderList,ValueTable) !Priority
149 | Body !(TQueue ByteString)
149 | Body !(TQueue ByteString)
150
150
151data ClosedCode = Finished
151data ClosedCode = Finished
warp/Network/Wai/Handler/Warp/HTTP2/Worker.hs+35−19
@@ -22,13 +22,13 @@ import Control.Monad (when)
22import Data.ByteString.Builder (byteString)
22import Data.ByteString.Builder (byteString)
23import qualified Network.HTTP.Types as H
23import qualified Network.HTTP.Types as H
24import Network.HTTP2
24import Network.HTTP2
25+import Network.HPACK
25import Network.Wai
26import Network.Wai
26−import Network.Wai.Handler.Warp.File
27import Network.Wai.Handler.Warp.FileInfoCache
27import Network.Wai.Handler.Warp.FileInfoCache
28import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
28import Network.Wai.Handler.Warp.HTTP2.EncodeFrame
29+import Network.Wai.Handler.Warp.HTTP2.File
29import Network.Wai.Handler.Warp.HTTP2.Manager
30import Network.Wai.Handler.Warp.HTTP2.Manager
30import Network.Wai.Handler.Warp.HTTP2.Types
31import Network.Wai.Handler.Warp.HTTP2.Types
31−import Network.Wai.Handler.Warp.Header
32import Network.Wai.Handler.Warp.IORef
32import Network.Wai.Handler.Warp.IORef
33import qualified Network.Wai.Handler.Warp.Response as R
33import qualified Network.Wai.Handler.Warp.Response as R
34import qualified Network.Wai.Handler.Warp.Settings as S
34import qualified Network.Wai.Handler.Warp.Settings as S
@@ -41,14 +41,15 @@ import Network.Wai.Internal (Response(..), ResponseReceived(..), ResponseReceive
41-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.
41-- | The wai definition is 'type Application = Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived'.
42-- This type implements the second argument (Response -> IO ResponseReceived)
42-- This type implements the second argument (Response -> IO ResponseReceived)
43-- with extra arguments.
43-- with extra arguments.
44+type Responder = InternalInfo -> ValueTable ->
44−type Responder = InternalInfo -> ThreadContinue -> Stream -> Request ->
45+ ThreadContinue -> Stream -> Request ->
45 Response -> IO ResponseReceived
46 Response -> IO ResponseReceived
46
47
47-- | This function is passed to workers.
48-- | This function is passed to workers.
48-- They also pass 'Response's from 'Application's to this function.
49-- They also pass 'Response's from 'Application's to this function.
49-- This function enqueues commands for the HTTP/2 sender.
50-- This function enqueues commands for the HTTP/2 sender.
50response :: S.Settings -> Context -> Manager -> Responder
51response :: S.Settings -> Context -> Manager -> Responder
51−response settings Context{outputQ} mgr ii tconf strm req rsp = case rsp of
52+response settings Context{outputQ} mgr ii reqvt tconf strm req rsp = case rsp of
52 ResponseStream s0 hs0 strmbdy
53 ResponseStream s0 hs0 strmbdy
53 | noBody s0 -> responseNoBody s0 hs0
54 | noBody s0 -> responseNoBody s0 hs0
54 | isHead -> responseNoBody s0 hs0
55 | isHead -> responseNoBody s0 hs0
@@ -73,18 +74,21 @@ response settings Context{outputQ} mgr ii tconf strm req rsp = case rsp of
73 -- log message are written here even the window size of streams
74 -- log message are written here even the window size of streams
74 -- is 0.
75 -- is 0.
75
76
76− responseNoBody s hs = do
77+ responseNoBody s hs0 = toHeaderTable hs0 >>= responseNoBody' s
78+
79+ responseNoBody' s tbl = do
77 logger req s Nothing
80 logger req s Nothing
78 setThreadContinue tconf True
81 setThreadContinue tconf True
79− let rspn = RspnNobody s hs
82+ let rspn = RspnNobody s tbl
80 out = ORspn strm rspn ii
83 out = ORspn strm rspn ii
81 enqueueOutput outputQ out
84 enqueueOutput outputQ out
82 return ResponseReceived
85 return ResponseReceived
83
86
84− responseBuilderBody s hs bdy = do
87+ responseBuilderBody s hs0 bdy = do
85 logger req s Nothing
88 logger req s Nothing
86 setThreadContinue tconf True
89 setThreadContinue tconf True
90+ tbl <- toHeaderTable hs0
87− let rspn = RspnBuilder s hs bdy
91+ let rspn = RspnBuilder s tbl bdy
88 out = ORspn strm rspn ii
92 out = ORspn strm rspn ii
89 enqueueOutput outputQ out
93 enqueueOutput outputQ out
90 return ResponseReceived
94 return ResponseReceived
@@ -93,20 +97,24 @@ response settings Context{outputQ} mgr ii tconf strm req rsp = case rsp of
93 efinfo <- E.try $ getFileInfo ii path
97 efinfo <- E.try $ getFileInfo ii path
94 case efinfo of
98 case efinfo of
95 Left (_ex :: E.IOException) -> response404 hs0
99 Left (_ex :: E.IOException) -> response404 hs0
100+ Right finfo -> do
101+ (rspths0,vt) <- toHeaderTable hs0
96− Right finfo -> case conditionalRequest finfo hs0 (indexRequestHeader (requestHeaders req)) of
102+ case conditionalRequest finfo rspths0 reqvt of
97− WithoutBody s -> responseNoBody s hs0
103+ WithoutBody s -> responseNoBody s hs0
98− WithBody s hs beg len -> responseFile2XX s hs path (Just (FilePart beg len (fileInfoSize finfo)))
104+ WithBody s rspths beg len -> responseFile2XX s (rspths,vt) path (Just (FilePart beg len (fileInfoSize finfo)))
99
105
100− responseFileXXX s0 hs0 path mpart = responseFile2XX s0 hs0 path mpart
106+ responseFileXXX s0 hs0 path mpart = do
107+ tbl <- toHeaderTable hs0
108+ responseFile2XX s0 tbl path mpart
101
109
102− responseFile2XX s hs path mpart
110+ responseFile2XX s tbl path mpart
103 | isHead = do
111 | isHead = do
104 logger req s Nothing
112 logger req s Nothing
105− responseNoBody s hs
113+ responseNoBody' s tbl
106 | otherwise = do
114 | otherwise = do
107 logger req s (filePartByteCount <$> mpart)
115 logger req s (filePartByteCount <$> mpart)
108 setThreadContinue tconf True
116 setThreadContinue tconf True
109− let rspn = RspnFile s hs path mpart
117+ let rspn = RspnFile s tbl path mpart
110 out = ORspn strm rspn ii
118 out = ORspn strm rspn ii
111 enqueueOutput outputQ out
119 enqueueOutput outputQ out
112 return ResponseReceived
120 return ResponseReceived
@@ -131,7 +139,8 @@ response settings Context{outputQ} mgr ii tconf strm req rsp = case rsp of
131 -- Since 'StreamingBody' is loop, we cannot control it.
139 -- Since 'StreamingBody' is loop, we cannot control it.
132 -- So, let's serialize 'Builder' with a designated queue.
140 -- So, let's serialize 'Builder' with a designated queue.
133 tbq <- newTBQueueIO 10 -- fixme: hard coding: 10
141 tbq <- newTBQueueIO 10 -- fixme: hard coding: 10
142+ tbl <- toHeaderTable hs0
134− let rspn = RspnStreaming s0 hs0 tbq
143+ let rspn = RspnStreaming s0 tbl tbq
135 out = ORspn strm rspn ii
144 out = ORspn strm rspn ii
136 enqueueOutput outputQ out
145 enqueueOutput outputQ out
137 let push b = do
146 let push b = do
@@ -153,11 +162,11 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do
153 setThreadContinue tcont True
162 setThreadContinue tcont True
154 ex <- E.try $ do
163 ex <- E.try $ do
155 T.pause th
164 T.pause th
156− inp@(Input strm req ii) <- atomically $ readTQueue inputQ
165+ inp@(Input strm req reqvt ii) <- atomically $ readTQueue inputQ
157 setStreamInfo sinfo inp
166 setStreamInfo sinfo inp
158 T.resume th
167 T.resume th
159 T.tickle th
168 T.tickle th
160− app req $ responder ii tcont strm req
169+ app req $ responder ii reqvt tcont strm req
161 cont1 <- case ex of
170 cont1 <- case ex of
162 Right ResponseReceived -> return True
171 Right ResponseReceived -> return True
163 Left e@(SomeException _)
172 Left e@(SomeException _)
@@ -177,7 +186,7 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do
177 minp <- getStreamInfo sinfo
186 minp <- getStreamInfo sinfo
178 case minp of
187 case minp of
179 Nothing -> return ()
188 Nothing -> return ()
180− Just (Input strm req _ii) -> do
189+ Just (Input strm req _reqvt _ii) -> do
181 closed ctx strm Killed
190 closed ctx strm Killed
182 let frame = resetFrame InternalError (streamNumber strm)
191 let frame = resetFrame InternalError (streamNumber strm)
183 enqueueControl controlQ $ CFrame frame
192 enqueueControl controlQ $ CFrame frame
@@ -196,12 +205,15 @@ worker ctx@Context{inputQ,controlQ} set app responder tm = do
196-- Otherwise, the worker get finished.
205-- Otherwise, the worker get finished.
197newtype ThreadContinue = ThreadContinue (IORef Bool)
206newtype ThreadContinue = ThreadContinue (IORef Bool)
198
207
208+{-# INLINE newThreadContinue #-}
199newThreadContinue :: IO ThreadContinue
209newThreadContinue :: IO ThreadContinue
200newThreadContinue = ThreadContinue <$> newIORef True
210newThreadContinue = ThreadContinue <$> newIORef True
201
211
212+{-# INLINE setThreadContinue #-}
202setThreadContinue :: ThreadContinue -> Bool -> IO ()
213setThreadContinue :: ThreadContinue -> Bool -> IO ()
203setThreadContinue (ThreadContinue ref) x = writeIORef ref x
214setThreadContinue (ThreadContinue ref) x = writeIORef ref x
204
215
216+{-# INLINE getThreadContinue #-}
205getThreadContinue :: ThreadContinue -> IO Bool
217getThreadContinue :: ThreadContinue -> IO Bool
206getThreadContinue (ThreadContinue ref) = readIORef ref
218getThreadContinue (ThreadContinue ref) = readIORef ref
207
219
@@ -210,14 +222,18 @@ getThreadContinue (ThreadContinue ref) = readIORef ref
210-- | The type to store enough information for 'settingsOnException'.
222-- | The type to store enough information for 'settingsOnException'.
211newtype StreamInfo = StreamInfo (IORef (Maybe Input))
223newtype StreamInfo = StreamInfo (IORef (Maybe Input))
212
224
225+{-# INLINE newStreamInfo #-}
213newStreamInfo :: IO StreamInfo
226newStreamInfo :: IO StreamInfo
214newStreamInfo = StreamInfo <$> newIORef Nothing
227newStreamInfo = StreamInfo <$> newIORef Nothing
215
228
229+{-# INLINE clearStreamInfo #-}
216clearStreamInfo :: StreamInfo -> IO ()
230clearStreamInfo :: StreamInfo -> IO ()
217clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing
231clearStreamInfo (StreamInfo ref) = writeIORef ref Nothing
218
232
233+{-# INLINE setStreamInfo #-}
219setStreamInfo :: StreamInfo -> Input -> IO ()
234setStreamInfo :: StreamInfo -> Input -> IO ()
220setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp
235setStreamInfo (StreamInfo ref) inp = writeIORef ref $ Just inp
221
236
237+{-# INLINE getStreamInfo #-}
222getStreamInfo :: StreamInfo -> IO (Maybe Input)
238getStreamInfo :: StreamInfo -> IO (Maybe Input)
223getStreamInfo (StreamInfo ref) = readIORef ref
239getStreamInfo (StreamInfo ref) = readIORef ref
warp/Network/Wai/Handler/Warp/HashMap.hs+3
@@ -6,6 +6,7 @@ import Data.IntMap.Strict (IntMap)
6import qualified Data.IntMap.Strict as I
6import qualified Data.IntMap.Strict as I
7import Data.Map.Strict (Map)
7import Data.Map.Strict (Map)
8import qualified Data.Map.Strict as M
8import qualified Data.Map.Strict as M
9+import Prelude hiding (lookup)
9
10
10type Hash = Int
11type Hash = Int
11newtype HashMap k v = HashMap (IntMap (Map k v))
12newtype HashMap k v = HashMap (IntMap (Map k v))
@@ -24,6 +25,8 @@ insert h k v (HashMap hm) = HashMap $ I.insertWith f h m hm
24 where
25 where
25 m = M.singleton k v
26 m = M.singleton k v
26 f = M.union -- fimxe
27 f = M.union -- fimxe
28+{-# SPECIALIZE insert :: Hash -> String -> v -> HashMap String v -> HashMap String v #-}
27
29
28lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v
30lookup :: Ord k => Hash -> k -> HashMap k v -> Maybe v
29lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k
31lookup h k (HashMap hm) = I.lookup h hm >>= M.lookup k
32+{-# SPECIALIZE lookup :: Hash -> String -> HashMap String v -> Maybe v #-}
warp/Network/Wai/Handler/Warp/PackInt.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Network.Wai.Handler.Warp.PackInt where
4+
5+import Control.Monad (when)
6+import Data.ByteString.Internal (ByteString(..), unsafeCreate)
7+import Data.Word8 (Word8)
8+import Foreign.Ptr (Ptr, plusPtr)
9+import Foreign.Storable (poke)
10+
11+-- |
12+--
13+-- prop> packIntegral (abs n) == B.pack (show (abs n))
14+-- prop> \(Large n) -> let n' = fromIntegral (abs n :: Int) in packIntegral n' == B.pack (show n')
15+
16+packIntegral :: Integral a => a -> ByteString
17+packIntegral 0 = "0"
18+packIntegral n | n < 0 = error "packIntegral"
19+packIntegral n = unsafeCreate len go0
20+ where
21+ n' = fromIntegral n + 1 :: Double
22+ len = ceiling $ logBase 10 n'
23+ go0 p = go n $ p `plusPtr` (len - 1)
24+ go :: Integral a => a -> Ptr Word8 -> IO ()
25+ go i p = do
26+ let (d,r) = i `divMod` 10
27+ poke p (48 + fromIntegral r)
28+ when (d /= 0) $ go d (p `plusPtr` (-1))
29+
30+{-# SPECIALIZE packIntegral :: Int -> ByteString #-}
31+{-# SPECIALIZE packIntegral :: Integer -> ByteString #-}
warp/warp.cabal+2
@@ -72,6 +72,7 @@ Library
72 Network.Wai.Handler.Warp.HashMap
72 Network.Wai.Handler.Warp.HashMap
73 Network.Wai.Handler.Warp.HTTP2
73 Network.Wai.Handler.Warp.HTTP2
74 Network.Wai.Handler.Warp.HTTP2.EncodeFrame
74 Network.Wai.Handler.Warp.HTTP2.EncodeFrame
75+ Network.Wai.Handler.Warp.HTTP2.File
75 Network.Wai.Handler.Warp.HTTP2.HPACK
76 Network.Wai.Handler.Warp.HTTP2.HPACK
76 Network.Wai.Handler.Warp.HTTP2.Manager
77 Network.Wai.Handler.Warp.HTTP2.Manager
77 Network.Wai.Handler.Warp.HTTP2.Receiver
78 Network.Wai.Handler.Warp.HTTP2.Receiver
@@ -82,6 +83,7 @@ Library
82 Network.Wai.Handler.Warp.Header
83 Network.Wai.Handler.Warp.Header
83 Network.Wai.Handler.Warp.IO
84 Network.Wai.Handler.Warp.IO
84 Network.Wai.Handler.Warp.IORef
85 Network.Wai.Handler.Warp.IORef
86+ Network.Wai.Handler.Warp.PackInt
85 Network.Wai.Handler.Warp.ReadInt
87 Network.Wai.Handler.Warp.ReadInt
86 Network.Wai.Handler.Warp.Recv
88 Network.Wai.Handler.Warp.Recv
87 Network.Wai.Handler.Warp.Request
89 Network.Wai.Handler.Warp.Request