diff --git a/Network/HTTP2.hs b/Network/HTTP2.hs --- a/Network/HTTP2.hs +++ b/Network/HTTP2.hs @@ -6,8 +6,10 @@ Frame(..) , FrameHeader(..) , FramePayload(..) + , isPaddingDefined -- * Encoding , encodeFrame + , encodeFrameChunks , encodeFrameHeader , encodeFramePayload , EncodeInfo(..) diff --git a/Network/HTTP2/Decode.hs b/Network/HTTP2/Decode.hs --- a/Network/HTTP2/Decode.hs +++ b/Network/HTTP2/Decode.hs @@ -42,19 +42,16 @@ decodeFrame :: Settings -- ^ HTTP/2 settings -> ByteString -- ^ Input byte-stream -> Either HTTP2Error Frame -- ^ Decoded frame -decodeFrame settings bs = decode typ +decodeFrame settings bs = checkFrameHeader settings (decodeFrameHeader bs0) + >>= \(typ,header) -> decodeFramePayload typ header bs1 + >>= \payload -> return $ Frame header payload where (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 - ---------------------------------------------------------------- --- | Must supply 9 bytes. +-- | Decoding an HTTP/2 frame header. +-- Must supply 9 bytes. decodeFrameHeader :: ByteString -> (FrameTypeId, FrameHeader) decodeFrameHeader (PS fptr off _) = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do let p = ptr +. off @@ -76,31 +73,41 @@ -- | 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 {..} +-- >>> checkFrameHeader defaultSettings (FrameData,(FrameHeader 100 0 stid)) +-- Left (ConnectionError ProtocolError "cannot used in control stream") +checkFrameHeader :: Settings + -> (FrameTypeId, FrameHeader) + -> Either HTTP2Error (FrameTypeId, FrameHeader) +checkFrameHeader Settings {..} typfrm@(typ,FrameHeader {..}) | payloadLength > maxFrameSize = - Just $ ConnectionError FrameSizeError "exceeds maximum frame size" + Left $ ConnectionError FrameSizeError "exceeds maximum frame size" | typ `elem` nonZeroFrameTypes && isControl streamId = - Just $ ConnectionError ProtocolError "cannot used in control stream" + Left $ ConnectionError ProtocolError "cannot used in control stream" | typ `elem` zeroFrameTypes && not (isControl streamId) = - Just $ ConnectionError ProtocolError "cannot used in non-zero stream" + Left $ ConnectionError ProtocolError "cannot used in non-zero stream" | otherwise = checkType typ where checkType FramePriority | payloadLength /= 5 = - Just $ StreamError FrameSizeError streamId + Left $ 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 + Left $ ConnectionError FrameSizeError "payload length is not 4 in rst stream frame" + checkType FrameSettings + | payloadLength `mod` 6 /= 0 = + Left $ ConnectionError FrameSizeError "payload length is not multiple of 6 in settings frame" + | testAck flags && payloadLength /= 0 = + Left $ ConnectionError FrameSizeError "payload length must be 0 if ack flag is set" + checkType FramePushPromise + | not enablePush = + Left $ ConnectionError ProtocolError "push not enabled" -- checkme + | not (isResponse streamId) = + Left $ ConnectionError ProtocolError "push promise must be used with even stream identifier" checkType FramePing | payloadLength /= 8 = - Just $ ConnectionError FrameSizeError "payload length is 8 in ping frame" + Left $ ConnectionError FrameSizeError "payload length is 8 in ping frame" + checkType FrameGoAway | payloadLength < 8 = + Left $ ConnectionError FrameSizeError "goaway body must be 8 bytes or larger" checkType FrameWindowUpdate | payloadLength /= 4 = - Just $ ConnectionError FrameSizeError "payload length is 4 in window update frame" - checkType _ = Nothing + Left $ ConnectionError FrameSizeError "payload length is 4 in window update frame" + checkType _ = Right typfrm zeroFrameTypes :: [FrameTypeId] zeroFrameTypes = [ @@ -121,7 +128,8 @@ ---------------------------------------------------------------- -type FramePayloadDecoder = FrameHeader -> ByteString -> FramePayload +type FramePayloadDecoder = FrameHeader -> ByteString + -> Either HTTP2Error FramePayload payloadDecoders :: Array Word8 FramePayloadDecoder payloadDecoders = listArray (minFrameType, maxFrameType) @@ -137,8 +145,12 @@ , decodeContinuationFrame ] +-- | Decoding an HTTP/2 frame payload. decodeFramePayload :: FrameTypeId -> FramePayloadDecoder -decodeFramePayload ftyp = payloadDecoders ! fromFrameTypeId ftyp +decodeFramePayload (FrameUnknown typ) = checkFrameSize $ decodeUnknownFrame typ +decodeFramePayload ftyp = checkFrameSize decoder + where + decoder = payloadDecoders ! fromFrameTypeId ftyp ---------------------------------------------------------------- @@ -157,13 +169,13 @@ hasPriority = testPriority $ flags header decodePriorityFrame :: FramePayloadDecoder -decodePriorityFrame _ bs = PriorityFrame $ priority bs +decodePriorityFrame _ bs = Right $ PriorityFrame $ priority bs decoderstStreamFrame :: FramePayloadDecoder -decoderstStreamFrame _ bs = RSTStreamFrame $ toErrorCodeId (word32 bs) +decoderstStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCodeId (word32 bs) decodeSettingsFrame :: FramePayloadDecoder -decodeSettingsFrame FrameHeader{..} (PS fptr off _) = SettingsFrame alist +decodeSettingsFrame FrameHeader{..} (PS fptr off _) = Right $ SettingsFrame alist where num = payloadLength `div` 6 alist = inlinePerformIO $ withForeignPtr fptr $ \ptr -> do @@ -188,10 +200,10 @@ in PushPromiseFrame sid bs1 decodePingFrame :: FramePayloadDecoder -decodePingFrame _ bs = PingFrame bs +decodePingFrame _ bs = Right $ PingFrame bs decodeGoAwayFrame :: FramePayloadDecoder -decodeGoAwayFrame _ bs = GoAwayFrame sid ecid bs2 +decodeGoAwayFrame _ bs = Right $ GoAwayFrame sid ecid bs2 where (bs0,bs1') = BS.splitAt 4 bs (bs1,bs2) = BS.splitAt 4 bs1' @@ -199,29 +211,40 @@ ecid = toErrorCodeId (word32 bs1) decodeWindowUpdateFrame :: FramePayloadDecoder -decodeWindowUpdateFrame _ bs = WindowUpdateFrame wsi +decodeWindowUpdateFrame _ bs + | wsi == 0 = Left $ ConnectionError ProtocolError "window update must not be 0" + | otherwise = Right $ WindowUpdateFrame wsi where !wsi = word32 bs `clearBit` 31 decodeContinuationFrame :: FramePayloadDecoder -decodeContinuationFrame _ bs = ContinuationFrame bs +decodeContinuationFrame _ bs = Right $ ContinuationFrame bs -decodeUnknownFrame :: FrameType -> ByteString -> FramePayload -decodeUnknownFrame typ bs = UnknownFrame typ bs +decodeUnknownFrame :: FrameType -> FramePayloadDecoder +decodeUnknownFrame typ _ bs = Right $ UnknownFrame typ bs ---------------------------------------------------------------- +checkFrameSize :: FramePayloadDecoder -> FramePayloadDecoder +checkFrameSize func header@FrameHeader{..} body + | payloadLength > BS.length body = + Left $ ConnectionError FrameSizeError "payload is too short" + | otherwise = func header body + -- | Helper function to pull off the padding if its there, and will -- 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 -decodeWithPadding :: FrameHeader -> ByteString -> (ByteString -> FramePayload) -> FramePayload +decodeWithPadding :: FrameHeader -> ByteString -> (ByteString -> FramePayload) -> Either HTTP2Error 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 + bodylen = payloadLength - padlen - 1 + in if bodylen < 0 then + Left $ ConnectionError ProtocolError "padding is not enough" + else + Right . body $ BS.take bodylen rest + | otherwise = Right $ body bs where padded = testPadded flags diff --git a/Network/HTTP2/Encode.hs b/Network/HTTP2/Encode.hs --- a/Network/HTTP2/Encode.hs +++ b/Network/HTTP2/Encode.hs @@ -2,34 +2,33 @@ module Network.HTTP2.Encode ( encodeFrame + , encodeFrameChunks , encodeFrameHeader , encodeFramePayload - , buildFrame - , buildFrameHeader - , buildFramePayload , EncodeInfo(..) , encodeInfo ) where -import Blaze.ByteString.Builder (Builder) -import qualified Blaze.ByteString.Builder as BB -import Data.Bits -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import Data.Monoid ((<>), mempty) +import Data.Bits (shiftR, (.&.)) +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString, unsafeCreate) +import Data.Word (Word8, Word16, Word32) +import Foreign.Ptr (Ptr, plusPtr) +import Foreign.Storable (poke) import Network.HTTP2.Types ---------------------------------------------------------------- +type Builder = [ByteString] -> [ByteString] + -- | Auxiliary information for frame encoding. data EncodeInfo = EncodeInfo { -- | Flags to be set in a frame header encodeFlags :: FrameFlags -- | Stream id to be set in a frame header , encodeStreamId :: StreamIdentifier - -- | Padding if any + -- | Padding if any. In the case where this value is set but the priority flag is not set, this value gets preference over the priority flag. So, if this value is set, the priority flag is also set. , encodePadding :: Maybe Padding } deriving (Show,Read) @@ -53,40 +52,35 @@ -- >>> 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 :: FrameTypeId -> FrameHeader -> ByteString -encodeFrameHeader ftid header = run $ buildFrameHeader ftid header +encodeFrame einfo payload = BS.concat $ encodeFrameChunks einfo payload -encodeFramePayload :: EncodeInfo -> FramePayload -> ByteString -encodeFramePayload einfo payload = run payloadBuilder +-- | Encoding an HTTP/2 frame to ['ByteString']. +-- This is suitable for sendMany. +encodeFrameChunks :: EncodeInfo -> FramePayload -> [ByteString] +encodeFrameChunks einfo payload = bs : bss where - (_, payloadBuilder) = buildFramePayload einfo payload - -run :: Builder -> ByteString -run = BL.toStrict . BB.toLazyByteString - ----------------------------------------------------------------- + ftid = framePayloadToFrameTypeId payload + bs = encodeFrameHeader ftid header + (header, bss) = encodeFramePayload einfo payload -buildFrame :: EncodeInfo -> FramePayload -> Builder -buildFrame einfo payload = headerBuilder <> payloadBuilder +-- | Encoding an HTTP/2 frame header. +-- The frame header must be completed. +encodeFrameHeader :: FrameTypeId -> FrameHeader -> ByteString +encodeFrameHeader ftid FrameHeader{..} = unsafeCreate frameHeaderLength $ \ptr -> do + poke24 ptr payloadLength + poke8 ptr 3 typ + poke8 ptr 4 flags + poke32 (ptr `plusPtr` 5) sid where - (header, payloadBuilder) = buildFramePayload einfo payload - ftyp = framePayloadToFrameTypeId payload - headerBuilder = buildFrameHeader ftyp header - ----------------------------------------------------------------- + typ = fromFrameTypeId ftid + sid = fromIntegral $ fromStreamIdentifier streamId -buildFrameHeader :: FrameTypeId -> FrameHeader -> Builder -buildFrameHeader ftyp FrameHeader{..} = len <> typ <> flg <> sid +-- | Encoding an HTTP/2 frame payload. +-- This returns a complete frame header and chunks of payload. +encodeFramePayload :: EncodeInfo -> FramePayload -> (FrameHeader, [ByteString]) +encodeFramePayload einfo payload = (header, builder []) where - -- fixme: 2^14 check - len1 = BB.fromWord16be (fromIntegral (payloadLength `shiftR` 8)) - len2 = BB.fromWord8 (fromIntegral (payloadLength .&. 0xff)) - len = len1 <> len2 - typ = BB.fromWord8 $ fromFrameTypeId ftyp - flg = BB.fromWord8 flags - sid = BB.fromWord32be . fromIntegral $ fromStreamIdentifier streamId + (header, builder) = buildFramePayload einfo payload ---------------------------------------------------------------- @@ -128,51 +122,44 @@ (header, builder) where header = FrameHeader len newflags encodeStreamId - builder = bpadlen <> btarget <> bpadding - bpadlen = BB.fromWord8 $ fromIntegral paddingLength - bpadding = BB.fromByteString padding - paddingLength = B.length padding + builder = (b1 :) . btarget . (padding :) + b1 = BS.singleton $ fromIntegral paddingLength + paddingLength = BS.length padding len = targetLength + paddingLength + 1 newflags = setPadded encodeFlags buildPriority :: Priority -> Builder buildPriority Priority{..} = builder where - builder = bstream <> bweight + builder = (priority :) stream = fromStreamIdentifier streamDependency estream | exclusive = setExclusive stream | otherwise = stream - bstream = BB.fromWord32be $ fromIntegral estream - bweight = BB.fromWord8 $ fromIntegral $ weight - 1 - --- fixme: clear 31th bit? -buildStream :: StreamIdentifier -> Builder -buildStream = BB.fromWord32be . fromIntegral . fromStreamIdentifier - -buildErrorCodeId :: ErrorCodeId -> Builder -buildErrorCodeId = BB.fromWord32be . fromErrorCodeId + priority = unsafeCreate 5 $ \ptr -> do + poke32 ptr $ fromIntegral estream + poke8 ptr 4 $ fromIntegral $ weight - 1 ---------------------------------------------------------------- buildFramePayloadData :: EncodeInfo -> ByteString -> (FrameHeader, Builder) buildFramePayloadData einfo body = buildPadding einfo builder len where - builder = BB.fromByteString body - len = B.length body + builder = (body :) + len = BS.length body buildFramePayloadHeaders :: EncodeInfo -> Maybe Priority -> HeaderBlockFragment -> (FrameHeader, Builder) buildFramePayloadHeaders einfo Nothing hdr = buildPadding einfo builder len where - builder = BB.fromByteString hdr - len = B.length hdr + builder = (hdr :) + len = BS.length hdr buildFramePayloadHeaders einfo (Just pri) hdr = buildPadding einfo' builder len where - builder = buildPriority pri <> BB.fromByteString hdr - len = B.length hdr + 5 + builder = buildPriority pri . (hdr :) + len = BS.length hdr + 5 einfo' = einfo { encodeFlags = setPriority (encodeFlags einfo) } buildFramePayloadPriority :: EncodeInfo -> Priority -> (FrameHeader, Builder) @@ -184,50 +171,99 @@ buildFramePayloadRSTStream :: EncodeInfo -> ErrorCodeId -> (FrameHeader, Builder) buildFramePayloadRSTStream EncodeInfo{..} e = (header, builder) where - builder = buildErrorCodeId e + builder = (b4 :) + b4 = bytestring4 $ fromErrorCodeId e header = FrameHeader 4 encodeFlags encodeStreamId buildFramePayloadSettings :: EncodeInfo -> SettingsList -> (FrameHeader, Builder) buildFramePayloadSettings EncodeInfo{..} alist = (header, builder) where - builder = foldr op mempty alist - (key, val) `op` x = BB.fromWord16be (fromSettingsKeyId key) - <> BB.fromWord32be (fromIntegral val) <> x + builder = (settings :) + settings = unsafeCreate len $ \ptr -> go ptr alist + go _ [] = return () + go p ((k,v):kvs) = do + poke16 p $ fromSettingsKeyId k + poke32 (p `plusPtr` 2) $ fromIntegral v + go (p `plusPtr` 6) kvs len = length alist * 6 header = FrameHeader len encodeFlags encodeStreamId buildFramePayloadPushPromise :: EncodeInfo -> StreamIdentifier -> HeaderBlockFragment -> (FrameHeader, Builder) -buildFramePayloadPushPromise einfo sid hdr = buildPadding einfo builder len +buildFramePayloadPushPromise einfo stid hdr = buildPadding einfo builder len where - builder = buildStream sid <> BB.fromByteString hdr - len = 4 + B.length hdr + builder = (b4 :) . (hdr :) + b4 = bytestring4 $ fromIntegral $ fromStreamIdentifier stid + len = 4 + BS.length hdr buildFramePayloadPing :: EncodeInfo -> ByteString -> (FrameHeader, Builder) buildFramePayloadPing EncodeInfo{..} odata = (header, builder) where - builder = BB.fromByteString odata + builder = (odata :) header = FrameHeader 8 encodeFlags encodeStreamId buildFramePayloadGoAway :: EncodeInfo -> LastStreamId -> ErrorCodeId -> ByteString -> (FrameHeader, Builder) buildFramePayloadGoAway EncodeInfo{..} sid e debug = (header, builder) where - builder = buildStream sid <> buildErrorCodeId e <> BB.fromByteString debug - len = 4 + 4 + B.length debug + builder = (b8 :) . (debug :) + len0 = 8 + b8 = unsafeCreate len0 $ \ptr -> do + poke32 ptr $ fromIntegral $ fromStreamIdentifier sid + poke32 (ptr `plusPtr` 4) $ fromErrorCodeId e + len = len0 + BS.length debug header = FrameHeader len encodeFlags encodeStreamId buildFramePayloadWindowUpdate :: EncodeInfo -> WindowSizeIncrement -> (FrameHeader, Builder) buildFramePayloadWindowUpdate EncodeInfo{..} size = (header, builder) where -- fixme: reserve bit - builder = BB.fromWord32be size + builder = (b4 :) + b4 = bytestring4 size header = FrameHeader 4 encodeFlags encodeStreamId buildFramePayloadContinuation :: EncodeInfo -> HeaderBlockFragment -> (FrameHeader, Builder) buildFramePayloadContinuation EncodeInfo{..} hdr = (header, builder) where - builder = BB.fromByteString hdr - len = B.length hdr + builder = (hdr :) + len = BS.length hdr header = FrameHeader len encodeFlags encodeStreamId buildFramePayloadUnknown :: EncodeInfo -> ByteString -> (FrameHeader, Builder) buildFramePayloadUnknown = buildFramePayloadData + +---------------------------------------------------------------- + +poke8 :: Ptr Word8 -> Int -> Word8 -> IO () +poke8 ptr n w = poke (ptr `plusPtr` n) w + +poke16 :: Ptr Word8 -> Word16 -> IO () +poke16 ptr i = do + poke ptr w0 + poke8 ptr 1 w1 + where + w0 = fromIntegral ((i `shiftR` 8) .&. 0xff) + w1 = fromIntegral (i .&. 0xff) + +poke24 :: Ptr Word8 -> Int -> IO () +poke24 ptr i = do + poke ptr w0 + poke8 ptr 1 w1 + poke8 ptr 2 w2 + where + w0 = fromIntegral ((i `shiftR` 16) .&. 0xff) + w1 = fromIntegral ((i `shiftR` 8) .&. 0xff) + w2 = fromIntegral (i .&. 0xff) + +poke32 :: Ptr Word8 -> Word32 -> IO () +poke32 ptr i = do + poke ptr w0 + poke8 ptr 1 w1 + poke8 ptr 2 w2 + poke8 ptr 3 w3 + where + w0 = fromIntegral ((i `shiftR` 24) .&. 0xff) + w1 = fromIntegral ((i `shiftR` 16) .&. 0xff) + w2 = fromIntegral ((i `shiftR` 8) .&. 0xff) + w3 = fromIntegral (i .&. 0xff) + +bytestring4 :: Word32 -> ByteString +bytestring4 i = unsafeCreate 4 $ \ptr -> poke32 ptr i diff --git a/Network/HTTP2/Types.hs b/Network/HTTP2/Types.hs --- a/Network/HTTP2/Types.hs +++ b/Network/HTTP2/Types.hs @@ -36,6 +36,7 @@ , FrameHeader(..) , FramePayload(..) , framePayloadToFrameTypeId + , isPaddingDefined -- * Stream identifier , StreamIdentifier(..) , fromStreamIdentifier @@ -535,3 +536,19 @@ framePayloadToFrameTypeId (WindowUpdateFrame _) = FrameWindowUpdate framePayloadToFrameTypeId (ContinuationFrame _) = FrameContinuation framePayloadToFrameTypeId (UnknownFrame w8 _) = FrameUnknown w8 + +---------------------------------------------------------------- + +-- | Checking if padding is defined in this frame type. +isPaddingDefined :: FramePayload -> Bool +isPaddingDefined (DataFrame _) = True +isPaddingDefined (HeadersFrame _ _) = True +isPaddingDefined (PriorityFrame _) = False +isPaddingDefined (RSTStreamFrame _) = False +isPaddingDefined (SettingsFrame _) = False +isPaddingDefined (PushPromiseFrame _ _) = True +isPaddingDefined (PingFrame _) = False +isPaddingDefined (GoAwayFrame _ _ _) = False +isPaddingDefined (WindowUpdateFrame _) = False +isPaddingDefined (ContinuationFrame _) = False +isPaddingDefined (UnknownFrame _ _) = False diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,5 +1,5 @@ Name: http2 -Version: 0.8.0 +Version: 0.9.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -133,6 +133,7 @@ Other-Modules: Case JSON Build-Depends: base >= 4 && < 5 + , Glob , aeson , aeson-pretty , bytestring diff --git a/test-frame/Case.hs b/test-frame/Case.hs --- a/test-frame/Case.hs +++ b/test-frame/Case.hs @@ -44,8 +44,8 @@ where -- fromJust is unsafe frm = case decodeFrame defaultSettings $ fromJust $ unhex wire_hex of - Left e -> error $ show e - Right (r,_) -> r + Left e -> error $ show e + Right r -> r wireToCase CaseWire { wire_error = Just e, ..} = Case { description = wire_description , wire = wire_hex diff --git a/test-frame/JSON.hs b/test-frame/JSON.hs --- a/test-frame/JSON.hs +++ b/test-frame/JSON.hs @@ -13,7 +13,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as B8 import Data.HashMap.Strict (union) -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, fromMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -63,19 +63,6 @@ instance FromJSON StreamIdentifier where parseJSON x = StreamIdentifier <$> parseJSON x -instance ToJSON Priority where - toJSON (Priority e s w) = object [ - "exclusive" .= e - , "stream_dependency" .= s - , "weight" .= w - ] - -instance FromJSON Priority where - parseJSON (Object o) = Priority <$> o .: "exclusive" - <*> o .: "stream_dependency" - <*> o .: "weight" - parseJSON _ = mzero - instance ToJSON ErrorCodeId where toJSON e = toJSON $ fromErrorCodeId e @@ -101,11 +88,15 @@ "data" .= body ] toJSON (HeadersFrame mpri hdr) = object [ - "priority" .= mpri + "exclusive" .= fromMaybe Null (toJSON . exclusive <$> mpri) + , "stream_dependency" .= fromMaybe Null (toJSON . streamDependency <$> mpri) + , "weight" .= fromMaybe Null (toJSON . weight <$> mpri) , "header_block_fragment" .= hdr ] toJSON (PriorityFrame pri) = object [ - "priority" .= pri + "exclusive" .= exclusive pri + , "stream_dependency" .= streamDependency pri + , "weight" .= weight pri ] toJSON (RSTStreamFrame e) = object [ "error_code" .= e @@ -147,7 +138,9 @@ ] where padObj = case toJSON fpPad of - Null -> emptyPad + Null + | isPaddingDefined framePayload -> emptyPad + | otherwise -> noPad x -> x instance FromJSON FramePad where @@ -175,11 +168,27 @@ where ftid = toFrameTypeId ftyp +priority :: Object -> Parser Priority +priority o = Priority <$> o .: "exclusive" + <*> o .: "stream_dependency" + <*> o .: "weight" + +mpriority :: Object -> Parser (Maybe Priority) +mpriority o = do + me <- o .:? "exclusive" + ms <- o .:? "stream_dependency" + mw <- o .:? "weight" + return $ case me of + Nothing -> Nothing + Just ex -> Just $ Priority ex (fromJust ms) (fromJust mw) + parsePayload :: FrameTypeId -> Object -> Parser FramePayload parsePayload FrameData o = DataFrame <$> o .: "data" -parsePayload FrameHeaders o = HeadersFrame <$> o .: "priority" - <*> o .: "header_block_fragment" -parsePayload FramePriority o = PriorityFrame <$> o .: "priority" +parsePayload FrameHeaders o = do + mpri <- mpriority o + hdr <- o .: "header_block_fragment" + return $ HeadersFrame mpri hdr +parsePayload FramePriority o = PriorityFrame <$> priority o parsePayload FrameRSTStream o = RSTStreamFrame <$> o .: "error_code" parsePayload FrameSettings o = SettingsFrame <$> o .: "settings" parsePayload FramePushPromise o = PushPromiseFrame <$> o .: "promised_stream_id" @@ -190,6 +199,7 @@ <*> o .: "additional_debug_data" parsePayload FrameWindowUpdate o = WindowUpdateFrame <$> o .: "window_size_increment" parsePayload FrameContinuation o = ContinuationFrame <$> o .: "header_block_fragment" +parsePayload (FrameUnknown typ) o = UnknownFrame typ <$> o .: "dummy" instance ToJSON Pad where toJSON (Pad padding) = object [ @@ -202,6 +212,9 @@ "padding_length" .= Null , "padding" .= Null ] + +noPad :: Value +noPad = object [] ----------------------------------------------------------------