{-# 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 = STM () -> IO ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool
isEmpty <- TBQueue a -> STM Bool
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) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
E.fromException SomeException
se = HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO HTTP2Error
e
    | Bool
otherwise = HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
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 :: IORef Settings
peerSettings :: Context -> IORef Settings
peerSettings, TVar OddStreamTable
oddStreamTable :: TVar OddStreamTable
oddStreamTable :: Context -> TVar OddStreamTable
oddStreamTable, TVar EvenStreamTable
evenStreamTable :: TVar EvenStreamTable
evenStreamTable :: Context -> TVar EvenStreamTable
evenStreamTable} SettingsList
peerAlist = do
    Int
oldws <- Settings -> Int
initialWindowSize (Settings -> Int) -> IO Settings -> IO Int
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
peerSettings
    IORef Settings -> (Settings -> Settings) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Settings
peerSettings ((Settings -> Settings) -> IO ())
-> (Settings -> Settings) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Settings
old -> Settings -> SettingsList -> Settings
fromSettingsList Settings
old SettingsList
peerAlist
    Int
newws <- Settings -> Int
initialWindowSize (Settings -> Int) -> IO Settings -> IO Int
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
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldws
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
dif Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        TVar OddStreamTable -> IO (IntMap Stream)
getOddStreams TVar OddStreamTable
oddStreamTable IO (IntMap Stream) -> (IntMap Stream -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 IO (IntMap Stream) -> (IntMap Stream -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
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 =
        IntMap Stream -> (Stream -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ IntMap Stream
strms ((Stream -> IO ()) -> IO ()) -> (Stream -> IO ()) -> IO ()
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 :: TQueue (Output Stream)
outputQ :: Context -> TQueue (Output Stream)
outputQ, TQueue Control
controlQ :: TQueue Control
controlQ :: Context -> TQueue Control
controlQ, DynamicTable
encodeDynamicTable :: DynamicTable
encodeDynamicTable :: Context -> DynamicTable
encodeDynamicTable, IORef Int
outputBufferLimit :: IORef Int
outputBufferLimit :: Context -> IORef Int
outputBufferLimit}
    Config{Int
Buffer
Manager
SockAddr
Int -> IO HeaderValue
PositionReadMaker
HeaderValue -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: HeaderValue -> IO ()
confReadN :: Int -> IO HeaderValue
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confMySockAddr :: SockAddr
confPeerSockAddr :: SockAddr
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> Int
confSendAll :: Config -> HeaderValue -> IO ()
confReadN :: Config -> Int -> IO HeaderValue
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
confMySockAddr :: Config -> SockAddr
confPeerSockAddr :: Config -> SockAddr
..}
    Manager
mgr = Int -> IO ()
loop Int
0 IO () -> (SomeException -> IO ()) -> IO ()
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 <- STM Switch -> IO Switch
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Switch -> IO Switch) -> STM Switch -> IO Switch
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 IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Control -> IO ()
control Control
ctl IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 IO Int -> (Int -> IO Int) -> IO Int
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO Int
flushIfNecessary IO Int -> (Int -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> IO ()
loop
                Switch
Flush -> Int -> IO ()
flushN Int
off IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        flushN Int
n = Buffer -> Int -> (HeaderValue -> IO ()) -> IO ()
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 <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            if Int
off Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
512
                then Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                else do
                    Int -> IO ()
flushN Int
off
                    Int -> IO Int
forall a. a -> IO a
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 <- TQueue Control -> STM Bool
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 <- TQueue (Output Stream) -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue (Output Stream)
outputQ
                    if Bool
isEmptyO
                        then if Int
off Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0 then Switch -> STM Switch
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return Switch
Flush else STM Switch
forall a. STM a
retrySTM
                        else Output Stream -> Switch
O (Output Stream -> Switch) -> STM (Output Stream) -> STM Switch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue (Output Stream) -> STM (Output Stream)
forall a. TQueue a -> STM a
readTQueue TQueue (Output Stream)
outputQ
                else Control -> Switch
C (Control -> Switch) -> STM Control -> STM Switch
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TQueue Control -> STM Control
forall a. TQueue a -> STM a
readTQueue TQueue Control
controlQ

        ----------------------------------------------------------------
        copyAll :: [HeaderValue] -> Buffer -> IO Buffer
copyAll [] Buffer
buf = Buffer -> IO Buffer
forall a. a -> IO a
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 IO Buffer -> (Buffer -> IO Buffer) -> IO Buffer
forall a b. IO a -> (a -> IO b) -> IO b
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) = HTTP2Error -> IO ()
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 Buffer -> Buffer -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Buffer
confWriteBuffer
            Int -> IO ()
flushN Int
off
            MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
mvar ()
            HTTP2Error -> IO ()
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 Buffer -> Buffer -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Buffer
confWriteBuffer
            Int -> IO ()
flushN Int
off
            case Maybe SettingsList
ms of
                Maybe SettingsList
Nothing -> () -> IO ()
forall a. a -> IO a
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 SettingsKey -> SettingsList -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SettingsKey
SettingsMaxFrameSize SettingsList
peerAlist of
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Just Int
payloadLen -> do
                            let dlim :: Int
dlim = Int
payloadLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                                buflim :: Int
buflim
                                    | Int
confBufferSize Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
dlim = Int
dlim
                                    | Bool
otherwise = Int
confBufferSize
                            IORef Int -> Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Int
outputBufferLimit Int
buflim
                    -- Peer SETTINGS_HEADER_TABLE_SIZE
                    case SettingsKey -> SettingsList -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup SettingsKey
SettingsHeaderTableSize SettingsList
peerAlist of
                        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
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 <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            let payloadOff :: Int
payloadOff = Int
off0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                datBuf :: Ptr b
datBuf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
payloadOff
                datBufSiz :: Int
datBufSiz = Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
payloadOff
            Next Int
datPayloadLen Bool
reqflush Maybe DynaNext
mnext <- DynaNext
curr Buffer
forall {b}. Ptr b
datBuf Int
datBufSiz Int
lim -- checkme
            NextTrailersMaker TrailersMaker
tlrmkr' <- TrailersMaker -> Buffer -> Int -> IO NextTrailersMaker
runTrailersMaker TrailersMaker
tlrmkr Buffer
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 ([Header] -> IO (TokenHeaderList, ValueTable))
-> [Header] -> IO (TokenHeaderList, ValueTable)
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.
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
endOfStream (IO () -> IO ()) -> IO () -> IO ()
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 -> Int -> IO Int
forall a. a -> IO a
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 -> IO () -> IO (IO ())
forall a. a -> IO a
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 = ONext next 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 = ONext next 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 (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ Int
off0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
            Output Stream -> Int -> Int -> IO Int
output Output Stream
out{outputType = OObj} Int
off Int
lim
        output Output Stream
_ Int
_ Int
_ = IO 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 = Maybe (TBQueue StreamingChunk) -> TBQueue StreamingChunk
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (TBQueue StreamingChunk)
mtbq
                takeQ :: IO (Maybe StreamingChunk)
takeQ = STM (Maybe StreamingChunk) -> IO (Maybe StreamingChunk)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Maybe StreamingChunk) -> IO (Maybe StreamingChunk))
-> STM (Maybe StreamingChunk) -> IO (Maybe StreamingChunk)
forall a b. (a -> b) -> a -> b
$ TBQueue StreamingChunk -> STM (Maybe StreamingChunk)
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 = ONext next 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 = (SomeException -> IO Int) -> IO Int -> IO Int
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
(e -> m a) -> m a -> m a
E.handle SomeException -> IO Int
resetStream (IO Int -> IO Int) -> IO Int -> IO Int
forall a b. (a -> b) -> a -> b
$ do
            StreamState
