http2 0.7.0 → 0.8.0
raw patch · 19 files changed
+542/−328 lines, 19 filesdep −attoparsecdep −attoparsec-binary
Dependencies removed: attoparsec, attoparsec-binary
Files
- Network/HPACK.hs +8/−8
- Network/HPACK/HeaderBlock.hs +3/−3
- Network/HPACK/HeaderBlock/Decode.hs +6/−6
- Network/HPACK/HeaderBlock/Encode.hs +4/−4
- Network/HPACK/Types.hs +6/−6
- Network/HTTP2.hs +80/−9
- Network/HTTP2/Decode.hs +183/−170
- Network/HTTP2/Encode.hs +20/−7
- Network/HTTP2/Internal.hs +5/−0
- Network/HTTP2/Types.hs +179/−60
- http2.cabal +3/−6
- test-frame/Case.hs +2/−4
- test-frame/JSON.hs +6/−8
- test-frame/frame-encode.hs +1/−1
- test-hpack/HPACKDecode.hs +1/−1
- test-hpack/HPACKEncode.hs +5/−5
- test/HPACK/HeaderBlock.hs +8/−7
- test/HPACK/HeaderBlockSpec.hs +17/−17
- test/HTTP2/FrameSpec.hs +5/−6
Network/HPACK.hs view
@@ -21,7 +21,6 @@ , HeaderName , HeaderValue -- * Basic types- , ByteStream , Size , Index ) where@@ -29,17 +28,18 @@ import Control.Applicative ((<$>)) import Control.Arrow (second) import Control.Exception (throwIO)-import Network.HPACK.HeaderBlock (toHeaderBlock, fromHeaderBlock, toByteStream, fromByteStream)+import Data.ByteString (ByteString)+import Network.HPACK.HeaderBlock (toHeaderBlock, fromHeaderBlock, toByteString, fromByteString) import Network.HPACK.Table (DynamicTable, Size, newDynamicTableForEncoding, newDynamicTableForDecoding) import Network.HPACK.Types ---------------------------------------------------------------- --- | HPACK encoding, from 'HeaderList' to 'ByteStream'.-type HPACKEncoding = DynamicTable -> HeaderList -> IO (DynamicTable, ByteStream)+-- | HPACK encoding, from 'HeaderList' to 'ByteString'.+type HPACKEncoding = DynamicTable -> HeaderList -> IO (DynamicTable, ByteString) --- | HPACK decoding, from 'ByteStream' to 'HeaderList'.-type HPACKDecoding = DynamicTable -> ByteStream -> IO (DynamicTable, HeaderList)+-- | HPACK decoding, from 'ByteString' to 'HeaderList'.+type HPACKDecoding = DynamicTable -> ByteString -> IO (DynamicTable, HeaderList) ---------------------------------------------------------------- @@ -48,11 +48,11 @@ encodeHeader stgy ctx hs = second toBS <$> toHeaderBlock algo ctx hs where algo = compressionAlgo stgy- toBS = toByteStream (useHuffman stgy)+ toBS = toByteString (useHuffman stgy) -- | Converting the low level format for HTTP request to 'HeaderList'. -- 'DecodeError' would be thrown. decodeHeader :: HPACKDecoding decodeHeader ctx bs = either throwIO (fromHeaderBlock ctx) ehb where- ehb = fromByteStream bs+ ehb = fromByteString bs
Network/HPACK/HeaderBlock.hs view
@@ -2,9 +2,9 @@ -- * Types for header block module Network.HPACK.HeaderBlock.HeaderField -- * Header block from/to Low level- , toByteStream- , fromByteStream- , fromByteStreamDebug+ , toByteString+ , fromByteString+ , fromByteStringDebug -- * Header block from/to header list , toHeaderBlock , fromHeaderBlock
Network/HPACK/HeaderBlock/Decode.hs view
@@ -1,6 +1,6 @@ module Network.HPACK.HeaderBlock.Decode (- fromByteStream- , fromByteStreamDebug+ fromByteString+ , fromByteStringDebug ) where import Data.Bits (testBit, clearBit, (.&.))@@ -16,8 +16,8 @@ ---------------------------------------------------------------- -- | Converting the low level format to 'HeaderBlock'.-fromByteStream :: ByteStream -> Either DecodeError HeaderBlock-fromByteStream inp = go inp empty+fromByteString :: ByteString -> Either DecodeError HeaderBlock+fromByteString inp = go inp empty where go bs builder | BS.null bs = Right $ run builder@@ -27,8 +27,8 @@ -- | Converting the low level format to 'HeaderBlock'. -- 'HeaderBlock' forms a pair with corresponding 'ByteString'.-fromByteStreamDebug :: ByteStream -> Either DecodeError [(ByteString,HeaderField)]-fromByteStreamDebug inp = go inp empty+fromByteStringDebug :: ByteString -> Either DecodeError [(ByteString,HeaderField)]+fromByteStringDebug inp = go inp empty where go bs builder | BS.null bs = Right $ run builder
Network/HPACK/HeaderBlock/Encode.hs view
@@ -1,10 +1,11 @@ module Network.HPACK.HeaderBlock.Encode (- toByteStream+ toByteString ) where import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as BB import Data.Bits (setBit)+import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.List (foldl') import Data.Monoid ((<>), mempty)@@ -12,13 +13,12 @@ import Network.HPACK.HeaderBlock.HeaderField import qualified Network.HPACK.HeaderBlock.Integer as I import qualified Network.HPACK.HeaderBlock.String as S-import Network.HPACK.Types ---------------------------------------------------------------- -- | Converting 'HeaderBlock' to the low level format.-toByteStream :: Bool -> HeaderBlock -> ByteStream-toByteStream huff hbs = BB.toByteString $ foldl' (<>) mempty $ map toBB hbs+toByteString :: Bool -> HeaderBlock -> ByteString+toByteString huff hbs = BB.toByteString $ foldl' (<>) mempty $ map toBB hbs where toBB = fromHeaderField huff
Network/HPACK/Types.hs view
@@ -8,7 +8,6 @@ , Header , HeaderList -- * Misc- , ByteStream , Index -- * Encoding and decoding , CompressionAlgo(..)@@ -36,9 +35,6 @@ -- | To be a 'HeaderName' or 'HeaderValue'. type HeaderStuff = ByteString --- | Byte stream in HTTP request/response.-type ByteStream = ByteString- -- | Index for table. type Index = Int @@ -46,6 +42,7 @@ data CompressionAlgo = Naive -- ^ No compression | Static -- ^ Using the static table only | Linear -- ^ Using indices only+ deriving (Eq, Show) -- | Strategy for HPACK encoding. data EncodeStrategy = EncodeStrategy {@@ -53,9 +50,12 @@ compressionAlgo :: CompressionAlgo -- | Whether or not to use Huffman encoding for strings. , useHuffman :: Bool- }+ } deriving (Eq, Show) --- | Default 'EncodeStrategy'. 'compressionAlgo' is 'Linear' and 'useHuffman' is 'True'.+-- | Default 'EncodeStrategy'.+--+-- >>> defaultEncodeStrategy+-- EncodeStrategy {compressionAlgo = Linear, useHuffman = True} defaultEncodeStrategy :: EncodeStrategy defaultEncodeStrategy = EncodeStrategy { compressionAlgo = Linear
Network/HTTP2.hs view
@@ -1,15 +1,80 @@ {-# LANGUAGE OverloadedStrings #-} +-- | Framing in HTTP/2. module Network.HTTP2 (- -- * Magic- connectionPreface- , connectionPrefaceLength- -- * Encoding and decoding+ -- * Frame+ Frame(..)+ , FrameHeader(..)+ , FramePayload(..)+ -- * Encoding+ , encodeFrame+ , encodeFrameHeader+ , encodeFramePayload , EncodeInfo(..) , encodeInfo- , encodeFrame- , decodeFrame- , module Network.HTTP2.Types+ , module Network.HTTP2.Decode+ -- * Frame type ID+ , FrameTypeId(..)+ , framePayloadToFrameTypeId+ -- * Frame type+ , FrameType+ , fromFrameTypeId+ , toFrameTypeId+ -- * Types+ , HeaderBlockFragment+ , Padding+ , Priority(..)+ , PromisedStreamId+ , LastStreamId+ , StreamDependency+ , WindowSizeIncrement+ -- * Stream identifier+ , StreamIdentifier+ , fromStreamIdentifier+ , toStreamIdentifier+ , isControl+ , isRequest+ , isResponse+ -- * Stream identifier related+ , testExclusive+ , setExclusive+ -- * Flags+ , FrameFlags+ , defaultFlags+ , testEndStream+ , testAck+ , testEndHeader+ , testPadded+ , testPriority+ , setEndStream+ , setAck+ , setEndHeader+ , setPadded+ , setPriority+ -- * SettingsList+ , SettingsList+ , SettingsValue+ , SettingsKeyId(..)+ , fromSettingsKeyId+ , toSettingsKeyId+ , checkSettingsList+ -- * Settings+ , Settings(..)+ , defaultSettings+ , updateSettings+ -- * Error code+ , ErrorCode+ , ErrorCodeId(..)+ , fromErrorCodeId+ , toErrorCodeId+ -- * Error+ , HTTP2Error(..)+ , errorCodeId+ -- * Magic+ , connectionPreface+ , connectionPrefaceLength+ , frameHeaderLength+ , maxPayloadLength ) where import Data.ByteString (ByteString)@@ -18,10 +83,16 @@ import Network.HTTP2.Encode import Network.HTTP2.Types --- | "PRI * HTTP/2.0\\r\\n\\r\\nSM\\r\\n\\r\\n"+-- | The preface of HTTP/2.+--+-- >>> connectionPreface+-- "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n" connectionPreface :: ByteString connectionPreface = "PRI * HTTP/2.0\r\n\r\nSM\r\n\r\n" --- | Length of the preface+-- | Length of the preface.+--+-- >>> connectionPrefaceLength+-- 24 connectionPrefaceLength :: Int connectionPrefaceLength = BS.length connectionPreface
Network/HTTP2/Decode.hs view
@@ -1,88 +1,106 @@-{-# LANGUAGE TupleSections, BangPatterns, RecordWildCards #-}+{-# LANGUAGE TupleSections, BangPatterns, RecordWildCards, OverloadedStrings #-} module Network.HTTP2.Decode (+ -- * Decoding decodeFrame , decodeFrameHeader- , parseFrame- , parseFrameHeader- , parseFramePayload+ , checkFrameHeader+ -- * Decoding payload+ , decodeFramePayload+ , FramePayloadDecoder+ , decodeDataFrame+ , decodeHeadersFrame+ , decodePriorityFrame+ , decoderstStreamFrame+ , decodeSettingsFrame+ , decodePushPromiseFrame+ , decodePingFrame+ , decodeGoAwayFrame+ , decodeWindowUpdateFrame+ , decodeContinuationFrame ) where -import Control.Applicative ((<$>), (<*>))-import Control.Monad (void, when)+import Control.Applicative ((<$>)) 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.Bits (clearBit, shiftL, (.|.)) import Data.ByteString (ByteString)-import Data.List (isPrefixOf)+import qualified Data.ByteString as BS+import Data.ByteString.Internal (ByteString(..), inlinePerformIO)+import Data.Word+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, plusPtr)+import Foreign.Storable (peek) 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.+-- | Decoding an HTTP/2 frame to 'ByteString'.+-- The second argument must be include the entire of frame.+-- So, this function is not useful for real applications+-- but useful for testing. 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+ -> Either HTTP2Error Frame -- ^ Decoded frame+decodeFrame settings bs = decode typ where- estr'- -- attoparsec specific, sigh.- | "Failed reading: " `isPrefixOf` estr = drop 16 estr- | otherwise = estr+ (bs0,bs1) = BS.splitAt 9 bs+ (typ, header) = decodeFrameHeader bs0+ decode (FrameUnknown v) = Right $ Frame header $ decodeUnknownFrame v bs1+ decode ftyp = case checkFrameHeader settings ftyp header of+ Just h2err -> Left h2err+ Nothing -> Right $ Frame header $ decodeFramePayload typ header bs1 + ---------------------------------------------------------------- -parseFrame :: Settings -> B.Parser Frame-parseFrame settings = do- (ftyp, header) <- parseFrameHeader settings- Frame header <$> parseFramePayload ftyp header+-- | Must supply 9 bytes.+decodeFrameHeader :: ByteString -> (FrameTypeId, FrameHeader)+decodeFrameHeader (PS fptr off _) = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do+ let p = ptr +. off+ l0 <- fromIntegral <$> peek p+ l1 <- fromIntegral <$> peek (p +. 1)+ l2 <- fromIntegral <$> peek (p +. 2)+ typ <- toFrameTypeId <$> peek (p +. 3)+ flg <- peek (p +. 4)+ w32 <- word32' (p +. 5)+ let !len = (l0 `shiftL` 16) .|. (l1 `shiftL` 8) .|. l2+ !sid = streamIdentifier w32+ return $ (typ, FrameHeader len flg sid) -----------------------------------------------------------------+(+.) :: Ptr Word8 -> Int -> Ptr Word8+(+.) = plusPtr -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+-- | Checking a frame header and reporting an error if any.+--+-- >>> let stid = toStreamIdentifier 0+-- >>> checkFrameHeader defaultSettings FrameData (FrameHeader 100 0 stid)+-- Just (ConnectionError ProtocolError "cannot used in control stream")+checkFrameHeader :: Settings -> FrameTypeId -> FrameHeader -> Maybe HTTP2Error+checkFrameHeader Settings {..} typ FrameHeader {..}+ | payloadLength > maxFrameSize =+ Just $ ConnectionError FrameSizeError "exceeds maximum frame size"+ | typ `elem` nonZeroFrameTypes && isControl streamId =+ Just $ ConnectionError ProtocolError "cannot used in control stream"+ | typ `elem` zeroFrameTypes && not (isControl streamId) =+ Just $ ConnectionError ProtocolError "cannot used in non-zero stream"+ | otherwise = checkType typ where- maxLength = maxFrameSize settings+ checkType FramePriority | payloadLength /= 5 =+ Just $ StreamError FrameSizeError streamId+ checkType FrameRSTStream | payloadLength /= 4 =+ Just $ ConnectionError FrameSizeError "payload length is not 4 in rst stream frame"+ checkType FrameSettings | payloadLength `mod` 6 /= 0 =+ Just $ ConnectionError FrameSizeError "payload length is not multiple of 6 in settings frame"+ checkType FramePushPromise | not enablePush =+ Just $ ConnectionError ProtocolError "push not enabled" -- checkme+ checkType FramePing | payloadLength /= 8 =+ Just $ ConnectionError FrameSizeError "payload length is 8 in ping frame"+ checkType FrameWindowUpdate | payloadLength /= 4 =+ Just $ ConnectionError FrameSizeError "payload length is 4 in window update frame"+ checkType _ = Nothing zeroFrameTypes :: [FrameTypeId] zeroFrameTypes = [@@ -101,153 +119,148 @@ , 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 = establishPush settings- ---------------------------------------------------------------- -type FramePayloadParser = FrameHeader -> B.Parser FramePayload+type FramePayloadDecoder = FrameHeader -> ByteString -> FramePayload -payloadParsers :: Array FrameTypeId FramePayloadParser-payloadParsers = listArray (minBound :: FrameTypeId, maxBound :: FrameTypeId)- [ parseDataFrame- , parseHeadersFrame- , parsePriorityFrame- , parseRstStreamFrame- , parseSettingsFrame- , parsePushPromiseFrame- , parsePingFrame- , parseGoAwayFrame- , parseWindowUpdateFrame- , parseContinuationFrame+payloadDecoders :: Array Word8 FramePayloadDecoder+payloadDecoders = listArray (minFrameType, maxFrameType)+ [ decodeDataFrame+ , decodeHeadersFrame+ , decodePriorityFrame+ , decoderstStreamFrame+ , decodeSettingsFrame+ , decodePushPromiseFrame+ , decodePingFrame+ , decodeGoAwayFrame+ , decodeWindowUpdateFrame+ , decodeContinuationFrame ] -parseFramePayload :: FrameType -> FramePayloadParser-parseFramePayload ftyp header = parsePayload mfid header- where- mfid = toFrameTypeId ftyp- parsePayload Nothing = parseUnknownFrame ftyp- parsePayload (Just fid) = payloadParsers ! fid+decodeFramePayload :: FrameTypeId -> FramePayloadDecoder+decodeFramePayload ftyp = payloadDecoders ! fromFrameTypeId ftyp ---------------------------------------------------------------- -parseDataFrame :: FramePayloadParser-parseDataFrame header = parseWithPadding header $ \len ->- DataFrame <$> B.take len+decodeDataFrame :: FramePayloadDecoder+decodeDataFrame header bs = decodeWithPadding header bs DataFrame -parseHeadersFrame :: FramePayloadParser-parseHeadersFrame header = parseWithPadding header $ \len ->- if hasPriority then do- p <- priority- HeadersFrame (Just p) <$> B.take (len - 5)+decodeHeadersFrame :: FramePayloadDecoder+decodeHeadersFrame header bs = decodeWithPadding header bs $ \bs' ->+ if hasPriority then+ let (bs0,bs1) = BS.splitAt 5 bs'+ p = priority bs0+ in HeadersFrame (Just p) bs1 else- HeadersFrame Nothing <$> B.take len+ HeadersFrame Nothing bs' where hasPriority = testPriority $ flags header -parsePriorityFrame :: FramePayloadParser-parsePriorityFrame _ = PriorityFrame <$> priority+decodePriorityFrame :: FramePayloadDecoder+decodePriorityFrame _ bs = PriorityFrame $ priority bs -parseRstStreamFrame :: FramePayloadParser-parseRstStreamFrame _ = RSTStreamFrame . toErrorCodeId <$> BI.anyWord32be+decoderstStreamFrame :: FramePayloadDecoder+decoderstStreamFrame _ bs = RSTStreamFrame $ toErrorCodeId (word32 bs) -parseSettingsFrame :: FramePayloadParser-parseSettingsFrame FrameHeader{..}- | isNotValid = fail protocolError- | otherwise = SettingsFrame <$> settings num id+decodeSettingsFrame :: FramePayloadDecoder+decodeSettingsFrame FrameHeader{..} (PS fptr off _) = SettingsFrame alist where num = payloadLength `div` 6- isNotValid = payloadLength `mod` 6 /= 0- settings 0 builder = return $ builder []- settings n builder = do- rawSetting <- BI.anyWord16be+ alist = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do+ let p = ptr +. off+ settings num p id+ settings 0 _ builder = return $ builder []+ settings n p builder = do+ rawSetting <- word16' p let msettings = toSettingsKeyId rawSetting n' = n - 1 case msettings of- Nothing -> settings n' builder -- ignoring unknown one (Section 6.5.2)+ Nothing -> settings n' (p +. 6) builder -- ignoring unknown one (Section 6.5.2) Just k -> do- v <- fromIntegral <$> BI.anyWord32be- settings n' (builder. ((k,v):))+ w32 <- word32' (p +. 2)+ let v = fromIntegral w32+ settings n' (p +. 6) (builder. ((k,v):)) -parsePushPromiseFrame :: FramePayloadParser-parsePushPromiseFrame header = parseWithPadding header $ \len ->- PushPromiseFrame <$> streamIdentifier <*> hbf len- where- hbf len = B.take $ len - 4+decodePushPromiseFrame :: FramePayloadDecoder+decodePushPromiseFrame header bs = decodeWithPadding header bs $ \bs' ->+ let (bs0,bs1) = BS.splitAt 4 bs'+ sid = streamIdentifier (word32 bs0)+ in PushPromiseFrame sid bs1 -parsePingFrame :: FramePayloadParser-parsePingFrame FrameHeader{..}- | payloadLength /= 8 = fail frameSizeError- | otherwise = PingFrame <$> B.take 8+decodePingFrame :: FramePayloadDecoder+decodePingFrame _ bs = PingFrame bs -parseGoAwayFrame :: FramePayloadParser-parseGoAwayFrame FrameHeader{..} =- GoAwayFrame <$> streamIdentifier <*> ecid <*> debug+decodeGoAwayFrame :: FramePayloadDecoder+decodeGoAwayFrame _ bs = GoAwayFrame sid ecid bs2 where- ecid = toErrorCodeId <$> BI.anyWord32be- debug = B.take $ payloadLength - 8--parseWindowUpdateFrame :: FramePayloadParser-parseWindowUpdateFrame FrameHeader{..}- | payloadLength /= 4 = fail frameSizeError -- not sure- | otherwise = WindowUpdateFrame <$> BI.anyWord32be+ (bs0,bs1') = BS.splitAt 4 bs+ (bs1,bs2) = BS.splitAt 4 bs1'+ sid = streamIdentifier (word32 bs0)+ ecid = toErrorCodeId (word32 bs1) -parseContinuationFrame :: FramePayloadParser-parseContinuationFrame FrameHeader{..} = ContinuationFrame <$> payload+decodeWindowUpdateFrame :: FramePayloadDecoder+decodeWindowUpdateFrame _ bs = WindowUpdateFrame wsi where- payload = B.take payloadLength+ !wsi = word32 bs `clearBit` 31 -parseUnknownFrame :: FrameType -> FramePayloadParser-parseUnknownFrame ftyp FrameHeader{..} = UnknownFrame ftyp <$> payload- where- payload = B.take payloadLength+decodeContinuationFrame :: FramePayloadDecoder+decodeContinuationFrame _ bs = ContinuationFrame bs +decodeUnknownFrame :: FrameType -> ByteString -> FramePayload+decodeUnknownFrame typ bs = UnknownFrame typ bs+ ---------------------------------------------------------------- -- | Helper function to pull off the padding if its there, and will--- eat up the trailing padding automatically. Calls the parser func+-- eat up the trailing padding automatically. Calls the decoder 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+decodeWithPadding :: FrameHeader -> ByteString -> (ByteString -> FramePayload) -> FramePayload+decodeWithPadding FrameHeader{..} bs body+ | padded = let Just (w8,rest) = BS.uncons bs+ padlen = intFromWord8 w8+ rest' = BS.take (payloadLength - padlen - 1) rest+ in body rest'+ | otherwise = body bs where padded = testPadded flags -streamIdentifier :: B.Parser StreamIdentifier-streamIdentifier = toStreamIdentifier . fromIntegral <$> BI.anyWord32be+streamIdentifier :: Word32 -> StreamIdentifier+streamIdentifier w32 = toStreamIdentifier (fromIntegral w32) -streamIdentifier' :: B.Parser (StreamIdentifier, Bool)-streamIdentifier' = do- n <- fromIntegral <$> BI.anyWord32be- let !streamdId = toStreamIdentifier n- !exclusive = testExclusive n- return (streamdId, exclusive)+priority :: ByteString -> Priority+priority (PS fptr off _) = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do+ let p = ptr +. off+ w32 <- word32' p+ let !streamdId = streamIdentifier w32+ !exclusive = testExclusive (fromIntegral w32) -- fixme+ w8 <- peek (p +. 4)+ let weight = intFromWord8 w8 + 1+ return $ Priority exclusive streamdId weight -priority :: B.Parser Priority-priority = do- (sid, excl) <- streamIdentifier'- Priority excl sid <$> w- where- w = (+1) <$> intFromWord8+intFromWord8 :: Word8 -> Int+intFromWord8 = fromIntegral -ignore :: Int -> B.Parser ()-ignore n = void $ B.take n+word32 :: ByteString -> Word32+word32 (PS fptr off _) = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do+ let p = ptr +. off+ word32' p+{-# INLINE word32 #-} -intFromWord8 :: B.Parser Int-intFromWord8 = fromIntegral <$> B.anyWord8+word32' :: Ptr Word8 -> IO Word32+word32' p = do+ w0 <- fromIntegral <$> peek p+ w1 <- fromIntegral <$> peek (p +. 1)+ w2 <- fromIntegral <$> peek (p +. 2)+ w3 <- fromIntegral <$> peek (p +. 3)+ let !w32 = (w0 `shiftL` 24) .|. (w1 `shiftL` 16) .|. (w2 `shiftL` 8) .|. w3+ return w32+{-# INLINE word32' #-} -intFromWord16be :: B.Parser Int-intFromWord16be = fromIntegral <$> BI.anyWord16be+word16' :: Ptr Word8 -> IO Word16+word16' p = do+ w0 <- fromIntegral <$> peek p+ w1 <- fromIntegral <$> peek (p +. 1)+ let !w16 = (w0 `shiftL` 8) .|. w1+ return w16+{-# INLINE word16' #-}
Network/HTTP2/Encode.hs view
@@ -36,16 +36,26 @@ ---------------------------------------------------------------- -- | A smart builder of 'EncodeInfo'.-encodeInfo :: (FrameFlags -> FrameFlags) -> Int -> EncodeInfo+--+-- >>> encodeInfo setAck 0+-- EncodeInfo {encodeFlags = 1, encodeStreamId = StreamIdentifier 0, encodePadding = Nothing}+encodeInfo :: (FrameFlags -> FrameFlags)+ -> Int -- ^ stream identifier+ -> EncodeInfo encodeInfo set stid = EncodeInfo (set defaultFlags) (toStreamIdentifier stid) Nothing ---------------------------------------------------------------- --- | Encoding an HTTP/2 frame to byte stream.+-- | Encoding an HTTP/2 frame to 'ByteString'.+-- This function is not efficient enough for high performace+-- program because of the concatenation of 'ByteString'.+--+-- >>> encodeFrame (encodeInfo id 1) (DataFrame "body")+-- "\NUL\NUL\EOT\NUL\NUL\NUL\NUL\NUL\SOHbody" encodeFrame :: EncodeInfo -> FramePayload -> ByteString encodeFrame einfo payload = run $ buildFrame einfo payload -encodeFrameHeader :: FrameType -> FrameHeader -> ByteString+encodeFrameHeader :: FrameTypeId -> FrameHeader -> ByteString encodeFrameHeader ftid header = run $ buildFrameHeader ftid header encodeFramePayload :: EncodeInfo -> FramePayload -> ByteString@@ -62,19 +72,19 @@ buildFrame einfo payload = headerBuilder <> payloadBuilder where (header, payloadBuilder) = buildFramePayload einfo payload- ftyp = framePayloadToFrameType payload+ ftyp = framePayloadToFrameTypeId payload headerBuilder = buildFrameHeader ftyp header ---------------------------------------------------------------- -buildFrameHeader :: FrameType -> FrameHeader -> Builder+buildFrameHeader :: FrameTypeId -> 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+ typ = BB.fromWord8 $ fromFrameTypeId ftyp flg = BB.fromWord8 flags sid = BB.fromWord32be . fromIntegral $ fromStreamIdentifier streamId @@ -106,7 +116,10 @@ ---------------------------------------------------------------- -buildPadding :: EncodeInfo -> Builder -> PayloadLength -> (FrameHeader, Builder)+buildPadding :: EncodeInfo+ -> Builder+ -> Int -- ^ Payload length.+ -> (FrameHeader, Builder) buildPadding EncodeInfo{ encodePadding = Nothing, ..} builder len = (header, builder) where
+ Network/HTTP2/Internal.hs view
@@ -0,0 +1,5 @@+module Network.HTTP2.Internal (+ StreamIdentifier(..)+ ) where++import Network.HTTP2.Types
Network/HTTP2/Types.hs view
@@ -1,14 +1,24 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+ module Network.HTTP2.Types (- -- * Settings- SettingsKey+ -- * Constant+ frameHeaderLength+ , maxPayloadLength+ -- * SettingsList , SettingsKeyId(..)- , SettingsValue+ , checkSettingsList , fromSettingsKeyId+ , SettingsValue+ , SettingsList , toSettingsKeyId+ -- * Settings , Settings(..)- , SettingsList , defaultSettings , updateSettings+ -- * Error+ , HTTP2Error(..)+ , errorCodeId -- * Error code , ErrorCode , ErrorCodeId(..)@@ -16,6 +26,8 @@ , toErrorCodeId -- * Frame type , FrameType+ , minFrameType+ , maxFrameType , FrameTypeId(..) , fromFrameTypeId , toFrameTypeId@@ -23,15 +35,17 @@ , Frame(..) , FrameHeader(..) , FramePayload(..)- , framePayloadToFrameType+ , framePayloadToFrameTypeId -- * Stream identifier , StreamIdentifier(..)- , StreamDependency- , PromisedStreamId- , LastStreamId , fromStreamIdentifier , toStreamIdentifier- , streamIdentifierForSeetings+ , isControl+ , isRequest+ , isResponse+ , PromisedStreamId+ , LastStreamId+ , StreamDependency , testExclusive , setExclusive -- * Flags@@ -47,9 +61,6 @@ , setEndHeader , setPadded , setPriority- -- * Payload length- , PayloadLength- , maxPayloadLength -- * Types , WindowSizeIncrement , HeaderBlockFragment@@ -57,13 +68,24 @@ , Padding ) where -import Data.Array (Ix)+import qualified Control.Exception as E import Data.Bits (setBit, testBit, clearBit) import Data.ByteString (ByteString)+import Data.Maybe (mapMaybe)+import Data.Typeable import Data.Word (Word8, Word16, Word32) ---------------------------------------------------------------- +-- | The length of HTTP/2 frame header.+--+-- >>> frameHeaderLength+-- 9+frameHeaderLength :: Int+frameHeaderLength = 9++----------------------------------------------------------------+ type ErrorCode = Word32 data ErrorCodeId = NoError@@ -82,7 +104,6 @@ | HTTP11Required -- our extensions | UnknownErrorCode ErrorCode- | UnknownError String deriving (Show, Read, Eq, Ord) -- |@@ -107,7 +128,6 @@ fromErrorCodeId InadequateSecurity = 0xc fromErrorCodeId HTTP11Required = 0xd fromErrorCodeId (UnknownErrorCode w) = w-fromErrorCodeId _ = 255 -- never reached -- | --@@ -136,6 +156,20 @@ ---------------------------------------------------------------- +-- | The connection error or the stream error.+data HTTP2Error = ConnectionError ErrorCodeId ByteString+ | StreamError ErrorCodeId StreamIdentifier+ deriving (Eq, Show, Typeable, Read)++instance E.Exception HTTP2Error++-- | Obtaining 'ErrorCodeId' from 'HTTP2Error'.+errorCodeId :: HTTP2Error -> ErrorCodeId+errorCodeId (ConnectionError err _) = err+errorCodeId (StreamError err _) = err++----------------------------------------------------------------+ data SettingsKeyId = SettingsHeaderTableSize | SettingsEnablePush | SettingsMaxConcurrentStreams@@ -144,7 +178,6 @@ | SettingsMaxHeaderBlockSize deriving (Show, Read, Eq, Ord, Enum, Bounded) -type SettingsKey = Word16 type SettingsValue = Int -- Word32 -- |@@ -181,23 +214,48 @@ ---------------------------------------------------------------- +-- | Settings containing raw values.+type SettingsList = [(SettingsKeyId,SettingsValue)]++-- | Checking 'SettingsList' and reporting an error if any.+--+-- >>> checkSettingsList [(SettingsEnablePush,2)]+-- Just (ConnectionError ProtocolError "enable push must be 0 or 1")+checkSettingsList :: SettingsList -> Maybe HTTP2Error+checkSettingsList settings = case mapMaybe checkSettingsValue settings of+ [] -> Nothing+ (x:_) -> Just x++checkSettingsValue :: (SettingsKeyId,SettingsValue) -> Maybe HTTP2Error+checkSettingsValue (SettingsEnablePush,v)+ | v /= 0 && v /= 1 = Just $ ConnectionError ProtocolError "enable push must be 0 or 1"+checkSettingsValue (SettingsInitialWindowSize,v)+ | v > 2147483647 = Just $ ConnectionError FlowControlError "Window size must be less than or equal to 65535"+checkSettingsValue (SettingsMaxFrameSize,v)+ | v < 16384 || v > 16777215 = Just $ ConnectionError ProtocolError "Max frame size must be in between 16384 and 16777215"+checkSettingsValue _ = Nothing++----------------------------------------------------------------++-- | Cooked version of settings. This is suitable to be stored in a HTTP/2 context. data Settings = Settings { headerTableSize :: Int- , establishPush :: Bool- , maxConcurrentStreams :: Int+ , enablePush :: Bool+ , maxConcurrentStreams :: Maybe Int , initialWindowSize :: Int , maxFrameSize :: Int , maxHeaderBlockSize :: Maybe Int } deriving (Show) -type SettingsList = [(SettingsKeyId,SettingsValue)]- -- | The default settings.+--+-- >>> defaultSettings+-- Settings {headerTableSize = 4096, enablePush = True, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Nothing} defaultSettings :: Settings defaultSettings = Settings { headerTableSize = 4096- , establishPush = True- , maxConcurrentStreams = 100+ , enablePush = True+ , maxConcurrentStreams = Nothing , initialWindowSize = 65535 , maxFrameSize = 16384 , maxHeaderBlockSize = Nothing@@ -206,14 +264,14 @@ -- | Updating settings. -- -- >>> updateSettings defaultSettings [(SettingsEnablePush,0),(SettingsMaxHeaderBlockSize,200)]--- Settings {headerTableSize = 4096, establishPush = False, maxConcurrentStreams = 100, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Just 200}+-- Settings {headerTableSize = 4096, enablePush = False, maxConcurrentStreams = Nothing, initialWindowSize = 65535, maxFrameSize = 16384, maxHeaderBlockSize = Just 200} updateSettings :: Settings -> SettingsList -> Settings updateSettings settings kvs = foldr update settings kvs where update (SettingsHeaderTableSize,x) def = def { headerTableSize = x } -- fixme: x should be 0 or 1- update (SettingsEnablePush,x) def = def { establishPush = x > 0 }- update (SettingsMaxConcurrentStreams,x) def = def { maxConcurrentStreams = x }+ update (SettingsEnablePush,x) def = def { enablePush = x > 0 }+ update (SettingsMaxConcurrentStreams,x) def = def { maxConcurrentStreams = Just x } update (SettingsInitialWindowSize,x) def = def { initialWindowSize = x } update (SettingsMaxFrameSize,x) def = def { maxFrameSize = x } update (SettingsMaxHeaderBlockSize,x) def = def { maxHeaderBlockSize = Just x }@@ -230,6 +288,12 @@ type FrameType = Word8 +minFrameType :: FrameType+minFrameType = 0++maxFrameType :: FrameType+maxFrameType = 9+ -- Valid frame types data FrameTypeId = FrameData | FrameHeaders@@ -241,7 +305,8 @@ | FrameGoAway | FrameWindowUpdate | FrameContinuation- deriving (Show, Eq, Ord, Enum, Bounded, Ix)+ | FrameUnknown FrameType+ deriving (Show, Eq, Ord) -- | --@@ -249,33 +314,49 @@ -- 0 -- >>> fromFrameTypeId FrameContinuation -- 9+-- >>> fromFrameTypeId (FrameUnknown 10)+-- 10 fromFrameTypeId :: FrameTypeId -> FrameType-fromFrameTypeId = fromIntegral . fromEnum--minFrameType :: FrameType-minFrameType = fromIntegral $ fromEnum (minBound :: FrameTypeId)--maxFrameType :: FrameType-maxFrameType = fromIntegral $ fromEnum (maxBound :: FrameTypeId)+fromFrameTypeId FrameData = 0+fromFrameTypeId FrameHeaders = 1+fromFrameTypeId FramePriority = 2+fromFrameTypeId FrameRSTStream = 3+fromFrameTypeId FrameSettings = 4+fromFrameTypeId FramePushPromise = 5+fromFrameTypeId FramePing = 6+fromFrameTypeId FrameGoAway = 7+fromFrameTypeId FrameWindowUpdate = 8+fromFrameTypeId FrameContinuation = 9+fromFrameTypeId (FrameUnknown x) = x -- | -- -- >>> toFrameTypeId 0--- Just FrameData+-- FrameData -- >>> toFrameTypeId 9--- Just FrameContinuation+-- FrameContinuation -- >>> toFrameTypeId 10--- Nothing-toFrameTypeId :: FrameType -> Maybe FrameTypeId-toFrameTypeId x- | minFrameType <= x && x <= maxFrameType = Just . toEnum . fromIntegral $ x- | otherwise = Nothing+-- FrameUnknown 10+toFrameTypeId :: FrameType -> FrameTypeId+toFrameTypeId 0 = FrameData+toFrameTypeId 1 = FrameHeaders+toFrameTypeId 2 = FramePriority+toFrameTypeId 3 = FrameRSTStream+toFrameTypeId 4 = FrameSettings+toFrameTypeId 5 = FramePushPromise+toFrameTypeId 6 = FramePing+toFrameTypeId 7 = FrameGoAway+toFrameTypeId 8 = FrameWindowUpdate+toFrameTypeId 9 = FrameContinuation+toFrameTypeId x = FrameUnknown x ---------------------------------------------------------------- -type PayloadLength = Int -- Word24 but Int is more natural--maxPayloadLength :: PayloadLength+-- | The maximum length of HTTP/2 payload.+--+-- >>> maxPayloadLength+-- 16384+maxPayloadLength :: Int maxPayloadLength = 2^(14::Int) ----------------------------------------------------------------@@ -283,6 +364,9 @@ type FrameFlags = Word8 +-- |+-- >>> defaultFlags+-- 0 defaultFlags :: FrameFlags defaultFlags = 0 @@ -353,21 +437,50 @@ type LastStreamId = StreamIdentifier type PromisedStreamId = StreamIdentifier +-- |+-- >>> toStreamIdentifier 0+-- StreamIdentifier 0 toStreamIdentifier :: Int -> StreamIdentifier toStreamIdentifier n = StreamIdentifier (n `clearBit` 31) +-- |+-- >>> fromStreamIdentifier (toStreamIdentifier 0)+-- 0 fromStreamIdentifier :: StreamIdentifier -> Int fromStreamIdentifier (StreamIdentifier n) = n +-- |+-- >>> isControl $ toStreamIdentifier 0+-- True+-- >>> isControl $ toStreamIdentifier 1+-- False+isControl :: StreamIdentifier -> Bool+isControl (StreamIdentifier 0) = True+isControl _ = False++-- |+-- >>> isRequest $ toStreamIdentifier 0+-- False+-- >>> isRequest $ toStreamIdentifier 1+-- True+isRequest :: StreamIdentifier -> Bool+isRequest (StreamIdentifier n) = odd n++-- |+-- >>> isResponse $ toStreamIdentifier 0+-- False+-- >>> isResponse $ toStreamIdentifier 2+-- True+isResponse :: StreamIdentifier -> Bool+isResponse (StreamIdentifier 0) = False+isResponse (StreamIdentifier n) = even n+ testExclusive :: Int -> Bool testExclusive n = n `testBit` 31 setExclusive :: Int -> Int setExclusive n = n `setBit` 31 -streamIdentifierForSeetings :: StreamIdentifier-streamIdentifierForSeetings = StreamIdentifier 0- ---------------------------------------------------------------- type WindowSizeIncrement = Word32@@ -376,18 +489,20 @@ ---------------------------------------------------------------- +-- | The data type for HTTP/2 frames. data Frame = Frame { frameHeader :: FrameHeader , framePayload :: FramePayload } deriving (Show, Read, Eq) --- A complete frame header+-- | The data type for HTTP/2 frame headers. data FrameHeader = FrameHeader- { payloadLength :: PayloadLength+ { payloadLength :: Int , flags :: FrameFlags , streamId :: StreamIdentifier } deriving (Show, Read, Eq) +-- | The data type for HTTP/2 frame payloads. data FramePayload = DataFrame ByteString | HeadersFrame (Maybe Priority) HeaderBlockFragment@@ -404,15 +519,19 @@ ---------------------------------------------------------------- -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+-- | Getting 'FrameType' from 'FramePayload'.+--+-- >>> framePayloadToFrameTypeId (DataFrame "body")+-- FrameData+framePayloadToFrameTypeId :: FramePayload -> FrameTypeId+framePayloadToFrameTypeId (DataFrame _) = FrameData+framePayloadToFrameTypeId (HeadersFrame _ _) = FrameHeaders+framePayloadToFrameTypeId (PriorityFrame _) = FramePriority+framePayloadToFrameTypeId (RSTStreamFrame _) = FrameRSTStream+framePayloadToFrameTypeId (SettingsFrame _) = FrameSettings+framePayloadToFrameTypeId (PushPromiseFrame _ _) = FramePushPromise+framePayloadToFrameTypeId (PingFrame _) = FramePing+framePayloadToFrameTypeId (GoAwayFrame _ _ _) = FrameGoAway+framePayloadToFrameTypeId (WindowUpdateFrame _) = FrameWindowUpdate+framePayloadToFrameTypeId (ContinuationFrame _) = FrameContinuation+framePayloadToFrameTypeId (UnknownFrame w8 _) = FrameUnknown w8
http2.cabal view
@@ -1,11 +1,11 @@ Name: http2-Version: 0.7.0+Version: 0.8.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 frames and HPACK-Description: HTTP/2.0 library including frames and HPACK+Description: HTTP/2.0 library including frames and HPACK. Currently HTTP/2 16 framing and HPACK 10 is supported. Category: Network Cabal-Version: >= 1.10@@ -28,6 +28,7 @@ GHC-Options: -Wall Exposed-Modules: Network.HPACK Network.HTTP2+ Network.HTTP2.Internal Other-Modules: Network.HPACK.Builder Network.HPACK.Builder.Word8 Network.HPACK.Huffman@@ -56,8 +57,6 @@ Network.HTTP2.Encode Network.HTTP2.Types Build-Depends: base >= 4 && < 5- , attoparsec >= 0.12.1- , attoparsec-binary >= 0.2 , PSQueue , array , blaze-builder@@ -91,8 +90,6 @@ Build-Depends: base >= 4 && < 5 , PSQueue , array- , attoparsec- , attoparsec-binary , blaze-builder , bytestring , containers
test-frame/Case.hs view
@@ -36,8 +36,7 @@ wireToCase :: CaseWire -> Case wireToCase CaseWire { wire_error = Nothing, ..} = Case {- draft = 14- , description = wire_description+ description = wire_description , wire = wire_hex , frame = Just $ FramePad frm wire_padding , err = Nothing@@ -48,8 +47,7 @@ Left e -> error $ show e Right (r,_) -> r wireToCase CaseWire { wire_error = Just e, ..} = Case {- draft = 14- , description = wire_description+ description = wire_description , wire = wire_hex , frame = Nothing , err = Just $ fromErrorCodeId <$> e
test-frame/JSON.hs view
@@ -18,6 +18,7 @@ import qualified Data.Text as T import Network.HTTP2+import Network.HTTP2.Internal ---------------------------------------------------------------- @@ -48,8 +49,7 @@ ---------------------------------------------------------------- data Case = Case {- draft :: Int- , description :: String+ description :: String , wire :: ByteString , frame :: Maybe FramePad , err :: Maybe [ErrorCode]@@ -140,7 +140,7 @@ instance ToJSON FramePad where toJSON FramePad{fpFrame = Frame{..},..} = object [ "length" .= payloadLength frameHeader- , "type" .= framePayloadToFrameType framePayload+ , "type" .= fromFrameTypeId (framePayloadToFrameTypeId framePayload) , "flags" .= flags frameHeader , "stream_identifier" .= fromStreamIdentifier (streamId frameHeader) , "frame_payload" .= (toJSON framePayload +++ padObj)@@ -173,7 +173,7 @@ payload <- parsePayload ftid o return (payload, mpad) where- ftid = fromJust $ toFrameTypeId ftyp+ ftid = toFrameTypeId ftyp parsePayload :: FrameTypeId -> Object -> Parser FramePayload parsePayload FrameData o = DataFrame <$> o .: "data"@@ -207,16 +207,14 @@ instance ToJSON Case where toJSON Case{..} = object [- "draft" .= draft- , "description" .= description+ "description" .= description , "wire" .= wire , "frame" .= frame , "error" .= err ] instance FromJSON Case where- parseJSON (Object o) = Case <$> o .: "draft"- <*> o .: "description"+ parseJSON (Object o) = Case <$> o .: "description" <*> o .: "wire" <*> o .:? "frame" <*> o .:? "error"
test-frame/frame-encode.hs view
@@ -13,7 +13,7 @@ main = do args <- getArgs xs <- getContents- if length args /= 0 then -- "-s"+ if length args /= 0 then -- "-w" printWire xs else printJSON xs
test-hpack/HPACKDecode.hs view
@@ -77,7 +77,7 @@ wirehex = wire c Just inp = unhex wirehex hs = headers c- bshd = fromByteStreamDebug inp+ bshd = fromByteStringDebug inp hd = map snd <$> bshd bshd' = map (\(x,y)->(hex x,y)) <$> bshd
test-hpack/HPACKEncode.hs view
@@ -24,13 +24,13 @@ run _ _ (Test _ _ []) = return [] run d stgy (Test _ _ ccs@(c:_)) = do let siz = maybe 4096 id $ size c- ehdrtbl <- newHeaderTableForEncoding siz+ ehdrtbl <- newDynamicTableForEncoding siz let conf = Conf { debug = d, enc = encodeHeader stgy } testLoop conf ccs ehdrtbl [] testLoop :: Conf -> [Case]- -> HeaderTable+ -> DynamicTable -> [ByteString] -> IO [ByteString] testLoop _ [] _ hexs = return $ reverse hexs@@ -40,14 +40,14 @@ test :: Conf -> Case- -> HeaderTable- -> IO (HeaderTable, ByteString)+ -> DynamicTable+ -> IO (DynamicTable, ByteString) test conf c ehdrtbl = do (ehdrtbl',out) <- enc conf ehdrtbl hs let hex' = hex out when (debug conf) $ do putStrLn "---- Output context"- printHeaderTable ehdrtbl'+ printDynamicTable ehdrtbl' putStrLn "--------------------------------" return (ehdrtbl', hex') where
test/HPACK/HeaderBlock.hs view
@@ -2,12 +2,13 @@ module HPACK.HeaderBlock where +import Data.ByteString (ByteString) import Data.Hex import Data.Maybe (fromJust) import Network.HPACK.HeaderBlock import Network.HPACK.Types -fromHexString :: ByteStream -> ByteStream+fromHexString :: ByteString -> ByteString fromHexString = fromJust . unhex ----------------------------------------------------------------@@ -27,7 +28,7 @@ ,(":authority","www.example.com") ] -d41b :: ByteStream+d41b :: ByteString d41b = fromHexString "828684418cf1e3c2e5f23a6ba0ab90f4ff" d42 :: HeaderBlock@@ -46,7 +47,7 @@ ,(":authority","www.example.com") ,("cache-control","no-cache")] -d42b :: ByteStream+d42b :: ByteString d42b = fromHexString "828684be5886a8eb10649cbf" d43 :: HeaderBlock@@ -66,7 +67,7 @@ ,("custom-key","custom-value") ] -d43b :: ByteStream+d43b :: ByteString d43b = fromHexString "828785bf408825a849e95ba97d7f8925a849e95bb8e8b4bf" ----------------------------------------------------------------@@ -86,7 +87,7 @@ ,("location","https://www.example.com") ] -d61b :: ByteStream+d61b :: ByteString d61b = fromHexString "488264025885aec3771a4b6196d07abe941054d444a8200595040b8166e082a62d1bff6e919d29ad171863c78f0b97c8e9ae82ae43d3" d62 :: HeaderBlock@@ -104,7 +105,7 @@ ,("location","https://www.example.com") ] -d62b :: ByteStream+d62b :: ByteString d62b = fromHexString "4883640effc1c0bf" d63 :: HeaderBlock@@ -125,5 +126,5 @@ ,("content-encoding","gzip") ,("set-cookie","foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1")] -d63b :: ByteStream+d63b :: ByteString d63b = fromHexString "88c16196d07abe941054d444a8200595040b8166e084a62d1bffc05a839bd9ab77ad94e7821dd7f2e6c7b335dfdfcd5b3960d5af27087f3672c1ab270fb5291f9587316065c003ed4ee5b1063d5007"
test/HPACK/HeaderBlockSpec.hs view
@@ -11,31 +11,31 @@ spec :: Spec spec = do- describe "toByteStream" $ do+ describe "toByteString" $ 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+ toByteString True d41 `shouldBe` d41b+ toByteString True d42 `shouldBe` d42b+ toByteString True d43 `shouldBe` d43b+ toByteString True d61 `shouldBe` d61b+ toByteString True d62 `shouldBe` d62b+ toByteString True d63 `shouldBe` d63b - describe "fromByteStream" $ do+ describe "fromByteString" $ 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+ fromByteString d41b `shouldBe` Right d41+ fromByteString d42b `shouldBe` Right d42+ fromByteString d43b `shouldBe` Right d43+ fromByteString d61b `shouldBe` Right d61+ fromByteString d62b `shouldBe` Right d62+ fromByteString d63b `shouldBe` Right d63 - describe "toByteStream & fromByteStream" $ do+ describe "toByteString & fromByteString" $ 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+ fromByteString (toByteString 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+ fromByteString (toByteString True hb) `shouldBe` Right hb
test/HTTP2/FrameSpec.hs view
@@ -18,10 +18,9 @@ , flags = defaultFlags , streamId = StreamIdentifier 10 }- ftyp = fromFrameTypeId FramePriority- wire = encodeFrameHeader ftyp header- Right fibHeader = decodeFrameHeader defaultSettings wire- fibHeader `shouldBe` (ftyp, header)+ wire = encodeFrameHeader FramePriority header+ fibHeader = decodeFrameHeader wire+ fibHeader `shouldBe` (FramePriority, header) describe "encodeFrame & decodeFrame" $ do it "encode/decodes frames properly" $ do@@ -32,7 +31,7 @@ } payload = DataFrame "Hello, world!" wire = encodeFrame einfo payload- Right (frame,_) = decodeFrame defaultSettings wire+ Right frame = decodeFrame defaultSettings wire payload' = framePayload frame payload' `shouldBe` payload it "encode/decodes padded frames properly" $ do@@ -43,6 +42,6 @@ } payload = DataFrame "Hello, world!" wire = encodeFrame einfo payload- Right (frame,_) = decodeFrame defaultSettings wire+ Right frame = decodeFrame defaultSettings wire payload' = framePayload frame payload' `shouldBe` payload