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
|
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module HPACKDecode (
run,
Result (..),
EncodeStrategy (..),
defaultEncodeStrategy,
CompressionAlgo (..),
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative ((<$>))
#endif
import Control.Exception
import Control.Monad (when)
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as B8
import Data.List (sort)
import Network.HPACK
import Network.HPACK.Table
import JSON
newtype Conf = Conf
{ debug :: Bool
}
data Result = Pass | Fail String deriving (Eq, Show)
run :: Bool -> Test -> IO Result
run _ (Test _ []) = return Pass
run d (Test _ ccs) = do
-- 'size c' must not be used. Initial value is defaultDynamicTableSize!
withDynamicTableForDecoding defaultDynamicTableSize 4096 $ \dyntbl -> do
let conf = Conf{debug = d}
testLoop conf ccs dyntbl
testLoop
:: Conf
-> [Case]
-> DynamicTable
-> IO Result
testLoop _ [] _ = return Pass
testLoop conf (c : cs) dyntbl = do
res <- test conf c dyntbl
case res of
Nothing -> testLoop conf cs dyntbl
Just e -> return $ Fail e
test
:: Conf
-> Case
-> DynamicTable
-> IO (Maybe String)
test conf c dyntbl = do
-- context is destructive!!!
when (debug conf) $ do
putStrLn "--------------------------------"
putStrLn "---- Input header list"
printHeaderList $ sort hs
putStrLn "---- Input header table"
printDynamicTable dyntbl
putStrLn "---- Input Hex"
B8.putStrLn wirehex
case size c of
Nothing -> return ()
Just siz -> renewDynamicTable siz dyntbl
x <- try $ decodeHeader dyntbl inp
case x of
Left e -> return $ Just $ show (e :: DecodeError)
Right hs' -> do
let pass = sort hs == sort hs'
if pass
then return Nothing
else
return $
Just $
"Headers are different in "
++ B8.unpack wirehex
++ ":\n"
++ show hs
++ "\n"
++ show hs'
where
wirehex = wire c
inp = B16.decodeLenient wirehex
hs = headers c
-- | Printing 'HeaderList'.
printHeaderList :: HeaderList -> IO ()
printHeaderList hs = mapM_ printHeader hs
where
printHeader (k, v) = do
B8.putStr k
putStr ": "
B8.putStr v
putStr "\n"
|
