Receiver.hs

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

module Network.QUIC.Receiver (
    receiver,
) where

import qualified Control.Exception as E
import qualified Data.ByteString as BS
import Network.Control
import Network.TLS (AlertDescription (..))
import System.Log.FastLogger

import Network.QUIC.Config
import Network.QUIC.Connection
import Network.QUIC.Connector
import Network.QUIC.Crypto
import Network.QUIC.Exception
import Network.QUIC.Imports
import Network.QUIC.Info
import Network.QUIC.Logger
import Network.QUIC.Packet
import Network.QUIC.Parameters
import Network.QUIC.Qlog
import Network.QUIC.Recovery
import Network.QUIC.Stream
import Network.QUIC.Types as QUIC

receiver :: Connection -> IO ()
receiver conn = handleLogT logAction body
  where
    body = do
        loopHandshake
        loopEstablished
    recvTimeout = do
        -- The spec says that CC is not sent when timeout.
        -- But we intentionally sends CC when timeout.
        ito <- readMinIdleTimeout conn
        mx <- timeout ito "recvTimeout" $ connRecv conn -- fixme: taking minimum with peer's one
        case mx of
            Nothing -> do
                st <- getConnectionState conn
                let msg0
                        | isClient conn = "Client"
                        | otherwise = "Server"
                    msg = msg0 ++ " " ++ show st
                qlogDebug conn $ Debug "recv timeout"
                E.throwIO $ ConnectionIsTimeout msg
            Just x -> return x
    loopHandshake = do
        rpkt <- recvTimeout
        processReceivedPacketHandshake conn rpkt
        established <- isConnectionEstablished conn
        unless established loopHandshake
    loopEstablished = forever $ do
        rpkt <- recvTimeout
        let CryptPacket hdr _ = rpCryptPacket rpkt
            cid = headerMyCID hdr
        included <- myCIDsInclude conn cid
        case included of
            Just nseq -> do
                -- RFC 9000 Sec 5.1.1: If an endpoint provided fewer
                -- connection IDs than the peer's
                -- active_connection_id_limit, it MAY supply a new
                -- connection ID when it receives a packet with a
                -- previously unused connection ID.
                shouldUpdate <- shouldUpdateMyCID conn nseq
                capOK <- checkPeerCIDCapacity conn
                when (shouldUpdate && capOK) $ do
                    setMyCID conn cid
                    cidInfo <- getNewMyCID conn
                    when (isServer conn) $ do
                        register <- getRegister conn
                        register (cidInfoCID cidInfo) conn
                    sent <- readIORef (sentRetirePriorTo conn)
                    writeIORef (sentRetirePriorTo conn) False
                    unless sent $
                        sendFrames conn RTT1Level [NewConnectionID cidInfo 0]
                processReceivedPacket conn rpkt
                shouldUpdatePeer <-
                    if shouldUpdate
                        then shouldUpdatePeerCID conn
                        else return False
                when shouldUpdatePeer $ choosePeerCIDForPrivacy conn
            _ -> do
                qlogDropped conn (hdr, "unknown_connection_id" :: String)
                connDebugLog conn $ bhow cid <> " is unknown"
    logAction msg = connDebugLog conn ("debug: receiver: " <> msg)

processReceivedPacketHandshake :: Connection -> ReceivedPacket -> IO ()
processReceivedPacketHandshake conn rpkt = do
    let CryptPacket hdr _ = rpCryptPacket rpkt
        lvl = rpEncryptionLevel rpkt
        msg =
            "processReceivedPacketHandshake "
                ++ if isServer conn then "Server" else "Client"
    mx <- timeout (Microseconds 10000) msg $ waitEncryptionLevel conn lvl
    case mx of
        Nothing -> do
            putOffCrypto conn lvl rpkt
            when (isClient conn) $ do
                lvl' <- getEncryptionLevel conn
                speedup (connLDCC conn) lvl' ("not decryptable: " <> toLogStr (show lvl))
        Just ()
            | isClient conn -> do
                when (lvl == InitialLevel) $ do
                    peercid <- getPeerCID conn
                    let newPeerCID = headerPeerCID hdr
                    when (peercid /= headerPeerCID hdr) $
                        resetPeerCID conn newPeerCID
                    setPeerAuthCIDs conn $ \auth ->
                        auth{initSrcCID = Just newPeerCID}
                case hdr of
                    Initial peerVer _ _ _ -> do
                        myVer <- getVersion conn
                        let myOrigiVer = getOriginalVersion conn
                            firstTime = myVer == myOrigiVer
                        when (firstTime && myVer /= peerVer) $ do
                            setVersion conn peerVer
                            dcid <- getClientDstCID conn
                            initializeCoder conn InitialLevel $ initialSecrets peerVer dcid
                            qlogDebug conn $ Debug "Version changed"
                    _ -> return ()
                processReceivedPacket conn rpkt
            | otherwise -> do
                mycid <- getMyCID conn
                when
                    ( lvl == HandshakeLevel
                        || (lvl == InitialLevel && mycid == headerMyCID hdr)
                    )
                    $ do
                        getPathInfo conn >>= setAddressValidated
                when (lvl == HandshakeLevel) $ do
                    let ldcc = connLDCC conn
                    discarded <- getAndSetPacketNumberSpaceDiscarded ldcc InitialLevel
                    unless discarded $ fire conn (Microseconds 100000) $ do
                        dropSecrets conn InitialLevel
                        clearCryptoStream conn InitialLevel
                        onPacketNumberSpaceDiscarded ldcc InitialLevel
                processReceivedPacket conn rpkt

