{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.HTTP2.H2.Sender (
    frameSender,
    fillBuilderBodyGetNext,
    fillFileBodyGetNext,
    fillStreamBodyGetNext,
    runTrailersMaker,
) where

import Control.Concurrent.MVar (putMVar)
import qualified Data.ByteString as BS
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder.Extra as B
import Data.IORef (modifyIORef', readIORef, writeIORef)
import Data.IntMap.Strict (IntMap)
import Foreign.Ptr (minusPtr, plusPtr)
import Network.ByteOrder
import qualified UnliftIO.Exception as E
import UnliftIO.STM

import Imports
import Network.HPACK (TokenHeaderList, setLimitForEncoding, toHeaderTable)
import Network.HTTP2.Frame
import Network.HTTP2.H2.Context
import Network.HTTP2.H2.EncodeFrame
import Network.HTTP2.H2.File
import Network.HTTP2.H2.HPACK
import Network.HTTP2.H2.Manager hiding (start)
import Network.HTTP2.H2.Queue
import Network.HTTP2.H2.Settings
import Network.HTTP2.H2.Stream
import Network.HTTP2.H2.StreamTable
import Network.HTTP2.H2.Types
import Network.HTTP2.H2.Window

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

data Leftover
    = LZero
    | LOne B.BufferWriter
    | LTwo ByteString B.BufferWriter

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

{-# INLINE waitStreaming #-}
waitStreaming :: TBQueue a -> IO ()
waitStreaming :: forall a. TBQueue a -> IO ()
waitStreaming TBQueue a
tbq = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
    Bool
isEmpty <- forall a. TBQueue a -> STM Bool
isEmptyTBQueue TBQueue a
tbq
    Bool -> STM ()
checkSTM (Bool -> Bool
not Bool
isEmpty)

data Switch
    = C Control
    | O (Output Stream)
    | Flush

wrapException :: E.SomeException -> IO ()
wrapException :: SomeException -> IO ()
wrapException SomeException
se
    | Just (HTTP2Error
e :: HTTP2Error) <- forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO HTTP2Error
e
    | Bool
otherwise = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$ SomeException -> HTTP2Error
BadThingHappen SomeException
se

-- Peer SETTINGS_INITIAL_WINDOW_SIZE
-- Adjusting initial window size for streams
updatePeerSettings :: Context -> SettingsList -> IO ()
updatePeerSettings :: Context -> SettingsList -> IO ()
updatePeerSettings Context{IORef Settings
peerSettings :: Context -> IORef Settings
peerSettings :: IORef Settings
peerSettings, TVar OddStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
oddStreamTable :: TVar OddStreamTable
oddStreamTable, TVar EvenStreamTable
evenStreamTable :: Context -> TVar EvenStreamTable
evenStreamTable :: TVar EvenStreamTable
evenStreamTable} SettingsList
peerAlist = do
    Int
oldws <- Settings -> Int
initialWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef Settings
peerSettings
    forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Settings
peerSettings forall a b. (a -> b) -> a -> b
$ \Settings
old -> Settings -> SettingsList -> Settings
fromSettingsList Settings
old SettingsList
peerAlist
    Int
newws <- Settings -> Int
initialWindowSize forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef Settings
peerSettings
    -- FIXME: race condition
    -- 1) newOddStream reads old peerSettings and
    --    insert it to its stream table after adjusting.
    -- 2) newOddStream reads new peerSettings and
    --    insert it to its stream table before adjusting.
    let dif :: Int
dif = Int
newws forall a. Num a => a -> a -> a
- Int
oldws
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dif forall a. Eq a => a -> a -> Bool
/= Int
0) forall a b. (a -> b) -> a -> b
$ do
        TVar OddStreamTable -> IO (IntMap Stream)
getOddStreams TVar OddStreamTable
oddStreamTable forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IntMap Stream -> IO ()
updateAllStreamTxFlow Int
dif
        TVar EvenStreamTable -> IO (IntMap Stream)
getEvenStreams TVar EvenStreamTable
evenStreamTable forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IntMap Stream -> IO ()
updateAllStreamTxFlow Int
dif
  where
    updateAllStreamTxFlow :: WindowSize -> IntMap Stream -> IO ()
    updateAllStreamTxFlow :: Int -> IntMap Stream -> IO ()
updateAllStreamTxFlow Int
siz IntMap Stream
strms =
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ IntMap Stream
strms forall a b. (a -> b) -> a -> b
$ \Stream
strm -> Stream -> Int -> IO ()
increaseStreamWindowSize Stream
strm Int
siz

frameSender :: Context -> Config -> Manager -> IO ()
frameSender :: Context -> Config -> Manager -> IO ()
frameSender
    ctx :: Context
ctx@Context{TQueue (Output Stream)
outputQ :: Context -> TQueue (Output Stream)
outputQ :: TQueue (Output Stream)
outputQ, TQueue Control
controlQ :: Context -> TQueue Control
controlQ :: TQueue Control
controlQ, DynamicTable
encodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable :: DynamicTable
encodeDynamicTable, IORef Int
outputBufferLimit :: Context -> IORef Int
outputBufferLimit :: IORef Int
outputBufferLimit}
    Config{Int
Buffer
Manager
SockAddr
Int -> IO HeaderValue
PositionReadMaker
HeaderValue -> IO ()
confPeerSockAddr :: Config -> SockAddr
confMySockAddr :: Config -> SockAddr
confTimeoutManager :: Config -> Manager
confPositionReadMaker :: Config -> PositionReadMaker
confReadN :: Config -> Int -> IO HeaderValue
confSendAll :: Config -> HeaderValue -> IO ()
confBufferSize :: Config -> Int
confWriteBuffer :: Config -> Buffer
confPeerSockAddr :: SockAddr
confMySockAddr :: SockAddr
confTimeoutManager :: Manager
confPositionReadMaker :: PositionReadMaker
confReadN :: Int -> IO HeaderValue
confSendAll :: HeaderValue -> IO ()
confBufferSize :: Int
confWriteBuffer :: Buffer
..}
    Manager
mgr = Int -> IO ()
loop Int
0 forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`E.catch` SomeException -> IO ()
wrapException
      where
        ----------------------------------------------------------------
        loop :: Offset -> IO ()
        loop :: Int -> IO ()
