Run.hs

{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE InterruptibleFFI #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.QUIC.Client.Run (
    run,
    migrate,
) where

import Control.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
import qualified Control.Exception as E
import Foreign.C.Types
import qualified Network.Socket as NS

import Network.QUIC.Client.Reader
import Network.QUIC.Closer
import Network.QUIC.Common
import Network.QUIC.Config
import Network.QUIC.Connection
import Network.QUIC.Crypto
import Network.QUIC.Handshake
import Network.QUIC.Imports
import Network.QUIC.Logger
import Network.QUIC.Parameters
import Network.QUIC.QLogger
import Network.QUIC.Receiver
import Network.QUIC.Recovery
import Network.QUIC.Sender
import Network.QUIC.Types

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

-- | Running a QUIC client.
--   A UDP socket is created according to 'ccServerName' and 'ccPortName'.
run :: ClientConfig -> (Connection -> IO a) -> IO a
-- Don't use handleLogUnit here because of a return value.
run conf client = do
    let resInfo = ccResumption conf
        verInfo = case resumptionSession resInfo of
            []
                | resumptionToken resInfo == emptyToken ->
                    let ver = ccVersion conf
                        vers = ccVersions conf
                     in VersionInfo ver vers
            _ -> let ver = resumptionVersion resInfo in VersionInfo ver [ver]
    -- Exceptions except NextVersion are passed through.
    ex <- E.try $ runClient conf client False verInfo
    case ex of
        Right v -> return v
        -- Other exceptions go though.
        Left (NextVersion nextVerInfo)
            | verInfo == brokenVersionInfo -> E.throwIO VersionNegotiationFailed
            | otherwise -> runClient conf client True nextVerInfo

runClient :: ClientConfig -> (Connection -> IO a) -> Bool -> VersionInfo -> IO a
runClient conf client0 isICVN verInfo = do
    E.bracket open clse $ \(ConnRes conn myAuthCIDs reader) -> do
        forkManaged conn reader
        let conf' =
                conf
                    { ccParameters =
                        (ccParameters conf)
                            { versionInformation = Just verInfo
                            }
                    }
        setIncompatibleVN conn isICVN -- must be before handshaker
        setToken conn $ resumptionToken $ ccResumption conf
        handshaker <- handshakeClient conf' conn myAuthCIDs
        let client = do
                -- For 0-RTT, the following variables should be initialized
                -- in advance -- from the parameters the previous connection
                -- gave, which is what RFC 9000 Sec 7.4.1 holds a client
                -- sending 0-RTT to, and not from 'defaultParameters'.  Those
                -- are 64 bidi streams and 10 uni where a server may have
                -- allowed fewer, and since each of these setters only ever
                -- raises, a limit too high here stayed too high for the rest
                -- of the connection.  The connection's own send limit
                -- belongs with them and was missing altogether: it starts at
                -- zero and nothing raised it before the handshake, so 0-RTT
                -- stream data went out against no connection limit at all.
                params <- getPeerParameters conn
                setTxMaxData conn $ initialMaxData params
                setTxMaxStreams conn $ initialMaxStreamsBidi params
                setTxUniMaxStreams conn $ initialMaxStreamsUni params
                if ccUse0RTT conf
                    then wait0RTTReady conn
                    else wait1RTTReady conn
                r <- client0 conn
                mainDone conn
                return r
            ldcc = connLDCC conn
        let s1 = labelMe "handshaker" >> handshaker
            s2 = labelMe "sender" >> sender conn
            s3 = labelMe "receiver" >> receiver conn
            s4 = labelMe "resender" >> resender ldcc
            s5 = labelMe "ldccTimer" >> ldccTimer ldcc
            s6 = labelMe "QUIC client" >> client
            c1 = labelMe "concurrently1" >> concurrently_ s1 s2
            c2 = labelMe "concurrently2" >> concurrently_ c1 s3
            c3 = labelMe "concurrently3" >> concurrently_ c2 s4
            c4 = labelMe "concurrently4" >> concurrently_ c3 s5
            c5 =
                labelMe "concurrently5"
                    >> concurrently (c4 `E.catch` \(_ :: InternalControl) -> return ()) s6
            runThreads = snd <$> c5
        when (ccWatchDog conf) $ forkManaged conn $ watchDog conn
        ex <- E.try runThreads
        sendFinal conn
        setConnectionClosed conn
        closure conn ldcc ex
  where
    open = createClientConnection conf verInfo
    clse connRes = do
        let conn = connResConnection connRes
        setDead conn
        freeResources conn
        killReaders conn