rateLimit :: Int
rateLimit = 10

checkRate :: [Frame] -> Int
checkRate fs0 = go fs0 0
  where
    go [] n = n
    go (f : fs) n
        | rateControled f = go fs (n + 1)
        | otherwise = go fs n

processReceivedPacket :: Connection -> ReceivedPacket -> IO ()
processReceivedPacket conn rpkt = do
    let CryptPacket hdr crypt = rpCryptPacket rpkt
        lvl = rpEncryptionLevel rpkt
        tim = rpTimeRecevied rpkt
    mplain <- decryptCrypt conn crypt lvl
    case mplain of
        Just plain@Plain{..} -> do
            addRxBytes conn $ rpReceivedBytes rpkt
            pathInfo <- getPathInfo conn
            addPathRxBytes pathInfo $ rpReceivedBytes rpkt
            when (isIllegalReservedBits plainMarks || isNoFrames plainMarks) $
                closeConnection conn ProtocolViolation "Non 0 RR bits or no frames"
            when (isUnknownFrame plainMarks) $
                closeConnection conn FrameEncodingError "Unknown frame"
            let controlled = checkRate plainFrames
            when (controlled /= 0) $ do
                rate <- addRate (controlRate conn) controlled
                when (rate > rateLimit) $ do
                    closeConnection conn QUIC.InternalError "Rate control"
            -- For Ping, record PPN first, then send an ACK.
            onPacketReceived (connLDCC conn) lvl plainPacketNumber
            when (lvl == RTT1Level) $ setPeerPacketNumber conn plainPacketNumber
            qlogReceived conn (PlainPacket hdr plain) tim
            let ackEli = any ackEliciting plainFrames
            (ckp, cpn) <- getCurrentKeyPhase conn
            let Flags flags = plainFlags
                nkp = flags `testBit` 2
            when (nkp /= ckp && plainPacketNumber > cpn) $ do
                setCurrentKeyPhase conn nkp plainPacketNumber
                updateCoder1RTT conn ckp -- ckp is now next
            mapM_ (processFrame conn lvl) plainFrames
            when ackEli $ do
                case lvl of
                    RTT0Level -> return ()
                    RTT1Level -> delayedAck conn
                    _ -> do
                        sup <- getSpeedingUp (connLDCC conn)
                        when sup $ do
                            qlogDebug conn $ Debug "ping for speedup"
                            sendFrames conn lvl [Ping]
        Nothing -> do
            qlogDropped conn (hdr, "decrypt_error" :: String)
            connDebugLog conn $
                "debug: cannot decrypt: "
                    <> bhow lvl
                    <> " size = "
                    <> bhow (BS.length $ cryptPacket crypt)

isSendOnly :: Connection -> StreamId -> Bool
isSendOnly conn sid
    | isClient conn = isClientInitiatedUnidirectional sid
    | otherwise = isServerInitiatedUnidirectional sid

isReceiveOnly :: Connection -> StreamId -> Bool
isReceiveOnly conn sid
    | isClient conn = isServerInitiatedUnidirectional sid
    | otherwise = isClientInitiatedUnidirectional sid

isInitiated :: Connection -> StreamId -> Bool
isInitiated conn sid
    | isClient conn = isClientInitiated sid
    | otherwise = isServerInitiated sid

guardStream :: Connection -> StreamId -> Maybe Stream -> IO ()
guardStream conn sid Nothing =
    streamNotCreatedYet
        conn
        sid
        ( "a locally-initiated stream that has not yet been created, sid = "
            <> shortpack (show sid)
        )
