{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternGuards #-}

module Network.HTTP2.Server.Receiver (frameReceiver) 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 Data.IORef
import Network.HPACK
import Network.HPACK.Token
import Network.HTTP2
import Network.HTTP2.Priority (toPrecedence, delete, prepare)

import Imports hiding (delete, insert)
import Network.HTTP2.Server.API
import Network.HTTP2.Server.EncodeFrame
import Network.HTTP2.Server.HPACK
import Network.HTTP2.Server.Types
import Network.HTTP2.Server.Context
import Network.HTTP2.Server.Stream
import Network.HTTP2.Server.Queue

----------------------------------------------------------------

-- | Type for input streaming.
data Source = Source !(IORef ByteString) !(IO ByteString)

mkSource :: IO ByteString -> IO Source
mkSource :: IO ByteString -> IO Source
mkSource IO ByteString
func = do
    IORef ByteString
ref <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef ByteString
BS.empty
    Source -> IO Source
forall (m :: * -> *) a. Monad m => a -> m a
return (Source -> IO Source) -> Source -> IO Source
forall a b. (a -> b) -> a -> b
$! IORef ByteString -> IO ByteString -> Source
Source IORef ByteString
ref IO ByteString
func

readSource :: Source -> IO ByteString
readSource :: Source -> IO ByteString
readSource (Source IORef ByteString
ref IO ByteString
func) = do
    ByteString
bs <- IORef ByteString -> IO ByteString
forall a. IORef a -> IO a
readIORef IORef ByteString
ref
    if ByteString -> Bool
BS.null ByteString
bs
        then IO ByteString
func
        else do
            IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ByteString
ref ByteString
BS.empty
            ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs

frameReceiver :: Context -> (BufferSize -> IO ByteString) -> IO ()
frameReceiver :: Context -> (BufferSize -> IO ByteString) -> IO ()
frameReceiver Context
ctx BufferSize -> IO ByteString
recvN = BufferSize -> IO ()
loop BufferSize
0 IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`E.catch` SomeException -> IO ()
sendGoaway
  where
    Context{ IORef Settings
http2settings :: Context -> IORef Settings
http2settings :: IORef Settings
http2settings
           , StreamTable
streamTable :: Context -> StreamTable
streamTable :: StreamTable
streamTable
           , IORef BufferSize
concurrency :: Context -> IORef BufferSize
concurrency :: IORef BufferSize
concurrency
           , IORef (Maybe BufferSize)
continued :: Context -> IORef (Maybe BufferSize)
continued :: IORef (Maybe BufferSize)
continued
           , IORef BufferSize
clientStreamId :: Context -> IORef BufferSize
clientStreamId :: IORef BufferSize
clientStreamId
           , TQueue Input
inputQ :: Context -> TQueue Input
inputQ :: TQueue Input
inputQ
           , TQueue Control
controlQ :: Context -> TQueue Control
controlQ :: TQueue Control
controlQ
           } = Context
ctx
    sendGoaway :: SomeException -> IO ()
sendGoaway SomeException
e
      | Just (ConnectionError ErrorCodeId
err ByteString
msg) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
e = do
          BufferSize
csid <- IORef BufferSize -> IO BufferSize
forall a. IORef a -> IO a
readIORef IORef BufferSize
clientStreamId
          let !frame :: ByteString
frame = BufferSize -> ErrorCodeId -> ByteString -> ByteString
goawayFrame BufferSize
csid ErrorCodeId
err ByteString
msg
          TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CGoaway ByteString
frame
      | Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    sendReset :: ErrorCodeId -> BufferSize -> IO ()
sendReset ErrorCodeId
err BufferSize
sid = do
        let !frame :: ByteString
frame = ErrorCodeId -> BufferSize -> ByteString
resetFrame ErrorCodeId
err BufferSize
sid
        TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame

    loop :: Int -> IO ()
    loop :: BufferSize -> IO ()
loop !BufferSize
n
      | BufferSize
n BufferSize -> BufferSize -> Bool
forall a. Eq a => a -> a -> Bool
== BufferSize
6 = do
          IO ()
yield
          BufferSize -> IO ()
loop BufferSize
0
      | Bool
otherwise = do
        ByteString
hd <- BufferSize -> IO ByteString
recvN BufferSize
frameHeaderLength
        if ByteString -> Bool
BS.null ByteString
hd then
            TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
CFinish
          else do
            Bool
cont <- (FrameTypeId, FrameHeader) -> IO Bool
processStreamGuardingError ((FrameTypeId, FrameHeader) -> IO Bool)
-> (FrameTypeId, FrameHeader) -> IO Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> (FrameTypeId, FrameHeader)
decodeFrameHeader ByteString
hd
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
cont (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ BufferSize -> IO ()
loop (BufferSize
n BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
1)

    processStreamGuardingError :: (FrameTypeId, FrameHeader) -> IO Bool
processStreamGuardingError (FrameTypeId
fid, FrameHeader{BufferSize
streamId :: FrameHeader -> BufferSize
streamId :: BufferSize
streamId})
      | BufferSize -> Bool
isResponse BufferSize
streamId Bool -> Bool -> Bool
&&
        (FrameTypeId
fid FrameTypeId -> [FrameTypeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameTypeId
FramePriority,FrameTypeId
FrameRSTStream,FrameTypeId
FrameWindowUpdate]) =
        HTTP2Error -> IO Bool
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO Bool) -> HTTP2Error -> IO Bool
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"stream id should be odd"
    processStreamGuardingError (FrameUnknown FrameType
_, FrameHeader{BufferSize
payloadLength :: FrameHeader -> BufferSize
payloadLength :: BufferSize
payloadLength}) = do
        Maybe BufferSize
mx <- IORef (Maybe BufferSize) -> IO (Maybe BufferSize)
forall a. IORef a -> IO a
readIORef IORef (Maybe BufferSize)
continued
        case Maybe BufferSize
mx of
            Maybe BufferSize
Nothing -> do
                -- ignoring unknown frame
                BufferSize -> IO ()
consume BufferSize
payloadLength
                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Just BufferSize
_  -> HTTP2Error -> IO Bool
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO Bool) -> HTTP2Error -> IO Bool
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"unknown frame"
    processStreamGuardingError (FrameTypeId
FramePushPromise, FrameHeader
_) =
        HTTP2Error -> IO Bool
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO Bool) -> HTTP2Error -> IO Bool
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"push promise is not allowed"
    processStreamGuardingError typhdr :: (FrameTypeId, FrameHeader)
