@@ -5,6 +5,7 @@ module 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
89import Data.ByteString.Builder (Builder)
910import qualified Data.ByteString.Char8 as B8
1011import Data.CaseInsensitive (foldedCase)
@@ -19,23 +20,35 @@ import Network.Wai.Handler.Warp.Response
1920import qualified Network.Wai.Handler.Warp.Settings as S
2021import Network.Wai.Handler.Warp.Types
2122
23+-- $setup
24+-- >>> :set -XOverloadedStrings
25+
26+-- Set-Cookie: contains only one cookie value.
27+-- So, we don't need to split it.
2228hpackEncodeHeader :: Context -> InternalInfo -> S.Settings -> Response
2329 -> IO Builder
24−hpackEncodeHeader Context{encodeDynamicTable} ii settings rsp = do
25− hdr1 <- addServerAndDate hdr0
30+hpackEncodeHeader ctx ii settings rsp = do
31+ hdr1 <- addServerAndDate h
2632 let hdr2 = (":status", status) : map (first foldedCase) hdr1
27− ehdrtbl <- readIORef encodeDynamicTable
28− (ehdrtbl', builder) <- encodeHeaderBuilder defaultEncodeStrategy ehdrtbl hdr2
29− writeIORef encodeDynamicTable ehdrtbl'
30− return builder
33+ hpackEncodeRawHeaders ctx hdr2
3134 where
32− hdr0 = responseHeaders rsp
33− status = B8.pack $ show $ H.statusCode $ responseStatus rsp
35+ s = responseStatus rsp
36+ h = responseHeaders rsp
37+ status = B8.pack $ show $ H.statusCode $ s
3438 dc = dateCacher ii
35− rspidxhdr = indexResponseHeader hdr0
39+ rspidxhdr = indexResponseHeader h
3640 defServer = S.settingsServerName settings
3741 addServerAndDate = addDate dc rspidxhdr . addServer defServer rspidxhdr
3842
43+hpackEncodeCIHeaders :: Context -> [H.Header] -> IO Builder
44+hpackEncodeCIHeaders ctx = hpackEncodeRawHeaders ctx . map (first foldedCase)
45+
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'
51+ return builder
3952
4053----------------------------------------------------------------
4154
@@ -44,6 +57,20 @@ hpackDecodeHeader hdrblk Context{decodeDynamicTable} = do
4457 hdrtbl <- readIORef decodeDynamicTable
4558 (hdrtbl', hdr) <- decodeHeader hdrtbl hdrblk `E.onException` cleanup
4659 writeIORef decodeDynamicTable hdrtbl'
47− return hdr
60+ return $ concatCookie hdr
4861 where
4962 cleanup = E.throwIO $ ConnectionError CompressionError "cannot decompress the header"
63+
64+-- |
65+--
66+-- >>> concatCookie [("foo","bar")]
67+-- [("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 []
72+ where
73+ collect cookies (("cookie",c):rest) = collect (cookies ++ [c]) rest
74+ collect cookies (h:rest) = h : collect cookies rest
75+ collect [] [] = []
76+ collect cookies [] = [("cookie", B.intercalate "; " cookies)]