Send.hs

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

module Network.HTTP3.Send (
    sendHeader,
    checkHeaderSize,
    sendBody,
    closeSentinel,
) 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.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.Error
import Network.HTTP3.Frame
import Network.QPACK

-- | Refusing a header section the peer said it would not take, before
--   anything is opened or sent.
--
-- The encoder refuses it too, but on a client that happens in the thread
-- sending the request, which has nobody to tell.
checkHeaderSize :: Context -> HT.RequestHeaders -> IO ()
checkHeaderSize ctx hdrs = do
    (ths, _) <- toTokenHeaderTable hdrs
    lim <- getPeerMaxFieldSectionSize ctx
    let siz = fieldSectionSize ths
    when (siz > lim) $ E.throwIO $ FieldSectionTooLargeForPeer siz lim

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

-- | Sending the body and its trailers.  'False' when the application
--   cancelled the stream ('outBodyCancel'), which has reset it: the caller
--   must not end it with a FIN.
sendBody :: Context -> Stream -> T.Handle -> OutObj -> IO Bool
sendBody ctx strm th outobj = case outObjBody outobj of
    OutBodyNone -> return True
    OutBodyFile (FileSpec path fileoff bytecount) -> do
        (pread, sentinel) <- pReadMaker ctx path
        let next = fillFileBodyGetNext pread fileoff bytecount sentinel
        True <$ sendNext ctx strm th next tlrmkr `E.onException` closeSentinel sentinel
    OutBodyBuilder builder -> do
        let next = fillBuilderBodyGetNext builder
        True <$ sendNext ctx strm th next tlrmkr
    OutBodyStreaming strmbdy ->
        sendStreaming
            ctx
            strm
            th
            tlrmkr
            (\iface -> outBodyUnmask iface $ strmbdy (outBodyPush iface) (outBodyFlush iface))
    OutBodyStreamingIface strmbdy -> sendStreaming ctx strm th tlrmkr strmbdy
  where
    tlrmkr = outObjTrailers outobj

sendNext :: Context -> Stream -> T.Handle -> DynaNext -> TrailersMaker -> IO ()
sendNext ctx strm th curr tlrmkr0 = do
    (bs, mnext, tlrmkr) <- newByteStringWith tlrmkr0 curr
    when (bs /= "") $ encodeH3Frame (H3Frame H3FrameData bs) >>= sendStream strm
    T.tickle th
    case mnext of
        Nothing -> do
            tm <- tlrmkr Nothing
            let trailers = case tm of
                    Trailers t -> t
                    _ -> []
            unless (null trailers) $ sendHeader ctx strm th trailers
        Just next -> sendNext ctx strm th next tlrmkr

newByteStringWith
    :: TrailersMaker -> DynaNext -> IO (ByteString, Maybe DynaNext, TrailersMaker)
newByteStringWith tlrmkr0 action = do
    fp <- BS.mallocByteString fileChunkSize
    Next len _reqflush mnext1 <- withForeignPtr fp $ \buf -> action buf fileChunkSize
    if len == 0
        -- Nothing this time, but not necessarily the end: there may be a
        -- next.  This used to end the body here.
        then return ("", mnext1, tlrmkr0)
        else do
            let bs = PS fp 0 len
            tlrmkr1 <- nextMaker <$> tlrmkr0 (Just bs)
            return (bs, mnext1, tlrmkr1)

-- | Closing a file whose body was not sent to its end.  Only the end closed
--   it, so a failure or a reset partway left the descriptor open.  'hClose',
--   which the default closer is, may be called again.
closeSentinel :: Sentinel -> IO ()
closeSentinel (Closer close) = close
closeSentinel (Refresher _) = return ()

-- | The most of a file or builder body put in one DATA frame.  It was 2048,
--   so a large body went out in many small frames, one 'sendStream' each.
fileChunkSize :: Int
fileChunkSize = 16384

-- | The trailers maker to go on with after a chunk of the body.
--
-- One that answers with the trailers before the end keeps them for the end.
-- That was taken to be impossible, and failed with a pattern match; or the
-- trailers were dropped for none.
nextMaker :: NextTrailersMaker -> TrailersMaker
nextMaker (NextTrailersMaker t) = t
nextMaker tm@(Trailers _) = \_ -> return tm

newByteStringAndSend
    :: Stream
    -> T.Handle
    -> TrailersMaker
    -> B.BufferWriter
    -> IO (B.Next, TrailersMaker)
newByteStringAndSend strm th tlrmkr0 action = do
    fp <- BS.mallocByteString 2048
    (len, signal) <- withForeignPtr fp $ \buf -> action buf 2048
    if len == 0
        then return (signal, tlrmkr0)
        else do
            let bs = PS fp 0 len
            tlrmkr1 <- nextMaker <$> tlrmkr0 (Just bs)
            encodeH3Frame (H3Frame H3FrameData bs) >>= sendStream strm
            T.tickle th
            return (signal, tlrmkr1)

sendStreaming
    :: Context
    -> Stream
    -> T.Handle
    -> TrailersMaker
    -> (OutBodyIface -> IO ())
    -> IO Bool
sendStreaming ctx strm th tlrmkr0 strmbdy = do
    ref <- newIORef tlrmkr0
    cancelled <- newIORef False
    E.mask $ \unmask -> do
        let iface =
                OutBodyIface
                    { outBodyUnmask = unmask
                    , outBodyPush = write ref
                    , outBodyPushFinal = write ref -- fixme
                    , outBodyFlush = flush
                    , outBodyCancel = cancel cancelled
                    }
        strmbdy iface
    done <- not <$> readIORef cancelled
    when done $ do
        tlrmkr <- readIORef ref
        tm <- tlrmkr Nothing
        let trailers = case tm of
                Trailers t -> t
                _ -> []
        unless (null trailers) $ sendHeader ctx strm th trailers
    return done
  where
    -- fixme: how to implement flush?
    flush = return ()
    -- The stream is reset, with H3_INTERNAL_ERROR for an exception and
    -- H3_REQUEST_CANCELLED otherwise, as HTTP/2 does with RST_STREAM.
    -- It did nothing, and the body cut short was ended with a FIN.
    cancel cancelled merr = do
        writeIORef cancelled True
        resetStream strm $ maybe H3RequestCancelled (const H3InternalError) merr
    write ref builder = do
        tlrmkr1 <- readIORef ref
        tlrmkr2 <- newByteStringAndSend strm th tlrmkr1 (B.runBuilder builder) >>= loop
        writeIORef ref tlrmkr2
      where
        loop (B.Done, tlrmkr1) = return tlrmkr1
        loop (B.More _ writer, tlrmkr1) =
            newByteStringAndSend strm th tlrmkr1 writer >>= loop
        loop (B.Chunk bs writer, tlrmkr1) = do
            encodeH3Frame (H3Frame H3FrameData bs) >>= sendStream strm
            tlrmkr2 <- nextMaker <$> tlrmkr1 (Just bs)
            T.tickle th
            newByteStringAndSend strm th tlrmkr2 writer >>= loop