@@ -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
@@ -22,39 +19,34 @@ import Network.Wai.Handler.Warp.Types
2219-- $setup
2320-- >>> :set -XOverloadedStrings
2421
22+strategy :: EncodeStrategy
23+strategy = EncodeStrategy { compressionAlgo = Linear, useHuffman = False }
24+
2525-- Set-Cookie: contains only one cookie value.
2626-- So, we don't need to split it.
27−hpackEncodeHeader :: Context -> InternalInfo -> S.Settings
27+hpackEncodeHeader :: Context -> Buffer -> BufSize
28+ -> InternalInfo -> S.Settings
2829 -> 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
30+ -> IO (HeaderList, Int)
31+hpackEncodeHeader Context{..} buf siz ii settings s hdr0 = do
32+ hdr1 <- addServerAndDate hdr0
33+ let hs = (":status", status) : map (first foldedCase) hdr1
34+ encodeHeaderBuffer buf siz strategy True encodeDynamicTable hs
3435 where
3536 status = B8.pack $ show $ H.statusCode s
3637 dc = dateCacher ii
37− rspidxhdr = indexResponseHeader h
38+ rspidxhdr = indexResponseHeader hdr0
3839 defServer = S.settingsServerName settings
3940 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
4041
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
42+hpackEncodeHeaderLoop :: Context -> Buffer -> BufSize -> HeaderList
43+ -> IO (HeaderList, Int)
44+hpackEncodeHeaderLoop Context{..} buf siz hs =
45+ encodeHeaderBuffer buf siz strategy False encodeDynamicTable hs
5046
5147----------------------------------------------------------------
5248
5349hpackDecodeHeader :: 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
59− where
60− cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
50+hpackDecodeHeader hdrblk Context{..} =
51+ decodeHeader decodeDynamicTable hdrblk `E.catch` \(E.SomeException _) ->
52+ E.throwIO $ ConnectionError CompressionError "cannot decompress the header"