loop Int
off = do
            Switch
x <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ Int -> STM Switch
dequeue Int
off
            case Switch
x of
                C Control
ctl -> Int -> IO ()
flushN Int
off forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Control -> IO ()
control Control
ctl forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
loop Int
0
                O Output Stream
out -> Output Stream -> Int -> IO Int
outputOrEnqueueAgain Output Stream
out Int
off forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO Int
flushIfNecessary forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO ()
loop
                Switch
Flush -> Int -> IO ()
flushN Int
off forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
loop Int
0

        -- Flush the connection buffer to the socket, where the first 'n' bytes of
        -- the buffer are filled.
        flushN :: Offset -> IO ()
        flushN :: Int -> IO ()
flushN Int
0 = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        flushN Int
n = forall a. Buffer -> Int -> (HeaderValue -> IO a) -> IO a
bufferIO Buffer
confWriteBuffer Int
n HeaderValue -> IO ()
confSendAll

        flushIfNecessary :: Offset -> IO Offset
        flushIfNecessary :: Int -> IO Int
flushIfNecessary Int
off = do
            Int
buflim <- forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            if Int
off forall a. Ord a => a -> a -> Bool
<= Int
buflim forall a. Num a => a -> a -> a
- Int
512
                then forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                else do
                    Int -> IO ()
flushN Int
off
                    forall (m :: * -> *) a. Monad m => a -> m a
return Int
0

        dequeue :: Offset -> STM Switch
        dequeue :: Int -> STM Switch
dequeue Int
off = do
            Bool
isEmptyC <- forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Control
controlQ
            if Bool
isEmptyC
                then do
                    -- FLOW CONTROL: WINDOW_UPDATE 0: send: respecting peer's limit
                    Context -> STM ()
waitConnectionWindowSize Context
ctx
                    Bool
isEmptyO <- forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue (Output Stream)
outputQ
                    if Bool
isEmptyO
                        then if Int
off forall a. Eq a => a -> a -> Bool
/= Int
0 then forall (m :: * -> *) a. Monad m => a -> m a
return Switch
Flush else forall a. STM a
retrySTM
                        else Output Stream -> Switch
O forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TQueue a -> STM a
readTQueue TQueue (Output Stream)
outputQ
                else Control -> Switch
C forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TQueue a -> STM a
readTQueue TQueue Control
controlQ

        ----------------------------------------------------------------
        copyAll :: [HeaderValue] -> Buffer -> IO Buffer
copyAll [] Buffer
buf = forall (m :: * -> *) a. Monad m => a -> m a
return Buffer
buf
        copyAll (HeaderValue
x : [HeaderValue]
xs) Buffer
buf = Buffer -> HeaderValue -> IO Buffer
copy Buffer
buf HeaderValue
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [HeaderValue] -> Buffer -> IO Buffer
copyAll [HeaderValue]
xs

        -- called with off == 0
        control :: Control -> IO ()
        control :: Control -> IO ()
control (CFinish HTTP2Error
e) = forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO HTTP2Error
e
        control (CGoaway HeaderValue
bs MVar ()
mvar) = do
            Buffer
buf <- [HeaderValue] -> Buffer -> IO Buffer
copyAll [HeaderValue
bs] Buffer
confWriteBuffer
            let off :: Int
off = Buffer
buf forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Buffer
confWriteBuffer
            Int -> IO ()
flushN Int
off
            forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
            forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO HTTP2Error
GoAwayIsSent
        control (CFrames Maybe SettingsList
ms [HeaderValue]
xs) = do
            Buffer
buf <- [HeaderValue] -> Buffer -> IO Buffer
copyAll [HeaderValue]
xs Buffer
confWriteBuffer
            let off :: Int
off = Buffer
buf forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Buffer
confWriteBuffer
            Int -> IO ()
flushN Int
off
            case Maybe SettingsList
ms of
                Maybe SettingsList
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just SettingsList
peerAlist -> do
                    -- Peer SETTINGS_INITIAL_WINDOW_SIZE
                    Context -> SettingsList -> IO ()
updatePeerSettings Context
ctx SettingsList
peerAlist
                    -- Peer SETTINGS_MAX_FRAME_SIZE
                    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SettingsKey
SettingsMaxFrameSize SettingsList
peerAlist of
                        Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just Int
payloadLen -> do
                            let dlim :: Int
dlim = Int
payloadLen forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                                buflim :: Int
buflim
                                    | Int
confBufferSize forall a. Ord a => a -> a -> Bool
>= Int
dlim = Int
dlim
                                    | Bool
otherwise = Int
confBufferSize
                            forall a. IORef a -> a -> IO ()
writeIORef IORef Int
outputBufferLimit Int
buflim
                    -- Peer SETTINGS_HEADER_TABLE_SIZE
                    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SettingsKey
SettingsHeaderTableSize SettingsList
peerAlist of
                        Maybe Int
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just Int
siz -> Int -> DynamicTable -> IO ()
setLimitForEncoding Int
siz DynamicTable
encodeDynamicTable

        ----------------------------------------------------------------
        output :: Output Stream -> Offset -> WindowSize -> IO Offset
        output :: Output Stream -> Int -> Int -> IO Int
output out :: Output Stream
out@(Output Stream
strm OutObj{} (ONext DynaNext
curr TrailersMaker
tlrmkr) Maybe (TBQueue StreamingChunk)
_ IO ()
sentinel) Int
off0 Int
lim = do
            -- Data frame payload
            Int
buflim <- forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            let payloadOff :: Int
payloadOff = Int
off0 forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                datBuf :: Ptr b
datBuf = Buffer
confWriteBuffer forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
payloadOff
                datBufSiz :: Int
datBufSiz = Int
buflim forall a. Num a => a -> a -> a
- Int
payloadOff
            Next Int
datPayloadLen Bool
reqflush Maybe DynaNext
mnext <- DynaNext
curr forall {b}. Ptr b
datBuf Int
datBufSiz Int
lim -- checkme
            NextTrailersMaker TrailersMaker
tlrmkr' <- TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker
runTrailersMaker TrailersMaker
tlrmkr forall {b}. Ptr b
datBuf Int
datPayloadLen
            Stream