typhdr@(FrameTypeId
ftyp, header :: FrameHeader
header@FrameHeader{BufferSize
payloadLength :: BufferSize
payloadLength :: FrameHeader -> BufferSize
payloadLength}) = do
        Settings
settings <- IORef Settings -> IO Settings
forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
        case Settings
-> (FrameTypeId, FrameHeader)
-> Either HTTP2Error (FrameTypeId, FrameHeader)
checkFrameHeader Settings
settings (FrameTypeId, FrameHeader)
typhdr of
            Left HTTP2Error
h2err -> case HTTP2Error
h2err of
                StreamError ErrorCodeId
err BufferSize
sid -> do
                    ErrorCodeId -> BufferSize -> IO ()
sendReset ErrorCodeId
err BufferSize
sid
                    BufferSize -> IO ()
consume BufferSize
payloadLength
                    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                HTTP2Error
connErr -> HTTP2Error -> IO Bool
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
connErr
            Right (FrameTypeId, FrameHeader)
_ -> do
                Either HTTP2Error Bool
ex <- IO Bool -> IO (Either HTTP2Error Bool)
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO Bool -> IO (Either HTTP2Error Bool))
-> IO Bool -> IO (Either HTTP2Error Bool)
forall a b. (a -> b) -> a -> b
$ FrameTypeId -> FrameHeader -> IO Bool
controlOrStream FrameTypeId
ftyp FrameHeader
header
                case Either HTTP2Error Bool
ex of
                    Left (StreamError ErrorCodeId
err BufferSize
sid) -> do
                        ErrorCodeId -> BufferSize -> IO ()
sendReset ErrorCodeId
err BufferSize
sid
                        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                    Left HTTP2Error
connErr -> HTTP2Error -> IO Bool
forall a e. Exception e => e -> a
E.throw HTTP2Error
connErr
                    Right Bool
cont -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
cont

    controlOrStream :: FrameTypeId -> FrameHeader -> IO Bool
controlOrStream FrameTypeId
ftyp header :: FrameHeader
header@FrameHeader{BufferSize
streamId :: BufferSize
streamId :: FrameHeader -> BufferSize
streamId, BufferSize
payloadLength :: BufferSize
payloadLength :: FrameHeader -> BufferSize
payloadLength}
      | BufferSize -> Bool
isControl BufferSize
streamId = do
          ByteString
pl <- BufferSize -> IO ByteString
recvN BufferSize
payloadLength
          FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool
control FrameTypeId
ftyp FrameHeader
header ByteString
pl Context
ctx
      | Bool
otherwise = do
          IO ()
checkContinued
          !Maybe Stream
mstrm <- IO (Maybe Stream)
getStream
          ByteString
pl <- BufferSize -> IO ByteString
recvN BufferSize
payloadLength
          case Maybe Stream
mstrm of
            Maybe Stream
Nothing -> do
                -- for h2spec only
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp FrameTypeId -> FrameTypeId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameTypeId
FramePriority) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                    PriorityFrame Priority
newpri <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
pl
                    Priority -> BufferSize -> IO ()
checkPriority Priority
newpri BufferSize
streamId
                Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- just ignore this frame
            Just strm :: Stream
strm@Stream{IORef Precedence
streamPrecedence :: Stream -> IORef Precedence
streamPrecedence :: IORef Precedence
streamPrecedence} -> do
              StreamState
state <- Stream -> IO StreamState
readStreamState Stream
strm
              StreamState
state' <- FrameTypeId
-> FrameHeader
-> ByteString
-> Context
-> StreamState
-> Stream
-> IO StreamState
stream FrameTypeId
ftyp FrameHeader
header ByteString
pl Context
ctx StreamState
state Stream
strm
              case StreamState
state' of
                  Open (NoBody tbl :: HeaderTable
tbl@(TokenHeaderList
_,ValueTable
reqvt) Priority
pri) -> do
                      IO ()
resetContinued
                      let mcl :: Maybe BufferSize
mcl = (BufferSize, ByteString) -> BufferSize
forall a b. (a, b) -> a
fst ((BufferSize, ByteString) -> BufferSize)
-> Maybe (BufferSize, ByteString) -> Maybe BufferSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenContentLength ValueTable
reqvt Maybe ByteString
-> (ByteString -> Maybe (BufferSize, ByteString))
-> Maybe (BufferSize, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (BufferSize, ByteString)
C8.readInt)
                      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe BufferSize -> (BufferSize -> Bool) -> Bool
