quic 0.3.16 → 0.3.17

raw patch · 7 files changed

+180/−40 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +6/−0
• Network/QUIC/Connection/Migration.hs +20/−12
• Network/QUIC/Server/Reader.hs +27/−17
• Network/QUIC/Types/Queue.hs +48/−5
• quic.cabal +7/−6
• test/MigrationSpec.hs +29/−0
• test/TypesSpec.hs +43/−0

@@ -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.

@@ -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

@@ -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)

@@ -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)

@@ -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

@@ -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

@@ -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 =