-> Int
-> Int
-> Maybe DynaNext
-> TrailersMaker
-> IO ()
-> Output Stream
-> Bool
-> IO Int
fillDataHeaderEnqueueNext
                Stream
strm
                Int
off0
                Int
datPayloadLen
                Maybe DynaNext
mnext
                TrailersMaker
tlrmkr'
                IO ()
sentinel
                Output Stream
out
                Bool
reqflush
        output out :: Output Stream
out@(Output Stream
strm (OutObj [Header]
hdr OutBody
body TrailersMaker
tlrmkr) OutputType
OObj Maybe (TBQueue StreamingChunk)
mtbq IO ()
_) Int
off0 Int
lim = do
            -- Header frame and Continuation frame
            let sid :: Int
sid = Stream -> Int
streamNumber Stream
strm
                endOfStream :: Bool
endOfStream = case OutBody
body of
                    OutBody
OutBodyNone -> Bool
True
                    OutBody
_ -> Bool
False
            (TokenHeaderList
ths, ValueTable
_) <- [Header] -> IO (TokenHeaderList, ValueTable)
toHeaderTable forall a b. (a -> b) -> a -> b
$ [Header] -> [Header]
fixHeaders [Header]
hdr
            Int
off' <- Int -> TokenHeaderList -> Bool -> Int -> IO Int
headerContinue Int
sid TokenHeaderList
ths Bool
endOfStream Int
off0
            -- halfClosedLocal calls closed which removes
            -- the stream from stream table.
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
endOfStream forall a b. (a -> b) -> a -> b
$ Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx Stream
strm ClosedCode
Finished
            Int
off <- Int -> IO Int
flushIfNecessary Int
off'
            case OutBody
body of
                OutBody
