@@ -5,6 +5,7 @@ module Network.Wai.Handler.Warp.HTTP2.HPACK where
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
8import Data.ByteString.Builder (Builder)
9import Data.ByteString.Builder (Builder)
9import qualified Data.ByteString.Char8 as B8
10import qualified Data.ByteString.Char8 as B8
10import Data.CaseInsensitive (foldedCase)
11import Data.CaseInsensitive (foldedCase)
@@ -19,23 +20,35 @@ import Network.Wai.Handler.Warp.Response
19import qualified Network.Wai.Handler.Warp.Settings as S
20import qualified Network.Wai.Handler.Warp.Settings as S
20import Network.Wai.Handler.Warp.Types
21import Network.Wai.Handler.Warp.Types
24+-- >>> :set -XOverloadedStrings
26+-- Set-Cookie: contains only one cookie value.
27+-- So, we don't need to split it.
22hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> Response
28hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> Response
23 -> IO Builder
29 -> IO Builder
24−hpackEncodeHeader Context{encodeDynamicTable} ii settings rsp = do
30+hpackEncodeHeader ctx ii settings rsp = do
25− hdr1 <- addServerAndDate hdr0
31+ hdr1 <- addServerAndDate h
26 let hdr2 = (":status", status) : map (first foldedCase) hdr1
32 let hdr2 = (":status", status) : map (first foldedCase) hdr1
27− ehdrtbl <- readIORef encodeDynamicTable
33+ hpackEncodeRawHeaders ctx hdr2
28− (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr2
29− writeIORef encodeDynamicTable ehdrtbl'
35+ s = responseStatus rsp
32− hdr0 = responseHeaders rsp
36+ h = responseHeaders rsp
33− status = B8.pack $ show $ H.statusCode $ responseStatus rsp
37+ status = B8.pack $ show $ H.statusCode $ s
34 dc = dateCacher ii
38 dc = dateCacher ii
35− rspidxhdr = indexResponseHeader hdr0
39+ rspidxhdr = indexResponseHeader h
36 defServer = S.settingsServerName settings
40 defServer = S.settingsServerName settings
37 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
41 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
43+hpackEncodeCIHeaders :: Context -> [H.Header] -> IO Builder
44+hpackEncodeCIHeaders ctx = hpackEncodeRawHeaders ctx . map (first foldedCase)
46+hpackEncodeRawHeaders :: Context -> [(B.ByteString, B.ByteString)] -> IO Builder
47+hpackEncodeRawHeaders Context{encodeDynamicTable} hdr = do
48+ ehdrtbl <- readIORef encodeDynamicTable
49+ (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr
50+ writeIORef encodeDynamicTable ehdrtbl'
40----------------------------------------------------------------
53----------------------------------------------------------------
@@ -44,6 +57,20 @@ hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do
44 hdrtbl <- readIORef decodeDynamicTable
57 hdrtbl <- readIORef decodeDynamicTable
45 (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup
58 (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup
46 writeIORef decodeDynamicTable hdrtbl'
59 writeIORef decodeDynamicTable hdrtbl'
47− return hdr
60+ return $ concatCookie hdr
49 cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
62 cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
66+-- >>> concatCookie [("foo","bar")]
68+-- >>> concatCookie [("cookie","a=b"),("foo","bar"),("cookie","c=d"),("cookie","e=f")]
69+-- [("foo","bar"),("cookie","a=b; c=d; e=f")]
70+concatCookie :: HeaderList -> HeaderList
71+concatCookie = collect []
73+ collect cookies (("cookie",c):rest) = collect (cookies ++ [c]) rest
74+ collect cookies (h:rest) = h : collect cookies rest
76+ collect cookies [] = [("cookie", B.intercalate "; " cookies)]