git.iko.soy/typeable/wai
on master help sign in
supporting new HPACK implementation.
commit5635fe084c3eca46a2467ac25002ae1d4afb8bf6 authorKazu Yamamoto <kazu@iij.ad.jp> dateWed 10 Feb 2016, 14:02 (11 years ago) parent3f4ca58
3 files changed+34−58
compare with master
unifiedsplit
warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hs+16−26 warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+13−27 warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+5−5
warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hs+16−26
@@ -1,16 +1,13 @@
11{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE NamedFieldPuns #-}
2+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
33
44module Network.Wai.Handler.Warp.HTTP2.HPACK where
55
66import Control.Arrow (first)
77import qualified Control.Exception as E
8−import qualified Data.ByteString as B
9−import Data.ByteString.Builder (Builder)
108import qualified Data.ByteString.Char8 as B8
119import Data.CaseInsensitive (foldedCase)
12−import Data.IORef (readIORef, writeIORef)
13−import Network.HPACK
10+import Network.HPACK hiding (Buffer)
1411import qualified Network.HTTP.Types as H
1512import Network.HTTP2
1613import Network.Wai.Handler.Warp.HTTP2.Types
@@ -24,37 +21,30 @@ import Network.Wai.Handler.Warp.Types
2421
2522-- Set-Cookie: contains only one cookie value.
2623-- So, we don't need to split it.
27−hpackEncodeHeader :: Context -> InternalInfo -> S.Settings
24+hpackEncodeHeader :: Context -> Buffer -> BufSize
25+ -> InternalInfo -> S.Settings
2826 -> H.Status -> H.ResponseHeaders
29− -> IO Builder
30−hpackEncodeHeader ctx ii settings s h = do
31− hdr1 <- addServerAndDate h
32− let hdr2 = (":status", status) : map (first foldedCase) hdr1
33− hpackEncodeRawHeaders ctx hdr2
27+ -> IO (HeaderList, Int)
28+hpackEncodeHeader Context{..} buf siz ii settings s hdr0 = do
29+ hdr1 <- addServerAndDate hdr0
30+ let hs = (":status", status) : map (first foldedCase) hdr1
31+ encodeHeaderBuffer buf siz defaultEncodeStrategy True encodeDynamicTable hs
3432 where
3533 status = B8.pack $ show $ H.statusCode s
3634 dc = dateCacher ii
37− rspidxhdr = indexResponseHeader h
35+ rspidxhdr = indexResponseHeader hdr0
3836 defServer = S.settingsServerName settings
3937 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
4038
41−hpackEncodeCIHeaders :: Context -> [H.Header] -> IO Builder
42−hpackEncodeCIHeaders ctx = hpackEncodeRawHeaders ctx . map (first foldedCase)
43−
44−hpackEncodeRawHeaders :: Context -> [(B.ByteString, B.ByteString)] -> IO Builder
45−hpackEncodeRawHeaders Context{encodeDynamicTable} hdr = do
46− ehdrtbl <- readIORef encodeDynamicTable
47− (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr
48− writeIORef encodeDynamicTable ehdrtbl'
49− return builder
39+hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> HeaderList
40+ -> IO (HeaderList, Int)
41+hpackEncodeHeaderLoop Context{..} buf siz hs =
42+ encodeHeaderBuffer buf siz defaultEncodeStrategy False encodeDynamicTable hs
5043
5144----------------------------------------------------------------
5245
5346hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderList
54−hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do
55− hdrtbl <- readIORef decodeDynamicTable
56− (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup
57− writeIORef decodeDynamicTable hdrtbl'
58− return hdr
47+hpackDecodeHeader hdrblk Context{..} =
48+ decodeHeader decodeDynamicTable hdrblk `E.onException` cleanup
5949 where
6050 cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+13−27
@@ -105,9 +105,7 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
105105 connSendAll frame
106106 case lookup SettingsHeaderTableSize alist of
107107 Nothing -> return ()
108− Just siz -> do
109− dyntbl <- readIORef encodeDynamicTable
110− setLimitForEncoding siz dyntbl
108+ Just siz -> setLimitForEncoding siz encodeDynamicTable
111109 return True
112110
113111 output (ONext strm curr mtbq) off0 lim = do
@@ -195,43 +193,31 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
195193 headerContinue sid rspn endOfStream off = do
196194 let !s = rspnStatus rspn
197195 !h = rspnHeaders rspn
198− builder <- hpackEncodeHeader ctx ii settings s h
199196 let !offkv = off + frameHeaderLength
200197 let !bufkv = connWriteBuffer `plusPtr` offkv
201198 !limkv = connBufferSize - offkv
202− (kvlen, signal) <- B.runBuilder builder bufkv limkv
203− let flag0 = case signal of
204− B.Done -> setEndHeader defaultFlags
205− _ -> defaultFlags
199+ (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ii settings s h
200+ let flag0 = case hs of
201+ [] -> setEndHeader defaultFlags
202+ _ -> defaultFlags
206203 flag = if endOfStream then setEndStream flag0 else flag0
207204 let buf = connWriteBuffer `plusPtr` off
208205 fillFrameHeader FrameHeaders kvlen sid flag buf
209− continue sid kvlen signal
206+ continue sid kvlen hs
210207
211208 bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
212209 headerPayloadLim = connBufferSize - frameHeaderLength
213210
214− continue _ kvlen B.Done = return kvlen
215− continue sid kvlen (B.More _ writer) = do
211+ continue _ kvlen [] = return kvlen
212+ continue sid kvlen hs = do
216213 flushN $ kvlen + frameHeaderLength
217214 -- Now off is 0
218− (kvlen', signal') <- writer bufHeaderPayload headerPayloadLim
219− let flag = case signal' of
220− B.Done -> setEndHeader defaultFlags
221− _ -> defaultFlags
215+ (hs', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim hs
216+ let flag = case hs' of
217+ [] -> setEndHeader defaultFlags
218+ _ -> defaultFlags
222219 fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer
223− continue sid kvlen' signal'
224− continue sid kvlen (B.Chunk bs writer) = do
225− flushN $ kvlen + frameHeaderLength
226− -- Now off is 0
227− let (bs1,bs2) = BS.splitAt headerPayloadLim bs
228− kvlen' = BS.length bs1
229− void $ copy bufHeaderPayload bs1
230− fillFrameHeader FrameContinuation kvlen' sid defaultFlags connWriteBuffer
231− if bs2 == "" then
232− continue sid kvlen' (B.More 0 writer)
233− else
234− continue sid kvlen' (B.Chunk bs2 writer)
220+ continue sid kvlen' hs'
235221
236222 -- Re-enqueue the stream in the output queue.
237223 maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence) -> Maybe DynaNext -> IO ()
warp/Network/Wai/Handler/Warp/HTTP2/Types.hs+5−5
@@ -24,7 +24,7 @@ import Network.Wai.Handler.Warp.Types
2424
2525import Network.HTTP2
2626import Network.HTTP2.Priority
27−import Network.HPACK
27+import Network.HPACK hiding (Buffer)
2828
2929----------------------------------------------------------------
3030
@@ -109,8 +109,8 @@ data Context = Context {
109109 , inputQ :: !(TQueue Input)
110110 , outputQ :: !(PriorityTree Output)
111111 , controlQ :: !(TQueue Control)
112− , encodeDynamicTable :: !(IORef DynamicTable)
113− , decodeDynamicTable :: !(IORef DynamicTable)
112+ , encodeDynamicTable :: !DynamicTable
113+ , decodeDynamicTable :: !DynamicTable
114114 , connectionWindow :: !(TVar WindowSize)
115115 }
116116
@@ -127,8 +127,8 @@ newContext = Context <$> newIORef defaultSettings
127127 <*> newTQueueIO
128128 <*> newPriorityTree
129129 <*> newTQueueIO
130− <*> (newDynamicTableForEncoding defaultDynamicTableSize >>= newIORef)
131− <*> (newDynamicTableForDecoding defaultDynamicTableSize >>= newIORef)
130+ <*> newDynamicTableForEncoding defaultDynamicTableSize
131+ <*> newDynamicTableForDecoding defaultDynamicTableSize 4096
132132 <*> newTVarIO defaultInitialWindowSize
133133
134134clearContext :: Context -> IO ()