OutBodyNone -> forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                OutBodyFile (FileSpec FilePath
path Int64
fileoff Int64
bytecount) -> do
                    (PositionRead
pread, Sentinel
sentinel') <- PositionReadMaker
confPositionReadMaker FilePath
path
                    IO ()
refresh <- case Sentinel
sentinel' of
                        Closer IO ()
closer -> Manager -> IO () -> IO (IO ())
timeoutClose Manager
mgr IO ()
closer
                        Refresher IO ()
refresher -> forall (m :: * -> *) a. Monad m => a -> m a
return IO ()
refresher
                    let next :: DynaNext
next = PositionRead -> Int64 -> Int64 -> IO () -> DynaNext
fillFileBodyGetNext PositionRead
pread Int64
fileoff Int64
bytecount IO ()
refresh
                        out' :: Output Stream
out' = Output Stream
out{outputType :: OutputType
outputType = DynaNext -> TrailersMaker -> OutputType
ONext DynaNext
next TrailersMaker
tlrmkr}
                    Output Stream -> Int -> Int -> IO Int
output Output Stream
out' Int
off Int
lim
                OutBodyBuilder Builder
builder -> do
                    let next :: DynaNext
next = Builder -> DynaNext
fillBuilderBodyGetNext Builder
builder
                        out' :: Output Stream
out' = Output Stream
out{outputType :: OutputType
outputType = DynaNext -> TrailersMaker -> OutputType
ONext DynaNext
next TrailersMaker
tlrmkr}
                    Output Stream -> Int -> Int -> IO Int
output Output Stream
out' Int
off Int
lim
                OutBodyStreaming (Builder -> IO ()) -> IO () -> IO ()
_ ->
                    Output Stream -> Int -> Int -> IO Int
output (Maybe (TBQueue StreamingChunk)
-> TrailersMaker -> Output Stream -> Output Stream
setNextForStreaming Maybe (TBQueue StreamingChunk)
mtbq TrailersMaker
tlrmkr Output Stream
out) Int
off Int
lim
                OutBodyStreamingUnmask (forall x. IO x -> IO x) -> (Builder -> IO ()) -> IO () -> IO ()
_ ->
                    Output Stream -> Int -> Int -> IO Int
output (Maybe (TBQueue StreamingChunk)
-> TrailersMaker -> Output Stream -> Output Stream
setNextForStreaming Maybe (TBQueue StreamingChunk)
mtbq TrailersMaker
tlrmkr Output Stream
out) Int
off Int
lim
        output out :: Output Stream
out@(Output Stream
strm OutObj
_ (OPush TokenHeaderList
ths Int
pid) Maybe (TBQueue StreamingChunk)
_ IO ()
_) Int
off0 Int
lim = do
            -- Creating a push promise header
            -- Frame id should be associated stream id from the client.
            let sid :: Int
sid = Stream -> Int
streamNumber Stream
strm
            Int
len <- Int -> Int -> TokenHeaderList -> Int -> IO Int
pushPromise Int
pid Int
sid TokenHeaderList
ths Int
off0
            Int
off <- Int -> IO Int
flushIfNecessary forall a b. (a -> b) -> a -> b
$ Int
off0 forall a. Num a => a -> a -> a
+ Int
frameHeaderLength forall a. Num a => a -> a -> a
+ Int
len
            Output Stream -> Int -> Int -> IO Int
output Output Stream
out{outputType :: OutputType
outputType = OutputType
OObj} Int
off Int
lim
        output Output Stream
_ Int
_ Int
_ = forall a. HasCallStack => a
undefined -- never reach

        ----------------------------------------------------------------
        setNextForStreaming
            :: Maybe (TBQueue StreamingChunk)
            -> TrailersMaker
            -> Output Stream
            -> Output Stream
        setNextForStreaming :: Maybe (TBQueue StreamingChunk)
-> TrailersMaker -> Output Stream -> Output Stream
setNextForStreaming Maybe (TBQueue StreamingChunk)
mtbq TrailersMaker
tlrmkr Output Stream
out =
            let tbq :: TBQueue StreamingChunk
tbq = forall a. HasCallStack => Maybe a -> a
fromJust Maybe (TBQueue StreamingChunk)
mtbq
                takeQ :: IO (Maybe StreamingChunk)
takeQ = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> STM (Maybe a)
tryReadTBQueue TBQueue StreamingChunk
tbq
                next :: DynaNext
next = IO (Maybe StreamingChunk) -> DynaNext
fillStreamBodyGetNext IO (Maybe StreamingChunk)
takeQ
             in Output Stream
out{outputType :: OutputType
outputType = DynaNext -> TrailersMaker -> OutputType
ONext DynaNext
next TrailersMaker
tlrmkr}

        ----------------------------------------------------------------
        outputOrEnqueueAgain :: Output Stream -> Offset -> IO Offset
        outputOrEnqueueAgain :: Output Stream -> Int -> IO Int
outputOrEnqueueAgain out :: Output Stream
out@(Output Stream
strm OutObj
_ OutputType
otyp Maybe (TBQueue StreamingChunk)
_ IO ()
_) Int
off = forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
E.handle SomeException -> IO Int
resetStream forall a b. (a -> b) -> a -> b
$ do
            StreamState
state <- Stream -> IO StreamState
readStreamState Stream
strm
            if StreamState -> Bool
isHalfClosedLocal StreamState
state
                then forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                else case OutputType
otyp of
                    OWait IO ()
wait -> do
                        -- Checking if all push are done.
                        IO ()
-> TQueue (Output Stream) -> Output Stream -> Manager -> IO ()
forkAndEnqueueWhenReady IO ()
wait TQueue (Output Stream)
outputQ Output Stream
out{outputType :: OutputType
outputType = OutputType
OObj} Manager
mgr
                        forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                    OutputType
_ -> case Maybe (TBQueue StreamingChunk)
mtbq of
                        Just TBQueue StreamingChunk
tbq -> forall {a}. TBQueue a -> IO Int
checkStreaming TBQueue StreamingChunk
tbq
                        Maybe (TBQueue StreamingChunk)
_ -> IO Int
checkStreamWindowSize
          where
            mtbq :: Maybe (TBQueue StreamingChunk)
mtbq = forall a. Output a -> Maybe (TBQueue StreamingChunk)
outputStrmQ Output Stream
out
            checkStreaming :: TBQueue a -> IO Int
checkStreaming TBQueue a
tbq = do
                Bool
isEmpty <- forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TBQueue a -> STM Bool
isEmptyTBQueue TBQueue a
tbq
                if Bool
isEmpty
                    then do
                        IO ()
-> TQueue (Output Stream) -> Output Stream -> Manager -> IO ()
forkAndEnqueueWhenReady (forall a. TBQueue a -> IO ()
waitStreaming TBQueue a
tbq) TQueue (Output Stream)
outputQ Output Stream
out Manager
mgr
                        forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                    else IO Int
checkStreamWindowSize
            -- FLOW CONTROL: WINDOW_UPDATE: send: respecting peer's limit
            checkStreamWindowSize :: IO Int
checkStreamWindowSize = do
                Int
sws <- Stream -> IO Int
getStreamWindowSize Stream
strm
                if Int
sws forall a. Eq a => a -> a -> Bool
== Int
0
                    then do
                        IO ()
-> TQueue (Output Stream) -> Output Stream -> Manager -> IO ()
forkAndEnqueueWhenReady (Stream -> IO ()
waitStreamWindowSize Stream
strm) TQueue (Output Stream)
outputQ Output Stream
out Manager
mgr
                        forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                    else do
                        Int
cws <- Context -> IO Int
getConnectionWindowSize Context
ctx -- not 0
                        let lim :: Int
lim = forall a. Ord a => a -> a -> a
min Int
cws Int
sws
                        Output Stream -> Int -> Int -> IO Int
output Output Stream
out Int
off Int
lim
            resetStream :: SomeException -> IO Int
resetStream SomeException
e = do
                Context -> Stream -> ClosedCode -> IO ()
closed Context
ctx Stream
strm (SomeException -> ClosedCode
ResetByMe SomeException
e)
                let rst :: HeaderValue
rst = ErrorCode -> Int -> HeaderValue
resetFrame ErrorCode
InternalError forall a b. (a -> b) -> a -> b
$ Stream -> Int
streamNumber Stream
strm
                TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [HeaderValue] -> Control
CFrames forall a. Maybe a
Nothing [HeaderValue
rst]
                forall (m :: * -> *) a. Monad m => a -> m a
return Int
off

        ----------------------------------------------------------------
        headerContinue :: StreamId -> TokenHeaderList -> Bool -> Offset -> IO Offset
        headerContinue :: Int -> TokenHeaderList -> Bool -> Int -> IO Int
headerContinue Int
sid TokenHeaderList
ths0 Bool
endOfStream Int
off0 = do
            Int
buflim <- forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            let offkv :: Int
offkv = Int
off0 forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                bufkv :: Ptr b
bufkv = Buffer
confWriteBuffer forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offkv
                limkv :: Int
limkv = Int
buflim forall a. Num a => a -> a -> a
- Int
offkv
            (TokenHeaderList
ths, Int
kvlen) <- Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeader Context
ctx forall {b}. Ptr b
bufkv Int
limkv TokenHeaderList
ths0
            if Int
kvlen forall a. Eq a => a -> a -> Bool
== Int
0
                then Int -> TokenHeaderList -> FrameType -> IO Int
continue Int
off0 TokenHeaderList
ths FrameType
FrameHeaders
                else do
                    let flag :: FrameFlags
flag = forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths
                        buf :: Ptr b
buf = Buffer
confWriteBuffer forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off0
                        off :: Int
off = Int
offkv forall a. Num a => a -> a -> a
+ Int
kvlen
                    FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FrameHeaders Int
kvlen Int
sid FrameFlags
flag forall {b}. Ptr b
buf
                    Int -> TokenHeaderList -> FrameType -> IO Int
continue Int
off TokenHeaderList
ths FrameType
FrameContinuation
          where
            eos :: FrameFlags -> FrameFlags
eos = if Bool
endOfStream then FrameFlags -> FrameFlags
setEndStream else forall a. a -> a
id
            getFlag :: [a] -> FrameFlags
getFlag [] = FrameFlags -> FrameFlags
eos forall a b. (a -> b) -> a -> b
$ FrameFlags -> FrameFlags
setEndHeader FrameFlags
defaultFlags
            getFlag [a]
_ = FrameFlags -> FrameFlags
eos forall a b. (a -> b) -> a -> b
$ FrameFlags
defaultFlags

            continue :: Offset -> TokenHeaderList -> FrameType -> IO Offset
            continue :: Int -> TokenHeaderList -> FrameType -> IO Int
continue Int
off [] FrameType
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
            continue Int
off TokenHeaderList
ths FrameType
ft = do
                Int -> IO ()
flushN Int
off
                -- Now off is 0
                Int
buflim <- forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
                let bufHeaderPayload :: Ptr b
bufHeaderPayload = Buffer
confWriteBuffer forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
frameHeaderLength

                    headerPayloadLim :: Int
headerPayloadLim = Int
buflim forall a. Num a => a -> a -> a
- Int
frameHeaderLength
                (TokenHeaderList
ths', Int
kvlen') <-
                    Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeaderLoop Context
ctx forall {b}. Ptr b
bufHeaderPayload Int
headerPayloadLim TokenHeaderList
ths
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TokenHeaderList
ths forall a. Eq a => a -> a -> Bool
== TokenHeaderList
ths') forall a b. (a -> b) -> a -> b
$
                    forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO forall a b. (a -> b) -> a -> b
$
                        ErrorCode -> Int -> ReasonPhrase -> HTTP2Error
ConnectionErrorIsSent ErrorCode
CompressionError Int
sid ReasonPhrase
"cannot compress the header"
                let flag :: FrameFlags
flag = forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths'
                    off' :: Int
off' = Int
frameHeaderLength forall a. Num a => a -> a -> a
+ Int
kvlen'
                FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
ft Int
kvlen' Int
sid FrameFlags
flag Buffer
confWriteBuffer
                Int -> TokenHeaderList -> FrameType -> IO Int
continue Int
off' TokenHeaderList
ths' FrameType
FrameContinuation

        ----------------------------------------------------------------
        fillDataHeaderEnqueueNext
            :: Stream
            -> Offset
            -> Int
            -> Maybe DynaNext
            -> (Maybe ByteString -> IO NextTrailersMaker)
            -> IO ()
            -> Output Stream
            -> Bool
            -> IO Offset
        fillDataHeaderEnqueueNext :: Stream
-> Int
-> Int
-> Maybe DynaNext
-> TrailersMaker
-> IO ()
-> Output Stream
-> Bool
-> IO Int
fillDataHeaderEnqueueNext
            strm :: Stream
strm@Stream{Int
streamNumber :: Int
streamNumber :: Stream -> Int
streamNumber}
            Int
off
            Int
datPayloadLen
            Maybe DynaNext
Nothing
            TrailersMaker
tlrmkr
            IO ()
tell
            Output Stream
_
            Bool
reqflush = do
                let buf :: Ptr b
buf = Buffer
confWriteBuffer forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                    off' :: Int
off' = Int
off forall a. Num a => a -> a -> a
+ Int
frameHeaderLength forall a. Num a => a -> a -> a
+ Int
datPayloadLen
                (Maybe [Header]
mtrailers, FrameFlags
flag) <- do
                    Trailers [Header]
trailers <- TrailersMaker
tlrmkr forall a. Maybe a
Nothing
                    if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Header]
trailers
                        then forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, FrameFlags -> FrameFlags
setEndStream FrameFlags
defaultFlags)
                        else forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just [Header]