guardStream _ _ _ = return ()

-- fixme: what about unidirection stream?
streamNotCreatedYet :: Connection -> StreamId -> ReasonPhrase -> IO ()
streamNotCreatedYet conn sid emsg
    | isInitiated conn sid = do
        curSid <- getMyStreamId conn
        when (sid > curSid) $
            closeConnection conn StreamStateError emsg
streamNotCreatedYet _ _ _ = return ()

processFrame :: Connection -> EncryptionLevel -> Frame -> IO ()
processFrame _ _ Padding{} = return ()
processFrame conn lvl Ping = do
    -- see ackEli above
    when (lvl /= InitialLevel && lvl /= RTT1Level) $ sendFrames conn lvl []
processFrame conn lvl (Ack ackInfo ackDelay) = do
    when (lvl == RTT0Level) $ closeConnection conn ProtocolViolation "ACK"
    onAckReceived (connLDCC conn) lvl ackInfo $ milliToMicro ackDelay
processFrame conn lvl (ResetStream sid aerr _finlen) = do
    when (lvl == InitialLevel || lvl == HandshakeLevel) $
        closeConnection conn ProtocolViolation "RESET_STREAM"
    when (isSendOnly conn sid) $
        closeConnection conn StreamStateError "Received in a send-only stream"
    mstrm <- findStream conn sid
    case mstrm of
        Nothing -> return ()
        Just strm -> do
            onResetStreamReceived (connHooks conn) strm aerr
            setTxStreamClosed strm
            setRxStreamClosed strm
            delStream conn strm
processFrame conn lvl (StopSending sid err) = do
    ok <- rateOK conn
    when ok $ do
        when (lvl == InitialLevel || lvl == HandshakeLevel) $
            closeConnection conn ProtocolViolation "STOP_SENDING"
        when (isReceiveOnly conn sid) $
            closeConnection conn StreamStateError "Receive-only stream"
        mstrm <- findStream conn sid
        case mstrm of
            Nothing -> streamNotCreatedYet conn sid "No such stream for STOP_SENDING"
            Just _strm -> sendFrames conn lvl [ResetStream sid err 0]
processFrame _ _ (CryptoF _ "") = return ()
processFrame conn lvl (CryptoF off cdat) = do
    when (lvl == RTT0Level) $
        closeConnection conn ProtocolViolation "CRYPTO in 0-RTT"
    let len = BS.length cdat
        rx = RxStreamData cdat off len False
    case lvl of
        InitialLevel -> do
            dup <- putRxCrypto conn lvl rx
            when dup $ speedup (connLDCC conn) lvl "duplicated"
        RTT0Level -> do
            connDebugLog conn $ "processFrame: invalid packet type " <> bhow lvl
        HandshakeLevel -> do
            dup <- putRxCrypto conn lvl rx
            when dup $ speedup (connLDCC conn) lvl "duplicated"
        RTT1Level
            | isClient conn ->
                void $ putRxCrypto conn lvl rx
            | otherwise ->
                closeConnection conn (cryptoError UnexpectedMessage) "CRYPTO in 1-RTT"
processFrame conn lvl (NewToken token) = do
    when (isServer conn || lvl /= RTT1Level) $
        closeConnection conn ProtocolViolation "NEW_TOKEN for server or in 1-RTT"
    when (isClient conn) $ setNewToken conn token
processFrame conn RTT0Level (StreamF sid off (dat : _) fin) = do
    when (off == 0) $ updatePeerStreamId conn sid
    -- FLOW CONTROL: MAX_STREAMS: recv: rejecting if over my limit
    ok <- checkRxMaxStreams conn sid
    unless ok $ closeConnection conn StreamLimitError "stream id is too large"
    when (isSendOnly conn sid) $
        closeConnection conn StreamStateError "send-only stream"
    mstrm <- findStream conn sid
    guardStream conn sid mstrm
    strm <- maybe (createStream conn sid) return mstrm
    let len = BS.length dat
        rx = RxStreamData dat off len fin
    fc <- putRxStreamData strm rx
    case fc of
        -- FLOW CONTROL: MAX_STREAM_DATA: recv: rejecting if over my limit
        OverLimit ->
            closeConnection conn FlowControlError "Flow control error for stream in 0-RTT"
        Duplicated -> return ()
        Reassembled -> do
            ok' <- checkRxMaxData conn len
            -- FLOW CONTROL: MAX_DATA: send: respecting peer's limit
            unless ok' $
                closeConnection
                    conn
                    FlowControlError
                    "Flow control error for connection in 0-RTT"
