Client.hs

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

-- | A client library for HTTP/3.
module Network.HTTP3.Client (
    -- * Runner
    run,

    -- * Client configration
    ClientConfig,
    defaultClientConfig,
    scheme,
    authority,

    -- * Common configuration
    Config (..),
    defaultConfig,
    allocSimpleConfig,
    freeSimpleConfig,
    defaultQEncoderConfig,
    ecMaxTableCapacity,
    ecHeaderBlockBufferSize,
    ecInstructionBufferSize,
    defaultQDecoderConfig,
    dcMaxTableCapacity,
    dcHuffmanBufferSize,
    Hooks (..),
    defaultHooks,

    -- * HTTP semantics
    module Network.HTTP.Semantics.Client,
) where

import Control.Concurrent
import qualified Control.Exception as E
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.UTF8 as UTF8
import Data.IORef
import Data.IP (IPv6)
import Network.HTTP.Semantics.Client
import Network.HTTP.Semantics.Client.Internal
import Network.QUIC (Connection)
import qualified Network.QUIC as QUIC
import qualified Network.QUIC.Internal as QUIC
import Text.Read (readMaybe)

import Imports
import Network.HTTP3.Config
import Network.HTTP3.Context
import Network.HTTP3.Error
import Network.HTTP3.Recv
import Network.HTTP3.Send
import Network.QPACK

-- | Configuration for HTTP\/3 or HQ client. For HQ, 'authority' is
--   not used and an server's IP address is used in 'Request'.
data ClientConfig = ClientConfig
    { scheme :: Scheme
    , authority :: Authority
    }

defaultClientConfig :: ClientConfig
defaultClientConfig =
    ClientConfig
        { scheme = "https"
        , authority = "localhost"
        }

-- | Running an HTTP\/3 client.
run :: Connection -> ClientConfig -> Config -> Client a -> IO a
run conn ClientConfig{..} conf client = withContext conn conf $ \ctx -> do
    forkManaged ctx "H3 client: readerClient" $ readerClient ctx
    client (sendRequest ctx scheme authority) aux
  where
    aux =
        defaultAux
            { auxPossibleClientStreams = QUIC.possibleMyStreams conn
            , auxSendPing = QUIC.sendFrames conn QUIC.RTT1Level [QUIC.Ping]
            }

readerClient :: Context -> IO ()
readerClient ctx = loop
  where
    loop = do
        accept ctx >>= process
        loop
    process strm
        | QUIC.isClientInitiatedUnidirectional sid = return () -- error
        | QUIC.isClientInitiatedBidirectional sid = return ()
        | QUIC.isServerInitiatedUnidirectional sid =
            forkManaged ctx "H3 client: unidirectional handler" $
                unidirectional ctx strm
        -- Server-initiated bidirectional.  RFC 9114, section 6.1: "Clients
        -- MUST treat receipt of a server-initiated bidirectional stream as a
        -- connection error of type H3_STREAM_CREATION_ERROR unless such an
        -- extension has been negotiated."
        | otherwise = abort ctx H3StreamCreationError
      where
        sid = QUIC.streamId strm

-- | The header section of the final response, past any informational (1xx)
-- ones before it.
--
-- RFC 9114, section 4.1: a response may begin with any number of
-- informational responses, each a header section of its own, before the
-- final one.  The first header section was taken for the response: after a
-- 103 (Early Hints) or a 100 (Continue), the client saw that, and the body
-- reader took the final response's HEADERS for trailers and ended the body
-- there, the final response lost.  They are skipped now, as the application
-- has no way here to be handed them.
--
-- RFC 9114 sets no limit on how many there may be, and a server could go on
-- sending them for as long as it liked, the request never answered.  More
-- than 'maxInformational' reset the stream with H3_EXCESSIVE_LOAD: a server
-- has no use for more than a couple -- a 100 and a 103, say.
recvFinalHeader
    :: Context -> QUIC.Stream -> Source -> IO (Maybe TokenHeaderTable)
recvFinalHeader ctx strm src = loop (0 :: Int)
  where
    sid = QUIC.streamId strm
    loop n = do
        mvt <- recvHeader ctx sid src
        case mvt of
            Just (_, vt)
                | Just status <- getFieldValue tokenStatus vt
                , informational status ->
                    if n < maxInformational
                        then loop (n + 1)
                        else do
                            QUIC.resetStream strm H3ExcessiveLoad
                            E.throwIO $
                                QUIC.ApplicationProtocolErrorIsSent
                                    H3ExcessiveLoad
                                    "too many informational responses"
            _ -> return mvt
    informational status = C8.length status == 3 && C8.head status == '1'