forall a. Maybe a -> (a -> Bool) -> Bool
just Maybe BufferSize
mcl (BufferSize -> BufferSize -> Bool
forall a. Eq a => a -> a -> Bool
/= (BufferSize
0 :: Int))) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                          HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> BufferSize -> HTTP2Error
StreamError ErrorCodeId
ProtocolError BufferSize
streamId
                      IORef Precedence -> Precedence -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Precedence
streamPrecedence (Precedence -> IO ()) -> Precedence -> IO ()
forall a b. (a -> b) -> a -> b
$ Priority -> Precedence
toPrecedence Priority
pri
                      Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
                      IORef (Maybe HeaderTable)
tlr <- Maybe HeaderTable -> IO (IORef (Maybe HeaderTable))
forall a. a -> IO (IORef a)
newIORef Maybe HeaderTable
forall a. Maybe a
Nothing
                      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue Input -> Input -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Input
inputQ (Input -> STM ()) -> Input -> STM ()
forall a b. (a -> b) -> a -> b
$ Stream -> Request -> Input
Input Stream
strm (Request -> Input) -> Request -> Input
forall a b. (a -> b) -> a -> b
$ HeaderTable
-> Maybe BufferSize
-> IO ByteString
-> IORef (Maybe HeaderTable)
-> Request
Request HeaderTable
tbl (BufferSize -> Maybe BufferSize
forall a. a -> Maybe a
Just BufferSize
0) (ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
"") IORef (Maybe HeaderTable)
tlr
                  Open (HasBody tbl :: HeaderTable
tbl@(TokenHeaderList
_,ValueTable
reqvt) Priority
pri) -> do
                      IO ()
resetContinued
                      TQueue ByteString
q <- IO (TQueue ByteString)
forall a. IO (TQueue a)
newTQueueIO
                      let !mcl :: Maybe BufferSize
mcl = (BufferSize, ByteString) -> BufferSize
forall a b. (a, b) -> a
fst ((BufferSize, ByteString) -> BufferSize)
-> Maybe (BufferSize, ByteString) -> Maybe BufferSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token -> ValueTable -> Maybe ByteString
getHeaderValue Token
tokenContentLength ValueTable
reqvt Maybe ByteString
-> (ByteString -> Maybe (BufferSize, ByteString))
-> Maybe (BufferSize, ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe (BufferSize, ByteString)
C8.readInt)
                      IORef Precedence -> Precedence -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Precedence
streamPrecedence (Precedence -> IO ()) -> Precedence -> IO ()
forall a b. (a -> b) -> a -> b
$ Priority -> Precedence
toPrecedence Priority
pri
                      IORef BufferSize
bodyLength <- BufferSize -> IO (IORef BufferSize)
forall a. a -> IO (IORef a)
newIORef BufferSize
0
                      IORef (Maybe HeaderTable)
tlr <- Maybe HeaderTable -> IO (IORef (Maybe HeaderTable))
forall a. a -> IO (IORef a)
newIORef Maybe HeaderTable
forall a. Maybe a
Nothing
                      Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm (StreamState -> IO ()) -> StreamState -> IO ()
forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open (TQueue ByteString
-> Maybe BufferSize
-> IORef BufferSize
-> IORef (Maybe HeaderTable)
-> OpenState
Body TQueue ByteString
q Maybe BufferSize
mcl IORef BufferSize
bodyLength IORef (Maybe HeaderTable)
tlr)
                      IO ByteString
readQ <- TQueue ByteString -> IO (IO ByteString)
newReadBody TQueue ByteString
q
                      Source
bodySource <- IO ByteString -> IO Source
mkSource IO ByteString
readQ
                      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue Input -> Input -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue Input
inputQ (Input -> STM ()) -> Input -> STM ()
forall a b. (a -> b) -> a -> b
$ Stream -> Request -> Input
Input Stream
strm (Request -> Input) -> Request -> Input
forall a b. (a -> b) -> a -> b
$ HeaderTable
-> Maybe BufferSize
-> IO ByteString
-> IORef (Maybe HeaderTable)
-> Request
Request HeaderTable
tbl Maybe BufferSize
mcl (Source -> IO ByteString
readSource Source
bodySource) IORef (Maybe HeaderTable)
tlr
                  s :: StreamState
s@(Open Continued{}) -> do
                      IO ()
setContinued
                      Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s
                  StreamState
HalfClosedRemote -> do
                      IO ()
resetContinued
                      Context -> Stream -> IO ()
halfClosedRemote Context
ctx Stream
strm
                  StreamState
s -> do -- Idle, Open Body, Closed
                      IO ()
resetContinued
                      Context -> Stream -> StreamState -> IO ()
setStreamState Context
ctx Stream
strm StreamState
s
              Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
       where
         setContinued :: IO ()
setContinued = IORef (Maybe BufferSize) -> Maybe BufferSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe BufferSize)
continued (BufferSize -> Maybe BufferSize
forall a. a -> Maybe a
Just BufferSize
streamId)
         resetContinued :: IO ()
resetContinued = IORef (Maybe BufferSize) -> Maybe BufferSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe BufferSize)
continued Maybe BufferSize
forall a. Maybe a
Nothing
         checkContinued :: IO ()
checkContinued = do
             Maybe BufferSize
mx <- IORef (Maybe BufferSize) -> IO (Maybe BufferSize)
forall a. IORef a -> IO a
readIORef IORef (Maybe BufferSize)
continued
             case Maybe BufferSize
mx of
                 Maybe BufferSize
Nothing  -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                 Just BufferSize
sid
                   | BufferSize