processFrame conn RTT1Level (StreamF sid _ [""] False) = do
    -- FLOW CONTROL: MAX_STREAMS: recv: rejecting if over my limit
    ok <- checkRxMaxStreams conn sid
    unless ok $ closeConnection conn StreamLimitError "stream id is too large"
    when (isSendOnly conn sid) $
        closeConnection conn StreamStateError "send-only stream"
    mstrm <- findStream conn sid
    guardStream conn sid mstrm
processFrame conn RTT1Level (StreamF sid off (dat : _) fin) = do
    when (off == 0) $ updatePeerStreamId conn sid
    -- FLOW CONTROL: MAX_STREAMS: recv: rejecting if over my limit
    ok <- checkRxMaxStreams conn sid
    unless ok $ closeConnection conn StreamLimitError "stream id is too large"
    when (isSendOnly conn sid) $
        closeConnection conn StreamStateError "send-only stream"
    mstrm <- findStream conn sid
    guardStream conn sid mstrm
    strm <- maybe (createStream conn sid) return mstrm
    let len = BS.length dat
        rx = RxStreamData dat off len fin
    fc <- putRxStreamData strm rx
    case fc of
        -- FLOW CONTROL: MAX_STREAM_DATA: recv: rejecting if over my limit
        OverLimit ->
            closeConnection conn FlowControlError "Flow control error for stream in 1-RTT"
        Duplicated -> return ()
        Reassembled -> do
            ok' <- checkRxMaxData conn len
            -- FLOW CONTROL: MAX_DATA: send: respecting peer's limit
            unless ok' $
                closeConnection
                    conn
                    FlowControlError
                    "Flow control error for connection in 1-RTT"
processFrame conn lvl (MaxData n) = do
    when (lvl == InitialLevel || lvl == HandshakeLevel) $
        closeConnection conn ProtocolViolation "MAX_DATA in Initial or Handshake"
    setTxMaxData conn n
processFrame conn lvl (MaxStreamData sid n) = do
    when (lvl == InitialLevel || lvl == HandshakeLevel) $
        closeConnection conn ProtocolViolation "MAX_STREAM_DATA in Initial or Handshake"
    when (isReceiveOnly conn sid) $
        closeConnection conn StreamStateError "Receive-only stream"
    mstrm <- findStream conn sid
    case mstrm of
        Nothing -> streamNotCreatedYet conn sid "No such stream for MAX_STREAM_DATA"
        Just strm -> setTxMaxStreamData strm n
processFrame conn lvl (MaxStreams dir n) = do
    when (lvl == InitialLevel || lvl == HandshakeLevel) $
        closeConnection conn ProtocolViolation "MAX_STREAMS in Initial or Handshake"
    when (n > 2 ^ (60 :: Int)) $
        closeConnection conn FrameEncodingError "Too large MAX_STREAMS"
    if dir == Bidirectional
        then setTxMaxStreams conn n
        else setTxUniMaxStreams conn n
processFrame _conn _lvl DataBlocked{} = return ()
processFrame _conn _lvl (StreamDataBlocked _sid _) = return ()
processFrame conn lvl (StreamsBlocked _dir n) = do
    when (lvl == InitialLevel || lvl == HandshakeLevel) $
        closeConnection conn ProtocolViolation "STREAMS_BLOCKED in Initial or Handshake"
    when (n > 2 ^ (60 :: Int)) $
        closeConnection conn FrameEncodingError "Too large STREAMS_BLOCKED"
