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