diff --git a/Network/HTTP2/Decode.hs b/Network/HTTP2/Decode.hs --- a/Network/HTTP2/Decode.hs +++ b/Network/HTTP2/Decode.hs @@ -25,14 +25,14 @@ import Control.Applicative ((<$>)) #endif import Data.Array (Array, listArray, (!)) -import Data.Bits (clearBit, shiftL, (.|.)) +import Data.Bits (clearBit) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..)) import Data.Word import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (peek) +import qualified Network.ByteOrder as N import System.IO.Unsafe (unsafeDupablePerformIO) import Network.HTTP2.Types @@ -59,14 +59,11 @@ decodeFrameHeader :: ByteString -> (FrameTypeId, FrameHeader) decodeFrameHeader (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do let p = ptr +. off - l0 <- fromIntegral <$> peek p - l1 <- fromIntegral <$> peek (p +. 1) - l2 <- fromIntegral <$> peek (p +. 2) - typ <- toFrameTypeId <$> peek (p +. 3) - flg <- peek (p +. 4) - w32 <- word32' (p +. 5) - let !len = (l0 `shiftL` 16) .|. (l1 `shiftL` 8) .|. l2 - !sid = streamIdentifier w32 + len <- fromIntegral <$> N.peek24 p 0 + typ <- toFrameTypeId <$> N.peek8 p 3 + flg <- N.peek8 p 4 + w32 <- N.peek32 p 5 + let !sid = streamIdentifier w32 return (typ, FrameHeader len flg sid) (+.) :: Ptr Word8 -> Int -> Ptr Word8 @@ -90,6 +87,13 @@ Left $ ConnectionError ProtocolError "cannot used in non-zero stream" | otherwise = checkType typ where + checkType FrameHeaders + | testPadded flags && payloadLength < 1 = + Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length" + | testPriority flags && payloadLength < 5 = + Left $ ConnectionError FrameSizeError "insufficient payload for priority fields" + | testPadded flags && testPriority flags && payloadLength < 6 = + Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length and priority fields" checkType FramePriority | payloadLength /= 5 = Left $ StreamError FrameSizeError streamId checkType FrameRSTStream | payloadLength /= 4 = @@ -182,7 +186,7 @@ -- | Frame payload decoder for RST_STREAM frame. decoderstStreamFrame :: FramePayloadDecoder -decoderstStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCodeId (word32 bs) +decoderstStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCodeId (N.word32 bs) -- | Frame payload decoder for SETTINGS frame. decodeSettingsFrame :: FramePayloadDecoder @@ -194,13 +198,13 @@ settings num p id settings 0 _ builder = return $ builder [] settings n p builder = do - rawSetting <- word16' p + rawSetting <- N.peek16 p 0 let msettings = toSettingsKeyId rawSetting n' = n - 1 case msettings of Nothing -> settings n' (p +. 6) builder -- ignoring unknown one (Section 6.5.2) Just k -> do - w32 <- word32' (p +. 2) + w32 <- N.peek32 p 2 let v = fromIntegral w32 settings n' (p +. 6) (builder. ((k,v):)) @@ -208,7 +212,7 @@ decodePushPromiseFrame :: FramePayloadDecoder decodePushPromiseFrame header bs = decodeWithPadding header bs $ \bs' -> let (bs0,bs1) = BS.splitAt 4 bs' - sid = streamIdentifier (word32 bs0) + sid = streamIdentifier (N.word32 bs0) in PushPromiseFrame sid bs1 -- | Frame payload decoder for PING frame. @@ -221,8 +225,8 @@ where (bs0,bs1') = BS.splitAt 4 bs (bs1,bs2) = BS.splitAt 4 bs1' - sid = streamIdentifier (word32 bs0) - ecid = toErrorCodeId (word32 bs1) + sid = streamIdentifier (N.word32 bs0) + ecid = toErrorCodeId (N.word32 bs1) -- | Frame payload decoder for WINDOW_UPDATE frame. decodeWindowUpdateFrame :: FramePayloadDecoder @@ -230,7 +234,7 @@ | wsi == 0 = Left $ ConnectionError ProtocolError "window update must not be 0" | otherwise = Right $ WindowUpdateFrame wsi where - !wsi = fromIntegral (word32 bs `clearBit` 31) + !wsi = fromIntegral (N.word32 bs `clearBit` 31) -- | Frame payload decoder for CONTINUATION frame. decodeContinuationFrame :: FramePayloadDecoder @@ -270,36 +274,12 @@ priority :: ByteString -> Priority priority (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do let p = ptr +. off - w32 <- word32' p + w32 <- N.peek32 p 0 let !streamdId = streamIdentifier w32 !exclusive = testExclusive (fromIntegral w32) -- fixme - w8 <- peek (p +. 4) + w8 <- N.peek8 p 4 let weight = intFromWord8 w8 + 1 return $ Priority exclusive streamdId weight intFromWord8 :: Word8 -> Int intFromWord8 = fromIntegral - -word32 :: ByteString -> Word32 -word32 (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do - let p = ptr +. off - word32' p -{-# INLINE word32 #-} - -word32' :: Ptr Word8 -> IO Word32 -word32' p = do - w0 <- fromIntegral <$> peek p - w1 <- fromIntegral <$> peek (p +. 1) - w2 <- fromIntegral <$> peek (p +. 2) - w3 <- fromIntegral <$> peek (p +. 3) - let !w32 = (w0 `shiftL` 24) .|. (w1 `shiftL` 16) .|. (w2 `shiftL` 8) .|. w3 - return w32 -{-# INLINE word32' #-} - -word16' :: Ptr Word8 -> IO Word16 -word16' p = do - w0 <- fromIntegral <$> peek p - w1 <- fromIntegral <$> peek (p +. 1) - let !w16 = (w0 `shiftL` 8) .|. w1 - return w16 -{-# INLINE word16' #-} diff --git a/Network/HTTP2/Encode.hs b/Network/HTTP2/Encode.hs --- a/Network/HTTP2/Encode.hs +++ b/Network/HTTP2/Encode.hs @@ -10,12 +10,11 @@ , encodeInfo ) where -import Data.Bits (shiftR, (.&.)) import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString, unsafeCreate) -import Data.Word (Word8, Word16, Word32) +import Data.Word (Word8) import Foreign.Ptr (Ptr, plusPtr) -import Foreign.Storable (poke) +import qualified Network.ByteOrder as N import Network.HTTP2.Types @@ -73,11 +72,12 @@ -- The length of the buffer must be larger than or equal to 9 bytes. encodeFrameHeaderBuf :: FrameTypeId -> FrameHeader -> Ptr Word8 -> IO () encodeFrameHeaderBuf ftid FrameHeader{..} ptr = do - poke24 ptr payloadLength - poke8 ptr 3 typ - poke8 ptr 4 flags - poke32 (ptr `plusPtr` 5) sid + N.poke24 plen ptr 0 + N.poke8 typ ptr 3 + N.poke8 flags ptr 4 + N.poke32 sid ptr 5 where + plen = fromIntegral payloadLength typ = fromFrameTypeId ftid sid = fromIntegral streamId @@ -142,8 +142,10 @@ | exclusive = setExclusive streamDependency | otherwise = streamDependency priority = unsafeCreate 5 $ \ptr -> do - poke32 ptr $ fromIntegral estream - poke8 ptr 4 $ fromIntegral $ weight - 1 + let esid = fromIntegral estream + w = fromIntegral $ weight - 1 + N.poke32 esid ptr 0 + N.poke8 w ptr 4 ---------------------------------------------------------------- @@ -177,7 +179,7 @@ buildFramePayloadRSTStream EncodeInfo{..} e = (header, builder) where builder = (b4 :) - b4 = bytestring4 $ fromErrorCodeId e + b4 = N.bytestring32 $ fromErrorCodeId e header = FrameHeader 4 encodeFlags encodeStreamId buildFramePayloadSettings :: EncodeInfo -> SettingsList -> (FrameHeader, Builder) @@ -187,8 +189,8 @@ 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 + N.poke16 (fromSettingsKeyId k) p 0 + N.poke32 (fromIntegral v) p 2 go (p `plusPtr` 6) kvs len = length alist * 6 header = FrameHeader len encodeFlags encodeStreamId @@ -197,7 +199,7 @@ buildFramePayloadPushPromise einfo sid hdr = buildPadding einfo builder len where builder = (b4 :) . (hdr :) - b4 = bytestring4 $ fromIntegral sid + b4 = N.bytestring32 $ fromIntegral sid len = 4 + BS.length hdr buildFramePayloadPing :: EncodeInfo -> ByteString -> (FrameHeader, Builder) @@ -212,8 +214,8 @@ builder = (b8 :) . (debug :) len0 = 8 b8 = unsafeCreate len0 $ \ptr -> do - poke32 ptr $ fromIntegral sid - poke32 (ptr `plusPtr` 4) $ fromErrorCodeId e + N.poke32 (fromIntegral sid) ptr 0 + N.poke32 (fromErrorCodeId e) ptr 4 len = len0 + BS.length debug header = FrameHeader len encodeFlags encodeStreamId @@ -222,7 +224,7 @@ where -- fixme: reserve bit builder = (b4 :) - b4 = bytestring4 $ fromIntegral size + b4 = N.bytestring32 $ fromIntegral size header = FrameHeader 4 encodeFlags encodeStreamId buildFramePayloadContinuation :: EncodeInfo -> HeaderBlockFragment -> (FrameHeader, Builder) @@ -234,41 +236,3 @@ 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/bench-priority/Main.hs b/bench-priority/Main.hs --- a/bench-priority/Main.hs +++ b/bench-priority/Main.hs @@ -5,7 +5,7 @@ import Control.Concurrent.STM import Criterion.Main import Data.List (foldl') -import System.Random +import System.Random.MWC import qualified RingOfQueuesSTM as A import qualified RingOfQueues as AIO @@ -26,9 +26,9 @@ main :: IO () main = do - gen <- getStdGen + gen <- create + ws <- uniformRs (1,256) gen numOfStreams let ks = [1,3..] - ws = take numOfStreams $ randomRs (1,256) gen xs = zip ks ws defaultMain [ bgroup "enqueue & dequeue" [ @@ -49,6 +49,13 @@ , bench "Ring of Queues IO" $ nfIO (deleteAIO xs) ] ] + where + uniformRs range gen n = loop n [] + where + loop 0 rs = return rs + loop i rs = do + r <- uniformR range gen + loop (i-1) (r:rs) ---------------------------------------------------------------- diff --git a/bench-priority/RandomSkewHeap.hs b/bench-priority/RandomSkewHeap.hs --- a/bench-priority/RandomSkewHeap.hs +++ b/bench-priority/RandomSkewHeap.hs @@ -5,7 +5,7 @@ -- If we take weight as priority, a typical heap (priority queue) -- is not fair enough. Consider two weight 201 for A and 101 for B. -- A typical heap would generate A(201), A(200), A(199), A(198), ...., --- and finaly A(101), B(101), A(100), B(100). +-- and finally A(101), B(101), A(100), B(100). -- What we want is A, A, B, A, A, B... -- -- So, we introduce randomness to Skew Heap. diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,5 +1,5 @@ Name: http2 -Version: 1.6.3 +Version: 1.6.4 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -79,12 +79,12 @@ Network.HTTP2.Priority.PSQ Network.HTTP2.Priority.Queue Network.HTTP2.Types - Build-Depends: base >= 4.6 && < 5 + Build-Depends: base >= 4.8 && < 5 , array , bytestring >= 0.10 - , bytestring-builder , case-insensitive , containers >= 0.5 + , network-byte-order , psqueues , stm @@ -115,11 +115,11 @@ Build-Depends: base >= 4 && < 5 , array , bytestring - , bytestring-builder , case-insensitive , containers , hex , hspec >= 1.3 + , network-byte-order , psqueues , stm , word8 @@ -138,13 +138,13 @@ , aeson-pretty , array , bytestring - , bytestring-builder , case-insensitive , containers , directory , filepath , hex , hspec >= 1.3 + , network-byte-order , text , unordered-containers , vector @@ -159,7 +159,7 @@ Other-Modules: Case JSON Build-Depends: base >= 4 && < 5 - , Glob + , Glob >= 0.9 , aeson , aeson-pretty , bytestring @@ -168,6 +168,7 @@ , hex , hspec >= 1.3 , http2 + , network-byte-order , text , unordered-containers @@ -188,10 +189,10 @@ , aeson-pretty , array , bytestring - , bytestring-builder , case-insensitive , containers , hex + , network-byte-order , text , unordered-containers , vector @@ -210,10 +211,10 @@ , aeson , array , bytestring - , bytestring-builder , case-insensitive , containers , hex + , network-byte-order , text , unordered-containers , vector @@ -233,11 +234,11 @@ , aeson-pretty , array , bytestring - , bytestring-builder , case-insensitive , containers , directory , filepath + , network-byte-order , text , unordered-containers , vector @@ -281,9 +282,9 @@ , case-insensitive , containers , criterion - , hashtables , heaps , mwc-random + , network-byte-order , psqueues , stm @@ -299,5 +300,5 @@ , case-insensitive , containers , criterion - , hashtables + , network-byte-order , stm