state <- Stream -> IO StreamState
readStreamState Stream
strm
            if StreamState -> Bool
isHalfClosedLocal StreamState
state
                then Int -> IO Int
forall a. a -> IO a
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 = OObj} Manager
mgr
                        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
                    OutputType
_ -> case Maybe (TBQueue StreamingChunk)
mtbq of
                        Just TBQueue StreamingChunk
tbq -> TBQueue StreamingChunk -> IO Int
forall {a}. TBQueue a -> IO Int
checkStreaming TBQueue StreamingChunk
tbq
                        Maybe (TBQueue StreamingChunk)
_ -> IO Int
checkStreamWindowSize
          where
            mtbq :: Maybe (TBQueue StreamingChunk)
mtbq = Output Stream -> Maybe (TBQueue StreamingChunk)
forall a. Output a -> Maybe (TBQueue StreamingChunk)
outputStrmQ Output Stream
out
            checkStreaming :: TBQueue a -> IO Int
checkStreaming TBQueue a
tbq = do
                Bool
isEmpty <- STM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM Bool -> IO Bool) -> STM Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ TBQueue a -> STM Bool
forall a. TBQueue a -> STM Bool
isEmptyTBQueue TBQueue a
tbq
                if Bool
isEmpty
                    then do
                        IO ()