-- | How many informational responses 'recvFinalHeader' takes before the
--   final one.
maxInformational :: Int
maxInformational = 10

sendRequest
    :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a
sendRequest ctx scm auth (Request outobj) processResponse = do
    -- RFC 9114, section 4.2.2: an endpoint "SHOULD NOT send an HTTP message
    -- header that exceeds the indicated size".  Here, so that the caller is
    -- the one told.
    checkHeaderSize ctx hdr'
    sent <- newIORef False
    E.bracket (newStream ctx) (done sent) $ \strm -> do
        forkManagedTimeout ctx "H3 client: sendRequest" $ \th ->
            ( do
                sendHeader ctx strm th hdr'
                sendBody ctx strm th outobj
                QUIC.shutdownStream strm
                writeIORef sent True
            )
                -- What goes wrong here is thrown away with the thread, and
                -- the request would be left half sent, with the response
                -- awaited for good.  Trailers too large for the peer are one
                -- such thing.
                `E.catch` \se -> case E.fromException se of
                    _ | isAsyncException se -> E.throwIO se
                    -- The sending part is closed: the server asked us with
                    -- STOP_SENDING to stop, and it has had its RESET_STREAM
                    -- for that already, or we are done with the stream.
                    -- The response may be on its way yet, and resetting
                    -- here takes the stream out of the table, after which
                    -- whatever arrives for it is thrown away: the response
                    -- would be awaited for good.
                    Just QUIC.StreamIsClosed -> return ()
                    _ -> QUIC.resetStream strm H3RequestCancelled
        src <- newSource strm
        let sid = QUIC.streamId strm
        (`E.finally` cancelUnlessReadToEnd ctx sid src) $ do
            mvt <- recvFinalHeader ctx strm src
            case mvt of
                Nothing -> do
                    QUIC.resetStream strm H3MessageError
                    threadDelay 100000
                    -- just for type inference
                    E.throwIO $ QUIC.ApplicationProtocolErrorIsSent H3MessageError ""
                Just vt
                    -- Malformed (RFC 9114, section 4.2).
                    | Just name <- connectionSpecificField vt -> do
                        QUIC.resetStream strm H3MessageError
                        E.throwIO $ ConnectionSpecificField name
                Just vt@(_, valtbl) -> do
                    (readB, refH) <-
                        newBodyReader ctx sid src valtbl $ noContent valtbl
                    let rsp = Response $ InpObj vt Nothing readB refH
                    processResponse rsp
  where
    -- A response defined to have no content: to HEAD, a 204 or a 304, or a
    -- 2xx to CONNECT (RFC 9110, section 6.4.1).  Its content-length, which it
    -- may carry, describes content it does not have; it was checked against
    -- the empty body all the same, and the client refused such a response
    -- with ContentLengthMismatch.
    noContent valtbl =
        method == Just "HEAD"
            || status `elem` [Just "204", Just "304"]
            || (method == Just "CONNECT" && maybe False ("2" `C8.isPrefixOf`) status)
      where
        status = getFieldValue tokenStatus valtbl
    method = snd <$> find ((== ":method") . fst) hdr
    -- Done with the stream: the response has been processed, or waiting for
    -- it was given up -- 'timeout', say.  A request sent in full has had its
    -- FIN, and closing the stream only tidies up.  One that has not is cut
    -- short, and is reset (H3_REQUEST_CANCELLED).  'closeStream' used to be
    -- called either way, and it ends the sending part with a FIN: the server
    -- took a request body cut short for a whole one.  The sender, if it is
    -- still at it, finds the stream closed and stops.
    done sent strm = do
        complete <- readIORef sent
        if complete
            then closeStream strm
            else QUIC.resetStream strm H3RequestCancelled
    hdr = outObjHeaders outobj
    isIPv6 = isJust (readMaybe auth :: Maybe IPv6)
    auth'
        | isIPv6 = "[" <> UTF8.fromString auth <> "]"
        | otherwise = UTF8.fromString auth
    hdr' = addIfNotExist (":scheme", scm) $ addIfNotExist (":authority", auth') hdr
    addIfNotExist keyVal@(key, _) hs = case find (\(k, _) -> k == key) hs of
        Nothing -> keyVal : hs
        Just _ -> hs