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

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

import qualified Data.ByteString as BS
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder.Extra as B
import Data.IORef (readIORef, writeIORef)
import Foreign.Ptr (plusPtr, minusPtr)
import Network.ByteOrder
import qualified UnliftIO.Exception as E
import UnliftIO.STM

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

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

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

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
Int -> IO HeaderValue
PositionReadMaker
HeaderValue -> IO ()
confWriteBuffer :: Buffer
confBufferSize :: Int
confSendAll :: HeaderValue -> IO ()
confReadN :: Int -> IO HeaderValue
confPositionReadMaker :: PositionReadMaker
confTimeoutManager :: Manager
confWriteBuffer :: Config -> Buffer
confBufferSize :: Config -> Int
confSendAll :: Config -> HeaderValue -> IO ()
confReadN :: Config -> Int -> IO HeaderValue
confPositionReadMaker :: Config -> PositionReadMaker
confTimeoutManager :: Config -> Manager
..}
            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
isEmpty <- TQueue Control -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue Control
controlQ
        if Bool
isEmpty then do
            Context -> STM ()
waitConnectionWindowSize Context
ctx
            Bool
emp <- TQueue (Output Stream) -> STM Bool
forall a. TQueue a -> STM Bool
isEmptyTQueue TQueue (Output Stream)
outputQ
            if Bool
emp 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 (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
        Int
off <- Int -> IO Int
flushIfNecessary Int
off'
        case OutBody
body of
            OutBody
OutBodyNone -> do
                -- halfClosedLocal calls closed which removes
                -- the stream from stream table.
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
isServer Context
ctx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> ClosedCode -> IO ()
halfClosedLocal Context
ctx Stream
strm ClosedCode
Finished
                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 :: 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 ()
_ -> do
                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
                    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

    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 :: OutputType
outputType=OutputType
OObj} Int
off Int
lim

    output Output Stream
_ Int
_ Int
_ = IO Int
forall a. HasCallStack => a
undefined -- never reach

    ----------------------------------------------------------------
    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 :: OutputType
outputType=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
        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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Context -> Bool
isServer Context
ctx) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 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
            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 :: 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'
            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 StreamingChunk
StreamingFinished    -> (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