-> TQueue (Output Stream) -> Output Stream -> Manager -> IO ()
forkAndEnqueueWhenReady (TBQueue a -> IO ()
forall a. TBQueue a -> IO ()
waitStreaming TBQueue a
tbq) TQueue (Output Stream)
outputQ Output Stream
out Manager
mgr
                        Int -> IO Int
forall a. a -> IO a
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 Int -> Int -> Bool
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
                        Int -> IO Int
forall a. a -> IO a
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 = Int -> Int -> Int
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 (Int -> HeaderValue) -> Int -> HeaderValue
forall a b. (a -> b) -> a -> b
$ Stream -> Int
streamNumber Stream
strm
                TQueue Control -> Control -> IO ()
enqueueControl TQueue Control
controlQ (Control -> IO ()) -> Control -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe SettingsList -> [HeaderValue] -> Control
CFrames Maybe SettingsList
forall a. Maybe a
Nothing [HeaderValue
rst]
                Int -> IO Int
forall a. a -> IO a
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 <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
            let offkv :: Int
offkv = Int
off0 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength
                bufkv :: Ptr b
bufkv = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offkv
                limkv :: Int
limkv = Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offkv
            (TokenHeaderList
ths, Int
kvlen) <- Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeader Context
ctx Buffer
forall {b}. Ptr b
bufkv Int
limkv TokenHeaderList
ths0
            if Int
kvlen Int -> Int -> Bool
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 = TokenHeaderList -> FrameFlags
forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths
                        buf :: Ptr b
buf = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off0
                        off :: Int
off = Int
offkv Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
kvlen
                    FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FrameHeaders Int
kvlen Int
sid FrameFlags
flag Buffer
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 FrameFlags -> FrameFlags
forall a. a -> a
id
            getFlag :: [a] -> FrameFlags
getFlag [] = FrameFlags -> FrameFlags
eos (FrameFlags -> FrameFlags) -> FrameFlags -> FrameFlags
forall a b. (a -> b) -> a -> b
$ FrameFlags -> FrameFlags
setEndHeader FrameFlags
defaultFlags
            getFlag [a]
_ = FrameFlags -> FrameFlags
eos (FrameFlags -> FrameFlags) -> FrameFlags -> FrameFlags
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
_ = Int -> IO Int
forall a. a -> IO a
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 <- IORef Int -> IO Int
forall a. IORef a -> IO a
readIORef IORef Int
outputBufferLimit
                let bufHeaderPayload :: Ptr b
bufHeaderPayload = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
frameHeaderLength

                    headerPayloadLim :: Int
headerPayloadLim = Int
buflim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
frameHeaderLength
                (TokenHeaderList
ths', Int
kvlen') <-
                    Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeaderLoop Context
ctx Buffer
forall {b}. Ptr b
bufHeaderPayload Int
headerPayloadLim TokenHeaderList
ths
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (TokenHeaderList
ths TokenHeaderList -> TokenHeaderList -> Bool
forall a. Eq a => a -> a -> Bool
== TokenHeaderList
ths') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                    HTTP2Error -> IO ()
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
E.throwIO (HTTP2Error -> IO ()) -> HTTP2Error -> IO ()
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 = TokenHeaderList -> FrameFlags
forall {a}. [a] -> FrameFlags
getFlag TokenHeaderList
ths'
                    off' :: Int
off' = Int
frameHeaderLength Int -> Int -> Int
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 :: Stream -> Int
streamNumber :: 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 Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                    off' :: Int
off' = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
datPayloadLen
                (Maybe [Header]
mtrailers, FrameFlags
flag) <- do
                    Trailers [Header]
trailers <- TrailersMaker
tlrmkr Maybe HeaderValue
forall a. Maybe a
Nothing
                    if [Header] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Header]
trailers
                        then (Maybe [Header], FrameFlags) -> IO (Maybe [Header], FrameFlags)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Header]
