http2 0.0.1 → 0.1.0
raw patch · 21 files changed
+303/−182 lines, 21 filesdep +aesondep +aeson-prettydep +directorydep −case-insensitivedep −http-typesdep ~basedep ~bytestring
Dependencies added: aeson, aeson-pretty, directory, filepath, text, unordered-containers, vector
Dependencies removed: case-insensitive, http-types
Dependency ranges changed: base, bytestring
Files
- Network/HPACK.hs +25/−21
- Network/HPACK/Builder.hs +15/−0
- Network/HPACK/Context.hs +8/−3
- Network/HPACK/Context/HeaderSet.hs +1/−2
- Network/HPACK/HeaderBlock/Decode.hs +34/−26
- Network/HPACK/HeaderBlock/Encode.hs +1/−2
- Network/HPACK/HeaderBlock/From.hs +7/−7
- Network/HPACK/HeaderBlock/String.hs +8/−6
- Network/HPACK/HeaderBlock/To.hs +35/−39
- Network/HPACK/Huffman/Code.hs +49/−27
- Network/HPACK/Table/Entry.hs +1/−1
- Network/HPACK/Table/Header.hs +1/−2
- Network/HPACK/Table/Static.hs +1/−2
- Network/HPACK/Types.hs +12/−13
- http2.cabal +21/−3
- test-hpack/HPACKSpec.hs +51/−0
- test-hpack/Spec.hs +1/−0
- test/DecodeSpec.hs +6/−6
- test/HeaderBlockSpec.hs +9/−12
- test/HuffmanRequestSpec.hs +13/−7
- test/HuffmanResponseSpec.hs +4/−3
Network/HPACK.hs view
@@ -5,6 +5,8 @@ , Context , newContext , DecodeError(..)+ , HPACKEncoding+ , HPACKDecoding -- * Request , encodeRequestHeader , decodeRequestHeader@@ -14,7 +16,8 @@ ) where import Control.Applicative ((<$>))-import Control.Arrow (first)+import Control.Arrow (second)+import Control.Exception (throwIO) import Network.HPACK.Context import Network.HPACK.HeaderBlock import Network.HPACK.Huffman@@ -22,34 +25,35 @@ ---------------------------------------------------------------- +type HPACKEncoding = Context -> HeaderSet -> IO (Context, ByteStream)+type HPACKDecoding = Context -> ByteStream -> IO (Context, HeaderSet)++----------------------------------------------------------------+ -- | Converting 'HeaderSet' for HTTP request to the low level format.-encodeRequestHeader :: HeaderSet- -> Context- -> IO (ByteStream, Context)-encodeRequestHeader hs ctx =- first (toByteStream huffmanEncodeInRequest) <$> toHeaderBlock hs ctx+encodeRequestHeader :: HPACKEncoding+encodeRequestHeader ctx hs = second toBS <$> toHeaderBlock ctx hs+ where+ toBS = toByteStream huffmanEncodeInRequest -- | Converting the low level format for HTTP request to 'HeaderSet'. -- 'DecodeError' would be thrown.-decodeRequestHeader :: ByteStream- -> Context- -> IO (HeaderSet, Context)-decodeRequestHeader bs ctx =- fromHeaderBlock (fromByteStream huffmanDecodeInRequest bs) ctx+decodeRequestHeader :: HPACKDecoding+decodeRequestHeader ctx bs = either throwIO (fromHeaderBlock ctx) ehb+ where+ ehb = fromByteStream huffmanDecodeInRequest bs ---------------------------------------------------------------- -- | Converting 'HeaderSet' for HTTP response to the low level format.-encodeResponseHeader :: HeaderSet- -> Context- -> IO (ByteStream, Context)-encodeResponseHeader hs ctx =- first (toByteStream huffmanEncodeInResponse) <$> toHeaderBlock hs ctx+encodeResponseHeader :: HPACKEncoding+encodeResponseHeader ctx hs = second toBS <$> toHeaderBlock ctx hs+ where+ toBS = toByteStream huffmanEncodeInResponse -- | Converting the low level format for HTTP response to 'HeaderSet'. -- 'DecodeError' would be thrown.-decodeResponseHeader :: ByteStream- -> Context- -> IO (HeaderSet, Context)-decodeResponseHeader bs ctx =- fromHeaderBlock (fromByteStream huffmanDecodeInResponse bs) ctx+decodeResponseHeader :: HPACKDecoding+decodeResponseHeader ctx bs = either throwIO (fromHeaderBlock ctx) ehb+ where+ ehb = fromByteStream huffmanDecodeInResponse bs
+ Network/HPACK/Builder.hs view
@@ -0,0 +1,15 @@+module Network.HPACK.Builder where++newtype Builder a = Builder ([a] -> [a])++(<<) :: Builder a -> a -> Builder a+Builder b << entry = Builder $ b . (entry :)++empty :: Builder a+empty = Builder id++singleton :: a -> Builder a+singleton x = Builder (x :)++run :: Builder a -> [a]+run (Builder b) = b []
Network/HPACK/Context.hs view
@@ -81,9 +81,11 @@ -- | The entry is removed from the reference set. removeRef :: Context -> Index -> IO Context-removeRef ctx idx = return ctx { oldReferenceSet = removeIndex idx oldref }+removeRef (Context hdrtbl oldref newref hdrset) idx = return ctx where- oldref = oldReferenceSet ctx+ oldref' = removeIndex idx oldref+ newref' = removeIndex idx newref+ ctx = Context hdrtbl oldref' newref' hdrset -- | The header field is emitted. -- The header field is inserted at the beginning of the header table.@@ -102,6 +104,8 @@ pushRef (Context hdrtbl oldref newref hdrset) idx e = return ctx where hdrset' = insertHeader (fromEntry e) hdrset+ -- isPresentIn ensures that idx does not exist in+ -- newref and oldref. newref' = addIndex idx newref ctx = Context hdrtbl oldref newref' hdrset' @@ -136,9 +140,10 @@ -- | Is 'Index' present in the reference set? isPresentIn :: Index -> Context -> Bool-isPresentIn idx ctx = idx `isMember` oldref+isPresentIn idx ctx = idx `isMember` oldref || idx `isMember` newref where oldref = oldReferenceSet ctx+ newref = newReferenceSet ctx ----------------------------------------------------------------
Network/HPACK/Context/HeaderSet.hs view
@@ -4,7 +4,6 @@ import qualified Data.ByteString.Char8 as BS import Network.HPACK.Table-import Network.HPACK.Types -- | Header set. type HeaderSet = [Header]@@ -18,7 +17,7 @@ printHeaderSet hs = mapM_ printHeader hs where printHeader (k,v) = do- BS.putStr $ fromHeaderName k+ BS.putStr k putStr ": " BS.putStr v putStr "\n"
Network/HPACK/HeaderBlock/Decode.hs view
@@ -5,6 +5,7 @@ import Data.Bits (testBit, clearBit, (.&.)) import qualified Data.ByteString as BS import Data.Word (Word8)+import Network.HPACK.Builder import Network.HPACK.HeaderBlock.HeaderField import qualified Network.HPACK.HeaderBlock.Integer as I import qualified Network.HPACK.HeaderBlock.String as S@@ -14,18 +15,20 @@ ---------------------------------------------------------------- -- | Converting the low level format to 'HeaderBlock'.-fromByteStream :: HuffmanDecoding -> ByteStream -> HeaderBlock-fromByteStream hd bs = go $ BS.unpack bs+fromByteStream :: HuffmanDecoding -> ByteStream+ -> Either DecodeError HeaderBlock+fromByteStream hd bs = go (BS.unpack bs) empty where- go [] = []- go ws = hf : go ws'- where- (hf, ws') = toHeaderField hd ws+ go [] builder = Right $ run builder+ go ws builder = do+ (hf, ws') <- toHeaderField hd ws+ go ws' (builder << hf) -toHeaderField :: HuffmanDecoding -> [Word8] -> (HeaderField, [Word8])-toHeaderField _ [] = error "toHeaderField"+toHeaderField :: HuffmanDecoding -> [Word8]+ -> Either DecodeError (HeaderField, [Word8])+toHeaderField _ [] = Left EmptyBlock toHeaderField hd (w:ws)- | w `testBit` 7 = indexed w ws+ | w `testBit` 7 = Right $ indexed w ws | w `testBit` 6 = withoutIndexing hd w ws | otherwise = incrementalIndexing hd w ws @@ -36,44 +39,49 @@ where idx = fromIntegral $ clearBit w 7 -withoutIndexing :: HuffmanDecoding -> Word8 -> [Word8] -> (HeaderField, [Word8])+withoutIndexing :: HuffmanDecoding -> Word8 -> [Word8]+ -> Either DecodeError (HeaderField, [Word8]) withoutIndexing hd w ws | isIndexedName w = indexedName NotAdd hd w ws | otherwise = newName NotAdd hd ws -incrementalIndexing :: HuffmanDecoding -> Word8 -> [Word8] -> (HeaderField, [Word8])+incrementalIndexing :: HuffmanDecoding -> Word8 -> [Word8]+ -> Either DecodeError (HeaderField, [Word8]) incrementalIndexing hd w ws | isIndexedName w = indexedName Add hd w ws | otherwise = newName Add hd ws ---------------------------------------------------------------- -indexedName :: Indexing -> HuffmanDecoding -> Word8 -> [Word8] -> (HeaderField, [Word8])-indexedName indexing hd w ws = (hf, ws'')+indexedName :: Indexing -> HuffmanDecoding -> Word8 -> [Word8]+ -> Either DecodeError (HeaderField, [Word8])+indexedName indexing hd w ws = do+ (val,ws'') <- headerStuff hd ws'+ let hf = Literal indexing (Idx idx) val+ return (hf, ws'') where p = mask6 w (idx,ws') = I.parseInteger 6 p ws- (val,ws'') = headerStuff hd ws'- hf = Literal indexing (Idx idx) val -newName :: Indexing -> HuffmanDecoding -> [Word8] -> (HeaderField, [Word8])-newName indexing hd ws = (hf, ws'')- where- (key,ws') = headerStuff hd ws- (val,ws'') = headerStuff hd ws'- name = toHeaderName key- hf = Literal indexing (Lit name) val +newName :: Indexing -> HuffmanDecoding -> [Word8]+ -> Either DecodeError (HeaderField, [Word8])+newName indexing hd ws = do+ (key,ws') <- headerStuff hd ws+ (val,ws'') <- headerStuff hd ws'+ let hf = Literal indexing (Lit key) val+ return (hf, ws'')+ ---------------------------------------------------------------- -headerStuff :: HuffmanDecoding -> [Word8] -> (HeaderStuff, [Word8])-headerStuff _ [] = error "headerStuff"-headerStuff hd (w:ws) = (hs, ws'')+headerStuff :: HuffmanDecoding -> [Word8]+ -> Either DecodeError (HeaderStuff, [Word8])+headerStuff _ [] = Left EmptyEncodedString+headerStuff hd (w:ws) = S.parseString hd huff len ws' where p = dropHuffman w huff = isHuffman w (len, ws') = I.parseInteger 7 p ws- (hs, ws'') = S.parseString hd huff len ws' ----------------------------------------------------------------
Network/HPACK/HeaderBlock/Encode.hs view
@@ -47,10 +47,9 @@ -- Using Huffman encoding newName :: HuffmanEncoding -> Setter -> HeaderName -> HeaderValue -> Builder-newName he set ck v = pre <> klen <> key <> vlen <> val+newName he set k v = pre <> klen <> key <> vlen <> val where pre = BB.fromWord8 $ set 0- k = fromHeaderName ck key0 = S.encode he k keyLen = length key0 -- FIXME: performance value = S.encode he v
Network/HPACK/HeaderBlock/From.hs view
@@ -13,11 +13,11 @@ ---------------------------------------------------------------- -- | Decoding 'HeaderBlock' to 'HeaderSet'.-fromHeaderBlock :: HeaderBlock- -> Context- -> IO (HeaderSet, Context)-fromHeaderBlock (r:rs) !ctx = decodeStep ctx r >>= fromHeaderBlock rs-fromHeaderBlock [] !ctx = decodeFinal ctx+fromHeaderBlock :: Context+ -> HeaderBlock+ -> IO (Context, HeaderSet)+fromHeaderBlock !ctx (r:rs) = decodeStep ctx r >>= \cx -> fromHeaderBlock cx rs+fromHeaderBlock !ctx [] = decodeFinal ctx ---------------------------------------------------------------- @@ -41,12 +41,12 @@ k <- fromNaming naming ctx newEntry ctx $ toEntry (k,v) -decodeFinal :: Context -> IO (HeaderSet, Context)+decodeFinal :: Context -> IO (Context, HeaderSet) decodeFinal ctx = do !ctx' <- emitNotEmitted ctx let !hs = getHeaderSet ctx' !ctx'' = clearHeaderSet ctx'- return (hs, ctx'')+ return (ctx'', hs) ----------------------------------------------------------------
Network/HPACK/HeaderBlock/String.hs view
@@ -8,12 +8,14 @@ encode :: HuffmanEncoding -> HeaderStuff -> [Word8] encode he h = he $ BS.unpack h -decode :: HuffmanDecoding -> [Word8] -> HeaderStuff-decode hd ws = BS.pack $ hd ws+decode :: HuffmanDecoding -> [Word8] -> Either DecodeError HeaderStuff+decode hd ws = hd ws >>= return . BS.pack -parseString :: HuffmanDecoding -> Bool -> Int -> [Word8] -> (HeaderStuff, [Word8])-parseString hd isHuffman len ws = (conv es, ws')+parseString :: HuffmanDecoding -> Bool -> Int -> [Word8]+ -> Either DecodeError (HeaderStuff, [Word8])+parseString _ False len ws = Right (BS.pack es, ws') where (es, ws') = splitAt len ws- conv | isHuffman = decode hd- | otherwise = BS.pack+parseString hd True len ws = decode hd es >>= \x -> return (x,ws')+ where+ (es, ws') = splitAt len ws
Network/HPACK/HeaderBlock/To.hs view
@@ -5,19 +5,22 @@ ) where import Control.Applicative ((<$>))+import Network.HPACK.Builder import Network.HPACK.Context import Network.HPACK.HeaderBlock.HeaderField import Network.HPACK.Table +type Ctx = (Context, Builder HeaderField)+ -- | Encoding 'HeaderSet' to 'HeaderBlock'.-toHeaderBlock :: HeaderSet- -> Context- -> IO (HeaderBlock, Context)-toHeaderBlock hs !ctx = encodeInit ctx >>= toHeaderBlock' hs+toHeaderBlock :: Context+ -> HeaderSet+ -> IO (Context, HeaderBlock)+toHeaderBlock !ctx hs = encodeInit ctx >>= toHeaderBlock' hs toHeaderBlock' :: HeaderSet- -> (DL, Context)- -> IO (HeaderBlock, Context)+ -> Ctx+ -> IO (Context, HeaderBlock) toHeaderBlock' (h:hs) !ctx = encodeStep ctx h >>= toHeaderBlock' hs toHeaderBlock' [] !ctx = encodeFinal ctx @@ -25,53 +28,46 @@ -- A simple encoding strategy to reset the reference set first -- by 'Index 0' and uses indexing as much as possible. -encodeStep :: (DL,Context) -> Header -> IO (DL,Context)-encodeStep (!dl,!ctx) h@(k,v) = do+encodeStep :: Ctx -> Header -> IO Ctx+encodeStep (!ctx,!builder) h@(k,v) = do cache <- lookupHeader h ctx let e = toEntry h case cache of None -> do- let dl' = dl << Literal Add (Lit k) v+ let builder' = builder << Literal Add (Lit k) v ctx' <- newEntry ctx e- return (dl', ctx')+ return (ctx', builder') KeyOnly InStaticTable i -> do- let dl' = dl << Literal Add (Idx i) v+ let builder' = builder << Literal Add (Idx i) v ctx' <- newEntry ctx e- return (dl', ctx')+ return (ctx', builder') KeyOnly InHeaderTable i -> do- let dl' = dl << Literal Add (Idx i) v+ let builder' = builder << Literal Add (Idx i) v ctx' <- newEntry ctx e- return (dl', ctx')+ return (ctx', builder') KeyValue InStaticTable i -> do- let dl' = dl << Indexed i+ let builder' = builder << Indexed i ctx' <- newEntry ctx e- return (dl', ctx')+ return (ctx', builder') KeyValue InHeaderTable i -> do- let dl' = dl << Indexed i- ctx' <- pushRef ctx i e- return (dl', ctx')+ (builder',ctx') <- if i `isPresentIn` ctx then do+ let b = builder << Indexed i << Indexed i+ c = ctx+ return (b,c)+ else do+ let b = builder << Indexed i+ c <- pushRef ctx i e+ return (b,c)+ return (ctx', builder') -encodeInit :: Context -> IO (DL, Context)+encodeInit :: Context -> IO Ctx encodeInit ctx = do ctx' <- clearHeaderSet <$> clearRefSets ctx- let initialHeaderBlock = initResult $ Indexed 0- return (initialHeaderBlock, ctx')+ let initialHeaderBlock = singleton $ Indexed 0+ return (ctx', initialHeaderBlock) -encodeFinal :: (DL, Context) -> IO (HeaderBlock, Context)-encodeFinal (dl,ctx) = do+encodeFinal :: Ctx -> IO (Context, HeaderBlock)+encodeFinal (ctx, builder) = do !ctx' <- emitNotEmitted ctx- let !hb = getResult dl- return (hb, ctx')--------------------------------------------------------------------type DL = HeaderBlock -> HeaderBlock--(<<) :: DL -> HeaderField -> DL-dl << entry = dl . (entry :)--initResult :: HeaderField -> DL-initResult hf = (hf :)--getResult :: DL -> HeaderBlock-getResult dl = dl []+ let !hb = run builder+ return (ctx', hb)
Network/HPACK/Huffman/Code.hs view
@@ -15,7 +15,9 @@ import Data.Array (Array, (!), listArray) import Data.List (partition) import Data.Word (Word8)+import Network.HPACK.Builder import Network.HPACK.Huffman.Bit+import Network.HPACK.Types (DecodeError(..)) ---------------------------------------------------------------- @@ -23,19 +25,18 @@ type HuffmanEncoding = [Word8] -> [Word8] -- | Huffman decoding.-type HuffmanDecoding = [Word8] -> [Word8]+type HuffmanDecoding = [Word8] -> Either DecodeError [Word8] ---------------------------------------------------------------- --- | Type for Huffman encoding.-newtype Encoder = Encoder (Array Int Bits)- idxEos :: Int idxEos = 256 -enc :: Encoder -> Int -> Bits-enc (Encoder ary) i = ary ! i+---------------------------------------------------------------- +-- | Type for Huffman encoding.+newtype Encoder = Encoder (Array Int Bits)+ -- | Creating 'Encoder'. toEncoder :: [Bits] -> Encoder toEncoder bs = Encoder $ listArray (0,idxEos) bs@@ -46,45 +47,66 @@ where bits = concatMap (enc encoder . fromIntegral) ws group8 xs- | null zs = eos ys : []+ | null zs = eos ys | otherwise = ys : group8 zs where (ys,zs) = splitAt 8 xs eos xs- | length xs == 8 = xs- | otherwise = take 8 (xs ++ enc encoder idxEos)+ | len == 0 = [] -- only when ws == [], [] should be encoded to [].+ | len == 8 = [xs]+ | otherwise = [take 8 (xs ++ enc encoder idxEos)]+ where+ len = length xs +enc :: Encoder -> Int -> Bits+enc (Encoder ary) i = ary ! i+ ---------------------------------------------------------------- -- | Type for Huffman decoding.-data Decoder = Tip Int | Bin Decoder Decoder deriving Show--dec :: Decoder -> Bits -> (Int,Bits)-dec (Tip i) xs = (i,xs)-dec (Bin l _) (F:xs) = dec l xs-dec (Bin _ r) (T:xs) = dec r xs-dec _ [] = (-1,[])+data Decoder = Tip (Maybe Int) Int+ | Bin (Maybe Int) Decoder Decoder+ deriving Show -- | Creating 'Decoder'. toDecoder :: [Bits] -> Decoder-toDecoder decoder = build $ zip [0..idxEos] decoder+toDecoder bs = mark 1 eos $ build $ zip [0..idxEos] bs+ where+ eos = bs !! idxEos build :: [(Int,Bits)] -> Decoder-build [(i,[])] = Tip i-build xs = Bin (build fs) (build ts)+build [(v,[])] = Tip Nothing v+build xs = Bin Nothing (build fs) (build ts) where (fs',ts') = partition ((==) F . head . snd) xs fs = map (second tail) fs' ts = map (second tail) ts' +mark :: Int -> Bits -> Decoder -> Decoder+mark i [] (Tip Nothing v) = Tip (Just i) v+mark i (F:bs) (Bin Nothing l r) = Bin (Just i) (mark (i+1) bs l) r+mark i (T:bs) (Bin Nothing l r) = Bin (Just i) l (mark (i+1) bs r)+mark _ _ _ = error "mark"+ -- | Huffman decoding. decode :: Decoder -> HuffmanDecoding-decode decoder ws = decodeBits decoder (concatMap toBits ws)+decode decoder ws = decodeBits decoder (concatMap toBits ws) empty -decodeBits :: Decoder -> Bits -> [Word8]-decodeBits _ [] = []-decodeBits decoder xs- | i < 0 = []- | otherwise = fromIntegral i : decodeBits decoder ys- where- (i,ys) = dec decoder xs+decodeBits :: Decoder -> Bits -> Builder Word8 -> Either DecodeError [Word8]+decodeBits decoder xs builder = case dec decoder xs of+ Right (OK v xs') -> decodeBits decoder xs' (builder << fromIntegral v)+ Right Eos -> Right $ run builder+ Left err -> Left err++data DecodeOK = Eos | OK Int Bits++dec :: Decoder -> Bits -> Either DecodeError DecodeOK+dec (Tip Nothing v) xs = Right $ OK v xs+dec (Tip _ _) _ = Left EosInTheMiddle+dec (Bin _ l _) (F:xs) = dec l xs+dec (Bin _ _ r) (T:xs) = dec r xs+dec (Bin Nothing _ _) [] = Left IllegalEos+dec (Bin (Just i) _ _) []+ -- i is 1 origin. 8 means Bits are consumed in the parent 7.+ | i <= 8 = Right Eos+ | otherwise = Left TooLongEos
Network/HPACK/Table/Entry.hs view
@@ -37,7 +37,7 @@ headerSizeMagicNumber = 32 headerSize :: Header -> Size-headerSize (k,v) = BS.length (fromHeaderName k)+headerSize (k,v) = BS.length k + BS.length v + headerSizeMagicNumber
Network/HPACK/Table/Header.hs view
@@ -11,7 +11,6 @@ import Data.Array.IO (IOArray, newArray, readArray, writeArray) import qualified Data.ByteString.Char8 as BS import Network.HPACK.Table.Entry-import Network.HPACK.Types ---------------------------------------------------------------- @@ -45,7 +44,7 @@ putStr "] (s = " putStr $ show $ entrySize e putStr ") "- BS.putStr $ fromHeaderName $ entryHeaderName e+ BS.putStr $ entryHeaderName e putStr ": " BS.putStrLn $ entryHeaderValue e
Network/HPACK/Table/Static.hs view
@@ -12,7 +12,6 @@ import Data.HashTable.IO (BasicHashTable) import qualified Data.HashTable.IO as I import Network.HPACK.Table.Entry-import Network.HPACK.Types import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Char8 as H @@ -78,7 +77,7 @@ -- | Checking if 'HeaderName' starts with colon. isColon :: Header -> Bool-isColon h = H.head (fromHeaderName (fst h)) == ':'+isColon h = H.head (fst h) == ':' ----------------------------------------------------------------
Network/HPACK/Types.hs view
@@ -5,8 +5,6 @@ HeaderName , HeaderValue , HeaderStuff- , fromHeaderName- , toHeaderName , Header -- * Misc , ByteStream@@ -16,24 +14,20 @@ import Control.Exception as E import Data.ByteString (ByteString)-import Data.CaseInsensitive (foldedCase, mk) import Data.Typeable-import Network.HTTP.Types (HeaderName, Header) +-- | Header name.+type HeaderName = ByteString+ -- | Header value. type HeaderValue = ByteString +-- | Header.+type Header = (HeaderName, HeaderValue)+ -- | To be a 'HeaderName' or 'HeaderValue'. type HeaderStuff = ByteString --- | Converting 'HeaderName' to 'HeaderStuff'.-fromHeaderName :: HeaderName -> HeaderStuff-fromHeaderName = foldedCase---- | Converting 'HeaderStuff' to 'HeaderName'.-toHeaderName :: HeaderStuff -> HeaderName-toHeaderName = mk- -- | Byte stream in HTTP request/response. type ByteStream = ByteString @@ -42,6 +36,11 @@ -- | Errors for decoder. data DecodeError = IndexOverrun Index -- ^ Index is out of range- deriving (Show,Typeable)+ | EosInTheMiddle -- ^ Eos appears in the middle of string+ | IllegalEos -- ^ Non-eos appears in the end of string+ | TooLongEos -- ^ Eos is more than 7 bits+ | EmptyEncodedString -- ^ Encoded string has no length+ | EmptyBlock -- ^ Header block is empty+ deriving (Eq,Show,Typeable) instance Exception DecodeError
http2.cabal view
@@ -1,5 +1,5 @@ Name: http2-Version: 0.0.1+Version: 0.1.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -18,6 +18,7 @@ Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Network.HPACK+ Network.HPACK.Builder Network.HPACK.Context Network.HPACK.Context.HeaderSet Network.HPACK.Context.ReferenceSet@@ -43,9 +44,7 @@ , array , blaze-builder , bytestring- , case-insensitive , hashtables- , http-types Test-Suite doctest Type: exitcode-stdio-1.0@@ -73,6 +72,25 @@ Build-Depends: base , bytestring , http2+ , hspec >= 1.3++Test-Suite hpack+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ HS-Source-Dirs: test-hpack+ Ghc-Options: -Wall+ Main-Is: Spec.hs+ Other-Modules: HPACKSpec+ Build-Depends: base+ , aeson+ , aeson-pretty+ , bytestring+ , unordered-containers+ , directory+ , filepath+ , http2+ , text+ , vector , hspec >= 1.3 Source-Repository head
+ test-hpack/HPACKSpec.hs view
@@ -0,0 +1,51 @@+module HPACKSpec where++import Control.Applicative ((<$>))+import Control.Monad (forM_, filterM)+import Data.Aeson (eitherDecode)+import qualified Data.ByteString.Lazy as BL+import Data.List (isPrefixOf, isSuffixOf)+import System.Directory (getDirectoryContents, doesDirectoryExist, doesFileExist)+import System.FilePath ((</>))+import Test.Hspec++import Types+import HPACK++testDir :: FilePath+testDir = "test-hpack/hpack-test-case"++getTestFiles :: FilePath -> IO [FilePath]+getTestFiles dir = do+ subdirs0 <- valid <$> getDirectoryContents dir+ subdirs1 <- filterM doesDirectoryExist subdirs0+ concat <$> mapM getTestFiles' subdirs1+ where+ valid = map (testDir </>) . filter (not . isPrefixOf ".")++getTestFiles' :: FilePath -> IO [FilePath]+getTestFiles' subdir = do+ files0 <- valid <$> getDirectoryContents subdir+ filterM doesFileExist files0+ where+ valid = map (subdir </>) . filter (isSuffixOf ".json")++test :: FilePath -> IO (Maybe String)+test file = do+ bs <- BL.readFile file+ let etc = eitherDecode bs :: Either String Test+ case etc of+ Left e -> return $ Just $ file ++ ": " ++ e+ Right tc -> do+ res <- run tc+ case res of+ Pass _ -> return Nothing+ Fail e -> return $ Just $ file ++ ": " ++ e++spec :: Spec+spec = do+ describe "decodeRequestHeader" $ do+ it "decodes headers in request" $ do+ files <- getTestFiles testDir+ forM_ files $ \file ->+ test file `shouldReturn` Nothing
+ test-hpack/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
test/DecodeSpec.hs view
@@ -10,16 +10,16 @@ spec = do describe "fromHeaderBlock" $ do it "decodes HeaderSet in request" $ do- (h1,c1) <- newContext 4096 >>= fromHeaderBlock e31+ (c1,h1) <- newContext 4096 >>= flip fromHeaderBlock e31 h1 `shouldBe` e31h- (h2,c2) <- fromHeaderBlock e32 c1+ (c2,h2) <- fromHeaderBlock c1 e32 h2 `shouldBe` e32h- (h3,_) <- fromHeaderBlock e33 c2+ (_,h3) <- fromHeaderBlock c2 e33 h3 `shouldBe` e33h it "decodes HeaderSet in response" $ do- (h1,c1) <- newContext 256 >>= fromHeaderBlock e51+ (c1,h1) <- newContext 256 >>= flip fromHeaderBlock e51 h1 `shouldBe` e51h- (h2,c2) <- fromHeaderBlock e52 c1+ (c2,h2) <- fromHeaderBlock c1 e52 h2 `shouldBe` e52h- (h3,_) <- fromHeaderBlock e53 c2+ (_,h3) <- fromHeaderBlock c2 e53 h3 `shouldBe` e53h
test/HeaderBlockSpec.hs view
@@ -5,7 +5,6 @@ import qualified Data.ByteString.Char8 as BS import Network.HPACK.HeaderBlock import Network.HPACK.Huffman-import Network.HPACK.Types import Test.Hspec import Test.Hspec.QuickCheck @@ -24,23 +23,21 @@ describe "fromByteStream" $ do it "encodes HeaderBlock" $ do- fromByteStream huffmanDecodeInRequest e31b `shouldBe` e31- fromByteStream huffmanDecodeInRequest e32b `shouldBe` e32- fromByteStream huffmanDecodeInRequest e33b `shouldBe` e33- fromByteStream huffmanDecodeInResponse e51b `shouldBe` e51- fromByteStream huffmanDecodeInResponse e52b `shouldBe` e52- fromByteStream huffmanDecodeInResponse e53b `shouldBe` e53+ fromByteStream huffmanDecodeInRequest e31b `shouldBe` Right e31+ fromByteStream huffmanDecodeInRequest e32b `shouldBe` Right e32+ fromByteStream huffmanDecodeInRequest e33b `shouldBe` Right e33+ fromByteStream huffmanDecodeInResponse e51b `shouldBe` Right e51+ fromByteStream huffmanDecodeInResponse e52b `shouldBe` Right e52+ fromByteStream huffmanDecodeInResponse e53b `shouldBe` Right e53 describe "toByteStream & fromByteStream" $ do prop "duality for request" $ \k v -> do- putStrLn $ "K length" ++ show (length k)- putStrLn $ "V length" ++ show (length v)- let key = toHeaderName $ BS.pack ('k':k)+ let key = BS.pack ('k':k) val = BS.pack ('v':v) hb = [Literal Add (Lit key) val] fromByteStream huffmanDecodeInRequest- (toByteStream huffmanEncodeInRequest hb) `shouldBe` hb+ (toByteStream huffmanEncodeInRequest hb) `shouldBe` Right hb prop "duality for response" $ \v -> do let val = BS.pack ('v':v) hb = [Literal Add (Idx 3) val] fromByteStream huffmanDecodeInResponse- (toByteStream huffmanEncodeInResponse hb) `shouldBe` hb+ (toByteStream huffmanEncodeInResponse hb) `shouldBe` Right hb
test/HuffmanRequestSpec.hs view
@@ -1,7 +1,9 @@ module HuffmanRequestSpec where +import Control.Applicative ((<$>)) import Data.Char import Network.HPACK.Huffman.Request+import Network.HPACK.Types import Test.Hspec import Test.Hspec.QuickCheck @@ -13,10 +15,10 @@ enc = toHexString . huffmanEncodeInRequest . toW toW = map (fromIntegral . ord) -shouldBeDecoded :: String -> String -> Expectation+shouldBeDecoded :: String -> Either DecodeError String -> Expectation shouldBeDecoded inp out = dec inp `shouldBe` out where- dec = toS . huffmanDecodeInRequest . fromHexString+ dec x = toS <$> huffmanDecodeInRequest (fromHexString x) toS = map (chr . fromIntegral) spec :: Spec@@ -24,16 +26,20 @@ describe "huffmanEncodeInRequest and huffmanDecodeInRequest" $ do prop "duality" $ \ns -> let is = map ((`mod` 255) . abs) ns- in huffmanDecodeInRequest (huffmanEncodeInRequest is) == is+ in huffmanDecodeInRequest (huffmanEncodeInRequest is) == Right is describe "huffmanEncodeInRequest" $ do it "encodes in request" $ do "www.example.com" `shouldBeEncoded` "db6d883e68d1cb1225ba7f" "no-cache" `shouldBeEncoded` "63654a1398ff" "custom-key" `shouldBeEncoded` "4eb08b749790fa7f" "custom-value" `shouldBeEncoded` "4eb08b74979a17a8ff"+ "" `shouldBeEncoded` "" describe "huffmanDecodeInRequest" $ do it "decodes in request" $ do- "db6d883e68d1cb1225ba7f" `shouldBeDecoded` "www.example.com"- "63654a1398ff" `shouldBeDecoded` "no-cache"- "4eb08b749790fa7f" `shouldBeDecoded` "custom-key"- "4eb08b74979a17a8ff" `shouldBeDecoded` "custom-value"+ "db6d883e68d1cb1225ba7f" `shouldBeDecoded` Right "www.example.com"+ "63654a1398ff" `shouldBeDecoded` Right "no-cache"+ "4eb08b749790fa7f" `shouldBeDecoded` Right "custom-key"+ "4eb08b74979a17a8ff" `shouldBeDecoded` Right "custom-value"+ "ff" `shouldBeDecoded` Left TooLongEos+ "fffff77f" `shouldBeDecoded` Right "\1"+ "fffff77fff" `shouldBeDecoded` Left TooLongEos
test/HuffmanResponseSpec.hs view
@@ -1,5 +1,6 @@ module HuffmanResponseSpec where +import Control.Applicative ((<$>)) import Data.Char import Network.HPACK.Huffman.Response import Test.Hspec@@ -14,9 +15,9 @@ toW = map (fromIntegral . ord) shouldBeDecoded :: String -> String -> Expectation-shouldBeDecoded inp out = dec inp `shouldBe` out+shouldBeDecoded inp out = dec inp `shouldBe` Right out where- dec = toS . huffmanDecodeInResponse . fromHexString+ dec x = toS <$> huffmanDecodeInResponse (fromHexString x) toS = map (chr . fromIntegral) spec :: Spec@@ -24,7 +25,7 @@ describe "huffmanEncodeInResponse and huffmanDecodeInResponse" $ do prop "duality" $ \ns -> let is = map ((`mod` 255) . abs) ns- in huffmanDecodeInResponse (huffmanEncodeInResponse is) == is+ in huffmanDecodeInResponse (huffmanEncodeInResponse is) == Right is describe "huffmanEncodeInResponse" $ do it "encodes in response" $ do "private" `shouldBeEncoded` "c31b39bf387f"