sid BufferSize -> BufferSize -> Bool
forall a. Eq a => a -> a -> Bool
== BufferSize
streamId Bool -> Bool -> Bool
&& FrameTypeId
ftyp FrameTypeId -> FrameTypeId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameTypeId
FrameContinuation -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   | Bool
otherwise -> HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"continuation frame must follow"
         getStream :: IO (Maybe Stream)
getStream = do
             Maybe Stream
mstrm0 <- StreamTable -> BufferSize -> IO (Maybe Stream)
search StreamTable
streamTable BufferSize
streamId
             case Maybe Stream
mstrm0 of
                 js :: Maybe Stream
js@(Just Stream
strm0) -> do
                     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp FrameTypeId -> FrameTypeId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameTypeId
FrameHeaders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                         StreamState
st <- Stream -> IO StreamState
readStreamState Stream
strm0
                         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isHalfClosedRemote StreamState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
StreamClosed ByteString
"header must not be sent to half or fully closed stream"
                         -- Priority made an idele stream
                         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (StreamState -> Bool
isIdle StreamState
st) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> IO ()
opened Context
ctx Stream
strm0
                     Maybe Stream -> IO (Maybe Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
js
                 Maybe Stream
Nothing
                   | BufferSize -> Bool
isResponse BufferSize
streamId -> Maybe Stream -> IO (Maybe Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing
                   | Bool
otherwise           -> do
                         BufferSize
csid <- IORef BufferSize -> IO BufferSize
forall a. IORef a -> IO a
readIORef IORef BufferSize
clientStreamId
                         if BufferSize
streamId BufferSize -> BufferSize -> Bool
forall a. Ord a => a -> a -> Bool
<= BufferSize
csid then -- consider the stream closed
                             if FrameTypeId
ftyp FrameTypeId -> [FrameTypeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FrameTypeId
FrameWindowUpdate, FrameTypeId
FrameRSTStream, FrameTypeId
FramePriority] then
                                 Maybe Stream -> IO (Maybe Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Stream
forall a. Maybe a
Nothing -- will be ignored
                               else
                                 HTTP2Error -> IO (Maybe Stream)
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO (Maybe Stream))
-> HTTP2Error -> IO (Maybe Stream)
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"stream identifier must not decrease"
                           else do -- consider the stream idle
                             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp FrameTypeId -> [FrameTypeId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [FrameTypeId
FrameHeaders,FrameTypeId
FramePriority]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                 HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError (ByteString -> HTTP2Error) -> ByteString -> HTTP2Error
forall a b. (a -> b) -> a -> b
$ ByteString
"this frame is not allowed in an idle stream: " ByteString -> ByteString -> ByteString
`BS.append` String -> ByteString
C8.pack (FrameTypeId -> String
forall a. Show a => a -> String
show FrameTypeId
ftyp)
                             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp FrameTypeId -> FrameTypeId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameTypeId
FrameHeaders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                 IORef BufferSize -> BufferSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BufferSize
clientStreamId BufferSize
streamId
                                 BufferSize
cnt <- IORef BufferSize -> IO BufferSize
forall a. IORef a -> IO a
readIORef IORef BufferSize
concurrency
                                 -- Checking the limitation of concurrency
                                 Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize
cnt BufferSize -> BufferSize -> Bool
forall a. Ord a => a -> a -> Bool
>= BufferSize
maxConcurrency) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                     HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> BufferSize -> HTTP2Error
StreamError ErrorCodeId
RefusedStream BufferSize
streamId
                             BufferSize
ws <- Settings -> BufferSize
initialWindowSize (Settings -> BufferSize) -> IO Settings -> IO BufferSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Settings -> IO Settings
forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
                             Stream
newstrm <- BufferSize -> BufferSize -> IO Stream
newStream BufferSize
streamId (BufferSize -> BufferSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral BufferSize
ws)
                             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FrameTypeId
ftyp FrameTypeId -> FrameTypeId -> Bool
forall a. Eq a => a -> a -> Bool
== FrameTypeId
FrameHeaders) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> IO ()
opened Context
ctx Stream
newstrm
                             StreamTable -> BufferSize -> Stream -> IO ()
insert StreamTable
streamTable BufferSize
streamId Stream
newstrm
                             Maybe Stream -> IO (Maybe Stream)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Stream -> IO (Maybe Stream))
-> Maybe Stream -> IO (Maybe Stream)
forall a b. (a -> b) -> a -> b
$ Stream -> Maybe Stream
forall a. a -> Maybe a
Just Stream
newstrm

    consume :: BufferSize -> IO ()
consume = IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteString -> IO ())
-> (BufferSize -> IO ByteString) -> BufferSize -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BufferSize -> IO ByteString
recvN

maxConcurrency :: Int
maxConcurrency :: BufferSize
maxConcurrency = BufferSize
recommendedConcurrency

initialFrame :: ByteString
initialFrame :: ByteString
initialFrame = (FrameType -> FrameType) -> SettingsList -> ByteString
settingsFrame FrameType -> FrameType
forall a. a -> a
id [(SettingsKeyId
SettingsMaxConcurrentStreams,BufferSize
maxConcurrency)]

----------------------------------------------------------------

control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool
control :: FrameTypeId -> FrameHeader -> ByteString -> Context -> IO Bool
control FrameTypeId
FrameSettings header :: FrameHeader
header@FrameHeader{FrameType
flags :: FrameHeader -> FrameType
flags :: FrameType
flags} ByteString
bs Context{IORef Settings
http2settings :: IORef Settings
http2settings :: Context -> IORef Settings
http2settings, TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ, IORef Bool
firstSettings :: Context -> IORef Bool
firstSettings :: IORef Bool
firstSettings, StreamTable
streamTable :: StreamTable
streamTable :: Context -> StreamTable
streamTable} = do
    SettingsFrame SettingsList