forall a. Maybe a
Nothing, FrameFlags -> FrameFlags
setEndStream FrameFlags
defaultFlags)
                        else (Maybe [Header], FrameFlags) -> IO (Maybe [Header], FrameFlags)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Header] -> Maybe [Header]
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 Buffer
forall {b}. Ptr b
buf
                Int
off'' <- Maybe [Header] -> Int -> IO Int
handleTrailers Maybe [Header]
mtrailers Int
off'
                IO () -> IO ()
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''
                        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
                    else Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off''
              where
                handleTrailers :: Maybe [Header] -> Int -> IO Int
handleTrailers Maybe [Header]
Nothing Int
off0 = Int -> IO Int
forall a. a -> IO a
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 = ONext next 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
                        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
                    else Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
off
        fillDataHeaderEnqueueNext
            strm :: Stream
strm@Stream{Int
streamNumber :: Stream -> Int
streamNumber :: 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 Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                    off' :: Int
off' = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength Int -> Int -> Int
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 Buffer
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 = ONext next 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'
                        Int -> IO Int
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
                    else Int -> IO Int
forall a. a -> IO a
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
frameHeaderLength -- checkme
                bufsid :: Ptr b
bufsid = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offsid
            Word32 -> Buffer -> Int -> IO ()
poke32 (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sid) Buffer
forall {b}. Ptr b
bufsid Int
0
            let offkv :: Int
offkv = Int
offsid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
                bufkv :: Ptr b
bufkv = Buffer
confWriteBuffer Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
offkv
                limkv :: Int
limkv = Int
confBufferSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offkv
            (TokenHeaderList
_, Int
kvlen) <- Context
-> Buffer -> Int -> TokenHeaderList -> IO (TokenHeaderList, Int)
hpackEncodeHeader Context
ctx Buffer
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 Buffer -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
off
                len :: Int
len = Int
kvlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4
            FrameType -> Int -> Int -> FrameFlags -> Buffer -> IO ()
fillFrameHeader FrameType
FramePushPromise Int
len Int
pid FrameFlags
flag Buffer
forall {b}. Ptr b
buf
            Int -> IO Int
forall a. a -> IO a
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 = Buffer
-> Int
-> (HeaderValue -> IO NextTrailersMaker)
-> IO NextTrailersMaker
forall a. Buffer -> Int -> (HeaderValue -> IO a) -> IO a
bufferIO Buffer
buf Int
siz ((HeaderValue -> IO NextTrailersMaker) -> IO NextTrailersMaker)
-> (HeaderValue -> IO NextTrailersMaker) -> IO NextTrailersMaker
forall a b. (a -> b) -> a -> b
$ \HeaderValue
bs -> TrailersMaker
tlrmkr (HeaderValue -> Maybe HeaderValue
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 = Int -> Int -> Int
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
    Next -> IO Next
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Next -> IO Next) -> Next -> IO Next
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 = Int -> Int -> Int
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' = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len
    Next -> IO Next
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Next -> IO Next) -> Next -> IO Next
forall a b. (a -> b) -> a -> b
$ Int -> PositionRead -> Int64 -> Int64 -> IO () -> Next
nextForFile Int
len' PositionRead
pread (Int64
start Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
len) (Int64
bytecount Int64 -> Int64 -> Int64
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 = Int -> Int -> Int
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
    Next -> IO Next
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Next -> IO Next) -> Next -> IO Next
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 = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
siz0 Int
lim
    case Leftover
leftover of
        Leftover
LZero -> FilePath -> IO Next
forall a. HasCallStack => FilePath -> a
error FilePath
"fillBufBuilder: LZero"
        LOne BufferWriter
