quic 0.2.9 → 0.2.10
raw patch · 32 files changed
+775/−242 lines, 32 files
Files
- ChangeLog.md +16/−0
- Network/QUIC/Client.hs +23/−2
- Network/QUIC/Client/Reader.hs +90/−17
- Network/QUIC/Client/Run.hs +47/−11
- Network/QUIC/Closer.hs +23/−15
- Network/QUIC/Config.hs +20/−0
- Network/QUIC/Connection/Migration.hs +61/−23
- Network/QUIC/Connection/Misc.hs +25/−13
- Network/QUIC/Connection/Queue.hs +23/−17
- Network/QUIC/Connection/Role.hs +15/−0
- Network/QUIC/Connection/State.hs +25/−17
- Network/QUIC/Connection/Types.hs +45/−17
- Network/QUIC/Handshake.hs +5/−2
- Network/QUIC/IO.hs +2/−2
- Network/QUIC/Info.hs +1/−1
- Network/QUIC/Packet/Frame.hs +4/−4
- Network/QUIC/Parameters.hs +1/−1
- Network/QUIC/Qlog.hs +12/−1
- Network/QUIC/Receiver.hs +86/−26
- Network/QUIC/Recovery/Release.hs +1/−3
- Network/QUIC/Recovery/Types.hs +2/−1
- Network/QUIC/Sender.hs +36/−17
- Network/QUIC/Server/Reader.hs +50/−16
- Network/QUIC/Server/Run.hs +6/−5
- Network/QUIC/Types.hs +16/−0
- Network/QUIC/Types/CID.hs +4/−1
- Network/QUIC/Types/Constants.hs +2/−2
- cbits/sysevent.c +72/−0
- quic.cabal +26/−19
- test/Config.hs +23/−6
- test/PacketSpec.hs +2/−1
- util/quic-client.hs +11/−2
ChangeLog.md view
@@ -1,5 +1,21 @@ # ChangeLog +## 0.2.10++* Fix a bug of ACK on retransmission.+* New scheme to pack ACK on handshake.+* Fix a race condition in closure. CC is broken sometime.+* Using Rate instead of TBQueue against DOS.+* Enhancing qlog.+* Cleaning up the code for migration.+* Anti-amplification for migration.+* Respecting active_connection_id_limit.+* If `ccWatchDog` is `True`, a watch dog thread is spawn to call+ `migration` when network configuration changes.+* Connected sockets again for clients. Set `ccSockConnected` to `True`+ to use connected sockets.+* Fixing time representation of qlog.+ ## 0.2.9 * Don't send Fin if connection is already closed.
Network/QUIC/Client.hs view
@@ -1,6 +1,4 @@ -- | This main module provides APIs for QUIC clients.--- When a new better network interface is up,--- migration is done automatically. module Network.QUIC.Client ( -- * Running a QUIC client run,@@ -18,6 +16,8 @@ ccVersions, -- , ccCredentials ccValidate,+ ccSockConnected,+ ccWatchDog, -- * Resumption ResumptionInfo,@@ -26,6 +26,27 @@ is0RTTPossible, -- * Migration++ -- | If 'ccSockConnected' is 'True', a connected socket is made.+ -- Otherwise, a unconnected socket is made.+ --+ -- For unconnected sockets, a preferred network IF is used+ -- according to packet routing. But since the current peer CID+ -- is used with the new local address, a bad guy can correlate+ -- the old local addresss and the new local address via the+ -- current peer CID. In other words, migration is trackable.+ --+ -- For connected sockets, the old local address is kept to be+ -- used even if a preferred network IF gets available. Call the+ -- 'migrate' API to use the new local address. This ensures that+ -- a new peer CID is used for the new local address. In short,+ -- migration is not trackable.+ --+ -- If 'ccWatchDog' is 'True' on Linux and macOS, a watch dog+ -- thread is spawned and it calls 'migrate' when network-related+ -- events (e.g. a new network IF is attached or the default+ -- route is changed) are observed. This is an experimental+ -- feature. migrate, ) where
Network/QUIC/Client/Reader.hs view
@@ -12,7 +12,7 @@ import Control.Concurrent import qualified Control.Exception as E import Data.List (intersect)-import Network.Socket (Socket, close, getSocketName)+import Network.Socket (Socket, close, connect, getSocketName) import qualified Network.Socket.ByteString as NSB import Network.QUIC.Common@@ -33,7 +33,14 @@ readerClient s0 conn = handleLogUnit logAction $ do labelMe "readerClient" wait- loop+ connected <- getSockConnected conn+ peersa0 <- peerSockAddr <$> getPathInfo conn+ let recv+ | connected = NSB.recv s0 2048+ | otherwise = do+ (bs, peersa) <- NSB.recvFrom s0 2048+ if peersa /= peersa0 then recv else return bs+ loop recv where wait = do bound <- E.handle (throughAsync (return False)) $ do@@ -42,19 +49,17 @@ unless bound $ do yield wait- loop = do+ loop recv = do ito <- readMinIdleTimeout conn- mbs <- timeout ito "readeClient" $ NSB.recvFrom s0 2048+ mbs <- timeout ito "readeClient" recv case mbs of Nothing -> close s0- 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+ Just bs -> do+ now <- getTimeMicrosecond+ let quicBit = greaseQuicBit $ getMyParameters conn+ pkts <- decodePackets bs (not quicBit)+ mapM_ (putQ now) pkts+ loop recv logAction msg = connDebugLog conn ("debug: readerClient: " <> msg) putQ _ (PacketIB BrokenPacket _) = return () putQ t (PacketIV pkt@(VersionNegotiationPacket dCID sCID peerVers)) = do@@ -92,6 +97,7 @@ qlogReceived conn pkt t ok <- checkCIDs conn dCID ex when ok $ do+ -- Re-creating peer's CIDDB with peer's CID. resetPeerCID conn sCID setPeerAuthCIDs conn $ \auth -> auth{retrySrcCID = Just sCID} initializeCoder conn InitialLevel $ initialSecrets ver sCID@@ -133,35 +139,102 @@ controlConnection' conn typ | otherwise = return False +----------------------------------------------------------------+-- ping: NewConnectionID(retirePriorTo), pong: RetireConnectionID+--+-- RFC 9000 Sec 5.1.2: Upon receipt of an increased Retire Prior To+-- field, the peer MUST stop using the corresponding connection IDs+-- and retire them with RETIRE_CONNECTION_ID frames before adding the+-- newly provided connection ID to the set of active connection IDs.+--+-- An endpoint MUST NOT forget a connection ID without retiring it.+--+----------------------------------------------------------------+-- ping: RetireConnectionID, pong: NewConnectionID+--+-- RFC 9000 Sec 5.1.1: An endpoint SHOULD supply a new connection ID+-- when the peer retires a connection ID.+-- RFC 9000 Sec 5.1.2: Sending a RETIRE_CONNECTION_ID frame indicates+-- that the connection ID will not be used again and requests that the+-- peer replace it with a new connection ID using a NEW_CONNECTION_ID+-- frame.+--+----------------------------------------------------------------+-- ping: PathChallenge, pong: PathResponse+--+-- RFC 9000 Sec 8.2.2: On receiving a PATH_CHALLENGE frame, an+-- endpoint MUST respond by echoing the data contained in the+-- PATH_CHALLENGE frame in a PATH_RESPONSE frame.+-- controlConnection' :: Connection -> ConnectionControl -> IO Bool+----------------------------------------------------------------+-- ChangeServerCID (-M)+--+-- Co -> Sn: RetireConnectionID(So)+-- Cn <- Sn: NewConnectionID (receiver) controlConnection' conn ChangeServerCID = do mn <- timeout (Microseconds 1000000) "controlConnection' 1" $ waitPeerCID conn -- fixme case mn of Nothing -> return False Just cidInfo -> do- sendFrames conn RTT1Level [RetireConnectionID (cidInfoSeq cidInfo)]+ let seqNum = cidInfoSeq cidInfo+ retirePeerCID conn seqNum+ -- Client tells "I don't use this CID of yours".+ sendFrames conn RTT1Level [RetireConnectionID seqNum] return True+----------------------------------------------------------------+-- ChangeClientCID (-N)+--+-- Co -> So: NewConnectionID(retirePriorTo Co)+-- Cn <- Sn: RetireConnectionID(Co) (processFrame) controlConnection' conn ChangeClientCID = do+ -- checkPeerCIDCapacity is not necessary beucase one CID is+ -- retired. cidInfo <- getNewMyCID conn- x <- (+ 1) <$> getMyCIDSeqNum conn- sendFrames conn RTT1Level [NewConnectionID cidInfo x]+ retirePriorTo' <- (+ 1) <$> getMyCIDSeqNum conn+ setMyRetirePriorTo conn retirePriorTo' -- just for record+ writeIORef (sentRetirePriorTo conn) True+ -- Client tells "My CIDs less than retirePriorTo should be retired".+ sendFrames conn RTT1Level [NewConnectionID cidInfo retirePriorTo'] return True+----------------------------------------------------------------+-- NATRebinding (-B)+--+-- <local port change>+-- So -> Co: PathChallenge (validatePath)+-- Co -> So: PathResponse (processFrame) controlConnection' conn NATRebinding = do rebind conn $ Microseconds 5000 -- nearly 0 return True+----------------------------------------------------------------+-- ActiveMigration (-A)+--+-- <local port change>+-- Co -> Sn: NewConnectionID(retirePriorTo Co), RetireConnectionID(So), PathChallenge (validatePath)+-- Cn <- Sn: RetireConnectionID(Co), PathChallenge (validatePath)+-- Cn <- Sn: NewConnectionID (receiver)+-- Cn -> Sn: PathResponse (processFrame)+-- Cn <- Sn: PathResponse (processFrame) controlConnection' conn ActiveMigration = do+ -- Changing peer CID mn <- timeout (Microseconds 1000000) "controlConnection' 2" $ waitPeerCID conn -- fixme case mn of Nothing -> return False mcidinfo -> do+ peersa <- peerSockAddr <$> getPathInfo conn rebind conn $ Microseconds 5000000- validatePath conn mcidinfo+ -- Sending PathChallenge, RetireConnectionID and NewConnectionID RPT+ pathInfo <- newPathInfo peersa+ addPathInfo conn pathInfo+ validatePath conn pathInfo mcidinfo return True rebind :: Connection -> Microseconds -> IO () rebind conn microseconds = do- PeerInfo peersa <- getPeerInfo conn+ peersa <- peerSockAddr <$> getPathInfo conn newSock <- natRebinding peersa+ connected <- getSockConnected conn+ when connected $ connect newSock peersa oldSock <- setSocket conn newSock let reader = readerClient newSock conn forkManaged conn reader
Network/QUIC/Client/Run.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE InterruptibleFFI #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -7,8 +9,10 @@ migrate, ) where +import Control.Concurrent import Control.Concurrent.Async import qualified Control.Exception as E+import Foreign.C.Types import qualified Network.Socket as NS import Network.QUIC.Client.Reader@@ -31,10 +35,6 @@ -- | Running a QUIC client. -- A UDP socket is created according to 'ccServerName' and 'ccPortName'.------ If 'ccAutoMigration' is 'True', a unconnected socket is made.--- Otherwise, a connected socket is made.--- 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 = do@@ -93,6 +93,7 @@ case er of Left () -> E.throwIO MustNotReached Right r -> return r+ when (ccWatchDog conf) $ forkManaged conn $ watchDog conn ex <- E.try runThreads sendFinal conn closure conn ldcc ex@@ -107,15 +108,24 @@ createClientConnection :: ClientConfig -> VersionInfo -> IO ConnRes createClientConnection conf@ClientConfig{..} verInfo = do (sock, peersa) <- clientSocket ccServerName ccPortName+ when ccSockConnected $ NS.connect sock peersa q <- newRecvQ sref <- newIORef sock- piref <- newIORef $ PeerInfo peersa- let send buf siz = do- s <- readIORef sref- PeerInfo sa <- readIORef piref- void $ NS.sendBufTo s buf siz sa+ pathInfo <- newPathInfo peersa+ piref <- newIORef $ PeerInfo pathInfo Nothing+ let send buf siz+ | ccSockConnected = do+ s <- readIORef sref+ void $ NS.sendBuf s buf siz+ | otherwise = do+ s <- readIORef sref+ PeerInfo pinfo _ <- readIORef piref+ void $ NS.sendBufTo s buf siz $ peerSockAddr pinfo recv = recvClient q myCID <- newCID+ -- Creating peer's CIDDB with the temporary CID. This is+ -- overridden by resetPeerCID later since no sequence number is+ -- assigned to the temporary CID by spec. peerCID <- newCID now <- getTimeMicrosecond (qLog, qclean) <- dirQLogger ccQLog now peerCID "client"@@ -141,6 +151,7 @@ send recv genSRT+ setSockConnected conn ccSockConnected addResource conn qclean let ver = chosenVersion verInfo initializeCoder conn InitialLevel $ initialSecrets ver peerCID@@ -149,11 +160,36 @@ pktSiz = (defaultPacketSize peersa `max` pktSiz0) `min` maximumPacketSize peersa setMaxPacketSize conn pktSiz setInitialCongestionWindow (connLDCC conn) pktSiz- setAddressValidated conn+ setAddressValidated pathInfo let reader = readerClient sock conn -- dies when s0 is closed. return $ ConnRes conn myAuthCIDs reader -- | Creating a new socket and execute a path validation--- with a new connection ID.+-- with a new connection ID. Typically, this is used+-- for migration in the case where 'ccSockConnected' is 'True'.+-- But this can also be used even when the value is 'False'. migrate :: Connection -> IO Bool migrate conn = controlConnection conn ActiveMigration++watchDog :: Connection -> IO ()+watchDog conn = E.bracket c_open_socket c_close_socket loop+ where+ loop s = do+ ret <- c_watch_socket s+ case ret of+ -1 -> loop s+ -2 -> return ()+ _ -> do+ _ <- migrate conn+ -- prevent calling "migrate" frequently+ threadDelay 100000+ loop s++foreign import ccall unsafe "open_socket"+ c_open_socket :: IO CInt++foreign import ccall interruptible "watch_socket"+ c_watch_socket :: CInt -> IO CInt++foreign import ccall unsafe "close_socket"+ c_close_socket :: CInt -> IO CInt
Network/QUIC/Closer.hs view
@@ -40,21 +40,29 @@ closure' :: Connection -> LDCC -> Frame -> IO () closure' conn ldcc frame = do sock <- getSocket conn- PeerInfo peersa <- getPeerInfo conn+ peersa <- peerSockAddr <$> getPathInfo conn+ connected <- getSockConnected conn -- send- let sbuf@(SizedBuffer sendbuf _) = encryptRes conn- siz <- encodeCC conn sbuf frame- let send = void $ NS.sendBufTo sock sendbuf siz peersa+ let bufsiz = maximumUdpPayloadSize+ sendbuf <- mallocBytes bufsiz+ -- This must be called before freeResourcesin runClient.+ siz <- encodeCC conn sendbuf bufsiz frame+ let send+ | connected = void $ NS.sendBuf sock sendbuf siz+ | otherwise = void $ NS.sendBufTo sock sendbuf siz peersa -- recv and clos killReaders conn -- client only (recv, freeRecvBuf, clos) <- if isServer conn- then return (void $ connRecv conn, return (), return ())+ then return (void $ connRecv conn, free sendbuf, return ()) else do- let bufsiz = maximumUdpPayloadSize recvbuf <- mallocBytes bufsiz- let recv' = void $ NS.recvBuf sock recvbuf bufsiz- free' = free recvbuf+ let recv'+ | connected = void $ NS.recvBuf sock recvbuf bufsiz+ | otherwise = do+ (_, sa) <- NS.recvBufFrom sock recvbuf bufsiz+ when (sa /= peersa) recv'+ free' = free recvbuf >> free sendbuf clos' = do NS.close sock -- This is just in case.@@ -70,28 +78,28 @@ freeRecvBuf clos -encodeCC :: Connection -> SizedBuffer -> Frame -> IO Int-encodeCC conn res0@(SizedBuffer sendbuf0 bufsiz0) frame = do+encodeCC :: Connection -> Buffer -> BufferSize -> Frame -> IO Int+encodeCC conn sendbuf0 bufsiz0 frame = do lvl0 <- getEncryptionLevel conn let lvl | lvl0 == RTT0Level = InitialLevel | otherwise = lvl0 if lvl == HandshakeLevel then do- siz0 <- encCC res0 InitialLevel+ siz0 <- encCC sendbuf0 bufsiz0 InitialLevel let sendbuf1 = sendbuf0 `plusPtr` siz0 bufsiz1 = bufsiz0 - siz0- res1 = SizedBuffer sendbuf1 bufsiz1- siz1 <- encCC res1 HandshakeLevel+ siz1 <- encCC sendbuf1 bufsiz1 HandshakeLevel return (siz0 + siz1) else- encCC res0 lvl+ encCC sendbuf0 bufsiz0 lvl where- encCC res lvl = do+ encCC sendbuf bufsiz lvl = do header <- mkHeader conn lvl mypn <- nextPacketNumber conn let plain = Plain (Flags 0) mypn [frame] 0 ppkt = PlainPacket header plain+ res = SizedBuffer sendbuf bufsiz siz <- fst <$> encodePlainPacket conn res ppkt Nothing if siz >= 0 then do
Network/QUIC/Config.hs view
@@ -59,6 +59,8 @@ -- ^ The version to start with. , ccVersions :: [Version] -- ^ Compatible versions with 'ccVersion' in the preferred order.+ --+ -- Default: @[Version2, Version1]@ , ccCiphers :: [Cipher] -- ^ Cipher candidates defined in TLS 1.3. , ccGroups :: [Group]@@ -73,6 +75,8 @@ , ccUse0RTT :: Bool -- ^ Use 0-RTT on the 2nd connection if possible. -- client original+ --+ -- Default: 'False' , ccServerName :: HostName -- ^ Used to create a socket and SNI for TLS. , ccPortName :: ServiceName@@ -81,11 +85,25 @@ -- ^ An ALPN provider. , ccValidate :: Bool -- ^ Authenticating a server based on its certificate.+ --+ -- Default: 'True' , ccResumption :: ResumptionInfo -- ^ Use resumption on the 2nd connection if possible. , ccPacketSize :: Maybe Int -- ^ QUIC packet size (UDP payload size)+ --+ -- Default: 'Nothing' , ccDebugLog :: Bool+ , ccSockConnected :: Bool+ -- ^ If 'True', use a connected socket. Otherwise, use a+ -- unconnected socket.+ --+ -- Default: 'False'+ , ccWatchDog :: Bool+ -- ^ If 'True', a watch dog thread is spawned and 'migrate' is+ -- called when network events are observed.+ --+ -- Default: 'False' } -- | The default value for client configuration.@@ -111,6 +129,8 @@ , ccResumption = defaultResumptionInfo , ccPacketSize = Nothing , ccDebugLog = False+ , ccSockConnected = False+ , ccWatchDog = False } ----------------------------------------------------------------
Network/QUIC/Connection/Migration.hs view
@@ -24,6 +24,11 @@ isPathValidating, checkResponse, validatePath,+ getMyRetirePriorTo,+ setMyRetirePriorTo,+ getPeerRetirePriorTo,+ setPeerRetirePriorTo,+ checkPeerCIDCapacity, ) where import Control.Concurrent.STM@@ -33,6 +38,7 @@ import Network.QUIC.Connection.Misc import Network.QUIC.Connection.Queue import Network.QUIC.Connection.Types+import Network.QUIC.Connector import Network.QUIC.Imports import Network.QUIC.Parameters import Network.QUIC.Qlog@@ -148,24 +154,44 @@ ---------------------------------------------------------------- +checkPeerCIDCapacity :: Connection -> IO Bool+checkPeerCIDCapacity Connection{..} = do+ lim <- activeConnectionIdLimit <$> readIORef peerParameters+ cap <- IntMap.size . cidInfos <$> readIORef myCIDDB+ return (cap < lim)++getMyRetirePriorTo :: Connection -> IO Int+getMyRetirePriorTo Connection{..} = retirePriorTo <$> readIORef myCIDDB++setMyRetirePriorTo :: Connection -> Int -> IO ()+setMyRetirePriorTo Connection{..} rpt =+ modifyIORef' myCIDDB $ \db -> db{retirePriorTo = rpt}++getPeerRetirePriorTo :: Connection -> IO Int+getPeerRetirePriorTo Connection{..} = retirePriorTo <$> readTVarIO peerCIDDB++setPeerRetirePriorTo :: Connection -> Int -> IO ()+setPeerRetirePriorTo Connection{..} rpt =+ atomically $ modifyTVar' peerCIDDB $ \db -> db{retirePriorTo = rpt}+ -- | Receiving NewConnectionID setPeerCIDAndRetireCIDs :: Connection -> Int -> IO [Int]-setPeerCIDAndRetireCIDs Connection{..} n = atomically $ do+setPeerCIDAndRetireCIDs Connection{..} rpt = atomically $ do db <- readTVar peerCIDDB- let (db', ns) = arrange n db+ let (db', ns) = arrange rpt db writeTVar peerCIDDB db' return ns arrange :: Int -> CIDDB -> (CIDDB, [Int])-arrange n db@CIDDB{..} = (db', dropSeqnums)+arrange rpt db@CIDDB{..} = (db', dropSeqnums) where- (toDrops, cidInfos') = IntMap.partitionWithKey (\k _ -> k < n) cidInfos+ (toDrops, cidInfos') = IntMap.partitionWithKey (\k _ -> k < rpt) cidInfos dropSeqnums = IntMap.foldrWithKey (\k _ ks -> k : ks) [] toDrops dropCIDs = IntMap.foldr (\c r -> cidInfoCID c : r) [] toDrops -- IntMap.findMin is a partial function. -- But receiver guarantees that there is at least one cidinfo. usedCIDInfo'- | cidInfoSeq usedCIDInfo >= n = usedCIDInfo+ | cidInfoSeq usedCIDInfo >= rpt = usedCIDInfo | otherwise = snd $ IntMap.findMin cidInfos' revInfos' = foldr Map.delete revInfos dropCIDs db' =@@ -173,6 +199,7 @@ { usedCIDInfo = usedCIDInfo' , cidInfos = cidInfos' , revInfos = revInfos'+ , retirePriorTo = rpt } ----------------------------------------------------------------@@ -282,27 +309,36 @@ ---------------------------------------------------------------- -validatePath :: Connection -> Maybe CIDInfo -> IO ()-validatePath conn Nothing = do+validatePath :: Connection -> PathInfo -> Maybe CIDInfo -> IO ()+validatePath conn pathInfo Nothing = do pdat <- newPathData- setChallenges conn pdat- putOutput conn $ OutControl RTT1Level [PathChallenge pdat] $ return ()+ setChallenges conn pathInfo pdat+ putOutput conn $ OutControl RTT1Level [PathChallenge pdat] waitResponse conn-validatePath conn (Just cidInfo) = do+validatePath conn pathInfo (Just cidInfo) = do pdat <- newPathData- setChallenges conn pdat+ setChallenges conn pathInfo pdat let retiredSeqNum = cidInfoSeq cidInfo- putOutput conn- $ OutControl- RTT1Level- [PathChallenge pdat, RetireConnectionID retiredSeqNum]- $ return ()- waitResponse conn retirePeerCID conn retiredSeqNum+ extra <-+ if isClient conn+ then do+ -- Cf: controlConnection' ChangeClientCID+ myCidInfo <- getNewMyCID conn+ retirePriorTo' <- (+ 1) <$> getMyCIDSeqNum conn+ setMyRetirePriorTo conn retirePriorTo' -- just for record+ writeIORef (sentRetirePriorTo conn) True+ -- Client tells "My CIDs less than retirePriorTo should be retired".+ return [NewConnectionID myCidInfo retirePriorTo']+ else+ return []+ let frames = extra ++ [PathChallenge pdat, RetireConnectionID retiredSeqNum]+ putOutput conn $ OutControl RTT1Level frames+ waitResponse conn -setChallenges :: Connection -> PathData -> IO ()-setChallenges Connection{..} pdat =- atomically $ writeTVar migrationState $ SendChallenge pdat+setChallenges :: Connection -> PathInfo -> PathData -> IO ()+setChallenges Connection{..} pathInfo pdat =+ atomically $ writeTVar migrationState $ SendChallenge pathInfo pdat setMigrationStarted :: Connection -> IO () setMigrationStarted Connection{..} =@@ -312,7 +348,7 @@ isPathValidating Connection{..} = do s <- readTVarIO migrationState case s of- SendChallenge _ -> return True+ SendChallenge{} -> return True MigrationStarted -> return True _ -> return False @@ -326,6 +362,8 @@ checkResponse Connection{..} pdat = do state <- readTVarIO migrationState case state of- SendChallenge pdat'- | pdat == pdat' -> atomically $ writeTVar migrationState RecvResponse+ SendChallenge pathInfo pdat'+ | pdat == pdat' -> atomically $ do+ writeTVar migrationState RecvResponse+ writeTVar (addressValidated pathInfo) True _ -> return ()
Network/QUIC/Connection/Misc.hs view
@@ -10,8 +10,9 @@ getSocket, setSocket, clearSocket,- getPeerInfo,- setPeerInfo,+ getPathInfo,+ addPathInfo,+ findPathInfo, getPeerAuthCIDs, setPeerAuthCIDs, getClientDstCID,@@ -28,7 +29,6 @@ readMinIdleTimeout, setMinIdleTimeout, sendFrames,- sendFramesLim, closeConnection, abortConnection, ) where@@ -36,7 +36,7 @@ import Control.Concurrent import qualified Control.Exception as E import qualified Data.Map.Strict as Map-import Network.Socket (Socket)+import Network.Socket (SockAddr, Socket) import System.Mem.Weak import Network.QUIC.Connection.Queue@@ -78,12 +78,27 @@ clearSocket :: Connection -> IO Socket clearSocket Connection{..} = atomicModifyIORef' connSocket (undefined,) -getPeerInfo :: Connection -> IO PeerInfo-getPeerInfo Connection{..} = readIORef peerInfo+---------------------------------------------------------------- -setPeerInfo :: Connection -> PeerInfo -> IO ()-setPeerInfo Connection{..} = writeIORef peerInfo+getPathInfo :: Connection -> IO PathInfo+getPathInfo Connection{..} = currPathInfo <$> readIORef peerInfo +addPathInfo :: Connection -> PathInfo -> IO ()+addPathInfo Connection{..} newpi = atomicModifyIORef'' peerInfo add+ where+ add (PeerInfo oldpi _) = PeerInfo newpi $ Just oldpi++findPathInfo :: Connection -> SockAddr -> IO (Maybe PathInfo)+findPathInfo Connection{..} sa = do+ PeerInfo currpi mprevpi <- readIORef peerInfo+ return $+ if peerSockAddr currpi == sa+ then Just currpi+ else+ if (peerSockAddr <$> mprevpi) == Just sa+ then mprevpi+ else Nothing+ ---------------------------------------------------------------- getMyAuthCIDs :: Connection -> IO AuthCIDs@@ -131,7 +146,7 @@ join $ atomicModifyIORef' delayedAckCancel (new,) sendAck where- sendAck = putOutput conn $ OutControl RTT1Level [] $ return ()+ sendAck = putOutput conn $ OutControl RTT1Level [] check 1 = (0, (1, True)) check n = (n + 1, (n, False)) @@ -204,10 +219,7 @@ ---------------------------------------------------------------- sendFrames :: Connection -> EncryptionLevel -> [Frame] -> IO ()-sendFrames conn lvl frames = putOutput conn $ OutControl lvl frames $ return ()--sendFramesLim :: Connection -> EncryptionLevel -> [Frame] -> IO ()-sendFramesLim conn lvl frames = putOutputLim conn $ OutControl lvl frames $ return ()+sendFrames conn lvl frames = putOutput conn $ OutControl lvl frames -- | Closing a connection with/without a transport error. -- Internal threads should use this.
Network/QUIC/Connection/Queue.hs view
@@ -1,24 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}+ module Network.QUIC.Connection.Queue where import Control.Concurrent.STM+import Network.Control (getRate) import Network.QUIC.Connection.Types-import Network.QUIC.Imports import Network.QUIC.Stream-import Network.QUIC.Types +----------------------------------------------------------------+ takeInput :: Connection -> IO Input takeInput conn = atomically $ readTQueue (inputQ conn) putInput :: Connection -> Input -> IO () putInput conn inp = atomically $ writeTQueue (inputQ conn) inp +----------------------------------------------------------------+ takeCrypto :: Connection -> IO Crypto takeCrypto conn = atomically $ readTQueue (cryptoQ conn) putCrypto :: Connection -> Crypto -> IO () putCrypto conn inp = atomically $ writeTQueue (cryptoQ conn) inp +isEmptyCryptoSTM :: Connection -> STM Bool+isEmptyCryptoSTM conn = isEmptyTQueue $ cryptoQ conn++----------------------------------------------------------------+ takeOutputSTM :: Connection -> STM Output takeOutputSTM conn = readTQueue (outputQ conn) @@ -31,17 +41,8 @@ putOutput :: Connection -> Output -> IO () putOutput conn out = atomically $ writeTQueue (outputQ conn) out -outputLimit :: Int-outputLimit = 10--putOutputLim :: Connection -> Output -> IO ()-putOutputLim conn out = atomically $ do- len <- fromIntegral <$> lengthTBQueue (outputQLim conn)- -- unless ok, the frames are intentionally dropped.- when (len < outputLimit) $ writeTBQueue (outputQLim conn) out--takeOutput1STM :: Connection -> STM Output-takeOutput1STM conn = readTBQueue (outputQLim conn)+isEmptyOutputSTM :: Connection -> STM Bool+isEmptyOutputSTM conn = isEmptyTQueue $ outputQ conn ---------------------------------------------------------------- @@ -57,10 +58,15 @@ putSendStreamQ :: Connection -> TxStreamData -> IO () putSendStreamQ conn out = atomically $ writeTQueue (sharedSendStreamQ $ shared conn) out +isEmptyStreamSTM :: Connection -> STM Bool+isEmptyStreamSTM conn = isEmptyTQueue $ sharedSendStreamQ $ shared conn+ ---------------------------------------------------------------- -readMigrationQ :: Connection -> IO ReceivedPacket-readMigrationQ conn = atomically $ readTQueue $ migrationQ conn+outputLimit :: Int+outputLimit = 10 -writeMigrationQ :: Connection -> ReceivedPacket -> IO ()-writeMigrationQ conn x = atomically $ writeTQueue (migrationQ conn) x+rateOK :: Connection -> IO Bool+rateOK conn = do+ rate <- getRate $ outputRate conn+ return $ rate < outputLimit
Network/QUIC/Connection/Role.hs view
@@ -20,6 +20,8 @@ getStopServer, setCertificateChain, getCertificateChain,+ setSockConnected,+ getSockConnected, ) where import qualified Crypto.Token as CT@@ -148,3 +150,16 @@ getCertificateChain :: Connection -> IO (Maybe CertificateChain) getCertificateChain Connection{..} = certChain <$> readIORef roleInfo++----------------------------------------------------------------++setSockConnected :: Connection -> Bool -> IO ()+setSockConnected Connection{..} b = atomicModifyIORef'' roleInfo $+ \ci -> ci{sockConnected = b}++getSockConnected :: Connection -> IO Bool+getSockConnected Connection{..} = do+ ri <- readIORef roleInfo+ case ri of+ ClientInfo{..} -> return sockConnected+ _ -> return False
Network/QUIC/Connection/State.hs view
@@ -21,6 +21,8 @@ getTxBytes, addRxBytes, getRxBytes,+ addPathTxBytes,+ addPathRxBytes, setAddressValidated, waitAntiAmplificationFree, checkAntiAmplificationFree,@@ -122,42 +124,48 @@ ---------------------------------------------------------------- addTxBytes :: Connection -> Int -> IO ()-addTxBytes Connection{..} n = atomically $ modifyTVar' bytesTx (+ n)+addTxBytes Connection{..} n = modifyIORef' bytesTx (+ n) getTxBytes :: Connection -> IO Int-getTxBytes Connection{..} = readTVarIO bytesTx+getTxBytes Connection{..} = readIORef bytesTx addRxBytes :: Connection -> Int -> IO ()-addRxBytes Connection{..} n = atomically $ modifyTVar' bytesRx (+ n)+addRxBytes Connection{..} n = modifyIORef' bytesRx (+ n) getRxBytes :: Connection -> IO Int-getRxBytes Connection{..} = readTVarIO bytesRx+getRxBytes Connection{..} = readIORef bytesRx +addPathTxBytes :: PathInfo -> Int -> IO ()+addPathTxBytes PathInfo{..} n = atomically $ modifyTVar' pathBytesTx (+ n)++addPathRxBytes :: PathInfo -> Int -> IO ()+addPathRxBytes PathInfo{..} n = atomically $ modifyTVar' pathBytesRx (+ n)+ ---------------------------------------------------------------- -setAddressValidated :: Connection -> IO ()-setAddressValidated Connection{..} = atomically $ writeTVar addressValidated True+setAddressValidated :: PathInfo -> IO ()+setAddressValidated PathInfo{..} = atomically $ writeTVar addressValidated True -- Three times rule for anti amplification-waitAntiAmplificationFree :: Connection -> Int -> IO ()-waitAntiAmplificationFree conn@Connection{..} siz = do- ok <- checkAntiAmplificationFree conn siz+waitAntiAmplificationFree :: Connection -> PathInfo -> Int -> IO ()+waitAntiAmplificationFree Connection{..} pathInfo siz = do+ ok <- checkAntiAmplificationFree pathInfo siz unless ok $ do beforeAntiAmp connLDCC- atomically (checkAntiAmplificationFreeSTM conn siz >>= check)+ atomically (checkAntiAmplificationFreeSTM pathInfo siz >>= check) -- setLossDetectionTimer is called eventually. -checkAntiAmplificationFreeSTM :: Connection -> Int -> STM Bool-checkAntiAmplificationFreeSTM Connection{..} siz = do+checkAntiAmplificationFreeSTM :: PathInfo -> Int -> STM Bool+checkAntiAmplificationFreeSTM PathInfo{..} siz = do validated <- readTVar addressValidated if validated then return True else do- tx <- readTVar bytesTx- rx <- readTVar bytesRx+ tx <- readTVar pathBytesTx+ rx <- readTVar pathBytesRx return (tx + siz <= 3 * rx) -checkAntiAmplificationFree :: Connection -> Int -> IO Bool-checkAntiAmplificationFree conn siz =- atomically $ checkAntiAmplificationFreeSTM conn siz+checkAntiAmplificationFree :: PathInfo -> Int -> IO Bool+checkAntiAmplificationFree pathInfo siz =+ atomically $ checkAntiAmplificationFreeSTM pathInfo siz
Network/QUIC/Connection/Types.hs view
@@ -17,7 +17,14 @@ import Data.X509 (CertificateChain) import Foreign.Marshal.Alloc import Foreign.Ptr (nullPtr)-import Network.Control (Rate, RxFlow, TxFlow, newRate, newRxFlow, newTxFlow)+import Network.Control (+ Rate,+ RxFlow,+ TxFlow,+ newRate,+ newRxFlow,+ newTxFlow,+ ) import Network.Socket (SockAddr, Socket) import Network.TLS.QUIC import System.Mem.Weak (Weak)@@ -45,6 +52,7 @@ { clientInitialToken :: Token -- new or retry token , resumptionInfo :: ResumptionInfo , incompatibleVN :: Bool+ , sockConnected :: Bool } | ServerInfo { tokenManager :: ~CT.TokenManager@@ -61,6 +69,7 @@ { clientInitialToken = emptyToken , resumptionInfo = defaultResumptionInfo , incompatibleVN = False+ , sockConnected = False } defaultServerRoleInfo :: RoleInfo@@ -81,6 +90,7 @@ , cidInfos :: IntMap CIDInfo , revInfos :: Map CID Int , nextSeqNum :: Int -- only for mine (new)+ , retirePriorTo :: Int , triggeredByMe :: Bool -- only for peer's } deriving (Show)@@ -92,6 +102,7 @@ , cidInfos = IntMap.singleton 0 cidInfo , revInfos = Map.singleton cid 0 , nextSeqNum = 1+ , retirePriorTo = 1 , triggeredByMe = False } where@@ -102,10 +113,17 @@ data MigrationState = NonMigration | MigrationStarted- | SendChallenge PathData+ | SendChallenge PathInfo PathData | RecvResponse- deriving (Eq, Show) +{- FOURMOLU_DISABLE -}+instance Eq MigrationState where+ NonMigration == NonMigration = True+ MigrationStarted == MigrationStarted = True+ RecvResponse == RecvResponse = True+ _ == _ = False+{- FOURMOLU_ENABLE -}+ ---------------------------------------------------------------- data Coder = Coder@@ -188,8 +206,22 @@ type Send = Buffer -> Int -> IO () type Recv = IO ReceivedPacket -data PeerInfo = PeerInfo SockAddr deriving (Eq, Show)+-- For migration, two SockAddr for the peer are contained.+data PeerInfo = PeerInfo+ { currPathInfo :: PathInfo+ , prevPathInfo :: Maybe PathInfo+ } +data PathInfo = PathInfo+ { peerSockAddr :: SockAddr+ , pathBytesTx :: TVar Int -- TVar for anti amplification+ , pathBytesRx :: TVar Int -- TVar for anti amplification+ , addressValidated :: TVar Bool+ }++newPathInfo :: SockAddr -> IO PathInfo+newPathInfo sa = PathInfo sa <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO False+ ---------------------------------------------------------------- -- | A quic connection to carry multiple streams.@@ -224,8 +256,7 @@ inputQ :: InputQ , cryptoQ :: CryptoQ , outputQ :: OutputQ- , outputQLim :: OutputQLim- , migrationQ :: MigrationQ+ , outputRate :: Rate , shared :: Shared , delayedAckCount :: IORef Int , delayedAckCancel :: IORef (IO ())@@ -239,10 +270,10 @@ , flowTx :: TVar TxFlow , flowRx :: IORef RxFlow , migrationState :: TVar MigrationState+ , sentRetirePriorTo :: IORef Bool , minIdleTimeout :: IORef Microseconds- , bytesTx :: TVar Int -- TVar for anti amplification- , bytesRx :: TVar Int -- TVar for anti amplification- , addressValidated :: TVar Bool+ , bytesTx :: IORef Int+ , bytesRx :: IORef Int , -- TLS pendingQ :: Array EncryptionLevel (TVar [ReceivedPacket]) , ciphers :: IOArray EncryptionLevel Cipher@@ -329,8 +360,7 @@ <*> newTQueueIO <*> newTQueueIO <*> return outQ- <*> newTBQueueIO 1- <*> newTQueueIO+ <*> newRate <*> newShared <*> newIORef 0 <*> newIORef (return ())@@ -344,10 +374,10 @@ <*> newTVarIO (newTxFlow 0) -- limit is set in Handshake <*> newIORef (newRxFlow $ initialMaxData myparams) <*> newTVarIO NonMigration+ <*> newIORef False <*> newIORef (milliToMicro $ maxIdleTimeout myparams)- <*> newTVarIO 0- <*> newTVarIO 0- <*> newTVarIO False+ <*> newIORef 0+ <*> newIORef 0 -- TLS <*> makePendingQ <*> newArray (InitialLevel, RTT1Level) defaultCipher@@ -425,15 +455,13 @@ data Crypto = InpHandshake EncryptionLevel ByteString deriving (Show) data Output- = OutControl EncryptionLevel [Frame] (IO ())+ = OutControl EncryptionLevel [Frame] | OutHandshake [(EncryptionLevel, ByteString)] | OutRetrans PlainPacket type InputQ = TQueue Input type CryptoQ = TQueue Crypto type OutputQ = TQueue Output-type OutputQLim = TBQueue Output-type MigrationQ = TQueue ReceivedPacket ----------------------------------------------------------------
Network/QUIC/Handshake.hs view
@@ -82,8 +82,7 @@ -- Sending ACKs for three times rule when ((n `mod` 3) == 1) $ sendCryptoData conn $- OutControl HandshakeLevel [] $- return ()+ OutControl HandshakeLevel [] return $ Right bs sendTLS :: Connection -> IORef HndState -> [(CryptLevel, ByteString)] -> IO ()@@ -267,6 +266,7 @@ when (maxUdpPayloadSize params < 1200) sendCCParamError when (ackDelayExponent params > 20) sendCCParamError when (maxAckDelay params >= 2 ^ (14 :: Int)) sendCCParamError+ when (activeConnectionIdLimit params < 2) sendCCParamError when (isServer conn) $ do when (isJust $ originalDestinationConnectionId params) sendCCParamError when (isJust $ preferredAddress params) sendCCParamError@@ -293,6 +293,8 @@ setPeerParameters conn params mapM_ (setPeerStatelessResetToken conn) $ statelessResetToken params setTxMaxData conn $ initialMaxData params+ -- My 'maxIdleTimeout' is already set 'minIdleTimeout'+ -- This selects the minimum of mine and peer's. setMinIdleTimeout conn $ milliToMicro $ maxIdleTimeout params setMaxAckDaley (connLDCC conn) $ milliToMicro $ maxAckDelay params setTxMaxStreams conn $ initialMaxStreamsBidi params@@ -311,6 +313,7 @@ setVersionInfo conn $ VersionInfo serverVer vers dcid <- getClientDstCID conn initializeCoder conn InitialLevel $ initialSecrets serverVer dcid+ qlogDebug conn $ Debug "Version changed" _ -> return () storeNegotiated :: Connection -> TLS.Context -> ApplicationSecretInfo -> IO ()
Network/QUIC/IO.hs view
@@ -213,7 +213,7 @@ setRxStreamClosed s lvl <- getEncryptionLevel conn let frame = ResetStream sid aerr 0- putOutput conn $ OutControl lvl [frame] $ return ()+ putOutput conn $ OutControl lvl [frame] delStream conn s -- | Asking the peer to stop sending.@@ -229,4 +229,4 @@ setRxStreamClosed s lvl <- getEncryptionLevel conn let frame = StopSending sid aerr- putOutput conn $ OutControl lvl [frame] $ return ()+ putOutput conn $ OutControl lvl [frame]
Network/QUIC/Info.hs view
@@ -14,7 +14,7 @@ sock <- getSocket conn -- fixme: this is undefined mysa <- NS.getSocketName sock- PeerInfo peersa <- getPeerInfo conn+ peersa <- peerSockAddr <$> getPathInfo conn mycid <- getMyCID conn peercid <- getPeerCID conn c <- getCipher conn RTT1Level
Network/QUIC/Packet/Frame.hs view
@@ -103,10 +103,10 @@ Bidirectional -> write8 wbuf 0x16 Unidirectional -> write8 wbuf 0x17 encodeInt' wbuf $ fromIntegral ms-encodeFrame wbuf (NewConnectionID cidInfo rpt) = do+encodeFrame wbuf (NewConnectionID cidInfo retirePriorTo) = do write8 wbuf 0x18 encodeInt' wbuf $ fromIntegral $ cidInfoSeq cidInfo- encodeInt' wbuf $ fromIntegral rpt+ encodeInt' wbuf $ fromIntegral retirePriorTo let (cid, len) = unpackCID $ cidInfoCID cidInfo write8 wbuf len copyShortByteString wbuf cid@@ -342,11 +342,11 @@ decodeNewConnectionID :: ReadBuffer -> IO Frame decodeNewConnectionID rbuf = do seqNum <- fromIntegral <$> decodeInt' rbuf- rpt <- fromIntegral <$> decodeInt' rbuf+ retirePriorTo <- fromIntegral <$> decodeInt' rbuf cidLen <- fromIntegral <$> read8 rbuf cID <- makeCID <$> extractShortByteString rbuf cidLen token <- StatelessResetToken <$> extractShortByteString rbuf 16- return $ NewConnectionID (newCIDInfo seqNum cID token) rpt+ return $ NewConnectionID (newCIDInfo seqNum cID token) retirePriorTo decodeRetireConnectionID :: ReadBuffer -> IO Frame decodeRetireConnectionID rbuf = do
Network/QUIC/Parameters.hs view
@@ -293,7 +293,7 @@ defaultParameters :: Parameters defaultParameters = baseParameters- { maxIdleTimeout = microToMilli idleTimeout -- 30000+ { maxIdleTimeout = idleTimeout -- 30000 , maxUdpPayloadSize = maximumUdpPayloadSize -- 2048 , initialMaxData = defaultMaxData -- !M , initialMaxStreamDataBidiLocal = defaultMaxStreamData -- 256K
Network/QUIC/Qlog.hs view
@@ -26,6 +26,7 @@ import qualified Data.ByteString.Short as Short import Data.List (intersperse) import System.Log.FastLogger+import Text.Printf import Network.QUIC.Imports import Network.QUIC.Parameters@@ -57,6 +58,14 @@ instance Qlog Header where qlog hdr = "{\"header\":{\"packet_type\":\"" <> packetType hdr <> "\"}}" +instance Qlog (Header, String) where+ qlog (hdr, str) =+ "{\"header\":{\"packet_type\":\""+ <> packetType hdr+ <> "\", \"trigger\":\""+ <> toLogStr str+ <> "\"}}"+ instance Qlog CryptPacket where qlog (CryptPacket hdr _) = qlog hdr @@ -139,6 +148,8 @@ <> sw (cidInfoCID cidinfo) <> "\",\"retire_prior_to\":\"" <> sw rpt+ <> "\",\"stateless_reset_token\":\""+ <> sw (cidInfoSRT cidinfo) <> "\"" frameExtra (RetireConnectionID sn) = ",\"sequence_number\":\"" <> sw sn <> "\"" frameExtra (PathChallenge _PathData) = ""@@ -309,7 +320,7 @@ {-# INLINE swtim #-} swtim :: TimeMicrosecond -> TimeMicrosecond -> LogStr-swtim tim base = toLogStr (show m ++ "." ++ show u)+swtim tim base = toLogStr (show m ++ "." ++ printf "%03d" u) where Microseconds x = elapsedTimeMicrosecond tim base (m, u) = x `divMod` 1000
Network/QUIC/Receiver.hs view
@@ -9,6 +9,7 @@ import qualified Data.ByteString as BS import Network.Control import Network.TLS (AlertDescription (..))+import System.Log.FastLogger import Network.QUIC.Config import Network.QUIC.Connection@@ -43,6 +44,7 @@ | isClient conn = "Client" | otherwise = "Server" msg = msg0 ++ " " ++ show st+ qlogDebug conn $ Debug "recv timeout" E.throwIO $ ConnectionIsTimeout msg Just x -> return x loopHandshake = do@@ -57,14 +59,23 @@ included <- myCIDsInclude conn cid case included of Just nseq -> do+ -- RFC 9000 Sec 5.1.1: If an endpoint provided fewer+ -- connection IDs than the peer's+ -- active_connection_id_limit, it MAY supply a new+ -- connection ID when it receives a packet with a+ -- previously unused connection ID. shouldUpdate <- shouldUpdateMyCID conn nseq- when shouldUpdate $ do+ capOK <- checkPeerCIDCapacity conn+ when (shouldUpdate && capOK) $ do setMyCID conn cid cidInfo <- getNewMyCID conn when (isServer conn) $ do register <- getRegister conn register (cidInfoCID cidInfo) conn- sendFrames conn RTT1Level [NewConnectionID cidInfo 0]+ sent <- readIORef (sentRetirePriorTo conn)+ writeIORef (sentRetirePriorTo conn) False+ unless sent $+ sendFrames conn RTT1Level [NewConnectionID cidInfo 0] processReceivedPacket conn rpkt shouldUpdatePeer <- if shouldUpdate@@ -72,7 +83,7 @@ else return False when shouldUpdatePeer $ choosePeerCIDForPrivacy conn _ -> do- qlogDropped conn hdr+ qlogDropped conn (hdr, "unknown_connection_id" :: String) connDebugLog conn $ bhow cid <> " is unknown" logAction msg = connDebugLog conn ("debug: receiver: " <> msg) @@ -89,7 +100,7 @@ putOffCrypto conn lvl rpkt when (isClient conn) $ do lvl' <- getEncryptionLevel conn- speedup (connLDCC conn) lvl' "not decryptable"+ speedup (connLDCC conn) lvl' ("not decryptable: " <> toLogStr (show lvl)) Just () | isClient conn -> do when (lvl == InitialLevel) $ do@@ -108,6 +119,7 @@ setVersion conn peerVer dcid <- getClientDstCID conn initializeCoder conn InitialLevel $ initialSecrets peerVer dcid+ qlogDebug conn $ Debug "Version changed" _ -> return () processReceivedPacket conn rpkt | otherwise -> do@@ -117,7 +129,7 @@ || (lvl == InitialLevel && mycid == headerMyCID hdr) ) $ do- setAddressValidated conn+ getPathInfo conn >>= setAddressValidated when (lvl == HandshakeLevel) $ do let ldcc = connLDCC conn discarded <- getAndSetPacketNumberSpaceDiscarded ldcc InitialLevel@@ -147,6 +159,8 @@ case mplain of Just plain@Plain{..} -> do addRxBytes conn $ rpReceivedBytes rpkt+ pathInfo <- getPathInfo conn+ addPathRxBytes pathInfo $ rpReceivedBytes rpkt when (isIllegalReservedBits plainMarks || isNoFrames plainMarks) $ closeConnection conn ProtocolViolation "Non 0 RR bits or no frames" when (isUnknownFrame plainMarks) $@@ -178,7 +192,7 @@ qlogDebug conn $ Debug "ping for speedup" sendFrames conn lvl [Ping] Nothing -> do- qlogDropped conn hdr+ qlogDropped conn (hdr, "decrypt_error" :: String) connDebugLog conn $ "debug: cannot decrypt: " <> bhow lvl@@ -239,14 +253,16 @@ setRxStreamClosed strm delStream conn strm processFrame conn lvl (StopSending sid err) = do- when (lvl == InitialLevel || lvl == HandshakeLevel) $- closeConnection conn ProtocolViolation "STOP_SENDING"- when (isReceiveOnly conn sid) $- closeConnection conn StreamStateError "Receive-only stream"- mstrm <- findStream conn sid- case mstrm of- Nothing -> streamNotCreatedYet conn sid "No such stream for STOP_SENDING"- Just _strm -> sendFramesLim conn lvl [ResetStream sid err 0]+ ok <- rateOK conn+ when ok $ do+ when (lvl == InitialLevel || lvl == HandshakeLevel) $+ closeConnection conn ProtocolViolation "STOP_SENDING"+ when (isReceiveOnly conn sid) $+ closeConnection conn StreamStateError "Receive-only stream"+ mstrm <- findStream conn sid+ case mstrm of+ Nothing -> streamNotCreatedYet conn sid "No such stream for STOP_SENDING"+ Just _strm -> sendFrames conn lvl [ResetStream sid err 0] processFrame _ _ (CryptoF _ "") = return () processFrame conn lvl (CryptoF off cdat) = do when (lvl == RTT0Level) $@@ -359,31 +375,75 @@ closeConnection conn ProtocolViolation "STREAMS_BLOCKED in Initial or Handshake" when (n > 2 ^ (60 :: Int)) $ closeConnection conn FrameEncodingError "Too large STREAMS_BLOCKED"-processFrame conn lvl (NewConnectionID cidInfo rpt) = do+processFrame conn lvl (NewConnectionID cidInfo retirePriorTo) = do when (lvl == InitialLevel || lvl == HandshakeLevel) $ closeConnection conn ProtocolViolation "NEW_CONNECTION_ID in Initial or Handshake"- ok <- addPeerCID conn cidInfo- unless ok $- closeConnection conn ConnectionIdLimitError "NEW_CONNECTION_ID limit error"- let (_, cidlen) = unpackCID $ cidInfoCID cidInfo- when (cidlen < 1 || 20 < cidlen || rpt > cidInfoSeq cidInfo) $- closeConnection conn FrameEncodingError "NEW_CONNECTION_ID parameter error"- when (rpt >= 1) $ do- seqNums <- setPeerCIDAndRetireCIDs conn rpt- sendFramesLim conn RTT1Level $ map RetireConnectionID seqNums+ ok <- rateOK conn+ when ok $ do+ let (_, cidlen) = unpackCID $ cidInfoCID cidInfo+ seqNum = cidInfoSeq cidInfo+ when (cidlen < 1 || 20 < cidlen || retirePriorTo > seqNum) $+ closeConnection conn FrameEncodingError "NEW_CONNECTION_ID parameter error"+ -- Retiring CIDs first then add a new CID.+ --+ -- RFC 9000 Sec 5.1.1 says:+ -- An endpoint MAY send connection IDs that temporarily exceed a+ -- peer's limit if the NEW_CONNECTION_ID frame also requires the+ -- retirement of any excess, by including a sufficiently large+ -- value in the Retire Prior To field.+ prevRetirePriorTo <- getPeerRetirePriorTo conn+ -- RFC 900 Sec 19.15 says:+ -- Once a sender indicates a Retire Prior To value, smaller values+ -- sent in subsequent NEW_CONNECTION_ID frames have no effect. A+ -- receiver MUST ignore any Retire Prior To fields that do not+ -- increase the largest received Retire Prior To value.+ when (retirePriorTo >= prevRetirePriorTo) $ do+ -- RFC 9000 Sec 5.1.2 says:+ -- Upon receipt of an increased Retire Prior To field, the+ -- peer MUST stop using the corresponding connection IDs and+ -- retire them with RETIRE_CONNECTION_ID frames before adding+ -- the newly provided connection ID to the set of active+ -- connection IDs.+ seqNums <- setPeerCIDAndRetireCIDs conn retirePriorTo -- upadting RPT+ sendFrames conn RTT1Level $ map RetireConnectionID seqNums+ -- Adding a new CID+ if seqNum < prevRetirePriorTo+ then+ -- RFC 9000 Sec 19.15 says:+ -- An endpoint that receives a NEW_CONNECTION_ID frame+ -- with a sequence number smaller than the Retire Prior To+ -- field of a previously received NEW_CONNECTION_ID frame+ -- MUST send a corresponding RETIRE_CONNECTION_ID frame+ -- that retires the newly received connection ID, unless+ -- it has already done so for that sequence number.+ sendFrames conn RTT1Level [RetireConnectionID seqNum]+ else do+ ng <- not <$> addPeerCID conn cidInfo+ when ng $+ closeConnection conn ConnectionIdLimitError "NEW_CONNECTION_ID limit error" processFrame conn RTT1Level (RetireConnectionID sn) = do+ -- FIXME: CID is necessary here+ -- The sequence number specified in a RETIRE_CONNECTION_ID frame+ -- MUST NOT refer to the Destination Connection ID field of the+ -- packet in which the frame is contained. The peer MAY treat this+ -- as a connection error of type PROTOCOL_VIOLATION. mcidInfo <- retireMyCID conn sn case mcidInfo of Nothing -> return () Just cidInfo -> do+ -- Don't send NewConnectionID since we don't know it is+ -- ping or pong. If this is a pong, NewConnectionID should+ -- not be send back. Instead, loopEstablished sends it+ -- when CID is changed. when (isServer conn) $ do unregister <- getUnregister conn unregister $ cidInfoCID cidInfo-processFrame conn RTT1Level (PathChallenge dat) =- sendFramesLim conn RTT1Level [PathResponse dat]+processFrame conn RTT1Level (PathChallenge dat) = do+ ok <- rateOK conn+ when ok $ sendFrames conn RTT1Level [PathResponse dat] processFrame conn RTT1Level (PathResponse dat) = -- RTT0Level falls intentionally checkResponse conn dat
Network/QUIC/Recovery/Release.hs view
@@ -49,9 +49,7 @@ mr <- atomicModifyIORef' (sentPackets ! lvl) oldest case mr of Nothing -> return ()- Just spkt -> do- delPeerPacketNumbers ldcc lvl $ spPacketNumber spkt- decreaseCC ldcc [spkt]+ Just spkt -> decreaseCC ldcc [spkt] return mr where oldest (SentPackets db) = case Seq.viewl db2 of
Network/QUIC/Recovery/Types.hs view
@@ -274,6 +274,7 @@ arr = array (InitialLevel, RTT1Level) lst return arr +-- Loss Detection and Congestion Control data LDCC = LDCC { ldccState :: ConnState , ldccQlogger :: QLogger@@ -408,7 +409,7 @@ packetNumberSpace RTT1Level = "application_data" delta :: Microseconds -> LogStr-delta (Microseconds n) = sw n+delta (Microseconds n) = sw (n `div` 1000) qlogSent :: (KeepQlog q, Qlog pkt) => q -> pkt -> TimeMicrosecond -> IO () qlogSent q pkt tim = keepQlog q $ QSent (qlog pkt) tim
Network/QUIC/Sender.hs view
@@ -57,10 +57,13 @@ when (isJust mx) $ qlogDebug conn $ Debug "probe new" (sentPackets, leftsiz) <- buildPackets buf0 bufsiz0 maxSiz spkts0 id let bytes = bufsiz0 - leftsiz- when (isServer conn) $ waitAntiAmplificationFree conn bytes+ pathInfo <- getPathInfo conn+ when (isServer conn) $+ waitAntiAmplificationFree conn pathInfo bytes now <- getTimeMicrosecond connSend conn buf0 bytes addTxBytes conn bytes+ addPathTxBytes pathInfo bytes forM_ sentPackets $ \sentPacket0 -> do let sentPacket = sentPacket0{spTimeSent = now} qlogSent conn sentPacket now@@ -92,11 +95,12 @@ sendPingPacket :: Connection -> EncryptionLevel -> IO () sendPingPacket conn lvl = do+ pathInfo <- getPathInfo conn maxSiz <- getMaxPacketSize conn ok <- if isClient conn then return True- else checkAntiAmplificationFree conn maxSiz+ else checkAntiAmplificationFree pathInfo maxSiz when ok $ do let ldcc = connLDCC conn mp <- releaseOldest ldcc lvl@@ -108,7 +112,7 @@ qlogDebug conn $ Debug "probe old" let PlainPacket _ plain0 = spPlainPacket spkt adjustForRetransmit conn $ plainFrames plain0- xs <- construct conn lvl frames+ xs <- construct conn lvl frames False if null xs then qlogDebug conn $ Debug "ping NULL" else do@@ -120,6 +124,7 @@ now <- getTimeMicrosecond connSend conn buf bytes addTxBytes conn bytes+ addPathTxBytes pathInfo bytes let sentPacket0 = fixSentPacket spkt bytes padlen sentPacket = sentPacket0{spTimeSent = now} qlogSent conn sentPacket now@@ -131,14 +136,15 @@ :: Connection -> EncryptionLevel -> [Frame]+ -> Bool -> IO [SentPacket]-construct conn lvl frames = do+construct conn lvl frames multilevel = do discarded <- getPacketNumberSpaceDiscarded ldcc lvl if discarded then return [] else do established <- isConnectionEstablished conn- if established || (isServer conn && lvl == HandshakeLevel)+ if established || multilevel then do constructTargetPacket else do@@ -229,7 +235,6 @@ atomically ( (SwPing <$> takePingSTM (connLDCC conn)) `orElse` (SwOut <$> takeOutputSTM conn)- `orElse` (SwOut <$> takeOutput1STM conn) `orElse` (SwStrm <$> takeSendStreamQSTM conn) ) case x of@@ -263,10 +268,22 @@ | otherwise = return () sendOutput :: Connection -> Output -> IO ()-sendOutput conn (OutControl lvl frames action) = do- construct conn lvl frames >>= sendPacket conn+sendOutput conn (OutControl RTT1Level []) = do+ exist <- atomically $ do+ b1 <- not <$> isEmptyCryptoSTM conn+ b2 <- not <$> isEmptyOutputSTM conn+ b3 <- not <$> isEmptyStreamSTM conn+ return $ or [b1, b2, b3]+ unless exist $ construct conn RTT1Level [] False >>= sendPacket conn+sendOutput conn (OutControl lvl frames) = do+ mout <- tryPeekOutput conn+ case mout of+ Just (OutControl lvl' frames')+ | lvl == lvl' -> do+ construct conn lvl (frames ++ frames') False >>= sendPacket conn+ void $ atomically $ takeOutputSTM conn+ _ -> construct conn lvl frames False >>= sendPacket conn when (lvl == HandshakeLevel) $ discardClientInitialPacketNumberSpace conn- action sendOutput conn (OutHandshake lcs0) = do let convert = onTLSHandshakeCreated $ connHooks conn (lcs, wait) = convert lcs0@@ -278,7 +295,7 @@ sendOutput conn (OutRetrans (PlainPacket hdr0 plain0)) = do frames <- adjustForRetransmit conn $ plainFrames plain0 let lvl = levelFromHeader hdr0- construct conn lvl frames >>= sendPacket conn+ construct conn lvl frames False >>= sendPacket conn levelFromHeader :: Header -> EncryptionLevel levelFromHeader hdr@@ -320,6 +337,7 @@ sendCryptoFragments conn lcs = do loop limitationC id lcs where+ multilevel = length lcs >= 2 loop :: Int -> ([SentPacket] -> [SentPacket])@@ -331,21 +349,22 @@ loop len0 build0 ((lvl, bs) : xs) | BS.length bs > len0 = do let (target, rest) = BS.splitAt len0 bs frame1 <- cryptoFrame conn target lvl- spkts1 <- construct conn lvl [frame1]+ spkts1 <- construct conn lvl [frame1] multilevel sendPacket conn $ build0 spkts1- loop limitationC id ((lvl, rest) : xs)+ -- to calculate multilevel again, let's call sendCryptoFragments+ sendCryptoFragments conn ((lvl, rest) : xs) loop _ build0 [(lvl, bs)] = do frame1 <- cryptoFrame conn bs lvl- spkts1 <- construct conn lvl [frame1]+ spkts1 <- construct conn lvl [frame1] multilevel sendPacket conn $ build0 spkts1 loop len0 build0 ((lvl, bs) : xs) | len0 - BS.length bs < thresholdC = do frame1 <- cryptoFrame conn bs lvl- spkts1 <- construct conn lvl [frame1]+ spkts1 <- construct conn lvl [frame1] multilevel sendPacket conn $ build0 spkts1 loop limitationC id xs loop len0 build0 ((lvl, bs) : xs) = do frame1 <- cryptoFrame conn bs lvl- spkts1 <- construct conn lvl [frame1]+ spkts1 <- construct conn lvl [frame1] multilevel let len1 = len0 - BS.length bs build1 = build0 . (spkts1 ++) loop len1 build1 xs@@ -387,7 +406,7 @@ let lvl | ready = RTT1Level | otherwise = RTT0Level- construct conn lvl frames >>= sendPacket conn+ construct conn lvl frames False >>= sendPacket conn mapM_ syncFinTx streams where tryPeek = do@@ -449,7 +468,7 @@ let lvl | ready = RTT1Level | otherwise = RTT0Level- construct conn lvl [frame] >>= sendPacket conn+ construct conn lvl [frame] False >>= sendPacket conn loop dats2 -- Typical case: [3, 1024, 1024, 1024, 200]
Network/QUIC/Server/Reader.hs view
@@ -29,9 +29,10 @@ import Network.ByteOrder import Network.Control (LRUCacheRef, Rate, getRate, newRate) import qualified Network.Control as LRUCache-import Network.Socket (Socket, waitReadSocketSTM)+import Network.Socket (SockAddr, Socket, waitReadSocketSTM) import qualified Network.Socket.ByteString as NSB import qualified System.IO.Error as E+import System.Log.FastLogger import System.Random (getStdRandom, randomRIO, uniformByteString) import Network.QUIC.Common@@ -43,6 +44,7 @@ import Network.QUIC.Logger import Network.QUIC.Packet import Network.QUIC.Parameters+import Network.QUIC.Qlog import Network.QUIC.Types import Network.QUIC.Windows @@ -122,7 +124,7 @@ , accMyAuthCIDs :: AuthCIDs , accPeerAuthCIDs :: AuthCIDs , accMySocket :: Socket- , accPeerInfo :: PeerInfo+ , accPeerSockAddr :: SockAddr , accRecvQ :: RecvQ , accPacketSize :: Int , accRegister :: CID -> Connection -> IO ()@@ -176,8 +178,7 @@ quicBit = greaseQuicBit $ scParameters conf cpckts <- decodeCryptPackets bs (not quicBit) let bytes = BS.length bs- peerInfo = PeerInfo peersa- switch = dispatch d conf forkConnection logAction mysock peerInfo send' bytes now+ switch = dispatch d conf forkConnection logAction mysock peersa send' bytes now mapM_ switch cpckts loop wait @@ -212,7 +213,7 @@ -> (Accept -> IO ()) -> DebugLogger -> Socket- -> PeerInfo+ -> SockAddr -> (ByteString -> IO ()) -> Int -> TimeMicrosecond@@ -224,13 +225,13 @@ forkConnection logAction mysock- peerInfo+ peersa send' bytes tim (cpkt@(CryptPacket (Initial peerVer dCID sCID token) _), lvl, siz) | bytes < defaultQUICPacketSize = do- logAction $ "too small " <> bhow bytes <> ", " <> bhow peerInfo+ logAction $ "too small " <> bhow bytes <> ", " <> bhow peersa | peerVer `notElem` myVersions = do let offerVersions | peerVer == GreasingVersion = GreasingVersion2 : myVersions@@ -273,7 +274,7 @@ , accMyAuthCIDs = myAuthCIDs , accPeerAuthCIDs = peerAuthCIDs , accMySocket = mysock- , accPeerInfo = peerInfo+ , accPeerSockAddr = peersa , accRecvQ = q , accPacketSize = bytes , accRegister = reg@@ -354,7 +355,7 @@ _ _ _mysock- _peerInfo+ _peersa _ _ tim@@ -370,7 +371,7 @@ _ logAction mysock- peerInfo+ peersa send' bytes tim@@ -389,12 +390,21 @@ let srt = genStatelessReset dCID statelessReset = BS.concat [BS.singleton flag, body, fromStatelessResetToken srt] send' statelessReset- logAction $ "Stateless reset is sent to " <> bhow peerInfo+ logAction $ "Stateless reset is sent to " <> bhow peersa Just conn -> do alive <- getAlive conn when alive $ do- void $ setSocket conn mysock- setPeerInfo conn peerInfo+ void $ setSocket conn mysock -- fixme+ curCID <- getMyCID conn+ -- setMyCID is not called here since setMyCID is+ -- done in Receiver.+ let cidChanged = curCID /= dCID+ mPathInfo <- findPathInfo conn peersa+ case mPathInfo of+ Nothing -> do+ forkManaged conn $+ onClientMigration conn dCID peersa cidChanged+ _ -> return () writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl ---------------------------------------------------------------- dispatch@@ -403,7 +413,7 @@ _ logAction mysock- peerInfo+ peersa _ _ tim@@ -411,11 +421,35 @@ let dCID = headerMyCID hdr mconn <- lookupConnectionDict dstTable dCID case mconn of- Nothing -> logAction $ "CID no match: " <> bhow dCID <> ", " <> bhow peerInfo+ Nothing -> logAction $ "CID no match: " <> bhow dCID <> ", " <> bhow peersa Just conn -> do+ -- fixme: is this block necessary? void $ setSocket conn mysock- setPeerInfo conn peerInfo+ mPathInfo <- findPathInfo conn peersa+ when (isNothing mPathInfo) $ do+ pathInfo <- newPathInfo peersa+ addPathInfo conn pathInfo writeRecvQ (connRecvQ conn) $ mkReceivedPacket cpkt tim siz lvl recvServer :: RecvQ -> IO ReceivedPacket recvServer = readRecvQ++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+ where+ logAction msg = connDebugLog conn ("debug: onClientMigration: " <> msg)
Network/QUIC/Server/Run.hs view
@@ -156,11 +156,12 @@ -> IO ConnRes createServerConnection conf@ServerConfig{..} dispatch Accept{..} stvar = do sref <- newIORef accMySocket- piref <- newIORef accPeerInfo+ pathInfo <- newPathInfo accPeerSockAddr+ piref <- newIORef $ PeerInfo pathInfo Nothing let send buf siz = void $ do sock <- readIORef sref- PeerInfo sa <- readIORef piref- NS.sendBufTo sock buf siz sa+ PeerInfo pinfo _ <- readIORef piref+ NS.sendBufTo sock buf siz $ peerSockAddr pinfo recv = recvServer accRecvQ let myCID = fromJust $ initSrcCID accMyAuthCIDs ocid = fromJust $ origDstCID accMyAuthCIDs@@ -188,14 +189,14 @@ ver = chosenVersion accVersionInfo initializeCoder conn InitialLevel $ initialSecrets ver cid setupCryptoStreams conn -- fixme: cleanup- let PeerInfo peersa = accPeerInfo+ let peersa = accPeerSockAddr pktSiz = (defaultPacketSize peersa `max` accPacketSize) `min` maximumPacketSize peersa setMaxPacketSize conn pktSiz setInitialCongestionWindow (connLDCC conn) pktSiz debugLog $ "Packet size: " <> bhow pktSiz <> " (" <> bhow accPacketSize <> ")"- when accAddressValidated $ setAddressValidated conn+ when accAddressValidated $ setAddressValidated pathInfo -- let retried = isJust $ retrySrcCID accMyAuthCIDs when retried $ do
Network/QUIC/Types.hs view
@@ -30,5 +30,21 @@ import Network.QUIC.Types.Resumption import Network.QUIC.Types.Time +{-+import Foreign.Ptr+import Foreign.Storable+import System.IO.Unsafe+import Text.Printf++instance Show SizedBuffer where+ show (SizedBuffer ptr _) = unsafePerformIO $ loop 0 id+ where+ loop 16 b = return $ b []+ loop n b = do+ x <- peek (ptr `plusPtr` n) :: IO Word8+ let b' = b . (printf "%02x " x ++)+ loop (n + 1) b'+-}+ type Close = IO () data SizedBuffer = SizedBuffer Buffer BufferSize
Network/QUIC/Types/CID.hs view
@@ -59,7 +59,10 @@ len = fromIntegral $ Short.length sbs -- 16 bytes-newtype StatelessResetToken = StatelessResetToken Bytes deriving (Eq, Ord, Show)+newtype StatelessResetToken = StatelessResetToken Bytes deriving (Eq, Ord)++instance Show StatelessResetToken where+ show (StatelessResetToken srt) = shortToString (enc16s srt) fromStatelessResetToken :: StatelessResetToken -> ByteString fromStatelessResetToken (StatelessResetToken srt) = Short.fromShort srt
Network/QUIC/Types/Constants.hs view
@@ -27,5 +27,5 @@ ---------------------------------------------------------------- -idleTimeout :: Microseconds-idleTimeout = Microseconds 30000000+idleTimeout :: Milliseconds+idleTimeout = Milliseconds 30000
+ cbits/sysevent.c view
@@ -0,0 +1,72 @@+#include <sys/socket.h>+#include <sys/types.h>+#include <unistd.h>++#if defined(OS_MacOS)+#include <sys/ioctl.h>+#include <sys/kern_event.h>++int open_socket () {+ struct kev_request filter = { 0 };++ int s = socket(PF_SYSTEM, SOCK_RAW, SYSPROTO_EVENT);++ filter.vendor_code = KEV_VENDOR_APPLE;+ filter.kev_class = KEV_NETWORK_CLASS;+ filter.kev_subclass = KEV_DL_SUBCLASS;+ ioctl(s, SIOCSKEVFILT, &filter);++ return s;+}++int watch_socket(int s) {+ struct kern_event_msg msg;+ int ret = recv(s, &msg, sizeof(msg), 0);+ if (ret < 0) {+ return -1;+ } else {+ return 0;+ }+}++int close_socket (int s) {+ int ret = close(s);+ return ret;+}+#elif defined(OS_Linux)+#include <linux/netlink.h>+#include <linux/rtnetlink.h>++int open_socket () {+ struct sockaddr_nl filter = { 0 };++ int s = socket(AF_NETLINK, SOCK_DGRAM, NETLINK_ROUTE);++ filter.nl_family = AF_NETLINK;+ filter.nl_groups = RTMGRP_IPV4_ROUTE | RTMGRP_IPV6_ROUTE;+ bind(s, (struct sockaddr *)&filter, sizeof(filter));++ return s;+}++int watch_socket(int s) {+ char msg[4096] = {0};+ int ret = recv(s, msg, sizeof(msg), 0);+ if (ret < 0) {+ return -1;+ } else {+ return 0;+ }+}++int close_socket (int s) {+ int ret = close(s);+ return ret;+}+#else+int open_socket () { return 0; }++int watch_socket(int s) { return -2; }++int close_socket (int s) { return 0; }+#endif
quic.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: quic-version: 0.2.9+version: 0.2.10 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp@@ -37,6 +37,7 @@ Network.QUIC.Internal Network.QUIC.Server + c-sources: cbits/sysevent.c other-modules: Network.QUIC.Client.Reader Network.QUIC.Client.Run@@ -128,29 +129,35 @@ ghc-options: -Wall -Wcompat build-depends: base >=4.9 && <5,- array >= 0.5 && < 0.6,+ array >=0.5 && <0.6, async,- base16-bytestring >= 1.0 && < 1.1,- bytestring >= 0.10,+ base16-bytestring >=1.0 && <1.1,+ bytestring >=0.10, containers,- crypto-token >= 0.1.2 && < 0.2,- crypton >= 0.34,- crypton-x509 >= 1.7.6 && < 1.8,- crypton-x509-system >= 1.6.7 && < 1.7,+ crypto-token >=0.1.2 && <0.2,+ crypton >=0.34,+ crypton-x509 >=1.7.6 && <1.8,+ crypton-x509-system >=1.6.7 && <1.7, data-default,- fast-logger >= 3.2.2 && < 3.3,+ fast-logger >=3.2.2 && <3.3, filepath,- iproute >= 1.7.12 && < 1.8,- memory >= 0.18.0 && < 0.19,- network >= 3.2.3,- network-byte-order >= 0.1.7 && < 0.2,- network-control >= 0.1.5 && < 0.2,- random >= 1.3 && < 1.4,+ iproute >=1.7.12 && <1.8,+ memory >=0.18.0 && <0.19,+ network >=3.2.3,+ network-byte-order >=0.1.7 && <0.2,+ network-control >=0.1.5 && <0.2,+ random >=1.3 && <1.4, serialise,- stm >= 2.5 && < 2.6,- tls >= 2.1.6 && < 2.2,- unix-time >= 0.4.12 && < 0.5+ stm >=2.5 && <2.6,+ tls >=2.1.6 && <2.2,+ unix-time >=0.4.12 && <0.5 + if os(linux)+ cc-options: -DOS_Linux++ if os(osx)+ cc-options: -DOS_MacOS+ if os(windows) cc-options: -D_WINDOWS @@ -181,7 +188,7 @@ network-byte-order, quic, tls,- tls-session-manager >= 0.0.5+ tls-session-manager >=0.0.5 if flag(devel)
test/Config.hs view
@@ -16,6 +16,7 @@ import qualified Control.Exception as E import Control.Monad import Data.ByteString (ByteString)+import qualified Data.ByteString as BS import Data.IORef import qualified Data.List as L import qualified Data.List.NonEmpty as NE@@ -43,6 +44,10 @@ defaultServerConfig { -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug) scAddresses = [("127.0.0.1", 50003)]+ , scParameters =+ (scParameters defaultServerConfig)+ { maxIdleTimeout = Milliseconds 10000+ } } makeTestServerConfigR :: IO ServerConfig@@ -62,6 +67,10 @@ defaultServerConfig { -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug) scAddresses = [("127.0.0.1", 50003)]+ , scParameters =+ (scParameters defaultServerConfig)+ { maxIdleTimeout = Milliseconds 10000+ } } testClientConfig :: ClientConfig@@ -71,6 +80,10 @@ , ccPortName = "50003" , ccValidate = False , ccDebugLog = True+ , ccParameters =+ (ccParameters defaultClientConfig)+ { maxIdleTimeout = Milliseconds 10000+ } } testClientConfigR :: ClientConfig@@ -80,6 +93,10 @@ , ccPortName = "50002" , ccValidate = False , ccDebugLog = True+ , ccParameters =+ (ccParameters defaultClientConfig)+ { maxIdleTimeout = Milliseconds 10000+ } } setServerQlog :: ServerConfig -> ServerConfig@@ -115,18 +132,18 @@ dropPacket0 <- shouldDrop scenario True n0 unless dropPacket0 $ void $ send sockS bs forever $ do- bs1 <-- recv sockC 2048+ bs1 <- recv sockC 2048 n <- atomicModifyIORef' irefC $ \x -> (x + 1, x) dropPacket <- shouldDrop scenario True n- unless dropPacket $ void $ send sockS bs1+ let isCC = BS.length bs1 < 200+ when (isCC || not dropPacket) $ void $ send sockS bs1 -- from server tid1 <- forkIO $ forever $ do- bs <-- recv sockS 2048+ bs <- recv sockS 2048 n <- atomicModifyIORef' irefS $ \x -> (x + 1, x) dropPacket <- shouldDrop scenario False n- unless dropPacket $ void $ send sockC bs+ let isCC = BS.length bs < 200+ when (isCC || not dropPacket) $ void $ send sockC bs body killThread tid0 killThread tid1
test/PacketSpec.hs view
@@ -49,7 +49,8 @@ (sock, peersa) <- clientSocket "127.0.0.1" "2000" q <- newRecvQ sref <- newIORef sock- piref <- newIORef $ PeerInfo peersa+ pathInfo <- newPathInfo peersa+ piref <- newIORef $ PeerInfo pathInfo Nothing let ver = v verInfo = VersionInfo ver [ver] genSRT <- makeGenStatelessReset
util/quic-client.hs view
@@ -44,6 +44,7 @@ , optPacketSize :: Maybe Int , optPerformance :: Word64 , optNumOfReqs :: Int+ , optSockConnected :: Bool } deriving (Show) @@ -67,6 +68,7 @@ , optPacketSize = Nothing , optPerformance = 0 , optNumOfReqs = 1+ , optSockConnected = False } usage :: String@@ -158,12 +160,12 @@ ['B'] ["nat-rebinding"] (NoArg (\o -> o{optMigration = Just NATRebinding}))- "use a new local port"+ "use a new client port" , Option ['A'] ["address-mobility"] (NoArg (\o -> o{optMigration = Just ActiveMigration}))- "use a new address and a new server CID"+ "use a new client address and a new server CID" , Option ['t'] ["performance"]@@ -174,6 +176,11 @@ ["number-of-requests"] (ReqArg (\n o -> o{optNumOfReqs = read n}) "<n>") "specify the number of requests"+ , Option+ ['m']+ ["use-connected-socket"]+ (NoArg (\o -> o{optSockConnected = True}))+ "use connected sockets instead of unconnected sockets" ] showUsageAndExit :: String -> IO a@@ -232,6 +239,8 @@ defaultHooks { onCloseCompleted = putMVar cmvar () }+ , ccSockConnected = optSockConnected+ , ccWatchDog = optSockConnected } debug | optDebugLog = putStrLn