processFrame conn lvl (NewConnectionID cidInfo retirePriorTo) = do
    when (lvl == InitialLevel || lvl == HandshakeLevel) $
        closeConnection
            conn
            ProtocolViolation
            "NEW_CONNECTION_ID in Initial or Handshake"
    ok <- rateOK conn
    when ok $ do
        let (_, cidlen) = unpackCID $ cidInfoCID cidInfo
            seqNum = cidInfoSeq cidInfo
        when (cidlen < 1 || 20 < cidlen || retirePriorTo > seqNum) $
            closeConnection conn FrameEncodingError "NEW_CONNECTION_ID parameter error"
        -- Retiring CIDs first then add a new CID.
        --
        -- RFC 9000 Sec 5.1.1 says:
        -- An endpoint MAY send connection IDs that temporarily exceed a
        -- peer's limit if the NEW_CONNECTION_ID frame also requires the
        -- retirement of any excess, by including a sufficiently large
        -- value in the Retire Prior To field.
        prevRetirePriorTo <- getPeerRetirePriorTo conn
        -- RFC 900 Sec 19.15 says:
        -- Once a sender indicates a Retire Prior To value, smaller values
        -- sent in subsequent NEW_CONNECTION_ID frames have no effect. A
        -- receiver MUST ignore any Retire Prior To fields that do not
        -- increase the largest received Retire Prior To value.
        when (retirePriorTo >= prevRetirePriorTo) $ do
            -- RFC 9000 Sec 5.1.2 says:
            -- 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.
            seqNums <- setPeerCIDAndRetireCIDs conn retirePriorTo -- upadting RPT
            sendFrames conn RTT1Level $ map RetireConnectionID seqNums
        -- Adding a new CID
        if seqNum < prevRetirePriorTo
            then
                -- RFC 9000 Sec 19.15 says:
                -- An endpoint that receives a NEW_CONNECTION_ID frame
                -- with a sequence number smaller than the Retire Prior To
                -- field of a previously received NEW_CONNECTION_ID frame
                -- MUST send a corresponding RETIRE_CONNECTION_ID frame
                -- that retires the newly received connection ID, unless
                -- it has already done so for that sequence number.
                sendFrames conn RTT1Level [RetireConnectionID seqNum]
            else do
                ng <- not <$> addPeerCID conn cidInfo
                when ng $
                    closeConnection conn ConnectionIdLimitError "NEW_CONNECTION_ID limit error"
processFrame conn RTT1Level (RetireConnectionID sn) = do
    -- FIXME: CID is necessary here
    -- The sequence number specified in a RETIRE_CONNECTION_ID frame
    -- MUST NOT refer to the Destination Connection ID field of the
    -- packet in which the frame is contained. The peer MAY treat this
    -- as a connection error of type PROTOCOL_VIOLATION.
    mcidInfo <- retireMyCID conn sn
    case mcidInfo of
        Nothing -> return ()
        Just cidInfo -> do
            -- Don't send NewConnectionID since we don't know it is
            -- ping or pong. If this is a pong, NewConnectionID should
            -- not be send back. Instead, loopEstablished sends it
            -- when CID is changed.
            when (isServer conn) $ do
                unregister <- getUnregister conn
                unregister $ cidInfoCID cidInfo
processFrame conn RTT1Level (PathChallenge dat) = do
    ok <- rateOK conn
    when ok $ sendFrames conn RTT1Level [PathResponse dat]
processFrame conn RTT1Level (PathResponse dat) =
    -- RTT0Level falls intentionally
    checkResponse conn dat
processFrame conn lvl (ConnectionClose NoError _ftyp reason) =
    when (isServer conn || lvl /= RTT1Level) $ E.throwIO $ ConnectionIsClosed reason
processFrame _conn _lvl (ConnectionClose err _ftyp reason) = do
    let quicexc = TransportErrorIsReceived err reason
    E.throwIO quicexc
processFrame _conn _lvl (ConnectionCloseApp err reason) = do
    let quicexc = ApplicationProtocolErrorIsReceived err reason
    E.throwIO quicexc
processFrame conn lvl HandshakeDone = do
    when (isServer conn || lvl /= RTT1Level) $
        closeConnection conn ProtocolViolation "HANDSHAKE_DONE for server"
    fire conn (Microseconds 100000) $ do
        let ldcc = connLDCC conn
        discarded0 <- getAndSetPacketNumberSpaceDiscarded ldcc RTT0Level
        unless discarded0 $ dropSecrets conn RTT0Level
        discarded1 <- getAndSetPacketNumberSpaceDiscarded ldcc HandshakeLevel
        unless discarded1 $ do
            dropSecrets conn HandshakeLevel
            onPacketNumberSpaceDiscarded ldcc HandshakeLevel
        clearCryptoStream conn HandshakeLevel
        clearCryptoStream conn RTT1Level
    setConnectionEstablished conn
    getConnectionInfo conn >>= onConnectionEstablished (connHooks conn)
    -- to receive NewSessionTicket
    fire conn (Microseconds 1000000) $ killHandshaker conn lvl
processFrame conn _ _ = closeConnection conn ProtocolViolation "Frame is not allowed"

-- Return value indicates duplication.
putRxCrypto :: Connection -> EncryptionLevel -> RxStreamData -> IO Bool
putRxCrypto conn lvl rx = do
    mstrm <- getCryptoStream conn lvl
    case mstrm of
        Nothing -> return False
        Just strm -> do
            let put = putCrypto conn . InpHandshake lvl
                putFin = return ()
            tryReassemble strm rx put putFin

killHandshaker :: Connection -> EncryptionLevel -> IO ()
killHandshaker conn lvl = putCrypto conn $ InpHandshake lvl ""