Reader.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.QUIC.Client.Reader (
    readerClient,
    recvClient,
    ConnectionControl (..),
    controlConnection,
    clientSocket,
) where

import Control.Concurrent
import qualified Control.Exception as E
import Data.List (intersect)
import Network.Socket (Socket, close, connect, getSocketName)
import qualified Network.Socket.ByteString as NSB

import Network.QUIC.Common
import Network.QUIC.Connection
import Network.QUIC.Connector
import Network.QUIC.Crypto
import Network.QUIC.Exception
import Network.QUIC.Imports
import Network.QUIC.Packet
import Network.QUIC.Parameters
import Network.QUIC.Qlog
import Network.QUIC.Recovery
import Network.QUIC.Socket
import Network.QUIC.Types

-- | readerClient dies when the socket is closed.
readerClient :: Socket -> Connection -> IO ()
readerClient s0 conn = handleLogUnit logAction $ do
    labelMe "readerClient"
    wait
    connected <- getSockConnected conn
    peersa0 <- peerSockAddr <$> getPathInfo conn
    let recv
            | connected = NSB.recv s0 2048
            | otherwise = do
                (bs, peersa) <- NSB.recvFrom s0 2048
                if peersa /= peersa0 then recv else return bs
    loop recv
  where
    wait = do
        bound <- E.handle (throughAsync (return False)) $ do
            _ <- getSocketName s0
            return True
        unless bound $ do
            yield
            wait
    loop recv = do
        ito <- readMinIdleTimeout conn
        mbs <- timeout ito "readeClient" recv
        case mbs of
            Nothing -> close s0
            Just bs -> do
                now <- getTimeMicrosecond
                let quicBit = greaseQuicBit $ getMyParameters conn
                pkts <- decodePackets bs (not quicBit)
                mapM_ (putQ now) pkts
                loop recv
    logAction msg = connDebugLog conn ("debug: readerClient: " <> msg)
    putQ _ (PacketIB BrokenPacket _) = return ()
    putQ t (PacketIV pkt@(VersionNegotiationPacket dCID sCID peerVers)) = do
        qlogReceived conn pkt t
        myVerInfo <- getVersionInfo conn
        let myVer = chosenVersion myVerInfo
            myVers0 = otherVersions myVerInfo
        -- ignoring VN if the original version is included.
        when (myVer `notElem` peerVers && Negotiation `notElem` peerVers) $ do
            ok <- checkCIDs conn dCID (Left sCID)
            let myVers = filter (not . isGreasingVersion) myVers0
                nextVerInfo = case myVers `intersect` peerVers of
                    vers@(ver : _) | ok -> VersionInfo ver vers
                    _ -> brokenVersionInfo
            E.throwTo (mainThreadId conn) $ VerNego nextVerInfo
    putQ t (PacketIC pkt@(CryptPacket hdr crypt) lvl siz) = do
        let cid = headerMyCID hdr
        included <- myCIDsInclude conn cid
        case included of
            Just _ -> writeRecvQ (connRecvQ conn) $ mkReceivedPacket pkt t siz lvl
            Nothing -> case decodeStatelessResetToken (cryptPacket crypt) of
                Just token -> do
                    isStatelessReset <- isStatelessRestTokenValid conn token
                    -- Our client does not send a stateless reset:
                    -- 1) Stateless reset token is not generated for
                    --    the my first CID.
                    -- 2) It's unlikely that QUIC packets are delivered
                    --    to a new UDP port when out client is rebooted.
                    when isStatelessReset $ do
                        qlogReceived conn StatelessReset t
                        connDebugLog conn "debug: connection is reset statelessly"
                        E.throwTo (mainThreadId conn) ConnectionIsReset
                _ -> return () -- really invalid, just ignore
    putQ t (PacketIR pkt@(RetryPacket ver dCID sCID token ex)) = do
        qlogReceived conn pkt t
        ok <- checkCIDs conn dCID ex
        when ok $ do
            -- Re-creating peer's CIDDB with peer's CID.
            resetPeerCID conn sCID
            setPeerAuthCIDs conn $ \auth -> auth{retrySrcCID = Just sCID}
            initializeCoder conn InitialLevel $ initialSecrets ver sCID
            setToken conn token
            setRetried conn True
            releaseByRetry (connLDCC conn) >>= mapM_ put
      where
        put ppkt = putOutput conn $ OutRetrans ppkt

checkCIDs :: Connection -> CID -> Either CID (ByteString, ByteString) -> IO Bool
checkCIDs conn dCID (Left sCID) = do
    localCID <- getMyCID conn
    remoteCID <- getPeerCID conn
    return (dCID == localCID && sCID == remoteCID)
checkCIDs conn dCID (Right (pseudo0, tag)) = do
    localCID <- getMyCID conn
    remoteCID <- getPeerCID conn
    ver <- getVersion conn
    let ok = calculateIntegrityTag ver remoteCID pseudo0 == tag
    return (dCID == localCID && ok)

