diff --git a/Network/HPACK.hs b/Network/HPACK.hs --- a/Network/HPACK.hs +++ b/Network/HPACK.hs @@ -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 diff --git a/Network/HPACK/HeaderBlock.hs b/Network/HPACK/HeaderBlock.hs --- a/Network/HPACK/HeaderBlock.hs +++ b/Network/HPACK/HeaderBlock.hs @@ -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 diff --git a/Network/HPACK/HeaderBlock/Decode.hs b/Network/HPACK/HeaderBlock/Decode.hs --- a/Network/HPACK/HeaderBlock/Decode.hs +++ b/Network/HPACK/HeaderBlock/Decode.hs @@ -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 diff --git a/Network/HPACK/HeaderBlock/Encode.hs b/Network/HPACK/HeaderBlock/Encode.hs --- a/Network/HPACK/HeaderBlock/Encode.hs +++ b/Network/HPACK/HeaderBlock/Encode.hs @@ -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 diff --git a/Network/HPACK/Types.hs b/Network/HPACK/Types.hs --- a/Network/HPACK/Types.hs +++ b/Network/HPACK/Types.hs @@ -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 diff --git a/Network/HTTP2.hs b/Network/HTTP2.hs --- a/Network/HTTP2.hs +++ b/Network/HTTP2.hs @@ -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 diff --git a/Network/HTTP2/Decode.hs b/Network/HTTP2/Decode.hs --- a/Network/HTTP2/Decode.hs +++ b/Network/HTTP2/Decode.hs @@ -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' #-} diff --git a/Network/HTTP2/Encode.hs b/Network/HTTP2/Encode.hs --- a/Network/HTTP2/Encode.hs +++ b/Network/HTTP2/Encode.hs @@ -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 diff --git a/Network/HTTP2/Internal.hs b/Network/HTTP2/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP2/Internal.hs @@ -0,0 +1,5 @@ +module Network.HTTP2.Internal ( + StreamIdentifier(..) + ) where + +import Network.HTTP2.Types diff --git a/Network/HTTP2/Types.hs b/Network/HTTP2/Types.hs --- a/Network/HTTP2/Types.hs +++ b/Network/HTTP2/Types.hs @@ -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 diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,11 +1,11 @@ Name: http2 -Version: 0.7.0 +Version: 0.8.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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 diff --git a/test-frame/Case.hs b/test-frame/Case.hs --- a/test-frame/Case.hs +++ b/test-frame/Case.hs @@ -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 diff --git a/test-frame/JSON.hs b/test-frame/JSON.hs --- a/test-frame/JSON.hs +++ b/test-frame/JSON.hs @@ -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" diff --git a/test-frame/frame-encode.hs b/test-frame/frame-encode.hs --- a/test-frame/frame-encode.hs +++ b/test-frame/frame-encode.hs @@ -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 diff --git a/test-hpack/HPACKDecode.hs b/test-hpack/HPACKDecode.hs --- a/test-hpack/HPACKDecode.hs +++ b/test-hpack/HPACKDecode.hs @@ -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 diff --git a/test-hpack/HPACKEncode.hs b/test-hpack/HPACKEncode.hs --- a/test-hpack/HPACKEncode.hs +++ b/test-hpack/HPACKEncode.hs @@ -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 diff --git a/test/HPACK/HeaderBlock.hs b/test/HPACK/HeaderBlock.hs --- a/test/HPACK/HeaderBlock.hs +++ b/test/HPACK/HeaderBlock.hs @@ -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" diff --git a/test/HPACK/HeaderBlockSpec.hs b/test/HPACK/HeaderBlockSpec.hs --- a/test/HPACK/HeaderBlockSpec.hs +++ b/test/HPACK/HeaderBlockSpec.hs @@ -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 diff --git a/test/HTTP2/FrameSpec.hs b/test/HTTP2/FrameSpec.hs --- a/test/HTTP2/FrameSpec.hs +++ b/test/HTTP2/FrameSpec.hs @@ -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