trailers, FrameFlags
defaultFlags)
                FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FrameData Int
datPayloadLen Int
streamNumber FrameFlags
flag forall {b}. Ptr b
buf
                Int
off'' <- Maybe [Header] -> Int -> IO Int
handleTrailers Maybe [Header]
mtrailers Int
off'
                forall (f :: * -> *) a. Functor f => f a -> f ()
void IO ()
tell
                Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx Stream
strm ClosedCode
Finished
                Context -> Stream -> Int -> IO ()
decreaseWindowSize Context
ctx Stream
strm Int
datPayloadLen
                if Bool
reqflush
                    then do
                        Int -> IO ()
flushN Int
off''
                        forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
                    else forall (m :: * -> *) a. Monad m => a -> m a
return Int
off''
              where
                handleTrailers :: Maybe [Header] -> Int -> IO Int
handleTrailers Maybe [Header]
Nothing Int
off0 = forall (m :: * -> *) a. Monad m => a -> m a
return Int
off0
                handleTrailers (Just [Header]
trailers) Int
off0 = do
                    (TokenHeaderList
ths, ValueTable
_) <- [Header] -> IO (TokenHeaderList, ValueTable)
toHeaderTable [Header]
trailers
                    Int -> TokenHeaderList -> Bool -> Int -> IO Int
headerContinue Int
streamNumber TokenHeaderList
ths Bool
True {- endOfStream -} Int
off0
        fillDataHeaderEnqueueNext
            Stream
_
            Int
off
            Int
0
            (Just DynaNext
next)
            TrailersMaker
tlrmkr
            IO ()
_
            Output Stream
out
            Bool
reqflush = do
                let out' :: Output Stream
out' = Output Stream
out{outputType :: OutputType
outputType = DynaNext -> TrailersMaker -> OutputType
ONext DynaNext
next TrailersMaker
tlrmkr}
                TQueue (Output Stream) -> Output Stream -> IO ()
enqueueOutput TQueue (Output Stream)
outputQ Output Stream
out'
                if Bool
reqflush
                    then do
                        Int -> IO ()
flushN Int
off
                        forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
                    else forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
        fillDataHeaderEnqueueNext
            strm :: Stream
strm@Stream{Int
streamNumber :: Int
streamNumber :: Stream -> Int
streamNumber}
            Int
off
            Int
datPayloadLen
            (Just DynaNext
next)
            TrailersMaker
tlrmkr
            IO ()
_
            Output Stream
out
            Bool
reqflush = do
                let buf :: Ptr b
buf = Buffer
confWriteBuffer forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                    off' :: Int
off' = Int
off forall a. Num a => a -> a -> a
+ Int
frameHeaderLength forall a. Num a => a -> a -> a
+ Int
datPayloadLen
                    flag :: FrameFlags
flag = FrameFlags
defaultFlags
                FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FrameData Int
datPayloadLen Int
streamNumber FrameFlags
flag forall {b}. Ptr b
buf
                Context -> Stream -> Int -> IO ()
decreaseWindowSize Context
ctx Stream
strm Int
datPayloadLen
                let out' :: Output Stream
out' = Output Stream
out{outputType :: OutputType
outputType = DynaNext -> TrailersMaker -> OutputType
ONext DynaNext
next TrailersMaker
tlrmkr}
                TQueue (Output Stream) -> Output Stream -> IO ()
