http2 0.5.0 → 0.6.0
raw patch · 33 files changed
+1820/−563 lines, 33 filesdep +attoparsecdep +attoparsec-binarydep +hexdep ~basedep ~bytestringnew-component:exe:frame-encode
Dependencies added: attoparsec, attoparsec-binary, hex, http2
Dependency ranges changed: base, bytestring
Files
- Network/HPACK/Context.hs +8/−1
- Network/HPACK/Table.hs +17/−8
- Network/HTTP2.hs +11/−0
- Network/HTTP2/Decode.hs +257/−0
- Network/HTTP2/Encode.hs +217/−0
- Network/HTTP2/Types.hs +407/−0
- http2.cabal +128/−54
- test-frame/Case.hs +56/−0
- test-frame/JSON.hs +223/−0
- test-frame/Spec.hs +1/−0
- test-frame/frame-encode.hs +25/−0
- test-hpack/HPACKDecode.hs +7/−7
- test-hpack/HPACKEncode.hs +6/−6
- test-hpack/HPACKSpec.hs +1/−1
- test-hpack/HexString.hs +0/−53
- test-hpack/JSON.hs +103/−0
- test-hpack/Types.hs +0/−103
- test-hpack/hpack-debug.hs +1/−1
- test-hpack/hpack-encode.hs +1/−1
- test-hpack/hpack-stat.hs +1/−1
- test/DecodeSpec.hs +0/−25
- test/HPACK/DecodeSpec.hs +44/−0
- test/HPACK/HeaderBlock.hs +130/−0
- test/HPACK/HeaderBlockSpec.hs +41/−0
- test/HPACK/HuffmanSpec.hs +54/−0
- test/HPACK/IntegerSpec.hs +24/−0
- test/HTTP2/FrameSpec.hs +48/−0
- test/HeaderBlock.hs +0/−127
- test/HeaderBlockSpec.hs +0/−41
- test/HexString.hs +0/−53
- test/HuffmanSpec.hs +0/−53
- test/IntegerSpec.hs +0/−24
- test/doctests.hs +9/−4
Network/HPACK/Context.hs view
@@ -2,11 +2,13 @@ -- * Types HeaderList -- re-exporting , Context+ , DecodeError(..)+ -- * Context , newContextForEncoding , newContextForDecoding , changeContextForDecoding- , DecodeError(..) , printContext+ , isContextTableEmpty -- * Processing , newEntryForEncoding , newEntryForDecoding@@ -54,6 +56,11 @@ changeContextForDecoding ctx@(Context hdrtbl) siz | shouldRenew hdrtbl siz = Context <$> renewHeaderTable siz hdrtbl | otherwise = return ctx++----------------------------------------------------------------++isContextTableEmpty :: Context -> Bool+isContextTableEmpty (Context hdrtbl) = isHeaderTableEmpty hdrtbl ----------------------------------------------------------------
Network/HPACK/Table.hs view
@@ -8,6 +8,7 @@ , shouldRenew , renewHeaderTable , printHeaderTable+ , isHeaderTableEmpty -- * Insertion , insertEntry -- * Header to index@@ -102,6 +103,11 @@ ---------------------------------------------------------------- +isHeaderTableEmpty :: HeaderTable -> Bool+isHeaderTableEmpty hdrtbl = numOfEntries hdrtbl == 0++----------------------------------------------------------------+ -- | Which table does `Index` refer to? data WhichTable = InHeaderTable | InStaticTable deriving (Eq,Show) @@ -227,14 +233,11 @@ adjustTableSize hdrtbl = adjust hdrtbl [] adjust :: HeaderTable -> [Header] -> IO (HeaderTable, [Header])-adjust hdrtbl hs- | tsize <= maxtsize = return (hdrtbl, hs)+adjust hdrtbl@HeaderTable{..} hs+ | headerTableSize <= maxHeaderTableSize = return (hdrtbl, hs) | otherwise = do (hdrtbl', h) <- removeEnd hdrtbl adjust hdrtbl' (h:hs)- where- tsize = headerTableSize hdrtbl- maxtsize = maxHeaderTableSize hdrtbl ---------------------------------------------------------------- @@ -271,19 +274,25 @@ ---------------------------------------------------------------- -- | Resolving an index from a header.+-- Static table is prefer to header table. lookupTable :: Header -> HeaderTable -> HeaderCache lookupTable h hdrtbl = case reverseIndex hdrtbl of Nothing -> None Just rev -> case HP.search h rev of- HP.N -> case HP.search h staticHashPSQ of+ HP.N -> case mstatic of HP.N -> None HP.K sidx -> KeyOnly InStaticTable (fromSIndexToIndex hdrtbl sidx) HP.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx)- HP.K hidx -> case HP.search h staticHashPSQ of+ HP.K hidx -> case mstatic of HP.N -> KeyOnly InHeaderTable (fromHIndexToIndex hdrtbl hidx) HP.K sidx -> KeyOnly InStaticTable (fromSIndexToIndex hdrtbl sidx) HP.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx)- HP.KV hidx -> KeyValue InHeaderTable (fromHIndexToIndex hdrtbl hidx)+ HP.KV hidx -> case mstatic of+ HP.N -> KeyValue InHeaderTable (fromHIndexToIndex hdrtbl hidx)+ HP.K _ -> KeyValue InHeaderTable (fromHIndexToIndex hdrtbl hidx)+ HP.KV sidx -> KeyValue InStaticTable (fromSIndexToIndex hdrtbl sidx)+ where+ mstatic = HP.search h staticHashPSQ ----------------------------------------------------------------
+ Network/HTTP2.hs view
@@ -0,0 +1,11 @@+module Network.HTTP2 (+ -- * Decoding and Encoding+ decodeFrame+ , EncodeInfo(..)+ , encodeFrame+ , module Network.HTTP2.Types+ ) where++import Network.HTTP2.Decode+import Network.HTTP2.Encode+import Network.HTTP2.Types
+ Network/HTTP2/Decode.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE TupleSections, BangPatterns, RecordWildCards #-}++module Network.HTTP2.Decode (+ decodeFrame+ , decodeFrameHeader+ , parseFrame+ , parseFrameHeader+ , parseFramePayload+ ) where++import Control.Applicative ((<$>), (<*>))+import Control.Monad (void, when)+import Data.Array (Array, listArray, (!))+import qualified Data.Attoparsec.Binary as BI+import qualified Data.Attoparsec.ByteString as B+import Data.Bits (shiftL, (.|.))+import Data.ByteString (ByteString)+import Data.List (isPrefixOf)++import Network.HTTP2.Types++----------------------------------------------------------------+-- atto-parsec can return only String as an error type, sigh.++protocolError :: String+protocolError = show ProtocolError++frameSizeError :: String+frameSizeError = show FrameSizeError++----------------------------------------------------------------++-- | Parsing byte stream to make an HTTP/2 frame.+decodeFrame :: Settings -- ^ HTTP/2 settings+ -> ByteString -- ^ Input byte-stream+ -> Either ErrorCodeId (Frame,ByteString) -- ^ (Decoded frame, leftover byte-stream)+decodeFrame settings bs = case B.parse (parseFrame settings) bs of+ B.Done left frame -> Right (frame, left)+ B.Fail _ _ estr -> Left $ toErrorCode estr+ B.Partial _ -> undefined -- fixme++decodeFrameHeader :: Settings -> ByteString+ -> Either ErrorCodeId (FrameType, FrameHeader)+decodeFrameHeader settings bs = case B.parseOnly (parseFrameHeader settings) bs of+ Right fh -> Right fh+ Left estr -> Left $ toErrorCode estr++toErrorCode :: String -> ErrorCodeId+toErrorCode estr+ | estr' == protocolError = ProtocolError+ | estr' == frameSizeError = FrameSizeError+ | otherwise = UnknownError estr' -- fixme+ where+ estr'+ -- attoparsec specific, sigh.+ | "Failed reading: " `isPrefixOf` estr = drop 16 estr+ | otherwise = estr++----------------------------------------------------------------++parseFrame :: Settings -> B.Parser Frame+parseFrame settings = do+ (ftyp, header) <- parseFrameHeader settings+ Frame header <$> parseFramePayload ftyp header++----------------------------------------------------------------++parseFrameHeader :: Settings -> B.Parser (FrameType, FrameHeader)+parseFrameHeader settings = do+ i0 <- intFromWord16be+ i1 <- intFromWord8+ let len = (i0 `shiftL` 8) .|. i1+ when (doesExceed settings len) $ fail frameSizeError+ ftyp <- B.anyWord8+ flg <- B.anyWord8+ sid <- streamIdentifier+ case toFrameTypeId ftyp of+ Nothing -> return ()+ Just typ -> when (isProtocolError settings typ sid) $ fail protocolError+ return $ (ftyp, FrameHeader len flg sid)++doesExceed :: Settings -> PayloadLength -> Bool+doesExceed settings len = len > maxLength+ where+ maxLength = case settings ! SettingsMaxFrameSize of+ Just x -> fromIntegral x+ Nothing -> maxPayloadLength++zeroFrameTypes :: [FrameTypeId]+zeroFrameTypes = [+ FrameSettings+ , FramePing+ , FrameGoAway+ ]++nonZeroFrameTypes :: [FrameTypeId]+nonZeroFrameTypes = [+ FrameData+ , FrameHeaders+ , FramePriority+ , FrameRSTStream+ , FramePushPromise+ , FrameContinuation+ ]++isProtocolError :: Settings -> FrameTypeId -> StreamIdentifier -> Bool+isProtocolError settings typ sid+ | typ `elem` nonZeroFrameTypes && sid == streamIdentifierForSeetings = True+ | typ `elem` zeroFrameTypes && sid /= streamIdentifierForSeetings = True+ | typ == FramePushPromise && not pushEnabled = True+ | otherwise = False+ where+ pushEnabled = case settings ! SettingsEnablePush of+ Nothing -> True+ Just x -> x /= 0++----------------------------------------------------------------++type FramePayloadParser = FrameHeader -> B.Parser FramePayload++payloadParsers :: Array FrameTypeId FramePayloadParser+payloadParsers = listArray (minBound :: FrameTypeId, maxBound :: FrameTypeId)+ [ parseDataFrame+ , parseHeadersFrame+ , parsePriorityFrame+ , parseRstStreamFrame+ , parseSettingsFrame+ , parsePushPromiseFrame+ , parsePingFrame+ , parseGoAwayFrame+ , parseWindowUpdateFrame+ , parseContinuationFrame+ ]++parseFramePayload :: FrameType -> FramePayloadParser+parseFramePayload ftyp header = parsePayload mfid header+ where+ mfid = toFrameTypeId ftyp+ parsePayload Nothing = parseUnknownFrame ftyp+ parsePayload (Just fid) = payloadParsers ! fid++----------------------------------------------------------------++parseDataFrame :: FramePayloadParser+parseDataFrame header = parseWithPadding header $ \len ->+ DataFrame <$> B.take len++parseHeadersFrame :: FramePayloadParser+parseHeadersFrame header = parseWithPadding header $ \len ->+ if hasPriority then do+ p <- priority+ HeadersFrame (Just p) <$> B.take (len - 5)+ else+ HeadersFrame Nothing <$> B.take len+ where+ hasPriority = testPriority $ flags header++parsePriorityFrame :: FramePayloadParser+parsePriorityFrame _ = PriorityFrame <$> priority++parseRstStreamFrame :: FramePayloadParser+parseRstStreamFrame _ = RSTStreamFrame . toErrorCodeId <$> BI.anyWord32be++parseSettingsFrame :: FramePayloadParser+parseSettingsFrame FrameHeader{..}+ | isNotValid = fail protocolError+ | otherwise = SettingsFrame <$> settings num id+ where+ num = payloadLength `div` 6+ isNotValid = payloadLength `mod` 6 /= 0+ settings 0 builder = return $ toSettings $ builder []+ settings n builder = do+ rawSetting <- BI.anyWord16be+ let msettings = toSettingsKeyId rawSetting+ n' = n - 1+ case msettings of+ Nothing -> settings n' builder -- ignoring unknown one (Section 6.5.2)+ Just k -> do+ v <- BI.anyWord32be+ settings n' (((k,v):) . builder)++parsePushPromiseFrame :: FramePayloadParser+parsePushPromiseFrame header = parseWithPadding header $ \len ->+ PushPromiseFrame <$> streamIdentifier <*> hbf len+ where+ hbf len = B.take $ len - 4++parsePingFrame :: FramePayloadParser+parsePingFrame FrameHeader{..}+ | payloadLength /= 8 = fail frameSizeError+ | otherwise = PingFrame <$> B.take 8++parseGoAwayFrame :: FramePayloadParser+parseGoAwayFrame FrameHeader{..} =+ GoAwayFrame <$> streamIdentifier <*> ecid <*> debug+ where+ ecid = toErrorCodeId <$> BI.anyWord32be+ debug = B.take $ payloadLength - 8++parseWindowUpdateFrame :: FramePayloadParser+parseWindowUpdateFrame FrameHeader{..}+ | payloadLength /= 4 = fail frameSizeError -- not sure+ | otherwise = WindowUpdateFrame <$> BI.anyWord32be++parseContinuationFrame :: FramePayloadParser+parseContinuationFrame FrameHeader{..} = ContinuationFrame <$> payload+ where+ payload = B.take payloadLength++parseUnknownFrame :: FrameType -> FramePayloadParser+parseUnknownFrame ftyp FrameHeader{..} = UnknownFrame ftyp <$> payload+ where+ payload = B.take payloadLength++----------------------------------------------------------------++-- | Helper function to pull off the padding if its there, and will+-- eat up the trailing padding automatically. Calls the parser func+-- passed in with the length of the unpadded portion between the+-- padding octet and the actual padding+parseWithPadding :: FrameHeader -> (Int -> B.Parser a) -> B.Parser a+parseWithPadding FrameHeader{..} p+ | padded = do+ padlen <- intFromWord8+ -- padding length consumes 1 byte.+ val <- p $ payloadLength - padlen - 1+ ignore padlen+ return val+ | otherwise = p payloadLength+ where+ padded = testPadded flags++streamIdentifier :: B.Parser StreamIdentifier+streamIdentifier = toStreamIdentifier <$> BI.anyWord32be++streamIdentifier' :: B.Parser (StreamIdentifier, Bool)+streamIdentifier' = do+ w32 <- BI.anyWord32be+ let !streamdId = toStreamIdentifier w32+ !exclusive = testExclusive w32+ return (streamdId, exclusive)++priority :: B.Parser Priority+priority = do+ (sid, excl) <- streamIdentifier'+ Priority excl sid <$> w+ where+ w = (+1) <$> intFromWord8++ignore :: Int -> B.Parser ()+ignore n = void $ B.take n++intFromWord8 :: B.Parser Int+intFromWord8 = fromIntegral <$> B.anyWord8++intFromWord16be :: B.Parser Int+intFromWord16be = fromIntegral <$> BI.anyWord16be
+ Network/HTTP2/Encode.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE RecordWildCards #-}++module Network.HTTP2.Encode (+ encodeFrame+ , encodeFrameHeader+ , encodeFramePayload+ , buildFrame+ , buildFrameHeader+ , buildFramePayload+ , EncodeInfo(..)+ ) where++import Blaze.ByteString.Builder (Builder)+import qualified Blaze.ByteString.Builder as BB+import Data.Array (assocs)+import Data.Bits+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Maybe (isJust)+import Data.Monoid ((<>), mempty)++import Network.HTTP2.Types++----------------------------------------------------------------++-- | Auxiliary information for frame encoding.+data EncodeInfo = EncodeInfo {+ -- | Flags to be set in a frame header+ encodeFlags :: FrameFlags+ -- | Stream id to be set in a frame header+ , encodeStreamId :: StreamIdentifier+ -- | Padding if any+ , encodePadding :: Maybe Padding+ } deriving (Show,Read)++----------------------------------------------------------------++-- | Encoding an HTTP/2 frame to byte stream.+encodeFrame :: EncodeInfo -> FramePayload -> ByteString+encodeFrame einfo payload = run $ buildFrame einfo payload++encodeFrameHeader :: FrameType -> FrameHeader -> ByteString+encodeFrameHeader ftid header = run $ buildFrameHeader ftid header++encodeFramePayload :: EncodeInfo -> FramePayload -> ByteString+encodeFramePayload einfo payload = run payloadBuilder+ where+ (_, payloadBuilder) = buildFramePayload einfo payload++run :: Builder -> ByteString+run = BL.toStrict . BB.toLazyByteString++----------------------------------------------------------------++buildFrame :: EncodeInfo -> FramePayload -> Builder+buildFrame einfo payload = headerBuilder <> payloadBuilder+ where+ (header, payloadBuilder) = buildFramePayload einfo payload+ ftyp = framePayloadToFrameType payload+ headerBuilder = buildFrameHeader ftyp header++----------------------------------------------------------------++buildFrameHeader :: FrameType -> FrameHeader -> Builder+buildFrameHeader ftyp FrameHeader{..} = len <> typ <> flg <> sid+ where+ -- fixme: 2^14 check+ len1 = BB.fromWord16be (fromIntegral (payloadLength `shiftR` 8))+ len2 = BB.fromWord8 (fromIntegral (payloadLength .&. 0xff))+ len = len1 <> len2+ typ = BB.fromWord8 ftyp+ flg = BB.fromWord8 flags+ sid = BB.fromWord32be $ fromStreamIdentifier streamId++----------------------------------------------------------------++buildFramePayload :: EncodeInfo -> FramePayload -> (FrameHeader, Builder)+buildFramePayload einfo (DataFrame body) =+ buildFramePayloadData einfo body+buildFramePayload einfo (HeadersFrame mpri hdr) =+ buildFramePayloadHeaders einfo mpri hdr+buildFramePayload einfo (PriorityFrame pri) =+ buildFramePayloadPriority einfo pri+buildFramePayload einfo (RSTStreamFrame e) =+ buildFramePayloadRSTStream einfo e+buildFramePayload einfo (SettingsFrame settings) =+ buildFramePayloadSettings einfo settings+buildFramePayload einfo (PushPromiseFrame sid hdr) =+ buildFramePayloadPushPromise einfo sid hdr+buildFramePayload einfo (PingFrame opaque) =+ buildFramePayloadPing einfo opaque+buildFramePayload einfo (GoAwayFrame sid e debug) =+ buildFramePayloadGoAway einfo sid e debug+buildFramePayload einfo (WindowUpdateFrame size) =+ buildFramePayloadWindowUpdate einfo size+buildFramePayload einfo (ContinuationFrame hdr) =+ buildFramePayloadContinuation einfo hdr+buildFramePayload einfo (UnknownFrame _ opaque) =+ buildFramePayloadUnknown einfo opaque++----------------------------------------------------------------++buildPadding :: EncodeInfo -> Builder -> PayloadLength -> (FrameHeader, Builder)+buildPadding EncodeInfo{ encodePadding = Nothing, ..} builder len =+ (header, builder)+ where+ header = FrameHeader len encodeFlags encodeStreamId+buildPadding EncodeInfo{ encodePadding = Just padding, ..} btarget targetLength =+ (header, builder)+ where+ header = FrameHeader len newflags encodeStreamId+ builder = bpadlen <> btarget <> bpadding+ bpadlen = BB.fromWord8 $ fromIntegral paddingLength+ bpadding = BB.fromByteString padding+ paddingLength = B.length padding+ len = targetLength + paddingLength + 1+ newflags = setPadded encodeFlags++buildPriority :: Priority -> Builder+buildPriority Priority{..} = builder+ where+ builder = bstream <> bweight+ stream = fromStreamIdentifier streamDependency+ estream+ | exclusive = setExclusive stream+ | otherwise = stream+ bstream = BB.fromWord32be estream+ bweight = BB.fromWord8 $ fromIntegral $ weight - 1++-- fixme: clear 31th bit?+buildStream :: StreamIdentifier -> Builder+buildStream = BB.fromWord32be . fromStreamIdentifier++buildErrorCodeId :: ErrorCodeId -> Builder+buildErrorCodeId = BB.fromWord32be . fromErrorCodeId++----------------------------------------------------------------++buildFramePayloadData :: EncodeInfo -> ByteString -> (FrameHeader, Builder)+buildFramePayloadData einfo body = buildPadding einfo builder len+ where+ builder = BB.fromByteString body+ len = B.length body++buildFramePayloadHeaders :: EncodeInfo -> Maybe Priority -> HeaderBlockFragment+ -> (FrameHeader, Builder)+buildFramePayloadHeaders einfo Nothing hdr =+ buildPadding einfo builder len+ where+ builder = BB.fromByteString hdr+ len = B.length hdr+buildFramePayloadHeaders einfo (Just pri) hdr =+ buildPadding einfo' builder len+ where+ builder = buildPriority pri <> BB.fromByteString hdr+ len = B.length hdr + 5+ einfo' = einfo { encodeFlags = setPriority (encodeFlags einfo) }++buildFramePayloadPriority :: EncodeInfo -> Priority -> (FrameHeader, Builder)+buildFramePayloadPriority EncodeInfo{..} p = (header, builder)+ where+ builder = buildPriority p+ header = FrameHeader 5 encodeFlags encodeStreamId++buildFramePayloadRSTStream :: EncodeInfo -> ErrorCodeId -> (FrameHeader, Builder)+buildFramePayloadRSTStream EncodeInfo{..} e = (header, builder)+ where+ builder = buildErrorCodeId e+ header = FrameHeader 4 encodeFlags encodeStreamId++buildFramePayloadSettings :: EncodeInfo -> Settings -> (FrameHeader, Builder)+buildFramePayloadSettings EncodeInfo{..} settings = (header, builder)+ where+ alist = assocs settings+ builder = foldr op mempty alist+ (_, Nothing) `op` x = x+ (key, Just val) `op` x = BB.fromWord16be (fromSettingsKeyId key)+ <> BB.fromWord32be val <> x+ len = length (filter (isJust . snd) alist) * 6+ header = FrameHeader len encodeFlags encodeStreamId++buildFramePayloadPushPromise :: EncodeInfo -> StreamIdentifier -> HeaderBlockFragment -> (FrameHeader, Builder)+buildFramePayloadPushPromise einfo sid hdr = buildPadding einfo builder len+ where+ builder = buildStream sid <> BB.fromByteString hdr+ len = 4 + B.length hdr++buildFramePayloadPing :: EncodeInfo -> ByteString -> (FrameHeader, Builder)+buildFramePayloadPing EncodeInfo{..} odata = (header, builder)+ where+ builder = BB.fromByteString odata+ header = FrameHeader 8 encodeFlags encodeStreamId++buildFramePayloadGoAway :: EncodeInfo -> LastStreamId -> ErrorCodeId -> ByteString -> (FrameHeader, Builder)+buildFramePayloadGoAway EncodeInfo{..} sid e debug = (header, builder)+ where+ builder = buildStream sid <> buildErrorCodeId e <> BB.fromByteString debug+ len = 4 + 4 + B.length debug+ header = FrameHeader len encodeFlags encodeStreamId++buildFramePayloadWindowUpdate :: EncodeInfo -> WindowSizeIncrement -> (FrameHeader, Builder)+buildFramePayloadWindowUpdate EncodeInfo{..} size = (header, builder)+ where+ -- fixme: reserve bit+ builder = BB.fromWord32be size+ header = FrameHeader 4 encodeFlags encodeStreamId++buildFramePayloadContinuation :: EncodeInfo -> HeaderBlockFragment -> (FrameHeader, Builder)+buildFramePayloadContinuation EncodeInfo{..} hdr = (header, builder)+ where+ builder = BB.fromByteString hdr+ len = B.length hdr+ header = FrameHeader len encodeFlags encodeStreamId++buildFramePayloadUnknown :: EncodeInfo -> ByteString -> (FrameHeader, Builder)+buildFramePayloadUnknown = buildFramePayloadData
+ Network/HTTP2/Types.hs view
@@ -0,0 +1,407 @@+module Network.HTTP2.Types (+ -- * Settings+ SettingsKey+ , SettingsKeyId(..)+ , SettingsValue+ , fromSettingsKeyId+ , toSettingsKeyId+ , Settings+ , defaultSettings+ , toSettings+ , fromSettings+ -- * Error code+ , ErrorCode+ , ErrorCodeId(..)+ , fromErrorCodeId+ , toErrorCodeId+ -- * Frame type+ , FrameType+ , FrameTypeId(..)+ , fromFrameTypeId+ , toFrameTypeId+ -- * Frame+ , Frame(..)+ , FrameHeader(..)+ , FramePayload(..)+ , framePayloadToFrameType+ -- * Stream identifier+ , StreamIdentifier(..)+ , StreamDependency+ , PromisedStreamId+ , LastStreamId+ , fromStreamIdentifier+ , toStreamIdentifier+ , streamIdentifierForSeetings+ , testExclusive+ , setExclusive+ -- * Flags+ , FrameFlags+ , defaultFlags+ , testEndStream+ , testAck+ , testEndHeader+ , testPadded+ , testPriority+ , setEndStream+ , setAck+ , setEndHeader+ , setPadded+ , setPriority+ -- * Payload length+ , PayloadLength+ , maxPayloadLength+ -- * Types+ , WindowSizeIncrement+ , HeaderBlockFragment+ , Priority(..)+ , Padding+ ) where++import Control.Arrow (second)+import Control.Monad (forM_)+import Data.Array (Array, Ix, listArray, assocs)+import Data.Array.ST (newArray, writeArray, runSTArray)+import Data.Bits (setBit, testBit, clearBit)+import Data.ByteString (ByteString)+import Data.Maybe (fromJust, isJust)+import Data.Word (Word8, Word16, Word32)++----------------------------------------------------------------++type ErrorCode = Word32++data ErrorCodeId = NoError+ | ProtocolError+ | InternalError+ | FlowControlError+ | SettingsTimeout+ | StreamClosed+ | FrameSizeError+ | RefusedStream+ | Cancel+ | CompressionError+ | ConnectError+ | EnhanceYourCalm+ | InadequateSecurity+ -- our extensions+ | UnknownErrorCode ErrorCode+ | UnknownError String+ deriving (Show, Read, Eq, Ord)++-- |+--+-- >>> fromErrorCodeId NoError+-- 0+-- >>> fromErrorCodeId InadequateSecurity+-- 12+fromErrorCodeId :: ErrorCodeId -> ErrorCode+fromErrorCodeId NoError = 0x0+fromErrorCodeId ProtocolError = 0x1+fromErrorCodeId InternalError = 0x2+fromErrorCodeId FlowControlError = 0x3+fromErrorCodeId SettingsTimeout = 0x4+fromErrorCodeId StreamClosed = 0x5+fromErrorCodeId FrameSizeError = 0x6+fromErrorCodeId RefusedStream = 0x7+fromErrorCodeId Cancel = 0x8+fromErrorCodeId CompressionError = 0x9+fromErrorCodeId ConnectError = 0xa+fromErrorCodeId EnhanceYourCalm = 0xb+fromErrorCodeId InadequateSecurity = 0xc+fromErrorCodeId (UnknownErrorCode w) = w+fromErrorCodeId _ = 255 -- never reached++-- |+--+-- >>> toErrorCodeId 0+-- NoError+-- >>> toErrorCodeId 0xc+-- InadequateSecurity+-- >>> toErrorCodeId 0xd+-- UnknownErrorCode 13+toErrorCodeId :: ErrorCode -> ErrorCodeId+toErrorCodeId 0x0 = NoError+toErrorCodeId 0x1 = ProtocolError+toErrorCodeId 0x2 = InternalError+toErrorCodeId 0x3 = FlowControlError+toErrorCodeId 0x4 = SettingsTimeout+toErrorCodeId 0x5 = StreamClosed+toErrorCodeId 0x6 = FrameSizeError+toErrorCodeId 0x7 = RefusedStream+toErrorCodeId 0x8 = Cancel+toErrorCodeId 0x9 = CompressionError+toErrorCodeId 0xa = ConnectError+toErrorCodeId 0xb = EnhanceYourCalm+toErrorCodeId 0xc = InadequateSecurity+toErrorCodeId w = UnknownErrorCode w++----------------------------------------------------------------++type SettingsKey = Word16+type SettingsValue = Word32++data SettingsKeyId = SettingsHeaderTableSize+ | SettingsEnablePush+ | SettingsMaxConcurrentStreams+ | SettingsInitialWindowSize+ | SettingsMaxFrameSize -- this means payload size+ | SettingsMaxHeaderBlockSize+ deriving (Show, Read, Eq, Ord, Enum, Bounded, Ix)++-- |+--+-- >>> fromSettingsKeyId SettingsHeaderTableSize+-- 1+-- >>> fromSettingsKeyId SettingsMaxHeaderBlockSize+-- 6+fromSettingsKeyId :: SettingsKeyId -> Word16+fromSettingsKeyId x = fromIntegral (fromEnum x) + 1++minSettingsKeyId :: Word16+minSettingsKeyId = fromIntegral $ fromEnum (minBound :: SettingsKeyId)++maxSettingsKeyId :: Word16+maxSettingsKeyId = fromIntegral $ fromEnum (maxBound :: SettingsKeyId)++-- |+--+-- >>> toSettingsKeyId 0+-- Nothing+-- >>> toSettingsKeyId 1+-- Just SettingsHeaderTableSize+-- >>> toSettingsKeyId 6+-- Just SettingsMaxHeaderBlockSize+-- >>> toSettingsKeyId 7+-- Nothing+toSettingsKeyId :: Word16 -> Maybe SettingsKeyId+toSettingsKeyId x+ | minSettingsKeyId <= n && n <= maxSettingsKeyId = Just . toEnum . fromIntegral $ n+ | otherwise = Nothing+ where+ n = x - 1++----------------------------------------------------------------++type Settings = Array SettingsKeyId (Maybe SettingsValue)++-- | Default settings. All values are 'Nothing'.+defaultSettings :: Settings+defaultSettings = listArray settingsRange [Nothing|_<-xs]+ where+ xs = [minBound :: SettingsKeyId .. maxBound :: SettingsKeyId]++-- |+--+-- >>> toSettings [(SettingsHeaderTableSize,10),(SettingsInitialWindowSize,20),(SettingsHeaderTableSize,30)]+-- array (SettingsHeaderTableSize,SettingsMaxHeaderBlockSize) [(SettingsHeaderTableSize,Just 30),(SettingsEnablePush,Nothing),(SettingsMaxConcurrentStreams,Nothing),(SettingsInitialWindowSize,Just 20),(SettingsMaxFrameSize,Nothing),(SettingsMaxHeaderBlockSize,Nothing)]+toSettings :: [(SettingsKeyId,SettingsValue)] -> Settings+toSettings kvs = runSTArray $ do+ arr <- newArray settingsRange Nothing+ forM_ kvs $ \(k,v) -> writeArray arr k (Just v)+ return arr++settingsRange :: (SettingsKeyId, SettingsKeyId)+settingsRange = (minBound, maxBound)++data Priority = Priority {+ exclusive :: Bool+ , streamDependency :: StreamIdentifier+ , weight :: Int+ } deriving (Show, Read, Eq)++-- |+-- >>> fromSettings $ toSettings [(SettingsHeaderTableSize,10),(SettingsInitialWindowSize,20),(SettingsHeaderTableSize,30)]+-- [(SettingsHeaderTableSize,30),(SettingsInitialWindowSize,20)]+fromSettings :: Settings -> [(SettingsKeyId,SettingsValue)]+fromSettings = map (second fromJust) . filter (isJust.snd) . assocs++----------------------------------------------------------------++type FrameType = Word8++-- Valid frame types+data FrameTypeId = FrameData+ | FrameHeaders+ | FramePriority+ | FrameRSTStream+ | FrameSettings+ | FramePushPromise+ | FramePing+ | FrameGoAway+ | FrameWindowUpdate+ | FrameContinuation+ deriving (Show, Eq, Ord, Enum, Bounded, Ix)++-- |+--+-- >>> fromFrameTypeId FrameData+-- 0+-- >>> fromFrameTypeId FrameContinuation+-- 9+fromFrameTypeId :: FrameTypeId -> FrameType+fromFrameTypeId = fromIntegral . fromEnum++minFrameType :: FrameType+minFrameType = fromIntegral $ fromEnum (minBound :: FrameTypeId)++maxFrameType :: FrameType+maxFrameType = fromIntegral $ fromEnum (maxBound :: FrameTypeId)++-- |+--+-- >>> toFrameTypeId 0+-- Just FrameData+-- >>> toFrameTypeId 9+-- Just FrameContinuation+-- >>> toFrameTypeId 10+-- Nothing+toFrameTypeId :: FrameType -> Maybe FrameTypeId+toFrameTypeId x+ | minFrameType <= x && x <= maxFrameType = Just . toEnum . fromIntegral $ x+ | otherwise = Nothing++----------------------------------------------------------------++type PayloadLength = Int -- Word24 but Int is more natural++maxPayloadLength :: PayloadLength+maxPayloadLength = 2^(14::Int)++----------------------------------------------------------------+-- Flags++type FrameFlags = Word8++defaultFlags :: FrameFlags+defaultFlags = 0++-- |+-- >>> testEndStream 0x1+-- True+testEndStream :: FrameFlags -> Bool+testEndStream x = x `testBit` 0++-- |+-- >>> testAck 0x1+-- True+testAck :: FrameFlags -> Bool+testAck x = x `testBit` 0 -- fixme: is the spec intentional?++-- |+-- >>> testEndHeader 0x4+-- True+testEndHeader :: FrameFlags -> Bool+testEndHeader x = x `testBit` 2++-- |+-- >>> testPadded 0x8+-- True+testPadded :: FrameFlags -> Bool+testPadded x = x `testBit` 3++-- |+-- >>> testPriority 0x20+-- True+testPriority :: FrameFlags -> Bool+testPriority x = x `testBit` 5++-- |+-- >>> setEndStream 0+-- 1+setEndStream :: FrameFlags -> FrameFlags+setEndStream x = x `setBit` 0++-- |+-- >>> setAck 0+-- 1+setAck :: FrameFlags -> FrameFlags+setAck x = x `setBit` 0 -- fixme: is the spec intentional?++-- |+-- >>> setEndHeader 0+-- 4+setEndHeader :: FrameFlags -> FrameFlags+setEndHeader x = x `setBit` 2++-- |+-- >>> setPadded 0+-- 8+setPadded :: FrameFlags -> FrameFlags+setPadded x = x `setBit` 3++-- |+-- >>> setPriority 0+-- 32+setPriority :: FrameFlags -> FrameFlags+setPriority x = x `setBit` 5++----------------------------------------------------------------++newtype StreamIdentifier = StreamIdentifier Word32 deriving (Show, Read, Eq)+type StreamDependency = StreamIdentifier+type LastStreamId = StreamIdentifier+type PromisedStreamId = StreamIdentifier++toStreamIdentifier :: Word32 -> StreamIdentifier+toStreamIdentifier w = StreamIdentifier (w `clearBit` 31)++fromStreamIdentifier :: StreamIdentifier -> Word32+fromStreamIdentifier (StreamIdentifier w32) = w32++testExclusive :: Word32 -> Bool+testExclusive w = w `testBit` 31++setExclusive :: Word32 -> Word32+setExclusive w = w `setBit` 31++streamIdentifierForSeetings :: StreamIdentifier+streamIdentifierForSeetings = StreamIdentifier 0++----------------------------------------------------------------++type WindowSizeIncrement = Word32+type HeaderBlockFragment = ByteString+type Padding = ByteString++----------------------------------------------------------------++data Frame = Frame+ { frameHeader :: FrameHeader+ , framePayload :: FramePayload+ } deriving (Show, Read, Eq)++-- A complete frame header+data FrameHeader = FrameHeader+ { payloadLength :: PayloadLength+ , flags :: FrameFlags+ , streamId :: StreamIdentifier+ } deriving (Show, Read, Eq)++data FramePayload =+ DataFrame ByteString+ | HeadersFrame (Maybe Priority) HeaderBlockFragment+ | PriorityFrame Priority+ | RSTStreamFrame ErrorCodeId+ | SettingsFrame Settings+ | PushPromiseFrame PromisedStreamId HeaderBlockFragment+ | PingFrame ByteString+ | GoAwayFrame LastStreamId ErrorCodeId ByteString+ | WindowUpdateFrame WindowSizeIncrement+ | ContinuationFrame HeaderBlockFragment+ | UnknownFrame FrameType ByteString+ deriving (Show, Read, Eq)++----------------------------------------------------------------++framePayloadToFrameType :: FramePayload -> FrameType+framePayloadToFrameType (DataFrame _) = fromFrameTypeId FrameData+framePayloadToFrameType (HeadersFrame _ _) = fromFrameTypeId FrameHeaders+framePayloadToFrameType (PriorityFrame _) = fromFrameTypeId FramePriority+framePayloadToFrameType (RSTStreamFrame _) = fromFrameTypeId FrameRSTStream+framePayloadToFrameType (SettingsFrame _) = fromFrameTypeId FrameSettings+framePayloadToFrameType (PushPromiseFrame _ _) = fromFrameTypeId FramePushPromise+framePayloadToFrameType (PingFrame _) = fromFrameTypeId FramePing+framePayloadToFrameType (GoAwayFrame _ _ _) = fromFrameTypeId FrameGoAway+framePayloadToFrameType (WindowUpdateFrame _) = fromFrameTypeId FrameWindowUpdate+framePayloadToFrameType (ContinuationFrame _) = fromFrameTypeId FrameContinuation+framePayloadToFrameType (UnknownFrame w8 _) = w8
http2.cabal view
@@ -1,20 +1,33 @@ Name: http2-Version: 0.5.0+Version: 0.6.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3 License-File: LICENSE Synopsis: HTTP/2.0 library including HPACK Description: HTTP/2.0 library including HPACK.- Currently only HPACK 09 is supported.+ Currently HTTP/2 14 framing and HPACK 09 is supported. Category: Network Cabal-Version: >= 1.10 Build-Type: Simple +----------------------------------------------------------------++Source-Repository head+ Type: git+ Location: git://github.com/kazu-yamamoto/http2++Flag devel+ Description: Development commands+ Default: False++----------------------------------------------------------------+ Library Default-Language: Haskell2010 GHC-Options: -Wall Exposed-Modules: Network.HPACK+ Network.HTTP2 Other-Modules: Network.HPACK.Builder Network.HPACK.Builder.Word8 Network.HPACK.Context@@ -40,7 +53,12 @@ Network.HPACK.Table.HashPSQ Network.HPACK.Table.Static Network.HPACK.Types+ Network.HTTP2.Decode+ Network.HTTP2.Encode+ Network.HTTP2.Types Build-Depends: base >= 4 && < 5+ , attoparsec >= 0.12.1+ , attoparsec-binary >= 0.2 , PSQueue , array , blaze-builder@@ -48,47 +66,100 @@ , containers , unordered-containers -Executable hpack-encode+----------------------------------------------------------------++Test-Suite doctest+ Type: exitcode-stdio-1.0 Default-Language: Haskell2010- HS-Source-Dirs: test-hpack, .- GHC-Options: -Wall- Main-Is: hpack-encode.hs- Other-Modules: HPACKEncode+ HS-Source-Dirs: test+ Ghc-Options: -Wall+ Main-Is: doctests.hs Build-Depends: base >= 4 && < 5+ , doctest >= 0.9.3++Test-Suite spec+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ HS-Source-Dirs: test, .+ Ghc-Options: -Wall+ Main-Is: Spec.hs+ Other-Modules: HPACK.DecodeSpec+ HPACK.HeaderBlock+ HPACK.HeaderBlockSpec+ HPACK.HuffmanSpec+ HPACK.IntegerSpec+ HTTP2.FrameSpec+ Build-Depends: base >= 4 && < 5 , PSQueue- , aeson- , aeson-pretty , array+ , attoparsec+ , attoparsec-binary , blaze-builder , bytestring , containers- , text+ , hex+ , hspec >= 1.3 , unordered-containers- , vector , word8 -Executable hpack-debug+Test-Suite hpack+ Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test-hpack, .- GHC-Options: -Wall- Main-Is: hpack-debug.hs+ Ghc-Options: -Wall+ Main-Is: Spec.hs+ Other-Modules: HPACKDecode+ HPACKSpec+ JSON Build-Depends: base >= 4 && < 5 , PSQueue , aeson+ , aeson-pretty , array , blaze-builder , bytestring , containers+ , directory+ , filepath+ , hex+ , hspec >= 1.3 , text , unordered-containers , vector , word8 -Executable hpack-stat+Test-Suite frame+ Type: exitcode-stdio-1.0 Default-Language: Haskell2010+ HS-Source-Dirs: test-frame+ GHC-Options: -Wall+ Main-Is: Spec.hs+ Other-Modules: Case+ JSON+ Build-Depends: base >= 4 && < 5+ , aeson+ , aeson-pretty+ , bytestring+ , directory+ , filepath+ , hex+ , hspec >= 1.3+ , http2+ , text+ , unordered-containers++----------------------------------------------------------------++Executable hpack-encode+ Default-Language: Haskell2010 HS-Source-Dirs: test-hpack, . GHC-Options: -Wall- Main-Is: hpack-stat.hs+ if flag(devel)+ Buildable: True+ else+ Buildable: False+ Main-Is: hpack-encode.hs+ Other-Modules: HPACKEncode Build-Depends: base >= 4 && < 5 , PSQueue , aeson@@ -97,55 +168,44 @@ , blaze-builder , bytestring , containers- , directory- , filepath+ , hex , text , unordered-containers , vector , word8 -Test-Suite doctest- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- HS-Source-Dirs: test- Ghc-Options: -Wall- Main-Is: doctests.hs- Build-Depends: base- , doctest >= 0.9.3--Test-Suite spec- Type: exitcode-stdio-1.0+Executable hpack-debug Default-Language: Haskell2010- HS-Source-Dirs: test, .- Ghc-Options: -Wall- Main-Is: Spec.hs- Other-Modules: DecodeSpec- HeaderBlock- HeaderBlockSpec- HexString- HuffmanSpec- IntegerSpec- Build-Depends: base+ HS-Source-Dirs: test-hpack, .+ GHC-Options: -Wall+ if flag(devel)+ Buildable: True+ else+ Buildable: False+ Main-Is: hpack-debug.hs+ Build-Depends: base >= 4 && < 5 , PSQueue+ , aeson , array , blaze-builder , bytestring , containers- , hspec >= 1.3+ , hex+ , text , unordered-containers+ , vector , word8 -Test-Suite hpack- Type: exitcode-stdio-1.0+Executable hpack-stat Default-Language: Haskell2010 HS-Source-Dirs: test-hpack, .- Ghc-Options: -Wall- Main-Is: Spec.hs- Other-Modules: HPACKDecode- HPACKSpec- HexString- Types- Build-Depends: base+ GHC-Options: -Wall+ if flag(devel)+ Buildable: True+ else+ Buildable: False+ Main-Is: hpack-stat.hs+ Build-Depends: base >= 4 && < 5 , PSQueue , aeson , aeson-pretty@@ -159,9 +219,23 @@ , unordered-containers , vector , word8- , hspec >= 1.3 -Source-Repository head- Type: git- Location: git://github.com/kazu-yamamoto/http2-+Executable frame-encode+ Default-Language: Haskell2010+ HS-Source-Dirs: test-frame+ GHC-Options: -Wall+ if flag(devel)+ Buildable: True+ else+ Buildable: False+ Main-Is: frame-encode.hs+ Other-Modules: Case+ JSON+ Build-Depends: base >= 4 && < 5+ , aeson+ , aeson-pretty+ , bytestring+ , hex+ , http2+ , text+ , unordered-containers
+ test-frame/Case.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}++module Case where++import Control.Applicative ((<$>))+import Data.ByteString (ByteString)+import Data.Hex+import Data.Maybe (fromJust)++import JSON+import Network.HTTP2++data CaseSource = CaseSource {+ cs_description :: String+ , cs_encodeinfo :: EncodeInfo+ , cs_payload :: FramePayload+ } deriving (Show,Read)++data CaseWire = CaseWire {+ wire_description :: String+ , wire_hex :: ByteString+ , wire_padding :: Maybe Pad+ , wire_error :: Maybe [ErrorCodeId]+ } deriving (Show,Read)++sourceToWire :: CaseSource -> CaseWire+sourceToWire CaseSource{..} = CaseWire {+ wire_description = cs_description+ , wire_hex = wire+ , wire_padding = Pad <$> encodePadding cs_encodeinfo+ , wire_error = Nothing+ }+ where+ frame = encodeFrame cs_encodeinfo cs_payload+ wire = hex frame++wireToCase :: CaseWire -> Case+wireToCase CaseWire { wire_error = Nothing, ..} = Case {+ draft = 14+ , description = wire_description+ , wire = wire_hex+ , frame = Just $ FramePad frm wire_padding+ , err = Nothing+ }+ where+ -- fromJust is unsafe+ frm = case decodeFrame defaultSettings $ fromJust $ unhex wire_hex of+ Left e -> error $ show e+ Right r -> r+wireToCase CaseWire { wire_error = Just e, ..} = Case {+ draft = 14+ , description = wire_description+ , wire = wire_hex+ , frame = Nothing+ , err = Just $ fromErrorCodeId <$> e+ }
+ test-frame/JSON.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module JSON where++import Control.Applicative ((<$>), (<*>))+import Control.Arrow (first)+import Control.Monad (mzero)+import Data.Aeson+import Data.Aeson.Types+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as B8+import Data.HashMap.Strict (union)+import Data.Maybe (fromJust)+import Data.Text (Text)+import qualified Data.Text as T++import Network.HTTP2++----------------------------------------------------------------++byteStringToText :: ByteString -> Text+byteStringToText = T.pack . B8.unpack++textToByteString :: Text -> ByteString+textToByteString = B8.pack . T.unpack++(+++) :: Value -> Value -> Value+Object x +++ Object y = Object $ x `union` y+Null +++ x = x+x +++ Null = x+_ +++ _ = error "+++"++----------------------------------------------------------------++data FramePad = FramePad {+ fpFrame :: Frame+ , fpPad :: Maybe Pad+ } deriving (Show, Read)++data Pad = Pad Padding deriving (Show, Read)++unPad :: Pad -> Padding+unPad (Pad x) = x++----------------------------------------------------------------++data Case = Case {+ draft :: Int+ , description :: String+ , wire :: ByteString+ , frame :: Maybe FramePad+ , err :: Maybe [ErrorCode]+ } deriving (Show, Read)++----------------------------------------------------------------++instance ToJSON StreamIdentifier where+ toJSON (StreamIdentifier s) = toJSON s++instance FromJSON StreamIdentifier where+ parseJSON x = StreamIdentifier <$> parseJSON x++instance ToJSON Priority where+ toJSON (Priority e s w) = object [+ "exclusive" .= e+ , "stream_dependency" .= s+ , "weight" .= w+ ]++instance FromJSON Priority where+ parseJSON (Object o) = Priority <$> o .: "exclusive"+ <*> o .: "stream_dependency"+ <*> o .: "weight"+ parseJSON _ = mzero++instance ToJSON ErrorCodeId where+ toJSON e = toJSON $ fromErrorCodeId e++instance FromJSON ErrorCodeId where+ parseJSON e = toErrorCodeId <$> parseJSON e++instance ToJSON Settings where+ toJSON settings = toJSON $ map (first fromSettingsKeyId) (fromSettings settings)++instance FromJSON Settings where+ parseJSON x = toSettings . map (first (fromJust . toSettingsKeyId)) <$> parseJSON x++instance ToJSON ByteString where+ toJSON bs = toJSON $ byteStringToText bs++instance FromJSON ByteString where+ parseJSON x = textToByteString <$> parseJSON x++----------------------------------------------------------------++instance ToJSON FramePayload where+ toJSON (DataFrame body) = object [+ "data" .= body+ ]+ toJSON (HeadersFrame mpri hdr) = object [+ "priority" .= mpri+ , "header_block_fragment" .= hdr+ ]+ toJSON (PriorityFrame pri) = object [+ "priority" .= pri+ ]+ toJSON (RSTStreamFrame e) = object [+ "error_code" .= e+ ]+ toJSON (SettingsFrame settings) = object [+ "settings" .= settings+ ]+ toJSON (PushPromiseFrame sid hdr) = object [+ "promised_stream_id" .= sid+ , "header_block_fragment" .= hdr+ ]+ toJSON (PingFrame odata) = object [+ "opaque_data" .= odata+ ]+ toJSON (GoAwayFrame sid e debug) = object [+ "last_stream_id" .= sid+ , "error_code" .= e+ , "additional_debug_data" .= debug+ ]+ toJSON (WindowUpdateFrame size) = object [+ "window_size_increment" .= size+ ]+ toJSON (ContinuationFrame hdr) = object [+ "header_block_fragment" .= hdr+ ]+ toJSON (UnknownFrame _ opaque) = object [+ "payload" .= opaque+ ]++----------------------------------------------------------------++instance ToJSON FramePad where+ toJSON FramePad{fpFrame = Frame{..},..} = object [+ "length" .= payloadLength frameHeader+ , "type" .= framePayloadToFrameType framePayload+ , "flags" .= flags frameHeader+ , "stream_identifier" .= fromStreamIdentifier (streamId frameHeader)+ , "frame_payload" .= (toJSON framePayload +++ padObj)+ ]+ where+ padObj = case toJSON fpPad of+ Null -> emptyPad+ x -> x++instance FromJSON FramePad where+ parseJSON (Object o) = do+ len <- o .: "length"+ typ <- o .: "type"+ flg <- o .: "flags"+ sid <- o .: "stream_identifier"+ pld <- o .: "frame_payload"+ (payload,mpad) <- parsePayloadPad typ pld+ return FramePad {+ fpFrame = Frame {+ frameHeader = FrameHeader len flg sid+ , framePayload = payload+ }+ , fpPad = mpad+ }+ parseJSON _ = mzero++parsePayloadPad :: FrameType -> Object -> Parser (FramePayload, Maybe Pad)+parsePayloadPad ftyp o = do+ mpad <- (Pad <$>) <$> o .:? "padding"+ payload <- parsePayload ftid o+ return (payload, mpad)+ where+ ftid = fromJust $ toFrameTypeId ftyp++parsePayload :: FrameTypeId -> Object -> Parser FramePayload+parsePayload FrameData o = DataFrame <$> o .: "data"+parsePayload FrameHeaders o = HeadersFrame <$> o .: "priority"+ <*> o .: "header_block_fragment"+parsePayload FramePriority o = PriorityFrame <$> o .: "priority"+parsePayload FrameRSTStream o = RSTStreamFrame <$> o .: "error_code"+parsePayload FrameSettings o = SettingsFrame <$> o .: "settings"+parsePayload FramePushPromise o = PushPromiseFrame <$> o .: "promised_stream_id"+ <*> o .: "header_block_fragment"+parsePayload FramePing o = PingFrame <$> o .: "opaque_data"+parsePayload FrameGoAway o = GoAwayFrame <$> o .: "last_stream_id"+ <*> o .: "error_code"+ <*> o .: "additional_debug_data"+parsePayload FrameWindowUpdate o = WindowUpdateFrame <$> o .: "window_size_increment"+parsePayload FrameContinuation o = ContinuationFrame <$> o .: "header_block_fragment"++instance ToJSON Pad where+ toJSON (Pad padding) = object [+ "padding_length" .= BS.length padding+ , "padding" .= padding+ ]++emptyPad :: Value+emptyPad = object [+ "padding_length" .= Null+ , "padding" .= Null+ ]++----------------------------------------------------------------++instance ToJSON Case where+ toJSON Case{..} = object [+ "draft" .= draft+ , "description" .= description+ , "wire" .= wire+ , "frame" .= frame+ , "error" .= err+ ]++instance FromJSON Case where+ parseJSON (Object o) = Case <$> o .: "draft"+ <*> o .: "description"+ <*> o .: "wire"+ <*> o .:? "frame"+ <*> o .:? "error"+ parseJSON _ = mzero
+ test-frame/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test-frame/frame-encode.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}++module Main where++import Data.Aeson+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy.Char8 as BL+import System.Environment (getArgs)++import Case++main :: IO ()+main = do+ args <- getArgs+ xs <- getContents+ if length args /= 0 then -- "-s"+ printWire xs+ else+ printJSON xs++printWire :: String -> IO ()+printWire = print . sourceToWire . read++printJSON :: String -> IO ()+printJSON = BL.putStrLn . encodePretty . toJSON . wireToCase . read
test-hpack/HPACKDecode.hs view
@@ -12,14 +12,14 @@ import Control.Exception import Control.Monad (when) import qualified Data.ByteString.Char8 as B8+import Data.Hex import Data.List (sort) import Network.HPACK import Network.HPACK.Context import Network.HPACK.Context.HeaderList import Network.HPACK.HeaderBlock -import HexString-import Types+import JSON data Conf = Conf { debug :: Bool@@ -59,7 +59,7 @@ putStrLn "---- Input context" printContext dctx putStrLn "---- Input Hex"- B8.putStrLn hex+ B8.putStrLn wirehex putStrLn "---- Input header block" print bshd' dctx0 <- case size c of@@ -73,11 +73,11 @@ if pass then return $ Right (dctx') else- return $ Left $ "Headers are different in " ++ B8.unpack hex ++ ":\n" ++ show hd ++ "\n" ++ show hs ++ "\n" ++ show hs'+ return $ Left $ "Headers are different in " ++ B8.unpack wirehex ++ ":\n" ++ show hd ++ "\n" ++ show hs ++ "\n" ++ show hs' where- hex = wire c- inp = fromHexString hex+ wirehex = wire c+ Just inp = unhex wirehex hs = headers c bshd = fromByteStreamDebug inp hd = map snd <$> bshd- bshd' = map (\(x,y)->(toHexString x,y)) <$> bshd+ bshd' = map (\(x,y)->(hex x,y)) <$> bshd
test-hpack/HPACKEncode.hs view
@@ -9,11 +9,11 @@ import Control.Monad (when) import Data.ByteString (ByteString)+import Data.Hex import Network.HPACK import Network.HPACK.Context -import HexString-import Types+import JSON data Conf = Conf { debug :: Bool@@ -34,9 +34,9 @@ -> [ByteString] -> IO [ByteString] testLoop _ [] _ hexs = return $ reverse hexs-testLoop conf (c:cs) ectx hexs = do- (ectx',hex) <- test conf c ectx- testLoop conf cs ectx' (hex:hexs)+testLoop conf (c:cs) ectx hxs = do+ (ectx',hx) <- test conf c ectx+ testLoop conf cs ectx' (hx:hxs) test :: Conf -> Case@@ -44,7 +44,7 @@ -> IO (Context, ByteString) test conf c ectx = do (ectx',out) <- enc conf ectx hs- let hex' = toHexString out+ let hex' = hex out when (debug conf) $ do putStrLn "---- Output context" printContext ectx'
test-hpack/HPACKSpec.hs view
@@ -9,7 +9,7 @@ import System.FilePath ((</>)) import Test.Hspec -import Types+import JSON import HPACKDecode testDir :: FilePath
− test-hpack/HexString.hs
@@ -1,53 +0,0 @@-module HexString (fromHexString, toHexString) where--import Data.ByteString.Internal (ByteString(..), unsafeCreate)-import Data.Word8-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (plusPtr)-import Foreign.Storable (peek, poke, peekByteOff, pokeByteOff)--fromHexString :: ByteString -> ByteString-fromHexString (PS fptr off len) = unsafeCreate size $ \dst ->- withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0- where- size = len `div` 2- go from to bytes- | bytes == size = return ()- | otherwise = do- w1 <- peek from- w2 <- peekByteOff from 1- let w = hex2w (w1,w2)- poke to w- go (from `plusPtr` 2) (to `plusPtr` 1) (bytes + 1)--hex2w :: (Word8, Word8) -> Word8-hex2w (w1,w2) = h2w w1 * 16 + h2w w2--h2w :: Word8 -> Word8-h2w w- | isDigit w = w - _0- | otherwise = w - _a + 10--toHexString :: ByteString -> ByteString-toHexString (PS fptr off len) = unsafeCreate size $ \dst ->- withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0- where- size = len * 2- go from to bytes- | bytes == len = return ()- | otherwise = do- w <- peek from- let (w1,w2) = w2hex w- poke to w1- pokeByteOff to 1 w2- go (from `plusPtr` 1) (to `plusPtr` 2) (bytes + 1)--w2hex :: Word8 -> (Word8, Word8)-w2hex w = (w2h w1, w2h w2)- where- (w1,w2) = w `divMod` 16--w2h :: Word8 -> Word8-w2h w- | w < 10 = w + _0- | otherwise = w + _a - 10
+ test-hpack/JSON.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module JSON (+ Test(..)+ , Case(..)+ , HeaderList+ ) where++import Control.Applicative+import Control.Monad (mzero)+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import qualified Data.HashMap.Strict as H+import Data.Text (Text)+import qualified Data.Text as T+import Data.Vector ((!))+import qualified Data.Vector as V+import Network.HPACK++{-+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy as BL++main :: IO ()+main = do+ bs <- BL.getContents+ let Right x = eitherDecode bs :: Either String Test+ BL.putStr $ encodePretty x+-}++data Test = Test {+ draft :: Int+ , description :: String+ , cases :: [Case]+ } deriving Show++data Case = Case {+ size :: Maybe Int+ , wire :: ByteString+ , headers :: HeaderList+ , seqno :: Maybe Int+ } deriving Show++instance FromJSON Test where+ parseJSON (Object o) = Test <$> o .: "draft"+ <*> o .: "description"+ <*> o .: "cases"+ parseJSON _ = mzero++instance ToJSON Test where+ toJSON (Test n desc cs) = object ["draft" .= n+ ,"description" .= desc+ ,"cases" .= cs+ ]++instance FromJSON Case where+ parseJSON (Object o) = Case <$> o .:? "header_table_size"+ <*> (textToByteString <$> (o .: "wire"))+ <*> o .: "headers"+ <*> o .:? "seqno"+ parseJSON _ = mzero++instance ToJSON Case where+ toJSON (Case (Just siz) w hs no) = object ["header_table_size" .= siz+ ,"wire" .= byteStringToText w+ ,"headers" .= hs+ ,"seqno" .= no+ ]+ toJSON (Case Nothing w hs no) = object ["wire" .= byteStringToText w+ ,"headers" .= hs+ ,"seqno" .= no+ ]++instance FromJSON HeaderList where+ parseJSON (Array a) = mapM parseJSON $ V.toList a+ parseJSON _ = mzero++instance ToJSON HeaderList where+ toJSON hs = toJSON $ map toJSON hs++instance FromJSON Header where+ parseJSON (Array a) = pure (toKey (a ! 0), toValue (a ! 1)) -- old+ where+ toKey = toValue+ parseJSON (Object o) = pure (textToByteString k, toValue v) -- new+ where+ (k,v) = head $ H.toList o+ parseJSON _ = mzero++instance ToJSON Header where+ toJSON (k,v) = object [ byteStringToText k .= byteStringToText v ]++textToByteString :: Text -> ByteString+textToByteString = B8.pack . T.unpack++byteStringToText :: ByteString -> Text+byteStringToText = T.pack . B8.unpack++toValue :: Value -> ByteString+toValue (String s) = textToByteString s+toValue _ = error "toValue"
− test-hpack/Types.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Types (- Test(..)- , Case(..)- , HeaderList- ) where--import Control.Applicative-import Control.Monad (mzero)-import Data.Aeson-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B8-import qualified Data.HashMap.Strict as H-import Data.Text (Text)-import qualified Data.Text as T-import Data.Vector ((!))-import qualified Data.Vector as V-import Network.HPACK--{--import Data.Aeson.Encode.Pretty (encodePretty)-import qualified Data.ByteString.Lazy as BL--main :: IO ()-main = do- bs <- BL.getContents- let Right x = eitherDecode bs :: Either String Test- BL.putStr $ encodePretty x--}--data Test = Test {- draft :: Int- , description :: String- , cases :: [Case]- } deriving Show--data Case = Case {- size :: Maybe Int- , wire :: ByteString- , headers :: HeaderList- , seqno :: Maybe Int- } deriving Show--instance FromJSON Test where- parseJSON (Object o) = Test <$> o .: "draft"- <*> o .: "description"- <*> o .: "cases"- parseJSON _ = mzero--instance ToJSON Test where- toJSON (Test n desc cs) = object ["draft" .= n- ,"description" .= desc- ,"cases" .= cs- ]--instance FromJSON Case where- parseJSON (Object o) = Case <$> o .:? "header_table_size"- <*> (textToByteString <$> (o .: "wire"))- <*> o .: "headers"- <*> o .:? "seqno"- parseJSON _ = mzero--instance ToJSON Case where- toJSON (Case (Just siz) w hs no) = object ["header_table_size" .= siz- ,"wire" .= byteStringToText w- ,"headers" .= hs- ,"seqno" .= no- ]- toJSON (Case Nothing w hs no) = object ["wire" .= byteStringToText w- ,"headers" .= hs- ,"seqno" .= no- ]--instance FromJSON HeaderList where- parseJSON (Array a) = mapM parseJSON $ V.toList a- parseJSON _ = mzero--instance ToJSON HeaderList where- toJSON hs = toJSON $ map toJSON hs--instance FromJSON Header where- parseJSON (Array a) = pure (toKey (a ! 0), toValue (a ! 1)) -- old- where- toKey = toValue- parseJSON (Object o) = pure (textToByteString k, toValue v) -- new- where- (k,v) = head $ H.toList o- parseJSON _ = mzero--instance ToJSON Header where- toJSON (k,v) = object [ byteStringToText k .= byteStringToText v ]--textToByteString :: Text -> ByteString-textToByteString = B8.pack . T.unpack--byteStringToText :: ByteString -> Text-byteStringToText = T.pack . B8.unpack--toValue :: Value -> ByteString-toValue (String s) = textToByteString s-toValue _ = error "toValue"
test-hpack/hpack-debug.hs view
@@ -3,7 +3,7 @@ import Data.Aeson (eitherDecode) import qualified Data.ByteString.Lazy as BL -import Types+import JSON import HPACKDecode main :: IO ()
test-hpack/hpack-encode.hs view
@@ -9,7 +9,7 @@ import System.IO (hPutStrLn, stderr) import HPACKEncode-import Types+import JSON main :: IO () main = do
test-hpack/hpack-stat.hs view
@@ -11,7 +11,7 @@ import System.FilePath import Control.Monad -import Types+import JSON hdir :: FilePath hdir = "test-hpack/hpack-test-case/nghttp2"
− test/DecodeSpec.hs
@@ -1,25 +0,0 @@-module DecodeSpec where--import Network.HPACK.Context-import Network.HPACK.HeaderBlock-import Test.Hspec--import HeaderBlock--spec :: Spec-spec = do- describe "fromHeaderBlock" $ do- it "decodes HeaderList in request" $ do- (c1,h1) <- newContextForDecoding 4096 >>= flip fromHeaderBlock d41- h1 `shouldBe` d41h- (c2,h2) <- fromHeaderBlock c1 d42- h2 `shouldBe` d42h- (_,h3) <- fromHeaderBlock c2 d43- h3 `shouldBe` d43h- it "decodes HeaderList in response" $ do- (c1,h1) <- newContextForDecoding 256 >>= flip fromHeaderBlock d61- h1 `shouldBe` d61h- (c2,h2) <- fromHeaderBlock c1 d62- h2 `shouldBe` d62h- (_,h3) <- fromHeaderBlock c2 d63- h3 `shouldBe` d63h
+ test/HPACK/DecodeSpec.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module HPACK.DecodeSpec where++import Network.HPACK.Context+import Network.HPACK.HeaderBlock+import Test.Hspec++import HPACK.HeaderBlock++spec :: Spec+spec = do+ describe "fromHeaderBlock" $ do+ it "decodes HeaderList in request" $ do+ (c1,h1) <- newContextForDecoding 4096 >>= flip fromHeaderBlock d41+ h1 `shouldBe` d41h+ (c2,h2) <- fromHeaderBlock c1 d42+ h2 `shouldBe` d42h+ (_,h3) <- fromHeaderBlock c2 d43+ h3 `shouldBe` d43h+ it "decodes HeaderList in response" $ do+ (c1,h1) <- newContextForDecoding 256 >>= flip fromHeaderBlock d61+ h1 `shouldBe` d61h+ (c2,h2) <- fromHeaderBlock c1 d62+ h2 `shouldBe` d62h+ (_,h3) <- fromHeaderBlock c2 d63+ h3 `shouldBe` d63h+ it "decodes HeaderList even if an entry is larger than HeaderTable" $ do+ (c1,h1) <- newContextForDecoding 64 >>= flip fromHeaderBlock hb1+ h1 `shouldBe` hl1+ isContextTableEmpty c1 `shouldBe` True++hb1 :: HeaderBlock+hb1 = [Literal Add (Lit "custom-key") "custom-value"+ -- this is larger than the header table+ ,Literal Add (Lit "loooooooooooooooooooooooooooooooooooooooooog-key")+ "loooooooooooooooooooooooooooooooooooooooooog-value"+ ]++hl1 :: HeaderList+hl1 = [("custom-key","custom-value")+ ,("loooooooooooooooooooooooooooooooooooooooooog-key"+ ,"loooooooooooooooooooooooooooooooooooooooooog-value")+ ]
+ test/HPACK/HeaderBlock.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}++module HPACK.HeaderBlock where++import Data.Hex+import Data.Maybe (fromJust)+import Network.HPACK.Context+import Network.HPACK.HeaderBlock+import Network.HPACK.Types++fromHexString :: ByteStream -> ByteStream+fromHexString = fromJust . unhex++----------------------------------------------------------------++d41 :: HeaderBlock+d41 = [+ Indexed 2+ , Indexed 6+ , Indexed 4+ , Literal Add (Idx 1) "www.example.com"+ ]++d41h :: HeaderList+d41h = [(":method","GET")+ ,(":scheme","http")+ ,(":path","/")+ ,(":authority","www.example.com")+ ]++d41b :: ByteStream+d41b = fromHexString "828684418cf1e3c2e5f23a6ba0ab90f4ff"++d42 :: HeaderBlock+d42 = [+ Indexed 2+ , Indexed 6+ , Indexed 4+ , Indexed 62+ , Literal Add (Idx 24) "no-cache"+ ]++d42h :: HeaderList+d42h = [(":method","GET")+ ,(":scheme","http")+ ,(":path","/")+ ,(":authority","www.example.com")+ ,("cache-control","no-cache")]++d42b :: ByteStream+d42b = fromHexString "828684be5886a8eb10649cbf"++d43 :: HeaderBlock+d43 = [+ Indexed 2+ , Indexed 7+ , Indexed 5+ , Indexed 63+ , Literal Add (Lit "custom-key") "custom-value"+ ]++d43h :: HeaderList+d43h = [(":method","GET")+ ,(":scheme","https")+ ,(":path","/index.html")+ ,(":authority","www.example.com")+ ,("custom-key","custom-value")+ ]++d43b :: ByteStream+d43b = fromHexString "828785bf408825a849e95ba97d7f8925a849e95bb8e8b4bf"++----------------------------------------------------------------++d61 :: HeaderBlock+d61 = [+ Literal Add (Idx 8) "302"+ , Literal Add (Idx 24) "private"+ , Literal Add (Idx 33) "Mon, 21 Oct 2013 20:13:21 GMT"+ , Literal Add (Idx 46) "https://www.example.com"+ ]++d61h :: HeaderList+d61h = [(":status","302")+ ,("cache-control","private")+ ,("date","Mon, 21 Oct 2013 20:13:21 GMT")+ ,("location","https://www.example.com")+ ]++d61b :: ByteStream+d61b = fromHexString "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3"++d62 :: HeaderBlock+d62 = [+ Literal Add (Idx 8) "307"+ , Indexed 65+ , Indexed 64+ , Indexed 63+ ]++d62h :: HeaderList+d62h = [(":status","307")+ ,("cache-control","private")+ ,("date","Mon, 21 Oct 2013 20:13:21 GMT")+ ,("location","https://www.example.com")+ ]++d62b :: ByteStream+d62b = fromHexString "4883640effc1c0bf"++d63 :: HeaderBlock+d63 = [+ Indexed 8+ , Indexed 65+ , Literal Add (Idx 33) "Mon, 21 Oct 2013 20:13:22 GMT"+ , Indexed 64+ , Literal Add (Idx 26) "gzip"+ ,Literal Add (Idx 55) "foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1"+ ]++d63h :: HeaderList+d63h = [(":status","200")+ ,("cache-control","private")+ ,("date","Mon, 21 Oct 2013 20:13:22 GMT")+ ,("location","https://www.example.com")+ ,("content-encoding","gzip")+ ,("set-cookie","foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1")]++d63b :: ByteStream+d63b = fromHexString "88c16196d07abe941054d444a8200595040b8166e084a62d1bffc05a839bd9ab77ad94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007"
+ test/HPACK/HeaderBlockSpec.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}++module HPACK.HeaderBlockSpec where++import qualified Data.ByteString.Char8 as BS+import Network.HPACK.HeaderBlock+import Test.Hspec+import Test.Hspec.QuickCheck++import HPACK.HeaderBlock++spec :: Spec+spec = do+ describe "toByteStream" $ do+ it "encodes HeaderBlock" $ do+ toByteStream True d41 `shouldBe` d41b+ toByteStream True d42 `shouldBe` d42b+ toByteStream True d43 `shouldBe` d43b+ toByteStream True d61 `shouldBe` d61b+ toByteStream True d62 `shouldBe` d62b+ toByteStream True d63 `shouldBe` d63b++ describe "fromByteStream" $ do+ it "encodes HeaderBlock" $ do+ fromByteStream d41b `shouldBe` Right d41+ fromByteStream d42b `shouldBe` Right d42+ fromByteStream d43b `shouldBe` Right d43+ fromByteStream d61b `shouldBe` Right d61+ fromByteStream d62b `shouldBe` Right d62+ fromByteStream d63b `shouldBe` Right d63++ describe "toByteStream & fromByteStream" $ do+ prop "duality for request" $ \k v -> do+ let key = BS.pack ('k':k)+ val = BS.pack ('v':v)+ hb = [Literal Add (Lit key) val]+ fromByteStream (toByteStream True hb) `shouldBe` Right hb+ prop "duality for response" $ \v -> do+ let val = BS.pack ('v':v)+ hb = [Literal Add (Idx 3) val]+ fromByteStream (toByteStream True hb) `shouldBe` Right hb
+ test/HPACK/HuffmanSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module HPACK.HuffmanSpec where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS+import Data.Char (toLower)+import Data.Hex+import Data.Maybe (fromJust)+import Network.HPACK+import Network.HPACK.Huffman+import Test.Hspec+import Test.Hspec.QuickCheck++testData :: [(ByteString, ByteString)]+testData = [+ ("", "")+ , ("www.example.com", "f1e3c2e5f23a6ba0ab90f4ff")+ , ("no-cache", "a8eb10649cbf")+ , ("custom-key", "25a849e95ba97d7f")+ , ("custom-value", "25a849e95bb8e8b4bf")+ , ("private", "aec3771a4b")+ , ("Mon, 21 Oct 2013 20:13:21 GMT", "d07abe941054d444a8200595040b8166e082a62d1bff")+ , ("https://www.example.com", "9d29ad171863c78f0b97c8e9ae82ae43d3")+ , ("Mon, 21 Oct 2013 20:13:22 GMT", "d07abe941054d444a8200595040b8166e084a62d1bff")+ , ("gzip", "9bd9ab")+ , ("foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1", "94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007")+ ]++shouldBeEncoded :: ByteString -> ByteString -> Expectation+shouldBeEncoded inp out = enc inp `shouldBe` out+ where+ enc = BS.map toLower . hex . encode++shouldBeDecoded :: ByteString -> Either DecodeError ByteString -> Expectation+shouldBeDecoded inp out = dec inp `shouldBe` out+ where+ dec = decode . fromJust . unhex++spec :: Spec+spec = do+ describe "encode and decode" $ do+ prop "duality" $ \cs ->+ let bs = BS.pack cs+ in decode (encode bs) == Right bs+ describe "encode" $ do+ it "encodes" $ do+ mapM_ (\(x,y) -> x `shouldBeEncoded` y) testData+ describe "decode" $ do+ it "decodes" $ do+ "ff" `shouldBeDecoded` Left TooLongEos+ "ffffea" `shouldBeDecoded` Right "\9"+ "ffffeaff" `shouldBeDecoded` Left TooLongEos+ mapM_ (\(x,y) -> y `shouldBeDecoded` Right x) testData
+ test/HPACK/IntegerSpec.hs view
@@ -0,0 +1,24 @@+module HPACK.IntegerSpec where++import Network.HPACK.HeaderBlock.Integer+import Test.Hspec+import Test.Hspec.QuickCheck+import qualified Data.ByteString as BS++dual :: Int -> Int -> Bool+dual n i = decode n w (BS.pack ws) == x+ where+ w:ws = encode n x+ x = abs i++spec :: Spec+spec = do+ describe "encode and decode" $ do+ prop "duality" $ dual 1+ prop "duality" $ dual 2+ prop "duality" $ dual 3+ prop "duality" $ dual 4+ prop "duality" $ dual 5+ prop "duality" $ dual 6+ prop "duality" $ dual 7+ prop "duality" $ dual 8
+ test/HTTP2/FrameSpec.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE OverloadedStrings #-}++module HTTP2.FrameSpec where++import Test.Hspec++import Data.ByteString.Char8 ()+import Network.HTTP2.Decode+import Network.HTTP2.Encode+import Network.HTTP2.Types++spec :: Spec+spec = do+ describe "encodeFrameHeader & decodeFrameHeader" $ do+ it "encode/decodes frames properly" $ do+ let header = FrameHeader {+ payloadLength = 500+ , flags = defaultFlags+ , streamId = StreamIdentifier 10+ }+ ftyp = fromFrameTypeId FramePriority+ wire = encodeFrameHeader ftyp header+ Right fibHeader = decodeFrameHeader defaultSettings wire+ fibHeader `shouldBe` (ftyp, header)++ describe "encodeFrame & decodeFrame" $ do+ it "encode/decodes frames properly" $ do+ let einfo = EncodeInfo {+ encodeFlags = defaultFlags+ , encodeStreamId = StreamIdentifier 2+ , encodePadding = Nothing+ }+ payload = DataFrame "Hello, world!"+ wire = encodeFrame einfo payload+ Right (frame,_) = decodeFrame defaultSettings wire+ payload' = framePayload frame+ payload' `shouldBe` payload+ it "encode/decodes padded frames properly" $ do+ let einfo = EncodeInfo {+ encodeFlags = defaultFlags+ , encodeStreamId = StreamIdentifier 2+ , encodePadding = Just "padding!"+ }+ payload = DataFrame "Hello, world!"+ wire = encodeFrame einfo payload+ Right (frame,_) = decodeFrame defaultSettings wire+ payload' = framePayload frame+ payload' `shouldBe` payload
− test/HeaderBlock.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module HeaderBlock where--import Network.HPACK.Context-import Network.HPACK.HeaderBlock-import Network.HPACK.Types--import HexString--------------------------------------------------------------------d41 :: HeaderBlock-d41 = [- Indexed 2- , Indexed 6- , Indexed 4- , Literal Add (Idx 1) "www.example.com"- ]--d41h :: HeaderList-d41h = [(":method","GET")- ,(":scheme","http")- ,(":path","/")- ,(":authority","www.example.com")- ]--d41b :: ByteStream-d41b = fromHexString "828684418cf1e3c2e5f23a6ba0ab90f4ff"--d42 :: HeaderBlock-d42 = [- Indexed 2- , Indexed 6- , Indexed 4- , Indexed 62- , Literal Add (Idx 24) "no-cache"- ]--d42h :: HeaderList-d42h = [(":method","GET")- ,(":scheme","http")- ,(":path","/")- ,(":authority","www.example.com")- ,("cache-control","no-cache")]--d42b :: ByteStream-d42b = fromHexString "828684be5886a8eb10649cbf"--d43 :: HeaderBlock-d43 = [- Indexed 2- , Indexed 7- , Indexed 5- , Indexed 63- , Literal Add (Lit "custom-key") "custom-value"- ]--d43h :: HeaderList-d43h = [(":method","GET")- ,(":scheme","https")- ,(":path","/index.html")- ,(":authority","www.example.com")- ,("custom-key","custom-value")- ]--d43b :: ByteStream-d43b = fromHexString "828785bf408825a849e95ba97d7f8925a849e95bb8e8b4bf"--------------------------------------------------------------------d61 :: HeaderBlock-d61 = [- Literal Add (Idx 8) "302"- , Literal Add (Idx 24) "private"- , Literal Add (Idx 33) "Mon, 21 Oct 2013 20:13:21 GMT"- , Literal Add (Idx 46) "https://www.example.com"- ]--d61h :: HeaderList-d61h = [(":status","302")- ,("cache-control","private")- ,("date","Mon, 21 Oct 2013 20:13:21 GMT")- ,("location","https://www.example.com")- ]--d61b :: ByteStream-d61b = fromHexString "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3"--d62 :: HeaderBlock-d62 = [- Literal Add (Idx 8) "307"- , Indexed 65- , Indexed 64- , Indexed 63- ]--d62h :: HeaderList-d62h = [(":status","307")- ,("cache-control","private")- ,("date","Mon, 21 Oct 2013 20:13:21 GMT")- ,("location","https://www.example.com")- ]--d62b :: ByteStream-d62b = fromHexString "4883640effc1c0bf"--d63 :: HeaderBlock-d63 = [- Indexed 8- , Indexed 65- , Literal Add (Idx 33) "Mon, 21 Oct 2013 20:13:22 GMT"- , Indexed 64- , Literal Add (Idx 26) "gzip"- ,Literal Add (Idx 55) "foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1"- ]--d63h :: HeaderList-d63h = [(":status","200")- ,("cache-control","private")- ,("date","Mon, 21 Oct 2013 20:13:22 GMT")- ,("location","https://www.example.com")- ,("content-encoding","gzip")- ,("set-cookie","foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1")]--d63b :: ByteStream-d63b = fromHexString "88c16196d07abe941054d444a8200595040b8166e084a62d1bffc05a839bd9ab77ad94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007"
− test/HeaderBlockSpec.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module HeaderBlockSpec where--import qualified Data.ByteString.Char8 as BS-import Network.HPACK.HeaderBlock-import Test.Hspec-import Test.Hspec.QuickCheck--import HeaderBlock--spec :: Spec-spec = do- describe "toByteStream" $ do- it "encodes HeaderBlock" $ do- toByteStream True d41 `shouldBe` d41b- toByteStream True d42 `shouldBe` d42b- toByteStream True d43 `shouldBe` d43b- toByteStream True d61 `shouldBe` d61b- toByteStream True d62 `shouldBe` d62b- toByteStream True d63 `shouldBe` d63b-- describe "fromByteStream" $ do- it "encodes HeaderBlock" $ do- fromByteStream d41b `shouldBe` Right d41- fromByteStream d42b `shouldBe` Right d42- fromByteStream d43b `shouldBe` Right d43- fromByteStream d61b `shouldBe` Right d61- fromByteStream d62b `shouldBe` Right d62- fromByteStream d63b `shouldBe` Right d63-- describe "toByteStream & fromByteStream" $ do- prop "duality for request" $ \k v -> do- let key = BS.pack ('k':k)- val = BS.pack ('v':v)- hb = [Literal Add (Lit key) val]- fromByteStream (toByteStream True hb) `shouldBe` Right hb- prop "duality for response" $ \v -> do- let val = BS.pack ('v':v)- hb = [Literal Add (Idx 3) val]- fromByteStream (toByteStream True hb) `shouldBe` Right hb
− test/HexString.hs
@@ -1,53 +0,0 @@-module HexString (fromHexString, toHexString) where--import Data.ByteString.Internal (ByteString(..), unsafeCreate)-import Data.Word8-import Foreign.ForeignPtr (withForeignPtr)-import Foreign.Ptr (plusPtr)-import Foreign.Storable (peek, poke, peekByteOff, pokeByteOff)--fromHexString :: ByteString -> ByteString-fromHexString (PS fptr off len) = unsafeCreate size $ \dst ->- withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0- where- size = len `div` 2- go from to bytes- | bytes == size = return ()- | otherwise = do- w1 <- peek from- w2 <- peekByteOff from 1- let w = hex2w (w1,w2)- poke to w- go (from `plusPtr` 2) (to `plusPtr` 1) (bytes + 1)--hex2w :: (Word8, Word8) -> Word8-hex2w (w1,w2) = h2w w1 * 16 + h2w w2--h2w :: Word8 -> Word8-h2w w- | isDigit w = w - _0- | otherwise = w - _a + 10--toHexString :: ByteString -> ByteString-toHexString (PS fptr off len) = unsafeCreate size $ \dst ->- withForeignPtr fptr $ \src -> go (src `plusPtr` off) dst 0- where- size = len * 2- go from to bytes- | bytes == len = return ()- | otherwise = do- w <- peek from- let (w1,w2) = w2hex w- poke to w1- pokeByteOff to 1 w2- go (from `plusPtr` 1) (to `plusPtr` 2) (bytes + 1)--w2hex :: Word8 -> (Word8, Word8)-w2hex w = (w2h w1, w2h w2)- where- (w1,w2) = w `divMod` 16--w2h :: Word8 -> Word8-w2h w- | w < 10 = w + _0- | otherwise = w + _a - 10
− test/HuffmanSpec.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module HuffmanSpec where--import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Network.HPACK-import Network.HPACK.Huffman-import Test.Hspec-import Test.Hspec.QuickCheck--import HexString--testData :: [(ByteString, ByteString)]-testData = [- ("", "")- , ("www.example.com", "f1e3c2e5f23a6ba0ab90f4ff")- , ("no-cache", "a8eb10649cbf")- , ("custom-key", "25a849e95ba97d7f")- , ("custom-value", "25a849e95bb8e8b4bf")- , ("private", "aec3771a4b")- , ("Mon, 21 Oct 2013 20:13:21 GMT", "d07abe941054d444a8200595040b8166e082a62d1bff")- , ("https://www.example.com", "9d29ad171863c78f0b97c8e9ae82ae43d3")- , ("Mon, 21 Oct 2013 20:13:22 GMT", "d07abe941054d444a8200595040b8166e084a62d1bff")- , ("gzip", "9bd9ab")- , ("foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1", "94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007")- ]--shouldBeEncoded :: ByteString -> ByteString -> Expectation-shouldBeEncoded inp out = enc inp `shouldBe` out- where- enc = toHexString . encode--shouldBeDecoded :: ByteString -> Either DecodeError ByteString -> Expectation-shouldBeDecoded inp out = dec inp `shouldBe` out- where- dec = decode . fromHexString--spec :: Spec-spec = do- describe "encode and decode" $ do- prop "duality" $ \cs ->- let bs = BS.pack cs- in decode (encode bs) == Right bs- describe "encode" $ do- it "encodes" $ do- mapM_ (\(x,y) -> x `shouldBeEncoded` y) testData- describe "decode" $ do- it "decodes" $ do- "ff" `shouldBeDecoded` Left TooLongEos- "ffffea" `shouldBeDecoded` Right "\9"- "ffffeaff" `shouldBeDecoded` Left TooLongEos- mapM_ (\(x,y) -> y `shouldBeDecoded` Right x) testData
− test/IntegerSpec.hs
@@ -1,24 +0,0 @@-module IntegerSpec where--import Network.HPACK.HeaderBlock.Integer-import Test.Hspec-import Test.Hspec.QuickCheck-import qualified Data.ByteString as BS--dual :: Int -> Int -> Bool-dual n i = decode n w (BS.pack ws) == x- where- w:ws = encode n x- x = abs i--spec :: Spec-spec = do- describe "encode and decode" $ do- prop "duality" $ dual 1- prop "duality" $ dual 2- prop "duality" $ dual 3- prop "duality" $ dual 4- prop "duality" $ dual 5- prop "duality" $ dual 6- prop "duality" $ dual 7- prop "duality" $ dual 8
test/doctests.hs view
@@ -3,7 +3,12 @@ import Test.DocTest main :: IO ()-main = doctest [- "-XOverloadedStrings"- , "Network/HPACK.hs"- ]+main = do+ doctest [+ "-XOverloadedStrings"+ , "Network/HPACK.hs"+ ]+ doctest [+ "-XOverloadedStrings"+ , "Network/HTTP2.hs"+ ]