{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

module Network.HTTP3.Send (
    sendHeader,
    sendBody,
) where

import qualified Control.Exception as E
import qualified Data.ByteString.Builder.Extra as B
import qualified Data.ByteString.Internal as BS
import Data.IORef
import Foreign.ForeignPtr
import Network.HPACK.Internal (toTokenHeaderTable)
import Network.HTTP.Semantics.Client
import Network.HTTP.Semantics.IO
import qualified Network.HTTP.Types as HT
import Network.QUIC
import qualified System.TimeManager as T

import Imports
import Network.HTTP3.Context
import Network.HTTP3.Frame

sendHeader :: Context -> Stream -> T.Handle -> HT.ResponseHeaders -> IO ()
sendHeader :: Context -> Stream -> Handle -> ResponseHeaders -> IO ()
sendHeader Context
ctx Stream
strm Handle
th ResponseHeaders
hdrs = do
    -- fixme: fixHeaders
    (TokenHeaderList
ths, ValueTable
_) <- ResponseHeaders -> IO (TokenHeaderList, ValueTable)
toTokenHeaderTable ResponseHeaders
hdrs
    (ByteString
hdr, ByteString
"") <- Context -> QEncoder
qpackEncode Context
ctx TokenHeaderList
ths
    let frames :: [H3Frame]
frames = [H3FrameType -> ByteString -> H3Frame
H3Frame H3FrameType
H3FrameHeaders ByteString
hdr]
        frames' :: [H3Frame]
frames' = Hooks -> [H3Frame] -> [H3Frame]
onHeadersFrameCreated (Context -> Hooks
getHooks Context
ctx) [H3Frame]
frames
        bss :: [ByteString]
bss = [H3Frame] -> [ByteString]
encodeH3Frames [H3Frame]
frames'
    Stream -> [ByteString] -> IO ()
sendStreamMany Stream
strm [ByteString]
bss
    Handle -> IO ()
T.tickle Handle
th

sendBody :: Context -> Stream -> T.Handle -> OutObj -> IO ()
sendBody :: Context -> Stream -> Handle -> OutObj -> IO ()
sendBody Context
ctx Stream
strm Handle
th OutObj
outobj = case OutObj -> OutBody
outObjBody OutObj
outobj of
    OutBody
OutBodyNone -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    OutBodyFile (FileSpec FilePath
path FileOffset
fileoff FileOffset
bytecount) -> do
        (PositionRead
pread, Sentinel
sentinel) <- Context -> PositionReadMaker
pReadMaker Context
ctx FilePath
path
        let next :: DynaNext
next = PositionRead -> FileOffset -> FileOffset -> Sentinel -> DynaNext
fillFileBodyGetNext PositionRead
pread FileOffset
fileoff FileOffset
bytecount Sentinel
sentinel
        Context -> Stream -> Handle -> DynaNext -> TrailersMaker -> IO ()
sendNext Context
ctx Stream
strm Handle
th DynaNext
next TrailersMaker
tlrmkr
    OutBodyBuilder Builder
builder -> do
        let next :: DynaNext
next = Builder -> DynaNext
fillBuilderBodyGetNext Builder
builder
        Context -> Stream -> Handle -> DynaNext -> TrailersMaker -> IO ()
sendNext Context
ctx Stream
strm Handle
th DynaNext
next TrailersMaker
tlrmkr
    OutBodyStreaming (Builder -> IO ()) -> IO () -> IO ()
strmbdy ->
        Context
-> Stream
-> Handle
-> TrailersMaker
-> (OutBodyIface -> IO ())
-> IO ()
sendStreaming
            Context
ctx
            Stream
strm
            Handle
th
            TrailersMaker
tlrmkr
            (\OutBodyIface
iface -> OutBodyIface -> forall x. IO x -> IO x
outBodyUnmask OutBodyIface
iface (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Builder -> IO ()) -> IO () -> IO ()
strmbdy (OutBodyIface -> Builder -> IO ()
outBodyPush OutBodyIface
iface) (OutBodyIface -> IO ()
outBodyFlush OutBodyIface
iface))
    OutBodyStreamingIface OutBodyIface -> IO ()
strmbdy -> Context
-> Stream
-> Handle
-> TrailersMaker
-> (OutBodyIface -> IO ())
-> IO ()
sendStreaming Context
ctx Stream
strm Handle
th TrailersMaker
tlrmkr OutBodyIface -> IO ()
strmbdy
  where
    tlrmkr :: TrailersMaker
tlrmkr = OutObj -> TrailersMaker
outObjTrailers OutObj
outobj

sendNext :: Context -> Stream -> T.Handle -> DynaNext -> TrailersMaker -> IO ()
sendNext :: Context -> Stream -> Handle -> DynaNext -> TrailersMaker -> IO ()
sendNext Context
ctx Stream
strm Handle
th DynaNext
curr TrailersMaker
tlrmkr0 = do
    (ByteString
bs, Maybe DynaNext
mnext, TrailersMaker
tlrmkr) <- TrailersMaker
-> DynaNext -> IO (ByteString, Maybe DynaNext, TrailersMaker)
newByteStringWith TrailersMaker
tlrmkr0 DynaNext
curr
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ H3Frame -> IO ByteString
encodeH3Frame (H3FrameType -> ByteString -> H3Frame
H3Frame H3FrameType
H3FrameData ByteString
bs) IO ByteString -> (ByteString -> 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
>>= Stream -> ByteString -> IO ()
sendStream Stream
strm
    Handle -> IO ()
T.tickle Handle
th
    case Maybe DynaNext
mnext of
        Maybe DynaNext
Nothing -> do
            Trailers ResponseHeaders
trailers <- TrailersMaker
tlrmkr Maybe ByteString
forall a. Maybe a
Nothing
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ResponseHeaders -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ResponseHeaders
trailers) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> Handle -> ResponseHeaders -> IO ()
sendHeader Context
ctx Stream
strm Handle
th ResponseHeaders
trailers
        Just DynaNext
next -> Context -> Stream -> Handle -> DynaNext -> TrailersMaker -> IO ()
sendNext Context
ctx Stream
strm Handle
th DynaNext
next TrailersMaker
tlrmkr

newByteStringWith
    :: TrailersMaker -> DynaNext -> IO (ByteString, Maybe DynaNext, TrailersMaker)
newByteStringWith :: TrailersMaker
-> DynaNext -> IO (ByteString, Maybe DynaNext, TrailersMaker)
newByteStringWith TrailersMaker
tlrmkr0 DynaNext
action = do
    ForeignPtr Word8
fp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
BS.mallocByteString Int
2048
    Next Int
len Bool
_reqflush Maybe DynaNext
mnext1 <- ForeignPtr Word8 -> (Ptr Word8 -> IO Next) -> IO Next
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO Next) -> IO Next)
-> (Ptr Word8 -> IO Next) -> IO Next
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf -> DynaNext
action Ptr Word8
buf Int
2048
    if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then (ByteString, Maybe DynaNext, TrailersMaker)