enqueueOutput TQueue (Output Stream)
outputQ Output Stream
out'
                if Bool
reqflush
                    then do
                        Int -> IO ()
flushN Int
off'
                        forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
                    else forall (m :: * -> *) a. Monad m => a -> m a
return Int
off'

        ----------------------------------------------------------------
        pushPromise :: StreamId -> StreamId -> TokenHeaderList -> Offset -> IO Int
        pushPromise :: Int -> Int -> TokenHeaderList -> Int -> IO Int
pushPromise Int
pid Int
sid TokenHeaderList
ths Int
off = do
            let offsid :: Int
offsid = Int
off forall a. Num a => a -> a -> a
+ Int
frameHeaderLength -- checkme
                bufsid :: Ptr b
bufsid = Buffer
confWriteBuffer forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offsid
            Word32 -> Buffer -> Int -> IO ()
poke32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sid) forall {b}. Ptr b
bufsid Int
0
            let offkv :: Int
offkv = Int
offsid forall a. Num a => a -> a -> a
+ Int
4
                bufkv :: Ptr b
bufkv = Buffer
confWriteBuffer forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offkv
                limkv :: Int
limkv = Int
confBufferSize forall a. Num a => a -> a -> a
- Int
offkv
            (TokenHeaderList
_, Int
kvlen) <- Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeader Context
ctx forall {b}. Ptr b
bufkv Int
limkv TokenHeaderList
ths
            let flag :: FrameFlags
flag = FrameFlags -> FrameFlags
setEndHeader FrameFlags
defaultFlags -- No EndStream flag
                buf :: Ptr b
buf = Buffer
confWriteBuffer forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                len :: Int
len = Int
kvlen forall a. Num a => a -> a -> a
+ Int
4
            FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FramePushPromise Int
len Int
pid FrameFlags
flag forall {b}. Ptr b
buf
            forall (m :: * -> *) a. Monad m => a -> m a
return Int
len

        ----------------------------------------------------------------
        {-# INLINE fillFrameHeader #-}
        fillFrameHeader :: FrameType -> Int -> StreamId -> FrameFlags -> Buffer -> IO ()
        fillFrameHeader :: FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
ftyp Int
len Int
sid FrameFlags
flag Buffer
buf = FrameType -> FrameHeader -> Buffer -> IO ()
encodeFrameHeaderBuf FrameType
ftyp FrameHeader
hinfo Buffer
buf
          where
            hinfo :: FrameHeader
hinfo =
                FrameHeader
                    { payloadLength :: Int
payloadLength = Int
len
                    , flags :: FrameFlags
flags = FrameFlags
flag
                    , streamId :: Int
streamId = Int
sid
                    }

-- | Running trailers-maker.
--
-- > bufferIO buf siz $ \bs -> tlrmkr (Just bs)
runTrailersMaker :: TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker
runTrailersMaker :: TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker
runTrailersMaker TrailersMaker
tlrmkr Buffer
buf Int
siz = forall a. Buffer -> Int -> (HeaderValue -> IO a) -> IO a
bufferIO Buffer
buf Int
siz forall a b. (a -> b) -> a -> b
$ \HeaderValue
bs -> TrailersMaker
tlrmkr (forall a. a -> Maybe a
Just HeaderValue
bs)

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

fillBuilderBodyGetNext :: Builder -> DynaNext
fillBuilderBodyGetNext :: Builder -> DynaNext
fillBuilderBodyGetNext Builder
bb Buffer
buf Int
siz Int
lim = do
    let room :: Int
room = forall a. Ord a => a -> a -> a
min Int
siz Int
lim
    (Int
len, Next
signal) <- Builder -> BufferWriter
B.runBuilder Builder
bb Buffer
buf Int
room
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Next -> Next
nextForBuilder Int
len Next
signal

fillFileBodyGetNext
    :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext
fillFileBodyGetNext :: PositionRead -> Int64 -> Int64 -> IO () -> DynaNext
fillFileBodyGetNext PositionRead
pread Int64
start Int64
bytecount IO ()
refresh Buffer
buf Int
siz Int
lim = do
    let room :: Int
room = forall a. Ord a => a -> a -> a
min Int
siz Int
lim
    Int64
len <- PositionRead
pread Int64
start (Int -> Int64 -> Int64
mini Int
room Int64
bytecount) Buffer
buf
    let len' :: Int
len' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> PositionRead -> Int64 -> Int64 -> IO () -> Next
nextForFile Int
len' PositionRead
pread (Int64
start forall a. Num a => a -> a -> a
+ Int64
len) (Int64
bytecount forall a. Num a => a -> a -> a
- Int64
len) IO ()
refresh

fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext
fillStreamBodyGetNext :: IO (Maybe StreamingChunk) -> DynaNext
fillStreamBodyGetNext IO (Maybe StreamingChunk)
takeQ Buffer
buf Int
siz Int
lim = do
    let room :: Int
room = forall a. Ord a => a -> a -> a
min Int
siz Int
lim
    (Bool
cont, Int
len, Bool
reqflush, Leftover
leftover) <- Buffer
-> Int
-> IO (Maybe StreamingChunk)
-> IO (Bool, Int, Bool, Leftover)
runStreamBuilder Buffer
buf Int
room IO (Maybe StreamingChunk)
takeQ
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
-> Int -> Bool -> Leftover -> IO (Maybe StreamingChunk) -> Next
nextForStream Bool
cont Int
len Bool
reqflush Leftover
leftover IO (Maybe StreamingChunk)
takeQ

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

fillBufBuilder :: Leftover -> DynaNext
fillBufBuilder :: Leftover -> DynaNext
fillBufBuilder Leftover
leftover Buffer
buf0 Int
siz0 Int
lim = do
    let room :: Int
room = forall a. Ord a => a -> a -> a
min Int
siz0 Int
lim
    case Leftover
leftover of
        Leftover
LZero -> forall a. HasCallStack => FilePath -> a
error FilePath
"fillBufBuilder: LZero"
        LOne BufferWriter
writer -> do
            (Int
len, Next
signal) <- BufferWriter
writer Buffer
buf0 Int
room
            forall {m :: * -> *}. Monad m => Int -> Next -> m Next
getNext Int
len Next
signal
        LTwo HeaderValue
bs BufferWriter
writer
            | HeaderValue -> Int
BS.length HeaderValue
bs forall a. Ord a => a -> a -> Bool
<= Int
room -> do
                Buffer
buf1 <- Buffer -> HeaderValue -> IO Buffer
copy Buffer
buf0 HeaderValue
bs
                let len1 :: Int
len1 = HeaderValue -> Int
BS.length HeaderValue
bs
                (Int
len2, Next
signal) <- BufferWriter
writer Buffer
buf1 (Int
room forall a. Num a => a -> a -> a
- Int
len1)
                forall {m :: * -> *}. Monad m => Int -> Next -> m Next
getNext (Int
len1 forall a. Num a => a -> a -> a
+ Int
len2) Next
signal
            | Bool
otherwise -> do
                let (HeaderValue
bs1, HeaderValue
bs2) = Int -> HeaderValue -> (HeaderValue, HeaderValue)
BS.splitAt Int
room HeaderValue
bs
                forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Buffer -> HeaderValue -> IO Buffer
copy Buffer
buf0 HeaderValue
bs1
                forall {m :: * -> *}. Monad m => Int -> Next -> m Next
getNext Int
room (HeaderValue -> BufferWriter -> Next
B.Chunk HeaderValue
bs2 BufferWriter
writer)
  where
    getNext :: Int -> Next -> m Next
getNext Int
l Next
s = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Next -> Next
nextForBuilder Int
l Next
s

nextForBuilder :: BytesFilled -> B.Next -> Next
nextForBuilder :: Int -> Next -> Next
nextForBuilder Int
len Next
B.Done =
    Int -> Bool -> Maybe DynaNext -> Next
Next Int
len Bool
True forall a. Maybe a
Nothing -- let's flush
nextForBuilder Int
len (B.More Int
_ BufferWriter
writer) =
    Int -> Bool -> Maybe DynaNext -> Next
Next Int
len Bool
False forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Leftover -> DynaNext
fillBufBuilder (BufferWriter -> Leftover
LOne BufferWriter
writer))
nextForBuilder Int
len (B.Chunk HeaderValue
bs BufferWriter
writer) =
    Int -> Bool -> Maybe DynaNext -> Next