alist <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeSettingsFrame FrameHeader
header ByteString
bs
    (HTTP2Error -> IO Any) -> Maybe HTTP2Error -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ HTTP2Error -> IO Any
forall e a. Exception e => e -> IO a
E.throwIO (Maybe HTTP2Error -> IO ()) -> Maybe HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ SettingsList -> Maybe HTTP2Error
checkSettingsList SettingsList
alist
    -- HTTP/2 Setting from a browser
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FrameType -> Bool
testAck FrameType
flags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        BufferSize
oldws <- Settings -> BufferSize
initialWindowSize (Settings -> BufferSize) -> IO Settings -> IO BufferSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Settings -> IO Settings
forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
        IORef Settings -> (Settings -> Settings) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Settings
http2settings ((Settings -> Settings) -> IO ())
-> (Settings -> Settings) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Settings
old -> Settings -> SettingsList -> Settings
updateSettings Settings
old SettingsList
alist
        BufferSize
newws <- Settings -> BufferSize
initialWindowSize (Settings -> BufferSize) -> IO Settings -> IO BufferSize
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef Settings -> IO Settings
forall a. IORef a -> IO a
readIORef IORef Settings
http2settings
        let diff :: BufferSize
diff = BufferSize
newws BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
- BufferSize
oldws
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize
diff BufferSize -> BufferSize -> Bool
forall a. Eq a => a -> a -> Bool
/= BufferSize
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (BufferSize -> BufferSize) -> StreamTable -> IO ()
updateAllStreamWindow (BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
diff) StreamTable
streamTable
        let !frame :: ByteString
frame = (FrameType -> FrameType) -> SettingsList -> ByteString
settingsFrame FrameType -> FrameType
setAck []
        Bool
sent <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
firstSettings
        let !setframe :: Control
setframe
              | Bool
sent      = ByteString -> SettingsList -> Control
CSettings               ByteString
frame SettingsList
alist
              | Bool
otherwise = ByteString -> ByteString -> SettingsList -> Control
CSettings0 ByteString
initialFrame ByteString
frame SettingsList
alist
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sent (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
firstSettings Bool
True
        TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
setframe
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

control FrameTypeId
FramePing FrameHeader{FrameType
flags :: FrameType
flags :: FrameHeader -> FrameType
flags} ByteString
bs Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ} =
    if FrameType -> Bool
testAck FrameType
flags then
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True -- just ignore
      else do
        let !frame :: ByteString
frame = ByteString -> ByteString
pingFrame ByteString
bs
        TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
        Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

control FrameTypeId
FrameGoAway FrameHeader
_ ByteString
_ Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ} = do
    TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ Control
CFinish
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

control FrameTypeId
FrameWindowUpdate FrameHeader
header ByteString
bs Context{TVar BufferSize
connectionWindow :: Context -> TVar BufferSize
connectionWindow :: TVar BufferSize
connectionWindow} = do
    WindowUpdateFrame BufferSize
n <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    !BufferSize
w <- STM BufferSize -> IO BufferSize
forall a. STM a -> IO a
atomically (STM BufferSize -> IO BufferSize)
-> STM BufferSize -> IO BufferSize
forall a b. (a -> b) -> a -> b
$ do
      BufferSize
w0 <- TVar BufferSize -> STM BufferSize
forall a. TVar a -> STM a
readTVar TVar BufferSize
connectionWindow
      let !w1 :: BufferSize
w1 = BufferSize
w0 BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
n
      TVar BufferSize -> BufferSize -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar BufferSize
connectionWindow BufferSize
w1
      BufferSize -> STM BufferSize
forall (m :: * -> *) a. Monad m => a -> m a
return BufferSize
w1
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize -> Bool
isWindowOverflow BufferSize
w) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
FlowControlError ByteString
"control window should be less than 2^31"
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

control FrameTypeId
_ FrameHeader
_ ByteString
_ Context
_ =
    -- must not reach here
    Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

----------------------------------------------------------------