-> IO (ByteString, Maybe DynaNext, TrailersMaker)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
"", Maybe DynaNext
forall a. Maybe a
Nothing, TrailersMaker
tlrmkr0)
        else do
            let bs :: ByteString
bs = ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
fp Int
0 Int
len
            NextTrailersMaker TrailersMaker
tlrmkr1 <- TrailersMaker
tlrmkr0 TrailersMaker -> TrailersMaker
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
            (ByteString, Maybe DynaNext, TrailersMaker)
-> IO (ByteString, Maybe DynaNext, TrailersMaker)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bs, Maybe DynaNext
mnext1, TrailersMaker
tlrmkr1)

newByteStringAndSend
    :: Stream
    -> T.Handle
    -> TrailersMaker
    -> B.BufferWriter
    -> IO (B.Next, TrailersMaker)
newByteStringAndSend :: Stream
-> Handle
-> TrailersMaker
-> BufferWriter
-> IO (Next, TrailersMaker)
newByteStringAndSend Stream
strm Handle
th TrailersMaker
tlrmkr0 BufferWriter
action = do
    ForeignPtr Word8
fp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
BS.mallocByteString Int
2048
    (Int
len, Next
signal) <- ForeignPtr Word8 -> (Ptr Word8 -> IO (Int, Next)) -> IO (Int, Next)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
fp ((Ptr Word8 -> IO (Int, Next)) -> IO (Int, Next))
-> (Ptr Word8 -> IO (Int, Next)) -> IO (Int, Next)
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
buf -> BufferWriter
action Ptr Word8
buf Int
2048
    if Int
len Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then (Next, TrailersMaker) -> IO (Next, TrailersMaker)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Next
signal, TrailersMaker
tlrmkr0)
        else do
            let bs :: ByteString
bs = ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
fp Int
0 Int
len
            NextTrailersMaker TrailersMaker
tlrmkr1 <- TrailersMaker
tlrmkr0 TrailersMaker -> TrailersMaker
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
            H3Frame -> IO ByteString
encodeH3Frame (H3FrameType -> ByteString -> H3Frame
H3Frame H3FrameType
H3FrameData ByteString
bs) IO ByteString -> (ByteString -> 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
>>= Stream -> ByteString -> IO ()
sendStream Stream
strm
            Handle -> IO ()
T.tickle Handle
th
            (Next, TrailersMaker) -> IO (Next, TrailersMaker)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Next
signal, TrailersMaker
tlrmkr1)

sendStreaming
    :: Context
    -> Stream
    -> T.Handle
    -> TrailersMaker
    -> (OutBodyIface -> IO ())
    -> IO ()
sendStreaming :: Context
-> Stream
-> Handle
-> TrailersMaker
-> (OutBodyIface -> IO ())
-> IO ()
sendStreaming Context
ctx Stream
strm Handle
th TrailersMaker
tlrmkr0 OutBodyIface -> IO ()
strmbdy = do
    IORef TrailersMaker