createClientConnection :: ClientConfig -> VersionInfo -> IO ConnRes
createClientConnection conf@ClientConfig{..} verInfo = do
    (sock, peersa) <- clientSocket ccServerName ccPortName
    -- As in 'createServerConnection': this is 'run's bracket acquire, so
    -- nothing releases what it has taken when it throws.  Here that is a
    -- socket as well -- 'clse' does not close it, the closer does, and a
    -- connection that never began has no closer.
    flip E.onException (NS.close sock) $ do
        when ccSockConnected $ NS.connect sock peersa
        q <- newRecvQ
        sref <- newIORef sock
        pathInfo <- newPathInfo peersa
        piref <- newIORef $ PeerInfo pathInfo Nothing
        let send buf siz
                | ccSockConnected = do
                    s <- readIORef sref
                    void $ NS.sendBuf s buf siz
                | otherwise = do
                    s <- readIORef sref
                    PeerInfo pinfo _ <- readIORef piref
                    void $ NS.sendBufTo s buf siz $ peerSockAddr pinfo
            recv = recvClient q
        myCID <- newCID
        -- Creating peer's CIDDB with the temporary CID.  This is
        -- overridden by resetPeerCID later since no sequence number is
        -- assigned to the temporary CID by spec.
        peerCID <- newCID
        now <- getTimeMicrosecond
        (qLog, qclean) <- dirQLogger ccQLog now peerCID "client"
        flip E.onException qclean $ do
            let debugLog msg
                    | ccDebugLog = stdoutLogger msg
                    | otherwise = return ()
            debugLog $ "Original CID: " <> bhow peerCID
            let myAuthCIDs = defaultAuthCIDs{initSrcCID = Just myCID}
                peerAuthCIDs = defaultAuthCIDs{initSrcCID = Just peerCID, origDstCID = Just peerCID}
            genSRT <- makeGenStatelessReset
            connRecvDatagramQ <- newTQueueIO
            conn <-
                clientConnection
                    conf
                    verInfo
                    myAuthCIDs
                    peerAuthCIDs
                    debugLog
                    qLog
                    ccHooks
                    sref
                    piref
                    q
                    connRecvDatagramQ
                    send
                    recv
                    genSRT
            flip E.onException (setDead conn >> freeResources conn) $ do
                setSockConnected conn ccSockConnected
                modifytPeerParameters conn ccResumption
                let ver = chosenVersion verInfo
                initializeCoder conn InitialLevel $ initialSecrets ver peerCID
                setupCryptoStreams conn -- fixme: cleanup
                -- RFC9000 \S14.2
                -- "In the absence of these mechanisms, QUIC endpoints SHOULD
                -- NOT send datagrams larger than the smallest allowed maximum
                -- datagram size."
                --
                -- Thus use 1200 bytes for minimum packet size.
                let pktSiz0 = fromMaybe (defaultPacketSize peersa) ccPacketSize
                    pktSiz = (defaultQUICPacketSize `max` pktSiz0) `min` maximumPacketSize peersa
                setMaxPacketSize conn pktSiz
                setInitialCongestionWindow (connLDCC conn) pktSiz
                setAddressValidated pathInfo
                let reader = readerClient sock conn -- dies when s0 is closed.
                -- Handing the qlog over.  Nothing below can throw, so from here
                -- 'freeResources' is the only releaser.
                addResource conn qclean
                return $ ConnRes conn myAuthCIDs reader

-- | Creating a new socket and execute a path validation
--   with a new connection ID. Typically, this is used
--   for migration in the case where 'ccSockConnected' is 'True'.
--   But this can also be used even when the value is 'False'.
migrate :: Connection -> IO Bool
migrate conn = controlConnection conn ActiveMigration

watchDog :: Connection -> IO ()
watchDog conn = E.bracket c_open_socket c_close_socket loop
  where
    loop s = do
        ret <- c_watch_socket s
        case ret of
            -1 -> loop s
            -2 -> return ()
            _ -> do
                _ <- migrate conn
                -- prevent calling "migrate" frequently
                threadDelay 100000
                loop s

foreign import ccall unsafe "open_socket"
    c_open_socket :: IO CInt

foreign import ccall interruptible "watch_socket"
    c_watch_socket :: CInt -> IO CInt

foreign import ccall unsafe "close_socket"
    c_close_socket :: CInt -> IO CInt