{-# INLINE guardIt #-}
guardIt :: Either HTTP2Error a -> IO a
guardIt :: Either HTTP2Error a -> IO a
guardIt Either HTTP2Error a
x = case Either HTTP2Error a
x of
    Left HTTP2Error
err    -> HTTP2Error -> IO a
forall e a. Exception e => e -> IO a
E.throwIO HTTP2Error
err
    Right a
frame -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
frame


{-# INLINE checkPriority #-}
checkPriority :: Priority -> StreamId -> IO ()
checkPriority :: Priority -> BufferSize -> IO ()
checkPriority Priority
p BufferSize
me
  | BufferSize
dep BufferSize -> BufferSize -> Bool
forall a. Eq a => a -> a -> Bool
== BufferSize
me = HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> BufferSize -> HTTP2Error
StreamError ErrorCodeId
ProtocolError BufferSize
me
  | Bool
otherwise = () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    dep :: BufferSize
dep = Priority -> BufferSize
streamDependency Priority
p

stream :: FrameTypeId -> FrameHeader -> ByteString -> Context -> StreamState -> Stream -> IO StreamState
stream :: FrameTypeId
-> FrameHeader
-> ByteString
-> Context
-> StreamState
-> Stream
-> IO StreamState
stream FrameTypeId
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameType
flags :: FrameType
flags :: FrameHeader -> FrameType
flags} ByteString
bs Context
ctx (Open OpenState
JustOpened) Stream{BufferSize
streamNumber :: Stream -> BufferSize
streamNumber :: BufferSize
streamNumber} = do
    HeadersFrame Maybe Priority
mp ByteString
frag <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
    Priority
pri <- case Maybe Priority
mp of
        Maybe Priority
Nothing -> Priority -> IO Priority
forall (m :: * -> *) a. Monad m => a -> m a
return Priority
defaultPriority
        Just Priority
p  -> do
            Priority -> BufferSize -> IO ()
checkPriority Priority
p BufferSize
streamNumber
            Priority -> IO Priority
forall (m :: * -> *) a. Monad m => a -> m a
return Priority
p
    let !endOfStream :: Bool
endOfStream = FrameType -> Bool
testEndStream FrameType
flags
        !endOfHeader :: Bool
endOfHeader = FrameType -> Bool
testEndHeader FrameType
flags
    if Bool
endOfHeader then do
        HeaderTable
tbl <- ByteString -> Context -> IO HeaderTable
hpackDecodeHeader ByteString
frag Context
ctx -- fixme
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ if Bool
endOfStream then
                    OpenState -> StreamState
Open (HeaderTable -> Priority -> OpenState
NoBody HeaderTable
tbl Priority
pri)
                   else
                    OpenState -> StreamState
Open (HeaderTable -> Priority -> OpenState
HasBody HeaderTable
tbl Priority
pri)
      else do
        let !siz :: BufferSize
siz = ByteString -> BufferSize
BS.length ByteString
frag
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open (OpenState -> StreamState) -> OpenState -> StreamState
forall a b. (a -> b) -> a -> b
$ [ByteString]
-> BufferSize -> BufferSize -> Bool -> Priority -> OpenState
Continued [ByteString
frag] BufferSize
siz BufferSize
1 Bool
endOfStream Priority
pri

stream FrameTypeId
FrameHeaders header :: FrameHeader
header@FrameHeader{FrameType
flags :: FrameType
flags :: FrameHeader -> FrameType
flags} ByteString
bs Context
ctx (Open (Body TQueue ByteString
q Maybe BufferSize
_ IORef BufferSize
_ IORef (Maybe HeaderTable)
tlr)) Stream
_ = do
    HeadersFrame Maybe Priority
_ ByteString
frag <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeHeadersFrame FrameHeader
header ByteString
bs
    let !endOfStream :: Bool
endOfStream = FrameType -> Bool
testEndStream FrameType
flags
    if Bool
endOfStream then do
        HeaderTable
tbl <- ByteString -> Context -> IO HeaderTable
hpackDecodeTrailer ByteString
frag Context
ctx
        IORef (Maybe HeaderTable) -> Maybe HeaderTable -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe HeaderTable)
tlr (HeaderTable -> Maybe HeaderTable
forall a. a -> Maybe a
Just HeaderTable
tbl)
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
""
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
      else
        -- we don't support continuation here.
        HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"continuation in trailer is not supported"

-- ignore data-frame except for flow-control when we're done locally
stream FrameTypeId
FrameData
       FrameHeader{FrameType
flags :: FrameType
flags :: FrameHeader -> FrameType
flags,BufferSize
payloadLength :: BufferSize
payloadLength :: FrameHeader -> BufferSize
payloadLength}
       ByteString
_bs
       Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ} s :: StreamState
s@(HalfClosedLocal ClosedCode
_)
       Stream{BufferSize
streamNumber :: BufferSize
streamNumber :: Stream -> BufferSize
streamNumber} = do
    let !endOfStream :: Bool
endOfStream = FrameType -> Bool
testEndStream FrameType
flags
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize
payloadLength BufferSize -> BufferSize -> Bool
forall a. Eq a => a -> a -> Bool
/= BufferSize
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let !frame1 :: ByteString
frame1 = BufferSize -> BufferSize -> ByteString
windowUpdateFrame BufferSize
0 BufferSize
payloadLength
            !frame2 :: ByteString
frame2 = BufferSize -> BufferSize -> ByteString
windowUpdateFrame BufferSize
streamNumber BufferSize
payloadLength
            !frame :: ByteString
frame = ByteString
frame1 ByteString -> ByteString -> ByteString
`BS.append` ByteString
frame2
        TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
    if Bool
endOfStream then do
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
      else
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

stream FrameTypeId
FrameData
       header :: FrameHeader
header@FrameHeader{FrameType
flags :: FrameType
flags :: FrameHeader -> FrameType
flags,BufferSize
payloadLength :: BufferSize
payloadLength :: FrameHeader -> BufferSize
payloadLength,BufferSize
streamId :: BufferSize
streamId :: FrameHeader -> BufferSize
streamId}
       ByteString
bs
       Context{TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ} s :: StreamState
s@(Open (Body TQueue ByteString
q Maybe BufferSize
mcl IORef BufferSize
bodyLength IORef (Maybe HeaderTable)
_))
       Stream{BufferSize
streamNumber :: BufferSize
streamNumber :: Stream -> BufferSize
streamNumber} = do
    DataFrame ByteString
body <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeDataFrame FrameHeader
header ByteString
bs
    let !endOfStream :: Bool
endOfStream = FrameType -> Bool
testEndStream FrameType
flags
    BufferSize
len0 <- IORef BufferSize -> IO BufferSize
forall a. IORef a -> IO a
readIORef IORef BufferSize
bodyLength
    let !len :: BufferSize
len = BufferSize
len0 BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
payloadLength
    IORef BufferSize -> BufferSize -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef BufferSize
bodyLength BufferSize
len
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize
payloadLength BufferSize -> BufferSize -> Bool
forall a. Eq a => a -> a -> Bool
/= BufferSize
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let !frame1 :: ByteString
frame1 = BufferSize -> BufferSize -> ByteString
windowUpdateFrame BufferSize
0 BufferSize
payloadLength
            !frame2 :: ByteString
