diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Imports.hs b/Imports.hs --- a/Imports.hs +++ b/Imports.hs @@ -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 diff --git a/Network/HPACK/HeaderBlock/Decode.hs b/Network/HPACK/HeaderBlock/Decode.hs --- a/Network/HPACK/HeaderBlock/Decode.hs +++ b/Network/HPACK/HeaderBlock/Decode.hs @@ -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'. diff --git a/Network/HPACK/Table/Dynamic.hs b/Network/HPACK/Table/Dynamic.hs --- a/Network/HPACK/Table/Dynamic.hs +++ b/Network/HPACK/Table/Dynamic.hs @@ -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 diff --git a/Network/HTTP2.hs b/Network/HTTP2.hs deleted file mode 100644 --- a/Network/HTTP2.hs +++ /dev/null @@ -1,7 +0,0 @@ --- | Framing in HTTP\/2(). -module Network.HTTP2 {-# DEPRECATED "Use Network.HTTP2.Frame instead" #-} - ( - module Network.HTTP2.Frame - ) where - -import Network.HTTP2.Frame diff --git a/Network/HTTP2/Arch/Context.hs b/Network/HTTP2/Arch/Context.hs --- a/Network/HTTP2/Arch/Context.hs +++ b/Network/HTTP2/Arch/Context.hs @@ -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 diff --git a/Network/HTTP2/Arch/EncodeFrame.hs b/Network/HTTP2/Arch/EncodeFrame.hs --- a/Network/HTTP2/Arch/EncodeFrame.hs +++ b/Network/HTTP2/Arch/EncodeFrame.hs @@ -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 diff --git a/Network/HTTP2/Arch/HPACK.hs b/Network/HTTP2/Arch/HPACK.hs --- a/Network/HTTP2/Arch/HPACK.hs +++ b/Network/HTTP2/Arch/HPACK.hs @@ -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 diff --git a/Network/HTTP2/Arch/Manager.hs b/Network/HTTP2/Arch/Manager.hs --- a/Network/HTTP2/Arch/Manager.hs +++ b/Network/HTTP2/Arch/Manager.hs @@ -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 diff --git a/Network/HTTP2/Arch/Queue.hs b/Network/HTTP2/Arch/Queue.hs --- a/Network/HTTP2/Arch/Queue.hs +++ b/Network/HTTP2/Arch/Queue.hs @@ -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 diff --git a/Network/HTTP2/Arch/Receiver.hs b/Network/HTTP2/Arch/Receiver.hs --- a/Network/HTTP2/Arch/Receiver.hs +++ b/Network/HTTP2/Arch/Receiver.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HTTP2/Arch/Sender.hs b/Network/HTTP2/Arch/Sender.hs --- a/Network/HTTP2/Arch/Sender.hs +++ b/Network/HTTP2/Arch/Sender.hs @@ -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. -- diff --git a/Network/HTTP2/Arch/Stream.hs b/Network/HTTP2/Arch/Stream.hs --- a/Network/HTTP2/Arch/Stream.hs +++ b/Network/HTTP2/Arch/Stream.hs @@ -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 diff --git a/Network/HTTP2/Arch/Types.hs b/Network/HTTP2/Arch/Types.hs --- a/Network/HTTP2/Arch/Types.hs +++ b/Network/HTTP2/Arch/Types.hs @@ -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 diff --git a/Network/HTTP2/Client.hs b/Network/HTTP2/Client.hs --- a/Network/HTTP2/Client.hs +++ b/Network/HTTP2/Client.hs @@ -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 ---------------------------------------------------------------- diff --git a/Network/HTTP2/Client/Run.hs b/Network/HTTP2/Client/Run.hs --- a/Network/HTTP2/Client/Run.hs +++ b/Network/HTTP2/Client/Run.hs @@ -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 ()) diff --git a/Network/HTTP2/Frame.hs b/Network/HTTP2/Frame.hs --- a/Network/HTTP2/Frame.hs +++ b/Network/HTTP2/Frame.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} --- | Framing in HTTP\/2(). +-- | Framing in HTTP\/2(). 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 diff --git a/Network/HTTP2/Frame/Decode.hs b/Network/HTTP2/Frame/Decode.hs --- a/Network/HTTP2/Frame/Decode.hs +++ b/Network/HTTP2/Frame/Decode.hs @@ -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 diff --git a/Network/HTTP2/Frame/Encode.hs b/Network/HTTP2/Frame/Encode.hs --- a/Network/HTTP2/Frame/Encode.hs +++ b/Network/HTTP2/Frame/Encode.hs @@ -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 diff --git a/Network/HTTP2/Frame/Types.hs b/Network/HTTP2/Frame/Types.hs --- a/Network/HTTP2/Frame/Types.hs +++ b/Network/HTTP2/Frame/Types.hs @@ -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 . -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 . ----------------------------------------------------------------- +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" -} diff --git a/Network/HTTP2/Priority.hs b/Network/HTTP2/Priority.hs deleted file mode 100644 --- a/Network/HTTP2/Priority.hs +++ /dev/null @@ -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 diff --git a/Network/HTTP2/Priority/Internal.hs b/Network/HTTP2/Priority/Internal.hs deleted file mode 100644 --- a/Network/HTTP2/Priority/Internal.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Network.HTTP2.Priority.Internal ( - module Network.HTTP2.Priority.PSQ - ) where - -import Network.HTTP2.Priority.PSQ diff --git a/Network/HTTP2/Priority/PSQ.hs b/Network/HTTP2/Priority/PSQ.hs deleted file mode 100644 --- a/Network/HTTP2/Priority/PSQ.hs +++ /dev/null @@ -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) diff --git a/Network/HTTP2/Priority/Queue.hs b/Network/HTTP2/Priority/Queue.hs deleted file mode 100644 --- a/Network/HTTP2/Priority/Queue.hs +++ /dev/null @@ -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 diff --git a/Network/HTTP2/Server.hs b/Network/HTTP2/Server.hs --- a/Network/HTTP2/Server.hs +++ b/Network/HTTP2/Server.hs @@ -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 diff --git a/Network/HTTP2/Server/Run.hs b/Network/HTTP2/Server/Run.hs --- a/Network/HTTP2/Server/Run.hs +++ b/Network/HTTP2/Server/Run.hs @@ -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 diff --git a/Network/HTTP2/Server/Types.hs b/Network/HTTP2/Server/Types.hs --- a/Network/HTTP2/Server/Types.hs +++ b/Network/HTTP2/Server/Types.hs @@ -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 { diff --git a/Network/HTTP2/Server/Worker.hs b/Network/HTTP2/Server/Worker.hs --- a/Network/HTTP2/Server/Worker.hs +++ b/Network/HTTP2/Server/Worker.hs @@ -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 diff --git a/bench-priority/BinaryHeap.hs b/bench-priority/BinaryHeap.hs deleted file mode 100644 --- a/bench-priority/BinaryHeap.hs +++ /dev/null @@ -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 diff --git a/bench-priority/BinaryHeapSTM.hs b/bench-priority/BinaryHeapSTM.hs deleted file mode 100644 --- a/bench-priority/BinaryHeapSTM.hs +++ /dev/null @@ -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 diff --git a/bench-priority/DoublyLinkedQueueIO.hs b/bench-priority/DoublyLinkedQueueIO.hs deleted file mode 100644 --- a/bench-priority/DoublyLinkedQueueIO.hs +++ /dev/null @@ -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 diff --git a/bench-priority/Heap.hs b/bench-priority/Heap.hs deleted file mode 100644 --- a/bench-priority/Heap.hs +++ /dev/null @@ -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 diff --git a/bench-priority/Main.hs b/bench-priority/Main.hs deleted file mode 100644 --- a/bench-priority/Main.hs +++ /dev/null @@ -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 - ----------------------------------------------------------------- diff --git a/bench-priority/RandomSkewHeap.hs b/bench-priority/RandomSkewHeap.hs deleted file mode 100644 --- a/bench-priority/RandomSkewHeap.hs +++ /dev/null @@ -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 diff --git a/bench-priority/RingOfQueues.hs b/bench-priority/RingOfQueues.hs deleted file mode 100644 --- a/bench-priority/RingOfQueues.hs +++ /dev/null @@ -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 diff --git a/bench-priority/RingOfQueuesSTM.hs b/bench-priority/RingOfQueuesSTM.hs deleted file mode 100644 --- a/bench-priority/RingOfQueuesSTM.hs +++ /dev/null @@ -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 diff --git a/http2.cabal b/http2.cabal --- a/http2.cabal +++ b/http2.cabal @@ -1,430 +1,428 @@ -Name: http2 -Version: 3.0.3 -Author: Kazu Yamamoto -Maintainer: Kazu Yamamoto -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 +author: Kazu Yamamoto +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 diff --git a/test-frame/Case.hs b/test-frame/Case.hs --- a/test-frame/Case.hs +++ b/test-frame/Case.hs @@ -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 } diff --git a/test-frame/FrameSpec.hs b/test-frame/FrameSpec.hs --- a/test-frame/FrameSpec.hs +++ b/test-frame/FrameSpec.hs @@ -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 diff --git a/test-frame/JSON.hs b/test-frame/JSON.hs --- a/test-frame/JSON.hs +++ b/test-frame/JSON.hs @@ -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 [ diff --git a/test/HPACK/IntegerSpec.hs b/test/HPACK/IntegerSpec.hs --- a/test/HPACK/IntegerSpec.hs +++ b/test/HPACK/IntegerSpec.hs @@ -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' diff --git a/test/HTTP2/ClientSpec.hs b/test/HTTP2/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/HTTP2/ClientSpec.hs @@ -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 diff --git a/test/HTTP2/FrameSpec.hs b/test/HTTP2/FrameSpec.hs --- a/test/HTTP2/FrameSpec.hs +++ b/test/HTTP2/FrameSpec.hs @@ -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 diff --git a/test/HTTP2/PrioritySpec.hs b/test/HTTP2/PrioritySpec.hs deleted file mode 100644 --- a/test/HTTP2/PrioritySpec.hs +++ /dev/null @@ -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) diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -47,7 +47,7 @@ preface <- takeMVar prefaceVar preface `shouldBe` connectionPreface -ignoreHTTP2Error :: HTTP2Error -> IO () +ignoreHTTP2Error :: C.HTTP2Error -> IO () ignoreHTTP2Error _ = pure () runServer :: IO () diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -10,5 +10,5 @@ ] doctest [ "-XOverloadedStrings" - , "Network/HTTP2.hs" + , "Network/HTTP2/Frame.hs" ] diff --git a/util/client.hs b/util/client.hs --- a/util/client.hs +++ b/util/client.hs @@ -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 " - 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"