recvClient :: RecvQ -> IO ReceivedPacket
recvClient = readRecvQ

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

-- | How to control a connection.
data ConnectionControl
    = ChangeServerCID
    | ChangeClientCID
    | NATRebinding
    | ActiveMigration
    deriving (Eq, Show)

controlConnection :: Connection -> ConnectionControl -> IO Bool
controlConnection conn typ
    | isClient conn = do
        waitEstablished conn
        controlConnection' conn typ
    | otherwise = return False

----------------------------------------------------------------
-- ping: NewConnectionID(retirePriorTo), pong: RetireConnectionID
--
-- RFC 9000 Sec 5.1.2: Upon receipt of an increased Retire Prior To
-- field, the peer MUST stop using the corresponding connection IDs
-- and retire them with RETIRE_CONNECTION_ID frames before adding the
-- newly provided connection ID to the set of active connection IDs.
--
-- An endpoint MUST NOT forget a connection ID without retiring it.
--
----------------------------------------------------------------
-- ping: RetireConnectionID, pong: NewConnectionID
--
-- RFC 9000 Sec 5.1.1: An endpoint SHOULD supply a new connection ID
-- when the peer retires a connection ID.
-- RFC 9000 Sec 5.1.2: Sending a RETIRE_CONNECTION_ID frame indicates
-- that the connection ID will not be used again and requests that the
-- peer replace it with a new connection ID using a NEW_CONNECTION_ID
-- frame.
--
----------------------------------------------------------------
-- ping: PathChallenge, pong: PathResponse
--
-- RFC 9000 Sec 8.2.2: On receiving a PATH_CHALLENGE frame, an
-- endpoint MUST respond by echoing the data contained in the
-- PATH_CHALLENGE frame in a PATH_RESPONSE frame.
--
controlConnection' :: Connection -> ConnectionControl -> IO Bool
----------------------------------------------------------------
-- ChangeServerCID (-M)
--
-- Co -> Sn: RetireConnectionID(So)
-- Cn <- Sn: NewConnectionID (receiver)
controlConnection' conn ChangeServerCID = do
    mn <- timeout (Microseconds 1000000) "controlConnection' 1" $ waitPeerCID conn -- fixme
    case mn of
        Nothing -> return False
        Just cidInfo -> do
            let seqNum = cidInfoSeq cidInfo
            retirePeerCID conn seqNum
            -- Client tells "I don't use this CID of yours".
            sendFrames conn RTT1Level [RetireConnectionID seqNum]
            return True
----------------------------------------------------------------
-- ChangeClientCID (-N)
--
-- Co -> So: NewConnectionID(retirePriorTo Co)
-- Cn <- Sn: RetireConnectionID(Co) (processFrame)
controlConnection' conn ChangeClientCID = do
    -- checkPeerCIDCapacity is not necessary beucase one CID is
    -- retired.
    cidInfo <- getNewMyCID conn
    retirePriorTo' <- (+ 1) <$> getMyCIDSeqNum conn
    setMyRetirePriorTo conn retirePriorTo' -- just for record
    writeIORef (sentRetirePriorTo conn) True
    -- Client tells "My CIDs less than retirePriorTo should be retired".
    sendFrames conn RTT1Level [NewConnectionID cidInfo retirePriorTo']
    return True
----------------------------------------------------------------
-- NATRebinding (-B)
--
-- <local port change>
-- So -> Co: PathChallenge (validatePath)
-- Co -> So: PathResponse (processFrame)
controlConnection' conn NATRebinding = do
    rebind conn $ Microseconds 5000 -- nearly 0
    return True
----------------------------------------------------------------
-- ActiveMigration (-A)
--
-- <local port change>
-- Co -> Sn: NewConnectionID(retirePriorTo Co), RetireConnectionID(So), PathChallenge (validatePath)
-- Cn <- Sn: RetireConnectionID(Co), PathChallenge (validatePath)
-- Cn <- Sn: NewConnectionID (receiver)
-- Cn -> Sn: PathResponse (processFrame)
-- Cn <- Sn: PathResponse (processFrame)
controlConnection' conn ActiveMigration = do
    -- Changing peer CID
    mn <- timeout (Microseconds 1000000) "controlConnection' 2" $ waitPeerCID conn -- fixme
    case mn of
        Nothing -> return False
        mcidinfo -> do
            peersa <- peerSockAddr <$> getPathInfo conn
            rebind conn $ Microseconds 5000000
            -- Sending PathChallenge, RetireConnectionID and NewConnectionID RPT
            pathInfo <- newPathInfo peersa
            addPathInfo conn pathInfo
            validatePath conn pathInfo mcidinfo
            return True

rebind :: Connection -> Microseconds -> IO ()
rebind conn microseconds = do
    peersa <- peerSockAddr <$> getPathInfo conn
    newSock <- natRebinding peersa
    connected <- getSockConnected conn
    when connected $ connect newSock peersa
    oldSock <- setSocket conn newSock
    let reader = readerClient newSock conn
    forkManaged conn reader
    fire conn microseconds $ close oldSock