frame2 = BufferSize -> BufferSize -> ByteString
windowUpdateFrame BufferSize
streamNumber BufferSize
payloadLength
            !frame :: ByteString
frame = ByteString
frame1 ByteString -> ByteString -> ByteString
`BS.append` ByteString
frame2
        TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Control
CFrame ByteString
frame
    STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
body
    if Bool
endOfStream then do
        case Maybe BufferSize
mcl of
            Maybe BufferSize
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just BufferSize
cl -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize
cl BufferSize -> BufferSize -> Bool
forall a. Eq a => a -> a -> Bool
/= BufferSize
len) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> BufferSize -> HTTP2Error
StreamError ErrorCodeId
ProtocolError BufferSize
streamId
        -- no trailers
        STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> ByteString -> STM ()
forall a. TQueue a -> a -> STM ()
writeTQueue TQueue ByteString
q ByteString
""
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
HalfClosedRemote
      else
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

stream FrameTypeId
FrameContinuation FrameHeader{FrameType
flags :: FrameType
flags :: FrameHeader -> FrameType
flags} ByteString
frag Context
ctx (Open (Continued [ByteString]
rfrags BufferSize
siz BufferSize
n Bool
endOfStream Priority
pri)) Stream
_ = do
    let !endOfHeader :: Bool
endOfHeader = FrameType -> Bool
testEndHeader FrameType
flags
        !rfrags' :: [ByteString]
rfrags' = ByteString
frag ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
rfrags
        !siz' :: BufferSize
siz' = BufferSize
siz BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ ByteString -> BufferSize
BS.length ByteString
frag
        !n' :: BufferSize
n' = BufferSize
n BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
1
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize
siz' BufferSize -> BufferSize -> Bool
forall a. Ord a => a -> a -> Bool
> BufferSize
51200) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ -- fixme: hard coding: 50K
      HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
EnhanceYourCalm ByteString
"Header is too big"
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize
n' BufferSize -> BufferSize -> Bool
forall a. Ord a => a -> a -> Bool
> BufferSize
10) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ -- fixme: hard coding
      HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
EnhanceYourCalm ByteString
"Header is too fragmented"
    if Bool
endOfHeader then do
        let !hdrblk :: ByteString
hdrblk = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse [ByteString]
rfrags'
        HeaderTable
tbl <- ByteString -> Context -> IO HeaderTable
hpackDecodeHeader ByteString
hdrblk Context
ctx
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ if Bool
endOfStream then
                    OpenState -> StreamState
Open (HeaderTable -> Priority -> OpenState
NoBody HeaderTable
tbl Priority
pri)
                   else
                    OpenState -> StreamState
Open (HeaderTable -> Priority -> OpenState
HasBody HeaderTable
tbl Priority
pri)
      else
        StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ OpenState -> StreamState
Open (OpenState -> StreamState) -> OpenState -> StreamState
forall a b. (a -> b) -> a -> b
$ [ByteString]
-> BufferSize -> BufferSize -> Bool -> Priority -> OpenState
Continued [ByteString]
rfrags' BufferSize
siz' BufferSize
n' Bool
endOfStream Priority
pri

stream FrameTypeId
FrameWindowUpdate header :: FrameHeader
header@FrameHeader{BufferSize
streamId :: BufferSize
streamId :: FrameHeader -> BufferSize
streamId} ByteString
bs Context
_ StreamState
s Stream{TVar BufferSize
streamWindow :: Stream -> TVar BufferSize
streamWindow :: TVar BufferSize
streamWindow} = do
    WindowUpdateFrame BufferSize
n <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodeWindowUpdateFrame FrameHeader
header ByteString
bs
    !BufferSize
w <- STM BufferSize -> IO BufferSize
forall a. STM a -> IO a
atomically (STM BufferSize -> IO BufferSize)
-> STM BufferSize -> IO BufferSize
forall a b. (a -> b) -> a -> b
$ do
      BufferSize
w0 <- TVar BufferSize -> STM BufferSize
forall a. TVar a -> STM a
readTVar TVar BufferSize
streamWindow
      let !w1 :: BufferSize
w1 = BufferSize
w0 BufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+ BufferSize
n
      TVar BufferSize -> BufferSize -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar BufferSize
streamWindow BufferSize
w1
      BufferSize -> STM BufferSize
forall (m :: * -> *) a. Monad m => a -> m a
return BufferSize
w1
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize -> Bool
isWindowOverflow BufferSize
w) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> BufferSize -> HTTP2Error
StreamError ErrorCodeId
FlowControlError BufferSize
streamId
    StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

stream FrameTypeId
FrameRSTStream FrameHeader
header ByteString
bs Context
ctx StreamState
_ Stream
strm = do
    RSTStreamFrame ErrorCodeId
e <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decoderstStreamFrame FrameHeader
header ByteString
bs
    let !cc :: ClosedCode
cc = ErrorCodeId -> ClosedCode
Reset ErrorCodeId
e
    Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm ClosedCode
cc
    StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return (StreamState -> IO StreamState) -> StreamState -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ClosedCode -> StreamState
Closed ClosedCode
cc -- will be written to streamState again

