1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.HTTP2.H2.HPACK (
hpackEncodeHeader,
hpackEncodeHeaderLoop,
hpackDecodeHeader,
hpackDecodeTrailer,
just,
fixHeaders,
) where
import qualified Control.Exception as E
import Network.ByteOrder
import qualified Network.HTTP.Types as H
import Imports
import Network.HPACK
import Network.HPACK.Token
import Network.HTTP2.Frame
import Network.HTTP2.H2.Context
import Network.HTTP2.H2.Types
-- $setup
-- >>> :set -XOverloadedStrings
----------------------------------------------------------------
fixHeaders :: H.ResponseHeaders -> H.ResponseHeaders
fixHeaders hdr = deleteUnnecessaryHeaders hdr
deleteUnnecessaryHeaders :: H.ResponseHeaders -> H.ResponseHeaders
deleteUnnecessaryHeaders hdr = filter del hdr
where
del (k, _) = k `notElem` headersToBeRemoved
headersToBeRemoved :: [H.HeaderName]
headersToBeRemoved =
[ H.hConnection
, "Transfer-Encoding"
-- Keep-Alive
-- Proxy-Connection
-- Upgrade
]
----------------------------------------------------------------
strategy :: EncodeStrategy
strategy = EncodeStrategy{compressionAlgo = Linear, useHuffman = False}
-- Set-Cookie: contains only one cookie value.
-- So, we don't need to split it.
hpackEncodeHeader
:: Context
-> Buffer
-> BufferSize
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
hpackEncodeHeader Context{..} buf siz ths =
encodeTokenHeader buf siz strategy True encodeDynamicTable ths
hpackEncodeHeaderLoop
:: Context
-> Buffer
-> BufferSize
-> TokenHeaderList
-> IO (TokenHeaderList, Int)
hpackEncodeHeaderLoop Context{..} buf siz hs =
encodeTokenHeader buf siz strategy False encodeDynamicTable hs
----------------------------------------------------------------
hpackDecodeHeader
:: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable
hpackDecodeHeader hdrblk sid ctx = do
tbl@(_, vt) <- hpackDecodeTrailer hdrblk sid ctx
if isClient ctx || checkRequestHeader vt
then return tbl
else E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal header"
hpackDecodeTrailer
:: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable
hpackDecodeTrailer hdrblk sid Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl
where
handl IllegalHeaderName =
E.throwIO $ StreamErrorIsSent ProtocolError sid "illegal trailer"
handl e = do
let msg = fromString $ show e
E.throwIO $ StreamErrorIsSent CompressionError sid msg
{-# INLINE checkRequestHeader #-}
checkRequestHeader :: ValueTable -> Bool
checkRequestHeader reqvt
| just mMethod (== "CONNECT") = isNothing mPath && isNothing mScheme
| isJust mStatus = False
| isNothing mMethod = False
| isNothing mScheme = False
| isNothing mPath = False
| mPath == Just "" = False
| isJust mConnection = False
| just mTE (/= "trailers") = False
| otherwise = checkAuth mAuthority mHost
where
mStatus = getHeaderValue tokenStatus reqvt
mScheme = getHeaderValue tokenScheme reqvt
mPath = getHeaderValue tokenPath reqvt
mMethod = getHeaderValue tokenMethod reqvt
mConnection = getHeaderValue tokenConnection reqvt
mTE = getHeaderValue tokenTE reqvt
mAuthority = getHeaderValue tokenAuthority reqvt
mHost = getHeaderValue tokenHost reqvt
checkAuth :: Maybe ByteString -> Maybe ByteString -> Bool
checkAuth Nothing Nothing = False
checkAuth (Just a) (Just h) | a /= h = False
checkAuth _ _ = True
{-# INLINE just #-}
just :: Maybe a -> (a -> Bool) -> Bool
just Nothing _ = False
just (Just x) p
| p x = True
| otherwise = False
|
