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 Network.HTTP.Semantics
import Network.HTTP.Types
import Imports
import Network.HPACK
import Network.HTTP2.Frame
import Network.HTTP2.H2.Context
import Network.HTTP2.H2.Types
-- $setup
-- >>> :set -XOverloadedStrings
----------------------------------------------------------------
fixHeaders :: ResponseHeaders -> ResponseHeaders
fixHeaders hdr = deleteUnnecessaryHeaders hdr
deleteUnnecessaryHeaders :: ResponseHeaders -> ResponseHeaders
deleteUnnecessaryHeaders hdr = filter del hdr
where
del (k, _) = k `notElem` headersToBeRemoved
headersToBeRemoved :: [HeaderName]
headersToBeRemoved =
[ 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 TokenHeaderTable
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 TokenHeaderTable
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 = getFieldValue tokenStatus reqvt
mScheme = getFieldValue tokenScheme reqvt
mPath = getFieldValue tokenPath reqvt
mMethod = getFieldValue tokenMethod reqvt
mConnection = getFieldValue tokenConnection reqvt
mTE = getFieldValue tokenTE reqvt
mAuthority = getFieldValue tokenAuthority reqvt
mHost = getFieldValue 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
|
