quic 0.3.4 → 0.3.5
raw patch · 29 files changed
+777/−165 lines, 29 filesdep +directorydep ~cryptonPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: directory
Dependency ranges changed: crypton
API changes (from Hackage documentation)
- Network.QUIC.Internal: fromAckInfoWithMin :: AckInfo -> PacketNumber -> [PacketNumber]
+ Network.QUIC.Internal: TooFragmented :: FlowCntl
+ Network.QUIC.Internal: cryptoBufferSize :: Int
+ Network.QUIC.Internal: dirQLogger :: Maybe FilePath -> TimeMicrosecond -> CID -> ByteString -> IO (QLogger, IO ())
+ Network.QUIC.Internal: maxCIDLength :: Int
+ Network.QUIC.Internal: maxReassFragments :: Int
+ Network.QUIC.Internal: putRxCryptoData :: Stream -> Int -> RxStreamData -> (StreamData -> IO ()) -> IO FlowCntl
+ Network.QUIC.Internal: supportedCipher :: Cipher -> Bool
+ Network.QUIC.Internal: unsupportedCipher :: String -> Cipher -> a
+ Network.QUIC.Internal: validAckInfo :: AckInfo -> Bool
- Network.QUIC.Internal: tryReassemble :: Stream -> RxStreamData -> (StreamData -> IO ()) -> IO () -> IO Bool
+ Network.QUIC.Internal: tryReassemble :: Stream -> RxStreamData -> (StreamData -> IO ()) -> IO () -> IO FlowCntl
Files
- ChangeLog.md +47/−0
- Network/QUIC/Crypto/Nite.hs +24/−7
- Network/QUIC/Crypto/Utils.hs +4/−10
- Network/QUIC/Handshake.hs +14/−0
- Network/QUIC/Internal.hs +2/−0
- Network/QUIC/Packet/Decode.hs +17/−4
- Network/QUIC/Packet/Decrypt.hs +13/−2
- Network/QUIC/Packet/Encode.hs +13/−1
- Network/QUIC/Parameters.hs +73/−30
- Network/QUIC/QLogger.hs +10/−1
- Network/QUIC/Receiver.hs +38/−3
- Network/QUIC/Recovery/Interface.hs +1/−1
- Network/QUIC/Recovery/LossRecovery.hs +6/−6
- Network/QUIC/Recovery/Timer.hs +21/−11
- Network/QUIC/Sender.hs +20/−6
- Network/QUIC/Stream.hs +1/−0
- Network/QUIC/Stream/Reass.hs +55/−24
- Network/QUIC/Stream/Types.hs +3/−2
- Network/QUIC/Types/Ack.hs +38/−32
- Network/QUIC/Types/CID.hs +9/−0
- Network/QUIC/Types/Constants.hs +27/−0
- quic.cabal +7/−2
- test/Config.hs +30/−23
- test/PacketSpec.hs +81/−0
- test/ParametersSpec.hs +54/−0
- test/QLoggerSpec.hs +36/−0
- test/ReassSpec.hs +45/−0
- test/TransportError.hs +71/−0
- test/TypesSpec.hs +17/−0
ChangeLog.md view
@@ -1,5 +1,52 @@ # ChangeLog +## 0.3.5++Security fixes. The first four can be reached by a peer that has not+authenticated itself.++* Drop a packet whose header protection sample is not whole. A sample of 1+ to 15 octets reached the cipher, which raised rather than answering with a+ short mask, and the connection went with it. One conforming datagram did+ it.+ [#95](https://github.com/kazu-yamamoto/quic/pull/95)+* Bound the CRYPTO data held out of order. CRYPTO frames sit outside the+ flow control that bounds stream data, so nothing stopped a peer parking+ fragments at scattered offsets and having every one held.+ CryptoBufferExceeded had been defined and never used.+ [#96](https://github.com/kazu-yamamoto/quic/pull/96)+* Decode the peer's transport parameters to the Maybe the type promises,+ rather than raising BufferOverrun out of a pure value.+ [#97](https://github.com/kazu-yamamoto/quic/pull/97)+* Refuse a transport parameter sent twice, and stream limits past 2^60.+ [#105](https://github.com/kazu-yamamoto/quic/pull/105)+* Stop the sender deadlocking on a congestion window it cannot free.+ Padding an ACK-only packet put it in flight, spending window that nothing+ would give back once the loss timer had been cancelled, and the loss timer+ could not be re-armed from another level.+ [#103](https://github.com/kazu-yamamoto/quic/pull/103)+* Leave the peer a whole header protection sample when encoding.+ [#104](https://github.com/kazu-yamamoto/quic/pull/104)+* Bound a connection id and a Retry packet in the long header decoder.+ [#106](https://github.com/kazu-yamamoto/quic/pull/106)+* Bound how many pieces a stream may be held in. Flow control counts octets,+ not fragments, and a fragment costs far more than the octet it carries.+ [#108](https://github.com/kazu-yamamoto/quic/pull/108)+* Check the ranges an ACK frame carries, and refuse an ACK for a packet never+ sent.+ [#109](https://github.com/kazu-yamamoto/quic/pull/109)+* Give the two ends of a connection their own qlog file. Pointing both at+ one directory took the server down.+ [#100](https://github.com/kazu-yamamoto/quic/pull/100)+* Remove the partial functions that were worth removing.+ [#107](https://github.com/kazu-yamamoto/quic/pull/107)+* Requiring crypton v2.0.1, whose 2.0.0 dispatched an XOP instruction on+ CPUs without XOP.+ [crypton#202](https://github.com/kazu-yamamoto/crypton/issues/202)+* This is a patch release, but `Network.QUIC.Internal` changed:+ `fromAckInfoWithMin` is gone, `FlowCntl` has `TooFragmented`, and+ `tryReassemble` returns `FlowCntl` rather than `Bool`.+ ## 0.3.4 * Add a server option to request client certificates.
Network/QUIC/Crypto/Nite.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE ScopedTypeVariables #-} module Network.QUIC.Crypto.Nite (+ supportedCipher,+ unsupportedCipher, niteEncrypt, niteEncrypt', niteDecrypt,@@ -28,6 +30,7 @@ import Foreign.Ptr (Ptr, nullPtr, plusPtr) import Foreign.Storable (peek, poke) import Network.TLS hiding (Version)+import qualified Network.TLS as TLS import Network.TLS.Extra.Cipher import Network.QUIC.Crypto.Types@@ -36,6 +39,24 @@ ---------------------------------------------------------------- +-- | The ciphers this implements.+--+-- AES-128-CCM is a TLS 1.3 cipher suite and is deliberately not here: there+-- is no CCM in cipherEncrypt or cipherDecrypt. It used to be accepted by the+-- two length functions below, so configuring it got past them and failed+-- later, inside encryption, with nothing to say which cipher it meant.+supportedCipher :: Cipher -> Bool+supportedCipher cipher =+ cipher+ `elem` [ cipher13_AES_128_GCM_SHA256+ , cipher13_AES_256_GCM_SHA384+ , cipher13_CHACHA20_POLY1305_SHA256+ ]++unsupportedCipher :: String -> Cipher -> a+unsupportedCipher fun cipher =+ error $ fun ++ ": unsupported cipher " ++ show (TLS.cipherName cipher)+ -- It would be nice to take [PlainText] and update AEAD context with -- [PlainText]. But since each PlainText is not aligned to cipher block, -- it's impossible.@@ -44,24 +65,22 @@ cipherEncrypt cipher key@(Key key') (Nonce nonce) | cipher == cipher13_AES_128_GCM_SHA256 = quicAeadEncrypt (aesGCMInit key nonce :: Maybe (AEAD AES128)) 16- | cipher == cipher13_AES_128_CCM_SHA256 = error "cipher13_AES_128_CCM_SHA256" | cipher == cipher13_AES_256_GCM_SHA384 = quicAeadEncrypt (aesGCMInit key nonce :: Maybe (AEAD AES256)) 16 | cipher == cipher13_CHACHA20_POLY1305_SHA256 = quicAeadEncrypt (maybeCryptoError $ aeadChacha20poly1305Init key' nonce) 16- | otherwise = error "cipherEncrypt"+ | otherwise = unsupportedCipher "cipherEncrypt" cipher cipherDecrypt :: Cipher -> Key -> Nonce -> CipherText -> AssDat -> Maybe PlainText cipherDecrypt cipher key@(Key key') (Nonce nonce) | cipher == cipher13_AES_128_GCM_SHA256 = quicAeadDecrypt (aesGCMInit key nonce :: Maybe (AEAD AES128)) 16- | cipher == cipher13_AES_128_CCM_SHA256 = error "cipher13_AES_128_CCM_SHA256" | cipher == cipher13_AES_256_GCM_SHA384 = quicAeadDecrypt (aesGCMInit key nonce :: Maybe (AEAD AES256)) 16 | cipher == cipher13_CHACHA20_POLY1305_SHA256 = quicAeadDecrypt (maybeCryptoError $ aeadChacha20poly1305Init key' nonce) 16- | otherwise = error "cipherDecrypt"+ | otherwise = unsupportedCipher "cipherDecrypt" cipher -- IMPORTANT: Using 'let' so that parameters can be memorized. quicAeadEncrypt@@ -222,11 +241,9 @@ cipherHeaderProtection :: Cipher -> Key -> (Sample -> Mask) cipherHeaderProtection cipher key | cipher == cipher13_AES_128_GCM_SHA256 = aes128ecbEncrypt key- | cipher == cipher13_AES_128_CCM_SHA256 = error "cipher13_AES_128_CCM_SHA256 " | cipher == cipher13_AES_256_GCM_SHA384 = aes256ecbEncrypt key | cipher == cipher13_CHACHA20_POLY1305_SHA256 = chacha20HeaderProtection key- | otherwise =- error "cipherHeaderProtection"+ | otherwise = unsupportedCipher "cipherHeaderProtection" cipher aes128ecbEncrypt :: Key -> (Sample -> Mask) aes128ecbEncrypt (Key key) = case maybeCryptoError $ cipherInit key of
Network/QUIC/Crypto/Utils.hs view
@@ -27,19 +27,13 @@ tagLength :: Cipher -> Int tagLength cipher- | cipher == cipher13_AES_128_GCM_SHA256 = 16- | cipher == cipher13_AES_128_CCM_SHA256 = 16- | cipher == cipher13_AES_256_GCM_SHA384 = 16- | cipher == cipher13_CHACHA20_POLY1305_SHA256 = 16- | otherwise = error "tagLength"+ | supportedCipher cipher = 16+ | otherwise = unsupportedCipher "tagLength" cipher sampleLength :: Cipher -> Int sampleLength cipher- | cipher == cipher13_AES_128_GCM_SHA256 = 16- | cipher == cipher13_AES_128_CCM_SHA256 = 16- | cipher == cipher13_AES_256_GCM_SHA384 = 16- | cipher == cipher13_CHACHA20_POLY1305_SHA256 = 16- | otherwise = error "sampleLength"+ | supportedCipher cipher = 16+ | otherwise = unsupportedCipher "sampleLength" cipher ----------------------------------------------------------------
Network/QUIC/Handshake.hs view
@@ -5,6 +5,7 @@ import qualified Control.Exception as E import Data.List (intersect)+import qualified Data.ByteString.Short as Short import qualified Network.TLS as TLS import Network.TLS.QUIC @@ -276,6 +277,19 @@ when (ackDelayExponent params > 20) sendCCParamError when (maxAckDelay params >= 2 ^ (14 :: Int)) sendCCParamError when (activeConnectionIdLimit params < 2) sendCCParamError+ -- RFC 9000 Sec 18.2: "values above 2^60 are invalid". A stream id+ -- has 62 bits with two taken for who opened it and whether it is+ -- bidirectional, so a count past 2^60 names no stream. The+ -- MAX_STREAMS frame is already checked for this; the parameter that+ -- sets the same limit at the start was not.+ when (initialMaxStreamsBidi params > 2 ^ (60 :: Int)) sendCCParamError+ when (initialMaxStreamsUni params > 2 ^ (60 :: Int)) sendCCParamError+ -- Sec 18.2 gives the token as sixteen octets, and Sec 10.3 reads+ -- exactly that many from the end of a datagram to compare against.+ -- A token of some other length could never match one, so it is not+ -- a token.+ forM_ (statelessResetToken params) $ \(StatelessResetToken srt) ->+ when (Short.length srt /= 16) sendCCParamError when (isServer conn) $ do when (isJust $ originalDestinationConnectionId params) sendCCParamError when (isJust $ preferredAddress params) sendCCParamError
Network/QUIC/Internal.hs view
@@ -7,6 +7,7 @@ module Network.QUIC.Packet, module Network.QUIC.Parameters, module Network.QUIC.Qlog,+ module Network.QUIC.QLogger, module Network.QUIC.Stream, module Network.QUIC.TLS, module Network.QUIC.Types,@@ -25,6 +26,7 @@ import Network.QUIC.Logger import Network.QUIC.Packet import Network.QUIC.Parameters+import Network.QUIC.QLogger import Network.QUIC.Qlog import Network.QUIC.Recovery import Network.QUIC.Socket
Network/QUIC/Packet/Decode.hs view
@@ -108,11 +108,18 @@ decodeLongHeader :: ReadBuffer -> IO (Version, CID, CID) decodeLongHeader rbuf = do ver <- Version <$> read32 rbuf- dcidlen <- fromIntegral <$> read8 rbuf- dCID <- makeCID <$> extractShortByteString rbuf dcidlen- scidlen <- fromIntegral <$> read8 rbuf- sCID <- makeCID <$> extractShortByteString rbuf scidlen+ dCID <- getCID+ sCID <- getCID return (ver, dCID, sCID)+ where+ -- The length is one octet, so it can say up to 255, but RFC 9000 section+ -- 17.2 caps a connection id at 20 and tells an endpoint receiving a+ -- longer one to drop the packet. Throwing here does that: decodePacket+ -- catches it and answers BrokenPacket.+ getCID = do+ len <- fromIntegral <$> read8 rbuf+ when (len > maxCIDLength) $ E.throwIO BufferOverrun+ makeCID <$> extractShortByteString rbuf len decodeVersionNegotiationPacket :: ReadBuffer -> CID -> CID -> IO PacketI decodeVersionNegotiationPacket rbuf dCID sCID = do@@ -130,6 +137,12 @@ :: ReadBuffer -> Flags Protected -> Version -> CID -> CID -> IO PacketI decodeRetryPacket rbuf _proFlags version dCID sCID = do rsiz <- remainingSize rbuf+ -- The integrity tag is the last 16 octets and the token is whatever comes+ -- before it, possibly nothing. With fewer than 16 octets left this is not+ -- a Retry packet, and the subtraction below would go negative -- which+ -- extractByteString does not refuse. It reads a negative length+ -- backwards, from before the packet, with no check at all.+ when (rsiz < 16) $ E.throwIO BufferOverrun token <- extractByteString rbuf (rsiz - 16) siz <- savingSize rbuf pseudo <- extractByteString rbuf $ negate siz
Network/QUIC/Packet/Decrypt.hs view
@@ -27,9 +27,20 @@ let proFlags = Flags (cryptPacket `BS.index` 0) sampleOffset = cryptPktNumOffset + 4 sampleLen = sampleLength cipher- sample = Sample $ BS.take sampleLen $ BS.drop sampleOffset cryptPacket+ sample = BS.take sampleLen $ BS.drop sampleOffset cryptPacket makeMask = unprotect protector- Mask mask = makeMask sample+ -- The mask is empty when we cannot unprotect, and the packet is+ -- dropped at the uncons below. That is already how a protector+ -- without keys answers; a sample shorter than the cipher asks for+ -- has to join it *here*, because cipherHeaderProtection is not+ -- total in the length of its sample: AES refuses anything that is+ -- not a whole block and ChaCha20 indexes the first four octets.+ -- A peer chooses that length -- the Length field of a long header+ -- decides where the packet ends -- so reaching those with a short+ -- one throws out of here and takes the connection with it.+ Mask mask+ | BS.length sample == sampleLen = makeMask $ Sample sample+ | otherwise = Mask BS.empty case BS.uncons mask of Nothing -> return Nothing Just (mask1, mask2) -> do
Network/QUIC/Packet/Encode.hs view
@@ -256,7 +256,19 @@ + (if lvl /= RTT1Level then 2 else 0) + epnLen let tagLen = tagLength cipher- plainLen = case mlen of+ -- RFC 9001 Sec 5.4.2: the packet number and the protected payload+ -- together have to run at least four octets past the sample+ -- header protection takes, or the peer cannot take one -- "An+ -- endpoint MUST discard packets that are not long enough to+ -- provide a sufficient sample."+ --+ -- Nothing else here guarantees it. The smallest thing we build+ -- is a CONNECTION_CLOSE with no reason, three octets of payload,+ -- which with a one-octet packet number and the tag comes to+ -- exactly the floor -- correct by arithmetic rather than by+ -- construction, and with no room for a frame to get smaller.+ minPlainLen = sampleLength cipher + 4 - epnLen - tagLen+ plainLen = max minPlainLen $ case mlen of Nothing -> payloadWithoutPaddingSiz Just expectedLen -> expectedLen - headerLen - tagLen packetLen = headerLen + plainLen + tagLen
Network/QUIC/Parameters.hs view
@@ -14,7 +14,10 @@ getCIDsToParameters, ) where +import qualified Control.Exception as E import qualified Data.ByteString as BS+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet import qualified Data.ByteString.Short as Short import Network.Control import System.IO.Unsafe (unsafeDupablePerformIO)@@ -26,7 +29,7 @@ encodeParameters = encodeParameterList . toParameterList decodeParameters :: ByteString -> Maybe Parameters-decodeParameters bs = fromParameterList <$> decodeParameterList bs+decodeParameters bs = decodeParameterList bs >>= fromParameterList newtype Key = Key Word32 deriving (Eq, Show) type Value = ByteString@@ -131,14 +134,28 @@ , maxDatagramFrameSize = 0 } -decInt :: ByteString -> Int-decInt = fromIntegral . decodeInt+-- | The value of an integer transport parameter, or 'Nothing' if the octets+-- given are not one.+--+-- RFC 9000 section 18 gives these values as a single variable-length integer,+-- so anything else is malformed: a value too short to hold the integer it+-- announces, an empty one, or one with octets left over behind the integer it+-- does hold. 'decodeInt' answers the first two by reading off the end, which+-- from inside 'unsafeDupablePerformIO' means an exception out of a pure value+-- -- raised wherever the field is first forced, which is nowhere near here.+decInt :: ByteString -> Maybe Int+decInt bs = unsafeDupablePerformIO $+ E.handle (\BufferOverrun -> return Nothing) $+ withReadBuffer bs $ \rbuf -> do+ n <- decodeInt' rbuf+ rest <- remainingSize rbuf+ return $ if rest == 0 then Just (fromIntegral n) else Nothing encInt :: Int -> ByteString encInt = encodeInt . fromIntegral -decMilliseconds :: ByteString -> Milliseconds-decMilliseconds = Milliseconds . fromIntegral . decodeInt+decMilliseconds :: ByteString -> Maybe Milliseconds+decMilliseconds bs = Milliseconds . fromIntegral <$> decInt bs encMilliseconds :: Milliseconds -> ByteString encMilliseconds (Milliseconds n) = encodeInt $ fromIntegral n@@ -165,53 +182,72 @@ len = BS.length bs (cnt, remainder) = len `divMod` 4 -fromParameterList :: ParameterList -> Parameters-fromParameterList kvs = foldl' update params kvs+-- | 'Nothing' if any parameter's value is malformed, or if any parameter is+-- sent twice. An unknown /key/ is neither: RFC 9000 section 18.1 says to+-- ignore one.+--+-- Section 7.4.2 on the repetition: \"An endpoint MUST treat receipt of a+-- duplicate transport parameter as a connection error of type+-- TRANSPORT_PARAMETER_ERROR.\" Being unknown is not an exemption -- an+-- unknown parameter is ignored once, not permitted twice -- so the check is+-- on the key as it arrived, before anything decides whether it means+-- something here.+fromParameterList :: ParameterList -> Maybe Parameters+fromParameterList kvs0 = go IntSet.empty params kvs0 where params = baseParameters+ go :: IntSet -> Parameters -> ParameterList -> Maybe Parameters+ go _ x [] = Just x+ go seen x (kv@(Key k, _) : kvs)+ | key `IntSet.member` seen = Nothing+ | otherwise = do+ x' <- update x kv+ go (IntSet.insert key seen) x' kvs+ where+ key = fromIntegral k update x (OriginalDestinationConnectionId, v) =- x{originalDestinationConnectionId = Just (toCID v)}+ Just x{originalDestinationConnectionId = Just (toCID v)} update x (MaxIdleTimeout, v) =- x{maxIdleTimeout = decMilliseconds v}+ (\n -> x{maxIdleTimeout = n}) <$> decMilliseconds v update x (StateLessResetToken, v) =- x{statelessResetToken = Just (StatelessResetToken $ Short.toShort v)}+ Just x{statelessResetToken = Just (StatelessResetToken $ Short.toShort v)} update x (MaxUdpPayloadSize, v) =- x{maxUdpPayloadSize = decInt v}+ (\n -> x{maxUdpPayloadSize = n}) <$> decInt v update x (InitialMaxData, v) =- x{initialMaxData = decInt v}+ (\n -> x{initialMaxData = n}) <$> decInt v update x (InitialMaxStreamDataBidiLocal, v) =- x{initialMaxStreamDataBidiLocal = decInt v}+ (\n -> x{initialMaxStreamDataBidiLocal = n}) <$> decInt v update x (InitialMaxStreamDataBidiRemote, v) =- x{initialMaxStreamDataBidiRemote = decInt v}+ (\n -> x{initialMaxStreamDataBidiRemote = n}) <$> decInt v update x (InitialMaxStreamDataUni, v) =- x{initialMaxStreamDataUni = decInt v}+ (\n -> x{initialMaxStreamDataUni = n}) <$> decInt v update x (InitialMaxStreamsBidi, v) =- x{initialMaxStreamsBidi = decInt v}+ (\n -> x{initialMaxStreamsBidi = n}) <$> decInt v update x (InitialMaxStreamsUni, v) =- x{initialMaxStreamsUni = decInt v}+ (\n -> x{initialMaxStreamsUni = n}) <$> decInt v update x (AckDelayExponent, v) =- x{ackDelayExponent = decInt v}+ (\n -> x{ackDelayExponent = n}) <$> decInt v update x (MaxAckDelay, v) =- x{maxAckDelay = decMilliseconds v}+ (\n -> x{maxAckDelay = n}) <$> decMilliseconds v update x (DisableActiveMigration, _) =- x{disableActiveMigration = True}+ Just x{disableActiveMigration = True} update x (PreferredAddress, v) =- x{preferredAddress = Just v}+ Just x{preferredAddress = Just v} update x (ActiveConnectionIdLimit, v) =- x{activeConnectionIdLimit = decInt v}+ (\n -> x{activeConnectionIdLimit = n}) <$> decInt v update x (InitialSourceConnectionId, v) =- x{initialSourceConnectionId = Just (toCID v)}+ Just x{initialSourceConnectionId = Just (toCID v)} update x (RetrySourceConnectionId, v) =- x{retrySourceConnectionId = Just (toCID v)}+ Just x{retrySourceConnectionId = Just (toCID v)} update x (Grease, v) =- x{grease = Just v}+ Just x{grease = Just v} update x (GreaseQuicBit, _) =- x{greaseQuicBit = True}+ Just x{greaseQuicBit = True} update x (VersionInformation, v) =- x{versionInformation = toVersionInfo v}+ Just x{versionInformation = toVersionInfo v} update x (MaxDatagramFrameSize, v) =- x{maxDatagramFrameSize = decInt v}- update x _ = x+ (\n -> x{maxDatagramFrameSize = n}) <$> decInt v+ update x _ = Just x diff :: Eq a@@ -280,8 +316,15 @@ encodeInt' wbuf $ fromIntegral $ BS.length v copyByteString wbuf v +-- | The transport parameters a peer sent, or 'Nothing' if they are not a+-- whole list. A key, a length and that many octets, repeated until the+-- octets run out; anything that stops in the middle of one of those reads+-- off the end. decodeParameterList :: ByteString -> Maybe ParameterList-decodeParameterList bs = unsafeDupablePerformIO $ withReadBuffer bs (`go` id)+decodeParameterList bs =+ unsafeDupablePerformIO $+ E.handle (\BufferOverrun -> return Nothing) $+ withReadBuffer bs (`go` id) where go rbuf build = do rest1 <- remainingSize rbuf
Network/QUIC/QLogger.hs view
@@ -5,6 +5,7 @@ dirQLogger, ) where +import qualified Data.ByteString.Char8 as C8 import System.FilePath import System.Log.FastLogger @@ -18,8 +19,16 @@ let qLog ~_ = return () clean = return () return (qLog, clean)+-- The role belongs in the name, not only in the vantage_point inside. A+-- client names its file after the peer CID and a server after the original+-- destination CID, which for one connection are the same value -- so a client+-- and a server in one process, pointed at one directory, ask for the same+-- file. LogFileNoRotate takes the file exclusively, and the second one to+-- ask does not get a degraded log, it gets "openFile: resource busy" thrown+-- through its connection setup. For the server that is the connection, gone+-- before it began. dirQLogger (Just dir) tim cid rl = do- let file = dir </> (show cid <> ".qlog")+ let file = dir </> (show cid <> "-" <> C8.unpack rl <> ".qlog") (fastlogger, clean) <- newFastLogger1 $ LogFileNoRotate file 4096 qlogger <- newQlogger tim rl cid fastlogger return (qlogger, clean)
Network/QUIC/Receiver.hs view
@@ -239,8 +239,22 @@ processFrame conn lvl Ping = do -- see ackEli above when (lvl /= InitialLevel && lvl /= RTT1Level) $ sendFrames conn lvl []-processFrame conn lvl (Ack ackInfo ackDelay) = do+processFrame conn lvl (Ack ackInfo@(AckInfo largestAcked _ _) ackDelay) = do when (lvl == RTT0Level) $ closeConnection conn ProtocolViolation "ACK"+ -- RFC 9000 Sec 19.3.1: walking the ranges down from the largest+ -- acknowledged, "if the value of the Gap field or the value calculated is+ -- negative, an endpoint MUST generate a connection error of type+ -- FRAME_ENCODING_ERROR".+ unless (validAckInfo ackInfo) $+ closeConnection conn FrameEncodingError "Invalid ACK range"+ -- RFC 9000 Sec 13.1: "An endpoint SHOULD treat receipt of an+ -- acknowledgment for a packet it did not send as a connection error of+ -- type PROTOCOL_VIOLATION, if it is able to detect that condition." We+ -- are able to: packet numbers come from one counter, so anything at or+ -- past the next one has never left here.+ nextPN <- getPacketNumber conn+ when (largestAcked >= nextPN) $+ closeConnection conn ProtocolViolation "ACK for a packet never sent" onAckReceived (connLDCC conn) lvl ackInfo $ milliToMicro ackDelay processFrame conn lvl (ResetStream sid aerr finlen) = do when (lvl == InitialLevel || lvl == HandshakeLevel) $@@ -310,6 +324,11 @@ -- FLOW CONTROL: MAX_STREAM_DATA: recv: rejecting if over my limit OverLimit -> closeConnection conn FlowControlError "Flow control error for stream in 0-RTT"+ -- Not a flow control error: the peer is inside its window, it is+ -- just spending it in more pieces than we will hold. Rate control+ -- answers with InternalError too.+ TooFragmented ->+ closeConnection conn QUIC.InternalError "Too many stream fragments" Duplicated -> return () Reassembled -> do ok' <- checkRxMaxData conn len@@ -344,6 +363,11 @@ -- FLOW CONTROL: MAX_STREAM_DATA: recv: rejecting if over my limit OverLimit -> closeConnection conn FlowControlError "Flow control error for stream in 1-RTT"+ -- Not a flow control error: the peer is inside its window, it is+ -- just spending it in more pieces than we will hold. Rate control+ -- answers with InternalError too.+ TooFragmented ->+ closeConnection conn QUIC.InternalError "Too many stream fragments" Duplicated -> return () Reassembled -> do ok' <- checkRxMaxData conn len@@ -498,8 +522,19 @@ Nothing -> return False Just strm -> do let put = putCrypto conn . InpHandshake lvl- putFin = return ()- tryReassemble strm rx put putFin+ fc <- putRxCryptoData strm cryptoBufferSize rx put+ case fc of+ -- RFC 9000 Sec 7.5: "If an endpoint does not expand its+ -- buffer, it MUST close the connection with a+ -- CRYPTO_BUFFER_EXCEEDED error code."+ OverLimit -> do+ closeConnection conn CryptoBufferExceeded "CRYPTO buffer exceeded"+ return False -- not reached: closeConnection throws+ TooFragmented -> do+ closeConnection conn QUIC.InternalError "Too many CRYPTO fragments"+ return False -- not reached: closeConnection throws+ Duplicated -> return True+ Reassembled -> return False killHandshaker :: Connection -> EncryptionLevel -> IO () killHandshaker conn lvl = putCrypto conn $ InpHandshake lvl ""
Network/QUIC/Recovery/Interface.hs view
@@ -46,7 +46,7 @@ unless (null packets) $ do onPacketsLost ldcc packets retransmit ldcc packets- setLossDetectionTimer ldcc lvl+ setLossDetectionTimer ldcc resender :: LDCC -> IO () resender ldcc@LDCC{..} = forever $ do
Network/QUIC/Recovery/LossRecovery.hs view
@@ -44,7 +44,7 @@ } atomicModifyIORef'' (sentPackets ! lvl) $ \(SentPackets db) -> SentPackets (db |> sentPacket)- setLossDetectionTimer ldcc lvl+ setLossDetectionTimer ldcc onPacketSentCC :: LDCC -> SentPacket -> IO () onPacketSentCC ldcc@LDCC{..} sentPacket = metricsUpdated ldcc $@@ -134,7 +134,7 @@ atomicModifyIORef'' recoveryRTT $ \rtt -> rtt{ptoCount = 0} - setLossDetectionTimer ldcc lvl+ setLossDetectionTimer ldcc releaseLostCandidates :: LDCC -> EncryptionLevel -> (SentPacket -> Bool) -> IO (Seq SentPacket)@@ -196,9 +196,9 @@ onPacketNumberSpaceDiscarded :: LDCC -> EncryptionLevel -> IO () onPacketNumberSpaceDiscarded ldcc lvl = do- let (lvl', label) = case lvl of- InitialLevel -> (HandshakeLevel, "initial")- _ -> (RTT1Level, "handshake")+ let label = case lvl of+ InitialLevel -> "initial"+ _ -> "handshake" qlogDebug ldcc $ Debug (label <> " discarded") void $ discard ldcc lvl- setLossDetectionTimer ldcc lvl'+ setLossDetectionTimer ldcc
Network/QUIC/Recovery/Timer.hs view
@@ -147,15 +147,26 @@ ---------------------------------------------------------------- -setLossDetectionTimer :: LDCC -> EncryptionLevel -> IO ()-setLossDetectionTimer ldcc@LDCC{..} lvl0 = do+-- | Arm, or cancel, the one loss detection timer.+--+-- There is one timer for the connection, not one per encryption level: it is+-- set to the earliest deadline any level has. So this takes no level, the+-- way RFC 9002 section A.8 does not. It used to take the level of whatever+-- the caller had just done and do nothing unless that matched the level the+-- deadline belonged to -- which meant a send at one level could not arm the+-- timer for another, and an arming skipped that way was skipped for good.+-- Once the timer had been cancelled it then stayed cancelled while packets+-- went on being sent: bytes in flight climbed to the congestion window, the+-- sender stopped, and nothing was left to declare the loss that would have+-- freed it.+setLossDetectionTimer :: LDCC -> IO ()+setLossDetectionTimer ldcc@LDCC{..} = do mtl <- getLossTimeAndSpace ldcc case mtl of Just (earliestLossTime, lvl) -> do- when (lvl0 == lvl) $ do- -- Time threshold loss detection.- let tmi = TimerInfo earliestLossTime lvl LossTime- updateLossDetectionTimer ldcc tmi+ -- Time threshold loss detection.+ let tmi = TimerInfo earliestLossTime lvl LossTime+ updateLossDetectionTimer ldcc tmi Nothing -> do -- See beforeAntiAmp CC{..} <- readTVarIO recoveryCC@@ -172,9 +183,8 @@ case mx of Nothing -> return () Just (ptoTime, lvl) -> do- when (lvl0 == lvl) $ do- let tmi = TimerInfo ptoTime lvl PTO- updateLossDetectionTimer ldcc tmi+ let tmi = TimerInfo ptoTime lvl PTO+ updateLossDetectionTimer ldcc tmi beforeAntiAmp :: LDCC -> IO () beforeAntiAmp ldcc = cancelLossDetectionTimer ldcc@@ -208,7 +218,7 @@ when (null lostPackets') $ qlogDebug ldcc $ Debug "onLossDetectionTimeout: null" onPacketsLost ldcc lostPackets' retransmit ldcc lostPackets'- setLossDetectionTimer ldcc lvl+ setLossDetectionTimer ldcc PTO -> do CC{..} <- readTVarIO recoveryCC if bytesInFlight > 0@@ -228,4 +238,4 @@ metricsUpdated ldcc $ atomicModifyIORef'' recoveryRTT $ \rtt -> rtt{ptoCount = ptoCount rtt + 1}- setLossDetectionTimer ldcc lvl+ setLossDetectionTimer ldcc
Network/QUIC/Sender.hs view
@@ -74,8 +74,21 @@ buildPackets _ _ _ [] _ = error "sendPacket: buildPackets" buildPackets buf bufsiz siz [spkt] build0 = do let pkt = spPlainPacket spkt+ -- Pad only what can be acknowledged. Padding puts a packet in+ -- flight (RFC 9002 Sec 2) and so spends congestion window, but it+ -- does not make the packet ack-eliciting -- and the loss timer is+ -- cancelled, correctly, when nothing ack-eliciting is in flight.+ -- An ACK-only packet padded to the full size therefore takes 1350+ -- bytes of window that nothing will ever give back: no timer, no+ -- loss declared, no release. Four of them fill a recovering+ -- window and the sender never speaks again. 1-RTT only; the+ -- handshake has its own reasons to pad.+ mlen+ | spAckEliciting spkt = Just siz+ | spEncryptionLevel spkt /= RTT1Level = Just siz+ | otherwise = Nothing (bytes, padlen) <-- encodePlainPacket conn (SizedBuffer buf bufsiz) pkt $ Just siz+ encodePlainPacket conn (SizedBuffer buf bufsiz) pkt mlen if bytes < 0 then return (build0 [], bufsiz) else do@@ -116,11 +129,12 @@ let PlainPacket _ plain0 = spPlainPacket spkt adjustForRetransmit conn $ plainFrames plain0 xs <- construct conn lvl frames False- if null xs- then qlogDebug conn $ Debug "ping NULL"- else do- let spkt = last xs- ping = spPlainPacket spkt+ -- Asking for the last one and asking whether there is one at all are+ -- the same question, so ask it once.+ case reverse xs of+ [] -> qlogDebug conn $ Debug "ping NULL"+ spkt : _ -> do+ let ping = spPlainPacket spkt let sizbuf@(SizedBuffer buf _) = encryptRes conn (bytes, padlen) <- encodePlainPacket conn sizbuf ping (Just maxSiz) when (bytes > 0) $ do
Network/QUIC/Stream.hs view
@@ -29,6 +29,7 @@ -- * Reass takeRecvStreamQwithSize, putRxStreamData,+ putRxCryptoData, FlowCntl (..), tryReassemble,
Network/QUIC/Stream/Reass.hs view
@@ -4,6 +4,7 @@ module Network.QUIC.Stream.Reass ( takeRecvStreamQwithSize, putRxStreamData,+ putRxCryptoData, FlowCntl (..), tryReassemble, ) where@@ -93,7 +94,14 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -data FlowCntl = OverLimit | Duplicated | Reassembled+data FlowCntl+ = -- | Past the octets the peer is allowed to have outstanding.+ OverLimit+ | -- | Past the number of separate pieces we will hold for one stream.+ TooFragmented+ | Duplicated+ | Reassembled+ deriving (Eq, Show) putRxStreamData :: Stream -> RxStreamData -> IO FlowCntl putRxStreamData s rx@(RxStreamData _ off len _) = do@@ -101,10 +109,7 @@ if len + off > lim then return OverLimit else do- dup <- tryReassemble s rx put putFin- if dup- then return Duplicated- else return Reassembled+ tryReassemble s rx put putFin where put "" = return () put d = do@@ -112,42 +117,57 @@ putRecvStreamQ s d putFin = putRecvStreamQ s "" +-- | Feed a CRYPTO frame to the reassembly of its stream, refusing anything+-- that would leave us holding more than @lim@ octets past the point the+-- stream has reached in order.+--+-- CRYPTO frames sit outside the flow control that bounds stream data -- they+-- have to, since they carry the handshake that settles those limits -- so+-- this is the only thing standing between a peer and an unbounded pile of+-- fragments at scattered offsets. Bounding the window bounds the pile: every+-- fragment we keep lies within it.+putRxCryptoData+ :: Stream -> Int -> RxStreamData -> (StreamData -> IO ()) -> IO FlowCntl+putRxCryptoData s lim rx@(RxStreamData _ off len _) put = do+ StreamState off0 _ <- readIORef $ streamStateRx s+ if off + len > off0 + lim+ then return OverLimit+ else tryReassemble s rx put (return ())+ -- fin of StreamState off fin means see-fin-already.--- return value indicates duplication tryReassemble- :: Stream -> RxStreamData -> (StreamData -> IO ()) -> IO () -> IO Bool-tryReassemble Stream{} (RxStreamData "" _ _ False) _ _ = return True+ :: Stream -> RxStreamData -> (StreamData -> IO ()) -> IO () -> IO FlowCntl+tryReassemble Stream{} (RxStreamData "" _ _ False) _ _ = return Duplicated tryReassemble Stream{..} x@(RxStreamData "" off _ True) _ putFin = do si0@(StreamState off0 fin0) <- readIORef streamStateRx let si1 = si0{streamFin = True} if fin0 then do -- stdoutLogger "Illegal Fin" -- fixme- return True+ return Duplicated else case off `compare` off0 of- LT -> return True+ LT -> return Duplicated EQ -> do writeIORef streamStateRx si1 putFin- return False+ return Reassembled GT -> do writeIORef streamStateRx si1- atomicModifyIORef'' streamReass (Skew.insert x)- return False+ hold streamReass x tryReassemble Stream{..} x@(RxStreamData dat off len False) put putFin = do si0@(StreamState off0 _) <- readIORef streamStateRx case off `compare` off0 of- LT -> return True+ LT -> return Duplicated EQ -> do put dat loop si0 (off0 + len)- return False- GT -> do- atomicModifyIORef'' streamReass (Skew.insert x)- return False+ return Reassembled+ GT -> hold streamReass x where loop si0 xff = do- mrxs <- atomicModifyIORef' streamReass (Skew.deleteMinIf xff)+ mrxs <- atomicModifyIORef' streamReass $ \(n, sk) ->+ let (sk', mrxs) = Skew.deleteMinIf xff sk+ in ((n - maybe 0 length mrxs, sk'), mrxs) case mrxs of Nothing -> writeIORef streamStateRx si0{streamOffset = xff} Just rxs -> do@@ -162,19 +182,30 @@ si0@(StreamState off0 fin0) <- readIORef streamStateRx let si1 = si0{streamFin = True} if fin0- then return True+ then return Duplicated else case off `compare` off0 of- LT -> return True+ LT -> return Duplicated EQ -> do let off1 = off0 + len writeIORef streamStateRx si1{streamOffset = off1} put dat putFin- return False+ return Reassembled GT -> do writeIORef streamStateRx si1- atomicModifyIORef'' streamReass (Skew.insert x)- return False+ hold streamReass x++-- | Keep a fragment that cannot be delivered yet, unless we are already+-- holding as many as we are willing to.+--+-- Flow control bounds the octets, not the pieces, and a peer that sends its+-- window one octet at a time at scattered offsets pays for the octets while+-- we pay for the pieces.+hold :: IORef (Int, Skew.Skew RxStreamData) -> RxStreamData -> IO FlowCntl+hold ref x = atomicModifyIORef' ref $ \st@(n, sk) ->+ if n >= maxReassFragments+ then (st, TooFragmented)+ else ((n + 1, Skew.insert x sk), Reassembled) hasFin :: Seq RxStreamData -> Bool hasFin s = case Seq.viewr s of
Network/QUIC/Stream/Types.hs view
@@ -38,7 +38,8 @@ , streamStateTx :: IORef StreamState -- offset, fin , streamStateRx :: IORef StreamState -- offset, fin , streamRecvQ :: RecvStreamQ -- input bytestring- , streamReass :: IORef (Skew RxStreamData) -- input stream fragments to streamQ+ , -- input stream fragments to streamQ, and how many of them+ streamReass :: IORef (Int, Skew RxStreamData) , streamSyncFinTx :: MVar () } @@ -53,7 +54,7 @@ streamStateTx <- newIORef emptyStreamState streamStateRx <- newIORef emptyStreamState streamRecvQ <- newRecvStreamQ- streamReass <- newIORef Skew.empty+ streamReass <- newIORef (0, Skew.empty) streamSyncFinTx <- newEmptyMVar return Stream{..} {- FOURMOLU_ENABLE -}
Network/QUIC/Types/Ack.hs view
@@ -14,6 +14,29 @@ ackInfo0 :: AckInfo ackInfo0 = AckInfo (-1) 0 [] +-- | Whether the ranges name packet numbers that could exist.+--+-- RFC 9000 section 19.3.1 walks the ranges downward from the largest+-- acknowledged. Each gap gives the largest of the next range as+-- @previous_smallest - gap - 2@, and "if the value of the Gap field or the+-- value calculated is negative, an endpoint MUST generate a connection error+-- of type FRAME_ENCODING_ERROR".+--+-- Nothing checked this. The ranges were turned into a predicate and asked+-- about packets we had sent; ones reaching below zero simply matched nothing.+validAckInfo :: AckInfo -> Bool+validAckInfo (AckInfo lpn fr grs) = lpn >= 0 && fr >= 0 && stt >= 0 && go stt grs+ where+ stt = lpn - fr+ go _ [] = True+ go s ((g, r) : xs)+ | g < 0 || r < 0 = False+ | z < 0 || lo < 0 = False+ | otherwise = go lo xs+ where+ z = s - g - 2+ lo = z - r+ -- | -- >>> toAckInfo [9] -- AckInfo 9 0 []@@ -47,50 +70,33 @@ -- >>> fromAckInfo $ AckInfo 9 2 [(0,1)] -- [4,5,7,8,9] fromAckInfo :: AckInfo -> [PacketNumber]-fromAckInfo (AckInfo lpn fr grs) = loop grs [stt .. lpn]- where- stt = lpn - fromIntegral fr- loop _ [] = error "loop"- loop [] acc = acc- loop ((g, r) : xs) acc@(s : _) = loop xs ([z - fromIntegral r .. z] ++ acc)- where- z = s - fromIntegral g - 2---- |--- >>> fromAckInfoWithMin (AckInfo 9 0 []) 1--- [9]--- >>> fromAckInfoWithMin (AckInfo 9 2 []) 8--- [8,9]--- >>> fromAckInfoWithMin (AckInfo 8 1 [(2,1)]) 3--- [3,7,8]--- >>> fromAckInfoWithMin (AckInfo 9 2 [(0,1)]) 8--- [8,9]-fromAckInfoWithMin :: AckInfo -> PacketNumber -> [PacketNumber]-fromAckInfoWithMin (AckInfo lpn fr grs) lim- | stt < lim = [lim .. lpn]- | otherwise = loop grs [stt .. lpn]+fromAckInfo (AckInfo lpn fr grs) = loop grs stt [stt .. lpn] where stt = lpn - fromIntegral fr- loop _ [] = error "loop"- loop [] acc = acc- loop ((g, r) : xs) acc@(s : _)- | z < lim = acc- | otherwise = loop xs ([r' .. z] ++ acc)+ -- Carrying the smallest of the range just built, rather than reading it+ -- back off the front of the accumulator. Taking it off the front needs a+ -- clause for the accumulator being empty, which it never is -- and that+ -- clause was an error call sitting on a path the peer's ACK ranges reach.+ loop [] _ acc = acc+ loop ((g, r) : xs) s acc = loop xs lo ([lo .. z] ++ acc) where z = s - fromIntegral g - 2- r' = max lim (z - fromIntegral r)+ lo = z - fromIntegral r fromAckInfoToPred :: AckInfo -> (PacketNumber -> Bool) fromAckInfoToPred (AckInfo lpn fr grs) =- \x -> any (f x) $ loop grs [(stt, lpn)]+ \x -> any (f x) $ loop grs stt [(stt, lpn)] where f x (l, u) = l <= x && x <= u stt = lpn - fromIntegral fr- loop _ [] = error "loop"- loop [] acc = acc- loop ((g, r) : xs) acc@((s, _) : _) = loop xs $ (z - fromIntegral r, z) : acc+ -- As in 'fromAckInfo': carry the smallest of the range just built instead+ -- of reading it back off the accumulator, so there is no empty case to+ -- answer for. The peer chooses these ranges.+ loop [] _ acc = acc+ loop ((g, r) : xs) s acc = loop xs lo ((lo, z) : acc) where z = s - fromIntegral g - 2+ lo = z - fromIntegral r ----------------------------------------------------------------
Network/QUIC/Types/CID.hs view
@@ -5,6 +5,7 @@ module Network.QUIC.Types.CID ( CID (..), myCIDLength,+ maxCIDLength, newCID, fromCID, toCID,@@ -40,6 +41,14 @@ myCIDLength :: Int myCIDLength = 8++-- | The longest connection id this version of QUIC has.+--+-- RFC 9000 section 17.2: "This version of QUIC (version 1) does not support+-- connection IDs longer than 20 bytes", and endpoints that receive a longer+-- one in a version 1 long header MUST drop the packet.+maxCIDLength :: Int+maxCIDLength = 20 -- | A type for conneciton ID. newtype CID = CID Bytes deriving (Eq, Ord, Generic)
Network/QUIC/Types/Constants.hs view
@@ -29,3 +29,30 @@ idleTimeout :: Milliseconds idleTimeout = Milliseconds 30000++----------------------------------------------------------------++-- | How much out-of-order CRYPTO data one encryption level will hold.+--+-- RFC 9000 section 7.5 asks an endpoint to buffer at least 4096 octets and+-- lets it hold more during the handshake. 4096 alone is too tight to be+-- useful: losing one packet early in a peer's flight leaves the rest of a+-- certificate chain waiting behind the gap, which is ordinary rather than+-- hostile. This is well above the floor and still a bound.+cryptoBufferSize :: Int+cryptoBufferSize = 65536++----------------------------------------------------------------++-- | How many out-of-order fragments one stream will hold.+--+-- Flow control bounds the octets a stream may hold, not the pieces they+-- arrive in, and a piece costs far more than the octet it carries: a+-- ByteString, a heap node, a place in a sequence. One-octet fragments at+-- scattered offsets therefore buy a peer two orders of magnitude on what its+-- window says it is spending.+--+-- Reordering in practice leaves a handful of gaps, not a thousand, so this is+-- far above anything real and still a bound.+maxReassFragments :: Int+maxReassFragments = 1024
quic.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: quic-version: 0.3.4+version: 0.3.5 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp@@ -135,7 +135,7 @@ bytestring >=0.10, containers, crypto-token >=0.2.0 && <0.3,- crypton >=1.1.0 && < 1.2,+ crypton >=2.0.1 && < 2.1, crypton-x509 >=1.9.0 && <1.10, crypton-x509-store >=1.9.0 && <1.10, crypton-x509-system >=1.9.0 && <1.10,@@ -243,6 +243,9 @@ HandshakeSpec IOSpec PacketSpec+ ReassSpec+ ParametersSpec+ QLoggerSpec RecoverySpec TLSSpec TransportError@@ -259,6 +262,8 @@ bytestring, containers, crypton,+ directory,+ filepath, hspec, network >=3.2.2, quic,
test/Config.hs view
@@ -124,30 +124,37 @@ setSocketOption sockS ReuseAddr 1 bind sockC saC connect sockS saS- -- from client- tid0 <- forkIO $ do- (bs, saO) <- recvFrom sockC 2048- connect sockC saO- n0 <- atomicModifyIORef' irefC $ \x -> (x + 1, x)- dropPacket0 <- shouldDrop scenario True n0- unless dropPacket0 $ void $ send sockS bs- forever $ do- bs1 <- recv sockC 2048- n <- atomicModifyIORef' irefC $ \x -> (x + 1, x)- dropPacket <- shouldDrop scenario True n- let isCC = BS.length bs1 < 200- when (isCC || not dropPacket) $ void $ send sockS bs1- -- from server- tid1 <- forkIO $ forever $ do- bs <- recv sockS 2048- n <- atomicModifyIORef' irefS $ \x -> (x + 1, x)- dropPacket <- shouldDrop scenario False n- let isCC = BS.length bs < 200- when (isCC || not dropPacket) $ void $ send sockC bs- body- killThread tid0- killThread tid1+ -- The relaying threads have to stop before the sockets close.+ -- Run at the end of body instead, the kills are skipped whenever+ -- body throws, and the threads are then left in recv on a socket+ -- the bracket has just closed. That surfaces as "threadWait:+ -- invalid argument (Bad file descriptor)" from a thread nobody is+ -- watching, and buries whatever the test was really failing on.+ E.bracket (startRelay sockC sockS irefC irefS) stopRelay $ \_ -> body where+ startRelay sockC sockS irefC irefS = do+ -- from client+ tid0 <- forkIO $ do+ (bs, saO) <- recvFrom sockC 2048+ connect sockC saO+ n0 <- atomicModifyIORef' irefC $ \x -> (x + 1, x)+ dropPacket0 <- shouldDrop scenario True n0+ unless dropPacket0 $ void $ send sockS bs+ forever $ do+ bs1 <- recv sockC 2048+ n <- atomicModifyIORef' irefC $ \x -> (x + 1, x)+ dropPacket <- shouldDrop scenario True n+ let isCC = BS.length bs1 < 200+ when (isCC || not dropPacket) $ void $ send sockS bs1+ -- from server+ tid1 <- forkIO $ forever $ do+ bs <- recv sockS 2048+ n <- atomicModifyIORef' irefS $ \x -> (x + 1, x)+ dropPacket <- shouldDrop scenario False n+ let isCC = BS.length bs < 200+ when (isCC || not dropPacket) $ void $ send sockC bs+ return (tid0, tid1)+ stopRelay (tid0, tid1) = killThread tid0 >> killThread tid1 hints = defaultHints { addrSocketType = Network.Socket.Datagram
test/PacketSpec.hs view
@@ -2,6 +2,7 @@ module PacketSpec where +import Control.Monad (forM_) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS@@ -30,6 +31,86 @@ it "describes example of Server Initial version 2" $ do conns <- swap <$> makeConnections serverConf Version2 checkBinary conns 1 serverInitialPacketBinaryV2+ describe "decryptCrypt" $ do+ it "drops a packet whose header protection sample is not whole" $ do+ (_, serverConn) <- makeConnections serverConf Version1+ -- The sample is 16 octets taken from 4 past the packet number+ -- offset, which here is 9, so a Length of L leaves 'L - 4'+ -- octets of it. 4 was already dropped -- an empty mask is how+ -- a protector without keys answers too -- and 20 is a whole+ -- one. Everything between used to reach the cipher's header+ -- protection with a partial sample and throw.+ forM_ [4 .. 20] $ \len -> do+ [(CryptPacket _ crypt, lvl, _)] <-+ decodeCryptPackets (shortSampleInitial len) True+ decryptCrypt serverConn crypt lvl `shouldReturn` Nothing+ describe "encodePlainPacket" $ do+ it "leaves the peer a whole header protection sample" $ do+ (senderConn, _) <- makeConnections serverConf Version1+ -- RFC 9001 Sec 5.4.2 asks that the packet number and the payload+ -- together run four octets past the sample, and Sec 5.4.2 again+ -- that a receiver discard a packet too short to give one. A+ -- single PING is one octet of payload: with a one-octet packet+ -- number and the tag that comes to eighteen, two short, and the+ -- encoder has to make up the difference itself.+ let hdr = Initial Version1 clientChosenCID (toCID "") ""+ ppkt = PlainPacket hdr $ Plain (Flags 0) 0 [Ping] 0+ bin <- BS.createAndTrim 4096 $ \buf ->+ fst <$> encodePlainPacket senderConn (SizedBuffer buf 2048) ppkt Nothing+ (PacketIC (CryptPacket _ crypt) _ _, _) <- decodePacket bin True+ let sample =+ BS.take 16 $+ BS.drop (cryptPktNumOffset crypt + 4) $+ cryptPacket crypt+ BS.length sample `shouldBe` 16++ describe "decodePacket" $ do+ -- RFC 9000 Sec 17.2: a connection id is at most 20 octets, and an+ -- endpoint receiving a longer one in a version 1 long header MUST+ -- drop the packet. The length field is one octet and can say 255.+ it "drops a long header whose connection id is over-long" $ do+ broken <- fst <$> decodePacket (longHeaderWithCIDLen 21) True+ broken `shouldSatisfy` isBroken+ it "keeps a long header at the longest allowed" $ do+ ok <- fst <$> decodePacket (longHeaderWithCIDLen 20) True+ ok `shouldSatisfy` (not . isBroken)+ -- A Retry packet is a token followed by a 16-octet integrity tag.+ -- With fewer than 16 octets left there is no tag, and the arithmetic+ -- that separates them goes negative -- which extractByteString reads+ -- backwards, from before the packet. The packet was already refused;+ -- what this pins is that it is refused for every length, the read+ -- itself being the thing that cannot be observed from here.+ it "drops a Retry packet with no room for its tag" $+ forM_ [0 .. 15] $ \n -> do+ broken <- fst <$> decodePacket (retryWithTrailing n) True+ broken `shouldSatisfy` isBroken++-- | An Initial packet in a datagram large enough that a server would not+-- discard it for being too small, saying its payload is @len@ octets.+shortSampleInitial :: Int -> ByteString+shortSampleInitial len = BS.pack $ header ++ replicate (1200 - length header) 0xAA+ where+ -- long header, Initial, version 1, no CIDs, no token, then the length+ header = [0xc0, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00, 0x00, fromIntegral len]++isBroken :: PacketI -> Bool+isBroken (PacketIB BrokenPacket _) = True+isBroken _ = False++-- | An Initial long header whose destination connection id says @n@ octets,+-- with that many actually there, then enough to look like a packet.+longHeaderWithCIDLen :: Int -> ByteString+longHeaderWithCIDLen n =+ BS.pack $+ [0xc0, 0x00, 0x00, 0x00, 0x01, fromIntegral n]+ ++ replicate n 0xAA+ ++ [0x00, 0x00, 0x44, 0xb0]+ ++ replicate 1200 0xBB++-- | A Retry long header with no connection ids and @n@ octets behind it.+retryWithTrailing :: Int -> ByteString+retryWithTrailing n =+ BS.pack $ [0xf0, 0x00, 0x00, 0x00, 0x01, 0x00, 0x00] ++ replicate n 0xAA clientChosenCID :: CID clientChosenCID = toCID $ dec16 "8394c8f03e515708"
+ test/ParametersSpec.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module ParametersSpec where++import qualified Data.ByteString as BS+import Test.Hspec++import Network.QUIC.Internal++spec :: Spec+spec = do+ describe "decodeParameters" $ do+ -- The list is a key, a length and that many octets, repeated. Each+ -- integer value is itself one variable-length integer. Anything that+ -- stops in the middle of one of those used to read off the end, and+ -- since the decoding is done inside unsafeDupablePerformIO, that+ -- arrived as an exception out of a pure value rather than as the+ -- Nothing the type promises.+ it "refuses a parameter list that stops mid-key" $+ decodeParameters (BS.pack [0x40]) `shouldSatisfy` isNothing'+ it "refuses a value shorter than its length says" $+ decodeParameters (BS.pack [0x04, 0x08, 0x01, 0x02]) `shouldSatisfy` isNothing'+ it "refuses an integer parameter with no value" $+ decodeParameters (BS.pack [0x04, 0x00]) `shouldSatisfy` isNothing'+ it "refuses an integer parameter with octets behind the integer" $+ decodeParameters (BS.pack [0x04, 0x02, 0x01, 0x02]) `shouldSatisfy` isNothing'+ it "accepts a whole one" $+ decodeParameters (BS.pack [0x04, 0x01, 0x20]) `shouldSatisfy` isJust'+ it "accepts an empty list" $+ decodeParameters "" `shouldSatisfy` isJust'+ -- RFC 9000 Sec 18.1: an unknown transport parameter is ignored.+ it "accepts an unknown parameter" $+ decodeParameters (BS.pack [0x21, 0x01, 0x00]) `shouldSatisfy` isJust'+ -- Sec 7.4.2: "An endpoint MUST treat receipt of a duplicate+ -- transport parameter as a connection error of type+ -- TRANSPORT_PARAMETER_ERROR."+ it "refuses a parameter sent twice" $+ decodeParameters (BS.pack [0x04, 0x01, 0x20, 0x04, 0x01, 0x21])+ `shouldSatisfy` isNothing'+ -- Being unknown is not an exemption: ignored once, not allowed twice.+ it "refuses an unknown parameter sent twice" $+ decodeParameters (BS.pack [0x21, 0x01, 0x00, 0x21, 0x01, 0x00])+ `shouldSatisfy` isNothing'+ it "accepts two different parameters" $+ decodeParameters (BS.pack [0x04, 0x01, 0x20, 0x05, 0x01, 0x21])+ `shouldSatisfy` isJust'++-- Parameters has no Eq, so keep only whether one came back.+isNothing' :: Maybe Parameters -> Bool+isNothing' Nothing = True+isNothing' _ = False++isJust' :: Maybe Parameters -> Bool+isJust' = not . isNothing'
+ test/QLoggerSpec.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}++module QLoggerSpec where++import qualified Control.Exception as E+import System.Directory+import System.FilePath+import Test.Hspec++import Network.QUIC.Internal++spec :: Spec+spec = do+ describe "dirQLogger" $ do+ -- A client names its file after the peer CID and a server after the+ -- original destination CID, which for one connection are the same+ -- value. Both in one process pointed at one directory therefore used+ -- to ask for the same file, and LogFileNoRotate takes a file+ -- exclusively: the second to ask got "openFile: resource busy" thrown+ -- through its connection setup rather than a worse log.+ it "gives the two ends of one connection their own files" $+ withTempDir $ \dir -> do+ now <- getTimeMicrosecond+ let cid = toCID "01234567"+ E.bracket (dirQLogger (Just dir) now cid "client") snd $ \_ ->+ E.bracket (dirQLogger (Just dir) now cid "server") snd $ \_ ->+ return ()+ files <- listDirectory dir+ length files `shouldBe` 2++withTempDir :: (FilePath -> IO a) -> IO a+withTempDir body = do+ tmp <- getTemporaryDirectory+ let dir = tmp </> "quic-qlogger-spec"+ E.bracket_ (createDirectoryIfMissing True dir) (removeDirectoryRecursive dir) $+ body dir
+ test/ReassSpec.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module ReassSpec where++import Test.Hspec++import Network.QUIC.Internal++import Config+import PacketSpec (makeConnections)++spec :: Spec+spec = do+ serverConf <- runIO makeTestServerConfig+ describe "putRxStreamData" $ do+ -- Flow control bounds the octets a stream may hold, not the pieces+ -- they arrive in. A peer spending its window one octet at a time at+ -- scattered offsets stays inside the only thing that was counted,+ -- while every piece costs a ByteString, a heap node and a place in a+ -- sequence to hold.+ it "refuses to hold a stream in more pieces than the limit" $ do+ strm <- scratchStream serverConf+ let put n = putRxStreamData strm $ RxStreamData "x" (n * 2 + 1) 1 False+ -- Odd offsets, so none of them is ever adjacent to another and+ -- none can be delivered: every one has to be held.+ held <- mapM put [1 .. maxReassFragments]+ map isReassembled held `shouldSatisfy` and+ put (maxReassFragments + 1) `shouldReturn` TooFragmented+ it "keeps taking fragments it can deliver" $ do+ strm <- scratchStream serverConf+ -- In order, so each one goes straight out and nothing is held.+ answers <-+ mapM+ (\n -> putRxStreamData strm (RxStreamData "x" n 1 False))+ [0 .. fromIntegral maxReassFragments + 100]+ map isReassembled answers `shouldSatisfy` and++scratchStream :: ServerConfig -> IO Stream+scratchStream serverConf = do+ (conn, _) <- makeConnections serverConf Version1+ newStream conn 0 1000000 1000000++isReassembled :: FlowCntl -> Bool+isReassembled Reassembled = True+isReassembled _ = False
test/TransportError.hs view
@@ -75,6 +75,11 @@ let cc = addHook cc0 $ setOnTransportParametersCreated setStatelessResetToken runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] it+ "MUST send TRANSPORT_PARAMETER_ERROR if a parameter value is malformed [Transport 18]"+ $ \_ -> do+ let cc = addHook cc0 $ setOnTLSExtensionCreated danglingParameter+ runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError]+ it "MUST send TRANSPORT_PARAMETER_ERROR if max_udp_payload_size < 1200 [Transport 7.4 and 18.2]" $ \_ -> do let cc = addHook cc0 $ setOnTransportParametersCreated setMaxUdpPayloadSize@@ -90,6 +95,26 @@ let cc = addHook cc0 $ setOnTransportParametersCreated setMaxAckDelay runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] it+ "MUST send TRANSPORT_PARAMETER_ERROR if initial_max_streams_bidi > 2^60 [Transport 18.2]"+ $ \_ -> do+ let cc = addHook cc0 $ setOnTransportParametersCreated setMaxStreamsBidi+ runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError]+ it+ "MUST send TRANSPORT_PARAMETER_ERROR if initial_max_streams_uni > 2^60 [Transport 18.2]"+ $ \_ -> do+ let cc = addHook cc0 $ setOnTransportParametersCreated setMaxStreamsUni+ runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError]+ it+ "MUST send FRAME_ENCODING_ERROR if an ACK range reaches below zero [Transport 19.3.1]"+ $ \_ -> do+ let cc = addHook cc0 $ setOnPlainCreated impossibleAckRange+ runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError]+ it+ "SHOULD send PROTOCOL_VIOLATION on an ACK for a packet never sent [Transport 13.1]"+ $ \_ -> do+ let cc = addHook cc0 $ setOnPlainCreated ackForUnsentPacket+ runCnoOp cc ms `shouldThrow` transportErrorsIn [ProtocolViolation]+ it "MUST send FRAME_ENCODING_ERROR if a frame of unknown type is received [Transport 12.4]" $ \_ -> do let cc = addHook cc0 $ setOnPlainCreated unknownFrame@@ -103,6 +128,11 @@ let cc = addHook cc0 $ setOnPlainCreated $ rrBits HandshakeLevel runCnoOp cc ms `shouldThrow` transportError it+ "MUST send CRYPTO_BUFFER_EXCEEDED if CRYPTO data is buffered beyond the limit [Transport 7.5]"+ $ \_ -> do+ let cc = addHook cc0 $ setOnPlainCreated cryptoBeyondBuffer+ runCnoOp cc ms `shouldThrow` transportErrorsIn [CryptoBufferExceeded]+ it "MUST send PROTOCOL_VIOLATION if PATH_CHALLENGE in Handshake is received [Transport 17.2.4]" $ \_ -> do let cc = addHook cc0 $ setOnPlainCreated handshakePathChallenge@@ -233,6 +263,14 @@ setOnTransportParametersCreated :: (Parameters -> Parameters) -> Hooks -> Hooks setOnTransportParametersCreated f hooks = hooks{onTransportParametersCreated = f} +-- initial_max_data announcing a zero-length value. Everything the peer+-- really sent is left in front of it, so this is the value alone being wrong+-- rather than the list being cut short. The value of an integer parameter is+-- one variable-length integer, and there is no such thing in no octets.+danglingParameter :: [ExtensionRaw] -> [ExtensionRaw]+danglingParameter [ExtensionRaw eid v] = [ExtensionRaw eid (v <> "\x04\x00")]+danglingParameter xs = xs+ setOnTLSExtensionCreated :: ([ExtensionRaw] -> [ExtensionRaw]) -> Hooks -> Hooks setOnTLSExtensionCreated f params = params{onTLSExtensionCreated = f} @@ -292,6 +330,14 @@ setMaxAckDelay :: Parameters -> Parameters setMaxAckDelay params = params{maxAckDelay = 2 ^ (15 :: Int)} +-- A stream id has 62 bits, two of them saying who opened it and whether it is+-- bidirectional, so a count past 2^60 names no stream.+setMaxStreamsBidi :: Parameters -> Parameters+setMaxStreamsBidi params = params{initialMaxStreamsBidi = 2 ^ (60 :: Int) + 1}++setMaxStreamsUni :: Parameters -> Parameters+setMaxStreamsUni params = params{initialMaxStreamsUni = 2 ^ (60 :: Int) + 1}+ ---------------------------------------------------------------- -- Stream 0 is not created internally. It is assumed that a server@@ -311,10 +357,35 @@ where fake = StreamF 1000000000 0 ["GET /\r\n"] True +-- Largest acknowledged 5, then a gap of 10: the next range would start at+-- 5 - 10 - 2, which is not a packet number.+impossibleAckRange :: EncryptionLevel -> Plain -> Plain+impossibleAckRange lvl plain+ | lvl == RTT1Level =+ plain{plainFrames = Ack (AckInfo 5 0 [(10, 0)]) 0 : plainFrames plain}+ | otherwise = plain++-- Nobody has sent a million packets down this connection.+ackForUnsentPacket :: EncryptionLevel -> Plain -> Plain+ackForUnsentPacket lvl plain+ | lvl == RTT1Level =+ plain{plainFrames = Ack (AckInfo 1000000 0 []) 0 : plainFrames plain}+ | otherwise = plain+ unknownFrame :: EncryptionLevel -> Plain -> Plain unknownFrame lvl plain | lvl == RTT1Level = plain{plainFrames = UnknownFrame 0x20 : plainFrames plain}+ | otherwise = plain++-- CRYPTO frames are outside flow control, so nothing but the buffer limit+-- stops a peer from parking a fragment far past where the stream has got to+-- and having it held. One octet at this offset is enough to ask for more+-- than any bound the receiver could sensibly hold.+cryptoBeyondBuffer :: EncryptionLevel -> Plain -> Plain+cryptoBeyondBuffer lvl plain+ | lvl == HandshakeLevel =+ plain{plainFrames = CryptoF 100000000 "x" : plainFrames plain} | otherwise = plain handshakePathChallenge :: EncryptionLevel -> Plain -> Plain
test/TypesSpec.hs view
@@ -15,3 +15,20 @@ (xs :: NonEmptyList (NonNegative (Small PacketNumber))) rs' = reverse rs fromAckInfo (toAckInfo rs') `shouldBe` rs+ describe "validAckInfo" $ do+ -- RFC 9000 Sec 19.3.1 walks the ranges down from the largest+ -- acknowledged; a gap that takes the walk below zero names packets+ -- that cannot exist.+ it "accepts what toAckInfo builds" $ property $ \xs -> do+ let rs =+ nub . sort . map (getSmall . getNonNegative) . getNonEmpty $+ (xs :: NonEmptyList (NonNegative (Small PacketNumber)))+ validAckInfo (toAckInfo (reverse rs)) `shouldBe` True+ it "refuses a gap that reaches below zero" $+ validAckInfo (AckInfo 5 0 [(10, 0)]) `shouldBe` False+ it "refuses a first range longer than the largest acknowledged" $+ validAckInfo (AckInfo 3 9 []) `shouldBe` False+ it "refuses a range reaching below zero after a legal gap" $+ validAckInfo (AckInfo 20 0 [(0, 100)]) `shouldBe` False+ it "accepts ranges that stop at zero" $+ validAckInfo (AckInfo 5 0 [(1, 2)]) `shouldBe` True