quic 0.2.7 → 0.2.8
raw patch · 30 files changed
+291/−179 lines, 30 filesdep ~networkdep ~network-controldep ~random
Dependency ranges changed: network, network-control, random, tls
Files
- ChangeLog.md +7/−0
- Network/QUIC/Client/Reader.hs +29/−13
- Network/QUIC/Client/Run.hs +7/−4
- Network/QUIC/Closer.hs +2/−2
- Network/QUIC/Connection/Migration.hs +22/−16
- Network/QUIC/Connection/Misc.hs +1/−2
- Network/QUIC/Connection/Timeout.hs +6/−0
- Network/QUIC/Connection/Types.hs +11/−5
- Network/QUIC/Crypto/Keys.hs +1/−1
- Network/QUIC/Crypto/Nite.hs +9/−12
- Network/QUIC/Crypto/Utils.hs +6/−6
- Network/QUIC/Handshake.hs +7/−3
- Network/QUIC/Info.hs +1/−1
- Network/QUIC/Packet/Encode.hs +0/−2
- Network/QUIC/Packet/Frame.hs +1/−1
- Network/QUIC/Qlog.hs +3/−3
- Network/QUIC/Receiver.hs +8/−29
- Network/QUIC/Server/Reader.hs +84/−49
- Network/QUIC/Server/Run.hs +8/−6
- Network/QUIC/Socket.hs +2/−1
- Network/QUIC/Stream/Types.hs +0/−2
- Network/QUIC/Types/CID.hs +29/−6
- Network/QUIC/Utils.hs +3/−0
- quic.cabal +5/−5
- test/Config.hs +2/−1
- test/IOSpec.hs +7/−4
- test/PacketSpec.hs +4/−1
- util/Common.hs +2/−2
- util/quic-client.hs +14/−2
- util/quic-server.hs +10/−0
ChangeLog.md view
@@ -1,5 +1,12 @@ # ChangeLog +## 0.2.8++* Proper handling for stateless reset. Servers generate SRTs based on+ their CIDs. Clients check SRTs before dispatching to a Connection.+ Note that the CID of stateless reset is random.+ Test: `quic-server -o 5` and `quic-client -i`/`p`.+ ## 0.2.7 * Introducing `forkManaged` to manage readers of clients properly.
Network/QUIC/Client/Reader.hs view
@@ -44,17 +44,16 @@ wait loop = do ito <- readMinIdleTimeout conn- mbs <-- timeout ito "readeClient" $- NSB.recvMsg s0 2048 2048 0 -- fixme+ mbs <- timeout ito "readeClient" $ NSB.recvFrom s0 2048 case mbs of Nothing -> close s0- Just (peersa, bs, cmsgs, _) -> do- setPeerInfo conn $ PeerInfo peersa cmsgs- now <- getTimeMicrosecond- let quicBit = greaseQuicBit $ getMyParameters conn- pkts <- decodePackets bs (not quicBit)- mapM_ (putQ now) pkts+ Just (bs, peersa) -> do+ PeerInfo peersa' <- getPeerInfo conn+ when (peersa == peersa') $ do+ now <- getTimeMicrosecond+ let quicBit = greaseQuicBit $ getMyParameters conn+ pkts <- decodePackets bs (not quicBit)+ mapM_ (putQ now) pkts loop logAction msg = connDebugLog conn ("debug: readerClient: " <> msg) putQ _ (PacketIB BrokenPacket _) = return ()@@ -71,7 +70,24 @@ vers@(ver : _) | ok -> VersionInfo ver vers _ -> brokenVersionInfo E.throwTo (mainThreadId conn) $ VerNego nextVerInfo- putQ t (PacketIC pkt lvl siz) = writeRecvQ (connRecvQ conn) $ mkReceivedPacket pkt t siz lvl+ putQ t (PacketIC pkt@(CryptPacket hdr crypt) lvl siz) = do+ let cid = headerMyCID hdr+ included <- myCIDsInclude conn cid+ case included of+ Just _ -> writeRecvQ (connRecvQ conn) $ mkReceivedPacket pkt t siz lvl+ Nothing -> case decodeStatelessResetToken (cryptPacket crypt) of+ Just token -> do+ isStatelessReset <- isStatelessRestTokenValid conn token+ -- Our client does not send a stateless reset:+ -- 1) Stateless reset token is not generated for+ -- the my first CID.+ -- 2) It's unlikely that QUIC packets are delivered+ -- to a new UDP port when out client is rebooted.+ when isStatelessReset $ do+ qlogReceived conn StatelessReset t+ connDebugLog conn "debug: connection is reset statelessly"+ E.throwTo (mainThreadId conn) ConnectionIsReset+ _ -> return () -- really invalid, just ignore putQ t (PacketIR pkt@(RetryPacket ver dCID sCID token ex)) = do qlogReceived conn pkt t ok <- checkCIDs conn dCID ex@@ -122,8 +138,8 @@ mn <- timeout (Microseconds 1000000) "controlConnection' 1" $ waitPeerCID conn -- fixme case mn of Nothing -> return False- Just (CIDInfo n _ _) -> do- sendFrames conn RTT1Level [RetireConnectionID n]+ Just cidInfo -> do+ sendFrames conn RTT1Level [RetireConnectionID (cidInfoSeq cidInfo)] return True controlConnection' conn ChangeClientCID = do cidInfo <- getNewMyCID conn@@ -144,7 +160,7 @@ rebind :: Connection -> Microseconds -> IO () rebind conn microseconds = do- PeerInfo peersa _ <- getPeerInfo conn+ PeerInfo peersa <- getPeerInfo conn newSock <- natRebinding peersa oldSock <- setSocket conn newSock let reader = readerClient newSock conn
Network/QUIC/Client/Run.hs view
@@ -37,7 +37,7 @@ -- Use the 'migrate' API for the connected socket. run :: ClientConfig -> (Connection -> IO a) -> IO a -- Don't use handleLogUnit here because of a return value.-run conf client = NS.withSocketsDo $ do+run conf client = do let resInfo = ccResumption conf verInfo = case resumptionSession resInfo of Nothing@@ -50,6 +50,7 @@ ex <- E.try $ runClient conf client False verInfo case ex of Right v -> return v+ -- Other exceptions go though. Left (NextVersion nextVerInfo) | verInfo == brokenVersionInfo -> E.throwIO VersionNegotiationFailed | otherwise -> runClient conf client True nextVerInfo@@ -108,11 +109,11 @@ (sock, peersa) <- clientSocket ccServerName ccPortName q <- newRecvQ sref <- newIORef sock- piref <- newIORef $ PeerInfo peersa []+ piref <- newIORef $ PeerInfo peersa let send buf siz = do s <- readIORef sref- PeerInfo sa cmsgs <- readIORef piref- void $ NS.sendBufMsg s sa [(buf, siz)] cmsgs 0+ PeerInfo sa <- readIORef piref+ void $ NS.sendBufTo s buf siz sa recv = recvClient q myCID <- newCID peerCID <- newCID@@ -124,6 +125,7 @@ debugLog $ "Original CID: " <> bhow peerCID let myAuthCIDs = defaultAuthCIDs{initSrcCID = Just myCID} peerAuthCIDs = defaultAuthCIDs{initSrcCID = Just peerCID, origDstCID = Just peerCID}+ genSRT <- makeGenStatelessReset conn <- clientConnection conf@@ -138,6 +140,7 @@ q send recv+ genSRT addResource conn qclean let ver = chosenVersion verInfo initializeCoder conn InitialLevel $ initialSecrets ver peerCID
Network/QUIC/Closer.hs view
@@ -40,11 +40,11 @@ closure' :: Connection -> LDCC -> Frame -> IO () closure' conn ldcc frame = do sock <- getSocket conn- PeerInfo peersa cmsgs <- getPeerInfo conn+ PeerInfo peersa <- getPeerInfo conn -- send let sbuf@(SizedBuffer sendbuf _) = encryptRes conn siz <- encodeCC conn sbuf frame- let send = void $ NS.sendBufMsg sock peersa [(sendbuf, siz)] cmsgs 0+ let send = void $ NS.sendBufTo sock sendbuf siz peersa -- recv and clos killReaders conn -- client only (recv, freeRecvBuf, clos) <-
Network/QUIC/Connection/Migration.hs view
@@ -77,7 +77,7 @@ getNewMyCID :: Connection -> IO CIDInfo getNewMyCID Connection{..} = do cid <- newCID- srt <- newStatelessResetToken+ let srt = genStatelessResetToken cid atomicModifyIORef' myCIDDB $ new cid srt ----------------------------------------------------------------@@ -207,18 +207,18 @@ } add :: CIDInfo -> CIDDB -> CIDDB-add cidInfo@CIDInfo{..} db@CIDDB{..} = db'+add cidInfo db@CIDDB{..} = db' where db' = db- { cidInfos = IntMap.insert cidInfoSeq cidInfo cidInfos- , revInfos = Map.insert cidInfoCID cidInfoSeq revInfos+ { cidInfos = IntMap.insert (cidInfoSeq cidInfo) cidInfo cidInfos+ , revInfos = Map.insert (cidInfoCID cidInfo) (cidInfoSeq cidInfo) revInfos } new :: CID -> StatelessResetToken -> CIDDB -> (CIDDB, CIDInfo) new cid srt db@CIDDB{..} = (db', cidInfo) where- cidInfo = CIDInfo nextSeqNum cid srt+ cidInfo = newCIDInfo nextSeqNum cid srt db' = db { nextSeqNum = nextSeqNum + 1@@ -268,14 +268,17 @@ , usedCIDInfo = cidinfo' } -isStatelessRestTokenValid :: Connection -> CID -> StatelessResetToken -> IO Bool-isStatelessRestTokenValid Connection{..} cid srt = srtCheck <$> readTVarIO peerCIDDB+-- Used in client only. Stateless reset is independent from+-- Connection because its CID is random. However, client uses only+-- one Connection. So, peerCIDDB can be considered a global variable.+-- This function tries to find the target statless reset token in+-- peerCIDDB.+isStatelessRestTokenValid :: Connection -> StatelessResetToken -> IO Bool+isStatelessRestTokenValid Connection{..} srt = srtCheck <$> readTVarIO peerCIDDB where- srtCheck CIDDB{..} = case Map.lookup cid revInfos of- Nothing -> False- Just n -> case IntMap.lookup n cidInfos of- Nothing -> False- Just (CIDInfo _ _ srt0) -> srt == srt0+ srtCheck CIDDB{..} = foldr chk False cidInfos+ chk _ True = True+ chk cidInfo _ = cidInfoSRT cidInfo == srt ---------------------------------------------------------------- @@ -285,12 +288,15 @@ setChallenges conn pdat putOutput conn $ OutControl RTT1Level [PathChallenge pdat] $ return () waitResponse conn-validatePath conn (Just (CIDInfo retiredSeqNum _ _)) = do+validatePath conn (Just cidInfo) = do pdat <- newPathData setChallenges conn pdat- putOutput conn $- OutControl RTT1Level [PathChallenge pdat, RetireConnectionID retiredSeqNum] $- return ()+ let retiredSeqNum = cidInfoSeq cidInfo+ putOutput conn+ $ OutControl+ RTT1Level+ [PathChallenge pdat, RetireConnectionID retiredSeqNum]+ $ return () waitResponse conn retirePeerCID conn retiredSeqNum
Network/QUIC/Connection/Misc.hs view
@@ -71,8 +71,7 @@ getSocket Connection{..} = readIORef connSocket setSocket :: Connection -> Socket -> IO Socket-setSocket Connection{..} sock = atomicModifyIORef' connSocket $- \sock0 -> (sock, sock0)+setSocket Connection{..} sock = atomicModifyIORef' connSocket (sock,) -- fixme clearSocket :: Connection -> IO Socket
Network/QUIC/Connection/Timeout.hs view
@@ -1,6 +1,7 @@ module Network.QUIC.Connection.Timeout ( timeout, fire,+ fire', cfire, delay, ) where@@ -26,6 +27,11 @@ action' = do alive <- getAlive conn when alive action `E.catch` ignore++fire' :: Microseconds -> TimeoutCallback -> IO ()+fire' (Microseconds microseconds) action = do+ timmgr <- getSystemTimerManager+ void $ registerTimeout timmgr microseconds action cfire :: Connection -> Microseconds -> TimeoutCallback -> IO (IO ()) cfire conn (Microseconds microseconds) action = do
Network/QUIC/Connection/Types.hs view
@@ -18,7 +18,7 @@ import Foreign.Marshal.Alloc import Foreign.Ptr (nullPtr) import Network.Control (Rate, RxFlow, TxFlow, newRate, newRxFlow, newTxFlow)-import Network.Socket (Cmsg, SockAddr, Socket)+import Network.Socket (SockAddr, Socket) import Network.TLS.QUIC import System.Mem.Weak (Weak) @@ -74,6 +74,8 @@ , certChain = Nothing } +-- cidInfoSRT in CIDInfo is only used in client+-- which accepts stateless reset. data CIDDB = CIDDB { usedCIDInfo :: CIDInfo , cidInfos :: IntMap CIDInfo@@ -93,7 +95,7 @@ , triggeredByMe = False } where- cidInfo = CIDInfo 0 cid (StatelessResetToken "")+ cidInfo = newCIDInfo 0 cid $ StatelessResetToken "" ---------------------------------------------------------------- @@ -186,7 +188,7 @@ type Send = Buffer -> Int -> IO () type Recv = IO ReceivedPacket -data PeerInfo = PeerInfo SockAddr [Cmsg] deriving (Eq, Show)+data PeerInfo = PeerInfo SockAddr deriving (Eq, Show) ---------------------------------------------------------------- @@ -203,6 +205,7 @@ -- Manage , connRecvQ :: RecvQ , connSocket :: IORef Socket+ , genStatelessResetToken :: CID -> StatelessResetToken , readers :: IORef (Map Word64 (Weak ThreadId)) , mainThreadId :: ThreadId , controlRate :: Rate@@ -296,8 +299,9 @@ -> RecvQ -> Send -> Recv+ -> (CID -> StatelessResetToken) -> IO Connection-newConnection rl myparams verInfo myAuthCIDs peerAuthCIDs debugLog qLog hooks sref piref recvQ ~send ~recv = do+newConnection rl myparams verInfo myAuthCIDs peerAuthCIDs debugLog qLog hooks sref piref recvQ ~send ~recv genSRT = do -- ~ for testing outQ <- newTQueueIO let put x = atomically $ writeTQueue outQ $ OutRetrans x@@ -306,7 +310,7 @@ encBuf <- mallocBytes bufsiz ecrptBuf <- mallocBytes bufsiz dcrptBuf <- mallocBytes bufsiz- Connection connstate debugLog qLog hooks send recv recvQ sref+ Connection connstate debugLog qLog hooks send recv recvQ sref genSRT <$> newIORef Map.empty <*> myThreadId <*> newRate@@ -392,6 +396,7 @@ -> RecvQ -> Send -> Recv+ -> (CID -> StatelessResetToken) -> IO Connection clientConnection ClientConfig{..} verInfo myAuthCIDs peerAuthCIDs = newConnection Client ccParameters verInfo myAuthCIDs peerAuthCIDs@@ -409,6 +414,7 @@ -> RecvQ -> Send -> Recv+ -> (CID -> StatelessResetToken) -> IO Connection serverConnection ServerConfig{..} verInfo myAuthCIDs peerAuthCIDs = newConnection Server scParameters verInfo myAuthCIDs peerAuthCIDs
Network/QUIC/Crypto/Keys.hs view
@@ -24,7 +24,7 @@ ---------------------------------------------------------------- defaultCipher :: Cipher-defaultCipher = cipher_TLS13_AES128GCM_SHA256+defaultCipher = cipher13_AES_128_GCM_SHA256 ----------------------------------------------------------------
Network/QUIC/Crypto/Nite.hs view
@@ -40,19 +40,17 @@ cipherEncrypt :: Cipher -> Key -> Nonce -> PlainText -> AssDat -> Maybe (CipherText, CipherText) cipherEncrypt cipher- | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128gcmEncrypt- | cipher == cipher_TLS13_AES128CCM_SHA256 =- error "cipher_TLS13_AES128CCM_SHA256"- | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256gcmEncrypt+ | cipher == cipher13_AES_128_GCM_SHA256 = aes128gcmEncrypt+ | cipher == cipher13_AES_128_CCM_SHA256 = error "cipher13_AES_128_CCM_SHA256"+ | cipher == cipher13_AES_256_GCM_SHA384 = aes256gcmEncrypt | otherwise = error "cipherEncrypt" cipherDecrypt :: Cipher -> Key -> Nonce -> CipherText -> AssDat -> Maybe PlainText cipherDecrypt cipher- | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128gcmDecrypt- | cipher == cipher_TLS13_AES128CCM_SHA256 =- error "cipher_TLS13_AES128CCM_SHA256"- | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256gcmDecrypt+ | cipher == cipher13_AES_128_GCM_SHA256 = aes128gcmDecrypt+ | cipher == cipher13_AES_128_CCM_SHA256 = error "cipher13_AES_128_CCM_SHA256"+ | cipher == cipher13_AES_256_GCM_SHA384 = aes256gcmDecrypt | otherwise = error "cipherDecrypt" -- IMPORTANT: Using 'let' so that parameters can be memorized.@@ -227,10 +225,9 @@ cipherHeaderProtection :: Cipher -> Key -> (Sample -> Mask) cipherHeaderProtection cipher key- | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128ecbEncrypt key- | cipher == cipher_TLS13_AES128CCM_SHA256 =- error "cipher_TLS13_AES128CCM_SHA256"- | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256ecbEncrypt 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 | otherwise = error "cipherHeaderProtection"
Network/QUIC/Crypto/Utils.hs view
@@ -27,16 +27,16 @@ tagLength :: Cipher -> Int tagLength cipher- | cipher == cipher_TLS13_AES128GCM_SHA256 = 16- | cipher == cipher_TLS13_AES128CCM_SHA256 = 16- | cipher == cipher_TLS13_AES256GCM_SHA384 = 16+ | cipher == cipher13_AES_128_GCM_SHA256 = 16+ | cipher == cipher13_AES_128_CCM_SHA256 = 16+ | cipher == cipher13_AES_256_GCM_SHA384 = 16 | otherwise = error "tagLength" sampleLength :: Cipher -> Int sampleLength cipher- | cipher == cipher_TLS13_AES128GCM_SHA256 = 16- | cipher == cipher_TLS13_AES128CCM_SHA256 = 16- | cipher == cipher_TLS13_AES256GCM_SHA384 = 16+ | cipher == cipher13_AES_128_GCM_SHA256 = 16+ | cipher == cipher13_AES_128_CCM_SHA256 = 16+ | cipher == cipher13_AES_256_GCM_SHA384 = 16 | otherwise = error "sampleLength" ----------------------------------------------------------------
Network/QUIC/Handshake.hs view
@@ -156,14 +156,18 @@ ---------------------------------------------------------------- -handshakeServer :: ServerConfig -> Connection -> AuthCIDs -> IO (IO ())-handshakeServer conf conn myAuthCIDs =+handshakeServer+ :: ServerConfig -> Connection -> AuthCIDs -> StatelessResetToken -> IO (IO ())+handshakeServer conf conn myAuthCIDs srt = handshakeServer' conf conn <$> getVersion conn <*> newHndStateRef <*> newIORef params where- params = setCIDsToParameters myAuthCIDs $ scParameters conf+ params =+ (setCIDsToParameters myAuthCIDs $ scParameters conf)+ { statelessResetToken = Just srt+ } handshakeServer' :: ServerConfig
Network/QUIC/Info.hs view
@@ -14,7 +14,7 @@ sock <- getSocket conn -- fixme: this is undefined mysa <- NS.getSocketName sock- PeerInfo peersa _ <- getPeerInfo conn+ PeerInfo peersa <- getPeerInfo conn mycid <- getMyCID conn peercid <- getPeerCID conn c <- getCipher conn RTT1Level
Network/QUIC/Packet/Encode.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE RecordWildCards #-}- module Network.QUIC.Packet.Encode ( -- encodePacket encodeVersionNegotiationPacket,
Network/QUIC/Packet/Frame.hs view
@@ -346,7 +346,7 @@ cidLen <- fromIntegral <$> read8 rbuf cID <- makeCID <$> extractShortByteString rbuf cidLen token <- StatelessResetToken <$> extractShortByteString rbuf 16- return $ NewConnectionID (CIDInfo seqNum cID token) rpt+ return $ NewConnectionID (newCIDInfo seqNum cID token) rpt decodeRetireConnectionID :: ReadBuffer -> IO Frame decodeRetireConnectionID rbuf = do
Network/QUIC/Qlog.hs view
@@ -132,11 +132,11 @@ frameExtra DataBlocked{} = "" frameExtra StreamDataBlocked{} = "" frameExtra StreamsBlocked{} = ""-frameExtra (NewConnectionID (CIDInfo sn cid _) rpt) =+frameExtra (NewConnectionID cidinfo rpt) = ",\"sequence_number\":\""- <> sw sn+ <> sw (cidInfoSeq cidinfo) <> "\",\"connection_id:\":\""- <> sw cid+ <> sw (cidInfoCID cidinfo) <> "\",\"retire_prior_to\":\"" <> sw rpt <> "\""
Network/QUIC/Receiver.hs view
@@ -178,21 +178,12 @@ qlogDebug conn $ Debug "ping for speedup" sendFrames conn lvl [Ping] Nothing -> do- statelessReset <- isStatelessReset conn hdr crypt- if statelessReset- then do- qlogReceived conn StatelessReset tim- connDebugLog conn "debug: connection is reset statelessly"- E.throwIO ConnectionIsReset- else do- qlogDropped conn hdr- connDebugLog conn $- "debug: cannot decrypt: "- <> bhow lvl- <> " size = "- <> bhow (BS.length $ cryptPacket crypt)---- fixme: sending statelss reset+ qlogDropped conn hdr+ connDebugLog conn $+ "debug: cannot decrypt: "+ <> bhow lvl+ <> " size = "+ <> bhow (BS.length $ cryptPacket crypt) isSendOnly :: Connection -> StreamId -> Bool isSendOnly conn sid@@ -376,10 +367,10 @@ mcidInfo <- retireMyCID conn sn case mcidInfo of Nothing -> return ()- Just (CIDInfo _ cid _) -> do+ Just cidInfo -> do when (isServer conn) $ do unregister <- getUnregister conn- unregister cid+ unregister $ cidInfoCID cidInfo processFrame conn RTT1Level (PathChallenge dat) = sendFramesLim conn RTT1Level [PathResponse dat] processFrame conn RTT1Level (PathResponse dat) =@@ -411,18 +402,6 @@ -- to receive NewSessionTicket fire conn (Microseconds 1000000) $ killHandshaker conn lvl processFrame _ _ _ = closeConnection ProtocolViolation "Frame is not allowed"---- QUIC version 1 uses only short packets for stateless reset.--- But we should check other packets, too.-isStatelessReset :: Connection -> Header -> Crypt -> IO Bool-isStatelessReset conn hdr Crypt{..} = do- let cid = headerMyCID hdr- included <- myCIDsInclude conn cid- case included of- Just _ -> return False- _ -> case decodeStatelessResetToken cryptPacket of- Nothing -> return False- Just token -> isStatelessRestTokenValid conn cid token -- Return value indicates duplication. putRxCrypto :: Connection -> EncryptionLevel -> RxStreamData -> IO Bool
Network/QUIC/Server/Reader.hs view
@@ -7,6 +7,7 @@ clearDispatch, runDispatcher, tokenMgr,+ genStatelessReset, -- * Accepting Accept (..),@@ -26,15 +27,17 @@ import qualified Data.Map.Strict as M import qualified GHC.IO.Exception as E import Network.ByteOrder-import Network.Control (LRUCache)+import Network.Control (LRUCacheRef, Rate, getRate, newRate) import qualified Network.Control as LRUCache import Network.Socket (Socket, waitReadSocketSTM) import qualified Network.Socket.ByteString as NSB import qualified System.IO.Error as E+import System.Random (getStdRandom, randomRIO, uniformByteString) import Network.QUIC.Common import Network.QUIC.Config import Network.QUIC.Connection+import Network.QUIC.Connector import Network.QUIC.Exception import Network.QUIC.Imports import Network.QUIC.Logger@@ -48,15 +51,22 @@ data Dispatch = Dispatch { tokenMgr :: CT.TokenManager , dstTable :: IORef ConnectionDict- , srcTable :: IORef RecvQDict+ , srcTable :: RecvQDict+ , genStatelessReset :: CID -> StatelessResetToken+ , statelessResetRate :: Rate } +statelessResetLimit :: Int+statelessResetLimit = 20+ newDispatch :: ServerConfig -> IO Dispatch newDispatch ServerConfig{..} = Dispatch <$> CT.spawnTokenManager conf <*> newIORef emptyConnectionDict- <*> newIORef emptyRecvQDict+ <*> newRecvQDict+ <*> makeGenStatelessReset+ <*> newRate where conf = CT.defaultConfig@@ -89,26 +99,21 @@ ---------------------------------------------------------------- --- Original destination CID -> RecvQ-newtype RecvQDict = RecvQDict (LRUCache CID RecvQ)+-- Source CID -> RecvQ+-- Initials and RTT0 are queued before Conneciton is created.+newtype RecvQDict = RecvQDict (LRUCacheRef CID RecvQ) recvQDictSize :: Int recvQDictSize = 100 -emptyRecvQDict :: RecvQDict-emptyRecvQDict = RecvQDict $ LRUCache.empty recvQDictSize+newRecvQDict :: IO RecvQDict+newRecvQDict = RecvQDict <$> LRUCache.newLRUCacheRef recvQDictSize -lookupRecvQDict :: IORef RecvQDict -> CID -> IO (Maybe RecvQ)-lookupRecvQDict ref dcid = do- RecvQDict c <- readIORef ref- return $ case LRUCache.lookup dcid c of- Nothing -> Nothing- Just q -> Just q+lookupRecvQDict :: RecvQDict -> CID -> IO (RecvQ, Bool)+lookupRecvQDict (RecvQDict ref) dcid = LRUCache.cached ref dcid newRecvQ -insertRecvQDict :: IORef RecvQDict -> CID -> RecvQ -> IO ()-insertRecvQDict ref dcid q = atomicModifyIORef'' ref ins- where- ins (RecvQDict c) = RecvQDict $ LRUCache.insert dcid q c+lookupRecvQDict' :: RecvQDict -> CID -> IO (Maybe RecvQ)+lookupRecvQDict' (RecvQDict ref) dcid = LRUCache.cached' ref dcid ---------------------------------------------------------------- @@ -164,14 +169,14 @@ loop wait = do cont <- checkLoop stvar wait when cont $ do- (peersa, bs, cmsgs, _) <- safeRecv $ NSB.recvMsg mysock 2048 2048 0+ (bs, peersa) <- safeRecv $ NSB.recvFrom mysock 2048 now <- getTimeMicrosecond- let send' b = void $ NSB.sendMsg mysock peersa [b] cmsgs 0+ let send' b = void $ NSB.sendTo mysock b peersa -- cf: greaseQuicBit $ getMyParameters conn quicBit = greaseQuicBit $ scParameters conf cpckts <- decodeCryptPackets bs (not quicBit) let bytes = BS.length bs- peerInfo = PeerInfo peersa cmsgs+ peerInfo = PeerInfo peersa switch = dispatch d conf forkConnection logAction mysock peerInfo send' bytes now mapM_ switch cpckts loop wait@@ -255,31 +260,28 @@ Just conn -> writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl where myVersions = scVersions- pushToAcceptQ myAuthCIDs peerAuthCIDs key addrValid = do- mq <- lookupRecvQDict srcTable key- case mq of- Just q -> writeRecvQ q $ mkReceivedPacket cpkt tim siz lvl- Nothing -> do- q <- newRecvQ- insertRecvQDict srcTable key q- writeRecvQ q $ mkReceivedPacket cpkt tim siz lvl- let reg = registerConnectionDict dstTable- unreg = unregisterConnectionDict dstTable- acc =- Accept- { accVersionInfo = VersionInfo peerVer myVersions- , accMyAuthCIDs = myAuthCIDs- , accPeerAuthCIDs = peerAuthCIDs- , accMySocket = mysock- , accPeerInfo = peerInfo- , accRecvQ = q- , accPacketSize = bytes- , accRegister = reg- , accUnregister = unreg- , accAddressValidated = addrValid- , accTime = tim- }- forkConnection acc+ pushToAcceptQ myAuthCIDs peerAuthCIDs addrValid = do+ (q, exist) <- lookupRecvQDict srcTable sCID+ writeRecvQ q $ mkReceivedPacket cpkt tim siz lvl+ unless exist $ do+ let reg = registerConnectionDict dstTable+ unreg cid =+ fire' (Microseconds 10000000) $ unregisterConnectionDict dstTable cid+ acc =+ Accept+ { accVersionInfo = VersionInfo peerVer myVersions+ , accMyAuthCIDs = myAuthCIDs+ , accPeerAuthCIDs = peerAuthCIDs+ , accMySocket = mysock+ , accPeerInfo = peerInfo+ , accRecvQ = q+ , accPacketSize = bytes+ , accRegister = reg+ , accUnregister = unreg+ , accAddressValidated = addrValid+ , accTime = tim+ }+ forkConnection acc -- Initial: DCID=S1, SCID=C1 -> -- <- Initial: DCID=C1, SCID=S2 -- ...@@ -300,7 +302,7 @@ defaultAuthCIDs { initSrcCID = Just sCID }- pushToAcceptQ myAuthCIDs peerAuthCIDs dCID addrValid+ pushToAcceptQ myAuthCIDs peerAuthCIDs addrValid -- Initial: DCID=S1, SCID=C1 -> -- <- Retry: DCID=C1, SCID=S2 -- Initial: DCID=S2, SCID=C1 ->@@ -323,7 +325,7 @@ defaultAuthCIDs { initSrcCID = Just sCID }- pushToAcceptQ myAuthCIDs peerAuthCIDs o True+ pushToAcceptQ myAuthCIDs peerAuthCIDs True pushToAcceptRetried _ = return () isRetryTokenValid (CryptoToken _tver life etim (Just (l, r, _))) = do diff <- getElapsedTimeMicrosecond etim@@ -356,11 +358,44 @@ _ _ tim- (cpkt@(CryptPacket (RTT0 _ dCID _) _), lvl, siz) = do- mq <- lookupRecvQDict srcTable dCID+ (cpkt@(CryptPacket (RTT0 _ _dCID sCID) _), lvl, siz) = do+ mq <- lookupRecvQDict' srcTable sCID case mq of Just q -> writeRecvQ q $ mkReceivedPacket cpkt tim siz lvl Nothing -> return ()+----------------------------------------------------------------+dispatch+ Dispatch{..}+ _+ _+ logAction+ mysock+ peerInfo+ send'+ bytes+ tim+ (cpkt@(CryptPacket (Short dCID) _), lvl, siz) = do+ mconn <- lookupConnectionDict dstTable dCID+ case mconn of+ Nothing -> do+ -- Three times rule for stateless reset+ -- Our packet size is 1280+ when (bytes > 427) $ do+ srRate <- getRate statelessResetRate+ -- fixme: hard coding+ when (srRate < statelessResetLimit) $ do+ flag <- randomRIO (0, 127)+ body <- getStdRandom $ uniformByteString 1263+ let srt = genStatelessReset dCID+ statelessReset = BS.concat [BS.singleton flag, body, fromStatelessResetToken srt]+ send' statelessReset+ logAction $ "Stateless reset is sent to " <> bhow peerInfo+ Just conn -> do+ alive <- getAlive conn+ when alive $ do+ void $ setSocket conn mysock+ setPeerInfo conn peerInfo+ writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl ---------------------------------------------------------------- dispatch Dispatch{..}
Network/QUIC/Server/Run.hs view
@@ -41,7 +41,7 @@ -- The action is executed with a new connection -- in a new lightweight thread. run :: ServerConfig -> (Connection -> IO ()) -> IO ()-run conf server = NS.withSocketsDo $ handleLogUnit debugLog $ do+run conf server = handleLogUnit debugLog $ do labelMe "QUIC run" stvar <- newTVarIO Running E.bracket (setup stvar) teardown $ \(_, _, _) -> do@@ -70,7 +70,7 @@ -- The action is executed with a new connection -- in a new lightweight thread. runWithSockets :: [NS.Socket] -> ServerConfig -> (Connection -> IO ()) -> IO ()-runWithSockets ssas conf server = NS.withSocketsDo $ handleLogUnit debugLog $ do+runWithSockets ssas conf server = handleLogUnit debugLog $ do labelMe "QUIC runWithSockets" stvar <- newTVarIO Running E.bracket (setup stvar) teardown $ \(_, _) -> do@@ -113,7 +113,8 @@ { versionInformation = Just $ accVersionInfo acc } }- handshaker <- handshakeServer conf' conn myAuthCIDs+ let srt = genStatelessReset dispatch $ fromJust $ initSrcCID myAuthCIDs+ handshaker <- handshakeServer conf' conn myAuthCIDs srt let server = do wait1RTTReady conn afterHandshakeServer conf conn@@ -158,8 +159,8 @@ piref <- newIORef accPeerInfo let send buf siz = void $ do sock <- readIORef sref- PeerInfo sa cmsgs <- readIORef piref- NS.sendBufMsg sock sa [(buf, siz)] cmsgs 0+ PeerInfo sa <- readIORef piref+ NS.sendBufTo sock buf siz sa recv = recvServer accRecvQ let myCID = fromJust $ initSrcCID accMyAuthCIDs ocid = fromJust $ origDstCID accMyAuthCIDs@@ -180,13 +181,14 @@ accRecvQ send recv+ (genStatelessReset dispatch) addResource conn qclean addResource conn dclean let cid = fromMaybe ocid $ retrySrcCID accMyAuthCIDs ver = chosenVersion accVersionInfo initializeCoder conn InitialLevel $ initialSecrets ver cid setupCryptoStreams conn -- fixme: cleanup- let PeerInfo peersa _ = accPeerInfo+ let PeerInfo peersa = accPeerInfo pktSiz = (defaultPacketSize peersa `max` accPacketSize) `min` maximumPacketSize peersa
Network/QUIC/Socket.hs view
@@ -6,6 +6,7 @@ import qualified Control.Exception as E import Data.IP (IP, toSockAddr)+import qualified Data.List.NonEmpty as NE import Network.Socket natRebinding :: SockAddr -> IO Socket@@ -21,7 +22,7 @@ clientSocket :: HostName -> ServiceName -> IO (Socket, SockAddr) clientSocket host port = do- addr <- head <$> getAddrInfo (Just hints) (Just host) (Just port)+ addr <- NE.head <$> getAddrInfo (Just hints) (Just host) (Just port) E.bracketOnError (openSocket addr) close $ \s -> return (s, addrAddress addr) where hints = defaultHints{addrSocketType = Datagram, addrFlags = [AI_ADDRCONFIG]}
Network/QUIC/Stream/Types.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE RecordWildCards #-}- module Network.QUIC.Stream.Types ( Stream (..), newStream,
Network/QUIC/Types/CID.hs view
@@ -9,16 +9,23 @@ makeCID, unpackCID, StatelessResetToken (..),- newStatelessResetToken,+ fromStatelessResetToken,+ makeGenStatelessReset, PathData (..), newPathData,- CIDInfo (..),+ CIDInfo,+ newCIDInfo,+ cidInfoSeq,+ cidInfoCID,+ cidInfoSRT, ) where -import qualified Data.ByteString.Short as Short- import Codec.Serialise+import Crypto.Hash+import Crypto.KDF.HKDF+import qualified Data.ByteString.Short as Short import GHC.Generics+import System.Random (getStdRandom, uniformByteString) import Network.QUIC.Imports @@ -54,9 +61,17 @@ -- 16 bytes newtype StatelessResetToken = StatelessResetToken Bytes deriving (Eq, Ord, Show) -newStatelessResetToken :: IO StatelessResetToken-newStatelessResetToken = StatelessResetToken <$> getRandomBytes 16+fromStatelessResetToken :: StatelessResetToken -> ByteString+fromStatelessResetToken (StatelessResetToken srt) = Short.fromShort srt +makeGenStatelessReset :: IO (CID -> StatelessResetToken)+makeGenStatelessReset = do+ salt <- getStdRandom $ uniformByteString 20+ ikm <- getStdRandom $ uniformByteString 20+ let prk = extract salt ikm :: PRK SHA256+ makeStatelessReset dcid = StatelessResetToken $ Short.toShort $ expand prk (fromCID dcid) 16+ return makeStatelessReset+ -- 8 bytes newtype PathData = PathData Bytes deriving (Eq, Show) @@ -69,3 +84,11 @@ , cidInfoSRT :: StatelessResetToken } deriving (Eq, Ord, Show)++newCIDInfo :: Int -> CID -> StatelessResetToken -> CIDInfo+newCIDInfo n cid srt =+ CIDInfo+ { cidInfoSeq = n+ , cidInfoCID = cid+ , cidInfoSRT = srt+ }
Network/QUIC/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Utils where@@ -11,7 +12,9 @@ import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as Short import Data.Char (chr)+#if __GLASGOW_HASKELL__ < 910 import Data.List (foldl')+#endif import Data.Word import Foreign.ForeignPtr (withForeignPtr) import Foreign.Ptr (Ptr, plusPtr)
quic.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: quic-version: 0.2.7+version: 0.2.8 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp@@ -144,12 +144,12 @@ fast-logger >= 3.2.2 && < 3.3, unix-time >= 0.4.12 && < 0.5, iproute >= 1.7.12 && < 1.8,- network >= 3.2.2,+ network >= 3.2.3, network-byte-order >= 0.1.7 && < 0.2,- network-control >= 0.1 && < 0.2,- random >= 1.2.1 && < 1.3,+ network-control >= 0.1.5 && < 0.2,+ random >= 1.2.1 && < 1.4, serialise,- tls >= 2.0 && < 2.2+ tls >= 2.1.6 && < 2.2 if os(windows) cc-options: -D_WINDOWS
test/Config.hs view
@@ -18,6 +18,7 @@ import Data.ByteString (ByteString) import Data.IORef import qualified Data.List as L+import qualified Data.List.NonEmpty as NE import Network.Socket import Network.Socket.ByteString import Network.TLS hiding (Version)@@ -137,7 +138,7 @@ , addrFamily = AF_INET } resolve port =- head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just port)+ NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just port) shouldDrop (Randomly n) _ _ = do w <- getRandomOneByte return ((w `mod` fromIntegral n) == 0)
test/IOSpec.hs view
@@ -199,10 +199,13 @@ strm <- acceptStream conn void $ forkIO $ do bs <- recvStream strm 1- let n = fromIntegral $ head $ BS.unpack bs- consumeBytes strm (chunklen * times)- assertEndOfStream strm- putMVar (mvars !! n) ()+ case BS.uncons bs of+ Nothing -> return ()+ Just (w, _) -> do+ let n = fromIntegral w+ consumeBytes strm (chunklen * times)+ assertEndOfStream strm+ putMVar (mvars !! n) () loop conn appErr :: QUICException -> Bool
test/PacketSpec.hs view
@@ -49,9 +49,10 @@ (sock, peersa) <- clientSocket "127.0.0.1" "2000" q <- newRecvQ sref <- newIORef sock- piref <- newIORef $ PeerInfo peersa []+ piref <- newIORef $ PeerInfo peersa let ver = v verInfo = VersionInfo ver [ver]+ genSRT <- makeGenStatelessReset ---- clientConn <- clientConnection@@ -67,6 +68,7 @@ q undefined undefined+ genSRT initializeCoder clientConn InitialLevel $ initialSecrets ver serverCID serverConn <- serverConnection@@ -82,6 +84,7 @@ q undefined undefined+ genSRT initializeCoder serverConn InitialLevel $ initialSecrets ver serverCID ---- return (clientConn, serverConn)
util/Common.hs view
@@ -36,9 +36,9 @@ split :: Char -> String -> [String] split _ "" = [] split c s = case break (c ==) s of- ("", r) -> split c (tail r)+ ("", r) -> split c (drop 1 r) (s', "") -> [s']- (s', r) -> s' : split c (tail r)+ (s', r) -> s' : split c (drop 1 r) getLogger :: Maybe FilePath -> (String -> IO ()) getLogger Nothing = \_ -> return ()
util/quic-client.hs view
@@ -415,7 +415,10 @@ putStrLn "q -- quit" putStrLn "g -- get" putStrLn "p -- ping"- putStrLn "n -- NAT rebinding"+ putStrLn "M -- change server CID"+ putStrLn "N -- change client CID"+ putStrLn "B -- NAT rebinding"+ putStrLn "A -- address mobility" loop where loop = do@@ -433,8 +436,17 @@ putStrLn "Ping" sendFrames conn RTT1Level [Ping] loop- "n" -> do+ "M" -> do+ controlConnection conn ChangeServerCID >>= print+ loop+ "N" -> do+ controlConnection conn ChangeClientCID >>= print+ loop+ "B" -> do controlConnection conn NATRebinding >>= print+ loop+ "A" -> do+ controlConnection conn ActiveMigration >>= print loop _ -> do putStrLn "No such command"
util/quic-server.hs view
@@ -27,6 +27,7 @@ , optQLogDir :: Maybe FilePath , optKeyLogFile :: Maybe FilePath , optGroups :: Maybe String+ , optTimeout :: Maybe Int , optCertFile :: FilePath , optKeyFile :: FilePath , optRetry :: Bool@@ -40,6 +41,7 @@ , optQLogDir = Nothing , optKeyLogFile = Nothing , optGroups = Nothing+ , optTimeout = Nothing , optCertFile = "servercert.pem" , optKeyFile = "serverkey.pem" , optRetry = False@@ -82,6 +84,11 @@ ["retry"] (NoArg (\o -> o{optRetry = True})) "require stateless retry"+ , Option+ ['o']+ ["timeout"]+ (ReqArg (\tim o -> o{optTimeout = Just (read tim)}) "<timeout>")+ "RX timeout in seconds" ] usage :: String@@ -140,6 +147,9 @@ , scCredentials = Credentials [cred] } run sc $ \conn -> do+ case optTimeout of+ Just t -> setMinIdleTimeout conn $ Microseconds $ t * 1000000+ Nothing -> return () info <- getConnectionInfo conn let server = case alpn info of Just proto