diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # ChangeLog +## 0.3.17 + +* Security fix: bound what an unauthenticated packet can take. + [#168](https://github.com/kazu-yamamoto/quic/pull/168) +* Allow crypton 2.2 and the x509 family at 1.10. + ## 0.3.16 * Stop waiting for a socket to be readable, and run on Windows. diff --git a/Network/QUIC/Connection/Migration.hs b/Network/QUIC/Connection/Migration.hs --- a/Network/QUIC/Connection/Migration.hs +++ b/Network/QUIC/Connection/Migration.hs @@ -22,8 +22,7 @@ choosePeerCIDForPrivacy, setPeerStatelessResetToken, isStatelessRestTokenValid, - setMigrationStarted, - isPathValidating, + claimMigration, checkResponse, validatePath, getMyRetirePriorTo, @@ -378,17 +377,26 @@ setChallenges Connection{..} pathInfo pdat = atomically $ writeTVar migrationState $ SendChallenge pathInfo pdat -setMigrationStarted :: Connection -> IO () -setMigrationStarted Connection{..} = - atomically $ writeTVar migrationState MigrationStarted - -isPathValidating :: Connection -> IO Bool -isPathValidating Connection{..} = do - s <- readTVarIO migrationState +-- | Take on the migration, if no one has it. +-- +-- True to the caller that took it, and that caller is then the one to carry +-- it out; False to everyone else, including every later caller until the +-- validation this one starts is finished. +-- +-- Test and set together. Apart, every packet that arrived before the +-- winner had set the state read it as free, and a peer that sends from an +-- address this connection has not seen -- which takes no more than another +-- port -- got a migration for each of those packets rather than one for all +-- of them. +claimMigration :: Connection -> IO Bool +claimMigration Connection{..} = atomically $ do + s <- readTVar migrationState case s of - SendChallenge{} -> return True - MigrationStarted -> return True - _ -> return False + SendChallenge{} -> return False + MigrationStarted -> return False + _ -> do + writeTVar migrationState MigrationStarted + return True waitResponse :: Connection -> IO () waitResponse Connection{..} = atomically $ do diff --git a/Network/QUIC/Server/Reader.hs b/Network/QUIC/Server/Reader.hs --- a/Network/QUIC/Server/Reader.hs +++ b/Network/QUIC/Server/Reader.hs @@ -518,8 +518,20 @@ mPathInfo <- findPathInfo conn peersa case mPathInfo of Nothing -> do - forkManaged conn $ - onClientMigration conn dCID peersa cidChanged + -- Taken here, before the thread rather than + -- inside it, so that a peer sending from an + -- address this connection has not seen gets one + -- thread for the migration and not one for every + -- packet. 'findPathInfo' knows the address in + -- use and the one before it and nothing else, so + -- a sender that moves its port -- which asks no + -- spoofing of it -- is unknown every time, and + -- this runs on packets nothing has authenticated + -- yet. + claimed <- claimMigration conn + when claimed $ + forkManaged conn $ + onClientMigration conn dCID peersa cidChanged _ -> return () writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl ---------------------------------------------------------------- @@ -550,22 +562,20 @@ recvServer :: RecvQ -> IO ReceivedPacket recvServer = readRecvQ +-- | Carry out the migration the caller has claimed with 'claimMigration'. onClientMigration :: Connection -> CID -> SockAddr -> Bool -> IO () onClientMigration conn newdCID peersa cidChanged = handleLogUnit logAction $ do - migrating <- isPathValidating conn -- fixme: test and set - unless migrating $ do - setMigrationStarted conn - -- fixme: should not block - mcidinfo <- - if cidChanged - then timeout (Microseconds 100000) "onClientMigration" $ waitPeerCID conn - else return Nothing -- PathChallenge only, no RetireConnectionID - let msg = "Migration: " <> bhow peersa <> " (" <> bhow newdCID <> ")" - qlogDebug conn $ Debug $ toLogStr msg - connDebugLog conn $ "debug: onClientMigration: " <> msg - pathInfo <- newPathInfo peersa - -- assumed that this PathInfo is not stored in PeerInfo - addPathInfo conn pathInfo - validatePath conn pathInfo mcidinfo + -- fixme: should not block + mcidinfo <- + if cidChanged + then timeout (Microseconds 100000) "onClientMigration" $ waitPeerCID conn + else return Nothing -- PathChallenge only, no RetireConnectionID + let msg = "Migration: " <> bhow peersa <> " (" <> bhow newdCID <> ")" + qlogDebug conn $ Debug $ toLogStr msg + connDebugLog conn $ "debug: onClientMigration: " <> msg + pathInfo <- newPathInfo peersa + -- assumed that this PathInfo is not stored in PeerInfo + addPathInfo conn pathInfo + validatePath conn pathInfo mcidinfo where logAction msg = connDebugLog conn ("debug: onClientMigration: " <> msg) diff --git a/Network/QUIC/Types/Queue.hs b/Network/QUIC/Types/Queue.hs --- a/Network/QUIC/Types/Queue.hs +++ b/Network/QUIC/Types/Queue.hs @@ -1,19 +1,62 @@ module Network.QUIC.Types.Queue where import Control.Concurrent.STM +import Control.Monad (when) import Network.QUIC.Types.Packet -newtype RecvQ = RecvQ (TQueue ReceivedPacket) +-- | How many packets a connection may have waiting to be decrypted. +-- +-- A server picks the connection a packet belongs to by the connection ID, +-- which is in the clear, and hands the packet over; whether the packet is +-- worth anything is settled later, in the receiver, by decrypting it. So +-- anyone who knows a connection ID can make a server queue packets, and +-- they cost the sender less to send than the AEAD that rejects them costs +-- the receiver to refuse. The queue grows, and before this it grew without +-- a limit: one connection's worth of junk could take all of a server's +-- memory. +-- +-- This much is several milliseconds of a receiver's work, far more than the +-- scheduling jitter the queue is there to absorb, and each packet holds the +-- datagram it was cut from, so the queue is worth a few megabytes to a +-- sender rather than everything. +recvQLimit :: Int +recvQLimit = 4096 +data RecvQ = RecvQ (TQueue ReceivedPacket) (TVar Int) + newRecvQ :: IO RecvQ -newRecvQ = RecvQ <$> newTQueueIO +newRecvQ = RecvQ <$> newTQueueIO <*> newTVarIO 0 readRecvQ :: RecvQ -> IO ReceivedPacket -readRecvQ (RecvQ q) = atomically $ readTQueue q +readRecvQ (RecvQ q qlen) = atomically $ do + x <- readTQueue q + modifyTVar' qlen (subtract 1) + return x +-- | Queue a packet, or drop it if 'recvQLimit' are already waiting. +-- +-- What is dropped is the packet that has just arrived rather than one +-- already queued, so that what the connection has taken on is kept and only +-- what is past the limit is lost. A lost packet is something QUIC is built +-- to recover from. +-- +-- Nothing is logged. The only sender that can reach the limit at any rate +-- is one sending faster than the receiver can refuse what it sends, and a +-- line of log for each of those packets is the same attack by another road. writeRecvQ :: RecvQ -> ReceivedPacket -> IO () -writeRecvQ (RecvQ q) x = atomically $ writeTQueue q x +writeRecvQ (RecvQ q qlen) x = atomically $ do + n <- readTVar qlen + when (n < recvQLimit) $ do + writeTQueue q x + writeTVar qlen $! n + 1 +-- | Put back a packet this connection had already taken. +-- +-- Not subject to the limit: these come from the packets put off for want of +-- the keys to read them, which the handshake bounds, and dropping one would +-- lose a packet the connection has already accounted for. prependRecvQ :: RecvQ -> ReceivedPacket -> STM () -prependRecvQ (RecvQ q) = unGetTQueue q +prependRecvQ (RecvQ q qlen) x = do + unGetTQueue q x + modifyTVar' qlen (+ 1) diff --git a/quic.cabal b/quic.cabal --- a/quic.cabal +++ b/quic.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: quic -version: 0.3.16 +version: 0.3.17 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp @@ -132,11 +132,11 @@ bytestring >=0.10, containers, crypto-token >=0.2.0 && <0.3, - crypton >=2.1.0 && <2.2, - crypton-x509 >=1.9.0 && <1.10, - crypton-x509-store >=1.9.0 && <1.10, - crypton-x509-system >=1.9.0 && <1.10, - crypton-x509-validation >=1.9.0 && <1.10, + crypton >=2.1.0 && <2.3, + crypton-x509 >=1.9.0 && <1.11, + crypton-x509-store >=1.9.0 && <1.11, + crypton-x509-system >=1.9.0 && <1.11, + crypton-x509-validation >=1.9.0 && <1.11, fast-logger >=3.2.8 && <3.3, filepath, iproute >=1.7.12 && <1.8, @@ -233,6 +233,7 @@ HandshakeSpec IOSpec LoggerSpec + MigrationSpec PacketSpec ReassSpec ParametersSpec diff --git a/test/MigrationSpec.hs b/test/MigrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/MigrationSpec.hs @@ -0,0 +1,29 @@ +module MigrationSpec where + +import Control.Concurrent.Async (mapConcurrently) +import Test.Hspec + +import Network.QUIC.Internal + +import Config +import PacketSpec (makeConnections) + +spec :: Spec +spec = do + serverConf <- runIO makeTestServerConfig + -- The dispatcher calls this for every packet that arrives from an + -- address the connection has not seen, before anything has + -- authenticated the packet, and 'findPathInfo' knows the address in use + -- and the one before it and nothing else. A peer that moves its port + -- -- which asks no spoofing of it -- is therefore unknown on every + -- packet it sends. One of those packets is a migration; the rest are + -- nothing. See #167. + describe "claimMigration" $ do + it "gives the migration to one caller and refuses the rest" $ do + (_, serverConn) <- makeConnections serverConf Version1 + rs <- mapConcurrently (const $ claimMigration serverConn) [1 .. 200 :: Int] + length (filter id rs) `shouldBe` 1 + it "refuses while the validation it started is unfinished" $ do + (_, serverConn) <- makeConnections serverConf Version1 + claimMigration serverConn `shouldReturn` True + claimMigration serverConn `shouldReturn` False diff --git a/test/TypesSpec.hs b/test/TypesSpec.hs --- a/test/TypesSpec.hs +++ b/test/TypesSpec.hs @@ -1,13 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} + module TypesSpec where +import Control.Concurrent.STM (atomically) +import Control.Monad (replicateM) +import qualified Data.ByteString.Char8 as C8 import Data.List +import qualified System.Timeout as Timeout import Test.Hspec import Test.QuickCheck import Network.QUIC.Internal +-- | A packet that carries nothing but a number, to tell it from the others. +numbered :: Int -> ReceivedPacket +numbered n = + mkReceivedPacket + (CryptPacket (Short (toCID "")) (Crypt 0 (C8.pack $ show n) 0)) + timeMicrosecond0 + 1200 + RTT1Level + +number :: ReceivedPacket -> Int +number rpkt = + let CryptPacket _ crypt = rpCryptPacket rpkt + in read $ C8.unpack $ cryptPacket crypt + spec :: Spec spec = do + -- A server queues a packet having read the connection ID, which is in + -- the clear, and finds out whether the packet is worth anything later, + -- when the receiver decrypts it. So the queue has to hold a bound, or + -- anyone who can see a connection ID can fill it. See #167. + describe "RecvQ" $ do + it "keeps what it has taken and drops what is past the limit" $ do + q <- newRecvQ + mapM_ (writeRecvQ q . numbered) [1 .. recvQLimit + 100] + ns <- replicateM recvQLimit (number <$> readRecvQ q) + -- The packets kept are the ones that arrived first: what is + -- dropped is what came after the queue was full, not what the + -- connection had already taken on. + ns `shouldBe` [1 .. recvQLimit] + Timeout.timeout 100000 (readRecvQ q) `shouldReturn` Nothing + it "takes back a packet it had already taken, full or not" $ do + q <- newRecvQ + mapM_ (writeRecvQ q . numbered) [1 .. recvQLimit] + -- Putting back what was put off for want of keys is not the + -- same as taking something new on, and the limit does not apply + -- to it. Dropping one would lose a packet already accounted + -- for. + atomically $ prependRecvQ q $ numbered 0 + number <$> readRecvQ q `shouldReturn` 0 describe "toAckInfo and fromAckInfo" $ do it "should be dual" $ property $ \xs -> do let rs =