Next Int
len Bool
False forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Leftover -> DynaNext
fillBufBuilder (HeaderValue -> BufferWriter -> Leftover
LTwo HeaderValue
bs BufferWriter
writer))

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

runStreamBuilder
    :: Buffer
    -> BufferSize
    -> IO (Maybe StreamingChunk)
    -> IO
        ( Bool -- continue
        , BytesFilled
        , Bool -- require flusing
        , Leftover
        )
runStreamBuilder :: Buffer
-> Int
-> IO (Maybe StreamingChunk)
-> IO (Bool, Int, Bool, Leftover)
runStreamBuilder Buffer
buf0 Int
room0 IO (Maybe StreamingChunk)
takeQ = Buffer -> Int -> Int -> IO (Bool, Int, Bool, Leftover)
loop Buffer
buf0 Int
room0 Int
0
  where
    loop :: Buffer -> Int -> Int -> IO (Bool, Int, Bool, Leftover)
loop Buffer
buf Int
room Int
total = do
        Maybe StreamingChunk
mbuilder <- IO (Maybe StreamingChunk)
takeQ
        case Maybe StreamingChunk
mbuilder of
            Maybe StreamingChunk
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Int
total, Bool
False, Leftover
LZero)
            Just (StreamingBuilder Builder
builder) -> do
                (Int
len, Next
signal) <- Builder -> BufferWriter
B.runBuilder Builder
builder Buffer
buf Int
room
                let total' :: Int
total' = Int
total forall a. Num a => a -> a -> a
+ Int
len
                case Next
signal of
                    Next
B.Done -> Buffer -> Int -> Int -> IO (Bool, Int, Bool, Leftover)
loop (Buffer
buf forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len) (Int
room forall a. Num a => a -> a -> a
- Int
len) Int
total'
                    B.More Int
_ BufferWriter
writer -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Int
total', Bool
False, BufferWriter -> Leftover
LOne BufferWriter
writer)
                    B.Chunk HeaderValue
bs BufferWriter
writer -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Int
total', Bool
False, HeaderValue -> BufferWriter -> Leftover
LTwo HeaderValue
bs BufferWriter
writer)
            Just StreamingChunk
StreamingFlush -> forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Int
total, Bool
True, Leftover
LZero)
            Just (StreamingFinished IO ()
dec) -> do
                IO ()
dec
                forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Int
total, Bool
True, Leftover
LZero)

fillBufStream :: Leftover -> IO (Maybe StreamingChunk) -> DynaNext
fillBufStream :: Leftover -> IO (Maybe StreamingChunk) -> DynaNext
fillBufStream Leftover
leftover0 IO (Maybe StreamingChunk)
takeQ Buffer
buf0 Int
siz0 Int
lim0 = do
    let room0 :: Int
room0 = forall a. Ord a => a -> a -> a
min Int
siz0 Int
lim0
    case Leftover
leftover0 of
        Leftover
LZero -> do
            (Bool
cont, Int
len, Bool
reqflush, Leftover
leftover) <- Buffer
-> Int
-> IO (Maybe StreamingChunk)
-> IO (Bool, Int, Bool, Leftover)
runStreamBuilder Buffer
buf0 Int
room0 IO (Maybe StreamingChunk)
takeQ
            Bool -> Int -> Bool -> Leftover -> IO Next
getNext Bool
cont Int
len Bool
reqflush Leftover
leftover
        LOne BufferWriter
writer -> BufferWriter -> DynaNext
write BufferWriter
writer Buffer
buf0 Int
room0 Int
0
        LTwo HeaderValue
bs BufferWriter
writer
            | HeaderValue -> Int
BS.length HeaderValue
bs forall a. Ord a => a -> a -> Bool
<= Int
room0 -> do
                Buffer
buf1 <- Buffer -> HeaderValue -> IO Buffer
copy Buffer
buf0 HeaderValue
bs
                let len :: Int
len = HeaderValue -> Int
BS.length HeaderValue
bs
                BufferWriter -> DynaNext
