http2 3.0.3 → 4.0.0
raw patch · 47 files changed
+1162/−2729 lines, 47 filesdep +unliftiodep −heapsdep −mwc-randomdep ~basedep ~containersdep ~network-byte-order
Dependencies added: unliftio
Dependencies removed: heaps, mwc-random
Dependency ranges changed: base, containers, network-byte-order
Files
- ChangeLog.md +10/−0
- Imports.hs +4/−0
- Network/HPACK/HeaderBlock/Decode.hs +1/−1
- Network/HPACK/Table/Dynamic.hs +33/−25
- Network/HTTP2.hs +0/−7
- Network/HTTP2/Arch/Context.hs +28/−17
- Network/HTTP2/Arch/EncodeFrame.hs +2/−2
- Network/HTTP2/Arch/HPACK.hs +17/−9
- Network/HTTP2/Arch/Manager.hs +3/−3
- Network/HTTP2/Arch/Queue.hs +3/−3
- Network/HTTP2/Arch/Receiver.hs +102/−101
- Network/HTTP2/Arch/Sender.hs +8/−12
- Network/HTTP2/Arch/Stream.hs +2/−2
- Network/HTTP2/Arch/Types.hs +48/−5
- Network/HTTP2/Client.hs +24/−15
- Network/HTTP2/Client/Run.hs +24/−17
- Network/HTTP2/Frame.hs +17/−23
- Network/HTTP2/Frame/Decode.hs +57/−50
- Network/HTTP2/Frame/Encode.hs +10/−10
- Network/HTTP2/Frame/Types.hs +224/−323
- Network/HTTP2/Priority.hs +0/−154
- Network/HTTP2/Priority/Internal.hs +0/−5
- Network/HTTP2/Priority/PSQ.hs +0/−111
- Network/HTTP2/Priority/Queue.hs +0/−42
- Network/HTTP2/Server.hs +1/−3
- Network/HTTP2/Server/Run.hs +6/−11
- Network/HTTP2/Server/Types.hs +0/−4
- Network/HTTP2/Server/Worker.hs +9/−8
- bench-priority/BinaryHeap.hs +0/−175
- bench-priority/BinaryHeapSTM.hs +0/−174
- bench-priority/DoublyLinkedQueueIO.hs +0/−85
- bench-priority/Heap.hs +0/−121
- bench-priority/Main.hs +0/−240
- bench-priority/RandomSkewHeap.hs +0/−108
- bench-priority/RingOfQueues.hs +0/−156
- bench-priority/RingOfQueuesSTM.hs +0/−149
- http2.cabal +403/−405
- test-frame/Case.hs +2/−2
- test-frame/FrameSpec.hs +4/−3
- test-frame/JSON.hs +18/−14
- test/HPACK/IntegerSpec.hs +2/−1
- test/HTTP2/ClientSpec.hs +75/−0
- test/HTTP2/FrameSpec.hs +3/−2
- test/HTTP2/PrioritySpec.hs +0/−109
- test/HTTP2/ServerSpec.hs +1/−1
- test/doctests.hs +1/−1
- util/client.hs +20/−20
ChangeLog.md view
@@ -1,3 +1,13 @@+## 4.0.0++* Breaking change: `HTTP2Error` is redefined.+* Breaking change: `FrameTypeId`, `SettingsKeyId` and `ErrorCodeId` are removed.+ Use `FrameType`, `SettingsKey` and `ErrorCode` instead.+* A client can receive a concrete `HTTP2Error`.+* Catching up RFC 9113. Host: and :authority cannot disagree.+* Breaking change: `Network.HTTP2` and `Network.HTTP2.Priority` are removed.+* Breaking change: obsoleted stuff are removed.+ ## 3.0.3 * Return correct status messages in HTTP2 client
Imports.hs view
@@ -1,8 +1,10 @@ module Imports ( ByteString(..)+ , ShortByteString , module Control.Applicative , module Control.Monad , module Data.Bits+ , module Data.Either , module Data.List , module Data.Foldable , module Data.Int@@ -20,6 +22,8 @@ import Control.Monad import Data.Bits hiding (Bits) import Data.ByteString.Internal (ByteString(..))+import Data.ByteString.Short (ShortByteString)+import Data.Either import Data.Foldable import Data.Int import Data.List
Network/HPACK/HeaderBlock/Decode.hs view
@@ -34,7 +34,7 @@ -- | An array to get 'HeaderValue' quickly. -- 'getHeaderValue' should be used.--- Internally, the key is 'Token' 'ix'.+-- Internally, the key is 'tokenIx'. type ValueTable = Array Int (Maybe HeaderValue) -- | Accessing 'HeaderValue' with 'Token'.
Network/HPACK/Table/Dynamic.hs view
@@ -79,16 +79,24 @@ 1 2 3 4 (numOfEntries = 4) -} -data CodeInfo =- EncodeInfo RevIndex -- Reverse index- -- The value informed by SETTINGS_HEADER_TABLE_SIZE.- -- If 'Nothing', dynamic table size update is not necessary.- -- Otherwise, dynamic table size update is sent- -- and this value should be set to 'Nothing'.- (IORef (Maybe Size))- | DecodeInfo HuffmanDecoder- (IORef Size) -- The limit size+data CodeInfo = CIE EncodeInfo | CID DecodeInfo+data EncodeInfo = EncodeInfo RevIndex -- Reverse index+ -- The value informed by SETTINGS_HEADER_TABLE_SIZE.+ -- If 'Nothing', dynamic table size update is not necessary.+ -- Otherwise, dynamic table size update is sent+ -- and this value should be set to 'Nothing'.+ (IORef (Maybe Size))+data DecodeInfo = DecodeInfo HuffmanDecoder+ (IORef Size) -- The limit size +toEncodeInfo :: CodeInfo -> EncodeInfo+toEncodeInfo (CIE x) = x+toEncodeInfo _ = error "toEncodeInfo"++toDecodeInfo :: CodeInfo -> DecodeInfo+toDecodeInfo (CID x) = x+toDecodeInfo _ = error "toDecodeInfo"+ -- | Type for dynamic table. data DynamicTable = DynamicTable { codeInfo :: CodeInfo@@ -116,7 +124,7 @@ huffmanDecoder :: DynamicTable -> HuffmanDecoder huffmanDecoder DynamicTable{..} = dec where- DecodeInfo dec _ = codeInfo+ DecodeInfo dec _ = toDecodeInfo codeInfo ---------------------------------------------------------------- @@ -156,7 +164,7 @@ isSuitableSize :: Size -> DynamicTable -> IO Bool isSuitableSize siz DynamicTable{..} = do- let DecodeInfo _ limref = codeInfo+ let DecodeInfo _ limref = toDecodeInfo codeInfo lim <- readIORef limref return $ siz <= lim @@ -164,7 +172,7 @@ needChangeTableSize :: DynamicTable -> IO TableSizeAction needChangeTableSize DynamicTable{..} = do- let EncodeInfo _ limref = codeInfo+ let EncodeInfo _ limref = toEncodeInfo codeInfo mlim <- readIORef limref maxsiz <- readIORef maxDynamicTableSize return $ case mlim of@@ -177,12 +185,12 @@ -- its value should be set by this function. setLimitForEncoding :: Size -> DynamicTable -> IO () setLimitForEncoding siz DynamicTable{..} = do- let EncodeInfo _ limref = codeInfo+ let EncodeInfo _ limref = toEncodeInfo codeInfo writeIORef limref $ Just siz resetLimitForEncoding :: DynamicTable -> IO () resetLimitForEncoding DynamicTable{..} = do- let EncodeInfo _ limref = codeInfo+ let EncodeInfo _ limref = toEncodeInfo codeInfo writeIORef limref Nothing ----------------------------------------------------------------@@ -193,7 +201,7 @@ newDynamicTableForEncoding maxsiz = do rev <- newRevIndex lim <- newIORef Nothing- let info = EncodeInfo rev lim+ let info = CIE $ EncodeInfo rev lim newDynamicTable maxsiz info -- | Creating 'DynamicTable' for decoding.@@ -204,7 +212,7 @@ lim <- newIORef maxsiz buf <- mallocPlainForeignPtrBytes huftmpsiz let decoder = decodeH buf huftmpsiz- info = DecodeInfo decoder lim+ info = CID $ DecodeInfo decoder lim newDynamicTable maxsiz info newDynamicTable :: Size -> CodeInfo -> IO DynamicTable@@ -236,8 +244,8 @@ writeIORef dynamicTableSize 0 writeIORef maxDynamicTableSize maxsiz case codeInfo of- EncodeInfo rev _ -> renewRevIndex rev- _ -> return ()+ CIE (EncodeInfo rev _) -> renewRevIndex rev+ _ -> return () copyEntries dyntbl entries getEntries :: DynamicTable -> IO [Entry]@@ -296,8 +304,8 @@ insertFront e dyntbl es <- adjustTableSize dyntbl case codeInfo of- EncodeInfo rev _ -> deleteRevIndexList es rev- _ -> return ()+ CIE (EncodeInfo rev _) -> deleteRevIndexList es rev+ _ -> return () insertFront :: Entry -> DynamicTable -> IO () insertFront e DynamicTable{..} = do@@ -317,8 +325,8 @@ writeIORef numOfEntries $ n + 1 writeIORef dynamicTableSize dsize' case codeInfo of- EncodeInfo rev _ -> insertRevIndex e (DIndex i) rev- _ -> return ()+ CIE (EncodeInfo rev _) -> insertRevIndex e (DIndex i) rev+ _ -> return () adjustTableSize :: DynamicTable -> IO [Entry] adjustTableSize dyntbl@DynamicTable{..} = adjust []@@ -348,8 +356,8 @@ writeIORef numOfEntries $ n + 1 writeIORef dynamicTableSize dsize' case codeInfo of- EncodeInfo rev _ -> insertRevIndex e (DIndex i) rev- _ -> return ()+ CIE (EncodeInfo rev _) -> insertRevIndex e (DIndex i) rev+ _ -> return () ---------------------------------------------------------------- @@ -387,4 +395,4 @@ getRevIndex :: DynamicTable-> RevIndex getRevIndex DynamicTable{..} = rev where- EncodeInfo rev _ = codeInfo+ EncodeInfo rev _ = toEncodeInfo codeInfo
− Network/HTTP2.hs
@@ -1,7 +0,0 @@--- | Framing in HTTP\/2(<https://tools.ietf.org/html/rfc7540>).-module Network.HTTP2 {-# DEPRECATED "Use Network.HTTP2.Frame instead" #-}- (- module Network.HTTP2.Frame- ) where--import Network.HTTP2.Frame
Network/HTTP2/Arch/Context.hs view
@@ -2,9 +2,9 @@ module Network.HTTP2.Arch.Context where -import Control.Concurrent.STM import Data.IORef import Network.HTTP.Types (Method)+import UnliftIO.STM import Imports hiding (insert) import Network.HPACK@@ -19,28 +19,39 @@ ---------------------------------------------------------------- -data RoleInfo = ServerInfo {- inputQ :: TQueue (Input Stream)- }- | ClientInfo {- scheme :: ByteString- , authority :: ByteString- , cache :: IORef (Cache (Method,ByteString) Stream)- }+data RoleInfo = RIS ServerInfo | RIC ClientInfo +data ServerInfo = ServerInfo {+ inputQ :: TQueue (Input Stream)+ }++data ClientInfo = ClientInfo {+ scheme :: ByteString+ , authority :: ByteString+ , cache :: IORef (Cache (Method,ByteString) Stream)+ }++toServerInfo :: RoleInfo -> ServerInfo+toServerInfo (RIS x) = x+toServerInfo _ = error "toServerInfo"++toClientInfo :: RoleInfo -> ClientInfo+toClientInfo (RIC x) = x+toClientInfo _ = error "toClientInfo"+ newServerInfo :: IO RoleInfo-newServerInfo = ServerInfo <$> newTQueueIO+newServerInfo = RIS . ServerInfo <$> newTQueueIO newClientInfo :: ByteString -> ByteString -> Int -> IO RoleInfo-newClientInfo scm auth lim = ClientInfo scm auth <$> newIORef (emptyCache lim)+newClientInfo scm auth lim = RIC . ClientInfo scm auth <$> newIORef (emptyCache lim) insertCache :: Method -> ByteString -> Stream -> RoleInfo -> IO ()-insertCache m path v (ClientInfo _ _ ref) = atomicModifyIORef' ref $ \c ->+insertCache m path v (RIC (ClientInfo _ _ ref)) = atomicModifyIORef' ref $ \c -> (Cache.insert (m,path) v c, ()) insertCache _ _ _ _ = error "insertCache" lookupCache :: Method -> ByteString -> RoleInfo -> IO (Maybe Stream)-lookupCache m path (ClientInfo _ _ ref) = Cache.lookup (m,path) <$> readIORef ref+lookupCache m path (RIC (ClientInfo _ _ ref)) = Cache.lookup (m,path) <$> readIORef ref lookupCache _ _ _ = error "lookupCache" ----------------------------------------------------------------@@ -54,7 +65,7 @@ , firstSettings :: IORef Bool , streamTable :: StreamTable , concurrency :: IORef Int- -- | RFC 7540 says "Other frames (from any stream) MUST NOT+ -- | RFC 9113 says "Other frames (from any stream) MUST NOT -- occur between the HEADERS frame and any CONTINUATION -- frames that might follow". This field is used to implement -- this requirement.@@ -94,8 +105,8 @@ <*> newRate where rl = case rinfo of- ClientInfo{} -> Client- _ -> Server+ RIC{} -> Client+ _ -> Server sid0 | rl == Client = 1 | otherwise = 2 @@ -159,7 +170,7 @@ atomicModifyIORef' concurrency (\x -> (x-1,())) setStreamState ctx strm (Closed cc) -- anyway -openStream :: Context -> StreamId -> FrameTypeId -> IO Stream+openStream :: Context -> StreamId -> FrameType -> IO Stream openStream ctx@Context{streamTable, http2settings} sid ftyp = do ws <- initialWindowSize <$> readIORef http2settings newstrm <- newStream sid $ fromIntegral ws
Network/HTTP2/Arch/EncodeFrame.hs view
@@ -6,13 +6,13 @@ ---------------------------------------------------------------- -goawayFrame :: StreamId -> ErrorCodeId -> ByteString -> ByteString+goawayFrame :: StreamId -> ErrorCode -> ByteString -> ByteString goawayFrame sid etype debugmsg = encodeFrame einfo frame where einfo = encodeInfo id 0 frame = GoAwayFrame sid etype debugmsg -resetFrame :: ErrorCodeId -> StreamId -> ByteString+resetFrame :: ErrorCode -> StreamId -> ByteString resetFrame etype sid = encodeFrame einfo frame where einfo = encodeInfo id sid
Network/HTTP2/Arch/HPACK.hs view
@@ -18,6 +18,7 @@ import Network.HPACK import Network.HPACK.Token import Network.HTTP2.Arch.Context+import Network.HTTP2.Arch.Types import Network.HTTP2.Frame -- $setup@@ -62,21 +63,21 @@ ---------------------------------------------------------------- -hpackDecodeHeader :: HeaderBlockFragment -> Context -> IO HeaderTable-hpackDecodeHeader hdrblk ctx = do- tbl@(_,vt) <- hpackDecodeTrailer hdrblk ctx+hpackDecodeHeader :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable+hpackDecodeHeader hdrblk sid ctx = do+ tbl@(_,vt) <- hpackDecodeTrailer hdrblk sid ctx if isClient ctx || checkRequestHeader vt then return tbl else- E.throwIO $ ConnectionError ProtocolError "the header key is illegal"+ E.throwIO $ StreamErrorIsSent ProtocolError sid -hpackDecodeTrailer :: HeaderBlockFragment -> Context -> IO HeaderTable-hpackDecodeTrailer hdrblk Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl+hpackDecodeTrailer :: HeaderBlockFragment -> StreamId -> Context -> IO HeaderTable+hpackDecodeTrailer hdrblk sid Context{..} = decodeTokenHeader decodeDynamicTable hdrblk `E.catch` handl where handl IllegalHeaderName =- E.throwIO $ ConnectionError ProtocolError "the header key is illegal"+ E.throwIO $ StreamErrorIsSent ProtocolError sid handl _ =- E.throwIO $ ConnectionError CompressionError "cannot decompress the header"+ E.throwIO $ StreamErrorIsSent CompressionError sid {-# INLINE checkRequestHeader #-} checkRequestHeader :: ValueTable -> Bool@@ -89,7 +90,7 @@ | mPath == Just "" = False | isJust mConnection = False | just mTE (/= "trailers") = False- | otherwise = True+ | otherwise = checkAuth mAuthority mHost where mStatus = getHeaderValue tokenStatus reqvt mScheme = getHeaderValue tokenScheme reqvt@@ -97,6 +98,13 @@ mMethod = getHeaderValue tokenMethod reqvt mConnection = getHeaderValue tokenConnection reqvt mTE = getHeaderValue tokenTE reqvt+ mAuthority = getHeaderValue tokenAuthority reqvt+ mHost = getHeaderValue tokenHost reqvt++checkAuth :: Maybe ByteString -> Maybe ByteString -> Bool+checkAuth Nothing Nothing = False+checkAuth (Just a) (Just h) | a /= h = False+checkAuth _ _ = True {-# INLINE just #-} just :: Maybe a -> (a -> Bool) -> Bool
Network/HTTP2/Arch/Manager.hs view
@@ -14,14 +14,14 @@ , timeoutClose ) where -import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Exception as E import Data.Foldable import Data.IORef import Data.Set (Set) import qualified Data.Set as Set import qualified System.TimeManager as T+import UnliftIO.Concurrent+import qualified UnliftIO.Exception as E+import UnliftIO.STM import Imports
Network/HTTP2/Arch/Queue.hs view
@@ -2,9 +2,9 @@ module Network.HTTP2.Arch.Queue where -import Control.Concurrent (forkIO)-import Control.Concurrent.STM-import Control.Exception (bracket)+import UnliftIO.Concurrent (forkIO)+import UnliftIO.Exception (bracket)+import UnliftIO.STM import Imports import Network.HTTP2.Arch.Manager
Network/HTTP2/Arch/Receiver.hs view
@@ -9,12 +9,13 @@ , initialFrame ) where -import Control.Concurrent-import Control.Concurrent.STM-import qualified Control.Exception as E import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Short as Short import Data.IORef+import UnliftIO.Concurrent+import qualified UnliftIO.Exception as E+import UnliftIO.STM import Imports hiding (delete, insert) import Network.HPACK@@ -70,43 +71,58 @@ if BS.null hd then enqueueControl controlQ CFinish else do- cont <- processFrame ctx recvN $ decodeFrameHeader hd- when cont $ loop (n + 1)+ processFrame ctx recvN $ decodeFrameHeader hd+ loop (n + 1) sendGoaway e- | Just (ConnectionError err msg) <- E.fromException e = do- psid <- getPeerStreamID ctx- let frame = goawayFrame psid err msg+ | Just ConnectionIsClosed <- E.fromException e = E.throwIO ConnectionIsClosed+ | Just (ConnectionErrorIsReceived _ _ _) <- E.fromException e =+ E.throwIO e+ | Just (ConnectionErrorIsSent err sid msg) <- E.fromException e = do+ let frame = goawayFrame sid err $ Short.fromShort msg enqueueControl controlQ $ CGoaway frame- | otherwise = return ()+ | Just (StreamErrorIsSent err sid) <- E.fromException e = do+ let frame = resetFrame err sid+ enqueueControl controlQ $ CFrame frame+ let frame' = goawayFrame sid err "treat a stream error as a connection error"+ enqueueControl controlQ $ CGoaway frame'+ E.throwIO e+ | Just (StreamErrorIsReceived err sid) <- E.fromException e = do+ let frame = goawayFrame sid err "treat a stream error as a connection error"+ enqueueControl controlQ $ CGoaway frame+ E.throwIO e+ -- this never happens+ | Just x@(BadThingHappen _) <- E.fromException e = E.throwIO x+ | otherwise = E.throwIO $ BadThingHappen e ---------------------------------------------------------------- -processFrame :: Context -> RecvN -> (FrameTypeId, FrameHeader) -> IO Bool+processFrame :: Context -> RecvN -> (FrameType, FrameHeader) -> IO () processFrame ctx _recvN (fid, FrameHeader{streamId}) | isServer ctx && isServerInitiated streamId && (fid `notElem` [FramePriority,FrameRSTStream,FrameWindowUpdate]) =- E.throwIO $ ConnectionError ProtocolError "stream id should be odd"-processFrame Context{..} recvN (FrameUnknown _, FrameHeader{payloadLength}) = do+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "stream id should be odd"++processFrame Context{..} recvN (ftyp, FrameHeader{payloadLength,streamId})+ | ftyp > maxFrameType = do mx <- readIORef continued case mx of Nothing -> do -- ignoring unknown frame void $ recvN payloadLength- return True- Just _ -> E.throwIO $ ConnectionError ProtocolError "unknown frame"-processFrame ctx recvN (FramePushPromise, header@FrameHeader{payloadLength})- | isServer ctx = E.throwIO $ ConnectionError ProtocolError "push promise is not allowed"+ Just _ -> E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "unknown frame"+processFrame ctx recvN (FramePushPromise, header@FrameHeader{payloadLength,streamId})+ | isServer ctx = E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "push promise is not allowed" | otherwise = do pl <- recvN payloadLength PushPromiseFrame sid frag <- guardIt $ decodePushPromiseFrame header pl unless (isServerInitiated sid) $- E.throwIO $ ConnectionError ProtocolError "wrong sid for push promise"+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "wrong sid for push promise" when (frag == "") $- E.throwIO $ ConnectionError ProtocolError "wrong header fragment for push promise"- (_,vt) <- hpackDecodeHeader frag ctx- let ClientInfo{..} = roleInfo ctx+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "wrong header fragment for push promise"+ (_,vt) <- hpackDecodeHeader frag streamId ctx+ let ClientInfo{..} = toClientInfo $ roleInfo ctx when (getHeaderValue tokenAuthority vt == Just authority && getHeaderValue tokenScheme vt == Just scheme) $ do let mmethod = getHeaderValue tokenMethod vt@@ -116,32 +132,15 @@ strm <- openStream ctx sid FramePushPromise insertCache method path strm $ roleInfo ctx _ -> return ()- return True-processFrame ctx@Context{..} recvN typhdr@(ftyp, header@FrameHeader{payloadLength}) = do+processFrame ctx@Context{..} recvN typhdr@(ftyp, header) = do settings <- readIORef http2settings case checkFrameHeader settings typhdr of- Left h2err -> case h2err of- StreamError err sid -> do- resetStream err sid- void $ recvN payloadLength- return True- connErr -> E.throwIO connErr- Right _ -> do- ex <- E.try $ controlOrStream ctx recvN ftyp header- case ex of- Left (StreamError err sid) -> do- resetStream err sid- return True- Left connErr -> E.throw connErr- Right cont -> return cont- where- resetStream err sid = do- let frame = resetFrame err sid- enqueueControl controlQ $ CFrame frame+ Left (FrameDecodeError ec sid msg) -> E.throwIO $ ConnectionErrorIsSent ec sid msg+ Right _ -> controlOrStream ctx recvN ftyp header ---------------------------------------------------------------- -controlOrStream :: Context -> RecvN -> FrameTypeId -> FrameHeader -> IO Bool+controlOrStream :: Context -> RecvN -> FrameType -> FrameHeader -> IO () controlOrStream ctx@Context{..} recvN ftyp header@FrameHeader{streamId, payloadLength} | isControl streamId = do pl <- recvN payloadLength@@ -163,7 +162,6 @@ PriorityFrame newpri <- guardIt $ decodePriorityFrame header pl checkPriority newpri streamId | otherwise -> return ()- return True where setContinued = writeIORef continued $ Just streamId resetContinued = writeIORef continued Nothing@@ -173,19 +171,20 @@ Nothing -> return () Just sid | sid == streamId && ftyp == FrameContinuation -> return ()- | otherwise -> E.throwIO $ ConnectionError ProtocolError "continuation frame must follow"+ | otherwise -> E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "continuation frame must follow" ---------------------------------------------------------------- processState :: StreamState -> Context -> Stream -> StreamId -> IO Bool processState (Open (NoBody tbl@(_,reqvt))) ctx@Context{..} strm@Stream{streamInput} streamId = do let mcl = fst <$> (getHeaderValue tokenContentLength reqvt >>= C8.readInt)- when (just mcl (/= (0 :: Int))) $ E.throwIO $ StreamError ProtocolError streamId+ when (just mcl (/= (0 :: Int))) $ E.throwIO $ StreamErrorIsSent ProtocolError streamId halfClosedRemote ctx strm tlr <- newIORef Nothing let inpObj = InpObj tbl (Just 0) (return "") tlr- if isServer ctx then- atomically $ writeTQueue (inputQ roleInfo) $ Input strm inpObj+ if isServer ctx then do+ let si = toServerInfo roleInfo+ atomically $ writeTQueue (inputQ si) $ Input strm inpObj else putMVar streamInput inpObj return False@@ -197,8 +196,9 @@ setStreamState ctx strm $ Open (Body q mcl bodyLength tlr) bodySource <- mkSource (updateWindow controlQ streamId) q let inpObj = InpObj tbl mcl (readSource bodySource) tlr- if isServer ctx then- atomically $ writeTQueue (inputQ roleInfo) $ Input strm inpObj+ if isServer ctx then do+ let si = toServerInfo roleInfo+ atomically $ writeTQueue (inputQ si) $ Input strm inpObj else putMVar streamInput inpObj return False@@ -215,15 +215,15 @@ ---------------------------------------------------------------- -getStream :: Context -> FrameTypeId -> StreamId -> IO (Maybe Stream)+getStream :: Context -> FrameType -> StreamId -> IO (Maybe Stream) getStream ctx@Context{..} ftyp streamId = search streamTable streamId >>= getStream' ctx ftyp streamId -getStream' :: Context -> FrameTypeId -> StreamId -> Maybe Stream -> IO (Maybe Stream)-getStream' ctx ftyp _streamId js@(Just strm0) = do+getStream' :: Context -> FrameType -> StreamId -> Maybe Stream -> IO (Maybe Stream)+getStream' ctx ftyp streamId js@(Just strm0) = do when (ftyp == FrameHeaders) $ do st <- readStreamState strm0- when (isHalfClosedRemote st) $ E.throwIO $ ConnectionError StreamClosed "header must not be sent to half or fully closed stream"+ when (isHalfClosedRemote st) $ E.throwIO $ ConnectionErrorIsSent StreamClosed streamId "header must not be sent to half or fully closed stream" -- Priority made an idle stream when (isIdle st) $ opened ctx strm0 return js@@ -235,32 +235,33 @@ if ftyp `elem` [FrameWindowUpdate, FrameRSTStream, FramePriority] then return Nothing -- will be ignored else- E.throwIO $ ConnectionError ProtocolError "stream identifier must not decrease"+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "stream identifier must not decrease" else do -- consider the stream idle- when (ftyp `notElem` [FrameHeaders,FramePriority]) $- E.throwIO $ ConnectionError ProtocolError $ "this frame is not allowed in an idle stream: " `BS.append` C8.pack (show ftyp)+ when (ftyp `notElem` [FrameHeaders,FramePriority]) $ do+ let errmsg = Short.toShort ("this frame is not allowed in an idle stream: " `BS.append` (C8.pack (show ftyp)))+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId errmsg when (ftyp == FrameHeaders) $ do setPeerStreamID ctx streamId cnt <- readIORef concurrency -- Checking the limitation of concurrency- when (cnt >= maxConcurrency) $ E.throwIO $ StreamError RefusedStream streamId+ when (cnt >= maxConcurrency) $ E.throwIO $ StreamErrorIsSent RefusedStream streamId Just <$> openStream ctx streamId ftyp | otherwise = undefined -- never reach ---------------------------------------------------------------- -control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool-control FrameSettings header@FrameHeader{flags} bs Context{http2settings, controlQ, firstSettings, streamTable, settingsRate} = do+type Payload = ByteString++control :: FrameType -> FrameHeader -> Payload -> Context -> IO ()+control FrameSettings header@FrameHeader{flags,streamId} bs Context{http2settings, controlQ, firstSettings, streamTable, settingsRate} = do SettingsFrame alist <- guardIt $ decodeSettingsFrame header bs traverse_ E.throwIO $ checkSettingsList alist -- HTTP/2 Setting from a browser- if testAck flags then- return True- else do+ unless (testAck flags) $ do -- Settings Flood - CVE-2019-9515 rate <- getRate settingsRate if rate > settingsRateLimit then- E.throwIO $ ConnectionError ProtocolError "too many settings"+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "too many settings" else do oldws <- initialWindowSize <$> readIORef http2settings modifyIORef' http2settings $ \old -> updateSettings old alist@@ -274,58 +275,57 @@ | otherwise = CSettings0 initialFrame frame alist unless sent $ writeIORef firstSettings True enqueueControl controlQ setframe- return True -control FramePing FrameHeader{flags} bs Context{controlQ,pingRate} =- if testAck flags then- return True- else do+control FramePing FrameHeader{flags,streamId} bs Context{controlQ,pingRate} =+ unless (testAck flags) $ do -- Ping Flood - CVE-2019-9512 rate <- getRate pingRate if rate > pingRateLimit then- E.throwIO $ ConnectionError ProtocolError "too many ping"+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "too many ping" else do let frame = pingFrame bs enqueueControl controlQ $ CFrame frame- return True -control FrameGoAway _ _ Context{controlQ} = do+control FrameGoAway header bs Context{controlQ} = do enqueueControl controlQ CFinish- return False+ GoAwayFrame sid err msg <- guardIt $ decodeGoAwayFrame header bs+ if err == NoError then+ E.throwIO ConnectionIsClosed+ else+ E.throwIO $ ConnectionErrorIsReceived err sid $ Short.toShort msg -control FrameWindowUpdate header bs Context{connectionWindow} = do+control FrameWindowUpdate header@FrameHeader{streamId} bs Context{connectionWindow} = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs w <- atomically $ do w0 <- readTVar connectionWindow let w1 = w0 + n writeTVar connectionWindow w1 return w1- when (isWindowOverflow w) $ E.throwIO $ ConnectionError FlowControlError "control window should be less than 2^31"- return True+ when (isWindowOverflow w) $ E.throwIO $ ConnectionErrorIsSent FlowControlError streamId "control window should be less than 2^31" control _ _ _ _ = -- must not reach here- return False+ return () ---------------------------------------------------------------- {-# INLINE guardIt #-}-guardIt :: Either HTTP2Error a -> IO a+guardIt :: Either FrameDecodeError a -> IO a guardIt x = case x of- Left err -> E.throwIO err+ Left (FrameDecodeError ec sid msg) -> E.throwIO $ ConnectionErrorIsSent ec sid msg Right frame -> return frame {-# INLINE checkPriority #-} checkPriority :: Priority -> StreamId -> IO () checkPriority p me- | dep == me = E.throwIO $ StreamError ProtocolError me+ | dep == me = E.throwIO $ StreamErrorIsSent ProtocolError me | otherwise = return () where dep = streamDependency p -stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState-stream FrameHeaders header@FrameHeader{flags} bs ctx s@(Open JustOpened) Stream{streamNumber} = do+stream :: FrameType -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState+stream FrameHeaders header@FrameHeader{flags,streamId} bs ctx s@(Open JustOpened) Stream{streamNumber} = do HeadersFrame mp frag <- guardIt $ decodeHeadersFrame header bs let endOfStream = testEndStream flags endOfHeader = testEndHeader flags@@ -333,7 +333,7 @@ -- Empty Frame Flooding - CVE-2019-9518 rate <- getRate $ emptyFrameRate ctx if rate > emptyFrameRateLimit then- E.throwIO $ ConnectionError ProtocolError "too many empty headers"+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "too many empty headers" else return s else do@@ -341,7 +341,7 @@ Nothing -> return () Just p -> checkPriority p streamNumber if endOfHeader then do- tbl <- hpackDecodeHeader frag ctx+ tbl <- hpackDecodeHeader frag streamId ctx return $ if endOfStream then Open (NoBody tbl) else@@ -350,18 +350,18 @@ let siz = BS.length frag return $ Open $ Continued [frag] siz 1 endOfStream -stream FrameHeaders header@FrameHeader{flags} bs ctx (Open (Body q _ _ tlr)) _ = do+stream FrameHeaders header@FrameHeader{flags,streamId} bs ctx (Open (Body q _ _ tlr)) _ = do HeadersFrame _ frag <- guardIt $ decodeHeadersFrame header bs let endOfStream = testEndStream flags -- checking frag == "" is not necessary if endOfStream then do- tbl <- hpackDecodeTrailer frag ctx+ tbl <- hpackDecodeTrailer frag streamId ctx writeIORef tlr (Just tbl) atomically $ writeTQueue q "" return HalfClosedRemote else -- we don't support continuation here.- E.throwIO $ ConnectionError ProtocolError "continuation in trailer is not supported"+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "continuation in trailer is not supported" -- ignore data-frame except for flow-control when we're done locally stream FrameData@@ -392,27 +392,27 @@ unless endOfStream $ do rate <- getRate emptyFrameRate when (rate > emptyFrameRateLimit) $ do- E.throwIO $ ConnectionError ProtocolError "too many empty data"+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "too many empty data" else do writeIORef bodyLength len atomically $ writeTQueue q body if endOfStream then do case mcl of Nothing -> return ()- Just cl -> when (cl /= len) $ E.throwIO $ StreamError ProtocolError streamId+ Just cl -> when (cl /= len) $ E.throwIO $ StreamErrorIsSent ProtocolError streamId -- no trailers atomically $ writeTQueue q "" return HalfClosedRemote else return s -stream FrameContinuation FrameHeader{flags} frag ctx s@(Open (Continued rfrags siz n endOfStream)) _ = do+stream FrameContinuation FrameHeader{flags,streamId} frag ctx s@(Open (Continued rfrags siz n endOfStream)) _ = do let endOfHeader = testEndHeader flags if frag == "" && not endOfHeader then do -- Empty Frame Flooding - CVE-2019-9518 rate <- getRate $ emptyFrameRate ctx if rate > emptyFrameRateLimit then- E.throwIO $ ConnectionError ProtocolError "too many empty continuation"+ E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "too many empty continuation" else return s else do@@ -420,12 +420,12 @@ siz' = siz + BS.length frag n' = n + 1 when (siz' > headerFragmentLimit) $- E.throwIO $ ConnectionError EnhanceYourCalm "Header is too big"+ E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too big" when (n' > continuationLimit) $- E.throwIO $ ConnectionError EnhanceYourCalm "Header is too fragmented"+ E.throwIO $ ConnectionErrorIsSent EnhanceYourCalm streamId "Header is too fragmented" if endOfHeader then do let hdrblk = BS.concat $ reverse rfrags'- tbl <- hpackDecodeHeader hdrblk ctx+ tbl <- hpackDecodeHeader hdrblk streamId ctx return $ if endOfStream then Open (NoBody tbl) else@@ -440,14 +440,15 @@ let w1 = w0 + n writeTVar streamWindow w1 return w1- when (isWindowOverflow w) $ E.throwIO $ StreamError FlowControlError streamId+ when (isWindowOverflow w) $ E.throwIO $ StreamErrorIsSent FlowControlError streamId return s -stream FrameRSTStream header bs ctx _ strm = do- RSTStreamFrame e <- guardIt $ decoderstStreamFrame header bs- let cc = Reset e+stream FrameRSTStream header@FrameHeader{streamId} bs ctx@Context{..} _ strm = do+ enqueueControl controlQ CFinish+ RSTStreamFrame err <- guardIt $ decoderstStreamFrame header bs+ let cc = Reset err closed ctx strm cc- return $ Closed cc -- will be written to streamState again+ E.throwIO $ StreamErrorIsReceived err streamId stream FramePriority header bs _ s Stream{streamNumber} = do -- ignore@@ -457,12 +458,12 @@ return s -- this ordering is important-stream FrameContinuation _ _ _ _ _ = E.throwIO $ ConnectionError ProtocolError "continue frame cannot come here"-stream _ _ _ _ (Open Continued{}) _ = E.throwIO $ ConnectionError ProtocolError "an illegal frame follows header/continuation frames"+stream FrameContinuation FrameHeader{streamId} _ _ _ _ = E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "continue frame cannot come here"+stream _ FrameHeader{streamId} _ _ (Open Continued{}) _ = E.throwIO $ ConnectionErrorIsSent ProtocolError streamId "an illegal frame follows header/continuation frames" -- Ignore frames to streams we have just reset, per section 5.1. stream _ _ _ _ st@(Closed (ResetByMe _)) _ = return st-stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError StreamClosed streamId-stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamError ProtocolError streamId+stream FrameData FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamErrorIsSent StreamClosed streamId+stream _ FrameHeader{streamId} _ _ _ _ = E.throwIO $ StreamErrorIsSent ProtocolError streamId ----------------------------------------------------------------
Network/HTTP2/Arch/Sender.hs view
@@ -10,13 +10,13 @@ , runTrailersMaker ) where -import Control.Concurrent.STM-import qualified Control.Exception as E import qualified Data.ByteString as BS import Data.ByteString.Builder (Builder) import qualified Data.ByteString.Builder.Extra as B import Foreign.Ptr (plusPtr) import Network.ByteOrder+import qualified UnliftIO.Exception as E+import UnliftIO.STM import Imports import Network.HPACK (setLimitForEncoding, toHeaderTable)@@ -47,13 +47,13 @@ waitStreamWindowSize :: Stream -> IO () waitStreamWindowSize Stream{streamWindow} = atomically $ do w <- readTVar streamWindow- check (w > 0)+ checkSTM (w > 0) {-# INLINE waitStreaming #-} waitStreaming :: TBQueue a -> IO () waitStreaming tbq = atomically $ do isEmpty <- isEmptyTBQueue tbq- check (not isEmpty)+ checkSTM (not isEmpty) data Switch = C Control | O (Output Stream)@@ -62,16 +62,16 @@ frameSender :: Context -> Config -> Manager -> IO () frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable} Config{..}- mgr = loop 0 `E.catch` ignore+ mgr = loop 0 where dequeue off = do isEmpty <- isEmptyTQueue controlQ if isEmpty then do w <- readTVar connectionWindow- check (w > 0)+ checkSTM (w > 0) emp <- isEmptyTQueue outputQ if emp then- if off /= 0 then return Flush else retry+ if off /= 0 then return Flush else retrySTM else O <$> readTQueue outputQ else@@ -231,7 +231,7 @@ flushN $ kvlen + frameHeaderLength -- Now off is 0 (ths', kvlen') <- hpackEncodeHeaderLoop ctx bufHeaderPayload headerPayloadLim ths- when (ths == ths') $ E.throwIO $ ConnectionError CompressionError "cannot compress the header"+ when (ths == ths') $ E.throwIO $ ConnectionErrorIsSent CompressionError sid "cannot compress the header" let flag = case ths' of [] -> setEndHeader defaultFlags _ -> defaultFlags@@ -308,10 +308,6 @@ fillFrameHeader ftyp len sid flag buf = encodeFrameHeaderBuf ftyp hinfo buf where hinfo = FrameHeader len flag sid-- {-# INLINE ignore #-}- ignore :: E.SomeException -> IO ()- ignore _ = return () -- | Running trailers-maker. --
Network/HTTP2/Arch/Stream.hs view
@@ -2,10 +2,10 @@ module Network.HTTP2.Arch.Stream where -import Control.Concurrent-import Control.Concurrent.STM import Data.IORef import qualified Data.IntMap.Strict as M+import UnliftIO.Concurrent+import UnliftIO.STM import Imports import Network.HTTP2.Arch.Types
Network/HTTP2/Arch/Types.hs view
@@ -2,13 +2,15 @@ module Network.HTTP2.Arch.Types where -import Control.Concurrent-import Control.Concurrent.STM-import Control.Exception (SomeException)+import qualified Control.Exception as E import Data.ByteString.Builder (Builder) import Data.IORef import Data.IntMap.Strict (IntMap)+import Data.Typeable import qualified Network.HTTP.Types as H+import UnliftIO.Concurrent+import UnliftIO.Exception (SomeException)+import UnliftIO.STM import Imports import Network.HPACK@@ -20,7 +22,7 @@ -- | "http" or "https". type Scheme = ByteString --- | For so-called "Host:" header.+-- | Authority. type Authority = ByteString -- | Path.@@ -119,7 +121,7 @@ data ClosedCode = Finished | Killed- | Reset ErrorCodeId+ | Reset ErrorCode | ResetByMe SomeException deriving Show @@ -195,3 +197,44 @@ data StreamingChunk = StreamingFinished | StreamingFlush | StreamingBuilder Builder++----------------------------------------------------------------++type ReasonPhrase = ShortByteString++-- | The connection error or the stream error.+-- Stream errors are treated as connection errors since+-- there are no good recovery ways.+-- `ErrorCode` in connection errors should be the highest stream identifier+-- but in this implementation it identifies the stream that+-- caused this error.+data HTTP2Error =+ ConnectionIsClosed -- NoError+ | ConnectionErrorIsReceived ErrorCode StreamId ReasonPhrase+ | ConnectionErrorIsSent ErrorCode StreamId ReasonPhrase+ | StreamErrorIsReceived ErrorCode StreamId+ | StreamErrorIsSent ErrorCode StreamId+ | BadThingHappen E.SomeException+ deriving (Show, Typeable)++instance E.Exception HTTP2Error++----------------------------------------------------------------++-- | Checking 'SettingsList' and reporting an error if any.+--+-- >>> checkSettingsList [(SettingsEnablePush,2)]+-- Just (ConnectionErrorIsSent ProtocolError 0 "enable push must be 0 or 1")+checkSettingsList :: SettingsList -> Maybe HTTP2Error+checkSettingsList settings = case mapMaybe checkSettingsValue settings of+ [] -> Nothing+ (x:_) -> Just x++checkSettingsValue :: (SettingsKey,SettingsValue) -> Maybe HTTP2Error+checkSettingsValue (SettingsEnablePush,v)+ | v /= 0 && v /= 1 = Just $ ConnectionErrorIsSent ProtocolError 0 "enable push must be 0 or 1"+checkSettingsValue (SettingsInitialWindowSize,v)+ | v > 2147483647 = Just $ ConnectionErrorIsSent FlowControlError 0 "Window size must be less than or equal to 65535"+checkSettingsValue (SettingsMaxFrameSize,v)+ | v < 16384 || v > 16777215 = Just $ ConnectionErrorIsSent ProtocolError 0 "Max frame size must be in between 16384 and 16777215"+checkSettingsValue _ = Nothing
Network/HTTP2/Client.hs view
@@ -5,10 +5,11 @@ -- Example: -- -- > {-# LANGUAGE OverloadedStrings #-}+-- > -- > module Main where -- >+-- > import Control.Concurrent.Async -- > import qualified Control.Exception as E--- > import Control.Concurrent (forkIO, threadDelay) -- > import qualified Data.ByteString.Char8 as C8 -- > import Network.HTTP.Types -- > import Network.Run.TCP (runTCPClient) -- network-run@@ -19,21 +20,25 @@ -- > serverName = "127.0.0.1" -- > -- > main :: IO ()--- > main = runTCPClient serverName "80" runHTTP2Client+-- > main = runTCPClient serverName "80" $ runHTTP2Client serverName -- > where--- > cliconf = ClientConfig "http" (C8.pack serverName) 20--- > runHTTP2Client s = E.bracket (allocSimpleConfig s 4096)--- > freeSimpleConfig--- > (\conf -> run cliconf conf client)+-- > cliconf host = ClientConfig "http" (C8.pack host) 20+-- > runHTTP2Client host s = E.bracket (allocSimpleConfig s 4096)+-- > freeSimpleConfig+-- > (\conf -> run (cliconf host) conf client) -- > client sendRequest = do--- > let req = requestNoBody methodGet "/" []--- > _ <- forkIO $ sendRequest req $ \rsp -> do--- > print rsp--- > getResponseBodyChunk rsp >>= C8.putStrLn--- > sendRequest req $ \rsp -> do--- > threadDelay 100000--- > print rsp--- > getResponseBodyChunk rsp >>= C8.putStrLn+-- > let req0 = requestNoBody methodGet "/" []+-- > client0 = sendRequest req0 $ \rsp -> do+-- > print rsp+-- > getResponseBodyChunk rsp >>= C8.putStrLn+-- > req1 = requestNoBody methodGet "/foo" []+-- > client1 = sendRequest req1 $ \rsp -> do+-- > print rsp+-- > getResponseBodyChunk rsp >>= C8.putStrLn+-- > ex <- E.try $ concurrently_ client0 client1+-- > case ex of+-- > Left e -> print (e :: HTTP2Error)+-- > Right () -> putStrLn "OK" module Network.HTTP2.Client ( -- * Runner@@ -73,6 +78,9 @@ , FileSpec(..) , FileOffset , ByteCount+ -- * Error+ , HTTP2Error(..)+ , ErrorCode(ErrorCode,NoError,ProtocolError,InternalError,FlowControlError,SettingsTimeout,StreamClosed,FrameSizeError,RefusedStream,Cancel,CompressionError,ConnectError,EnhanceYourCalm,InadequateSecurity,HTTP11Required) -- * RecvN , defaultReadN -- * Position read for files@@ -89,8 +97,9 @@ import Network.HPACK import Network.HTTP2.Arch-import Network.HTTP2.Client.Types import Network.HTTP2.Client.Run+import Network.HTTP2.Client.Types+import Network.HTTP2.Frame ----------------------------------------------------------------
Network/HTTP2/Client/Run.hs view
@@ -3,11 +3,12 @@ module Network.HTTP2.Client.Run where -import Control.Concurrent.Async-import Control.Concurrent-import qualified Control.Exception as E import Data.IORef (writeIORef)+import UnliftIO.Async+import UnliftIO.Concurrent+import qualified UnliftIO.Exception as E +import Imports import Network.HTTP2.Arch import Network.HTTP2.Client.Types import Network.HTTP2.Frame@@ -26,27 +27,33 @@ ctx <- newContext clientInfo mgr <- start confTimeoutManager let runBackgroundThreads = do- race_- (frameReceiver ctx confReadN)- (frameSender ctx conf mgr)- E.throwIO (ConnectionError ProtocolError "connection terminated")+ let runReceiver = frameReceiver ctx confReadN+ runSender = frameSender ctx conf mgr+ concurrently_ runReceiver runSender exchangeSettings conf ctx- fmap (either id id) $- race runBackgroundThreads (client (sendRequest ctx scheme authority))- `E.finally` stop mgr+ let runClient = do+ x <- client $ sendRequest ctx scheme authority+ let frame = goawayFrame 0 NoError "graceful closing"+ enqueueControl (controlQ ctx) $ CGoaway frame+ return x+ ex <- race runBackgroundThreads runClient `E.finally` stop mgr+ case ex of+ Left () -> undefined -- never reach+ Right x -> return x sendRequest :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a sendRequest ctx@Context{..} scheme auth (Request req) processResponse = do- let hdr = outObjHeaders req- Just method = lookup ":method" hdr- Just path = lookup ":path" hdr+ let hdr0 = outObjHeaders req+ method = fromMaybe (error "sendRequest:method") $ lookup ":method" hdr0+ path = fromMaybe (error "sendRequest:path") $ lookup ":path" hdr0 mstrm0 <- lookupCache method path roleInfo strm <- case mstrm0 of Nothing -> do- let hdr' = (":scheme", scheme)- : (":authority", auth)- : hdr- req' = req { outObjHeaders = hdr' }+ let hdr1 | scheme /= "" = (":scheme", scheme) : hdr0+ | otherwise = hdr0+ hdr2 | auth /= "" = (":authority", auth) : hdr1+ | otherwise = hdr1+ req' = req { outObjHeaders = hdr2 } sid <- getMyNewStreamId ctx newstrm <- openStream ctx sid FrameHeaders enqueueOutput outputQ $ Output newstrm req' OObj Nothing (return ())
Network/HTTP2/Frame.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} --- | Framing in HTTP\/2(<https://tools.ietf.org/html/rfc7540>).+-- | Framing in HTTP\/2(<https://www.rfc-editor.org/rfc/rfc9113>). module Network.HTTP2.Frame ( -- * Frame Frame(..)@@ -18,26 +18,21 @@ , EncodeInfo(..) , encodeInfo , module Network.HTTP2.Frame.Decode- -- * Frame type ID- , FrameTypeId(..)- , framePayloadToFrameTypeId -- * Frame type- , FrameType- , fromFrameTypeId- , toFrameTypeId+ , FrameType(FrameType,FrameData,FrameHeaders,FramePriority,FrameRSTStream,FrameSettings,FramePushPromise,FramePing,FrameGoAway,FrameWindowUpdate,FrameContinuation)+ , fromFrameType+ , toFrameType+ , minFrameType+ , maxFrameType+ , framePayloadToFrameType -- * Priority , Priority(..) , Weight- , defaultPriority- , highestPriority- , defaultWeight -- * Stream identifier , StreamId , isControl , isClientInitiated , isServerInitiated- , isRequest- , isResponse -- * Stream identifier related , testExclusive , setExclusive@@ -57,11 +52,10 @@ , setPriority -- * SettingsList , SettingsList- , SettingsKeyId(..)+ , SettingsKey(SettingsKey,SettingsHeaderTableSize,SettingsEnablePush,SettingsMaxConcurrentStreams,SettingsInitialWindowSize,SettingsMaxFrameSize,SettingsMaxHeaderBlockSize) , SettingsValue- , fromSettingsKeyId- , toSettingsKeyId- , checkSettingsList+ , fromSettingsKey+ , toSettingsKey -- * Settings , Settings(..) , defaultSettings@@ -72,19 +66,19 @@ , maxWindowSize , isWindowOverflow -- * Error code- , ErrorCode- , ErrorCodeId(..)- , fromErrorCodeId- , toErrorCodeId- -- * Error- , HTTP2Error(..)- , errorCodeId+ , ErrorCode(ErrorCode,NoError,ProtocolError,InternalError,FlowControlError,SettingsTimeout,StreamClosed,FrameSizeError,RefusedStream,Cancel,CompressionError,ConnectError,EnhanceYourCalm,InadequateSecurity,HTTP11Required)+ , fromErrorCode+ , toErrorCode -- * Predefined values , connectionPreface , connectionPrefaceLength , frameHeaderLength , maxPayloadLength , recommendedConcurrency+ -- * Deprecated+ , ErrorCodeId+ , SettingsKeyId+ , FrameTypeId ) where import qualified Data.ByteString as BS
Network/HTTP2/Frame/Decode.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.HTTP2.Frame.Decode ( -- * Decoding decodeFrame , decodeFrameHeader , checkFrameHeader+ , FrameDecodeError(..) -- * Decoding payload , decodeFramePayload , FramePayloadDecoder@@ -32,13 +33,18 @@ ---------------------------------------------------------------- +data FrameDecodeError = FrameDecodeError ErrorCode StreamId ShortByteString+ deriving (Eq, Show)++----------------------------------------------------------------+ -- | Decoding an HTTP/2 frame to 'ByteString'. -- The second argument must be include the entire of frame. -- So, this function is not useful for real applications -- but useful for testing. decodeFrame :: Settings -- ^ HTTP/2 settings -> ByteString -- ^ Input byte-stream- -> Either HTTP2Error Frame -- ^ Decoded frame+ -> Either FrameDecodeError Frame -- ^ Decoded frame decodeFrame settings bs = checkFrameHeader settings (decodeFrameHeader bs0) >>= \(typ,header) -> decodeFramePayload typ header bs1 >>= \payload -> return $ Frame header payload@@ -49,13 +55,13 @@ -- | Decoding an HTTP/2 frame header. -- Must supply 9 bytes.-decodeFrameHeader :: ByteString -> (FrameTypeId, FrameHeader)+decodeFrameHeader :: ByteString -> (FrameType, FrameHeader) decodeFrameHeader (PS fptr off _) = unsafeDupablePerformIO $ withForeignPtr fptr $ \ptr -> do let p = ptr +. off- len <- fromIntegral <$> N.peek24 p 0- typ <- toFrameTypeId <$> N.peek8 p 3- flg <- N.peek8 p 4- w32 <- N.peek32 p 5+ len <- fromIntegral <$> N.peek24 p 0+ typ <- toFrameType <$> N.peek8 p 3+ flg <- N.peek8 p 4+ w32 <- N.peek32 p 5 let sid = streamIdentifier w32 return (typ, FrameHeader len flg sid) @@ -67,56 +73,56 @@ -- | Checking a frame header and reporting an error if any. -- -- >>> checkFrameHeader defaultSettings (FrameData,(FrameHeader 100 0 0))--- Left (ConnectionError ProtocolError "cannot used in control stream")+-- Left (FrameDecodeError ProtocolError 0 "cannot used in control stream") checkFrameHeader :: Settings- -> (FrameTypeId, FrameHeader)- -> Either HTTP2Error (FrameTypeId, FrameHeader)-checkFrameHeader Settings {..} typfrm@(typ,FrameHeader {..})+ -> (FrameType, FrameHeader)+ -> Either FrameDecodeError (FrameType, FrameHeader)+checkFrameHeader Settings {..} typfrm@(typ,FrameHeader{..}) | payloadLength > maxFrameSize =- Left $ ConnectionError FrameSizeError "exceeds maximum frame size"+ Left $ FrameDecodeError FrameSizeError streamId "exceeds maximum frame size" | typ `elem` nonZeroFrameTypes && isControl streamId =- Left $ ConnectionError ProtocolError "cannot used in control stream"+ Left $ FrameDecodeError ProtocolError streamId "cannot used in control stream" | typ `elem` zeroFrameTypes && not (isControl streamId) =- Left $ ConnectionError ProtocolError "cannot used in non-zero stream"+ Left $ FrameDecodeError ProtocolError streamId "cannot used in non-zero stream" | otherwise = checkType typ where checkType FrameHeaders | testPadded flags && payloadLength < 1 =- Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length"+ Left $ FrameDecodeError FrameSizeError streamId "insufficient payload for Pad Length" | testPriority flags && payloadLength < 5 =- Left $ ConnectionError FrameSizeError "insufficient payload for priority fields"+ Left $ FrameDecodeError FrameSizeError streamId "insufficient payload for priority fields" | testPadded flags && testPriority flags && payloadLength < 6 =- Left $ ConnectionError FrameSizeError "insufficient payload for Pad Length and priority fields"+ Left $ FrameDecodeError FrameSizeError streamId "insufficient payload for Pad Length and priority fields" checkType FramePriority | payloadLength /= 5 =- Left $ StreamError FrameSizeError streamId+ Left $ FrameDecodeError FrameSizeError streamId "payload length is not 5 in priority frame" checkType FrameRSTStream | payloadLength /= 4 =- Left $ ConnectionError FrameSizeError "payload length is not 4 in rst stream frame"+ Left $ FrameDecodeError FrameSizeError streamId "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"+ Left $ FrameDecodeError FrameSizeError streamId "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"+ Left $ FrameDecodeError FrameSizeError streamId "payload length must be 0 if ack flag is set" checkType FramePushPromise | not enablePush =- Left $ ConnectionError ProtocolError "push not enabled" -- checkme+ Left $ FrameDecodeError ProtocolError streamId "push not enabled" -- checkme | isClientInitiated streamId =- Left $ ConnectionError ProtocolError "push promise must be used with even stream identifier"+ Left $ FrameDecodeError ProtocolError streamId "push promise must be used with even stream identifier" checkType FramePing | payloadLength /= 8 =- Left $ ConnectionError FrameSizeError "payload length is 8 in ping frame"+ Left $ FrameDecodeError FrameSizeError streamId "payload length is 8 in ping frame" checkType FrameGoAway | payloadLength < 8 =- Left $ ConnectionError FrameSizeError "goaway body must be 8 bytes or larger"+ Left $ FrameDecodeError FrameSizeError streamId "goaway body must be 8 bytes or larger" checkType FrameWindowUpdate | payloadLength /= 4 =- Left $ ConnectionError FrameSizeError "payload length is 4 in window update frame"+ Left $ FrameDecodeError FrameSizeError streamId "payload length is 4 in window update frame" checkType _ = Right typfrm -zeroFrameTypes :: [FrameTypeId]+zeroFrameTypes :: [FrameType] zeroFrameTypes = [ FrameSettings , FramePing , FrameGoAway ] -nonZeroFrameTypes :: [FrameTypeId]+nonZeroFrameTypes :: [FrameType] nonZeroFrameTypes = [ FrameData , FrameHeaders@@ -130,9 +136,9 @@ -- | The type for frame payload decoder. type FramePayloadDecoder = FrameHeader -> ByteString- -> Either HTTP2Error FramePayload+ -> Either FrameDecodeError FramePayload -payloadDecoders :: Array Word8 FramePayloadDecoder+payloadDecoders :: Array FrameType FramePayloadDecoder payloadDecoders = listArray (minFrameType, maxFrameType) [ decodeDataFrame , decodeHeadersFrame@@ -149,11 +155,12 @@ -- | Decoding an HTTP/2 frame payload. -- This function is considered to return a frame payload decoder -- according to a frame type.-decodeFramePayload :: FrameTypeId -> FramePayloadDecoder-decodeFramePayload (FrameUnknown typ) = checkFrameSize $ decodeUnknownFrame typ-decodeFramePayload ftyp = checkFrameSize decoder+decodeFramePayload :: FrameType -> FramePayloadDecoder+decodeFramePayload ftyp+ | ftyp > maxFrameType = checkFrameSize $ decodeUnknownFrame ftyp+decodeFramePayload ftyp = checkFrameSize decoder where- decoder = payloadDecoders ! fromFrameTypeId ftyp+ decoder = payloadDecoders ! ftyp ---------------------------------------------------------------- @@ -179,12 +186,12 @@ -- | Frame payload decoder for RST_STREAM frame. decoderstStreamFrame :: FramePayloadDecoder-decoderstStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCodeId (N.word32 bs)+decoderstStreamFrame _ bs = Right $ RSTStreamFrame $ toErrorCode (N.word32 bs) -- | Frame payload decoder for SETTINGS frame. decodeSettingsFrame :: FramePayloadDecoder decodeSettingsFrame FrameHeader{..} (PS fptr off _)- | num > 10 = Left $ ConnectionError EnhanceYourCalm "Settings is too large"+ | num > 10 = Left $ FrameDecodeError EnhanceYourCalm streamId "Settings is too large" | otherwise = Right $ SettingsFrame alist where num = payloadLength `div` 6@@ -194,14 +201,14 @@ settings 0 _ builder = return $ builder [] settings n p builder = do rawSetting <- N.peek16 p 0- let msettings = toSettingsKeyId rawSetting+ let k = toSettingsKey rawSetting n' = n - 1- case msettings of- Nothing -> settings n' (p +. 6) builder -- ignoring unknown one (Section 6.5.2)- Just k -> do- w32 <- N.peek32 p 2- let v = fromIntegral w32- settings n' (p +. 6) (builder. ((k,v):))+ if k < minSettingsKey || k > maxSettingsKey then+ settings n' (p +. 6) builder -- ignoring unknown one (Section 6.5.2)+ else do+ w32 <- N.peek32 p 2+ let v = fromIntegral w32+ settings n' (p +. 6) (builder. ((k,v):)) -- | Frame payload decoder for PUSH_PROMISE frame. decodePushPromiseFrame :: FramePayloadDecoder@@ -221,12 +228,12 @@ (bs0,bs1') = BS.splitAt 4 bs (bs1,bs2) = BS.splitAt 4 bs1' sid = streamIdentifier (N.word32 bs0)- ecid = toErrorCodeId (N.word32 bs1)+ ecid = toErrorCode (N.word32 bs1) -- | Frame payload decoder for WINDOW_UPDATE frame. decodeWindowUpdateFrame :: FramePayloadDecoder-decodeWindowUpdateFrame _ bs- | wsi == 0 = Left $ ConnectionError ProtocolError "window update must not be 0"+decodeWindowUpdateFrame FrameHeader{..} bs+ | wsi == 0 = Left $ FrameDecodeError ProtocolError streamId "window update must not be 0" | otherwise = Right $ WindowUpdateFrame wsi where wsi = fromIntegral (N.word32 bs `clearBit` 31)@@ -243,20 +250,20 @@ checkFrameSize :: FramePayloadDecoder -> FramePayloadDecoder checkFrameSize func header@FrameHeader{..} body | payloadLength > BS.length body =- Left $ ConnectionError FrameSizeError "payload is too short"+ Left $ FrameDecodeError FrameSizeError streamId "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) -> Either HTTP2Error FramePayload+decodeWithPadding :: FrameHeader -> ByteString -> (ByteString -> FramePayload) -> Either FrameDecodeError FramePayload decodeWithPadding FrameHeader{..} bs body- | padded = let Just (w8,rest) = BS.uncons bs+ | padded = let (w8,rest) = fromMaybe (error "decodeWithPadding") $ BS.uncons bs padlen = intFromWord8 w8 bodylen = payloadLength - padlen - 1 in if bodylen < 0 then- Left $ ConnectionError ProtocolError "padding is not enough"+ Left $ FrameDecodeError ProtocolError streamId "padding is not enough" else Right . body $ BS.take bodylen rest | otherwise = Right $ body bs
Network/HTTP2/Frame/Encode.hs view
@@ -59,18 +59,18 @@ encodeFrameChunks :: EncodeInfo -> FramePayload -> [ByteString] encodeFrameChunks einfo payload = bs : bss where- ftid = framePayloadToFrameTypeId payload+ ftid = framePayloadToFrameType payload bs = encodeFrameHeader ftid header (header, bss) = encodeFramePayload einfo payload -- | Encoding an HTTP/2 frame header. -- The frame header must be completed.-encodeFrameHeader :: FrameTypeId -> FrameHeader -> ByteString+encodeFrameHeader :: FrameType -> FrameHeader -> ByteString encodeFrameHeader ftid fhdr = unsafeCreate frameHeaderLength $ encodeFrameHeaderBuf ftid fhdr -- | Writing an encoded HTTP/2 frame header to the buffer. -- The length of the buffer must be larger than or equal to 9 bytes.-encodeFrameHeaderBuf :: FrameTypeId -> FrameHeader -> Ptr Word8 -> IO ()+encodeFrameHeaderBuf :: FrameType -> FrameHeader -> Ptr Word8 -> IO () encodeFrameHeaderBuf ftid FrameHeader{..} ptr = do N.poke24 plen ptr 0 N.poke8 typ ptr 3@@ -78,7 +78,7 @@ N.poke32 sid ptr 5 where plen = fromIntegral payloadLength- typ = fromFrameTypeId ftid+ typ = fromFrameType ftid sid = fromIntegral streamId -- | Encoding an HTTP/2 frame payload.@@ -175,11 +175,11 @@ builder = buildPriority p header = FrameHeader 5 encodeFlags encodeStreamId -buildFramePayloadRSTStream :: EncodeInfo -> ErrorCodeId -> (FrameHeader, Builder)+buildFramePayloadRSTStream :: EncodeInfo -> ErrorCode -> (FrameHeader, Builder) buildFramePayloadRSTStream EncodeInfo{..} e = (header, builder) where builder = (b4 :)- b4 = N.bytestring32 $ fromErrorCodeId e+ b4 = N.bytestring32 $ fromErrorCode e header = FrameHeader 4 encodeFlags encodeStreamId buildFramePayloadSettings :: EncodeInfo -> SettingsList -> (FrameHeader, Builder)@@ -189,8 +189,8 @@ settings = unsafeCreate len $ \ptr -> go ptr alist go _ [] = return () go p ((k,v):kvs) = do- N.poke16 (fromSettingsKeyId k) p 0- N.poke32 (fromIntegral v) p 2+ N.poke16 (fromSettingsKey k) p 0+ N.poke32 (fromIntegral v) p 2 go (p `plusPtr` 6) kvs len = length alist * 6 header = FrameHeader len encodeFlags encodeStreamId@@ -208,14 +208,14 @@ builder = (odata :) header = FrameHeader 8 encodeFlags encodeStreamId -buildFramePayloadGoAway :: EncodeInfo -> StreamId -> ErrorCodeId -> ByteString -> (FrameHeader, Builder)+buildFramePayloadGoAway :: EncodeInfo -> StreamId -> ErrorCode -> ByteString -> (FrameHeader, Builder) buildFramePayloadGoAway EncodeInfo{..} sid e debug = (header, builder) where builder = (b8 :) . (debug :) len0 = 8 b8 = unsafeCreate len0 $ \ptr -> do N.poke32 (fromIntegral sid) ptr 0- N.poke32 (fromErrorCodeId e) ptr 4+ N.poke32 (fromErrorCode e) ptr 4 len = len0 + BS.length debug header = FrameHeader len encodeFlags encodeStreamId
Network/HTTP2/Frame/Types.hs view
@@ -1,84 +1,12 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-} -module Network.HTTP2.Frame.Types (- -- * Constant- frameHeaderLength- , maxPayloadLength- -- * SettingsList- , SettingsKeyId(..)- , checkSettingsList- , fromSettingsKeyId- , SettingsValue- , SettingsList- , toSettingsKeyId- -- * Settings- , Settings(..)- , defaultSettings- , updateSettings- -- * Error- , HTTP2Error(..)- , errorCodeId- -- * Error code- , ErrorCode- , ErrorCodeId(..)- , fromErrorCodeId- , toErrorCodeId- -- * Frame type- , FrameType- , minFrameType- , maxFrameType- , FrameTypeId(..)- , fromFrameTypeId- , toFrameTypeId- -- * Frame- , Frame(..)- , FrameHeader(..)- , FramePayload(..)- , framePayloadToFrameTypeId- , isPaddingDefined- -- * Stream identifier- , StreamId- , isControl- , isClientInitiated- , isServerInitiated- , isRequest- , isResponse- , testExclusive- , setExclusive- , clearExclusive- -- * Flags- , FrameFlags- , defaultFlags- , testEndStream- , testAck- , testEndHeader- , testPadded- , testPriority- , setEndStream- , setAck- , setEndHeader- , setPadded- , setPriority- -- * Window- , WindowSize- , defaultInitialWindowSize- , maxWindowSize- , isWindowOverflow- -- * Misc- , recommendedConcurrency- -- * Types- , HeaderBlockFragment- , Weight- , defaultWeight- , Priority(..)- , defaultPriority- , highestPriority- , Padding- ) where+module Network.HTTP2.Frame.Types where -import qualified Control.Exception as E-import Data.Typeable+import Data.Ix+import Text.Read+import qualified Text.Read.Lex as L import Imports @@ -94,158 +22,142 @@ ---------------------------------------------------------------- -- | The type for raw error code.-type ErrorCode = Word32+newtype ErrorCode = ErrorCode Word32 deriving (Eq, Ord, Read) --- | The type for error code. See <https://tools.ietf.org/html/rfc7540#section-7>.-data ErrorCodeId = NoError- | ProtocolError- | InternalError- | FlowControlError- | SettingsTimeout- | StreamClosed- | FrameSizeError- | RefusedStream- | Cancel- | CompressionError- | ConnectError- | EnhanceYourCalm- | InadequateSecurity- | HTTP11Required- -- our extensions- | UnknownErrorCode ErrorCode- deriving (Show, Read, Eq, Ord)+fromErrorCode :: ErrorCode -> Word32+fromErrorCode (ErrorCode w) = w --- | Converting 'ErrorCodeId' to 'ErrorCode'.------ >>> 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 HTTP11Required = 0xd-fromErrorCodeId (UnknownErrorCode w) = w+toErrorCode :: Word32 -> ErrorCode+toErrorCode = ErrorCode --- | Converting 'ErrorCode' to 'ErrorCodeId'.------ >>> toErrorCodeId 0--- NoError--- >>> toErrorCodeId 0xc--- InadequateSecurity--- >>> toErrorCodeId 0xe--- UnknownErrorCode 14-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 0xd = HTTP11Required-toErrorCodeId w = UnknownErrorCode w+-- | The type for error code. See <https://www.rfc-editor.org/rfc/rfc9113#ErrorCodes>. -----------------------------------------------------------------+pattern NoError :: ErrorCode+pattern NoError = ErrorCode 0x0 --- | The connection error or the stream error.-data HTTP2Error = ConnectionError ErrorCodeId ByteString- | StreamError ErrorCodeId StreamId- deriving (Eq, Show, Typeable, Read)+pattern ProtocolError :: ErrorCode+pattern ProtocolError = ErrorCode 0x1 -instance E.Exception HTTP2Error+pattern InternalError :: ErrorCode+pattern InternalError = ErrorCode 0x2 --- | Obtaining 'ErrorCodeId' from 'HTTP2Error'.-errorCodeId :: HTTP2Error -> ErrorCodeId-errorCodeId (ConnectionError err _) = err-errorCodeId (StreamError err _) = err+pattern FlowControlError :: ErrorCode+pattern FlowControlError = ErrorCode 0x3 +pattern SettingsTimeout :: ErrorCode+pattern SettingsTimeout = ErrorCode 0x4++pattern StreamClosed :: ErrorCode+pattern StreamClosed = ErrorCode 0x5++pattern FrameSizeError :: ErrorCode+pattern FrameSizeError = ErrorCode 0x6++pattern RefusedStream :: ErrorCode+pattern RefusedStream = ErrorCode 0x7++pattern Cancel :: ErrorCode+pattern Cancel = ErrorCode 0x8++pattern CompressionError :: ErrorCode+pattern CompressionError = ErrorCode 0x9++pattern ConnectError :: ErrorCode+pattern ConnectError = ErrorCode 0xa++pattern EnhanceYourCalm :: ErrorCode+pattern EnhanceYourCalm = ErrorCode 0xb++pattern InadequateSecurity :: ErrorCode+pattern InadequateSecurity = ErrorCode 0xc++pattern HTTP11Required :: ErrorCode+pattern HTTP11Required = ErrorCode 0xd++instance Show ErrorCode where+ show (ErrorCode 0x0) = "NoError"+ show (ErrorCode 0x1) = "ProtocolError"+ show (ErrorCode 0x2) = "InternalError"+ show (ErrorCode 0x3) = "FlowControlError"+ show (ErrorCode 0x4) = "SettingsTimeout"+ show (ErrorCode 0x5) = "StreamClosed"+ show (ErrorCode 0x6) = "FrameSizeError"+ show (ErrorCode 0x7) = "RefusedStream"+ show (ErrorCode 0x8) = "Cancel"+ show (ErrorCode 0x9) = "CompressionError"+ show (ErrorCode 0xa) = "ConnectError"+ show (ErrorCode 0xb) = "EnhanceYourCalm"+ show (ErrorCode 0xc) = "InadequateSecurity"+ show (ErrorCode 0xd) = "HTTP11Required"+ show (ErrorCode x) = "ErrorCode " ++ show x+ ---------------------------------------------------------------- -- | The type for SETTINGS key.-data SettingsKeyId = SettingsHeaderTableSize- | SettingsEnablePush- | SettingsMaxConcurrentStreams- | SettingsInitialWindowSize- | SettingsMaxFrameSize -- this means payload size- | SettingsMaxHeaderBlockSize- deriving (Show, Read, Eq, Ord, Enum, Bounded)+newtype SettingsKey = SettingsKey Word16 deriving (Eq, Ord) --- | The type for raw SETTINGS value.-type SettingsValue = Int -- Word32+fromSettingsKey :: SettingsKey -> Word16+fromSettingsKey (SettingsKey x) = x --- | Converting 'SettingsKeyId' to raw value.------ >>> fromSettingsKeyId SettingsHeaderTableSize--- 1--- >>> fromSettingsKeyId SettingsMaxHeaderBlockSize--- 6-fromSettingsKeyId :: SettingsKeyId -> Word16-fromSettingsKeyId x = fromIntegral (fromEnum x) + 1+toSettingsKey :: Word16 -> SettingsKey+toSettingsKey = SettingsKey -minSettingsKeyId :: Word16-minSettingsKeyId = fromIntegral $ fromEnum (minBound :: SettingsKeyId)+minSettingsKey :: SettingsKey+minSettingsKey = SettingsKey 1 -maxSettingsKeyId :: Word16-maxSettingsKeyId = fromIntegral $ fromEnum (maxBound :: SettingsKeyId)+maxSettingsKey :: SettingsKey+maxSettingsKey = SettingsKey 6 --- | Converting raw value to '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+pattern SettingsHeaderTableSize :: SettingsKey+pattern SettingsHeaderTableSize = SettingsKey 1 -----------------------------------------------------------------+pattern SettingsEnablePush :: SettingsKey+pattern SettingsEnablePush = SettingsKey 2 --- | Association list of SETTINGS.-type SettingsList = [(SettingsKeyId,SettingsValue)]+pattern SettingsMaxConcurrentStreams :: SettingsKey+pattern SettingsMaxConcurrentStreams = SettingsKey 3 --- | Checking 'SettingsList' and reporting an error if any.------ >>> checkSettingsList [(SettingsEnablePush,2)]--- Just (ConnectionError ProtocolError "enable push must be 0 or 1")-checkSettingsList :: SettingsList -> Maybe HTTP2Error-checkSettingsList settings = case mapMaybe checkSettingsValue settings of- [] -> Nothing- (x:_) -> Just x+pattern SettingsInitialWindowSize :: SettingsKey+pattern SettingsInitialWindowSize = SettingsKey 4 -checkSettingsValue :: (SettingsKeyId,SettingsValue) -> Maybe HTTP2Error-checkSettingsValue (SettingsEnablePush,v)- | v /= 0 && v /= 1 = Just $ ConnectionError ProtocolError "enable push must be 0 or 1"-checkSettingsValue (SettingsInitialWindowSize,v)- | v > 2147483647 = Just $ ConnectionError FlowControlError "Window size must be less than or equal to 65535"-checkSettingsValue (SettingsMaxFrameSize,v)- | v < 16384 || v > 16777215 = Just $ ConnectionError ProtocolError "Max frame size must be in between 16384 and 16777215"-checkSettingsValue _ = Nothing+pattern SettingsMaxFrameSize :: SettingsKey+pattern SettingsMaxFrameSize = SettingsKey 5 -- this means payload size +pattern SettingsMaxHeaderBlockSize :: SettingsKey+pattern SettingsMaxHeaderBlockSize = SettingsKey 6++instance Show SettingsKey where+ show SettingsHeaderTableSize = "SettingsHeaderTableSize"+ show SettingsEnablePush = "SettingsEnablePush"+ show SettingsMaxConcurrentStreams = "SettingsMaxConcurrentStreams"+ show SettingsInitialWindowSize = "SettingsInitialWindowSize"+ show SettingsMaxFrameSize = "SettingsMaxFrameSize"+ show SettingsMaxHeaderBlockSize = "SettingsMaxHeaderBlockSize"+ show (SettingsKey x) = "SettingsKey " ++ show x++instance Read SettingsKey where+ readListPrec = readListPrecDefault+ readPrec = do+ Ident idnt <- lexP+ readSK idnt+ where+ readSK "SettingsHeaderTableSize" = return SettingsHeaderTableSize+ readSK "SettingsEnablePush" = return SettingsEnablePush+ readSK "SettingsMaxConcurrentStreams" = return SettingsMaxConcurrentStreams+ readSK "SettingsInitialWindowSize" = return SettingsInitialWindowSize+ readSK "SettingsMaxFrameSize" = return SettingsMaxFrameSize+ readSK "SettingsMaxHeaderBlockSize" = return SettingsMaxHeaderBlockSize+ readSK "SettingsKey" = do+ Number ftyp <- lexP+ return $ SettingsKey $ fromIntegral $ fromJust $ L.numberToInteger ftyp+ readSK _ = error "Read for SettingsKey"++-- | The type for raw SETTINGS value.+type SettingsValue = Int -- Word32++-- | Association list of SETTINGS.+type SettingsList = [(SettingsKey,SettingsValue)]+ ---------------------------------------------------------------- -- | Cooked version of settings. This is suitable to be stored in a HTTP/2 context.@@ -286,6 +198,7 @@ update def (SettingsInitialWindowSize,x) = def { initialWindowSize = x } update def (SettingsMaxFrameSize,x) = def { maxFrameSize = x } update def (SettingsMaxHeaderBlockSize,x) = def { maxHeaderBlockSize = Just x }+ update def _ = def -- | The type for window size. type WindowSize = Int@@ -326,104 +239,103 @@ ---------------------------------------------------------------- -- | The type for weight in priority. Its values are from 1 to 256.+-- Deprecated in RFC 9113. type Weight = Int --- | Default weight.------ >>> defaultWeight--- 16-defaultWeight :: Weight-defaultWeight = 16-{-# DEPRECATED defaultWeight "Don't use this" #-}---- | Type for stream priority+-- | Type for stream priority. Deprecated in RFC 9113 but provided for 'FrameHeaders'. data Priority = Priority { exclusive :: Bool , streamDependency :: StreamId , weight :: Weight } deriving (Show, Read, Eq) --- | Default priority which depends on stream 0.------ >>> defaultPriority--- Priority {exclusive = False, streamDependency = 0, weight = 16}-defaultPriority :: Priority-defaultPriority = Priority False 0 defaultWeight---- | Highest priority which depends on stream 0.------ >>> highestPriority--- Priority {exclusive = False, streamDependency = 0, weight = 256}-highestPriority :: Priority-highestPriority = Priority False 0 256- ---------------------------------------------------------------- -- | The type for raw frame type.-type FrameType = Word8+newtype FrameType = FrameType Word8 deriving (Eq, Ord, Ix) +-- | Converting 'FrameType' to 'Word8'.+--+-- >>> fromFrameType FrameData+-- 0+-- >>> fromFrameType FrameContinuation+-- 9+fromFrameType :: FrameType -> Word8+fromFrameType (FrameType x) = x++toFrameType :: Word8 -> FrameType+toFrameType = FrameType+ minFrameType :: FrameType-minFrameType = 0+minFrameType = FrameType 0 maxFrameType :: FrameType-maxFrameType = 9+maxFrameType = FrameType 9 --- | The type for frame type.-data FrameTypeId = FrameData- | FrameHeaders- | FramePriority- | FrameRSTStream- | FrameSettings- | FramePushPromise- | FramePing- | FrameGoAway- | FrameWindowUpdate- | FrameContinuation- | FrameUnknown FrameType- deriving (Show, Eq, Ord)+pattern FrameData :: FrameType+pattern FrameData = FrameType 0 --- | Converting 'FrameTypeId' to 'FrameType'.------ >>> fromFrameTypeId FrameData--- 0--- >>> fromFrameTypeId FrameContinuation--- 9--- >>> fromFrameTypeId (FrameUnknown 10)--- 10-fromFrameTypeId :: FrameTypeId -> FrameType-fromFrameTypeId FrameData = 0-fromFrameTypeId FrameHeaders = 1-fromFrameTypeId FramePriority = 2-fromFrameTypeId FrameRSTStream = 3-fromFrameTypeId FrameSettings = 4-fromFrameTypeId FramePushPromise = 5-fromFrameTypeId FramePing = 6-fromFrameTypeId FrameGoAway = 7-fromFrameTypeId FrameWindowUpdate = 8-fromFrameTypeId FrameContinuation = 9-fromFrameTypeId (FrameUnknown x) = x+pattern FrameHeaders :: FrameType+pattern FrameHeaders = FrameType 1 --- | Converting 'FrameType' to 'FrameTypeId'.------ >>> toFrameTypeId 0--- FrameData--- >>> toFrameTypeId 9--- FrameContinuation--- >>> toFrameTypeId 10--- FrameUnknown 10-toFrameTypeId :: FrameType -> FrameTypeId-toFrameTypeId 0 = FrameData-toFrameTypeId 1 = FrameHeaders-toFrameTypeId 2 = FramePriority-toFrameTypeId 3 = FrameRSTStream-toFrameTypeId 4 = FrameSettings-toFrameTypeId 5 = FramePushPromise-toFrameTypeId 6 = FramePing-toFrameTypeId 7 = FrameGoAway-toFrameTypeId 8 = FrameWindowUpdate-toFrameTypeId 9 = FrameContinuation-toFrameTypeId x = FrameUnknown x+pattern FramePriority :: FrameType+pattern FramePriority = FrameType 2 +pattern FrameRSTStream :: FrameType+pattern FrameRSTStream = FrameType 3++pattern FrameSettings :: FrameType+pattern FrameSettings = FrameType 4++pattern FramePushPromise :: FrameType+pattern FramePushPromise = FrameType 5++pattern FramePing :: FrameType+pattern FramePing = FrameType 6++pattern FrameGoAway :: FrameType+pattern FrameGoAway = FrameType 7++pattern FrameWindowUpdate :: FrameType+pattern FrameWindowUpdate = FrameType 8++pattern FrameContinuation :: FrameType+pattern FrameContinuation = FrameType 9++instance Show FrameType where+ show (FrameType 0) = "FrameData"+ show (FrameType 1) = "FrameHeaders"+ show (FrameType 2) = "FramePriority"+ show (FrameType 3) = "FrameRSTStream"+ show (FrameType 4) = "FrameSettings"+ show (FrameType 5) = "FramePushPromise"+ show (FrameType 6) = "FramePing"+ show (FrameType 7) = "FrameGoAway"+ show (FrameType 8) = "FrameWindowUpdate"+ show (FrameType 9) = "FrameContinuation"+ show (FrameType x) = "FrameType " ++ show x++instance Read FrameType where+ readListPrec = readListPrecDefault+ readPrec = do+ Ident idnt <- lexP+ readFT idnt+ where+ readFT "FrameData" = return FrameData+ readFT "FrameHeaders" = return FrameHeaders+ readFT "FramePriority" = return FramePriority+ readFT "FrameRSTStream" = return FrameRSTStream+ readFT "FrameSettings" = return FrameSettings+ readFT "FramePushPromise" = return FramePushPromise+ readFT "FramePing" = return FramePing+ readFT "FrameGoAway" = return FrameGoAway+ readFT "FrameWindowUpdate" = return FrameWindowUpdate+ readFT "FrameContinuation" = return FrameContinuation+ readFT "FrameType" = do+ Number ftyp <- lexP+ return $ FrameType $ fromIntegral $ fromJust $ L.numberToInteger ftyp+ readFT _ = error "Read for FrameType"+ ---------------------------------------------------------------- -- | The maximum length of HTTP/2 payload.@@ -548,27 +460,6 @@ isServerInitiated 0 = False isServerInitiated n = even n --- | Checking if the stream identifier for request.------ >>> isRequest 0--- False--- >>> isRequest 1--- True-isRequest :: StreamId -> Bool-isRequest = odd-{-# DEPRECATED isRequest "Use isClientInitiated instead" #-}---- | Checking if the stream identifier for response.------ >>> isResponse 0--- False--- >>> isResponse 2--- True-isResponse :: StreamId -> Bool-isResponse 0 = False-isResponse n = even n-{-# DEPRECATED isResponse "Use isServerInitiated instead" #-}- -- | Checking if the exclusive flag is set. testExclusive :: StreamId -> Bool testExclusive n = n `testBit` 31@@ -609,11 +500,11 @@ DataFrame ByteString | HeadersFrame (Maybe Priority) HeaderBlockFragment | PriorityFrame Priority- | RSTStreamFrame ErrorCodeId+ | RSTStreamFrame ErrorCode | SettingsFrame SettingsList | PushPromiseFrame StreamId HeaderBlockFragment | PingFrame ByteString- | GoAwayFrame StreamId ErrorCodeId ByteString+ | GoAwayFrame {- the last -}StreamId ErrorCode ByteString | WindowUpdateFrame WindowSize | ContinuationFrame HeaderBlockFragment | UnknownFrame FrameType ByteString@@ -623,20 +514,20 @@ -- | Getting 'FrameType' from 'FramePayload'. ----- >>> framePayloadToFrameTypeId (DataFrame "body")+-- >>> framePayloadToFrameType (DataFrame "body") -- FrameData-framePayloadToFrameTypeId :: FramePayload -> FrameTypeId-framePayloadToFrameTypeId DataFrame{} = FrameData-framePayloadToFrameTypeId HeadersFrame{} = FrameHeaders-framePayloadToFrameTypeId PriorityFrame{} = FramePriority-framePayloadToFrameTypeId RSTStreamFrame{} = FrameRSTStream-framePayloadToFrameTypeId SettingsFrame{} = FrameSettings-framePayloadToFrameTypeId PushPromiseFrame{} = FramePushPromise-framePayloadToFrameTypeId PingFrame{} = FramePing-framePayloadToFrameTypeId GoAwayFrame{} = FrameGoAway-framePayloadToFrameTypeId WindowUpdateFrame{} = FrameWindowUpdate-framePayloadToFrameTypeId ContinuationFrame{} = FrameContinuation-framePayloadToFrameTypeId (UnknownFrame w8 _) = FrameUnknown w8+framePayloadToFrameType :: FramePayload -> FrameType+framePayloadToFrameType DataFrame{} = FrameData+framePayloadToFrameType HeadersFrame{} = FrameHeaders+framePayloadToFrameType PriorityFrame{} = FramePriority+framePayloadToFrameType RSTStreamFrame{} = FrameRSTStream+framePayloadToFrameType SettingsFrame{} = FrameSettings+framePayloadToFrameType PushPromiseFrame{} = FramePushPromise+framePayloadToFrameType PingFrame{} = FramePing+framePayloadToFrameType GoAwayFrame{} = FrameGoAway+framePayloadToFrameType WindowUpdateFrame{} = FrameWindowUpdate+framePayloadToFrameType ContinuationFrame{} = FrameContinuation+framePayloadToFrameType (UnknownFrame ft _) = ft ---------------------------------------------------------------- @@ -658,3 +549,13 @@ isPaddingDefined WindowUpdateFrame{} = False isPaddingDefined ContinuationFrame{} = False isPaddingDefined UnknownFrame{} = False++----------------------------------------------------------------+-- Deprecated++type ErrorCodeId = ErrorCode+type SettingsKeyId = SettingsKey+type FrameTypeId = FrameType+{- DEPRECATED ErrorCodeId "Use ErrorCode instead" -}+{- DEPRECATED SettingsKeyId "Use SettingsKey instead" -}+{- DEPRECATED FrameTypeId "Use FrameType instead" -}
− Network/HTTP2/Priority.hs
@@ -1,154 +0,0 @@--- | This is partial implementation of the priority of HTTP/2.------ This implementation does support structured priority queue--- but not support re-structuring. This means that it is assumed that--- an entry created by a Priority frame is never closed. The entry--- behaves an intermediate node, not a leaf.------ This queue is fair for weight. Consider two weights: 201 and 101.--- Repeating enqueue/dequeue probably produces--- 201, 201, 101, 201, 201, 101, ...------ Only one entry per stream should be enqueued.--module Network.HTTP2.Priority {-# DEPRECATED "Should be replaced with extensible priority" #-} (- -- * Precedence- Precedence- , defaultPrecedence- , toPrecedence- -- * PriorityTree- , PriorityTree- , newPriorityTree- -- * PriorityTree functions- , prepare- , enqueue- , dequeue- , dequeueSTM- , isEmpty- , isEmptySTM- , delete- ) where--import Control.Concurrent.STM-import Data.IntMap.Strict (IntMap)-import qualified Data.IntMap.Strict as Map--import Imports hiding (delete, empty)-import Network.HTTP2.Priority.Queue (TPriorityQueue, Precedence)-import qualified Network.HTTP2.Priority.Queue as Q-import Network.HTTP2.Frame.Types---------------------------------------------------------------------- | Abstract data type for priority trees.-data PriorityTree a = PriorityTree (TVar (Glue a))- (TNestedPriorityQueue a)--type Glue a = IntMap (TNestedPriorityQueue a, Precedence)---- INVARIANT: Empty TNestedPriorityQueue is never enqueued in--- another TNestedPriorityQueue.-type TNestedPriorityQueue a = TPriorityQueue (Element a)--data Element a = Child a- | Parent (TNestedPriorityQueue a)----------------------------------------------------------------------- | Default precedence.-defaultPrecedence :: Precedence-defaultPrecedence = toPrecedence defaultPriority---- | Converting 'Priority' to 'Precedence'.--- When an entry is enqueued at the first time,--- this function should be used.-toPrecedence :: Priority -> Precedence-toPrecedence (Priority _ dep w) = Q.Precedence 0 w dep---------------------------------------------------------------------- | Creating a new priority tree.-newPriorityTree :: IO (PriorityTree a)-newPriorityTree = PriorityTree <$> newTVarIO Map.empty- <*> atomically Q.new---------------------------------------------------------------------- | Bringing up the structure of the priority tree.--- This must be used for Priority frame.-prepare :: PriorityTree a -> StreamId -> Priority -> IO ()-prepare (PriorityTree var _) sid p = atomically $ do- q <- Q.new- let pre = toPrecedence p- modifyTVar' var $ Map.insert sid (q, pre)---- | Enqueuing an entry to the priority tree.--- This must be used for Header frame.-enqueue :: PriorityTree a -> StreamId -> Precedence -> a -> IO ()-enqueue (PriorityTree var q0) sid p0 x = atomically $ do- m <- readTVar var- let el = Child x- loop m el p0- where- loop m el p- | pid == 0 = Q.enqueue q0 sid p el- | otherwise = case Map.lookup pid m of- -- If not found, enqueuing it to the stream 0 queue.- Nothing -> Q.enqueue q0 sid p el- Just (q', p') -> do- notQueued <- Q.isEmpty q'- Q.enqueue q' sid p el- when notQueued $ do- let el' = Parent q'- loop m el' p'- where- pid = Q.dependency p----- | Checking if the priority tree is empty.-isEmpty :: PriorityTree a -> IO Bool-isEmpty = atomically . isEmptySTM---- | Checking if the priority tree is empty.-isEmptySTM :: PriorityTree a -> STM Bool-isEmptySTM (PriorityTree _ q0) = Q.isEmpty q0---- | Dequeuing an entry from the priority tree.-dequeue :: PriorityTree a -> IO (StreamId, Precedence, a)-dequeue = atomically . dequeueSTM---- | Dequeuing an entry from the priority tree.-dequeueSTM :: PriorityTree a -> STM (StreamId, Precedence, a)-dequeueSTM (PriorityTree _ q0) = loop q0- where- loop q = do- (sid,p,el) <- Q.dequeue q- case el of- Child x -> return (sid, p, x)- Parent q' -> do- entr <- loop q'- empty <- Q.isEmpty q'- unless empty $ Q.enqueue q sid p el- return entr---- | Deleting the entry corresponding to 'StreamId'.--- 'delete' and 'enqueue' are used to change the priority of--- a live stream.-delete :: PriorityTree a -> StreamId -> Precedence -> IO (Maybe a)-delete (PriorityTree var q0) sid p- | pid == 0 = atomically $ del q0- | otherwise = atomically $ do- m <- readTVar var- case Map.lookup pid m of- Nothing -> return Nothing- Just (q,_) -> del q- where- pid = Q.dependency p- del q = do- mel <- Q.delete sid q- case mel of- Nothing -> return Nothing- Just el -> case el of- Child x -> return $ Just x- Parent _ -> return Nothing -- fixme: this is error
− Network/HTTP2/Priority/Internal.hs
@@ -1,5 +0,0 @@-module Network.HTTP2.Priority.Internal (- module Network.HTTP2.Priority.PSQ- ) where--import Network.HTTP2.Priority.PSQ
− Network/HTTP2/Priority/PSQ.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module Network.HTTP2.Priority.PSQ (- Key- , Weight- , Deficit- , Precedence(..)- , newPrecedence- , PriorityQueue(..)- , Heap- , empty- , isEmpty- , enqueue- , dequeue- , delete- ) where--import Data.Array (Array, listArray, (!))-import Data.IntPSQ (IntPSQ)-import qualified Data.IntPSQ as P--------------------------------------------------------------------type Key = Int-type Weight = Int-type Deficit = Word -- Deficit can be overflowed---- | Internal representation of priority in priority queues.--- The precedence of a dequeued entry should be specified--- to enqueue when the entry is enqueued again.-data Precedence = Precedence {- deficit :: Deficit- , weight :: Weight- -- stream dependency, used by the upper layer- , dependency :: Key- } deriving Show---- | For test only-newPrecedence :: Weight -> Precedence-newPrecedence w = Precedence 0 w 0--instance Eq Precedence where- Precedence d1 _ _ == Precedence d2 _ _ = d1 == d2--instance Ord Precedence where- -- This is correct even if one of them is overflowed- Precedence d1 _ _ < Precedence d2 _ _ = d1 /= d2 && d2 - d1 <= deficitStepsW- Precedence d1 _ _ <= Precedence d2 _ _ = d2 - d1 <= deficitStepsW--type Heap a = IntPSQ Precedence a--data PriorityQueue a = PriorityQueue {- baseDeficit :: Deficit- , queue :: Heap a- }--------------------------------------------------------------------deficitSteps :: Int-deficitSteps = 65536--deficitStepsW :: Word-deficitStepsW = fromIntegral deficitSteps--deficitList :: [Deficit]-deficitList = map calc idxs- where- idxs = [1..256] :: [Double]- calc w = round (fromIntegral deficitSteps / w)--deficitTable :: Array Int Deficit-deficitTable = listArray (1,256) deficitList--weightToDeficit :: Weight -> Deficit-weightToDeficit w = deficitTable ! w--------------------------------------------------------------------empty :: PriorityQueue a-empty = PriorityQueue 0 P.empty--isEmpty :: PriorityQueue a -> Bool-isEmpty PriorityQueue{..} = P.null queue--enqueue :: Key -> Precedence -> a -> PriorityQueue a -> PriorityQueue a-enqueue k p@Precedence{..} v PriorityQueue{..} =- PriorityQueue baseDeficit queue'- where- d = weightToDeficit weight- b = if deficit == 0 then baseDeficit else deficit- deficit' = max (b + d) baseDeficit- p' = p { deficit = deficit' }- queue' = P.insert k p' v queue--dequeue :: PriorityQueue a -> Maybe (Key, Precedence, a, PriorityQueue a)-dequeue PriorityQueue{..} = case P.minView queue of- Nothing -> Nothing- Just (k, p, v, queue') -> let base = deficit p- in Just (k, p, v, PriorityQueue base queue')--delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)-delete k q@PriorityQueue{..} = case P.alter f k queue of- (mv@(Just _), queue') -> case P.minView queue of- Nothing -> error "delete"- Just (k',p',_,_)- | k' == k -> (mv, PriorityQueue (deficit p') queue')- | otherwise -> (mv, PriorityQueue baseDeficit queue')- (Nothing, _) -> (Nothing, q)- where- f Nothing = (Nothing, Nothing)- f (Just (_,v)) = (Just v, Nothing)
− Network/HTTP2/Priority/Queue.hs
@@ -1,42 +0,0 @@-module Network.HTTP2.Priority.Queue (- Precedence(..)- , TPriorityQueue- , new- , isEmpty- , enqueue- , dequeue- , delete- ) where--import Control.Concurrent.STM-import Network.HTTP2.Priority.PSQ (PriorityQueue, Key, Precedence(..))-import qualified Network.HTTP2.Priority.PSQ as Q--------------------------------------------------------------------newtype TPriorityQueue a = TPriorityQueue (TVar (PriorityQueue a))--new :: STM (TPriorityQueue a)-new = TPriorityQueue <$> newTVar Q.empty--isEmpty :: TPriorityQueue a -> STM Bool-isEmpty (TPriorityQueue th) = Q.isEmpty <$> readTVar th--enqueue :: TPriorityQueue a -> Key -> Precedence -> a -> STM ()-enqueue (TPriorityQueue th) k p v = modifyTVar' th $ Q.enqueue k p v--dequeue :: TPriorityQueue a -> STM (Key, Precedence, a)-dequeue (TPriorityQueue th) = do- h <- readTVar th- case Q.dequeue h of- Nothing -> retry- Just (k, p, v, h') -> do- writeTVar th h'- return (k, p, v)--delete :: Key -> TPriorityQueue a -> STM (Maybe a)-delete k (TPriorityQueue th) = do- q <- readTVar th- let (mv, q') = Q.delete k q- writeTVar th q'- return mv
Network/HTTP2/Server.hs view
@@ -68,8 +68,6 @@ , pushPromise , promiseRequestPath , promiseResponse- , promiseWeight- , defaultWeight -- * Types , Path , Authority@@ -187,4 +185,4 @@ -- | Creating push promise. -- The third argument is traditional, not used. pushPromise :: ByteString -> Response -> Weight -> PushPromise-pushPromise path rsp w = PushPromise path rsp w+pushPromise path rsp _ = PushPromise path rsp
Network/HTTP2/Server/Run.hs view
@@ -3,8 +3,8 @@ module Network.HTTP2.Server.Run where -import Control.Concurrent (forkIO, killThread)-import qualified Control.Exception as E+import UnliftIO.Async (race_)+import qualified UnliftIO.Exception as E import Imports import Network.HTTP2.Arch@@ -31,14 +31,9 @@ -- If it is large, huge memory is consumed and many -- context switches happen. replicateM_ 3 $ spawnAction mgr- -- Receiver- tid <- forkIO $ frameReceiver ctx confReadN- -- Sender- -- frameSender is the main thread because it ensures to send- -- a goway frame.- frameSender ctx conf mgr `E.finally` do- stop mgr- killThread tid+ let runReceiver = frameReceiver ctx confReadN+ runSender = frameSender ctx conf mgr+ race_ runReceiver runSender `E.finally` stop mgr where checkPreface = do preface <- confReadN connectionPrefaceLength@@ -49,7 +44,7 @@ return True -- connClose must not be called here since Run:fork calls it-goaway :: Config -> ErrorCodeId -> ByteString -> IO ()+goaway :: Config -> ErrorCode -> ByteString -> IO () goaway Config{..} etype debugmsg = confSendAll bytestream where bytestream = goawayFrame 0 etype debugmsg
Network/HTTP2/Server/Types.hs view
@@ -4,7 +4,6 @@ import Imports import Network.HTTP2.Arch-import Network.HTTP2.Frame ---------------------------------------------------------------- @@ -31,10 +30,7 @@ -- | Accessor for response actually pushed from a server. , promiseResponse :: Response -- | Accessor for response weight.- , promiseWeight :: Weight }--{-# DEPRECATED promiseWeight "Don't use this" #-} -- | Additional information. newtype Aux = Aux {
Network/HTTP2/Server/Worker.hs view
@@ -9,12 +9,13 @@ , fromContext ) where -import Control.Concurrent.STM-import Control.Exception (SomeException(..), AsyncException(..))-import qualified Control.Exception as E+import Control.Exception (AsyncException(..)) import Data.IORef import qualified Network.HTTP.Types as H import qualified System.TimeManager as T+import UnliftIO.Exception (SomeException(..))+import qualified UnliftIO.Exception as E+import UnliftIO.STM import Imports hiding (insert) import Network.HPACK@@ -36,7 +37,7 @@ fromContext :: Context -> WorkerConf Stream fromContext ctx@Context{..} = WorkerConf {- readInputQ = atomically $ readTQueue $ inputQ roleInfo+ readInputQ = atomically $ readTQueue $ inputQ $ toServerInfo roleInfo , writeOutputQ = enqueueOutput outputQ , workerCleanup = \strm -> do closed ctx strm Killed@@ -78,15 +79,15 @@ increment tvar = atomically $ modifyTVar' tvar (+1) waiter lim tvar = atomically $ do n <- readTVar tvar- check (n >= lim)+ checkSTM (n >= lim) push _ [] n = return (n :: Int) push tvar (pp:pps) n = do (pid, sid, newstrm) <- makePushStream pstrm pp insertStream sid newstrm let scheme = fromJust $ getHeaderValue tokenScheme reqvt -- fixme: this value can be Nothing- auth = fromJust (getHeaderValue tokenHost reqvt- <|> getHeaderValue tokenAuthority reqvt)+ auth = fromJust (getHeaderValue tokenAuthority reqvt+ <|> getHeaderValue tokenHost reqvt) path = promiseRequestPath pp promiseRequest = [(tokenMethod, H.methodGet) ,(tokenScheme, scheme)@@ -149,7 +150,7 @@ where go sinfo tcont th = do setThreadContinue tcont True- ex <- E.try $ do+ ex <- E.trySyncOrAsync $ do T.pause th Input strm req <- readInputQ let req' = pauseRequestBody req th
− bench-priority/BinaryHeap.hs
@@ -1,175 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts, CPP #-}--module BinaryHeap (- Entry- , newEntry- , renewEntry- , item- , PriorityQueue(..)- , new- , enqueue- , dequeue- , delete- ) where--#if __GLASGOW_HASKELL__ < 709-import Data.Word (Word)-#endif-import Control.Monad (when, void)-import Data.Array (Array, listArray, (!))-import Data.Array.IO (IOArray)-import Data.Array.MArray (newArray_, readArray, writeArray)-import Data.IORef--------------------------------------------------------------------type Weight = Int-type Deficit = Word---- | Abstract data type of entries for priority queues.--- This does not contain Key because Entry is assumed to be stored--- in HTTP/2 stream information, too.-data Entry a = Entry {- weight :: {-# UNPACK #-} !Weight- , item :: {-# UNPACK #-} !(IORef a) -- ^ Extracting an item from an entry.- , deficit :: {-# UNPACK #-} !(IORef Deficit)- , index :: {-# UNPACK #-} !(IORef Index)- }--newEntry :: a -> Weight -> IO (Entry a)-newEntry x w = Entry w <$> newIORef x <*> newIORef magicDeficit <*> newIORef (-1)---- | Changing the item of an entry.-renewEntry :: Entry a -> a -> IO ()-renewEntry Entry{..} x = writeIORef item x--------------------------------------------------------------------type Index = Int-type MA a = IOArray Index (Entry a)--data PriorityQueue a = PriorityQueue (IORef Deficit)- (IORef Index)- (MA a)--------------------------------------------------------------------magicDeficit :: Deficit-magicDeficit = 0--deficitSteps :: Int-deficitSteps = 65536--deficitStepsW :: Word-deficitStepsW = fromIntegral deficitSteps--deficitList :: [Deficit]-deficitList = map calc idxs- where- idxs = [1..256] :: [Double]- calc w = round (fromIntegral deficitSteps / w)--deficitTable :: Array Index Deficit-deficitTable = listArray (1,256) deficitList--weightToDeficit :: Weight -> Deficit-weightToDeficit w = deficitTable ! w--------------------------------------------------------------------new :: Int -> IO (PriorityQueue a)-new n = PriorityQueue <$> newIORef 0- <*> newIORef 1- <*> newArray_ (1,n)---- | Enqueuing an entry. PriorityQueue is updated.-enqueue :: Entry a -> PriorityQueue a -> IO ()-enqueue ent@Entry{..} (PriorityQueue bref idx arr) = do- i <- readIORef idx- base <- readIORef bref- d <- readIORef deficit- let !b = if d == magicDeficit then base else d- !d' = b + weightToDeficit weight- writeIORef deficit d'- write arr i ent- shiftUp arr i- let !i' = i + 1- writeIORef idx i'- return ()---- | Dequeuing an entry. PriorityQueue is updated.-dequeue :: PriorityQueue a -> IO (Entry a)-dequeue (PriorityQueue bref idx arr) = do- ent <- shrink arr 1 idx- i <- readIORef idx- shiftDown arr 1 i- d <- readIORef $ deficit ent- writeIORef bref $ if i == 1 then 0 else d- return ent--shrink :: MA a -> Index -> IORef Index -> IO (Entry a)-shrink arr r idx = do- entr <- readArray arr r- -- fixme: checking if i == 0- i <- subtract 1 <$> readIORef idx- xi <- readArray arr i- write arr r xi- writeIORef idx i- return entr--shiftUp :: MA a -> Int -> IO ()-shiftUp _ 1 = return ()-shiftUp arr c = do- swapped <- swap arr p c- when swapped $ shiftUp arr p- where- p = c `div` 2--shiftDown :: MA a -> Int -> Int -> IO ()-shiftDown arr p n- | c1 > n = return ()- | c1 == n = void $ swap arr p c1- | otherwise = do- let !c2 = c1 + 1- xc1 <- readArray arr c1- xc2 <- readArray arr c2- d1 <- readIORef $ deficit xc1- d2 <- readIORef $ deficit xc2- let !c = if d1 /= d2 && d2 - d1 <= deficitStepsW then c1 else c2- swapped <- swap arr p c- when swapped $ shiftDown arr c n- where- c1 = 2 * p--{-# INLINE swap #-}-swap :: MA a -> Index -> Index -> IO Bool-swap arr p c = do- xp <- readArray arr p- xc <- readArray arr c- dp <- readIORef $ deficit xp- dc <- readIORef $ deficit xc- if dc < dp then do- write arr c xp- write arr p xc- return True- else- return False--{-# INLINE write #-}-write :: MA a -> Index -> Entry a -> IO ()-write arr i ent = do- writeArray arr i ent- writeIORef (index ent) i--delete :: Entry a -> PriorityQueue a -> IO ()-delete ent pq@(PriorityQueue _ idx arr) = do- i <- readIORef $ index ent- if i == 1 then- void $ dequeue pq- else do- entr <- shrink arr i idx- r <- readIORef $ index entr- shiftDown arr r (i - 1)- shiftUp arr r
− bench-priority/BinaryHeapSTM.hs
@@ -1,174 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts, CPP #-}--module BinaryHeapSTM (- Entry- , newEntry- , renewEntry- , item- , PriorityQueue(..)- , new- , enqueue- , dequeue- , delete- ) where--#if __GLASGOW_HASKELL__ < 709-import Data.Word (Word)-#endif-import Control.Concurrent.STM-import Control.Monad (when, void)-import Data.Array (Array, listArray, (!))-import Data.Array.MArray (newArray_, readArray, writeArray)--------------------------------------------------------------------type Weight = Int-type Deficit = Word---- | Abstract data type of entries for priority queues.-data Entry a = Entry {- weight :: {-# UNPACK #-} !Weight- , item :: {-# UNPACK #-} !(TVar a) -- ^ Extracting an item from an entry.- , deficit :: {-# UNPACK #-} !(TVar Deficit)- , index :: {-# UNPACK #-} !(TVar Index)- }--newEntry :: a -> Weight -> STM (Entry a)-newEntry x w = Entry w <$> newTVar x <*> newTVar magicDeficit <*> newTVar (-1)---- | Changing the item of an entry.-renewEntry :: Entry a -> a -> STM ()-renewEntry Entry{..} x = writeTVar item x--------------------------------------------------------------------type Index = Int-type MA a = TArray Index (Entry a)---- FIXME: The base (Word64) would be overflowed.--- In that case, the heap must be re-constructed.-data PriorityQueue a = PriorityQueue (TVar Deficit)- (TVar Index)- (MA a)--------------------------------------------------------------------magicDeficit :: Deficit-magicDeficit = 0--deficitSteps :: Int-deficitSteps = 65536--deficitStepsW :: Word-deficitStepsW = fromIntegral deficitSteps--deficitList :: [Deficit]-deficitList = map calc idxs- where- idxs = [1..256] :: [Double]- calc w = round (fromIntegral deficitSteps / w)--deficitTable :: Array Index Deficit-deficitTable = listArray (1,256) deficitList--weightToDeficit :: Weight -> Deficit-weightToDeficit w = deficitTable ! w--------------------------------------------------------------------new :: Int -> STM (PriorityQueue a)-new n = PriorityQueue <$> newTVar 0- <*> newTVar 1- <*> newArray_ (1,n)---- | Enqueuing an entry. PriorityQueue is updated.-enqueue :: Entry a -> PriorityQueue a -> STM ()-enqueue ent@Entry{..} (PriorityQueue bref idx arr) = do- i <- readTVar idx- base <- readTVar bref- d <- readTVar deficit- let !b = if d == magicDeficit then base else d- !d' = b + weightToDeficit weight- writeTVar deficit d'- write arr i ent- shiftUp arr i- let !i' = i + 1- writeTVar idx i'- return ()---- | Dequeuing an entry. PriorityQueue is updated.-dequeue :: PriorityQueue a -> STM (Entry a)-dequeue (PriorityQueue bref idx arr) = do- ent <- shrink arr 1 idx- i <- readTVar idx- shiftDown arr 1 i- d <- readTVar $ deficit ent- writeTVar bref $ if i == 1 then 0 else d- return ent--shrink :: MA a -> Index -> TVar Index -> STM (Entry a)-shrink arr r idx = do- entr <- readArray arr r- -- fixme: checking if i == 0- i <- subtract 1 <$> readTVar idx- xi <- readArray arr i- write arr r xi- writeTVar idx i- return entr--shiftUp :: MA a -> Int -> STM ()-shiftUp _ 1 = return ()-shiftUp arr c = do- swapped <- swap arr p c- when swapped $ shiftUp arr p- where- p = c `div` 2--shiftDown :: MA a -> Int -> Int -> STM ()-shiftDown arr p n- | c1 > n = return ()- | c1 == n = void $ swap arr p c1- | otherwise = do- let !c2 = c1 + 1- xc1 <- readArray arr c1- xc2 <- readArray arr c2- d1 <- readTVar $ deficit xc1- d2 <- readTVar $ deficit xc2- let !c = if d1 /= d2 && d2 - d1 <= deficitStepsW then c1 else c2- swapped <- swap arr p c- when swapped $ shiftDown arr c n- where- c1 = 2 * p--{-# INLINE swap #-}-swap :: MA a -> Index -> Index -> STM Bool-swap arr p c = do- xp <- readArray arr p- xc <- readArray arr c- dp <- readTVar $ deficit xp- dc <- readTVar $ deficit xc- if dc < dp then do- write arr c xp- write arr p xc- return True- else- return False--{-# INLINE write #-}-write :: MA a -> Index -> Entry a -> STM ()-write arr i ent = do- writeArray arr i ent- writeTVar (index ent) i--delete :: Entry a -> PriorityQueue a -> STM ()-delete ent pq@(PriorityQueue _ idx arr) = do- i <- readTVar $ index ent- if i == 1 then- void $ dequeue pq- else do- entr <- shrink arr i idx- r <- readTVar $ index entr- shiftDown arr r (i - 1)- shiftUp arr r
− bench-priority/DoublyLinkedQueueIO.hs
@@ -1,85 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--module DoublyLinkedQueueIO (- Queue- , Node- , item- , new- , isEmpty- , enqueue- , dequeue- , delete- ) where--import Data.IORef--data Queue a = Queue {- entr :: Node a- , exit :: Node a- }--data Node a = Node {- item :: a- , prev :: {-# UNPACK #-} !(IORef (Node a))- , next :: {-# UNPACK #-} !(IORef (Node a))- } deriving Eq--newNode :: a -> IO (Node a)-newNode x = Node x <$> newIORef undefined <*> newIORef undefined--{-# INLINE getNext #-}-getNext :: Node a -> IO (Node a)-getNext Node{..} = readIORef next--{-# INLINE setNext #-}-setNext :: Node a -> Node a -> IO ()-setNext Node{..} x = writeIORef next x--{-# INLINE getPrev #-}-getPrev :: Node a -> IO (Node a)-getPrev Node{..} = readIORef prev--{-# INLINE setPrev #-}-setPrev :: Node a -> Node a -> IO ()-setPrev Node{..} x = writeIORef prev x--new :: IO (Queue a)-new = do- a1 <- newNode undefined- a2 <- newNode undefined- setPrev a1 a2- setNext a1 a2- setPrev a2 a1- setNext a2 a1- return $! Queue a1 a2--isEmpty :: Queue a -> IO Bool-isEmpty Queue{..} = do- n <- getNext entr- nn <- getNext n- return $! next entr == next nn--enqueue :: a -> Queue a -> IO (Node a)-enqueue a Queue{..} = do- x <- newNode a- n <- getNext entr- setPrev x entr- setNext x n- setPrev n x- setNext entr x- return x--dequeue :: Queue a -> IO a-dequeue Queue{..} = do- p <- getPrev exit- pp <- getPrev p- setPrev exit pp- setNext pp exit- return $! item p--delete :: Node a -> IO ()-delete x = do- p <- getPrev x- n <- getNext x- setNext p n- setPrev n p
− bench-priority/Heap.hs
@@ -1,121 +0,0 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE RecordWildCards #-}--module Heap (- PriorityQueue(..)- , Precedence(..)- , newPrecedence- , empty- , isEmpty- , enqueue- , dequeue- , delete- ) where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative ((<$>))-import Data.Word (Word)-#endif-import Data.Array (Array, listArray, (!))-import Data.Heap (Heap)-import qualified Data.Heap as H--------------------------------------------------------------------type Key = Int-type Weight = Int-type Deficit = Word -- Deficit can be overflowed--data Precedence = Precedence {- deficit :: {-# UNPACK #-} !Deficit- , weight :: {-# UNPACK #-} !Weight- -- stream dependency, used by the upper layer- , dependency :: {-# UNPACK #-} !Key- } deriving Show---- | For test only-newPrecedence :: Weight -> Precedence-newPrecedence w = Precedence 0 w 0--instance Eq Precedence where- Precedence d1 _ _ == Precedence d2 _ _ = d1 == d2--instance Ord Precedence where- -- This is correct even if one of them is overflowed- Precedence d1 _ _ < Precedence d2 _ _ = d1 /= d2 && d2 - d1 <= deficitStepsW- Precedence d1 _ _ <= Precedence d2 _ _ = d2 - d1 <= deficitStepsW--data Entry a = Entry Key Precedence a--instance Eq (Entry a) where- Entry _ p1 _ == Entry _ p2 _ = p1 == p2--instance Ord (Entry a) where- Entry _ p1 _ < Entry _ p2 _ = p1 < p2- Entry _ p1 _ <= Entry _ p2 _ = p1 <= p2---- FIXME: The base (Word64) would be overflowed.--- In that case, the heap must be re-constructed.-data PriorityQueue a = PriorityQueue {- baseDeficit :: {-# UNPACK #-} !Deficit- , queue :: Heap (Entry a)- }--------------------------------------------------------------------magicDeficit :: Deficit-magicDeficit = 0--deficitSteps :: Int-deficitSteps = 65536--deficitStepsW :: Word-deficitStepsW = fromIntegral deficitSteps--deficitList :: [Deficit]-deficitList = map calc idxs- where- idxs = [1..256] :: [Double]- calc w = round (fromIntegral deficitSteps / w)--deficitTable :: Array Int Deficit-deficitTable = listArray (1,256) deficitList--weightToDeficit :: Weight -> Deficit-weightToDeficit w = deficitTable ! w--------------------------------------------------------------------empty :: PriorityQueue a-empty = PriorityQueue 0 H.empty--isEmpty :: PriorityQueue a -> Bool-isEmpty (PriorityQueue _ h) = H.null h--enqueue :: Key -> Precedence -> a -> PriorityQueue a -> PriorityQueue a-enqueue k p v PriorityQueue{..} = PriorityQueue b queue'- where- !d = weightToDeficit (weight p)- !b = if deficit p == magicDeficit then baseDeficit else deficit p- !deficit' = max (b + d) baseDeficit- !p' = p { deficit = deficit' }- !queue' = H.insert (Entry k p' v) queue--dequeue :: PriorityQueue a -> Maybe (Key, Precedence, a, PriorityQueue a)-dequeue (PriorityQueue _ heap) = case H.uncons heap of- Nothing -> Nothing- Just (Entry k p v, heap') -> Just (k, p, v, PriorityQueue (deficit p) heap')--delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)-delete k (PriorityQueue base heap) = (mv, PriorityQueue base' heap')- where- !(h,heap') = H.partition (\(Entry k' _ _) -> k' == k) heap- mv = case H.viewMin h of- Nothing -> Nothing- Just (Entry _ _ v, _) -> Just v- base' = case H.viewMin heap of- Nothing -> base- Just (Entry k' p _, _)- | k == k' -> deficit p- | otherwise -> base
− bench-priority/Main.hs
@@ -1,240 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module Main where--import Control.Concurrent.STM-import Gauge.Main-import Data.List (foldl')-import System.Random.MWC--import qualified RingOfQueuesSTM as A-import qualified RingOfQueues as AIO-import qualified BinaryHeapSTM as B-import qualified BinaryHeap as BIO-import qualified Heap as O-import qualified Network.HTTP2.Priority.PSQ as P-import qualified RandomSkewHeap as R--type Key = Int-type Weight = Int--numOfStreams :: Int-numOfStreams = 100--numOfTrials :: Int-numOfTrials = 10000--main :: IO ()-main = do- gen <- create- ws <- uniformRs (1,256) gen numOfStreams- let ks = [1,3..]- xs = zip ks ws- defaultMain [- bgroup "enqueue & dequeue" [- bench "Random Skew Heap" $ whnf enqdeqR xs- , bench "Skew Binomial Heap" $ whnf enqdeqO xs- , bench "Priority Search Queue" $ whnf enqdeqP xs- , bench "Binary Heap" $ nfIO (enqdeqBIO xs)- , bench "Binary Heap STM" $ nfIO (enqdeqB xs)- , bench "Ring of Queues" $ nfIO (enqdeqAIO xs)- , bench "Ring of Queues STM" $ nfIO (enqdeqA xs)- ]- , bgroup "delete" [- bench "Random Skew Heap" $ whnf deleteR xs- , bench "Skew Binomial Heap" $ whnf deleteO xs- , bench "Priority Search Queue" $ whnf deleteP xs- , bench "Binary Heap" $ nfIO (deleteBIO xs)- , bench "Binary Heap STM" $ nfIO (deleteB xs)- , 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)--------------------------------------------------------------------enqdeqR :: [(Key,Weight)] -> ()-enqdeqR xs = loop pq numOfTrials- where- !pq = createR xs R.empty- loop _ 0 = ()- loop q !n = case R.dequeue q of- Nothing -> error "enqdeqR"- Just (k,w,v,q') -> let !q'' = R.enqueue k w v q'- in loop q'' (n - 1)--deleteR :: [(Key,Weight)] -> R.PriorityQueue Int-deleteR xs = foldl' (\q k -> let (_,!q') = R.delete k q in q') pq ks- where- !pq = createR xs R.empty- (ks,_) = unzip xs--createR :: [(Key,Weight)] -> R.PriorityQueue Int -> R.PriorityQueue Int-createR [] !q = q-createR ((k,w):xs) !q = createR xs q'- where- !v = k- !q' = R.enqueue k w v q--------------------------------------------------------------------enqdeqO :: [(Key,Weight)] -> O.PriorityQueue Int-enqdeqO xs = loop pq numOfTrials- where- !pq = createO xs O.empty- loop !q 0 = q- loop !q !n = case O.dequeue q of- Nothing -> error "enqdeqO"- Just (k,p,v,q') -> loop (O.enqueue k p v q') (n - 1)--deleteO :: [(Key,Weight)] -> O.PriorityQueue Int-deleteO xs = foldl' (\q k -> let (_,!q') = O.delete k q in q') pq ks- where- !pq = createO xs O.empty- (ks,_) = unzip xs--createO :: [(Key,Weight)] -> O.PriorityQueue Int -> O.PriorityQueue Int-createO [] !q = q-createO ((k,w):xs) !q = createO xs q'- where- !pre = O.newPrecedence w- !v = k- !q' = O.enqueue k pre v q--------------------------------------------------------------------enqdeqP :: [(Key,Weight)] -> P.PriorityQueue Int-enqdeqP xs = loop pq numOfTrials- where- !pq = createP xs P.empty- loop !q 0 = q- loop !q !n = case P.dequeue q of- Nothing -> error "enqdeqP"- Just (k,pre,x,q') -> loop (P.enqueue k pre x q') (n - 1)--deleteP :: [(Key,Weight)] -> P.PriorityQueue Int-deleteP xs = foldl' (\q k -> let (_,!q') = P.delete k q in q') pq ks- where- !pq = createP xs P.empty- (ks,_) = unzip xs--createP :: [(Key,Weight)] -> P.PriorityQueue Int -> P.PriorityQueue Int-createP [] !q = q-createP ((k,w):xs) !q = createP xs q'- where- !pre = P.newPrecedence w- !v = k- !q' = P.enqueue k pre v q--------------------------------------------------------------------enqdeqB :: [(Key,Weight)] -> IO ()-enqdeqB xs = do- q <- atomically (B.new numOfStreams)- _ <- createB xs q- loop q numOfTrials- where- loop _ 0 = return ()- loop q !n = do- ent <- atomically $ B.dequeue q- atomically $ B.enqueue ent q- loop q (n - 1)--deleteB :: [(Key,Weight)] -> IO ()-deleteB xs = do- q <- atomically $ B.new numOfStreams- ents <- createB xs q- mapM_ (\ent -> atomically $ B.delete ent q) ents--createB :: [(Key,Weight)] -> B.PriorityQueue Int -> IO [B.Entry Key]-createB [] _ = return []-createB ((k,w):xs) !q = do- ent <- atomically $ B.newEntry k w- atomically $ B.enqueue ent q- ents <- createB xs q- return $ ent:ents--------------------------------------------------------------------enqdeqBIO :: [(Key,Weight)] -> IO ()-enqdeqBIO xs = do- q <- BIO.new numOfStreams- _ <- createBIO xs q- loop q numOfTrials- where- loop _ 0 = return ()- loop q !n = do- ent <- BIO.dequeue q- BIO.enqueue ent q- loop q (n - 1)--deleteBIO :: [(Key,Weight)] -> IO ()-deleteBIO xs = do- q <- BIO.new numOfStreams- ents <- createBIO xs q- mapM_ (\ent -> BIO.delete ent q) ents--createBIO :: [(Key,Weight)] -> BIO.PriorityQueue Int -> IO [BIO.Entry Key]-createBIO [] _ = return []-createBIO ((k,w):xs) !q = do- ent <- BIO.newEntry k w- BIO.enqueue ent q- ents <- createBIO xs q- return $ ent:ents--------------------------------------------------------------------enqdeqA :: [(Key,Weight)] -> IO ()-enqdeqA ws = do- q <- atomically A.new- createA ws q- loop q numOfTrials- where- loop _ 0 = return ()- loop q !n = do- ent <- atomically $ A.dequeue q- atomically $ A.enqueue ent q- loop q (n - 1)--createA :: [(Key,Weight)] -> A.PriorityQueue Int -> IO ()-createA [] _ = return ()-createA ((k,w):xs) !q = do- let !ent = A.newEntry k w- atomically $ A.enqueue ent q- createA xs q--------------------------------------------------------------------enqdeqAIO :: [(Key,Weight)] -> IO ()-enqdeqAIO xs = do- q <- AIO.new- _ <- createAIO xs q- loop q numOfTrials- where- loop _ 0 = return ()- loop q !n = do- Just ent <- AIO.dequeue q- _ <- AIO.enqueue ent q- loop q (n - 1)--deleteAIO :: [(Key,Weight)] -> IO ()-deleteAIO xs = do- q <- AIO.new- ns <- createAIO xs q- mapM_ AIO.delete ns--createAIO :: [(Key,Weight)] -> AIO.PriorityQueue Int -> IO [AIO.Node (AIO.Entry Weight)]-createAIO [] _ = return []-createAIO ((k,w):xs) !q = do- let !ent = AIO.newEntry k w- n <- AIO.enqueue ent q- ns <- createAIO xs q- return $ n : ns------------------------------------------------------------------
− bench-priority/RandomSkewHeap.hs
@@ -1,108 +0,0 @@-{-# LANGUAGE BangPatterns #-}---- This data structure is based on skew heap.------ 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 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.------ In the random binary tree,--- an element is selected as the root with probability of--- 1 / (n + 1) where n is the size of the original tree.--- In the random skew heap, an element is selected as the root--- with the probability of weight / total_weight.------ Since this data structure uses random numbers, APIs should be--- essentially impure. But since this is used with STM,--- APIs are made to be pure with unsafePerformIO.--module RandomSkewHeap (- PriorityQueue- , empty- , isEmpty- , enqueue- , dequeue- , delete- ) where--import Data.List (partition)-import System.IO.Unsafe (unsafePerformIO)-import System.Random.MWC (createSystemRandom, uniformR, GenIO)--------------------------------------------------------------------type Key = Int-type Weight = Int--------------------------------------------------------------------data PriorityQueue a = Leaf | Node {-# UNPACK #-} !Weight -- total- {-# UNPACK #-} !Key- {-# UNPACK #-} !Weight- !a- !(PriorityQueue a)- !(PriorityQueue a) deriving Show--------------------------------------------------------------------empty :: PriorityQueue a-empty = Leaf--isEmpty :: PriorityQueue a -> Bool-isEmpty Leaf = True-isEmpty _ = False--singleton :: Key -> Weight -> a -> PriorityQueue a-singleton k w v = Node w k w v Leaf Leaf--------------------------------------------------------------------enqueue :: Key -> Weight -> a -> PriorityQueue a -> PriorityQueue a-enqueue k w v q = merge (singleton k w v) q---- if l is a singleton, w1 == tw1.-merge :: PriorityQueue t -> PriorityQueue t -> PriorityQueue t-merge t Leaf = t-merge Leaf t = t-merge l@(Node tw1 k1 w1 v1 ll lr) r@(Node tw2 k2 w2 v2 rl rr)- | g <= w1 = Node tw k1 w1 v1 lr $ merge ll r- | otherwise = Node tw k2 w2 v2 rr $ merge rl l- where- tw = tw1 + tw2- g = unsafePerformIO $ uniformR (1,tw) gen-{-# NOINLINE merge #-}--dequeue :: PriorityQueue a -> Maybe (Key, Weight, a, PriorityQueue a)-dequeue Leaf = Nothing-dequeue (Node _ k w v l r) = Just (k, w, v, t)- where- !t = merge l r--delete :: Key -> PriorityQueue a -> (Maybe a, PriorityQueue a)-delete k q = (mv, fromList xs')- where- !xs = toList q- (!ds,!xs') = partition (\(k',_,_) -> k' == k) xs- mv = case ds of- [] -> Nothing- ((_,_,v):_) -> Just v--toList :: PriorityQueue a -> [(Key, Weight, a)]-toList q = go q id []- where- go Leaf b = b- go (Node _ k w v l r) b = go r (go l (((k,w,v) :) . b))--fromList :: [(Key, Weight, a)] -> PriorityQueue a-fromList xs = go empty xs- where- go !q [] = q- go !q ((k,w,v):xks) = go (enqueue k w v q) xks--{-# NOINLINE gen #-}-gen :: GenIO-gen = unsafePerformIO createSystemRandom
− bench-priority/RingOfQueues.hs
@@ -1,156 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}---- Haskell implementation of H2O's priority queue.--- https://github.com/h2o/h2o/blob/master/lib/http2/scheduler.c--module RingOfQueues (- Entry- , newEntry- , renewEntry- , item- , Node- , PriorityQueue(..)- , new- , enqueue- , dequeue- , delete- ) where--import Control.Monad (replicateM)-import Data.Array (Array, listArray, (!))-import Data.Bits (setBit, clearBit, shiftR)-import Data.IORef-import Data.Word (Word64)-import Foreign.C.Types (CLLong(..))--import DoublyLinkedQueueIO (Queue, Node)-import qualified DoublyLinkedQueueIO as Q--------------------------------------------------------------------type Weight = Int---- | Abstract data type of entries for priority queues.-data Entry a = Entry {- item :: a -- ^ Extracting an item from an entry.- , weight :: {-# UNPACK #-} !Weight- , deficit :: {-# UNPACK #-} !Int- } deriving Show--newEntry :: a -> Weight -> Entry a-newEntry x w = Entry x w 0---- | Changing the item of an entry.-renewEntry :: Entry a -> b -> Entry b-renewEntry ent x = ent { item = x }--------------------------------------------------------------------data PriorityQueue a = PriorityQueue {- bitsRef :: IORef Word64- , offsetRef :: IORef Int- , queues :: Array Int (Queue (Entry a))- }--------------------------------------------------------------------bitWidth :: Int-bitWidth = 64--relativeIndex :: Int -> Int -> Int-relativeIndex idx offset = (offset + idx) `mod` bitWidth--------------------------------------------------------------------deficitSteps :: Int-deficitSteps = 65536--deficitList :: [Int]-deficitList = map calc idxs- where- idxs :: [Double]- idxs = [1..256]- calc w = round (65536 * 63 / w)--deficitTable :: Array Int Int-deficitTable = listArray (1,256) deficitList---------------------------------------------------------------------- https://en.wikipedia.org/wiki/Find_first_set-foreign import ccall unsafe "strings.h ffsll"- c_ffs :: CLLong -> CLLong---- | Finding first bit set. O(1)------ >>> firstBitSet $ setBit 0 63--- 63--- >>> firstBitSet $ setBit 0 62--- 62--- >>> firstBitSet $ setBit 0 1--- 1--- >>> firstBitSet $ setBit 0 0--- 0--- >>> firstBitSet 0--- -1-firstBitSet :: Word64 -> Int-firstBitSet x = ffs x - 1- where- ffs = fromIntegral . c_ffs . fromIntegral--------------------------------------------------------------------new :: IO (PriorityQueue a)-new = PriorityQueue <$> newIORef 0 <*> newIORef 0 <*> newQueues- where- newQueues = listArray (0, bitWidth - 1) <$> replicateM bitWidth Q.new---- | Enqueuing an entry. PriorityQueue is updated.-enqueue :: Entry a -> PriorityQueue a -> IO (Node (Entry a))-enqueue ent PriorityQueue{..} = do- let (!idx,!deficit') = calcIdxAndDeficit- !offidx <- getOffIdx idx- node <- push offidx ent { deficit = deficit' }- updateBits idx- return node- where- calcIdxAndDeficit = total `divMod` deficitSteps- where- total = deficitTable ! weight ent + deficit ent- getOffIdx idx = relativeIndex idx <$> readIORef offsetRef- push offidx ent' = Q.enqueue ent' (queues ! offidx)- updateBits idx = modifyIORef' bitsRef $ flip setBit idx---- | Dequeuing an entry. PriorityQueue is updated.-dequeue :: PriorityQueue a -> IO (Maybe (Entry a))-dequeue pq@PriorityQueue{..} = do- !idx <- getIdx- if idx == -1 then- return Nothing- else do- !offidx <- getOffIdx idx- updateOffset offidx- queueIsEmpty <- checkEmpty offidx- updateBits idx queueIsEmpty- if queueIsEmpty then- dequeue pq- else- Just <$> pop offidx- where- getIdx = firstBitSet <$> readIORef bitsRef- getOffIdx idx = relativeIndex idx <$> readIORef offsetRef- pop offidx = Q.dequeue (queues ! offidx)- checkEmpty offidx = Q.isEmpty (queues ! offidx)- updateOffset offset' = writeIORef offsetRef offset'- updateBits idx isEmpty = modifyIORef' bitsRef shiftClear- where- shiftClear bits- | isEmpty = clearBit (shiftR bits idx) 0- | otherwise = shiftR bits idx---- bits is not updated because it's difficult.-delete :: Node (Entry a) -> IO ()-delete node = Q.delete node
− bench-priority/RingOfQueuesSTM.hs
@@ -1,149 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}---- Haskell implementation of H2O's priority queue.--- https://github.com/h2o/h2o/blob/master/lib/http2/scheduler.c---- delete is not supported because TQueue does not support deletion.--- So, key is not passed to enqueue.--module RingOfQueuesSTM (- Entry- , newEntry- , renewEntry- , item- , PriorityQueue(..)- , new- , enqueue- , dequeue- ) where--import Control.Concurrent.STM-import Control.Monad (replicateM)-import Data.Array (Array, listArray, (!))-import Data.Bits (setBit, clearBit, shiftR)-import Data.Word (Word64)-import Foreign.C.Types (CLLong(..))--------------------------------------------------------------------type Weight = Int---- | Abstract data type of entries for priority queues.-data Entry a = Entry {- item :: a -- ^ Extracting an item from an entry.- , weight :: {-# UNPACK #-} !Weight- , deficit :: {-# UNPACK #-} !Int- } deriving Show--newEntry :: a -> Weight -> Entry a-newEntry x w = Entry x w 0---- | Changing the item of an entry.-renewEntry :: Entry a -> b -> Entry b-renewEntry ent x = ent { item = x }--------------------------------------------------------------------data PriorityQueue a = PriorityQueue {- bitsRef :: TVar Word64- , offsetRef :: TVar Int- , queues :: Array Int (TQueue (Entry a))- }--------------------------------------------------------------------bitWidth :: Int-bitWidth = 64--relativeIndex :: Int -> Int -> Int-relativeIndex idx offset = (offset + idx) `mod` bitWidth--------------------------------------------------------------------deficitSteps :: Int-deficitSteps = 65536--deficitList :: [Int]-deficitList = map calc idxs- where- idxs :: [Double]- idxs = [1..256]- calc w = round (65536 * 63 / w)--deficitTable :: Array Int Int-deficitTable = listArray (1,256) deficitList---------------------------------------------------------------------- https://en.wikipedia.org/wiki/Find_first_set-foreign import ccall unsafe "strings.h ffsll"- c_ffs :: CLLong -> CLLong---- | Finding first bit set. O(1)------ >>> firstBitSet $ setBit 0 63--- 63--- >>> firstBitSet $ setBit 0 62--- 62--- >>> firstBitSet $ setBit 0 1--- 1--- >>> firstBitSet $ setBit 0 0--- 0--- >>> firstBitSet 0--- -1-firstBitSet :: Word64 -> Int-firstBitSet x = ffs x - 1- where- ffs = fromIntegral . c_ffs . fromIntegral--------------------------------------------------------------------new :: STM (PriorityQueue a)-new = PriorityQueue <$> newTVar 0 <*> newTVar 0 <*> newQueues- where- newQueues = listArray (0, bitWidth - 1) <$> replicateM bitWidth newTQueue---- | Enqueuing an entry. PriorityQueue is updated.-enqueue :: Entry a -> PriorityQueue a -> STM ()-enqueue ent PriorityQueue{..} = do- let (!idx,!deficit') = calcIdxAndDeficit- !offidx <- getOffIdx idx- push offidx ent { deficit = deficit' }- updateBits idx- where- calcIdxAndDeficit = total `divMod` deficitSteps- where- total = deficitTable ! weight ent + deficit ent- getOffIdx idx = relativeIndex idx <$> readTVar offsetRef- push offidx ent' = writeTQueue (queues ! offidx) ent'- updateBits idx = modifyTVar' bitsRef $ flip setBit idx---- | Dequeuing an entry. PriorityQueue is updated.-dequeue :: PriorityQueue a -> STM (Entry a)-dequeue pq@PriorityQueue{..} = do- !idx <- getIdx- if idx == -1 then- retry- else do- !offidx <- getOffIdx idx- updateOffset offidx- queueIsEmpty <- checkEmpty offidx- updateBits idx queueIsEmpty- if queueIsEmpty then- dequeue pq- else- pop offidx- where- getIdx = firstBitSet <$> readTVar bitsRef- getOffIdx idx = relativeIndex idx <$> readTVar offsetRef- pop offidx = readTQueue (queues ! offidx)- checkEmpty offidx = isEmptyTQueue (queues ! offidx)- updateOffset offset' = writeTVar offsetRef offset'- updateBits idx isEmpty = modifyTVar' bitsRef shiftClear- where- shiftClear bits- | isEmpty = clearBit (shiftR bits idx) 0- | otherwise = shiftR bits idx
http2.cabal view
@@ -1,430 +1,428 @@-Name: http2-Version: 3.0.3-Author: Kazu Yamamoto <kazu@iij.ad.jp>-Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>-License: BSD3-License-File: LICENSE-Synopsis: HTTP/2 library-Description: HTTP/2 library including frames, priority queues, HPACK, client and server.-Homepage: https://github.com/kazu-yamamoto/http2-Category: Network-Cabal-Version: >= 1.10-Build-Type: Simple-Extra-Source-Files: ChangeLog.md- test/inputFile- test-hpack/hpack-test-case/go-hpack/*.json- test-hpack/hpack-test-case/haskell-http2-linear/*.json- test-hpack/hpack-test-case/haskell-http2-linear-huffman/*.json- test-hpack/hpack-test-case/haskell-http2-naive/*.json- test-hpack/hpack-test-case/haskell-http2-naive-huffman/*.json- test-hpack/hpack-test-case/haskell-http2-static/*.json- test-hpack/hpack-test-case/haskell-http2-static-huffman/*.json- test-hpack/hpack-test-case/nghttp2/*.json- test-hpack/hpack-test-case/nghttp2-16384-4096/*.json- test-hpack/hpack-test-case/nghttp2-change-table-size/*.json- test-hpack/hpack-test-case/node-http2-hpack/*.json- test-frame/http2-frame-test-case/continuation/*.json- test-frame/http2-frame-test-case/data/*.json- test-frame/http2-frame-test-case/error/*.json- test-frame/http2-frame-test-case/goaway/*.json- test-frame/http2-frame-test-case/headers/*.json- test-frame/http2-frame-test-case/ping/*.json- test-frame/http2-frame-test-case/priority/*.json- test-frame/http2-frame-test-case/push_promise/*.json- test-frame/http2-frame-test-case/rst_stream/*.json- test-frame/http2-frame-test-case/settings/*.json- test-frame/http2-frame-test-case/window_update/*.json- bench-hpack/headers.hs+cabal-version: >=1.10+name: http2+version: 4.0.0+license: BSD3+license-file: LICENSE+maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+author: Kazu Yamamoto <kazu@iij.ad.jp>+homepage: https://github.com/kazu-yamamoto/http2+synopsis: HTTP/2 library+description:+ HTTP/2 library including frames, priority queues, HPACK, client and server. -----------------------------------------------------------------+category: Network+build-type: Simple+extra-source-files:+ ChangeLog.md+ test/inputFile+ test-hpack/hpack-test-case/go-hpack/*.json+ test-hpack/hpack-test-case/haskell-http2-linear/*.json+ test-hpack/hpack-test-case/haskell-http2-linear-huffman/*.json+ test-hpack/hpack-test-case/haskell-http2-naive/*.json+ test-hpack/hpack-test-case/haskell-http2-naive-huffman/*.json+ test-hpack/hpack-test-case/haskell-http2-static/*.json+ test-hpack/hpack-test-case/haskell-http2-static-huffman/*.json+ test-hpack/hpack-test-case/nghttp2/*.json+ test-hpack/hpack-test-case/nghttp2-16384-4096/*.json+ test-hpack/hpack-test-case/nghttp2-change-table-size/*.json+ test-hpack/hpack-test-case/node-http2-hpack/*.json+ test-frame/http2-frame-test-case/continuation/*.json+ test-frame/http2-frame-test-case/data/*.json+ test-frame/http2-frame-test-case/error/*.json+ test-frame/http2-frame-test-case/goaway/*.json+ test-frame/http2-frame-test-case/headers/*.json+ test-frame/http2-frame-test-case/ping/*.json+ test-frame/http2-frame-test-case/priority/*.json+ test-frame/http2-frame-test-case/push_promise/*.json+ test-frame/http2-frame-test-case/rst_stream/*.json+ test-frame/http2-frame-test-case/settings/*.json+ test-frame/http2-frame-test-case/window_update/*.json+ bench-hpack/headers.hs -Source-Repository head- Type: git- Location: git://github.com/kazu-yamamoto/http2+source-repository head+ type: git+ location: git://github.com/kazu-yamamoto/http2 -Flag devel- Description: Development commands- Default: False+flag devel+ description: Development commands+ default: False -Flag h2spec- Description: Development commands- Default: False+flag h2spec+ description: Development commands+ default: False -Flag doc- Description: Doctest- Default: False+flag doc+ description: Doctest+ default: False -----------------------------------------------------------------+library+ exposed-modules:+ Network.HPACK+ Network.HPACK.Internal+ Network.HPACK.Table+ Network.HPACK.Token+ Network.HTTP2.Client+ Network.HTTP2.Client.Internal+ Network.HTTP2.Frame+ Network.HTTP2.Internal+ Network.HTTP2.Server+ Network.HTTP2.Server.Internal -Library- Default-Language: Haskell2010- GHC-Options: -Wall- Exposed-Modules: Network.HPACK- Network.HPACK.Internal- Network.HPACK.Table- Network.HPACK.Token- Network.HTTP2- Network.HTTP2.Client- Network.HTTP2.Client.Internal- Network.HTTP2.Frame- Network.HTTP2.Internal- Network.HTTP2.Priority- Network.HTTP2.Priority.Internal- Network.HTTP2.Server- Network.HTTP2.Server.Internal- Other-Modules: Imports- Network.HPACK.Builder- Network.HTTP2.Client.Types- Network.HTTP2.Client.Run- Network.HPACK.HeaderBlock- Network.HPACK.HeaderBlock.Decode- Network.HPACK.HeaderBlock.Encode- Network.HPACK.HeaderBlock.Integer- Network.HPACK.Huffman- Network.HPACK.Huffman.Bit- Network.HPACK.Huffman.ByteString- Network.HPACK.Huffman.Decode- Network.HPACK.Huffman.Encode- Network.HPACK.Huffman.Params- Network.HPACK.Huffman.Table- Network.HPACK.Huffman.Tree- Network.HPACK.Table.Dynamic- Network.HPACK.Table.Entry- Network.HPACK.Table.RevIndex- Network.HPACK.Table.Static- Network.HPACK.Types- Network.HTTP2.Arch- Network.HTTP2.Arch.Cache- Network.HTTP2.Arch.Config- Network.HTTP2.Arch.Context- Network.HTTP2.Arch.EncodeFrame- Network.HTTP2.Arch.File- Network.HTTP2.Arch.HPACK- Network.HTTP2.Arch.Manager- Network.HTTP2.Arch.Queue- Network.HTTP2.Arch.Rate- Network.HTTP2.Arch.ReadN- Network.HTTP2.Arch.Receiver- Network.HTTP2.Arch.Sender- Network.HTTP2.Arch.Status- Network.HTTP2.Arch.Stream- Network.HTTP2.Arch.Types- Network.HTTP2.Frame.Decode- Network.HTTP2.Frame.Encode- Network.HTTP2.Frame.Types- Network.HTTP2.Priority.PSQ- Network.HTTP2.Priority.Queue- Network.HTTP2.Server.Run- Network.HTTP2.Server.Types- Network.HTTP2.Server.Worker- Build-Depends: base >= 4.9 && < 5- , array- , async- , bytestring >= 0.10- , case-insensitive- , containers >= 0.5- , http-types- , network- , network-byte-order >= 0.1.5- , psqueues- , stm- , time-manager- , unix-time- Default-Extensions: Strict StrictData+ other-modules:+ Imports+ Network.HPACK.Builder+ Network.HTTP2.Client.Types+ Network.HTTP2.Client.Run+ Network.HPACK.HeaderBlock+ Network.HPACK.HeaderBlock.Decode+ Network.HPACK.HeaderBlock.Encode+ Network.HPACK.HeaderBlock.Integer+ Network.HPACK.Huffman+ Network.HPACK.Huffman.Bit+ Network.HPACK.Huffman.ByteString+ Network.HPACK.Huffman.Decode+ Network.HPACK.Huffman.Encode+ Network.HPACK.Huffman.Params+ Network.HPACK.Huffman.Table+ Network.HPACK.Huffman.Tree+ Network.HPACK.Table.Dynamic+ Network.HPACK.Table.Entry+ Network.HPACK.Table.RevIndex+ Network.HPACK.Table.Static+ Network.HPACK.Types+ Network.HTTP2.Arch+ Network.HTTP2.Arch.Cache+ Network.HTTP2.Arch.Config+ Network.HTTP2.Arch.Context+ Network.HTTP2.Arch.EncodeFrame+ Network.HTTP2.Arch.File+ Network.HTTP2.Arch.HPACK+ Network.HTTP2.Arch.Manager+ Network.HTTP2.Arch.Queue+ Network.HTTP2.Arch.Rate+ Network.HTTP2.Arch.ReadN+ Network.HTTP2.Arch.Receiver+ Network.HTTP2.Arch.Sender+ Network.HTTP2.Arch.Status+ Network.HTTP2.Arch.Stream+ Network.HTTP2.Arch.Types+ Network.HTTP2.Frame.Decode+ Network.HTTP2.Frame.Encode+ Network.HTTP2.Frame.Types+ Network.HTTP2.Server.Run+ Network.HTTP2.Server.Types+ Network.HTTP2.Server.Worker -----------------------------------------------------------------+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ array,+ async,+ bytestring >=0.10,+ case-insensitive,+ containers >=0.5,+ http-types,+ network,+ network-byte-order >=0.1.5,+ psqueues,+ stm,+ time-manager,+ unix-time,+ unliftio -Test-Suite doctest- if flag(doc)- Buildable: True- else- Buildable: False- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- HS-Source-Dirs: test- Ghc-Options: -Wall- Main-Is: doctests.hs- Build-Depends: base >= 4.9 && < 5- , doctest >= 0.9.3- Default-Extensions: Strict StrictData+executable client+ main-is: client.hs+ hs-source-dirs: util+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall -threaded+ build-depends:+ base >=4.9 && <5,+ async,+ bytestring,+ http-types,+ http2,+ network-run -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.EncodeSpec- HPACK.HeaderBlock- HPACK.HuffmanSpec- HPACK.IntegerSpec- HTTP2.FrameSpec- HTTP2.PrioritySpec- HTTP2.ServerSpec- Build-Depends: base >= 4.9 && < 5- , async- , base16-bytestring >= 1.0- , bytestring- , cryptonite- , hspec >= 1.3- , http-types- , http2- , network- , network-run >= 0.1.0- , typed-process- Default-Extensions: Strict StrictData- Build-Tool-Depends: hspec-discover:hspec-discover+ if flag(devel) + else+ buildable: False -Test-Suite spec2- if flag(h2spec)- Buildable: True- else- Buildable: False- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- HS-Source-Dirs: test2- Ghc-Options: -Wall- Main-Is: Spec.hs- Other-Modules: ServerSpec- Build-Depends: base >= 4.9 && < 5- , bytestring- , hspec >= 1.3- , http-types- , http2- , network-run >= 0.1.0- , typed-process- Default-Extensions: Strict StrictData- Build-Tool-Depends: hspec-discover:hspec-discover+executable server+ main-is: server.hs+ hs-source-dirs: util+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall -threaded+ build-depends:+ base >=4.9 && <5,+ bytestring,+ cryptonite,+ http2,+ http-types,+ network-run -Test-Suite hpack- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- HS-Source-Dirs: test-hpack- Ghc-Options: -Wall- Main-Is: Spec.hs- Other-Modules: HPACKDecode- HPACKSpec- JSON- Build-Depends: base >= 4.9 && < 5- , aeson >= 2- , base16-bytestring >= 1.0- , bytestring- , directory- , filepath- , hspec >= 1.3- , http2- , text- , unordered-containers- , vector- Default-Extensions: Strict StrictData- Build-Tool-Depends: hspec-discover:hspec-discover+ if flag(devel) -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- FrameSpec- JSON- Build-Depends: base >= 4.9 && < 5- , Glob >= 0.9- , aeson >= 2- , aeson-pretty- , base16-bytestring >= 1.0- , bytestring- , directory- , filepath- , hspec >= 1.3- , http2- , network-byte-order- , text- , unordered-containers- Default-Extensions: Strict StrictData- Build-Tool-Depends: hspec-discover:hspec-discover+ else+ buildable: False -----------------------------------------------------------------+executable hpack-encode+ main-is: hpack-encode.hs+ hs-source-dirs: test-hpack+ other-modules:+ HPACKEncode+ JSON -Executable client- Default-Language: Haskell2010- HS-Source-Dirs: util- GHC-Options: -Wall -threaded- if flag(devel)- Buildable: True- else- Buildable: False- Main-Is: client.hs- Build-Depends: base >= 4.9 && < 5- , bytestring- , http-types- , http2- , network-run- Default-Extensions: Strict StrictData+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ aeson >=2,+ aeson-pretty,+ array,+ base16-bytestring >=1.0,+ bytestring,+ case-insensitive,+ containers,+ http2,+ network-byte-order,+ text,+ unordered-containers,+ vector,+ word8 -Executable server- Default-Language: Haskell2010- HS-Source-Dirs: util- GHC-Options: -Wall -threaded- if flag(devel)- Buildable: True- else- Buildable: False- Main-Is: server.hs- Build-Depends: base >= 4.9 && < 5- , bytestring- , cryptonite- , http2- , http-types- , network-run- Default-Extensions: Strict StrictData+ if flag(devel) -----------------------------------------------------------------+ else+ buildable: False -Executable hpack-encode- Default-Language: Haskell2010- HS-Source-Dirs: test-hpack- GHC-Options: -Wall- if flag(devel)- Buildable: True- else- Buildable: False- Main-Is: hpack-encode.hs- Other-Modules: HPACKEncode- JSON- Build-Depends: base >= 4.9 && < 5- , aeson >= 2- , aeson-pretty- , array- , base16-bytestring >= 1.0- , bytestring- , case-insensitive- , containers- , http2- , network-byte-order- , text- , unordered-containers- , vector- , word8- Default-Extensions: Strict StrictData+executable hpack-debug+ main-is: hpack-debug.hs+ hs-source-dirs: test-hpack+ other-modules:+ HPACKDecode+ JSON -Executable hpack-debug- Default-Language: Haskell2010- HS-Source-Dirs: test-hpack- GHC-Options: -Wall- if flag(devel)- Buildable: True- else- Buildable: False- Main-Is: hpack-debug.hs- Other-Modules: HPACKDecode- JSON- Build-Depends: base >= 4.9 && < 5- , aeson >= 2- , array- , base16-bytestring >= 1.0- , bytestring- , case-insensitive- , containers- , http2- , network-byte-order- , text- , unordered-containers- , vector- , word8- Default-Extensions: Strict StrictData+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ aeson >=2,+ array,+ base16-bytestring >=1.0,+ bytestring,+ case-insensitive,+ containers,+ http2,+ network-byte-order,+ text,+ unordered-containers,+ vector,+ word8 -Executable hpack-stat- Default-Language: Haskell2010- HS-Source-Dirs: test-hpack- GHC-Options: -Wall- if flag(devel)- Buildable: True- else- Buildable: False- Main-Is: hpack-stat.hs- Other-Modules: JSON- Build-Depends: base >= 4.9 && < 5- , aeson >= 2- , aeson-pretty- , array- , bytestring- , case-insensitive- , containers- , directory- , filepath- , http2- , network-byte-order- , text- , unordered-containers- , vector- , word8- Default-Extensions: Strict StrictData+ if flag(devel) -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.9 && < 5- , aeson >= 2- , aeson-pretty- , base16-bytestring >= 1.0- , bytestring- , http2- , text- , unordered-containers- Default-Extensions: Strict StrictData+ else+ buildable: False -----------------------------------------------------------------+executable hpack-stat+ main-is: hpack-stat.hs+ hs-source-dirs: test-hpack+ other-modules: JSON+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ aeson >=2,+ aeson-pretty,+ array,+ bytestring,+ case-insensitive,+ containers,+ directory,+ filepath,+ http2,+ network-byte-order,+ text,+ unordered-containers,+ vector,+ word8 -Benchmark priority- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- Hs-Source-Dirs: bench-priority, .- Ghc-Options: -Wall- Main-Is: Main.hs- Other-Modules: BinaryHeap- BinaryHeapSTM- DoublyLinkedQueueIO- Heap- RandomSkewHeap- RingOfQueues- RingOfQueuesSTM- Network.HTTP2.Priority.PSQ- Build-Depends: base >= 4.9 && < 5- , array- , case-insensitive- , containers- , gauge- , heaps- , mwc-random- , network-byte-order- , psqueues- , stm- Default-Extensions: Strict StrictData+ if flag(devel) -Benchmark header-compression- Type: exitcode-stdio-1.0- Default-Language: Haskell2010- Hs-Source-Dirs: bench-hpack- Ghc-Options: -Wall- Main-Is: Main.hs- Build-Depends: base- , array- , bytestring- , case-insensitive- , containers- , gauge- , network-byte-order- , stm- , http2- Default-Extensions: Strict StrictData+ else+ buildable: False++executable frame-encode+ main-is: frame-encode.hs+ hs-source-dirs: test-frame+ other-modules:+ Case+ JSON++ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ aeson >=2,+ aeson-pretty,+ base16-bytestring >=1.0,+ bytestring,+ http2,+ text,+ unordered-containers++ if flag(devel)++ else+ buildable: False++test-suite doctest+ type: exitcode-stdio-1.0+ main-is: doctests.hs+ hs-source-dirs: test+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ doctest >=0.9.3++ if flag(doc)++ else+ buildable: False++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test+ other-modules:+ HTTP2.ClientSpec+ HPACK.DecodeSpec+ HPACK.EncodeSpec+ HPACK.HeaderBlock+ HPACK.HuffmanSpec+ HPACK.IntegerSpec+ HTTP2.FrameSpec+ HTTP2.ServerSpec++ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ async,+ base16-bytestring >=1.0,+ bytestring,+ cryptonite,+ hspec >=1.3,+ http-types,+ http2,+ network,+ network-run >=0.1.0,+ typed-process++test-suite spec2+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test2+ other-modules: ServerSpec+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ bytestring,+ hspec >=1.3,+ http-types,+ http2,+ network-run >=0.1.0,+ typed-process++ if flag(h2spec)++ else+ buildable: False++test-suite hpack+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test-hpack+ other-modules:+ HPACKDecode+ HPACKSpec+ JSON++ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ aeson >=2,+ base16-bytestring >=1.0,+ bytestring,+ directory,+ filepath,+ hspec >=1.3,+ http2,+ text,+ unordered-containers,+ vector++test-suite frame+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test-frame+ other-modules:+ Case+ FrameSpec+ JSON++ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <5,+ Glob >=0.9,+ aeson >=2,+ aeson-pretty,+ base16-bytestring >=1.0,+ bytestring,+ directory,+ filepath,+ hspec >=1.3,+ http2,+ network-byte-order,+ text,+ unordered-containers++benchmark header-compression+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench-hpack+ default-language: Haskell2010+ default-extensions: Strict StrictData+ ghc-options: -Wall+ build-depends:+ base,+ array,+ bytestring,+ case-insensitive,+ containers,+ gauge,+ network-byte-order,+ stm,+ http2
test-frame/Case.hs view
@@ -21,7 +21,7 @@ wire_description :: String , wire_hex :: ByteString , wire_padding :: Maybe Pad- , wire_error :: Maybe [ErrorCodeId]+ , wire_error :: Maybe [ErrorCode] } deriving (Show,Read) sourceToWire :: CaseSource -> CaseWire@@ -51,5 +51,5 @@ description = wire_description , wire = wire_hex , frame = Nothing- , err = Just $ fromErrorCodeId <$> e+ , err = Just e }
test-frame/FrameSpec.hs view
@@ -31,12 +31,13 @@ let bin = B16.decodeLenient $ wire tc erc = decodeFrame defaultSettings bin case erc of- Left h2err -> case err tc of+ Left fderr -> case err tc of Nothing -> do putStrLn file -- fixme- print h2err+ print fderr Just errs -> do- let e = fromErrorCodeId $ errorCodeId h2err+ let e = case fderr of+ FrameDecodeError x _ _ -> x errs `shouldContain` [e] Right frm -> do case frame tc of
test-frame/JSON.hs view
@@ -66,17 +66,23 @@ parseJSON x = StreamIdentifier <$> parseJSON x -} -instance ToJSON ErrorCodeId where- toJSON e = toJSON $ fromErrorCodeId e+instance ToJSON ErrorCode where+ toJSON e = toJSON $ fromErrorCode e -instance FromJSON ErrorCodeId where- parseJSON e = toErrorCodeId <$> parseJSON e+instance FromJSON ErrorCode where+ parseJSON e = toErrorCode <$> parseJSON e +instance ToJSON FrameType where+ toJSON e = toJSON $ fromFrameType e++instance FromJSON FrameType where+ parseJSON e = toFrameType <$> parseJSON e+ instance {-# OVERLAPPING #-} ToJSON SettingsList where- toJSON settings = toJSON $ map (first fromSettingsKeyId) settings+ toJSON settings = toJSON $ map (first fromSettingsKey) settings instance {-# OVERLAPPING #-} FromJSON SettingsList where- parseJSON x = map (first (fromJust . toSettingsKeyId)) <$> parseJSON x+ parseJSON x = map (first toSettingsKey) <$> parseJSON x instance ToJSON ByteString where toJSON bs = toJSON $ byteStringToText bs@@ -134,10 +140,10 @@ instance ToJSON FramePad where toJSON FramePad{fpFrame = Frame{..},..} = object [ "length" .= payloadLength frameHeader- , "type" .= fromFrameTypeId (framePayloadToFrameTypeId framePayload)- , "flags" .= flags frameHeader+ , "type" .= framePayloadToFrameType framePayload+ , "flags" .= flags frameHeader , "stream_identifier" .= streamId frameHeader- , "frame_payload" .= (toJSON framePayload +++ padObj)+ , "frame_payload" .= (toJSON framePayload +++ padObj) ] where padObj = case toJSON fpPad of@@ -166,10 +172,8 @@ parsePayloadPad :: FrameType -> Object -> Parser (FramePayload, Maybe Pad) parsePayloadPad ftyp o = do mpad <- (Pad <$>) <$> o .:? "padding"- payload <- parsePayload ftid o+ payload <- parsePayload ftyp o return (payload, mpad)- where- ftid = toFrameTypeId ftyp priority :: Object -> Parser Priority priority o = Priority <$> o .: "exclusive"@@ -185,7 +189,7 @@ Nothing -> Nothing Just ex -> Just $ Priority ex (fromJust ms) (fromJust mw) -parsePayload :: FrameTypeId -> Object -> Parser FramePayload+parsePayload :: FrameType -> Object -> Parser FramePayload parsePayload FrameData o = DataFrame <$> o .: "data" parsePayload FrameHeaders o = do mpri <- mpriority o@@ -202,7 +206,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"+parsePayload ftyp o = UnknownFrame ftyp <$> o .: "dummy" instance ToJSON Pad where toJSON (Pad padding) = object [
test/HPACK/IntegerSpec.hs view
@@ -1,6 +1,7 @@ module HPACK.IntegerSpec where import qualified Data.ByteString as BS+import Data.Maybe (fromMaybe) import Network.HPACK.Internal import Test.Hspec import Test.Hspec.QuickCheck@@ -9,7 +10,7 @@ dual n i = do let x = abs i bs <- encodeInteger n x- let Just (w, ws) = BS.uncons bs+ let (w, ws) = fromMaybe (error "dual") $ BS.uncons bs x' <- decodeInteger n w ws x `shouldBe` x'
+ test/HTTP2/ClientSpec.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-}++module HTTP2.ClientSpec where++import Control.Concurrent+import qualified Control.Exception as E+import Data.ByteString (ByteString)+import Data.ByteString.Builder (byteString)+import qualified Data.ByteString.Char8 as C8+import Network.HTTP.Types+import Network.Run.TCP+import Test.Hspec++import Network.HTTP2.Client+import qualified Network.HTTP2.Server as S++port :: String+port = "8080"++host :: String+host = "127.0.0.1"++host' :: ByteString+host' = C8.pack host++spec :: Spec+spec = do+ describe "server" $ do+ it "receives an error if scheme is missing" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runClient "" host' [] `shouldThrow` streamError++ it "receives an error if authority is missing" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runClient "http" "" [] `shouldThrow` streamError++ it "receives an error if authority and host are different" $+ E.bracket (forkIO runServer) killThread $ \_ -> do+ threadDelay 10000+ runClient "http" host' [("Host","foo")] `shouldThrow` streamError++runServer :: IO ()+runServer = runTCPServer (Just host) port runHTTP2Server+ where+ runHTTP2Server s = E.bracket (allocSimpleConfig s 4096)+ freeSimpleConfig+ (`S.run` server)+server :: S.Server+server _req _aux sendResponse = sendResponse responseHello []++responseHello :: S.Response+responseHello = S.responseBuilder ok200 header body+ where+ header = [("Content-Type", "text/plain")]+ body = byteString "Hello, world!\n"++runClient :: Scheme -> Authority -> RequestHeaders -> IO ()+runClient sc au hd = runTCPClient host port $ runHTTP2Client+ where+ cliconf = ClientConfig sc au 20+ runHTTP2Client s = E.bracket (allocSimpleConfig s 4096)+ freeSimpleConfig+ (\conf -> run cliconf conf client)+ client sendRequest = do+ let req = requestNoBody methodGet "/" hd+ sendRequest req $ \rsp -> do+ responseStatus rsp `shouldBe` Just ok200+ fmap statusMessage (responseStatus rsp) `shouldBe` Just "OK"++streamError :: Selector HTTP2Error+streamError (StreamErrorIsReceived _ _) = True+streamError _ = False
test/HTTP2/FrameSpec.hs view
@@ -5,6 +5,7 @@ import Test.Hspec import Data.ByteString.Char8 ()+import Data.Either import Network.HTTP2.Frame spec :: Spec@@ -29,7 +30,7 @@ } payload = DataFrame "Hello, world!" wire = encodeFrame einfo payload- Right frame = decodeFrame defaultSettings wire+ frame = fromRight (error "encode/decodes frames properly") $ decodeFrame defaultSettings wire payload' = framePayload frame payload' `shouldBe` payload it "encode/decodes padded frames properly" $ do@@ -40,6 +41,6 @@ } payload = DataFrame "Hello, world!" wire = encodeFrame einfo payload- Right frame = decodeFrame defaultSettings wire+ frame = fromRight (error "encode/decodes padded frames properly") $ decodeFrame defaultSettings wire payload' = framePayload frame payload' `shouldBe` payload
− test/HTTP2/PrioritySpec.hs
@@ -1,109 +0,0 @@-{-# LANGUAGE BangPatterns, CPP #-}-{-# OPTIONS_GHC -Wno-deprecations #-}--module HTTP2.PrioritySpec where--#if __GLASGOW_HASKELL__ < 709-import Control.Applicative-#endif-import Data.List (group, sort)-import Test.Hspec--import Network.HTTP2.Frame-import Network.HTTP2.Priority-import qualified Network.HTTP2.Priority.Internal as P--spec :: Spec-spec = do- describe "priority tree" $ do- it "enqueue and dequeue frames from Firefox properly" $ firefox- describe "base priority queue" $ do- it "queues entries based on weight" $ do- let q = P.enqueue 5 (P.newPrecedence 1) 5 $- P.enqueue 3 (P.newPrecedence 101) 3 $- P.enqueue 1 (P.newPrecedence 201) 1 P.empty- xs = enqdeq q 1000- map length (group (sort xs)) `shouldBe` [664,333,3]- it "deletes properly" $ do- let q = P.enqueue 7 (P.newPrecedence 1) 7 $- P.enqueue 5 (P.newPrecedence 5) 5 $- P.enqueue 3 (P.newPrecedence 50) 3 $- P.enqueue 1 (P.newPrecedence 201) (1 :: Int) P.empty- let Just (k1,_,_,q1) = P.dequeue q- k1 `shouldBe` 1- let (mk, q2) = P.delete 5 q1- mk `shouldBe` Just 5- let Just (k3,_,_,q3) = P.dequeue q2- k3 `shouldBe` 3- let Just (k4,_,_,_) = P.dequeue q3- k4 `shouldBe` 7- it "deletes entries properly" $ do- let q = P.enqueue 5 (P.newPrecedence 1) 5 $- P.enqueue 3 (P.newPrecedence 101) 3 $- P.enqueue 1 (P.newPrecedence 201) 1 P.empty- (mv1,q1) = P.delete 1 q- (mv2,q2) = P.delete 3 q- P.baseDeficit q `shouldBe` 0- mv1 `shouldBe` Just (1 :: Int)- P.baseDeficit q1 `shouldBe` 326- mv2 `shouldBe` Just 3- P.baseDeficit q2 `shouldBe` 0--firefox :: IO ()-firefox = do- pt <- newPriorityTree :: IO (PriorityTree Int)- prepare pt 3 (pri 0 201)- prepare pt 5 (pri 0 101)- prepare pt 7 (pri 0 1)- prepare pt 9 (pri 7 1)- prepare pt 11 (pri 3 1)- enQ pt 13 (pre 11 32)- deQ pt `shouldReturn` 13- enQ pt 15 (pre 3 32)- enQ pt 17 (pre 3 32)- enQ pt 19 (pre 3 32)- enQ pt 21 (pre 3 32)- enQ pt 23 (pre 3 32)- enQ pt 25 (pre 3 32)- enQ pt 27 (pre 11 22)- enQ pt 29 (pre 11 22)- enQ pt 31 (pre 11 22)- enQ pt 33 (pre 5 32)- enQ pt 35 (pre 5 32)- enQ pt 37 (pre 5 32)- deQ pt `shouldReturn` 15- deQ pt `shouldReturn` 33- deQ pt `shouldReturn` 17- delete pt 17 (pre 3 32) `shouldReturn` Nothing- delete pt 31 (pre 11 22) `shouldReturn` Just 31- deQ pt `shouldReturn` 19- deQ pt `shouldReturn` 35- deQ pt `shouldReturn` 21- deQ pt `shouldReturn` 23- deQ pt `shouldReturn` 37- deQ pt `shouldReturn` 25- deQ pt `shouldReturn` 27- deQ pt `shouldReturn` 29- enQ pt 39 (pre 3 32)- deQ pt `shouldReturn` 39--enQ :: PriorityTree Int -> StreamId -> Precedence -> IO ()-enQ pt sid p = enqueue pt sid p sid--deQ :: PriorityTree Int- -> IO StreamId-deQ pt = (\(x,_,_) -> x) <$> dequeue pt--pri :: StreamId -> Weight -> Priority-pri dep w = Priority False dep w--pre :: StreamId -> Weight -> Precedence-pre dep w = toPrecedence $ pri dep w--enqdeq :: P.PriorityQueue Int -> Int -> [Int]-enqdeq pq num = loop pq num []- where- loop _ 0 ks = ks- loop !q !n ks = case P.dequeue q of- Nothing -> error "enqdeq"- Just (k,p,v,q') -> loop (P.enqueue k p v q') (n - 1) (k:ks)
test/HTTP2/ServerSpec.hs view
@@ -47,7 +47,7 @@ preface <- takeMVar prefaceVar preface `shouldBe` connectionPreface -ignoreHTTP2Error :: HTTP2Error -> IO ()+ignoreHTTP2Error :: C.HTTP2Error -> IO () ignoreHTTP2Error _ = pure () runServer :: IO ()
test/doctests.hs view
@@ -10,5 +10,5 @@ ] doctest [ "-XOverloadedStrings"- , "Network/HTTP2.hs"+ , "Network/HTTP2/Frame.hs" ]
util/client.hs view
@@ -1,35 +1,35 @@ {-# LANGUAGE OverloadedStrings #-}+ module Main where -import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.Async import qualified Control.Exception as E-import Control.Monad import qualified Data.ByteString.Char8 as C8 import Network.HTTP.Types-import Network.HTTP2.Client import Network.Run.TCP (runTCPClient) -- network-run-import System.Environment-import System.Exit +import Network.HTTP2.Client++serverName :: String+serverName = "127.0.0.1"+ main :: IO ()-main = do- args <- getArgs- when (length args /= 2) $ do- putStrLn "client <addr> <port>"- exitFailure- let [host,port] = args- runTCPClient host port $ runHTTP2Client host+main = runTCPClient serverName "80" $ runHTTP2Client serverName where cliconf host = ClientConfig "http" (C8.pack host) 20 runHTTP2Client host s = E.bracket (allocSimpleConfig s 4096) freeSimpleConfig (\conf -> run (cliconf host) conf client) client sendRequest = do- let req = requestNoBody methodGet "/" []- _ <- forkIO $ sendRequest req $ \rsp -> do- print rsp- getResponseBodyChunk rsp >>= C8.putStrLn- sendRequest req $ \rsp -> do- threadDelay 100000- print rsp- getResponseBodyChunk rsp >>= C8.putStrLn+ let req0 = requestNoBody methodGet "/" []+ client0 = sendRequest req0 $ \rsp -> do+ print rsp+ getResponseBodyChunk rsp >>= C8.putStrLn+ req1 = requestNoBody methodGet "/foo" []+ client1 = sendRequest req1 $ \rsp -> do+ print rsp+ getResponseBodyChunk rsp >>= C8.putStrLn+ ex <- E.try $ concurrently_ client0 client1+ case ex of+ Left e -> print (e :: HTTP2Error)+ Right () -> putStrLn "OK"