ref <- TrailersMaker -> IO (IORef TrailersMaker)
forall a. a -> IO (IORef a)
newIORef TrailersMaker
tlrmkr0
    ((forall x. IO x -> IO x) -> IO ()) -> IO ()
forall b. ((forall x. IO x -> IO x) -> IO b) -> IO b
E.mask (((forall x. IO x -> IO x) -> IO ()) -> IO ())
-> ((forall x. IO x -> IO x) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \forall x. IO x -> IO x
unmask -> do
        let iface :: OutBodyIface
iface =
                OutBodyIface
                    { outBodyUnmask :: forall x. IO x -> IO x
outBodyUnmask = IO x -> IO x
forall x. IO x -> IO x
unmask
                    , outBodyPush :: Builder -> IO ()
outBodyPush = IORef TrailersMaker -> Builder -> IO ()
write IORef TrailersMaker
ref
                    , outBodyPushFinal :: Builder -> IO ()
outBodyPushFinal = IORef TrailersMaker -> Builder -> IO ()
write IORef TrailersMaker
ref -- fixme
                    , outBodyFlush :: IO ()
outBodyFlush = IO ()
flush
                    , outBodyCancel :: Maybe SomeException -> IO ()
outBodyCancel = Maybe SomeException -> IO ()
forall {m :: * -> *} {p}. Monad m => p -> m ()
cancel
                    }
        OutBodyIface -> IO ()
strmbdy OutBodyIface
iface
    TrailersMaker
tlrmkr <- IORef TrailersMaker -> IO TrailersMaker
forall a. IORef a -> IO a
readIORef IORef TrailersMaker
ref
    Trailers ResponseHeaders
trailers <- TrailersMaker
tlrmkr Maybe ByteString
forall a. Maybe a
Nothing
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ResponseHeaders -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ResponseHeaders
trailers) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Stream -> Handle -> ResponseHeaders -> IO ()
sendHeader Context
ctx Stream
strm Handle
th ResponseHeaders
trailers
  where
    -- fixme: how to implement flush and cancel?
    flush :: IO ()
flush = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    cancel :: p -> m ()
cancel p
_ = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    write :: IORef TrailersMaker -> Builder -> IO ()
write IORef TrailersMaker
ref Builder
builder = do
        TrailersMaker
tlrmkr1 <- IORef TrailersMaker -> IO TrailersMaker
forall a. IORef a -> IO a
readIORef IORef TrailersMaker
ref
        TrailersMaker
tlrmkr2 <- Stream
-> Handle
-> TrailersMaker
-> BufferWriter
-> IO (Next, TrailersMaker)
newByteStringAndSend Stream
strm Handle
th TrailersMaker
tlrmkr1 (Builder -> BufferWriter
B.runBuilder Builder
builder) IO (Next, TrailersMaker)
-> ((Next, TrailersMaker) -> IO TrailersMaker) -> IO TrailersMaker
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Next, TrailersMaker) -> IO TrailersMaker
loop
        IORef TrailersMaker -> TrailersMaker -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef TrailersMaker
ref TrailersMaker
tlrmkr2
      where
        loop :: (Next, TrailersMaker) -> IO TrailersMaker
loop (Next
B.Done, TrailersMaker
tlrmkr1) = TrailersMaker -> IO TrailersMaker
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TrailersMaker
tlrmkr1
        loop (B.More Int
_ BufferWriter
writer, TrailersMaker
tlrmkr1) =
            Stream
-> Handle
-> TrailersMaker
-> BufferWriter
-> IO (Next, TrailersMaker)
newByteStringAndSend Stream
strm Handle
th TrailersMaker
tlrmkr1 BufferWriter
writer IO (Next, TrailersMaker)
-> ((Next, TrailersMaker) -> IO TrailersMaker) -> IO TrailersMaker
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Next, TrailersMaker) -> IO TrailersMaker
loop
        loop (B.Chunk ByteString
bs BufferWriter
writer, TrailersMaker
tlrmkr1) = do
            H3Frame -> IO ByteString
encodeH3Frame (H3FrameType -> ByteString -> H3Frame
H3Frame H3FrameType
H3FrameData ByteString
bs) IO ByteString -> (ByteString -> 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
>>= Stream -> ByteString -> IO ()
sendStream Stream
strm
            NextTrailersMaker TrailersMaker
tlrmkr2 <- TrailersMaker
tlrmkr1 TrailersMaker -> TrailersMaker
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
bs
            Handle -> IO ()
T.tickle Handle
th
            Stream
-> Handle
-> TrailersMaker
-> BufferWriter
-> IO (Next, TrailersMaker)
newByteStringAndSend Stream
strm Handle
th TrailersMaker
tlrmkr2 BufferWriter
writer IO (Next, TrailersMaker)
-> ((Next, TrailersMaker) -> IO TrailersMaker) -> IO TrailersMaker
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Next, TrailersMaker) -> IO TrailersMaker
loop