write BufferWriter
writer Buffer
buf1 (Int
room0 forall a. Num a => a -> a -> a
- Int
len) Int
len
            | Bool
otherwise -> do
                let (HeaderValue
bs1, HeaderValue
bs2) = Int -> HeaderValue -> (HeaderValue, HeaderValue)
BS.splitAt Int
room0 HeaderValue
bs
                forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Buffer -> HeaderValue -> IO Buffer
copy Buffer
buf0 HeaderValue
bs1
                Bool -> Int -> Bool -> Leftover -> IO Next
getNext Bool
True Int
room0 Bool
False forall a b. (a -> b) -> a -> b
$ HeaderValue -> BufferWriter -> Leftover
LTwo HeaderValue
bs2 BufferWriter
writer
  where
    getNext :: Bool -> BytesFilled -> Bool -> Leftover -> IO Next
    getNext :: Bool -> Int -> Bool -> Leftover -> IO Next
getNext Bool
cont Int
len Bool
reqflush Leftover
l = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
-> Int -> Bool -> Leftover -> IO (Maybe StreamingChunk) -> Next
nextForStream Bool
cont Int
len Bool
reqflush Leftover
l IO (Maybe StreamingChunk)
takeQ

    write
        :: (Buffer -> BufferSize -> IO (Int, B.Next))
        -> Buffer
        -> BufferSize
        -> Int
        -> IO Next
    write :: BufferWriter -> DynaNext
write BufferWriter
writer1 Buffer
buf Int
room Int
sofar = do
        (Int
len, Next
signal) <- BufferWriter
writer1 Buffer
buf Int
room
        case Next
signal of
            Next
B.Done -> do
                (Bool
cont, Int
extra, Bool
reqflush, Leftover
leftover) <-
                    Buffer
-> Int
-> IO (Maybe StreamingChunk)
-> IO (Bool, Int, Bool, Leftover)
runStreamBuilder (Buffer
buf forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len) (Int
room forall a. Num a => a -> a -> a
- Int
len) IO (Maybe StreamingChunk)
takeQ
                let total :: Int
total = Int
sofar forall a. Num a => a -> a -> a
+ Int
len forall a. Num a => a -> a -> a
+ Int
extra
                Bool -> Int -> Bool -> Leftover -> IO Next
getNext Bool
cont Int
total Bool
reqflush Leftover
leftover
            B.More Int
_ BufferWriter
writer -> do
                let total :: Int
total = Int
sofar forall a. Num a => a -> a -> a
+ Int
len
                Bool -> Int -> Bool -> Leftover -> IO Next
getNext Bool
True Int
total Bool
False forall a b. (a -> b) -> a -> b
$ BufferWriter -> Leftover
LOne BufferWriter
writer
            B.Chunk HeaderValue
bs BufferWriter
writer -> do
                let total :: Int
total = Int
sofar forall a. Num a => a -> a -> a
+ Int
len
                Bool -> Int -> Bool -> Leftover -> IO Next
getNext Bool
True Int
total Bool
False forall a b. (a -> b) -> a -> b
$ HeaderValue -> BufferWriter -> Leftover
LTwo HeaderValue
bs BufferWriter
writer

nextForStream
    :: Bool
    -> BytesFilled
    -> Bool
    -> Leftover
    -> IO (Maybe StreamingChunk)
    -> Next
nextForStream :: Bool
-> Int -> Bool -> Leftover -> IO (Maybe StreamingChunk) -> Next
nextForStream Bool
False Int
len Bool
reqflush Leftover
_ IO (Maybe StreamingChunk)
_ = Int -> Bool -> Maybe DynaNext -> Next
Next Int
len Bool
reqflush forall a. Maybe a
Nothing
nextForStream Bool
True Int
len Bool
reqflush Leftover
leftOrZero IO (Maybe StreamingChunk)
takeQ =
    Int -> Bool -> Maybe DynaNext -> Next
Next Int
len Bool
reqflush forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Leftover -> IO (Maybe StreamingChunk) -> DynaNext
fillBufStream Leftover
leftOrZero IO (Maybe StreamingChunk)
takeQ)

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

fillBufFile :: PositionRead -> FileOffset -> ByteCount -> IO () -> DynaNext
fillBufFile :: PositionRead -> Int64 -> Int64 -> IO () -> DynaNext
fillBufFile PositionRead
pread Int64
start Int64
bytes IO ()
refresh Buffer
buf Int
siz Int
lim = do
    let room :: Int
room = forall a. Ord a => a -> a -> a
min Int
siz Int
lim
    Int64
len <- PositionRead
pread Int64
start (Int -> Int64 -> Int64
mini Int
room Int64
bytes) Buffer
buf
    IO ()
refresh
    let len' :: Int
len' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> PositionRead -> Int64 -> Int64 -> IO () -> Next
nextForFile Int
len' PositionRead
pread (Int64
start forall a. Num a => a -> a -> a
+ Int64
len) (Int64
bytes forall a. Num a => a -> a -> a
- Int64
len) IO ()
refresh

nextForFile
    :: BytesFilled -> PositionRead -> FileOffset -> ByteCount -> IO () -> Next
nextForFile :: Int -> PositionRead -> Int64 -> Int64 -> IO () -> Next
nextForFile Int
0 PositionRead
_ Int64
_ Int64
_ IO ()
_ = Int -> Bool -> Maybe DynaNext -> Next
Next Int
0 Bool
True forall a. Maybe a
Nothing -- let's flush
nextForFile Int
len PositionRead
_ Int64
_ Int64
0 IO ()
_ = Int -> Bool -> Maybe DynaNext -> Next
Next Int
len Bool
False forall a. Maybe a
Nothing
nextForFile Int
len PositionRead
pread Int64
start Int64
bytes IO ()
refresh =
    Int -> Bool -> Maybe DynaNext -> Next
Next Int
len Bool
False forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PositionRead -> Int64 -> Int64 -> IO () -> DynaNext
fillBufFile PositionRead
pread Int64
start Int64
bytes IO ()
refresh

{-# INLINE mini #-}
mini :: Int -> Int64 -> Int64
mini :: Int -> Int64 -> Int64
mini Int
i Int64
n
    | forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i forall a. Ord a => a -> a -> Bool
< Int64
n = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
    | Bool
otherwise = Int64
n