git.iko.soy/typeable/wai
on master help sign in
Merge branch 'new-hpack'
ea43ec0Kazu Yamamoto
warp/Network/Wai/Handler/Warp/HTTP2/HPACK.hs+20−28
compare with master
unifiedsplit
@@ -1,16 +1,13 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE NamedFieldPuns #-}
2+{-# LANGUAGE NamedFieldPuns, RecordWildCards #-}
3
3
4module Network.Wai.Handler.Warp.HTTP2.HPACK where
4module Network.Wai.Handler.Warp.HTTP2.HPACK where
5
5
6import Control.Arrow (first)
6import Control.Arrow (first)
7import qualified Control.Exception as E
7import qualified Control.Exception as E
8−import qualified Data.ByteString as B
9−import Data.ByteString.Builder (Builder)
10import qualified Data.ByteString.Char8 as B8
8import qualified Data.ByteString.Char8 as B8
11import Data.CaseInsensitive (foldedCase)
9import Data.CaseInsensitive (foldedCase)
12−import Data.IORef (readIORef, writeIORef)
10+import Network.HPACK hiding (Buffer)
13−import Network.HPACK
14import qualified Network.HTTP.Types as H
11import qualified Network.HTTP.Types as H
15import Network.HTTP2
12import Network.HTTP2
16import Network.Wai.Handler.Warp.HTTP2.Types
13import Network.Wai.Handler.Warp.HTTP2.Types
@@ -22,39 +19,34 @@ import Network.Wai.Handler.Warp.Types
22-- $setup
19-- $setup
23-- >>> :set -XOverloadedStrings
20-- >>> :set -XOverloadedStrings
24
21
22+strategy :: EncodeStrategy
23+strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }
24+
25-- Set-Cookie: contains only one cookie value.
25-- Set-Cookie: contains only one cookie value.
26-- So, we don't need to split it.
26-- So, we don't need to split it.
27+hpackEncodeHeader :: Context -> Buffer -> BufSize
27−hpackEncodeHeader :: Context -> InternalInfo -> S.Settings
28+ -> InternalInfo -> S.Settings
28 -> H.Status -> H.ResponseHeaders
29 -> H.Status -> H.ResponseHeaders
29− -> IO Builder
30+ -> IO (HeaderList, Int)
30−hpackEncodeHeader ctx ii settings s h = do
31+hpackEncodeHeader Context{..} buf siz ii settings s hdr0 = do
31− hdr1 <- addServerAndDate h
32+ hdr1 <- addServerAndDate hdr0
32− let hdr2 = (":status", status) : map (first foldedCase) hdr1
33+ let hs = (":status", status) : map (first foldedCase) hdr1
33− hpackEncodeRawHeaders ctx hdr2
34+ encodeHeaderBuffer buf siz strategy True encodeDynamicTable hs
34 where
35 where
35 status = B8.pack $ show $ H.statusCode s
36 status = B8.pack $ show $ H.statusCode s
36 dc = dateCacher ii
37 dc = dateCacher ii
37− rspidxhdr = indexResponseHeader h
38+ rspidxhdr = indexResponseHeader hdr0
38 defServer = S.settingsServerName settings
39 defServer = S.settingsServerName settings
39 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
40 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
40
41
41−hpackEncodeCIHeaders :: Context -> [H.Header] -> IO Builder
42+hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> HeaderList
42−hpackEncodeCIHeaders ctx = hpackEncodeRawHeaders ctx . map (first foldedCase)
43+ -> IO (HeaderList, Int)
43−
44+hpackEncodeHeaderLoop Context{..} buf siz hs =
44−hpackEncodeRawHeaders :: Context -> [(B.ByteString, B.ByteString)] -> IO Builder
45+ encodeHeaderBuffer buf siz strategy False encodeDynamicTable hs
45−hpackEncodeRawHeaders Context{encodeDynamicTable} hdr = do
46− ehdrtbl <- readIORef encodeDynamicTable
47− (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr
48− writeIORef encodeDynamicTable ehdrtbl'
49− return builder
50
46
51----------------------------------------------------------------
47----------------------------------------------------------------
52
48
53hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderList
49hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderList
54−hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do
50+hpackDecodeHeader hdrblk Context{..} =
55− hdrtbl <- readIORef decodeDynamicTable
51+ decodeHeader decodeDynamicTable hdrblk `E.catch` \(E.SomeException _) ->
56− (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup
57− writeIORef decodeDynamicTable hdrtbl'
58− return hdr
59− where
60− cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
52+ E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
warp/Network/Wai/Handler/Warp/HTTP2/Sender.hs+14−27
@@ -105,9 +105,7 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
105 connSendAll frame
105 connSendAll frame
106 case lookup SettingsHeaderTableSize alist of
106 case lookup SettingsHeaderTableSize alist of
107 Nothing -> return ()
107 Nothing -> return ()
108− Just siz -> do
109− dyntbl <- readIORef encodeDynamicTable
108+ Just siz -> setLimitForEncoding siz encodeDynamicTable
110− setLimitForEncoding siz dyntbl
111 return True
109 return True
112
110
113 output (ONext strm curr mtbq) off0 lim = do
111 output (ONext strm curr mtbq) off0 lim = do
@@ -195,43 +193,32 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable}
195 headerContinue sid rspn endOfStream off = do
193 headerContinue sid rspn endOfStream off = do
196 let !s = rspnStatus rspn
194 let !s = rspnStatus rspn
197 !h = rspnHeaders rspn
195 !h = rspnHeaders rspn
198− builder <- hpackEncodeHeader ctx ii settings s h
199 let !offkv = off + frameHeaderLength
196 let !offkv = off + frameHeaderLength
200 let !bufkv = connWriteBuffer `plusPtr` offkv
197 let !bufkv = connWriteBuffer `plusPtr` offkv
201 !limkv = connBufferSize - offkv
198 !limkv = connBufferSize - offkv
202− (kvlen, signal) <- B.runBuilder builder bufkv limkv
199+ (hs,kvlen) <- hpackEncodeHeader ctx bufkv limkv ii settings s h
203− let flag0 = case signal of
200+ let flag0 = case hs of
204− B.Done -> setEndHeader defaultFlags
201+ [] -> setEndHeader defaultFlags
205− _ -> defaultFlags
202+ _ -> defaultFlags
206 flag = if endOfStream then setEndStream flag0 else flag0
203 flag = if endOfStream then setEndStream flag0 else flag0
207 let buf = connWriteBuffer `plusPtr` off
204 let buf = connWriteBuffer `plusPtr` off
208 fillFrameHeader FrameHeaders kvlen sid flag buf
205 fillFrameHeader FrameHeaders kvlen sid flag buf
209− continue sid kvlen signal
206+ continue sid kvlen hs
210
207
211 bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
208 bufHeaderPayload = connWriteBuffer `plusPtr` frameHeaderLength
212 headerPayloadLim = connBufferSize - frameHeaderLength
209 headerPayloadLim = connBufferSize - frameHeaderLength
213
210
214− continue _ kvlen B.Done = return kvlen
211+ continue _ kvlen [] = return kvlen
215− continue sid kvlen (B.More _ writer) = do
212+ continue sid kvlen hs = do
216 flushN $ kvlen + frameHeaderLength
213 flushN $ kvlen + frameHeaderLength
217 -- Now off is 0
214 -- Now off is 0
218− (kvlen', signal') <- writer bufHeaderPayload headerPayloadLim
215+ (hs', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim hs
216+ when (hs == hs') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"
219− let flag = case signal' of
217+ let flag = case hs' of
220− B.Done -> setEndHeader defaultFlags
218+ [] -> setEndHeader defaultFlags
221− _ -> defaultFlags
219+ _ -> defaultFlags
222 fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer
220 fillFrameHeader FrameContinuation kvlen' sid flag connWriteBuffer
223− continue sid kvlen' signal'
221+ continue sid kvlen' hs'
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)
235
222
236 -- Re-enqueue the stream in the output queue.
223 -- Re-enqueue the stream in the output queue.
237 maybeEnqueueNext :: Stream -> Maybe (TBQueue Sequence) -> Maybe DynaNext -> IO ()
224 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
24
24
25import Network.HTTP2
25import Network.HTTP2
26import Network.HTTP2.Priority
26import Network.HTTP2.Priority
27−import Network.HPACK
27+import Network.HPACK hiding (Buffer)
28
28
29----------------------------------------------------------------
29----------------------------------------------------------------
30
30
@@ -109,8 +109,8 @@ data Context = Context {
109 , inputQ :: !(TQueue Input)
109 , inputQ :: !(TQueue Input)
110 , outputQ :: !(PriorityTree Output)
110 , outputQ :: !(PriorityTree Output)
111 , controlQ :: !(TQueue Control)
111 , controlQ :: !(TQueue Control)
112− , encodeDynamicTable :: !(IORef DynamicTable)
112+ , encodeDynamicTable :: !DynamicTable
113− , decodeDynamicTable :: !(IORef DynamicTable)
113+ , decodeDynamicTable :: !DynamicTable
114 , connectionWindow :: !(TVar WindowSize)
114 , connectionWindow :: !(TVar WindowSize)
115 }
115 }
116
116
@@ -127,8 +127,8 @@ newContext = Context <$> newIORef defaultSettings
127 <*> newTQueueIO
127 <*> newTQueueIO
128 <*> newPriorityTree
128 <*> newPriorityTree
129 <*> newTQueueIO
129 <*> newTQueueIO
130− <*> (newDynamicTableForEncoding defaultDynamicTableSize >>= newIORef)
130+ <*> newDynamicTableForEncoding defaultDynamicTableSize
131− <*> (newDynamicTableForDecoding defaultDynamicTableSize >>= newIORef)
131+ <*> newDynamicTableForDecoding defaultDynamicTableSize 4096
132 <*> newTVarIO defaultInitialWindowSize
132 <*> newTVarIO defaultInitialWindowSize
133
133
134clearContext :: Context -> IO ()
134clearContext :: Context -> IO ()
warp/warp.cabal+2−2
@@ -43,7 +43,7 @@ Library
43 , ghc-prim
43 , ghc-prim
44 , http-types >= 0.8.5
44 , http-types >= 0.8.5
45 , iproute >= 1.3.1
45 , iproute >= 1.3.1
46− , http2 >= 1.4 && < 1.5
46+ , http2 >= 1.5 && < 1.6
47 , simple-sendfile >= 0.2.7 && < 0.3
47 , simple-sendfile >= 0.2.7 && < 0.3
48 , unix-compat >= 0.2
48 , unix-compat >= 0.2
49 , wai >= 3.2 && < 3.3
49 , wai >= 3.2 && < 3.3
@@ -163,7 +163,7 @@ Test-Suite spec
163 , directory
163 , directory
164 , process
164 , process
165 , containers
165 , containers
166− , http2 >= 1.4 && < 1.5
166+ , http2 >= 1.5 && < 1.6
167 , word8
167 , word8
168 , hashable
168 , hashable
169 , http-date
169 , http-date