Context.hs

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

module Network.HTTP3.Context (
    Context,
    withContext,
    unidirectional,
    isH3Server,
    isH3Client,
    accept,
    qpackEncode,
    qpackDecode,
    withHandle,
    newStream,
    closeStream,
    pReadMaker,
    abort,
    getHooks,
    Hooks (..), -- re-export
    getMySockAddr,
    getPeerSockAddr,
    getMaxFieldSectionSize,
    forkManaged,
    forkManagedTimeout,
    forkManagedTimeoutFinally,
    isAsyncException,
) where

import qualified Control.Exception as E
import Control.Monad (void)
import Data.IORef
import Network.HTTP.Semantics.Client
import Network.QUIC
import Network.QUIC.Internal (connDebugLog, isClient, isServer)
import Network.Socket (SockAddr)
import qualified System.ThreadManager as T

import Network.HTTP3.Config
import Network.HTTP3.Control
import Network.HTTP3.Frame
import Network.HTTP3.Stream
import Network.QPACK
import Network.QPACK.Internal

data Context = Context
    { ctxConnection :: Connection
    , ctxQEncoder :: QEncoder
    , ctxQDecoder :: QDecoder
    , ctxUniSwitch :: H3StreamType -> InstructionHandler
    , ctxPReadMaker :: PositionReadMaker
    , ctxThreadManager :: T.ThreadManager
    , ctxHooks :: Hooks
    , ctxMySockAddr :: SockAddr
    , ctxPeerSockAddr :: SockAddr
    , ctxMaxFieldSectionSize :: Int
    -- ^ What we told the peer we would accept, and so the most of any one
    -- frame we are willing to hold in memory while it arrives.
    }

withContext :: Connection -> Config -> (Context -> IO a) -> IO a
withContext conn conf action = do
    ctx <- newContext conn conf
    T.stopAfter (ctxThreadManager ctx) (action ctx) (\_ -> return ())

newContext :: Connection -> Config -> IO Context
newContext conn conf = do
    (sendEI, sendDI) <- setupUnidirectional conn conf
    (ctxQEncoder, handleDI, dyntblE) <- newQEncoder (confQEncoderConfig conf) sendEI
    -- newQDecoder passes dyntbl for decoder to handleEI internally
    (ctxQDecoder, handleEI) <- newQDecoder (confQDecoderConfig conf) sendDI
    let ctxMaxFieldSectionSize = dcMaxFieldSectionSize $ confQDecoderConfig conf
    ctl <- controlStream conn ctxMaxFieldSectionSize dyntblE <$> newIORef IInit
    info <- getConnectionInfo conn
    let handleDI' recv = handleDI recv `E.catch` abortWith QpackDecoderStreamError
        handleEI' recv = handleEI recv `E.catch` abortWith QpackEncoderStreamError
        ctxUniSwitch = switch conn ctl handleEI' handleDI'
        ctxPReadMaker = confPositionReadMaker conf
        ctxHooks = confHooks conf
        ctxMySockAddr = localSockAddr info
        ctxPeerSockAddr = remoteSockAddr info
    ctxThreadManager <- T.newThreadManager $ confTimeoutManager conf
    let ctxConnection = conn
    return Context{..}
  where
    abortWith :: ApplicationProtocolError -> E.SomeException -> IO ()
    abortWith aerr se
        | isAsyncException se = E.throwIO se
        | otherwise = abortConnection conn aerr ""

isAsyncException :: E.Exception e => e -> Bool
isAsyncException e =
    case E.fromException (E.toException e) of
        Just (E.SomeAsyncException _) -> True
        Nothing -> False

switch
    :: Connection
    -> InstructionHandler
    -> InstructionHandler
    -> InstructionHandler
    -> H3StreamType
    -> InstructionHandler
switch conn ctl handleEI handleDI styp
    | styp == H3ControlStreams = ctl
    | styp == QPACKEncoderStream = handleEI
    | styp == QPACKDecoderStream = handleDI
    | otherwise = \_ -> connDebugLog conn "switch unknown stream type"

isH3Server :: Context -> Bool
isH3Server Context{..} = isServer ctxConnection

isH3Client :: Context -> Bool
isH3Client Context{..} = isClient ctxConnection

accept :: Context -> IO Stream
accept Context{..} = acceptStream ctxConnection

qpackEncode :: Context -> QEncoder
qpackEncode Context{..} = ctxQEncoder

qpackDecode :: Context -> QDecoder
qpackDecode Context{..} = ctxQDecoder

unidirectional :: Context -> Stream -> IO ()
unidirectional Context{..} strm = do
    -- The type is a variable-length integer (RFC 9114, section 6.2), so one,
    -- two, four or eight octets -- not the single one it used to be read as,
    -- which cut anything from 0x40 up in half and handed the tail of the type
    -- to a handler as though it were the stream's contents.
    mtyp <- recvQInt (recvStream strm)
    case mtyp of
        -- The peer opened a unidirectional stream and closed it without
        -- saying what it was for.  Nothing to dispatch to; this used to be a
        -- pattern match failure.
        Nothing -> return ()
        Just i -> ctxUniSwitch (toH3StreamType i) (recvStream strm)

withHandle :: Context -> (T.Handle -> IO ()) -> IO ()
withHandle Context{..} action = void $ T.withHandle ctxThreadManager (return ()) action

newStream :: Context -> IO Stream
newStream Context{..} = stream ctxConnection

pReadMaker :: Context -> PositionReadMaker
pReadMaker = ctxPReadMaker

forkManaged :: Context -> String -> IO () -> IO ()
forkManaged Context{..} = T.forkManaged ctxThreadManager

forkManagedTimeout :: Context -> String -> (T.Handle -> IO ()) -> IO ()
forkManagedTimeout Context{..} =
    T.forkManagedTimeout ctxThreadManager

forkManagedTimeoutFinally
    :: Context -> String -> (T.Handle -> IO ()) -> IO () -> IO ()
forkManagedTimeoutFinally Context{..} =
    T.forkManagedTimeoutFinally ctxThreadManager

abort :: Context -> ApplicationProtocolError -> IO ()
abort ctx aerr = abortConnection (ctxConnection ctx) aerr ""

getHooks :: Context -> Hooks
getHooks = ctxHooks

getMySockAddr :: Context -> SockAddr
getMySockAddr = ctxMySockAddr

getPeerSockAddr :: Context -> SockAddr
getPeerSockAddr = ctxPeerSockAddr

getMaxFieldSectionSize :: Context -> Int
getMaxFieldSectionSize = ctxMaxFieldSectionSize