stream FrameTypeId
FramePriority FrameHeader
header ByteString
bs Context{PriorityTree Output
outputQ :: Context -> PriorityTree Output
outputQ :: PriorityTree Output
outputQ,IORef BufferSize
priorityTreeSize :: Context -> IORef BufferSize
priorityTreeSize :: IORef BufferSize
priorityTreeSize} StreamState
s Stream{BufferSize
streamNumber :: BufferSize
streamNumber :: Stream -> BufferSize
streamNumber,IORef Precedence
streamPrecedence :: IORef Precedence
streamPrecedence :: Stream -> IORef Precedence
streamPrecedence} = do
    PriorityFrame Priority
newpri <- Either HTTP2Error FramePayload -> IO FramePayload
forall a. Either HTTP2Error a -> IO a
guardIt (Either HTTP2Error FramePayload -> IO FramePayload)
-> Either HTTP2Error FramePayload -> IO FramePayload
forall a b. (a -> b) -> a -> b
$ FramePayloadDecoder
decodePriorityFrame FrameHeader
header ByteString
bs
    Priority -> BufferSize -> IO ()
checkPriority Priority
newpri BufferSize
streamNumber
    Precedence
oldpre <- IORef Precedence -> IO Precedence
forall a. IORef a -> IO a
readIORef IORef Precedence
streamPrecedence
    let !newpre :: Precedence
newpre = Priority -> Precedence
toPrecedence Priority
newpri
    IORef Precedence -> Precedence -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Precedence
streamPrecedence Precedence
newpre
    if StreamState -> Bool
isIdle StreamState
s then do
        BufferSize
n <- IORef BufferSize
-> (BufferSize -> (BufferSize, BufferSize)) -> IO BufferSize
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef BufferSize
priorityTreeSize (\BufferSize
x -> (BufferSize
xBufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+BufferSize
1,BufferSize
xBufferSize -> BufferSize -> BufferSize
forall a. Num a => a -> a -> a
+BufferSize
1))
        -- fixme hard coding
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BufferSize
n BufferSize -> BufferSize -> Bool
forall a. Ord a => a -> a -> Bool
>= BufferSize
20) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ HTTP2Error -> IO ()
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
EnhanceYourCalm ByteString
"too many idle priority frames"
        PriorityTree Output -> BufferSize -> Priority -> IO ()
forall a. PriorityTree a -> BufferSize -> Priority -> IO ()
prepare PriorityTree Output
outputQ BufferSize
streamNumber Priority
newpri
      else do
        Maybe Output
mout <- PriorityTree Output
-> BufferSize -> Precedence -> IO (Maybe Output)
forall a.
PriorityTree a -> BufferSize -> Precedence -> IO (Maybe a)
delete PriorityTree Output
outputQ BufferSize
streamNumber Precedence
oldpre
        (Output -> IO ()) -> Maybe Output -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (PriorityTree Output -> Output -> IO ()
enqueueOutput PriorityTree Output
outputQ) Maybe Output
mout
    StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
s

-- this ordering is important
stream FrameTypeId
FrameContinuation FrameHeader
_ ByteString
_ Context
_ StreamState
_ Stream
_ = HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"continue frame cannot come here"
stream FrameTypeId
_ FrameHeader
_ ByteString
_ Context
_ (Open Continued{}) Stream
_ = HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> ByteString -> HTTP2Error
ConnectionError ErrorCodeId
ProtocolError ByteString
"an illegal frame follows header/continuation frames"
-- Ignore frames to streams we have just reset, per section 5.1.
stream FrameTypeId
_ FrameHeader
_ ByteString
_ Context
_ st :: StreamState
st@(Closed (ResetByMe SomeException
_)) Stream
_ = StreamState -> IO StreamState
forall (m :: * -> *) a. Monad m => a -> m a
return StreamState
st
stream FrameTypeId
FrameData FrameHeader{BufferSize
streamId :: BufferSize
streamId :: FrameHeader -> BufferSize
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ = HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> BufferSize -> HTTP2Error
StreamError ErrorCodeId
StreamClosed BufferSize
streamId
stream FrameTypeId
_ FrameHeader{BufferSize
streamId :: BufferSize
streamId :: FrameHeader -> BufferSize
streamId} ByteString
_ Context
_ StreamState
_ Stream
_ = HTTP2Error -> IO StreamState
forall e a. Exception e => e -> IO a
E.throwIO (HTTP2Error -> IO StreamState) -> HTTP2Error -> IO StreamState
forall a b. (a -> b) -> a -> b
$ ErrorCodeId -> BufferSize -> HTTP2Error
StreamError ErrorCodeId
ProtocolError BufferSize
streamId

----------------------------------------------------------------

{-# INLINE newReadBody #-}
newReadBody :: TQueue ByteString -> IO (IO ByteString)
newReadBody :: TQueue ByteString -> IO (IO ByteString)
newReadBody TQueue ByteString
q = do
    IORef Bool
ref <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    IO ByteString -> IO (IO ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (IO ByteString -> IO (IO ByteString))
-> IO ByteString -> IO (IO ByteString)
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> IORef Bool -> IO ByteString
readBody TQueue ByteString
q IORef Bool
ref

{-# INLINE readBody #-}
readBody :: TQueue ByteString -> IORef Bool -> IO ByteString
readBody :: TQueue ByteString -> IORef Bool -> IO ByteString
readBody TQueue ByteString
q IORef Bool
ref = do
    Bool
eof <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
ref
    if Bool
eof then
        ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
""
      else do
        ByteString
bs <- STM ByteString -> IO ByteString
forall a. STM a -> IO a
atomically (STM ByteString -> IO ByteString)
-> STM ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ TQueue ByteString -> STM ByteString
forall a. TQueue a -> STM a
readTQueue TQueue ByteString
q
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
ref Bool
True
        ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bs