writer -> do
            (Int
len, Next
signal) <- BufferWriter
writer Buffer
buf0 Int
room
            Int -> Next -> IO Next
forall {m :: * -> *}. Monad m => Int -> Next -> m Next
getNext Int
len Next
signal
        LTwo HeaderValue
bs BufferWriter
writer
            | HeaderValue -> Int
BS.length HeaderValue
bs Int -> Int -> Bool
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len1)
                Int -> Next -> IO Next
forall {m :: * -> *}. Monad m => Int -> Next -> m Next
getNext (Int
len1 Int -> Int -> Int
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
                IO Buffer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Buffer -> IO ()) -> IO Buffer -> IO ()
forall a b. (a -> b) -> a -> b
$ Buffer -> HeaderValue -> IO Buffer
copy Buffer
buf0 HeaderValue
bs1
                Int -> Next -> IO Next
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 = Next -> m Next
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Next -> m Next) -> Next -> m Next
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 Maybe DynaNext
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 (Maybe DynaNext -> Next) -> Maybe DynaNext -> Next
forall a b. (a -> b) -> a -> b
$ DynaNext -> Maybe DynaNext
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 (Maybe DynaNext -> Next) -> Maybe DynaNext -> Next
forall a b. (a -> b) -> a -> b
$ DynaNext -> Maybe DynaNext
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 -> (Bool, Int, Bool, Leftover) -> IO (Bool, Int, Bool, Leftover)
forall a. a -> IO a
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 Int -> Int -> Int
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 Buffer -> Int -> Buffer
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len) (Int
room Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len) Int
total'
                    B.More Int
_ BufferWriter
writer -> (Bool, Int, Bool, Leftover) -> IO (Bool, Int, Bool, Leftover)
forall a. a -> IO a
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 -> (Bool, Int, Bool, Leftover) -> IO (Bool, Int, Bool, Leftover)
forall a. a -> IO a
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 -> (Bool, Int, Bool, Leftover) -> IO (Bool, Int, Bool, Leftover)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
True, Int
total, Bool
True, Leftover
LZero)
            Just (StreamingFinished IO ()
dec) -> do
                IO ()
dec
                (Bool, Int, Bool, Leftover) -> IO (Bool, Int, Bool, Leftover)
forall a. a -> IO a
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 = Int -> Int -> Int
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 Int -> Int -> Bool
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 Int -> Int -> Int
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
                IO Buffer -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Buffer -> IO ()) -> IO Buffer -> IO ()
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 (Leftover -> IO Next) -> Leftover -> IO Next
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 = Next -> IO Next
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Next -> IO Next) -> Next -> IO Next
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 Buffer -> Int -> Buffer
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
len) (Int
room Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
len) IO (Maybe StreamingChunk)
takeQ
                let total :: Int
total = Int
sofar Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
                Bool -> Int -> Bool -> Leftover -> IO Next
getNext Bool
True Int
total Bool
False (Leftover -> IO Next) -> Leftover -> IO Next
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
len
                Bool -> Int -> Bool -> Leftover -> IO Next
getNext Bool
True Int
total Bool
False (Leftover -> IO Next) -> Leftover -> IO Next
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 Maybe DynaNext
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 (Maybe DynaNext -> Next) -> Maybe DynaNext -> Next
forall a b. (a -> b) -> a -> b
$ DynaNext -> Maybe DynaNext
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 = Int -> Int -> Int
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' = Int64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
len
    Next -> IO Next
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Next -> IO Next) -> Next -> IO Next
forall a b. (a -> b) -> a -> b
$ Int -> PositionRead -> Int64 -> Int64 -> IO () -> Next
nextForFile Int
len' PositionRead
pread (Int64
start Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
+ Int64
len) (Int64
bytes Int64 -> Int64 -> Int64
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 Maybe DynaNext
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 Maybe DynaNext
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 (Maybe DynaNext -> Next) -> Maybe DynaNext -> Next
forall a b. (a -> b) -> a -> b
$ DynaNext -> Maybe DynaNext
forall a. a -> Maybe a
Just (DynaNext -> Maybe DynaNext) -> DynaNext -> Maybe DynaNext
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
    | Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
n = Int -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
    | Bool
otherwise = Int64
n