diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ +## 0.1.9 + +- Using the network-control package. +- Rate control for some frames. +- Announcing MaxStreams correctly. + ## 0.1.8 - Announcing MaxStreams properly. diff --git a/Network/QUIC.hs b/Network/QUIC.hs --- a/Network/QUIC.hs +++ b/Network/QUIC.hs @@ -4,47 +4,75 @@ -- -- The -threaded option must be specified to GHC to use this library. module Network.QUIC ( - -- * Connection - Connection - , abortConnection - -- * Stream - , Stream - , StreamId - , streamId - -- ** Category - , isClientInitiatedBidirectional - , isServerInitiatedBidirectional - , isClientInitiatedUnidirectional - , isServerInitiatedUnidirectional - -- ** Opening - , stream - , unidirectionalStream - , acceptStream - -- ** Closing - , closeStream - , shutdownStream - , resetStream - , stopStream - -- * IO - , recvStream - , sendStream - , sendStreamMany - -- * Information - , ConnectionInfo(..) - , getConnectionInfo - -- * Statistics - , ConnectionStats(..) - , getConnectionStats - -- * Synchronization - , wait0RTTReady - , wait1RTTReady - , waitEstablished - -- * Exceptions and Errors - , QUICException(..) - , TransportError(.., NoError, InternalError, ConnectionRefused, FlowControlError, StreamLimitError, StreamStateError, FinalSizeError, FrameEncodingError, TransportParameterError, ConnectionIdLimitError, ProtocolViolation, InvalidToken, ApplicationError, CryptoBufferExceeded, KeyUpdateError, AeadLimitReached, NoViablePath) - , cryptoError - , ApplicationProtocolError(..) - ) where + -- * Connection + Connection, + abortConnection, + + -- * Stream + Stream, + StreamId, + streamId, + + -- ** Category + isClientInitiatedBidirectional, + isServerInitiatedBidirectional, + isClientInitiatedUnidirectional, + isServerInitiatedUnidirectional, + + -- ** Opening + stream, + unidirectionalStream, + acceptStream, + + -- ** Closing + closeStream, + shutdownStream, + resetStream, + stopStream, + + -- * IO + recvStream, + sendStream, + sendStreamMany, + + -- * Information + ConnectionInfo (..), + getConnectionInfo, + + -- * Statistics + ConnectionStats (..), + getConnectionStats, + + -- * Synchronization + wait0RTTReady, + wait1RTTReady, + waitEstablished, + + -- * Exceptions and Errors + QUICException (..), + TransportError ( + .., + NoError, + InternalError, + ConnectionRefused, + FlowControlError, + StreamLimitError, + StreamStateError, + FinalSizeError, + FrameEncodingError, + TransportParameterError, + ConnectionIdLimitError, + ProtocolViolation, + InvalidToken, + ApplicationError, + CryptoBufferExceeded, + KeyUpdateError, + AeadLimitReached, + NoViablePath + ), + cryptoError, + ApplicationProtocolError (..), +) where import Network.QUIC.Connection import Network.QUIC.IO diff --git a/Network/QUIC/Client.hs b/Network/QUIC/Client.hs --- a/Network/QUIC/Client.hs +++ b/Network/QUIC/Client.hs @@ -2,30 +2,33 @@ -- When a new better network interface is up, -- migration is done automatically. module Network.QUIC.Client ( - -- * Running a QUIC client - run - -- * Configration - , ClientConfig - , defaultClientConfig - , ccServerName - , ccPortName - , ccALPN - , ccUse0RTT - , ccResumption - , ccCiphers - , ccGroups - , ccVersions --- , ccCredentials - , ccValidate - , ccAutoMigration - -- * Resumption - , ResumptionInfo - , getResumptionInfo - , isResumptionPossible - , is0RTTPossible - -- * Migration - , migrate - ) where + -- * Running a QUIC client + run, + + -- * Configration + ClientConfig, + defaultClientConfig, + ccServerName, + ccPortName, + ccALPN, + ccUse0RTT, + ccResumption, + ccCiphers, + ccGroups, + ccVersions, + -- , ccCredentials + ccValidate, + ccAutoMigration, + + -- * Resumption + ResumptionInfo, + getResumptionInfo, + isResumptionPossible, + is0RTTPossible, + + -- * Migration + migrate, +) where import Network.QUIC.Client.Run import Network.QUIC.Config diff --git a/Network/QUIC/Client/Reader.hs b/Network/QUIC/Client/Reader.hs --- a/Network/QUIC/Client/Reader.hs +++ b/Network/QUIC/Client/Reader.hs @@ -1,13 +1,12 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.QUIC.Client.Reader ( - readerClient - , recvClient - , ConnectionControl(..) - , controlConnection - ) where + readerClient, + recvClient, + ConnectionControl (..), + controlConnection, +) where import Data.List (intersect) import Network.Socket (getSocketName) @@ -25,9 +24,6 @@ import Network.QUIC.Qlog import Network.QUIC.Recovery import Network.QUIC.Types -#if defined(mingw32_HOST_OS) -import Network.QUIC.Windows -#endif -- | readerClient dies when the socket is closed. readerClient :: UDPSocket -> Connection -> IO () @@ -44,32 +40,30 @@ wait loop = do ito <- readMinIdleTimeout conn - mbs <- timeout ito "readeClient" $ -#if defined(mingw32_HOST_OS) - windowsThreadBlockHack $ -#endif - recv cs0 + mbs <- + timeout ito "readeClient" $ + recv cs0 case mbs of - Nothing -> close cs0 - Just bs -> do - now <- getTimeMicrosecond - pkts <- decodePackets bs - mapM_ (putQ now) pkts - loop + Nothing -> close cs0 + Just bs -> do + now <- getTimeMicrosecond + pkts <- decodePackets bs + mapM_ (putQ now) pkts + loop logAction msg = connDebugLog conn ("debug: readerClient: " <> msg) putQ _ (PacketIB BrokenPacket) = return () putQ t (PacketIV pkt@(VersionNegotiationPacket dCID sCID peerVers)) = do qlogReceived conn pkt t myVerInfo <- getVersionInfo conn - let myVer = chosenVersion myVerInfo + let myVer = chosenVersion myVerInfo myVers0 = otherVersions myVerInfo -- ignoring VN if the original version is included. when (myVer `notElem` peerVers && Negotiation `notElem` peerVers) $ do ok <- checkCIDs conn dCID (Left sCID) let myVers = filter (not . isGreasingVersion) myVers0 nextVerInfo = case myVers `intersect` peerVers of - vers@(ver:_) | ok -> VersionInfo ver vers - _ -> brokenVersionInfo + 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 (PacketIR pkt@(RetryPacket ver dCID sCID token ex)) = do @@ -77,7 +71,7 @@ ok <- checkCIDs conn dCID ex when ok $ do resetPeerCID conn sCID - setPeerAuthCIDs conn $ \auth -> auth { retrySrcCID = Just sCID } + setPeerAuthCIDs conn $ \auth -> auth{retrySrcCID = Just sCID} initializeCoder conn InitialLevel $ initialSecrets ver sCID setToken conn token setRetried conn True @@ -85,12 +79,12 @@ where put ppkt = putOutput conn $ OutRetrans ppkt -checkCIDs :: Connection -> CID -> Either CID (ByteString,ByteString) -> IO Bool +checkCIDs :: Connection -> CID -> Either CID (ByteString, ByteString) -> IO Bool checkCIDs conn dCID (Left sCID) = do localCID <- getMyCID conn remoteCID <- getPeerCID conn return (dCID == localCID && sCID == remoteCID) -checkCIDs conn dCID (Right (pseudo0,tag)) = do +checkCIDs conn dCID (Right (pseudo0, tag)) = do localCID <- getMyCID conn remoteCID <- getPeerCID conn ver <- getVersion conn @@ -103,30 +97,31 @@ ---------------------------------------------------------------- -- | How to control a connection. -data ConnectionControl = ChangeServerCID - | ChangeClientCID - | NATRebinding - | ActiveMigration - deriving (Eq, Show) +data ConnectionControl + = ChangeServerCID + | ChangeClientCID + | NATRebinding + | ActiveMigration + deriving (Eq, Show) controlConnection :: Connection -> ConnectionControl -> IO Bool controlConnection conn typ - | isClient conn = do + | isClient conn = do waitEstablished conn controlConnection' conn typ - | otherwise = return False + | otherwise = return False controlConnection' :: Connection -> ConnectionControl -> IO Bool controlConnection' conn ChangeServerCID = do mn <- timeout (Microseconds 1000000) "controlConnection' 1" $ waitPeerCID conn -- fixme case mn of - Nothing -> return False - Just (CIDInfo n _ _) -> do - sendFrames conn RTT1Level [RetireConnectionID n] - return True + Nothing -> return False + Just (CIDInfo n _ _) -> do + sendFrames conn RTT1Level [RetireConnectionID n] + return True controlConnection' conn ChangeClientCID = do cidInfo <- getNewMyCID conn - x <- (+1) <$> getMyCIDSeqNum conn + x <- (+ 1) <$> getMyCIDSeqNum conn sendFrames conn RTT1Level [NewConnectionID cidInfo x] return True controlConnection' conn NATRebinding = do @@ -135,11 +130,11 @@ controlConnection' conn ActiveMigration = do mn <- timeout (Microseconds 1000000) "controlConnection' 2" $ waitPeerCID conn -- fixme case mn of - Nothing -> return False - mcidinfo -> do - rebind conn $ Microseconds 5000000 - validatePath conn mcidinfo - return True + Nothing -> return False + mcidinfo -> do + rebind conn $ Microseconds 5000000 + validatePath conn mcidinfo + return True rebind :: Connection -> Microseconds -> IO () rebind conn microseconds = do diff --git a/Network/QUIC/Client/Run.hs b/Network/QUIC/Client/Run.hs --- a/Network/QUIC/Client/Run.hs +++ b/Network/QUIC/Client/Run.hs @@ -3,12 +3,12 @@ {-# LANGUAGE ScopedTypeVariables #-} module Network.QUIC.Client.Run ( - run - , migrate - ) where + run, + migrate, +) where import qualified Network.Socket as NS -import Network.UDP (UDPSocket(..)) +import Network.UDP (UDPSocket (..)) import qualified Network.UDP as UDP import UnliftIO.Async import UnliftIO.Concurrent @@ -41,50 +41,55 @@ run :: ClientConfig -> (Connection -> IO a) -> IO a -- Don't use handleLogUnit here because of a return value. run conf client = NS.withSocketsDo $ do - let resInfo = ccResumption conf - verInfo = case resumptionSession resInfo of - Nothing | resumptionToken resInfo == emptyToken -> - let vers = ccVersions conf - ver = head vers - in VersionInfo ver vers - _ -> let ver = resumptionVersion resInfo in VersionInfo ver [ver] - ex <- E.try $ runClient conf client False verInfo - case ex of - Right v -> return v - Left (NextVersion nextVerInfo) - | verInfo == brokenVersionInfo -> E.throwIO VersionNegotiationFailed - | otherwise -> runClient conf client True nextVerInfo + let resInfo = ccResumption conf + verInfo = case resumptionSession resInfo of + Nothing + | resumptionToken resInfo == emptyToken -> + let vers = ccVersions conf + ver = head vers + in VersionInfo ver vers + _ -> let ver = resumptionVersion resInfo in VersionInfo ver [ver] + ex <- E.try $ runClient conf client False verInfo + case ex of + Right v -> return v + Left (NextVersion nextVerInfo) + | verInfo == brokenVersionInfo -> E.throwIO VersionNegotiationFailed + | otherwise -> runClient conf client True nextVerInfo runClient :: ClientConfig -> (Connection -> IO a) -> Bool -> VersionInfo -> IO a runClient conf client0 isICVN verInfo = do E.bracket open clse $ \(ConnRes conn myAuthCIDs reader) -> do forkIO reader >>= addReader conn - let conf' = conf { - ccParameters = (ccParameters conf) { - versionInformation = Just verInfo + let conf' = + conf + { ccParameters = + (ccParameters conf) + { versionInformation = Just verInfo + } } - } setIncompatibleVN conn isICVN -- must be before handshaker setToken conn $ resumptionToken $ ccResumption conf handshaker <- handshakeClient conf' conn myAuthCIDs let client = do - if ccUse0RTT conf then - wait0RTTReady conn - else - wait1RTTReady conn + if ccUse0RTT conf + then wait0RTTReady conn + else wait1RTTReady conn client0 conn ldcc = connLDCC conn - supporters = foldr1 concurrently_ [handshaker - ,sender conn - ,receiver conn - ,resender ldcc - ,ldccTimer ldcc - ] + supporters = + foldr1 + concurrently_ + [ handshaker + , sender conn + , receiver conn + , resender ldcc + , ldccTimer ldcc + ] runThreads = do er <- race supporters client case er of - Left () -> E.throwIO MustNotReached - Right r -> return r + Left () -> E.throwIO MustNotReached + Right r -> return r ex <- E.trySyncOrAsync runThreads sendFinal conn closure conn ldcc ex @@ -98,23 +103,37 @@ createClientConnection :: ClientConfig -> VersionInfo -> IO ConnRes createClientConnection conf@ClientConfig{..} verInfo = do - us@(UDPSocket _ sa _) <- UDP.clientSocket ccServerName ccPortName (not ccAutoMigration) + us@(UDPSocket _ sa _) <- + UDP.clientSocket ccServerName ccPortName (not ccAutoMigration) q <- newRecvQ sref <- newIORef us let send = \buf siz -> do cs <- readIORef sref UDP.sendBuf cs buf siz recv = recvClient q - myCID <- newCID + myCID <- newCID peerCID <- newCID now <- getTimeMicrosecond (qLog, qclean) <- dirQLogger ccQLog now peerCID "client" - let debugLog msg | ccDebugLog = stdoutLogger msg - | otherwise = return () + let debugLog msg + | ccDebugLog = stdoutLogger msg + | otherwise = return () debugLog $ "Original CID: " <> bhow peerCID - let myAuthCIDs = defaultAuthCIDs { initSrcCID = Just myCID } - peerAuthCIDs = defaultAuthCIDs { initSrcCID = Just peerCID, origDstCID = Just peerCID } - conn <- clientConnection conf verInfo myAuthCIDs peerAuthCIDs debugLog qLog ccHooks sref q send recv + let myAuthCIDs = defaultAuthCIDs{initSrcCID = Just myCID} + peerAuthCIDs = defaultAuthCIDs{initSrcCID = Just peerCID, origDstCID = Just peerCID} + conn <- + clientConnection + conf + verInfo + myAuthCIDs + peerAuthCIDs + debugLog + qLog + ccHooks + sref + q + send + recv addResource conn qclean let ver = chosenVersion verInfo initializeCoder conn InitialLevel $ initialSecrets ver peerCID diff --git a/Network/QUIC/Common.hs b/Network/QUIC/Common.hs --- a/Network/QUIC/Common.hs +++ b/Network/QUIC/Common.hs @@ -17,8 +17,8 @@ defaultPacketSize :: NS.SockAddr -> Int defaultPacketSize NS.SockAddrInet6{} = defaultQUICPacketSizeForIPv6 -defaultPacketSize _ = defaultQUICPacketSizeForIPv4 +defaultPacketSize _ = defaultQUICPacketSizeForIPv4 maximumPacketSize :: NS.SockAddr -> Int maximumPacketSize NS.SockAddrInet6{} = 1500 - 40 - 8 -- fixme -maximumPacketSize _ = 1500 - 20 - 8 -- fixme +maximumPacketSize _ = 1500 - 20 - 8 -- fixme diff --git a/Network/QUIC/Config.hs b/Network/QUIC/Config.hs --- a/Network/QUIC/Config.hs +++ b/Network/QUIC/Config.hs @@ -5,7 +5,7 @@ import Data.IP import Network.Socket -import Network.TLS hiding (Version, HostName, Hooks) +import Network.TLS hiding (Hooks, HostName, Version) import Network.TLS.QUIC import Network.QUIC.Imports @@ -16,112 +16,138 @@ ---------------------------------------------------------------- -- | Hooks. -data Hooks = Hooks { - onCloseCompleted :: IO () - , onPlainCreated :: EncryptionLevel -> Plain -> Plain - , onTransportParametersCreated :: Parameters -> Parameters - , onTLSExtensionCreated :: [ExtensionRaw] -> [ExtensionRaw] - , onTLSHandshakeCreated :: [(EncryptionLevel,CryptoData)] -> ([(EncryptionLevel,CryptoData)],Bool) - , onResetStreamReceived :: Stream -> ApplicationProtocolError -> IO () - , onServerReady :: IO () - } +data Hooks = Hooks + { onCloseCompleted :: IO () + , onPlainCreated :: EncryptionLevel -> Plain -> Plain + , onTransportParametersCreated :: Parameters -> Parameters + , onTLSExtensionCreated :: [ExtensionRaw] -> [ExtensionRaw] + , onTLSHandshakeCreated + :: [(EncryptionLevel, CryptoData)] + -> ([(EncryptionLevel, CryptoData)], Bool) + , onResetStreamReceived :: Stream -> ApplicationProtocolError -> IO () + , onServerReady :: IO () + } -- | Default hooks. defaultHooks :: Hooks -defaultHooks = Hooks { - onCloseCompleted = return () - , onPlainCreated = \_l p -> p - , onTransportParametersCreated = id - , onTLSExtensionCreated = id - , onTLSHandshakeCreated = (, False) - , onResetStreamReceived = \_ _ -> return () - , onServerReady = return () - } +defaultHooks = + Hooks + { onCloseCompleted = return () + , onPlainCreated = \_l p -> p + , onTransportParametersCreated = id + , onTLSExtensionCreated = id + , onTLSHandshakeCreated = (,False) + , onResetStreamReceived = \_ _ -> return () + , onServerReady = return () + } ---------------------------------------------------------------- -- | Client configuration. -data ClientConfig = ClientConfig { - ccVersions :: [Version] -- ^ Compatible versions in the preferred order. - , ccCiphers :: [Cipher] -- ^ Cipher candidates defined in TLS 1.3. - , ccGroups :: [Group] -- ^ Key exchange group candidates defined in TLS 1.3. - , ccParameters :: Parameters - , ccKeyLog :: String -> IO () - , ccQLog :: Maybe FilePath - , ccCredentials :: Credentials -- ^ TLS credentials. - , ccHooks :: Hooks - , ccUse0RTT :: Bool -- ^ Use 0-RTT on the 2nd connection if possible. - -- client original - , ccServerName :: HostName -- ^ Used to create a socket and SNI for TLS. - , ccPortName :: ServiceName -- ^ Used to create a socket. - , ccALPN :: Version -> IO (Maybe [ByteString]) -- ^ An ALPN provider. - , ccValidate :: Bool -- ^ Authenticating a server based on its certificate. - , ccResumption :: ResumptionInfo -- ^ Use resumption on the 2nd connection if possible. - , ccPacketSize :: Maybe Int -- ^ QUIC packet size (UDP payload size) - , ccDebugLog :: Bool - , ccAutoMigration :: Bool -- ^ If 'True', use a unconnected socket for auto migration. Otherwise, use a connected socket. - } +data ClientConfig = ClientConfig + { ccVersions :: [Version] + -- ^ Compatible versions in the preferred order. + , ccCiphers :: [Cipher] + -- ^ Cipher candidates defined in TLS 1.3. + , ccGroups :: [Group] + -- ^ Key exchange group candidates defined in TLS 1.3. + , ccParameters :: Parameters + , ccKeyLog :: String -> IO () + , ccQLog :: Maybe FilePath + , ccCredentials :: Credentials + -- ^ TLS credentials. + , ccHooks :: Hooks + , ccUse0RTT :: Bool + -- ^ Use 0-RTT on the 2nd connection if possible. + -- client original + , ccServerName :: HostName + -- ^ Used to create a socket and SNI for TLS. + , ccPortName :: ServiceName + -- ^ Used to create a socket. + , ccALPN :: Version -> IO (Maybe [ByteString]) + -- ^ An ALPN provider. + , ccValidate :: Bool + -- ^ Authenticating a server based on its certificate. + , ccResumption :: ResumptionInfo + -- ^ Use resumption on the 2nd connection if possible. + , ccPacketSize :: Maybe Int + -- ^ QUIC packet size (UDP payload size) + , ccDebugLog :: Bool + , ccAutoMigration :: Bool + -- ^ If 'True', use a unconnected socket for auto migration. Otherwise, use a connected socket. + } -- | The default value for client configuration. defaultClientConfig :: ClientConfig -defaultClientConfig = ClientConfig { - ccVersions = [Version2,Version1] - , ccCiphers = supportedCiphers defaultSupported - , ccGroups = supportedGroups defaultSupported - , ccParameters = defaultParameters - , ccKeyLog = \_ -> return () - , ccQLog = Nothing - , ccCredentials = mempty - , ccHooks = defaultHooks - , ccUse0RTT = False - -- client original - , ccServerName = "127.0.0.1" - , ccPortName = "4433" - , ccALPN = \_ -> return Nothing - , ccValidate = True - , ccResumption = defaultResumptionInfo - , ccPacketSize = Nothing - , ccDebugLog = False - , ccAutoMigration = True - } +defaultClientConfig = + ClientConfig + { ccVersions = [Version2, Version1] + , ccCiphers = supportedCiphers defaultSupported + , ccGroups = supportedGroups defaultSupported + , ccParameters = defaultParameters + , ccKeyLog = \_ -> return () + , ccQLog = Nothing + , ccCredentials = mempty + , ccHooks = defaultHooks + , ccUse0RTT = False + , -- client original + ccServerName = "127.0.0.1" + , ccPortName = "4433" + , ccALPN = \_ -> return Nothing + , ccValidate = True + , ccResumption = defaultResumptionInfo + , ccPacketSize = Nothing + , ccDebugLog = False + , ccAutoMigration = True + } ---------------------------------------------------------------- -- | Server configuration. -data ServerConfig = ServerConfig { - scVersions :: [Version] -- ^ Fully-Deployed Versions in the preferred order. - , scCiphers :: [Cipher] -- ^ Cipher candidates defined in TLS 1.3. - , scGroups :: [Group] -- ^ Key exchange group candidates defined in TLS 1.3. - , scParameters :: Parameters - , scKeyLog :: String -> IO () - , scQLog :: Maybe FilePath - , scCredentials :: Credentials -- ^ Server certificate information. - , scHooks :: Hooks - , scUse0RTT :: Bool -- ^ Use 0-RTT on the 2nd connection if possible. - -- server original - , scAddresses :: [(IP,PortNumber)] -- ^ Server addresses assigned to used network interfaces. - , scALPN :: Maybe (Version -> [ByteString] -> IO ByteString) -- ^ ALPN handler. - , scRequireRetry :: Bool -- ^ Requiring QUIC retry. - , scSessionManager :: SessionManager -- ^ A session manager of TLS 1.3. - , scDebugLog :: Maybe FilePath - } +data ServerConfig = ServerConfig + { scVersions :: [Version] + -- ^ Fully-Deployed Versions in the preferred order. + , scCiphers :: [Cipher] + -- ^ Cipher candidates defined in TLS 1.3. + , scGroups :: [Group] + -- ^ Key exchange group candidates defined in TLS 1.3. + , scParameters :: Parameters + , scKeyLog :: String -> IO () + , scQLog :: Maybe FilePath + , scCredentials :: Credentials + -- ^ Server certificate information. + , scHooks :: Hooks + , scUse0RTT :: Bool + -- ^ Use 0-RTT on the 2nd connection if possible. + -- server original + , scAddresses :: [(IP, PortNumber)] + -- ^ Server addresses assigned to used network interfaces. + , scALPN :: Maybe (Version -> [ByteString] -> IO ByteString) + -- ^ ALPN handler. + , scRequireRetry :: Bool + -- ^ Requiring QUIC retry. + , scSessionManager :: SessionManager + -- ^ A session manager of TLS 1.3. + , scDebugLog :: Maybe FilePath + } -- | The default value for server configuration. defaultServerConfig :: ServerConfig -defaultServerConfig = ServerConfig { - scVersions = [Version2,Version1] - , scCiphers = supportedCiphers defaultSupported - , scGroups = supportedGroups defaultSupported - , scParameters = defaultParameters - , scKeyLog = \_ -> return () - , scQLog = Nothing - , scCredentials = mempty - , scHooks = defaultHooks - , scUse0RTT = False - -- server original - , scAddresses = [("0.0.0.0",4433),("::",4433)] - , scALPN = Nothing - , scRequireRetry = False - , scSessionManager = noSessionManager - , scDebugLog = Nothing - } +defaultServerConfig = + ServerConfig + { scVersions = [Version2, Version1] + , scCiphers = supportedCiphers defaultSupported + , scGroups = supportedGroups defaultSupported + , scParameters = defaultParameters + , scKeyLog = \_ -> return () + , scQLog = Nothing + , scCredentials = mempty + , scHooks = defaultHooks + , scUse0RTT = False + , -- server original + scAddresses = [("0.0.0.0", 4433), ("::", 4433)] + , scALPN = Nothing + , scRequireRetry = False + , scSessionManager = noSessionManager + , scDebugLog = Nothing + } diff --git a/Network/QUIC/Connection.hs b/Network/QUIC/Connection.hs --- a/Network/QUIC/Connection.hs +++ b/Network/QUIC/Connection.hs @@ -1,16 +1,16 @@ module Network.QUIC.Connection ( - module Network.QUIC.Connection.PacketNumber - , module Network.QUIC.Connection.Crypto - , module Network.QUIC.Connection.Migration - , module Network.QUIC.Connection.Misc - , module Network.QUIC.Connection.State - , module Network.QUIC.Connection.Stream - , module Network.QUIC.Connection.StreamTable - , module Network.QUIC.Connection.Queue - , module Network.QUIC.Connection.Role - , module Network.QUIC.Connection.Timeout - , module Network.QUIC.Connection.Types - ) where + module Network.QUIC.Connection.PacketNumber, + module Network.QUIC.Connection.Crypto, + module Network.QUIC.Connection.Migration, + module Network.QUIC.Connection.Misc, + module Network.QUIC.Connection.State, + module Network.QUIC.Connection.Stream, + module Network.QUIC.Connection.StreamTable, + module Network.QUIC.Connection.Queue, + module Network.QUIC.Connection.Role, + module Network.QUIC.Connection.Timeout, + module Network.QUIC.Connection.Types, +) where import Network.QUIC.Connection.Crypto import Network.QUIC.Connection.Migration diff --git a/Network/QUIC/Connection/Crypto.hs b/Network/QUIC/Connection/Crypto.hs --- a/Network/QUIC/Connection/Crypto.hs +++ b/Network/QUIC/Connection/Crypto.hs @@ -1,28 +1,28 @@ -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} module Network.QUIC.Connection.Crypto ( - setEncryptionLevel - , waitEncryptionLevel - , putOffCrypto - -- - , getCipher - , setCipher - , getTLSMode - , getApplicationProtocol - , setNegotiated - -- - , dropSecrets - -- - , initializeCoder - , initializeCoder1RTT - , updateCoder1RTT - , getCoder - , getProtector - -- - , getCurrentKeyPhase - , setCurrentKeyPhase - ) where + setEncryptionLevel, + waitEncryptionLevel, + putOffCrypto, + -- + getCipher, + setCipher, + getTLSMode, + getApplicationProtocol, + setNegotiated, + -- + dropSecrets, + -- + initializeCoder, + initializeCoder1RTT, + updateCoder1RTT, + getCoder, + getProtector, + -- + getCurrentKeyPhase, + setCurrentKeyPhase, +) where import Network.TLS.QUIC import UnliftIO.STM @@ -49,12 +49,12 @@ atomically $ do writeTVar (encryptionLevel connState) lvl case lvl of - HandshakeLevel -> do - readTVar (pendingQ ! RTT0Level) >>= mapM_ (prependRecvQ q) - readTVar (pendingQ ! HandshakeLevel) >>= mapM_ (prependRecvQ q) - RTT1Level -> - readTVar (pendingQ ! RTT1Level) >>= mapM_ (prependRecvQ q) - _ -> return () + HandshakeLevel -> do + readTVar (pendingQ ! RTT0Level) >>= mapM_ (prependRecvQ q) + readTVar (pendingQ ! HandshakeLevel) >>= mapM_ (prependRecvQ q) + RTT1Level -> + readTVar (pendingQ ! RTT1Level) >>= mapM_ (prependRecvQ q) + _ -> return () putOffCrypto :: Connection -> EncryptionLevel -> ReceivedPacket -> IO () putOffCrypto Connection{..} lvl rpkt = @@ -81,13 +81,20 @@ getApplicationProtocol :: Connection -> IO (Maybe NegotiatedProtocol) getApplicationProtocol Connection{..} = applicationProtocol <$> readIORef negotiated -setNegotiated :: Connection -> HandshakeMode13 -> Maybe NegotiatedProtocol -> ApplicationSecretInfo -> IO () +setNegotiated + :: Connection + -> HandshakeMode13 + -> Maybe NegotiatedProtocol + -> ApplicationSecretInfo + -> IO () setNegotiated Connection{..} mode mproto appSecInf = - writeIORef negotiated Negotiated { - tlsHandshakeMode = mode - , applicationProtocol = mproto - , applicationSecretInfo = appSecInf - } + writeIORef + negotiated + Negotiated + { tlsHandshakeMode = mode + , applicationProtocol = mproto + , applicationSecretInfo = appSecInf + } ---------------------------------------------------------------- @@ -100,17 +107,16 @@ initializeCoder :: Connection -> EncryptionLevel -> TrafficSecrets a -> IO () initializeCoder conn lvl sec = do - ver <- if lvl == RTT0Level then - return $ getOriginalVersion conn - else - getVersion conn + ver <- + if lvl == RTT0Level + then return $ getOriginalVersion conn + else getVersion conn cipher <- getCipher conn lvl avail <- isFusionAvailable (coder, protector) <- - if useFusion && avail then - genFusionCoder (isClient conn) ver cipher sec - else - genNiteCoder (isClient conn) ver cipher sec + if useFusion && avail + then genFusionCoder (isClient conn) ver cipher sec + else genNiteCoder (isClient conn) ver cipher sec writeArray (coders conn) lvl coder writeArray (protectors conn) lvl protector @@ -120,10 +126,9 @@ cipher <- getCipher conn RTT1Level avail <- isFusionAvailable (coder, protector) <- - if useFusion && avail then - genFusionCoder (isClient conn) ver cipher sec - else - genNiteCoder (isClient conn) ver cipher sec + if useFusion && avail + then genFusionCoder (isClient conn) ver cipher sec + else genNiteCoder (isClient conn) ver cipher sec let coder1 = Coder1RTT coder sec writeArray (coders1RTT conn) False coder1 writeArray (protectors conn) RTT1Level protector @@ -136,126 +141,148 @@ Coder1RTT coder secN <- readArray (coders1RTT conn) (not nextPhase) let secN1 = updateSecret ver cipher secN avail <- isFusionAvailable - coderN1 <- if useFusion && avail then - genFusionCoder1RTT (isClient conn) ver cipher secN1 coder - else - genNiteCoder1RTT (isClient conn) ver cipher secN1 coder + coderN1 <- + if useFusion && avail + then genFusionCoder1RTT (isClient conn) ver cipher secN1 coder + else genNiteCoder1RTT (isClient conn) ver cipher secN1 coder let nextCoder = Coder1RTT coderN1 secN1 writeArray (coders1RTT conn) nextPhase nextCoder -updateSecret :: Version -> Cipher -> TrafficSecrets ApplicationSecret -> TrafficSecrets ApplicationSecret +updateSecret + :: Version + -> Cipher + -> TrafficSecrets ApplicationSecret + -> TrafficSecrets ApplicationSecret updateSecret ver cipher (ClientTrafficSecret cN, ServerTrafficSecret sN) = secN1 where Secret cN1 = nextSecret ver cipher $ Secret cN Secret sN1 = nextSecret ver cipher $ Secret sN secN1 = (ClientTrafficSecret cN1, ServerTrafficSecret sN1) -genFusionCoder :: Bool -> Version -> Cipher -> TrafficSecrets a -> IO (Coder, Protector) +genFusionCoder + :: Bool -> Version -> Cipher -> TrafficSecrets a -> IO (Coder, Protector) genFusionCoder cli ver cipher (ClientTrafficSecret c, ServerTrafficSecret s) = do fctxt <- fusionNewContext fctxr <- fusionNewContext fusionSetup cipher fctxt txPayloadKey txPayloadIV fusionSetup cipher fctxr rxPayloadKey rxPayloadIV supp <- fusionSetupSupplement cipher txHeaderKey - let coder = Coder { - encrypt = fusionEncrypt fctxt supp - , decrypt = fusionDecrypt fctxr - , supplement = Just supp - } - let protector = Protector { - setSample = fusionSetSample supp - , getMask = fusionGetMask supp - , unprotect = unp - } + let coder = + Coder + { encrypt = fusionEncrypt fctxt supp + , decrypt = fusionDecrypt fctxr + , supplement = Just supp + } + let protector = + Protector + { setSample = fusionSetSample supp + , getMask = fusionGetMask supp + , unprotect = unp + } return (coder, protector) where - txSecret | cli = Secret c - | otherwise = Secret s - rxSecret | cli = Secret s - | otherwise = Secret c + txSecret + | cli = Secret c + | otherwise = Secret s + rxSecret + | cli = Secret s + | otherwise = Secret c txPayloadKey = aeadKey ver cipher txSecret - txPayloadIV = initialVector ver cipher txSecret - txHeaderKey = headerProtectionKey ver cipher txSecret + txPayloadIV = initialVector ver cipher txSecret + txHeaderKey = headerProtectionKey ver cipher txSecret rxPayloadKey = aeadKey ver cipher rxSecret - rxPayloadIV = initialVector ver cipher rxSecret - rxHeaderKey = headerProtectionKey ver cipher rxSecret + rxPayloadIV = initialVector ver cipher rxSecret + rxHeaderKey = headerProtectionKey ver cipher rxSecret unp = protectionMask cipher rxHeaderKey -genNiteCoder :: Bool -> Version -> Cipher -> TrafficSecrets a -> IO (Coder, Protector) +genNiteCoder + :: Bool -> Version -> Cipher -> TrafficSecrets a -> IO (Coder, Protector) genNiteCoder cli ver cipher (ClientTrafficSecret c, ServerTrafficSecret s) = do let enc = makeNiteEncrypt cipher txPayloadKey txPayloadIV dec = makeNiteDecrypt cipher rxPayloadKey rxPayloadIV - (set,get) <- makeNiteProtector cipher txHeaderKey - let coder = Coder { - encrypt = enc - , decrypt = dec - , supplement = Nothing - } - let protector = Protector { - setSample = set - , getMask = get - , unprotect = unp - } + (set, get) <- makeNiteProtector cipher txHeaderKey + let coder = + Coder + { encrypt = enc + , decrypt = dec + , supplement = Nothing + } + let protector = + Protector + { setSample = set + , getMask = get + , unprotect = unp + } return (coder, protector) where - txSecret | cli = Secret c - | otherwise = Secret s - rxSecret | cli = Secret s - | otherwise = Secret c + txSecret + | cli = Secret c + | otherwise = Secret s + rxSecret + | cli = Secret s + | otherwise = Secret c txPayloadKey = aeadKey ver cipher txSecret - txPayloadIV = initialVector ver cipher txSecret - txHeaderKey = headerProtectionKey ver cipher txSecret + txPayloadIV = initialVector ver cipher txSecret + txHeaderKey = headerProtectionKey ver cipher txSecret rxPayloadKey = aeadKey ver cipher rxSecret - rxPayloadIV = initialVector ver cipher rxSecret - rxHeaderKey = headerProtectionKey ver cipher rxSecret + rxPayloadIV = initialVector ver cipher rxSecret + rxHeaderKey = headerProtectionKey ver cipher rxSecret unp = protectionMask cipher rxHeaderKey -genFusionCoder1RTT :: Bool -> Version -> Cipher -> TrafficSecrets a -> Coder -> IO Coder +genFusionCoder1RTT + :: Bool -> Version -> Cipher -> TrafficSecrets a -> Coder -> IO Coder genFusionCoder1RTT cli ver cipher (ClientTrafficSecret c, ServerTrafficSecret s) oldcoder = do fctxt <- fusionNewContext fctxr <- fusionNewContext fusionSetup cipher fctxt txPayloadKey txPayloadIV fusionSetup cipher fctxr rxPayloadKey rxPayloadIV let supp = fromJust $ supplement oldcoder - let coder = Coder { - encrypt = fusionEncrypt fctxt supp - , decrypt = fusionDecrypt fctxr - , supplement = Just supp - } + let coder = + Coder + { encrypt = fusionEncrypt fctxt supp + , decrypt = fusionDecrypt fctxr + , supplement = Just supp + } return coder where - txSecret | cli = Secret c - | otherwise = Secret s - rxSecret | cli = Secret s - | otherwise = Secret c + txSecret + | cli = Secret c + | otherwise = Secret s + rxSecret + | cli = Secret s + | otherwise = Secret c txPayloadKey = aeadKey ver cipher txSecret - txPayloadIV = initialVector ver cipher txSecret + txPayloadIV = initialVector ver cipher txSecret rxPayloadKey = aeadKey ver cipher rxSecret - rxPayloadIV = initialVector ver cipher rxSecret + rxPayloadIV = initialVector ver cipher rxSecret -genNiteCoder1RTT :: Bool -> Version -> Cipher -> TrafficSecrets a -> Coder -> IO Coder +genNiteCoder1RTT + :: Bool -> Version -> Cipher -> TrafficSecrets a -> Coder -> IO Coder genNiteCoder1RTT cli ver cipher (ClientTrafficSecret c, ServerTrafficSecret s) _oldcoder = do let enc = makeNiteEncrypt cipher txPayloadKey txPayloadIV dec = makeNiteDecrypt cipher rxPayloadKey rxPayloadIV - let coder = Coder { - encrypt = enc - , decrypt = dec - , supplement = Nothing - } + let coder = + Coder + { encrypt = enc + , decrypt = dec + , supplement = Nothing + } return coder where - txSecret | cli = Secret c - | otherwise = Secret s - rxSecret | cli = Secret s - | otherwise = Secret c + txSecret + | cli = Secret c + | otherwise = Secret s + rxSecret + | cli = Secret s + | otherwise = Secret c txPayloadKey = aeadKey ver cipher txSecret - txPayloadIV = initialVector ver cipher txSecret + txPayloadIV = initialVector ver cipher txSecret rxPayloadKey = aeadKey ver cipher rxSecret - rxPayloadIV = initialVector ver cipher rxSecret + rxPayloadIV = initialVector ver cipher rxSecret getCoder :: Connection -> EncryptionLevel -> Bool -> IO Coder getCoder conn RTT1Level k = coder1RTT <$> readArray (coders1RTT conn) k -getCoder conn lvl _ = readArray (coders conn) lvl +getCoder conn lvl _ = readArray (coders conn) lvl getProtector :: Connection -> EncryptionLevel -> IO Protector getProtector conn lvl = readArray (protectors conn) lvl diff --git a/Network/QUIC/Connection/Migration.hs b/Network/QUIC/Connection/Migration.hs --- a/Network/QUIC/Connection/Migration.hs +++ b/Network/QUIC/Connection/Migration.hs @@ -1,30 +1,30 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Connection.Migration ( - getMyCID - , getMyCIDs - , getPeerCID - , isMyCID - , myCIDsInclude - , shouldUpdateMyCID - , shouldUpdatePeerCID - , resetPeerCID - , getNewMyCID - , getMyCIDSeqNum - , setMyCID - , setPeerCIDAndRetireCIDs - , retirePeerCID - , retireMyCID - , addPeerCID - , waitPeerCID - , choosePeerCIDForPrivacy - , setPeerStatelessResetToken - , isStatelessRestTokenValid - , setMigrationStarted - , isPathValidating - , checkResponse - , validatePath - ) where + getMyCID, + getMyCIDs, + getPeerCID, + isMyCID, + myCIDsInclude, + shouldUpdateMyCID, + shouldUpdatePeerCID, + resetPeerCID, + getNewMyCID, + getMyCIDSeqNum, + setMyCID, + setPeerCIDAndRetireCIDs, + retirePeerCID, + retireMyCID, + addPeerCID, + waitPeerCID, + choosePeerCIDForPrivacy, + setPeerStatelessResetToken, + isStatelessRestTokenValid, + setMigrationStarted, + isPathValidating, + checkResponse, + validatePath, +) where import qualified Data.IntMap.Strict as IntMap import qualified Data.Map.Strict as Map @@ -85,8 +85,8 @@ addPeerCID Connection{..} cidInfo = atomically $ do db <- readTVar peerCIDDB case Map.lookup (cidInfoCID cidInfo) (revInfos db) of - Nothing -> modifyTVar' peerCIDDB $ add cidInfo - Just _ -> return () + Nothing -> modifyTVar' peerCIDDB $ add cidInfo + Just _ -> return () shouldUpdatePeerCID :: Connection -> IO Bool shouldUpdatePeerCID Connection{..} = @@ -98,14 +98,14 @@ mr <- atomically $ do mncid <- pickPeerCID conn case mncid of - Nothing -> return () - Just ncid -> do - setPeerCID conn ncid False - return () + Nothing -> return () + Just ncid -> do + setPeerCID conn ncid False + return () return mncid case mr of - Nothing -> return () - Just ncid -> qlogCIDUpdate conn $ Remote $ cidInfoCID ncid + Nothing -> return () + Just ncid -> qlogCIDUpdate conn $ Remote $ cidInfoCID ncid -- | Only for the internal "migration" API waitPeerCID :: Connection -> IO CIDInfo @@ -151,18 +151,20 @@ arrange n db@CIDDB{..} = (db', dropSeqnums) where (toDrops, cidInfos') = IntMap.partitionWithKey (\k _ -> k < n) cidInfos - dropSeqnums = IntMap.foldrWithKey (\k _ ks -> k:ks) [] toDrops + 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 - | otherwise = snd $ IntMap.findMin cidInfos' + usedCIDInfo' + | cidInfoSeq usedCIDInfo >= n = usedCIDInfo + | otherwise = snd $ IntMap.findMin cidInfos' revInfos' = foldr Map.delete revInfos dropCIDs - db' = db { - usedCIDInfo = usedCIDInfo' - , cidInfos = cidInfos' - , revInfos = revInfos' - } + db' = + db + { usedCIDInfo = usedCIDInfo' + , cidInfos = cidInfos' + , revInfos = revInfos' + } ---------------------------------------------------------------- @@ -173,12 +175,12 @@ when r $ qlogCIDUpdate conn $ Local ncid where findSet db@CIDDB{..} - | cidInfoCID usedCIDInfo == ncid = (db, False) - | otherwise = case Map.lookup ncid revInfos of - Nothing -> (db, False) - Just n -> case IntMap.lookup n cidInfos of + | cidInfoCID usedCIDInfo == ncid = (db, False) + | otherwise = case Map.lookup ncid revInfos of Nothing -> (db, False) - Just ncidinfo -> (set ncidinfo False db, True) + Just n -> case IntMap.lookup n cidInfos of + Nothing -> (db, False) + Just ncidinfo -> (set ncidinfo False db, True) -- | Receiving RetireConnectionID retireMyCID :: Connection -> Int -> IO (Maybe CIDInfo) @@ -189,49 +191,54 @@ set :: CIDInfo -> Bool -> CIDDB -> CIDDB set cidInfo pri db = db' where - db' = db { - usedCIDInfo = cidInfo - , triggeredByMe = pri - } + db' = + db + { usedCIDInfo = cidInfo + , triggeredByMe = pri + } add :: CIDInfo -> CIDDB -> CIDDB add cidInfo@CIDInfo{..} db@CIDDB{..} = db' where - db' = db { - cidInfos = IntMap.insert cidInfoSeq cidInfo cidInfos - , revInfos = Map.insert cidInfoCID cidInfoSeq revInfos - } + db' = + db + { cidInfos = IntMap.insert cidInfoSeq cidInfo cidInfos + , revInfos = Map.insert cidInfoCID cidInfoSeq revInfos + } new :: CID -> StatelessResetToken -> CIDDB -> (CIDDB, CIDInfo) new cid srt db@CIDDB{..} = (db', cidInfo) where - cidInfo = CIDInfo nextSeqNum cid srt - db' = db { - nextSeqNum = nextSeqNum + 1 - , cidInfos = IntMap.insert nextSeqNum cidInfo cidInfos - , revInfos = Map.insert cid nextSeqNum revInfos - } + cidInfo = CIDInfo nextSeqNum cid srt + db' = + db + { nextSeqNum = nextSeqNum + 1 + , cidInfos = IntMap.insert nextSeqNum cidInfo cidInfos + , revInfos = Map.insert cid nextSeqNum revInfos + } del :: Int -> CIDDB -> CIDDB del n db@CIDDB{..} = db' where db' = case IntMap.lookup n cidInfos of - Nothing -> db - Just cidInfo -> db { - cidInfos = IntMap.delete n cidInfos - , revInfos = Map.delete (cidInfoCID cidInfo) revInfos - } + Nothing -> db + Just cidInfo -> + db + { cidInfos = IntMap.delete n cidInfos + , revInfos = Map.delete (cidInfoCID cidInfo) revInfos + } del' :: Int -> CIDDB -> (CIDDB, Maybe CIDInfo) del' n db@CIDDB{..} = (db', mcidInfo) where mcidInfo = IntMap.lookup n cidInfos db' = case mcidInfo of - Nothing -> db - Just cidInfo -> db { - cidInfos = IntMap.delete n cidInfos - , revInfos = Map.delete (cidInfoCID cidInfo) revInfos - } + Nothing -> db + Just cidInfo -> + db + { cidInfos = IntMap.delete n cidInfos + , revInfos = Map.delete (cidInfoCID cidInfo) revInfos + } ---------------------------------------------------------------- @@ -242,22 +249,24 @@ adjust db@CIDDB{..} = db' where db' = case IntMap.lookup 0 cidInfos of - Nothing -> db - Just cidinfo -> let cidinfo' = cidinfo { cidInfoSRT = srt } - in db { - cidInfos = IntMap.insert 0 cidinfo' - $ IntMap.delete 0 cidInfos - , usedCIDInfo = cidinfo' - } + Nothing -> db + Just cidinfo -> + let cidinfo' = cidinfo{cidInfoSRT = srt} + in db + { cidInfos = + IntMap.insert 0 cidinfo' $ + IntMap.delete 0 cidInfos + , usedCIDInfo = cidinfo' + } isStatelessRestTokenValid :: Connection -> CID -> StatelessResetToken -> IO Bool isStatelessRestTokenValid Connection{..} cid 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 + Just n -> case IntMap.lookup n cidInfos of + Nothing -> False + Just (CIDInfo _ _ srt0) -> srt == srt0 ---------------------------------------------------------------- @@ -270,7 +279,9 @@ validatePath conn (Just (CIDInfo retiredSeqNum _ _)) = do pdat <- newPathData setChallenges conn [pdat] - putOutput conn $ OutControl RTT1Level [PathChallenge pdat, RetireConnectionID retiredSeqNum] $ return () + putOutput conn $ + OutControl RTT1Level [PathChallenge pdat, RetireConnectionID retiredSeqNum] $ + return () waitResponse conn retirePeerCID conn retiredSeqNum @@ -286,9 +297,9 @@ isPathValidating Connection{..} = do s <- readTVarIO migrationState case s of - SendChallenge _ -> return True - MigrationStarted -> return True - _ -> return False + SendChallenge _ -> return True + MigrationStarted -> return True + _ -> return False waitResponse :: Connection -> IO () waitResponse Connection{..} = atomically $ do @@ -300,6 +311,6 @@ checkResponse Connection{..} pdat = do state <- readTVarIO migrationState case state of - SendChallenge pdats - | pdat `elem` pdats -> atomically $ writeTVar migrationState RecvResponse - _ -> return () + SendChallenge pdats + | pdat `elem` pdats -> atomically $ writeTVar migrationState RecvResponse + _ -> return () diff --git a/Network/QUIC/Connection/Misc.hs b/Network/QUIC/Connection/Misc.hs --- a/Network/QUIC/Connection/Misc.hs +++ b/Network/QUIC/Connection/Misc.hs @@ -2,33 +2,33 @@ {-# LANGUAGE TupleSections #-} module Network.QUIC.Connection.Misc ( - setVersionInfo - , getVersionInfo - , setVersion - , getVersion - , getOriginalVersion - , getSocket - , setSocket - , clearSocket - , getPeerAuthCIDs - , setPeerAuthCIDs - , getClientDstCID - , getMyParameters - , getPeerParameters - , setPeerParameters - , delayedAck - , resetDealyedAck - , setMaxPacketSize - , addReader - , killReaders - , addResource - , freeResources - , readMinIdleTimeout - , setMinIdleTimeout - , sendFrames - , closeConnection - , abortConnection - ) where + setVersionInfo, + getVersionInfo, + setVersion, + getVersion, + getOriginalVersion, + getSocket, + setSocket, + clearSocket, + getPeerAuthCIDs, + setPeerAuthCIDs, + getClientDstCID, + getMyParameters, + getPeerParameters, + setPeerParameters, + delayedAck, + resetDealyedAck, + setMaxPacketSize, + addReader, + killReaders, + addResource, + freeResources, + readMinIdleTimeout, + setMinIdleTimeout, + sendFrames, + closeConnection, + abortConnection, +) where import Network.UDP import System.Mem.Weak @@ -53,7 +53,7 @@ setVersion :: Connection -> Version -> IO () setVersion Connection{..} ver = atomicModifyIORef'' quicVersionInfo $ \vi -> - vi { chosenVersion = ver } + vi{chosenVersion = ver} getVersion :: Connection -> IO Version getVersion conn = chosenVersion <$> getVersionInfo conn @@ -86,13 +86,13 @@ getClientDstCID :: Connection -> IO CID getClientDstCID conn = do - cids <- if isClient conn then - getPeerAuthCIDs conn - else - getMyAuthCIDs conn + cids <- + if isClient conn + then getPeerAuthCIDs conn + else getMyAuthCIDs conn return $ case retrySrcCID cids of - Nothing -> fromJust $ origDstCID cids - Just dcid -> dcid + Nothing -> fromJust $ origDstCID cids + Just dcid -> dcid ---------------------------------------------------------------- @@ -111,7 +111,7 @@ delayedAck :: Connection -> IO () delayedAck conn@Connection{..} = do - (oldcnt,send_) <- atomicModifyIORef' delayedAckCount check + (oldcnt, send_) <- atomicModifyIORef' delayedAckCount check when (oldcnt == 0) $ do new <- cfire conn (Microseconds 20000) sendAck join $ atomicModifyIORef' delayedAckCancel (new,) @@ -121,8 +121,8 @@ sendAck where sendAck = putOutput conn $ OutControl RTT1Level [] $ return () - check 1 = (0, (1, True)) - check n = (n+1, (n, False)) + check 1 = (0, (1, True)) + check n = (n + 1, (n, False)) resetDealyedAck :: Connection -> IO () resetDealyedAck Connection{..} = do @@ -165,8 +165,8 @@ setMinIdleTimeout :: Connection -> Microseconds -> IO () setMinIdleTimeout Connection{..} us - | us == Microseconds 0 = return () - | otherwise = atomicModifyIORef'' minIdleTimeout modify + | us == Microseconds 0 = return () + | otherwise = atomicModifyIORef'' minIdleTimeout modify where modify us0 = min us us0 @@ -183,5 +183,6 @@ quicexc = TransportErrorIsSent err desc -- | Closing a connection with an application protocol error. -abortConnection :: Connection -> ApplicationProtocolError -> ReasonPhrase -> IO () +abortConnection + :: Connection -> ApplicationProtocolError -> ReasonPhrase -> IO () abortConnection conn err desc = E.throwTo (mainThreadId conn) $ Abort err desc diff --git a/Network/QUIC/Connection/PacketNumber.hs b/Network/QUIC/Connection/PacketNumber.hs --- a/Network/QUIC/Connection/PacketNumber.hs +++ b/Network/QUIC/Connection/PacketNumber.hs @@ -1,10 +1,10 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Connection.PacketNumber ( - nextPacketNumber - , setPeerPacketNumber - , getPeerPacketNumber - ) where + nextPacketNumber, + setPeerPacketNumber, + getPeerPacketNumber, +) where import Network.QUIC.Connection.Types import Network.QUIC.Connector diff --git a/Network/QUIC/Connection/Role.hs b/Network/QUIC/Connection/Role.hs --- a/Network/QUIC/Connection/Role.hs +++ b/Network/QUIC/Connection/Role.hs @@ -2,25 +2,25 @@ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module Network.QUIC.Connection.Role ( - setToken - , getToken - , getResumptionInfo - , setRetried - , getRetried - , setIncompatibleVN - , getIncompatibleVN - , setResumptionSession - , setNewToken - , setRegister - , getRegister - , getUnregister - , setTokenManager - , getTokenManager - , setBaseThreadId - , getBaseThreadId - , setCertificateChain - , getCertificateChain - ) where + setToken, + getToken, + getResumptionInfo, + setRetried, + getRetried, + setIncompatibleVN, + getIncompatibleVN, + setResumptionSession, + setNewToken, + setRegister, + getRegister, + getUnregister, + setTokenManager, + getTokenManager, + setBaseThreadId, + getBaseThreadId, + setCertificateChain, + getCertificateChain, +) where import qualified Crypto.Token as CT import Data.X509 (CertificateChain) @@ -36,12 +36,12 @@ setToken :: Connection -> Token -> IO () setToken Connection{..} token = atomicModifyIORef'' roleInfo $ - \ci -> ci { clientInitialToken = token } + \ci -> ci{clientInitialToken = token} getToken :: Connection -> IO Token getToken conn@Connection{..} - | isClient conn = clientInitialToken <$> readIORef roleInfo - | otherwise = return emptyToken + | isClient conn = clientInitialToken <$> readIORef roleInfo + | otherwise = return emptyToken ---------------------------------------------------------------- @@ -53,59 +53,67 @@ setRetried :: Connection -> Bool -> IO () setRetried conn@Connection{..} r - | isClient conn = atomicModifyIORef'' roleInfo $ \ci -> ci { - resumptionInfo = (resumptionInfo ci) { resumptionRetry = r} - } - | otherwise = atomicModifyIORef'' roleInfo $ \si -> si { askRetry = r } + | isClient conn = atomicModifyIORef'' roleInfo $ \ci -> + ci + { resumptionInfo = (resumptionInfo ci){resumptionRetry = r} + } + | otherwise = atomicModifyIORef'' roleInfo $ \si -> si{askRetry = r} getRetried :: Connection -> IO Bool getRetried conn@Connection{..} - | isClient conn = resumptionRetry . resumptionInfo <$> readIORef roleInfo - | otherwise = askRetry <$> readIORef roleInfo + | isClient conn = resumptionRetry . resumptionInfo <$> readIORef roleInfo + | otherwise = askRetry <$> readIORef roleInfo ---------------------------------------------------------------- setIncompatibleVN :: Connection -> Bool -> IO () setIncompatibleVN conn@Connection{..} icvn - | isClient conn = atomicModifyIORef'' roleInfo $ \ci -> ci { - incompatibleVN = icvn - } - | otherwise = return () + | isClient conn = atomicModifyIORef'' roleInfo $ \ci -> + ci + { incompatibleVN = icvn + } + | otherwise = return () getIncompatibleVN :: Connection -> IO Bool getIncompatibleVN conn@Connection{..} - | isClient conn = incompatibleVN <$> readIORef roleInfo - | otherwise = return False + | isClient conn = incompatibleVN <$> readIORef roleInfo + | otherwise = return False ---------------------------------------------------------------- setResumptionSession :: Connection -> SessionEstablish setResumptionSession conn@Connection{..} si sd = do ver <- getVersion conn - atomicModifyIORef'' roleInfo $ \ci -> ci { - resumptionInfo = (resumptionInfo ci) { - resumptionVersion = ver - , resumptionSession = Just (si,sd) + atomicModifyIORef'' roleInfo $ \ci -> + ci + { resumptionInfo = + (resumptionInfo ci) + { resumptionVersion = ver + , resumptionSession = Just (si, sd) + } } - } setNewToken :: Connection -> Token -> IO () setNewToken conn@Connection{..} token = do ver <- getVersion conn - atomicModifyIORef'' roleInfo $ \ci -> ci { - resumptionInfo = (resumptionInfo ci) { - resumptionVersion = ver - , resumptionToken = token + atomicModifyIORef'' roleInfo $ \ci -> + ci + { resumptionInfo = + (resumptionInfo ci) + { resumptionVersion = ver + , resumptionToken = token + } } - } ---------------------------------------------------------------- -setRegister :: Connection -> (CID -> Connection -> IO ()) -> (CID -> IO ()) -> IO () -setRegister Connection{..} regisrer unregister = atomicModifyIORef'' roleInfo $ \si -> si { - registerCID = regisrer - , unregisterCID = unregister - } +setRegister + :: Connection -> (CID -> Connection -> IO ()) -> (CID -> IO ()) -> IO () +setRegister Connection{..} regisrer unregister = atomicModifyIORef'' roleInfo $ \si -> + si + { registerCID = regisrer + , unregisterCID = unregister + } getRegister :: Connection -> IO (CID -> Connection -> IO ()) getRegister Connection{..} = registerCID <$> readIORef roleInfo @@ -117,7 +125,7 @@ setTokenManager :: Connection -> CT.TokenManager -> IO () setTokenManager Connection{..} mgr = atomicModifyIORef'' roleInfo $ - \si -> si { tokenManager = mgr } + \si -> si{tokenManager = mgr} getTokenManager :: Connection -> IO CT.TokenManager getTokenManager Connection{..} = tokenManager <$> readIORef roleInfo @@ -126,7 +134,7 @@ setBaseThreadId :: Connection -> ThreadId -> IO () setBaseThreadId Connection{..} tid = atomicModifyIORef'' roleInfo $ - \si -> si { baseThreadId = tid } + \si -> si{baseThreadId = tid} getBaseThreadId :: Connection -> IO ThreadId getBaseThreadId Connection{..} = baseThreadId <$> readIORef roleInfo @@ -135,7 +143,7 @@ setCertificateChain :: Connection -> Maybe CertificateChain -> IO () setCertificateChain Connection{..} mcc = atomicModifyIORef'' roleInfo $ - \si -> si { certChain = mcc } + \si -> si{certChain = mcc} getCertificateChain :: Connection -> IO (Maybe CertificateChain) getCertificateChain Connection{..} = certChain <$> readIORef roleInfo diff --git a/Network/QUIC/Connection/State.hs b/Network/QUIC/Connection/State.hs --- a/Network/QUIC/Connection/State.hs +++ b/Network/QUIC/Connection/State.hs @@ -1,41 +1,36 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Connection.State ( - setConnection0RTTReady - , isConnection1RTTReady - , setConnection1RTTReady - , isConnectionEstablished - , setConnectionEstablished - , wait0RTTReady - , wait1RTTReady - , waitEstablished - , readConnectionFlowTx - , addTxData - , getTxData - , setTxMaxData - , getTxMaxData - , addRxData - , getRxData - , addRxMaxData - , getRxMaxData - , getRxDataWindow - , checkRxMaxData - , addTxBytes - , getTxBytes - , addRxBytes - , getRxBytes - , setAddressValidated - , waitAntiAmplificationFree - , checkAntiAmplificationFree - ) where + setConnection0RTTReady, + isConnection1RTTReady, + setConnection1RTTReady, + isConnectionEstablished, + setConnectionEstablished, + wait0RTTReady, + wait1RTTReady, + waitEstablished, + readConnectionFlowTx, + addTxData, + setTxMaxData, + getRxMaxData, + updateFlowRx, + checkRxMaxData, + addTxBytes, + getTxBytes, + addRxBytes, + getRxBytes, + setAddressValidated, + waitAntiAmplificationFree, + checkAntiAmplificationFree, +) where +import Network.Control import UnliftIO.STM import Network.QUIC.Connection.Types import Network.QUIC.Connector import Network.QUIC.Imports import Network.QUIC.Recovery -import Network.QUIC.Stream ---------------------------------------------------------------- @@ -84,7 +79,7 @@ ---------------------------------------------------------------- -readConnectionFlowTx :: Connection -> STM Flow +readConnectionFlowTx :: Connection -> STM TxFlow readConnectionFlowTx Connection{..} = readTVar flowTx ---------------------------------------------------------------- @@ -92,55 +87,27 @@ addTxData :: Connection -> Int -> STM () addTxData Connection{..} n = modifyTVar' flowTx add where - add flow = flow { flowData = flowData flow + n } - -getTxData :: Connection -> IO Int -getTxData Connection{..} = atomically $ flowData <$> readTVar flowTx + add flow = flow{txfSent = txfSent flow + n} setTxMaxData :: Connection -> Int -> IO () setTxMaxData Connection{..} n = atomically $ modifyTVar' flowTx set where set flow - | flowMaxData flow < n = flow { flowMaxData = n } - | otherwise = flow - -getTxMaxData :: Connection -> STM Int -getTxMaxData Connection{..} = flowMaxData <$> readTVar flowTx + | txfLimit flow < n = flow{txfLimit = n} + | otherwise = flow ---------------------------------------------------------------- -addRxData :: Connection -> Int -> IO () -addRxData Connection{..} n = atomicModifyIORef'' flowRx add - where - add flow = flow { flowData = flowData flow + n } - -getRxData :: Connection -> IO Int -getRxData Connection{..} = flowData <$> readIORef flowRx - -addRxMaxData :: Connection -> Int -> IO Int -addRxMaxData Connection{..} n = atomicModifyIORef' flowRx add - where - add flow = (flow { flowMaxData = m }, m) - where - m = flowMaxData flow + n - getRxMaxData :: Connection -> IO Int -getRxMaxData Connection{..} = flowMaxData <$> readIORef flowRx - -getRxDataWindow :: Connection -> IO Int -getRxDataWindow Connection{..} = flowWindow <$> readIORef flowRx +getRxMaxData Connection{..} = rxfLimit <$> readIORef flowRx ----------------------------------------------------------------- +updateFlowRx :: Connection -> Int -> IO (Maybe Int) +updateFlowRx Connection{..} consumed = + atomicModifyIORef' flowRx $ maybeOpenRxWindow consumed FCTMaxData checkRxMaxData :: Connection -> Int -> IO Bool -checkRxMaxData Connection{..} len = do - received <- readIORef flowBytesRx - maxData <- flowMaxData <$> readIORef flowRx - if received + len < maxData then do - modifyIORef' flowBytesRx (+ len) - return True - else - return False +checkRxMaxData Connection{..} len = + atomicModifyIORef' flowRx $ checkRxLimit len ---------------------------------------------------------------- @@ -168,17 +135,18 @@ unless ok $ do beforeAntiAmp connLDCC atomically (checkAntiAmplificationFreeSTM conn siz >>= checkSTM) - -- setLossDetectionTimer is called eventually. +-- setLossDetectionTimer is called eventually. + checkAntiAmplificationFreeSTM :: Connection -> Int -> STM Bool checkAntiAmplificationFreeSTM Connection{..} siz = do validated <- readTVar addressValidated - if validated then - return True - else do - tx <- readTVar bytesTx - rx <- readTVar bytesRx - return (tx + siz <= 3 * rx) + if validated + then return True + else do + tx <- readTVar bytesTx + rx <- readTVar bytesRx + return (tx + siz <= 3 * rx) checkAntiAmplificationFree :: Connection -> Int -> IO Bool checkAntiAmplificationFree conn siz = diff --git a/Network/QUIC/Connection/Stream.hs b/Network/QUIC/Connection/Stream.hs --- a/Network/QUIC/Connection/Stream.hs +++ b/Network/QUIC/Connection/Stream.hs @@ -3,15 +3,15 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Connection.Stream ( - getMyStreamId - , waitMyNewStreamId - , waitMyNewUniStreamId - , setTxMaxStreams - , setTxUniMaxStreams - , checkRxMaxStreams - , updatePeerStreamId - , checkStreamIdRoom - ) where + getMyStreamId, + waitMyNewStreamId, + waitMyNewUniStreamId, + setTxMaxStreams, + setTxUniMaxStreams, + checkRxMaxStreams, + updatePeerStreamId, + checkStreamIdRoom, +) where import UnliftIO.STM @@ -40,7 +40,7 @@ StreamIdBase base = maxStreams checkSTM (currentStream < base * 4 + streamType) let currentStream' = currentStream + 4 - writeTVar tvar conc { currentStream = currentStream' } + writeTVar tvar conc{currentStream = currentStream'} return currentStream -- From "Peer", but set it to "My". @@ -52,20 +52,26 @@ setTxUniMaxStreams Connection{..} = set myUniStreamId set :: TVar Concurrency -> Int -> IO () -set tvar mx = atomically $ modifyTVar tvar $ \c -> c { maxStreams = StreamIdBase mx } +set tvar mx = atomically $ modifyTVar tvar $ \c -> c{maxStreams = StreamIdBase mx} updatePeerStreamId :: Connection -> StreamId -> IO () updatePeerStreamId conn sid = do - when ((isClient conn && isServerInitiatedBidirectional sid) - || (isServer conn && isClientInitiatedBidirectional sid)) $ do - atomicModifyIORef'' (peerStreamId conn) check - when ((isClient conn && isServerInitiatedUnidirectional sid) - || (isServer conn && isClientInitiatedUnidirectional sid)) $ do - atomicModifyIORef'' (peerUniStreamId conn) check + when + ( (isClient conn && isServerInitiatedBidirectional sid) + || (isServer conn && isClientInitiatedBidirectional sid) + ) + $ do + atomicModifyIORef'' (peerStreamId conn) check + when + ( (isClient conn && isServerInitiatedUnidirectional sid) + || (isServer conn && isClientInitiatedUnidirectional sid) + ) + $ do + atomicModifyIORef'' (peerUniStreamId conn) check where check conc@Concurrency{..} - | currentStream < sid = conc { currentStream = sid } - | otherwise = conc + | currentStream < sid = conc{currentStream = sid} + | otherwise = conc checkRxMaxStreams :: Connection -> StreamId -> IO Bool checkRxMaxStreams conn@Connection{..} sid = do @@ -76,30 +82,31 @@ where streamType = sid .&. 0b11 readForClient = case streamType of - 0 -> readTVarIO myStreamId - 1 -> readIORef peerStreamId - 2 -> readTVarIO myUniStreamId - 3 -> readIORef peerUniStreamId - _ -> error "never reach" + 0 -> readTVarIO myStreamId + 1 -> readIORef peerStreamId + 2 -> readTVarIO myUniStreamId + 3 -> readIORef peerUniStreamId + _ -> error "never reach" readForServer = case streamType of - 0 -> readIORef peerStreamId - 1 -> readTVarIO myStreamId - 2 -> readIORef peerUniStreamId - 3 -> readTVarIO myUniStreamId - _ -> error "never reach" + 0 -> readIORef peerStreamId + 1 -> readTVarIO myStreamId + 2 -> readIORef peerUniStreamId + 3 -> readTVarIO myUniStreamId + _ -> error "never reach" checkStreamIdRoom :: Connection -> Direction -> IO (Maybe Int) checkStreamIdRoom conn dir = do - let ref | dir == Bidirectional = peerStreamId conn - | otherwise = peerUniStreamId conn + let ref + | dir == Bidirectional = peerStreamId conn + | otherwise = peerUniStreamId conn atomicModifyIORef' ref check where check conc@Concurrency{..} = let StreamIdBase base = maxStreams initialStreams = initialMaxStreamsBidi $ getMyParameters conn cbase = currentStream !>>. 2 - in if (base - cbase < (initialStreams !>>. 3)) then - let base' = base + initialStreams - in (conc { maxStreams = StreamIdBase base' }, Just base') - else - (conc, Nothing) + in if (base - cbase < (initialStreams !>>. 3)) + then + let base' = cbase + initialStreams + in (conc{maxStreams = StreamIdBase base'}, Just base') + else (conc, Nothing) diff --git a/Network/QUIC/Connection/StreamTable.hs b/Network/QUIC/Connection/StreamTable.hs --- a/Network/QUIC/Connection/StreamTable.hs +++ b/Network/QUIC/Connection/StreamTable.hs @@ -1,15 +1,15 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Connection.StreamTable ( - createStream - , findStream - , addStream - , delStream - , initialRxMaxStreamData - , setupCryptoStreams - , clearCryptoStream - , getCryptoStream - ) where + createStream, + findStream, + addStream, + delStream, + initialRxMaxStreamData, + setupCryptoStreams, + clearCryptoStream, + getCryptoStream, +) where import Network.QUIC.Connection.Misc import Network.QUIC.Connection.Queue @@ -22,26 +22,29 @@ createStream :: Connection -> StreamId -> IO Stream createStream conn sid = do - strm <- addStream conn sid - putInput conn $ InpStream strm - return strm + strm <- addStream conn sid + putInput conn $ InpStream strm + return strm findStream :: Connection -> StreamId -> IO (Maybe Stream) findStream Connection{..} sid = lookupStream sid <$> readIORef streamTable addStream :: Connection -> StreamId -> IO Stream addStream conn@Connection{..} sid = do - strm <- newStream conn sid - if isClient conn then do - let clientParams = getMyParameters conn - setRxMaxStreamData strm $ clientInitial sid clientParams - serverParams <- getPeerParameters conn - setTxMaxStreamData strm $ serverInitial sid serverParams - else do - let serverParams = getMyParameters conn - setRxMaxStreamData strm $ serverInitial sid serverParams - clientParams <- getPeerParameters conn - setTxMaxStreamData strm $ clientInitial sid clientParams + strm <- + if isClient conn + then do + serverParams <- getPeerParameters conn + let txLim = serverInitial sid serverParams + let clientParams = getMyParameters conn + rxLim = clientInitial sid clientParams + newStream conn sid txLim rxLim + else do + clientParams <- getPeerParameters conn + let txLim = clientInitial sid clientParams + serverParams = getMyParameters conn + rxLim = serverInitial sid serverParams + newStream conn sid txLim rxLim atomicModifyIORef'' streamTable $ insertStream sid strm return strm @@ -52,23 +55,23 @@ initialRxMaxStreamData :: Connection -> StreamId -> Int initialRxMaxStreamData conn sid | isClient conn = clientInitial sid params - | otherwise = serverInitial sid params + | otherwise = serverInitial sid params where params = getMyParameters conn clientInitial :: StreamId -> Parameters -> Int clientInitial sid params - | isClientInitiatedBidirectional sid = initialMaxStreamDataBidiLocal params - | isServerInitiatedBidirectional sid = initialMaxStreamDataBidiRemote params - -- intentionally not using isServerInitiatedUnidirectional - | otherwise = initialMaxStreamDataUni params + | isClientInitiatedBidirectional sid = initialMaxStreamDataBidiLocal params + | isServerInitiatedBidirectional sid = initialMaxStreamDataBidiRemote params + -- intentionally not using isServerInitiatedUnidirectional + | otherwise = initialMaxStreamDataUni params serverInitial :: StreamId -> Parameters -> Int serverInitial sid params - | isServerInitiatedBidirectional sid = initialMaxStreamDataBidiLocal params - | isClientInitiatedBidirectional sid = initialMaxStreamDataBidiRemote params - -- intentionally not using isClientInitiatedUnidirectional - | otherwise = initialMaxStreamDataUni params + | isServerInitiatedBidirectional sid = initialMaxStreamDataBidiLocal params + | isClientInitiatedBidirectional sid = initialMaxStreamDataBidiRemote params + -- intentionally not using isClientInitiatedUnidirectional + | otherwise = initialMaxStreamDataUni params ---------------------------------------------------------------- diff --git a/Network/QUIC/Connection/Timeout.hs b/Network/QUIC/Connection/Timeout.hs --- a/Network/QUIC/Connection/Timeout.hs +++ b/Network/QUIC/Connection/Timeout.hs @@ -1,14 +1,14 @@ module Network.QUIC.Connection.Timeout ( - timeout - , fire - , cfire - , delay - ) where + timeout, + fire, + cfire, + delay, +) where import Network.QUIC.Event +import qualified System.Timeout as ST import UnliftIO.Concurrent import qualified UnliftIO.Exception as E -import qualified System.Timeout as ST import Network.QUIC.Connection.Types import Network.QUIC.Connector diff --git a/Network/QUIC/Connection/Types.hs b/Network/QUIC/Connection/Types.hs --- a/Network/QUIC/Connection/Types.hs +++ b/Network/QUIC/Connection/Types.hs @@ -15,6 +15,7 @@ import Data.X509 (CertificateChain) import Foreign.Marshal.Alloc import Foreign.Ptr (nullPtr) +import Network.Control (Rate, RxFlow, TxFlow, newRate, newRxFlow, newTxFlow) import Network.TLS.QUIC import Network.UDP (UDPSocket) import UnliftIO.Concurrent @@ -38,133 +39,147 @@ ---------------------------------------------------------------- -data RoleInfo = ClientInfo { clientInitialToken :: Token -- new or retry token - , resumptionInfo :: ResumptionInfo - , incompatibleVN :: Bool - } - | ServerInfo { tokenManager :: ~CT.TokenManager - , registerCID :: CID -> Connection -> IO () - , unregisterCID :: CID -> IO () - , askRetry :: Bool - , baseThreadId :: ~ThreadId - , certChain :: Maybe CertificateChain - } +data RoleInfo + = ClientInfo + { clientInitialToken :: Token -- new or retry token + , resumptionInfo :: ResumptionInfo + , incompatibleVN :: Bool + } + | ServerInfo + { tokenManager :: ~CT.TokenManager + , registerCID :: CID -> Connection -> IO () + , unregisterCID :: CID -> IO () + , askRetry :: Bool + , baseThreadId :: ~ThreadId + , certChain :: Maybe CertificateChain + } defaultClientRoleInfo :: RoleInfo -defaultClientRoleInfo = ClientInfo { - clientInitialToken = emptyToken - , resumptionInfo = defaultResumptionInfo - , incompatibleVN = False - } +defaultClientRoleInfo = + ClientInfo + { clientInitialToken = emptyToken + , resumptionInfo = defaultResumptionInfo + , incompatibleVN = False + } defaultServerRoleInfo :: RoleInfo -defaultServerRoleInfo = ServerInfo { - tokenManager = undefined - , registerCID = \_ _ -> return () - , unregisterCID = \_ -> return () - , askRetry = False - , baseThreadId = undefined - , certChain = Nothing - } +defaultServerRoleInfo = + ServerInfo + { tokenManager = undefined + , registerCID = \_ _ -> return () + , unregisterCID = \_ -> return () + , askRetry = False + , baseThreadId = undefined + , certChain = Nothing + } -- fixme: limitation -data CIDDB = CIDDB { - usedCIDInfo :: CIDInfo - , cidInfos :: IntMap CIDInfo - , revInfos :: Map CID Int - , nextSeqNum :: Int -- only for mine (new) - , triggeredByMe :: Bool -- only for peer's - } deriving (Show) +data CIDDB = CIDDB + { usedCIDInfo :: CIDInfo + , cidInfos :: IntMap CIDInfo + , revInfos :: Map CID Int + , nextSeqNum :: Int -- only for mine (new) + , triggeredByMe :: Bool -- only for peer's + } + deriving (Show) newCIDDB :: CID -> CIDDB -newCIDDB cid = CIDDB { - usedCIDInfo = cidInfo - , cidInfos = IntMap.singleton 0 cidInfo - , revInfos = Map.singleton cid 0 - , nextSeqNum = 1 - , triggeredByMe = False - } +newCIDDB cid = + CIDDB + { usedCIDInfo = cidInfo + , cidInfos = IntMap.singleton 0 cidInfo + , revInfos = Map.singleton cid 0 + , nextSeqNum = 1 + , triggeredByMe = False + } where cidInfo = CIDInfo 0 cid (StatelessResetToken "") ---------------------------------------------------------------- -data MigrationState = NonMigration - | MigrationStarted - | SendChallenge [PathData] - | RecvResponse - deriving (Eq, Show) +data MigrationState + = NonMigration + | MigrationStarted + | SendChallenge [PathData] + | RecvResponse + deriving (Eq, Show) ---------------------------------------------------------------- -data Coder = Coder { - encrypt :: Buffer -> PlainText -> AssDat -> PacketNumber -> IO Int - , decrypt :: Buffer -> CipherText -> AssDat -> PacketNumber -> IO Int - , supplement :: Maybe Supplement - } +data Coder = Coder + { encrypt :: Buffer -> PlainText -> AssDat -> PacketNumber -> IO Int + , decrypt :: Buffer -> CipherText -> AssDat -> PacketNumber -> IO Int + , supplement :: Maybe Supplement + } initialCoder :: Coder -initialCoder = Coder { - encrypt = \_ _ _ _ -> return (-1) - , decrypt = \_ _ _ _ -> return (-1) - , supplement = Nothing - } +initialCoder = + Coder + { encrypt = \_ _ _ _ -> return (-1) + , decrypt = \_ _ _ _ -> return (-1) + , supplement = Nothing + } -data Coder1RTT = Coder1RTT { - coder1RTT :: Coder - , secretN :: TrafficSecrets ApplicationSecret - } +data Coder1RTT = Coder1RTT + { coder1RTT :: Coder + , secretN :: TrafficSecrets ApplicationSecret + } initialCoder1RTT :: Coder1RTT -initialCoder1RTT = Coder1RTT { - coder1RTT = initialCoder - , secretN = (ClientTrafficSecret "", ServerTrafficSecret "") - } +initialCoder1RTT = + Coder1RTT + { coder1RTT = initialCoder + , secretN = (ClientTrafficSecret "", ServerTrafficSecret "") + } -data Protector = Protector { - setSample :: Buffer -> IO () - , getMask :: IO Buffer - , unprotect :: Sample -> Mask - } +data Protector = Protector + { setSample :: Buffer -> IO () + , getMask :: IO Buffer + , unprotect :: Sample -> Mask + } initialProtector :: Protector -initialProtector = Protector { - setSample = \_ -> return () - , getMask = return nullPtr - , unprotect = \_ -> Mask "" - } +initialProtector = + Protector + { setSample = \_ -> return () + , getMask = return nullPtr + , unprotect = \_ -> Mask "" + } ---------------------------------------------------------------- -data Negotiated = Negotiated { - tlsHandshakeMode :: HandshakeMode13 +data Negotiated = Negotiated + { tlsHandshakeMode :: HandshakeMode13 , applicationProtocol :: Maybe NegotiatedProtocol , applicationSecretInfo :: ApplicationSecretInfo } initialNegotiated :: Negotiated -initialNegotiated = Negotiated { - tlsHandshakeMode = FullHandshake - , applicationProtocol = Nothing - , applicationSecretInfo = ApplicationSecretInfo defaultTrafficSecrets - } +initialNegotiated = + Negotiated + { tlsHandshakeMode = FullHandshake + , applicationProtocol = Nothing + , applicationSecretInfo = ApplicationSecretInfo defaultTrafficSecrets + } ---------------------------------------------------------------- -newtype StreamIdBase = StreamIdBase { fromStreamIdBase :: Int } +newtype StreamIdBase = StreamIdBase {fromStreamIdBase :: Int} deriving (Eq, Show) -data Concurrency = Concurrency { - currentStream :: StreamId - , maxStreams :: StreamIdBase - } +data Concurrency = Concurrency + { currentStream :: StreamId + , maxStreams :: StreamIdBase + } + deriving (Show) newConcurrency :: Role -> Direction -> Int -> Concurrency newConcurrency rl dir n = Concurrency ini $ StreamIdBase n - where - bidi = dir == Bidirectional - ini | rl == Client = if bidi then 0 else 2 - | otherwise = if bidi then 1 else 3 + where + bidi = dir == Bidirectional + ini + | rl == Client = if bidi then 0 else 2 + | otherwise = if bidi then 1 else 3 ---------------------------------------------------------------- @@ -174,81 +189,82 @@ ---------------------------------------------------------------- -- | A quic connection to carry multiple streams. -data Connection = Connection { - connState :: ConnState - -- Actions - , connDebugLog :: DebugLogger -- ^ A logger for debugging. - , connQLog :: QLogger - , connHooks :: Hooks - , connSend :: ~Send -- ~ for testing - , connRecv :: ~Recv -- ~ for testing - -- Manage - , connRecvQ :: RecvQ - , udpSocket :: ~(IORef UDPSocket) - , readers :: IORef (IO ()) - , mainThreadId :: ThreadId - -- Info - , roleInfo :: IORef RoleInfo - , quicVersionInfo :: IORef VersionInfo - , origVersionInfo :: VersionInfo -- chosenVersion is client's ver in Initial - -- Mine - , myParameters :: Parameters - , myCIDDB :: IORef CIDDB - -- Peer - , peerParameters :: IORef Parameters - , peerCIDDB :: TVar CIDDB - -- Queues - , inputQ :: InputQ - , cryptoQ :: CryptoQ - , outputQ :: OutputQ - , migrationQ :: MigrationQ - , shared :: Shared - , delayedAckCount :: IORef Int - , delayedAckCancel :: IORef (IO ()) - -- State - , peerPacketNumber :: IORef PacketNumber -- for RTT1 - , streamTable :: IORef StreamTable - , myStreamId :: TVar Concurrency -- C:0 S:1 - , myUniStreamId :: TVar Concurrency -- C:2 S:3 - , peerStreamId :: IORef Concurrency -- C:1 S:0 - , peerUniStreamId :: IORef Concurrency -- C:3 S:2 - , flowTx :: TVar Flow - , flowRx :: IORef Flow - , flowBytesRx :: IORef Int - , migrationState :: TVar MigrationState - , minIdleTimeout :: IORef Microseconds - , bytesTx :: TVar Int -- TVar for anti amplification - , bytesRx :: TVar Int -- TVar for anti amplification - , addressValidated :: TVar Bool - -- TLS - , pendingQ :: Array EncryptionLevel (TVar [ReceivedPacket]) - , ciphers :: IOArray EncryptionLevel Cipher - , coders :: IOArray EncryptionLevel Coder - , coders1RTT :: IOArray Bool Coder1RTT - , protectors :: IOArray EncryptionLevel Protector - , currentKeyPhase :: IORef (Bool, PacketNumber) - , negotiated :: IORef Negotiated - , connMyAuthCIDs :: IORef AuthCIDs - , connPeerAuthCIDs :: IORef AuthCIDs - -- Resources - , connResources :: IORef (IO ()) - , encodeBuf :: Buffer - , encryptRes :: SizedBuffer - , decryptBuf :: Buffer - -- Recovery - , connLDCC :: LDCC - } +data Connection = Connection + { connState :: ConnState + , -- Actions + connDebugLog :: DebugLogger + -- ^ A logger for debugging. + , connQLog :: QLogger + , connHooks :: Hooks + , connSend :: ~Send -- ~ for testing + , connRecv :: ~Recv -- ~ for testing + -- Manage + , connRecvQ :: RecvQ + , udpSocket :: ~(IORef UDPSocket) + , readers :: IORef (IO ()) + , mainThreadId :: ThreadId + , controlRate :: Rate + , -- Info + roleInfo :: IORef RoleInfo + , quicVersionInfo :: IORef VersionInfo + , origVersionInfo :: VersionInfo -- chosenVersion is client's ver in Initial + -- Mine + , myParameters :: Parameters + , myCIDDB :: IORef CIDDB + , -- Peer + peerParameters :: IORef Parameters + , peerCIDDB :: TVar CIDDB + , -- Queues + inputQ :: InputQ + , cryptoQ :: CryptoQ + , outputQ :: OutputQ + , migrationQ :: MigrationQ + , shared :: Shared + , delayedAckCount :: IORef Int + , delayedAckCancel :: IORef (IO ()) + , -- State + peerPacketNumber :: IORef PacketNumber -- for RTT1 + , streamTable :: IORef StreamTable + , myStreamId :: TVar Concurrency -- C:0 S:1 + , myUniStreamId :: TVar Concurrency -- C:2 S:3 + , peerStreamId :: IORef Concurrency -- C:1 S:0 + , peerUniStreamId :: IORef Concurrency -- C:3 S:2 + , flowTx :: TVar TxFlow + , flowRx :: IORef RxFlow + , migrationState :: TVar MigrationState + , minIdleTimeout :: IORef Microseconds + , bytesTx :: TVar Int -- TVar for anti amplification + , bytesRx :: TVar Int -- TVar for anti amplification + , addressValidated :: TVar Bool + , -- TLS + pendingQ :: Array EncryptionLevel (TVar [ReceivedPacket]) + , ciphers :: IOArray EncryptionLevel Cipher + , coders :: IOArray EncryptionLevel Coder + , coders1RTT :: IOArray Bool Coder1RTT + , protectors :: IOArray EncryptionLevel Protector + , currentKeyPhase :: IORef (Bool, PacketNumber) + , negotiated :: IORef Negotiated + , connMyAuthCIDs :: IORef AuthCIDs + , connPeerAuthCIDs :: IORef AuthCIDs + , -- Resources + connResources :: IORef (IO ()) + , encodeBuf :: Buffer + , encryptRes :: SizedBuffer + , decryptBuf :: Buffer + , -- Recovery + connLDCC :: LDCC + } instance KeepQlog Connection where keepQlog conn = connQLog conn instance Connector Connection where - getRole = role . connState + getRole = role . connState getEncryptionLevel = readTVarIO . encryptionLevel . connState - getMaxPacketSize = readIORef . maxPacketSize . connState + getMaxPacketSize = readIORef . maxPacketSize . connState getConnectionState = readTVarIO . connectionState . connState - getPacketNumber = readIORef . packetNumber . connState - getAlive = readIORef . connectionAlive . connState + getPacketNumber = readIORef . packetNumber . connState + getAlive = readIORef . connectionAlive . connState setDead :: Connection -> IO () setDead conn = writeIORef (connectionAlive $ connState conn) False @@ -258,30 +274,36 @@ q1 <- newTVarIO [] q2 <- newTVarIO [] q3 <- newTVarIO [] - let lst = [(RTT0Level,q1),(HandshakeLevel,q2),(RTT1Level,q3)] - arr = array (RTT0Level,RTT1Level) lst + let lst = [(RTT0Level, q1), (HandshakeLevel, q2), (RTT1Level, q3)] + arr = array (RTT0Level, RTT1Level) lst return arr -newConnection :: Role - -> Parameters - -> VersionInfo -> AuthCIDs -> AuthCIDs - -> DebugLogger -> QLogger -> Hooks - -> IORef UDPSocket - -> RecvQ - -> Send - -> Recv - -> IO Connection +newConnection + :: Role + -> Parameters + -> VersionInfo + -> AuthCIDs + -> AuthCIDs + -> DebugLogger + -> QLogger + -> Hooks + -> IORef UDPSocket + -> RecvQ + -> Send + -> Recv + -> IO Connection newConnection rl myparams verInfo myAuthCIDs peerAuthCIDs debugLog qLog hooks sref recvQ ~send ~recv = do outQ <- newTQueueIO let put x = atomically $ writeTQueue outQ $ OutRetrans x connstate <- newConnState rl let bufsiz = maximumUdpPayloadSize - encBuf <- mallocBytes bufsiz + encBuf <- mallocBytes bufsiz ecrptBuf <- mallocBytes bufsiz dcrptBuf <- mallocBytes bufsiz Connection connstate debugLog qLog hooks send recv recvQ sref <$> newIORef (return ()) <*> myThreadId + <*> newRate -- Info <*> newIORef initialRoleInfo <*> newIORef verInfo @@ -303,13 +325,12 @@ -- State <*> newIORef 0 <*> newIORef emptyStreamTable - <*> newTVarIO (newConcurrency rl Bidirectional 0) + <*> newTVarIO (newConcurrency rl Bidirectional 0) <*> newTVarIO (newConcurrency rl Unidirectional 0) - <*> newIORef peerConcurrency - <*> newIORef peerUniConcurrency - <*> newTVarIO defaultFlow - <*> newIORef defaultFlow { flowMaxData = initialMaxData myparams } - <*> newIORef 0 + <*> newIORef peerConcurrency + <*> newIORef peerUniConcurrency + <*> newTVarIO (newTxFlow 0) -- limit is set in Handshake + <*> newIORef (newRxFlow $ initialMaxData myparams) <*> newTVarIO NonMigration <*> newIORef (milliToMicro $ maxIdleTimeout myparams) <*> newTVarIO 0 @@ -317,17 +338,17 @@ <*> newTVarIO False -- TLS <*> makePendingQ - <*> newArray (InitialLevel,RTT1Level) defaultCipher - <*> newArray (InitialLevel,HandshakeLevel) initialCoder - <*> newArray (False,True) initialCoder1RTT - <*> newArray (InitialLevel,RTT1Level) initialProtector - <*> newIORef (False,0) + <*> newArray (InitialLevel, RTT1Level) defaultCipher + <*> newArray (InitialLevel, HandshakeLevel) initialCoder + <*> newArray (False, True) initialCoder1RTT + <*> newArray (InitialLevel, RTT1Level) initialProtector + <*> newIORef (False, 0) <*> newIORef initialNegotiated <*> newIORef myAuthCIDs <*> newIORef peerAuthCIDs -- Resources <*> newIORef (free encBuf >> free ecrptBuf >> free dcrptBuf) - <*> return encBuf -- used sender or closere + <*> return encBuf -- used sender or closere <*> return (SizedBuffer ecrptBuf bufsiz) -- used sender <*> return dcrptBuf -- used receiver -- Recovery @@ -335,12 +356,13 @@ where isclient = rl == Client initialRoleInfo - | isclient = defaultClientRoleInfo - | otherwise = defaultServerRoleInfo - myCID = fromJust $ initSrcCID myAuthCIDs + | isclient = defaultClientRoleInfo + | otherwise = defaultServerRoleInfo + myCID = fromJust $ initSrcCID myAuthCIDs peerCID = fromJust $ initSrcCID peerAuthCIDs - peer | isclient = Server - | otherwise = Client + peer + | isclient = Server + | otherwise = Client peerConcurrency = newConcurrency peer Bidirectional (initialMaxStreamsBidi myparams) peerUniConcurrency = newConcurrency peer Unidirectional (initialMaxStreamsUni myparams) @@ -349,34 +371,49 @@ ---------------------------------------------------------------- -clientConnection :: ClientConfig - -> VersionInfo -> AuthCIDs -> AuthCIDs - -> DebugLogger -> QLogger -> Hooks - -> IORef UDPSocket - -> RecvQ -> Send -> Recv - -> IO Connection +clientConnection + :: ClientConfig + -> VersionInfo + -> AuthCIDs + -> AuthCIDs + -> DebugLogger + -> QLogger + -> Hooks + -> IORef UDPSocket + -> RecvQ + -> Send + -> Recv + -> IO Connection clientConnection ClientConfig{..} verInfo myAuthCIDs peerAuthCIDs = newConnection Client ccParameters verInfo myAuthCIDs peerAuthCIDs -serverConnection :: ServerConfig - -> VersionInfo -> AuthCIDs -> AuthCIDs - -> DebugLogger -> QLogger -> Hooks - -> IORef UDPSocket - -> RecvQ -> Send -> Recv - -> IO Connection +serverConnection + :: ServerConfig + -> VersionInfo + -> AuthCIDs + -> AuthCIDs + -> DebugLogger + -> QLogger + -> Hooks + -> IORef UDPSocket + -> RecvQ + -> Send + -> Recv + -> IO Connection serverConnection ServerConfig{..} verInfo myAuthCIDs peerAuthCIDs = newConnection Server scParameters verInfo myAuthCIDs peerAuthCIDs ---------------------------------------------------------------- -newtype Input = InpStream Stream deriving Show -data Crypto = InpHandshake EncryptionLevel ByteString deriving Show +newtype Input = InpStream Stream deriving (Show) +data Crypto = InpHandshake EncryptionLevel ByteString deriving (Show) -data Output = OutControl EncryptionLevel [Frame] (IO ()) - | OutHandshake [(EncryptionLevel,ByteString)] - | OutRetrans PlainPacket +data Output + = OutControl EncryptionLevel [Frame] (IO ()) + | OutHandshake [(EncryptionLevel, ByteString)] + | OutRetrans PlainPacket -type InputQ = TQueue Input +type InputQ = TQueue Input type CryptoQ = TQueue Crypto type OutputQ = TQueue Output type MigrationQ = TQueue ReceivedPacket @@ -385,15 +422,17 @@ type SendStreamQ = TQueue TxStreamData -data Shared = Shared { - sharedCloseSent :: IORef Bool - , sharedCloseReceived :: IORef Bool - , shared1RTTReady :: IORef Bool - , sharedSendStreamQ :: SendStreamQ - } +data Shared = Shared + { sharedCloseSent :: IORef Bool + , sharedCloseReceived :: IORef Bool + , shared1RTTReady :: IORef Bool + , sharedSendStreamQ :: SendStreamQ + } newShared :: IO Shared -newShared = Shared <$> newIORef False - <*> newIORef False - <*> newIORef False - <*> newTQueueIO +newShared = + Shared + <$> newIORef False + <*> newIORef False + <*> newIORef False + <*> newTQueueIO diff --git a/Network/QUIC/Connector.hs b/Network/QUIC/Connector.hs --- a/Network/QUIC/Connector.hs +++ b/Network/QUIC/Connector.hs @@ -5,34 +5,35 @@ import UnliftIO.STM class Connector a where - getRole :: a -> Role + getRole :: a -> Role getEncryptionLevel :: a -> IO EncryptionLevel - getMaxPacketSize :: a -> IO Int + getMaxPacketSize :: a -> IO Int getConnectionState :: a -> IO ConnectionState - getPacketNumber :: a -> IO PacketNumber - getAlive :: a -> IO Bool + getPacketNumber :: a -> IO PacketNumber + getAlive :: a -> IO Bool ---------------------------------------------------------------- -data ConnState = ConnState { - role :: Role - , connectionState :: TVar ConnectionState - , packetNumber :: IORef PacketNumber -- squeezing three to one - , encryptionLevel :: TVar EncryptionLevel -- to synchronize - , maxPacketSize :: IORef Int - -- Explicitly separated from 'ConnectionState' - -- It seems that STM triggers a dead-lock if - -- it is used in the close function of bracket. - , connectionAlive :: IORef Bool - } +data ConnState = ConnState + { role :: Role + , connectionState :: TVar ConnectionState + , packetNumber :: IORef PacketNumber -- squeezing three to one + , encryptionLevel :: TVar EncryptionLevel -- to synchronize + , maxPacketSize :: IORef Int + , -- Explicitly separated from 'ConnectionState' + -- It seems that STM triggers a dead-lock if + -- it is used in the close function of bracket. + connectionAlive :: IORef Bool + } newConnState :: Role -> IO ConnState newConnState rl = - ConnState rl <$> newTVarIO Handshaking - <*> newIORef 0 - <*> newTVarIO InitialLevel - <*> newIORef defaultQUICPacketSize - <*> newIORef True + ConnState rl + <$> newTVarIO Handshaking + <*> newIORef 0 + <*> newTVarIO InitialLevel + <*> newIORef defaultQUICPacketSize + <*> newIORef True ---------------------------------------------------------------- @@ -46,15 +47,16 @@ ---------------------------------------------------------------- -data ConnectionState = Handshaking - | ReadyFor0RTT - | ReadyFor1RTT - | Established - deriving (Eq, Ord, Show) +data ConnectionState + = Handshaking + | ReadyFor0RTT + | ReadyFor1RTT + | Established + deriving (Eq, Ord, Show) isConnectionEstablished :: Connector a => a -> IO Bool isConnectionEstablished conn = do st <- getConnectionState conn return $ case st of - Established -> True - _ -> False + Established -> True + _ -> False diff --git a/Network/QUIC/Crypto.hs b/Network/QUIC/Crypto.hs --- a/Network/QUIC/Crypto.hs +++ b/Network/QUIC/Crypto.hs @@ -2,12 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Crypto ( - module Network.QUIC.Crypto.Fusion - , module Network.QUIC.Crypto.Nite - , module Network.QUIC.Crypto.Types - , module Network.QUIC.Crypto.Keys - , module Network.QUIC.Crypto.Utils - ) where + module Network.QUIC.Crypto.Fusion, + module Network.QUIC.Crypto.Nite, + module Network.QUIC.Crypto.Types, + module Network.QUIC.Crypto.Keys, + module Network.QUIC.Crypto.Utils, +) where import Network.TLS hiding (Version) import Network.TLS.QUIC diff --git a/Network/QUIC/Crypto/Fusion.hs b/Network/QUIC/Crypto/Fusion.hs --- a/Network/QUIC/Crypto/Fusion.hs +++ b/Network/QUIC/Crypto/Fusion.hs @@ -1,17 +1,17 @@ {-# LANGUAGE CPP #-} module Network.QUIC.Crypto.Fusion ( - FusionContext - , fusionNewContext - , fusionSetup - , fusionEncrypt - , fusionDecrypt - , Supplement - , fusionSetupSupplement - , fusionSetSample - , fusionGetMask - , isFusionAvailable - ) where + FusionContext, + fusionNewContext, + fusionSetup, + fusionEncrypt, + fusionDecrypt, + Supplement, + fusionSetupSupplement, + fusionSetSample, + fusionGetMask, + isFusionAvailable, +) where #ifdef USE_FUSION import qualified Data.ByteString as BS diff --git a/Network/QUIC/Crypto/Keys.hs b/Network/QUIC/Crypto/Keys.hs --- a/Network/QUIC/Crypto/Keys.hs +++ b/Network/QUIC/Crypto/Keys.hs @@ -2,15 +2,15 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Crypto.Keys ( - defaultCipher - , initialSecrets - , clientInitialSecret - , serverInitialSecret - , aeadKey - , initialVector - , nextSecret - , headerProtectionKey - ) where + defaultCipher, + initialSecrets, + clientInitialSecret, + serverInitialSecret, + aeadKey, + initialVector, + nextSecret, + headerProtectionKey, +) where import Network.TLS hiding (Version) import Network.TLS.Extra.Cipher @@ -29,9 +29,12 @@ ---------------------------------------------------------------- initialSalt :: Version -> Salt -initialSalt Draft29 = "\xaf\xbf\xec\x28\x99\x93\xd2\x4c\x9e\x97\x86\xf1\x9c\x61\x11\xe0\x43\x90\xa8\x99" -initialSalt Version1 = "\x38\x76\x2c\xf7\xf5\x59\x34\xb3\x4d\x17\x9a\xe6\xa4\xc8\x0c\xad\xcc\xbb\x7f\x0a" -initialSalt Version2 = "\x0d\xed\xe3\xde\xf7\x00\xa6\xdb\x81\x93\x81\xbe\x6e\x26\x9d\xcb\xf9\xbd\x2e\xd9" +initialSalt Draft29 = + "\xaf\xbf\xec\x28\x99\x93\xd2\x4c\x9e\x97\x86\xf1\x9c\x61\x11\xe0\x43\x90\xa8\x99" +initialSalt Version1 = + "\x38\x76\x2c\xf7\xf5\x59\x34\xb3\x4d\x17\x9a\xe6\xa4\xc8\x0c\xad\xcc\xbb\x7f\x0a" +initialSalt Version2 = + "\x0d\xed\xe3\xde\xf7\x00\xa6\xdb\x81\x93\x81\xbe\x6e\x26\x9d\xcb\xf9\xbd\x2e\xd9" initialSalt (Version v) = E.impureThrow $ VersionIsUnknown v initialSecrets :: Version -> CID -> TrafficSecrets InitialSecret @@ -44,65 +47,65 @@ serverInitialSecret v c = ServerTrafficSecret $ initialSecret v c $ Label "server in" initialSecret :: Version -> CID -> Label -> ByteString -initialSecret Draft29 = initialSecret' $ initialSalt Draft29 +initialSecret Draft29 = initialSecret' $ initialSalt Draft29 initialSecret Version1 = initialSecret' $ initialSalt Version1 initialSecret Version2 = initialSecret' $ initialSalt Version2 -initialSecret _ = \_ _ -> "not supported" +initialSecret _ = \_ _ -> "not supported" initialSecret' :: ByteString -> CID -> Label -> ByteString initialSecret' salt cid (Label label) = secret where - cipher = defaultCipher - hash = cipherHash cipher + cipher = defaultCipher + hash = cipherHash cipher iniSecret = hkdfExtract hash salt $ fromCID cid - hashSize = hashDigestSize hash - secret = hkdfExpandLabel hash iniSecret label "" hashSize + hashSize = hashDigestSize hash + secret = hkdfExpandLabel hash iniSecret label "" hashSize aeadKey :: Version -> Cipher -> Secret -> Key -aeadKey Draft29 = genKey $ Label "quic key" +aeadKey Draft29 = genKey $ Label "quic key" aeadKey Version1 = genKey $ Label "quic key" aeadKey Version2 = genKey $ Label "quicv2 key" -aeadKey _ = genKey $ Label "not supported" +aeadKey _ = genKey $ Label "not supported" headerProtectionKey :: Version -> Cipher -> Secret -> Key -headerProtectionKey Draft29 = genKey $ Label "quic hp" +headerProtectionKey Draft29 = genKey $ Label "quic hp" headerProtectionKey Version1 = genKey $ Label "quic hp" headerProtectionKey Version2 = genKey $ Label "quicv2 hp" -headerProtectionKey _ = genKey $ Label "not supported" +headerProtectionKey _ = genKey $ Label "not supported" genKey :: Label -> Cipher -> Secret -> Key genKey (Label label) cipher (Secret secret) = Key key where - hash = cipherHash cipher - bulk = cipherBulk cipher + hash = cipherHash cipher + bulk = cipherBulk cipher keySize = bulkKeySize bulk - key = hkdfExpandLabel hash secret label "" keySize + key = hkdfExpandLabel hash secret label "" keySize initialVector :: Version -> Cipher -> Secret -> IV initialVector ver cipher (Secret secret) = IV iv where - label = ivLabel ver - hash = cipherHash cipher - bulk = cipherBulk cipher + label = ivLabel ver + hash = cipherHash cipher + bulk = cipherBulk cipher ivSize = max 8 (bulkIVSize bulk + bulkExplicitIV bulk) - iv = hkdfExpandLabel hash secret label "" ivSize + iv = hkdfExpandLabel hash secret label "" ivSize ivLabel :: Version -> ByteString -ivLabel Draft29 = "quic iv" +ivLabel Draft29 = "quic iv" ivLabel Version1 = "quic iv" ivLabel Version2 = "quicv2 iv" -ivLabel _ = "not supported" +ivLabel _ = "not supported" nextSecret :: Version -> Cipher -> Secret -> Secret nextSecret ver cipher (Secret secN) = Secret secN1 where - label = kuLabel ver - hash = cipherHash cipher + label = kuLabel ver + hash = cipherHash cipher hashSize = hashDigestSize hash - secN1 = hkdfExpandLabel hash secN label "" hashSize + secN1 = hkdfExpandLabel hash secN label "" hashSize kuLabel :: Version -> ByteString -kuLabel Draft29 = "quic ku" +kuLabel Draft29 = "quic ku" kuLabel Version1 = "quic ku" kuLabel Version2 = "quicv2 ku" -kuLabel _ = "not supported" +kuLabel _ = "not supported" diff --git a/Network/QUIC/Crypto/Nite.hs b/Network/QUIC/Crypto/Nite.hs --- a/Network/QUIC/Crypto/Nite.hs +++ b/Network/QUIC/Crypto/Nite.hs @@ -2,17 +2,17 @@ {-# LANGUAGE ScopedTypeVariables #-} module Network.QUIC.Crypto.Nite ( - niteEncrypt - , niteEncrypt' - , niteDecrypt - , niteDecrypt' - , protectionMask - , aes128gcmEncrypt - , makeNonce - , makeNiteEncrypt - , makeNiteDecrypt - , makeNiteProtector - ) where + niteEncrypt, + niteEncrypt', + niteDecrypt, + niteDecrypt', + protectionMask, + aes128gcmEncrypt, + makeNonce, + makeNiteEncrypt, + makeNiteDecrypt, + makeNiteProtector, +) where import Crypto.Cipher.AES import Crypto.Cipher.Types hiding (Cipher, IV) @@ -20,10 +20,10 @@ import qualified Data.ByteArray as Byte (convert) import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS -import Foreign.ForeignPtr (withForeignPtr, newForeignPtr_) +import Foreign.ForeignPtr (newForeignPtr_, withForeignPtr) import Foreign.Marshal.Alloc (mallocBytes) import Foreign.Marshal.Utils (copyBytes) -import Foreign.Ptr (Ptr, plusPtr, nullPtr) +import Foreign.Ptr (Ptr, nullPtr, plusPtr) import Foreign.Storable (peek, poke) import Network.TLS hiding (Version) import Network.TLS.Extra.Cipher @@ -37,64 +37,70 @@ -- It would be nice to take [PlainText] and update AEAD context with -- [PlainText]. But since each PlainText is not aligned to cipher block, -- it's impossible. -cipherEncrypt :: Cipher -> Key -> Nonce -> PlainText -> AssDat -> Maybe (CipherText,CipherText) +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 - | otherwise = error "cipherEncrypt" + | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128gcmEncrypt + | cipher == cipher_TLS13_AES128CCM_SHA256 = + error "cipher_TLS13_AES128CCM_SHA256" + | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256gcmEncrypt + | otherwise = error "cipherEncrypt" -cipherDecrypt :: Cipher -> Key -> Nonce -> CipherText -> AssDat -> Maybe PlainText +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 - | otherwise = error "cipherDecrypt" + | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128gcmDecrypt + | cipher == cipher_TLS13_AES128CCM_SHA256 = + error "cipher_TLS13_AES128CCM_SHA256" + | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256gcmDecrypt + | otherwise = error "cipherDecrypt" -- IMPORTANT: Using 'let' so that parameters can be memorized. -aes128gcmEncrypt :: Key -> (Nonce -> PlainText -> AssDat -> Maybe (CipherText,CipherText)) +aes128gcmEncrypt + :: Key -> (Nonce -> PlainText -> AssDat -> Maybe (CipherText, CipherText)) aes128gcmEncrypt (Key key) = case maybeCryptoError $ cipherInit key of - Nothing -> \_ _ _ -> Nothing - Just (aes :: AES128) -> \(Nonce nonce) plaintext (AssDat ad) -> - case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of - Nothing -> Nothing - Just aead -> - let (AuthTag tag0, ciphertext) = aeadSimpleEncrypt aead ad plaintext 16 - tag = Byte.convert tag0 - in Just (ciphertext,tag) + Nothing -> \_ _ _ -> Nothing + Just (aes :: AES128) -> \(Nonce nonce) plaintext (AssDat ad) -> + case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of + Nothing -> Nothing + Just aead -> + let (AuthTag tag0, ciphertext) = aeadSimpleEncrypt aead ad plaintext 16 + tag = Byte.convert tag0 + in Just (ciphertext, tag) aes128gcmDecrypt :: Key -> (Nonce -> CipherText -> AssDat -> Maybe PlainText) aes128gcmDecrypt (Key key) = case maybeCryptoError $ cipherInit key of - Nothing -> \_ _ _ -> Nothing - Just (aes :: AES128) -> \(Nonce nonce) ciphertag (AssDat ad) -> - case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of - Nothing -> Nothing - Just aead -> - let (ciphertext, tag) = BS.splitAt (BS.length ciphertag - 16) ciphertag - authtag = AuthTag $ Byte.convert tag - in aeadSimpleDecrypt aead ad ciphertext authtag + Nothing -> \_ _ _ -> Nothing + Just (aes :: AES128) -> \(Nonce nonce) ciphertag (AssDat ad) -> + case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of + Nothing -> Nothing + Just aead -> + let (ciphertext, tag) = BS.splitAt (BS.length ciphertag - 16) ciphertag + authtag = AuthTag $ Byte.convert tag + in aeadSimpleDecrypt aead ad ciphertext authtag -aes256gcmEncrypt :: Key -> (Nonce -> PlainText -> AssDat -> Maybe (CipherText,CipherText)) +aes256gcmEncrypt + :: Key -> (Nonce -> PlainText -> AssDat -> Maybe (CipherText, CipherText)) aes256gcmEncrypt (Key key) = case maybeCryptoError $ cipherInit key of - Nothing -> \_ _ _ -> Nothing - Just (aes :: AES256) -> \(Nonce nonce) plaintext (AssDat ad) -> - case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of - Nothing -> Nothing - Just aead -> - let (AuthTag tag0, ciphertext) = aeadSimpleEncrypt aead ad plaintext 16 - tag = Byte.convert tag0 - in Just (ciphertext,tag) + Nothing -> \_ _ _ -> Nothing + Just (aes :: AES256) -> \(Nonce nonce) plaintext (AssDat ad) -> + case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of + Nothing -> Nothing + Just aead -> + let (AuthTag tag0, ciphertext) = aeadSimpleEncrypt aead ad plaintext 16 + tag = Byte.convert tag0 + in Just (ciphertext, tag) aes256gcmDecrypt :: Key -> (Nonce -> CipherText -> AssDat -> Maybe PlainText) aes256gcmDecrypt (Key key) = case maybeCryptoError $ cipherInit key of - Nothing -> \_ _ _ -> Nothing - Just (aes :: AES256) -> \(Nonce nonce) ciphertag (AssDat ad) -> - case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of - Nothing -> Nothing - Just aead -> - let (ciphertext, tag) = BS.splitAt (BS.length ciphertag - 16) ciphertag - authtag = AuthTag $ Byte.convert tag - in aeadSimpleDecrypt aead ad ciphertext authtag + Nothing -> \_ _ _ -> Nothing + Just (aes :: AES256) -> \(Nonce nonce) ciphertag (AssDat ad) -> + case maybeCryptoError $ aeadInit AEAD_GCM aes nonce of + Nothing -> Nothing + Just aead -> + let (ciphertext, tag) = BS.splitAt (BS.length ciphertag - 16) ciphertag + authtag = AuthTag $ Byte.convert tag + in aeadSimpleDecrypt aead ad ciphertext authtag ---------------------------------------------------------------- @@ -112,15 +118,15 @@ -- Nonce +IIIIIIIIIIIIIIIIII--------+ bsXORpad :: ByteString -> ByteString -> ByteString bsXORpad (PS fp0 off0 len0) (PS fp1 off1 len1) - | len0 < len1 = error "bsXORpad" - | otherwise = BS.unsafeCreate len0 $ \dst -> - withForeignPtr fp0 $ \p0 -> - withForeignPtr fp1 $ \p1 -> do - let src0 = p0 `plusPtr` off0 - let src1 = p1 `plusPtr` off1 - let diff = len0 - len1 - copyBytes dst src0 diff - loop (dst `plusPtr` diff) (src0 `plusPtr` diff) src1 len1 + | len0 < len1 = error "bsXORpad" + | otherwise = BS.unsafeCreate len0 $ \dst -> + withForeignPtr fp0 $ \p0 -> + withForeignPtr fp1 $ \p1 -> do + let src0 = p0 `plusPtr` off0 + let src1 = p1 `plusPtr` off1 + let diff = len0 - len1 + copyBytes dst src0 diff + loop (dst `plusPtr` diff) (src0 `plusPtr` diff) src1 len1 where loop :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Int -> IO () loop _ _ _ 0 = return () @@ -146,25 +152,35 @@ makeNiteEncrypt :: Cipher -> Key -> IV -> NiteEncrypt makeNiteEncrypt cipher key iv = niteEncryptWrapper (niteEncrypt cipher key iv) -niteEncryptWrapper :: (PlainText -> AssDat -> PacketNumber -> Maybe (CipherText,CipherText)) -> NiteEncrypt +niteEncryptWrapper + :: (PlainText -> AssDat -> PacketNumber -> Maybe (CipherText, CipherText)) + -> NiteEncrypt niteEncryptWrapper enc dst plaintext ad pn = case enc plaintext ad pn of Nothing -> return (-1) - Just (hdr,bdy) -> do + Just (hdr, bdy) -> do len <- copyBS dst hdr let dst' = dst `plusPtr` len len' <- copyBS dst' bdy return (len + len') -niteEncrypt :: Cipher -> Key -> IV - -> PlainText -> AssDat -> PacketNumber -> Maybe (CipherText,CipherText) +niteEncrypt + :: Cipher + -> Key + -> IV + -> PlainText + -> AssDat + -> PacketNumber + -> Maybe (CipherText, CipherText) niteEncrypt cipher key iv = let enc = cipherEncrypt cipher key - mk = makeNonce iv - in \plaintext header pn -> let bytePN = bytestring64 $ fromIntegral pn - nonce = mk bytePN - in enc nonce plaintext header + mk = makeNonce iv + in \plaintext header pn -> + let bytePN = bytestring64 $ fromIntegral pn + nonce = mk bytePN + in enc nonce plaintext header -niteEncrypt' :: Cipher -> Key -> Nonce -> PlainText -> AssDat -> Maybe (CipherText,CipherText) +niteEncrypt' + :: Cipher -> Key -> Nonce -> PlainText -> AssDat -> Maybe (CipherText, CipherText) niteEncrypt' cipher key nonce plaintext header = cipherEncrypt cipher key nonce plaintext header @@ -175,21 +191,30 @@ makeNiteDecrypt :: Cipher -> Key -> IV -> NiteDecrypt makeNiteDecrypt cipher key iv = niteDecryptWrapper (niteDecrypt cipher key iv) -niteDecryptWrapper :: (CipherText -> AssDat -> PacketNumber -> Maybe PlainText) -> NiteDecrypt +niteDecryptWrapper + :: (CipherText -> AssDat -> PacketNumber -> Maybe PlainText) -> NiteDecrypt niteDecryptWrapper dec dst ciphertext ad pn = case dec ciphertext ad pn of - Nothing -> return (-1) - Just bs -> copyBS dst bs + Nothing -> return (-1) + Just bs -> copyBS dst bs -niteDecrypt :: Cipher -> Key -> IV - -> CipherText -> AssDat -> PacketNumber -> Maybe PlainText +niteDecrypt + :: Cipher + -> Key + -> IV + -> CipherText + -> AssDat + -> PacketNumber + -> Maybe PlainText niteDecrypt cipher key iv = let dec = cipherDecrypt cipher key - mk = makeNonce iv - in \ciphertext header pn -> let bytePN = bytestring64 (fromIntegral pn) - nonce = mk bytePN - in dec nonce ciphertext header + mk = makeNonce iv + in \ciphertext header pn -> + let bytePN = bytestring64 (fromIntegral pn) + nonce = mk bytePN + in dec nonce ciphertext header -niteDecrypt' :: Cipher -> Key -> Nonce -> CipherText -> AssDat -> Maybe PlainText +niteDecrypt' + :: Cipher -> Key -> Nonce -> CipherText -> AssDat -> Maybe PlainText niteDecrypt' cipher key nonce ciphertext header = cipherDecrypt cipher key nonce ciphertext header @@ -198,30 +223,34 @@ protectionMask :: Cipher -> Key -> (Sample -> Mask) protectionMask cipher key = let f = cipherHeaderProtection cipher key - in \sample -> f sample + in \sample -> f sample 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 - | otherwise = error "cipherHeaderProtection" + | cipher == cipher_TLS13_AES128GCM_SHA256 = aes128ecbEncrypt key + | cipher == cipher_TLS13_AES128CCM_SHA256 = + error "cipher_TLS13_AES128CCM_SHA256" + | cipher == cipher_TLS13_AES256GCM_SHA384 = aes256ecbEncrypt key + | otherwise = + error "cipherHeaderProtection" aes128ecbEncrypt :: Key -> (Sample -> Mask) aes128ecbEncrypt (Key key) = case maybeCryptoError $ cipherInit key of - Nothing -> \_ -> Mask "0123456789012345" - Just (aes :: AES128) -> - let encrypt = ecbEncrypt aes - in \(Sample sample) -> let mask = encrypt sample - in Mask mask + Nothing -> \_ -> Mask "0123456789012345" + Just (aes :: AES128) -> + let encrypt = ecbEncrypt aes + in \(Sample sample) -> + let mask = encrypt sample + in Mask mask aes256ecbEncrypt :: Key -> (Sample -> Mask) aes256ecbEncrypt (Key key) = case maybeCryptoError $ cipherInit key of - Nothing -> \_ -> Mask "0123456789012345" - Just (aes :: AES256) -> - let encrypt = ecbEncrypt aes - in \(Sample sample) -> let mask = encrypt sample - in Mask mask + Nothing -> \_ -> Mask "0123456789012345" + Just (aes :: AES256) -> + let encrypt = ecbEncrypt aes + in \(Sample sample) -> + let mask = encrypt sample + in Mask mask ---------------------------------------------------------------- diff --git a/Network/QUIC/Crypto/Types.hs b/Network/QUIC/Crypto/Types.hs --- a/Network/QUIC/Crypto/Types.hs +++ b/Network/QUIC/Crypto/Types.hs @@ -1,23 +1,23 @@ module Network.QUIC.Crypto.Types ( - -- * Types - PlainText - , CipherText - , Key(..) - , IV(..) - , CID - , Secret(..) - , AssDat(..) - , Sample(..) - , Mask(..) - , Nonce(..) - , Salt - , Label(..) - , Cipher - , InitialSecret - , TrafficSecrets - , ClientTrafficSecret(..) - , ServerTrafficSecret(..) - ) where + -- * Types + PlainText, + CipherText, + Key (..), + IV (..), + CID, + Secret (..), + AssDat (..), + Sample (..), + Mask (..), + Nonce (..), + Salt, + Label (..), + Cipher, + InitialSecret, + TrafficSecrets, + ClientTrafficSecret (..), + ServerTrafficSecret (..), +) where import qualified Data.ByteString.Char8 as C8 import Network.TLS hiding (Version) @@ -28,18 +28,18 @@ ---------------------------------------------------------------- -type PlainText = ByteString +type PlainText = ByteString type CipherText = ByteString -type Salt = ByteString +type Salt = ByteString -newtype Key = Key ByteString deriving (Eq) -newtype IV = IV ByteString deriving (Eq) +newtype Key = Key ByteString deriving (Eq) +newtype IV = IV ByteString deriving (Eq) newtype Secret = Secret ByteString deriving (Eq) newtype AssDat = AssDat ByteString deriving (Eq) newtype Sample = Sample ByteString deriving (Eq) -newtype Mask = Mask ByteString deriving (Eq) -newtype Label = Label ByteString deriving (Eq) -newtype Nonce = Nonce ByteString deriving (Eq) +newtype Mask = Mask ByteString deriving (Eq) +newtype Label = Label ByteString deriving (Eq) +newtype Nonce = Nonce ByteString deriving (Eq) instance Show Key where show (Key x) = "Key=" ++ C8.unpack (enc16 x) diff --git a/Network/QUIC/Crypto/Utils.hs b/Network/QUIC/Crypto/Utils.hs --- a/Network/QUIC/Crypto/Utils.hs +++ b/Network/QUIC/Crypto/Utils.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Crypto.Utils ( - tagLength - , sampleLength - , bsXOR - , calculateIntegrityTag - ) where + tagLength, + sampleLength, + bsXOR, + calculateIntegrityTag, +) where import qualified Data.ByteArray as Byte (xor) import qualified Data.ByteString as BS @@ -27,35 +27,38 @@ tagLength :: Cipher -> Int tagLength cipher - | cipher == cipher_TLS13_AES128GCM_SHA256 = 16 - | cipher == cipher_TLS13_AES128CCM_SHA256 = 16 - | cipher == cipher_TLS13_AES256GCM_SHA384 = 16 - | otherwise = error "tagLength" + | cipher == cipher_TLS13_AES128GCM_SHA256 = 16 + | cipher == cipher_TLS13_AES128CCM_SHA256 = 16 + | cipher == cipher_TLS13_AES256GCM_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 - | otherwise = error "sampleLength" + | cipher == cipher_TLS13_AES128GCM_SHA256 = 16 + | cipher == cipher_TLS13_AES128CCM_SHA256 = 16 + | cipher == cipher_TLS13_AES256GCM_SHA384 = 16 + | otherwise = error "sampleLength" ---------------------------------------------------------------- calculateIntegrityTag :: Version -> CID -> ByteString -> ByteString calculateIntegrityTag ver oCID pseudo0 = case aes128gcmEncrypt (key ver) (nonce ver) "" (AssDat pseudo) of - Nothing -> "" - Just (hdr,bdy) -> hdr `BS.append` bdy + Nothing -> "" + Just (hdr, bdy) -> hdr `BS.append` bdy where (ocid, ocidlen) = unpackCID oCID - pseudo = BS.concat [BS.singleton ocidlen - ,Short.fromShort ocid - ,pseudo0] - key Draft29 = Key "\xcc\xce\x18\x7e\xd0\x9a\x09\xd0\x57\x28\x15\x5a\x6c\xb9\x6b\xe1" + pseudo = + BS.concat + [ BS.singleton ocidlen + , Short.fromShort ocid + , pseudo0 + ] + key Draft29 = Key "\xcc\xce\x18\x7e\xd0\x9a\x09\xd0\x57\x28\x15\x5a\x6c\xb9\x6b\xe1" key Version1 = Key "\xbe\x0c\x69\x0b\x9f\x66\x57\x5a\x1d\x76\x6b\x54\xe3\x68\xc8\x4e" key Version2 = Key "\x8f\xb4\xb0\x1b\x56\xac\x48\xe2\x60\xfb\xcb\xce\xad\x7c\xcc\x92" - key _ = Key "not supported" - nonce Draft29 = Nonce "\xe5\x49\x30\xf9\x7f\x21\x36\xf0\x53\x0a\x8c\x1c" + key _ = Key "not supported" + nonce Draft29 = Nonce "\xe5\x49\x30\xf9\x7f\x21\x36\xf0\x53\x0a\x8c\x1c" nonce Version1 = Nonce "\x46\x15\x99\xd3\x5d\x63\x2b\xf2\x23\x98\x25\xbb" nonce Version2 = Nonce "\xd8\x69\x69\xbc\x2d\x7c\x6d\x99\x90\xef\xb0\x4a" - nonce _ = Nonce "not supported" + nonce _ = Nonce "not supported" diff --git a/Network/QUIC/Event.hs b/Network/QUIC/Event.hs --- a/Network/QUIC/Event.hs +++ b/Network/QUIC/Event.hs @@ -1,13 +1,14 @@ {-# LANGUAGE CPP #-} + module Network.QUIC.Event ( - getSystemTimerManager - , registerTimeout - , unregisterTimeout - , updateTimeout - , TimerManager - , TimeoutCallback - , TimeoutKey - ) where + getSystemTimerManager, + registerTimeout, + unregisterTimeout, + updateTimeout, + TimerManager, + TimeoutCallback, + TimeoutKey, +) where #if defined(mingw32_HOST_OS) import GHC.Event.Windows diff --git a/Network/QUIC/Exception.hs b/Network/QUIC/Exception.hs --- a/Network/QUIC/Exception.hs +++ b/Network/QUIC/Exception.hs @@ -1,9 +1,9 @@ {-# LANGUAGE ScopedTypeVariables #-} module Network.QUIC.Exception ( - handleLogT - , handleLogUnit - ) where + handleLogT, + handleLogUnit, +) where import qualified GHC.IO.Exception as E import qualified System.IO.Error as E @@ -17,11 +17,11 @@ where handler :: E.SomeException -> IO () handler se = case E.fromException se of - -- threadWait: invalid argument (Bad file descriptor) - Just e | E.ioeGetErrorType e == E.InvalidArgument -> return () - -- recvBuf: does not exist (Connection refused) - Just e | E.ioeGetErrorType e == E.NoSuchThing -> return () - _ -> logAction $ bhow se + -- threadWait: invalid argument (Bad file descriptor) + Just e | E.ioeGetErrorType e == E.InvalidArgument -> return () + -- recvBuf: does not exist (Connection refused) + Just e | E.ioeGetErrorType e == E.NoSuchThing -> return () + _ -> logAction $ bhow se -- Log and throw an exception handleLogT :: DebugLogger -> IO a -> IO a diff --git a/Network/QUIC/IO.hs b/Network/QUIC/IO.hs --- a/Network/QUIC/IO.hs +++ b/Network/QUIC/IO.hs @@ -3,13 +3,13 @@ module Network.QUIC.IO where import qualified Data.ByteString as BS +import Network.Control import qualified UnliftIO.Exception as E import UnliftIO.STM import Network.QUIC.Connection import Network.QUIC.Connector import Network.QUIC.Imports -import Network.QUIC.Parameters import Network.QUIC.Stream import Network.QUIC.Types @@ -33,10 +33,11 @@ ---------------------------------------------------------------- -data Blocked = BothBlocked Stream Int Int - | ConnBlocked Int - | StrmBlocked Stream Int - deriving Show +data Blocked + = BothBlocked Stream Int Int + | ConnBlocked Int + | StrmBlocked Stream Int + deriving (Show) addTx :: Connection -> Stream -> Int -> IO () addTx conn s len = atomically $ do @@ -45,19 +46,19 @@ -- | Sending a list of data in the stream. sendStreamMany :: Stream -> [ByteString] -> IO () -sendStreamMany _ [] = return () +sendStreamMany _ [] = return () sendStreamMany s dats0 = do sclosed <- isTxStreamClosed s when sclosed $ E.throwIO StreamIsClosed -- fixme: size check for 0RTT let len = totalLen dats0 ready <- isConnection1RTTReady conn - if not ready then do - -- 0-RTT - putSendStreamQ conn $ TxStreamData s dats0 len False - addTx conn s len - else - flowControl dats0 len False + if not ready + then do + -- 0-RTT + putSendStreamQ conn $ TxStreamData s dats0 len False + addTx conn s len + else flowControl dats0 len False where conn = streamConnection s flowControl dats len wait = do @@ -66,36 +67,37 @@ -- FLOW CONTROL: MAX_DATA: send: respecting peer's limit eblocked <- checkBlocked s len wait case eblocked of - Right n - | len == n -> do - putSendStreamQ conn $ TxStreamData s dats len False - addTx conn s n - | otherwise -> do - let (dats1,dats2) = split n dats - putSendStreamQ conn $ TxStreamData s dats1 n False - addTx conn s n - flowControl dats2 (len - n) False - Left blocked -> do - -- fixme: RTT0Level? - sendBlocked conn RTT1Level blocked - flowControl dats len True + Right n + | len == n -> do + putSendStreamQ conn $ TxStreamData s dats len False + addTx conn s n + | otherwise -> do + let (dats1, dats2) = split n dats + putSendStreamQ conn $ TxStreamData s dats1 n False + addTx conn s n + flowControl dats2 (len - n) False + Left blocked -> do + -- fixme: RTT0Level? + sendBlocked conn RTT1Level blocked + flowControl dats len True sendBlocked :: Connection -> EncryptionLevel -> Blocked -> IO () sendBlocked conn lvl blocked = sendFrames conn lvl frames where frames = case blocked of - StrmBlocked strm n -> [StreamDataBlocked (streamId strm) n] - ConnBlocked n -> [DataBlocked n] - BothBlocked strm n m -> [StreamDataBlocked (streamId strm) n, DataBlocked m] + StrmBlocked strm n -> [StreamDataBlocked (streamId strm) n] + ConnBlocked n -> [DataBlocked n] + BothBlocked strm n m -> [StreamDataBlocked (streamId strm) n, DataBlocked m] -split :: Int -> [BS.ByteString] -> ([BS.ByteString],[BS.ByteString]) +split :: Int -> [BS.ByteString] -> ([BS.ByteString], [BS.ByteString]) split n0 dats0 = loop n0 dats0 id where - loop 0 bss build = (build [], bss) - loop _ [] build = (build [], []) - loop n (bs:bss) build = case len `compare` n of - GT -> let (bs1,bs2) = BS.splitAt n bs - in (build [bs1], bs2:bss) + loop 0 bss build = (build [], bss) + loop _ [] build = (build [], []) + loop n (bs : bss) build = case len `compare` n of + GT -> + let (bs1, bs2) = BS.splitAt n bs + in (build [bs1], bs2 : bss) EQ -> (build [bs], bss) LT -> loop (n - len) bss (build . (bs :)) where @@ -106,21 +108,21 @@ let conn = streamConnection s strmFlow <- readStreamFlowTx s connFlow <- readConnectionFlowTx conn - let strmWindow = flowWindow strmFlow - connWindow = flowWindow connFlow + let strmWindow = txWindowSize strmFlow + connWindow = txWindowSize connFlow minFlow = min strmWindow connWindow n = min len minFlow when wait $ checkSTM (n > 0) - if n > 0 then - return $ Right n - else do - let cs = len > strmWindow - cw = len > connWindow - blocked - | cs && cw = BothBlocked s (flowMaxData strmFlow) (flowMaxData connFlow) - | cs = StrmBlocked s (flowMaxData strmFlow) - | otherwise = ConnBlocked (flowMaxData connFlow) - return $ Left blocked + if n > 0 + then return $ Right n + else do + let cs = len > strmWindow + cw = len > connWindow + blocked + | cs && cw = BothBlocked s (txfLimit strmFlow) (txfLimit connFlow) + | cs = StrmBlocked s (txfLimit strmFlow) + | otherwise = ConnBlocked (txfLimit connFlow) + return $ Left blocked ---------------------------------------------------------------- @@ -147,23 +149,29 @@ putSendStreamQ conn $ TxStreamData s [] 0 True waitFinTx s delStream conn s - when ((isClient conn && isServerInitiatedBidirectional sid) - || (isServer conn && isClientInitiatedBidirectional sid)) $ do - -- FLOW CONTROL: MAX_STREAMS: recv: announcing my limit properly - checkMaxStreams conn Bidirectional - when ((isClient conn && isServerInitiatedUnidirectional sid) - || (isServer conn && isClientInitiatedUnidirectional sid)) $ do - -- FLOW CONTROL: MAX_STREAMS: recv: announcing my limit properly - checkMaxStreams conn Unidirectional + when + ( (isClient conn && isServerInitiatedBidirectional sid) + || (isServer conn && isClientInitiatedBidirectional sid) + ) + $ do + -- FLOW CONTROL: MAX_STREAMS: recv: announcing my limit properly + checkMaxStreams conn Bidirectional + when + ( (isClient conn && isServerInitiatedUnidirectional sid) + || (isServer conn && isClientInitiatedUnidirectional sid) + ) + $ do + -- FLOW CONTROL: MAX_STREAMS: recv: announcing my limit properly + checkMaxStreams conn Unidirectional where checkMaxStreams conn dir = do mx <- checkStreamIdRoom conn dir case mx of - Nothing -> return () - Just nms -> do - sendFrames conn RTT1Level [MaxStreams dir nms] - fire conn (Microseconds 50000) $ + Nothing -> return () + Just nms -> do sendFrames conn RTT1Level [MaxStreams dir nms] + fire conn (Microseconds 50000) $ + sendFrames conn RTT1Level [MaxStreams dir nms] -- | Accepting a stream initiated by the peer. acceptStream :: Connection -> IO Stream @@ -177,23 +185,17 @@ recvStream s n = do bs <- takeRecvStreamQwithSize s n let len = BS.length bs + sid = streamId s conn = streamConnection s - addRxStreamData s len - addRxData conn len - window <- getRxStreamWindow s - let sid = streamId s - initialWindow = initialRxMaxStreamData conn sid -- FLOW CONTROL: MAX_STREAM_DATA: recv: announcing my limit properly - when (window <= (initialWindow !>>. 1)) $ do - newMax <- addRxMaxStreamData s initialWindow + mxs <- updateStreamFlowRx s len + forM_ mxs $ \newMax -> do sendFrames conn RTT1Level [MaxStreamData sid newMax] fire conn (Microseconds 50000) $ sendFrames conn RTT1Level [MaxStreamData sid newMax] -- FLOW CONTROL: MAX_DATA: recv: announcing my limit properly - cwindow <- getRxDataWindow conn - let cinitialWindow = initialMaxData $ getMyParameters conn - when (cwindow <= (cinitialWindow !>>. 1)) $ do - newMax <- addRxMaxData conn cinitialWindow + mxc <- updateFlowRx conn len + forM_ mxc $ \newMax -> do sendFrames conn RTT1Level [MaxData newMax] fire conn (Microseconds 50000) $ sendFrames conn RTT1Level [MaxData newMax] diff --git a/Network/QUIC/Info.hs b/Network/QUIC/Info.hs --- a/Network/QUIC/Info.hs +++ b/Network/QUIC/Info.hs @@ -5,8 +5,8 @@ import qualified Data.ByteString.Char8 as C8 import qualified Network.Socket as NS -import Network.TLS hiding (Version, HandshakeFailed) -import Network.UDP (UDPSocket(..)) +import Network.TLS hiding (HandshakeFailed, Version) +import Network.UDP (UDPSocket (..)) import Network.QUIC.Connection import Network.QUIC.Imports @@ -15,67 +15,86 @@ ---------------------------------------------------------------- -- | Information about a connection. -data ConnectionInfo = ConnectionInfo { - version :: Version - , cipher :: Cipher - , alpn :: Maybe ByteString - , handshakeMode :: HandshakeMode13 - , retry :: Bool - , localSockAddr :: NS.SockAddr - , remoteSockAddr :: NS.SockAddr - , localCID :: CID - , remoteCID :: CID - } +data ConnectionInfo = ConnectionInfo + { version :: Version + , cipher :: Cipher + , alpn :: Maybe ByteString + , handshakeMode :: HandshakeMode13 + , retry :: Bool + , localSockAddr :: NS.SockAddr + , remoteSockAddr :: NS.SockAddr + , localCID :: CID + , remoteCID :: CID + } -- | Getting information about a connection. getConnectionInfo :: Connection -> IO ConnectionInfo getConnectionInfo conn = do UDPSocket{..} <- getSocket conn mysa <- NS.getSocketName udpSocket - mycid <- getMyCID conn + mycid <- getMyCID conn peercid <- getPeerCID conn c <- getCipher conn RTT1Level mproto <- getApplicationProtocol conn mode <- getTLSMode conn r <- getRetried conn v <- getVersion conn - return ConnectionInfo { - version = v - , cipher = c - , alpn = mproto - , handshakeMode = mode - , retry = r - , localSockAddr = mysa - , remoteSockAddr = peerSockAddr - , localCID = mycid - , remoteCID = peercid - } + return + ConnectionInfo + { version = v + , cipher = c + , alpn = mproto + , handshakeMode = mode + , retry = r + , localSockAddr = mysa + , remoteSockAddr = peerSockAddr + , localCID = mycid + , remoteCID = peercid + } instance Show ConnectionInfo where - show ConnectionInfo{..} = "Version: " ++ show version ++ "\n" - ++ "Cipher: " ++ show cipher ++ "\n" - ++ "ALPN: " ++ maybe "none" C8.unpack alpn ++ "\n" - ++ "Mode: " ++ show handshakeMode ++ "\n" - ++ "Local CID: " ++ show localCID ++ "\n" - ++ "Remote CID: " ++ show remoteCID ++ "\n" - ++ "Local SockAddr: " ++ show localSockAddr ++ "\n" - ++ "Remote SockAddr: " ++ show remoteSockAddr ++ - if retry then "\nQUIC retry" else "" + show ConnectionInfo{..} = + "Version: " + ++ show version + ++ "\n" + ++ "Cipher: " + ++ show cipher + ++ "\n" + ++ "ALPN: " + ++ maybe "none" C8.unpack alpn + ++ "\n" + ++ "Mode: " + ++ show handshakeMode + ++ "\n" + ++ "Local CID: " + ++ show localCID + ++ "\n" + ++ "Remote CID: " + ++ show remoteCID + ++ "\n" + ++ "Local SockAddr: " + ++ show localSockAddr + ++ "\n" + ++ "Remote SockAddr: " + ++ show remoteSockAddr + ++ if retry then "\nQUIC retry" else "" ---------------------------------------------------------------- -- | Statistics of a connection. -data ConnectionStats = ConnectionStats { - txBytes :: Int - , rxBytes :: Int - } deriving (Eq, Show) +data ConnectionStats = ConnectionStats + { txBytes :: Int + , rxBytes :: Int + } + deriving (Eq, Show) -- | Getting statistics of a connection. getConnectionStats :: Connection -> IO ConnectionStats getConnectionStats conn = do tx <- getTxBytes conn rx <- getRxBytes conn - return $ ConnectionStats { - txBytes = tx - , rxBytes = rx - } + return $ + ConnectionStats + { txBytes = tx + , rxBytes = rx + } diff --git a/Network/QUIC/Internal.hs b/Network/QUIC/Internal.hs --- a/Network/QUIC/Internal.hs +++ b/Network/QUIC/Internal.hs @@ -1,22 +1,22 @@ module Network.QUIC.Internal ( - module Network.QUIC.Config - , module Network.QUIC.Connection - , module Network.QUIC.Connector - , module Network.QUIC.Crypto - , module Network.QUIC.Logger - , module Network.QUIC.Packet - , module Network.QUIC.Parameters - , module Network.QUIC.Qlog - , module Network.QUIC.Stream - , module Network.QUIC.TLS - , module Network.QUIC.Types - , module Network.QUIC.Utils - , module Network.QUIC.Recovery - , module Network.QUIC.Client.Reader - , module Network.QUIC.Windows - ) where + module Network.QUIC.Config, + module Network.QUIC.Connection, + module Network.QUIC.Connector, + module Network.QUIC.Crypto, + module Network.QUIC.Logger, + module Network.QUIC.Packet, + module Network.QUIC.Parameters, + module Network.QUIC.Qlog, + module Network.QUIC.Stream, + module Network.QUIC.TLS, + module Network.QUIC.Types, + module Network.QUIC.Utils, + module Network.QUIC.Recovery, + module Network.QUIC.Client.Reader, + module Network.QUIC.Windows, +) where -import Network.QUIC.Client.Reader (controlConnection,ConnectionControl(..)) +import Network.QUIC.Client.Reader (ConnectionControl (..), controlConnection) import Network.QUIC.Config import Network.QUIC.Connection import Network.QUIC.Connector diff --git a/Network/QUIC/Logger.hs b/Network/QUIC/Logger.hs --- a/Network/QUIC/Logger.hs +++ b/Network/QUIC/Logger.hs @@ -1,18 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Logger ( - Builder - , DebugLogger - , bhow - , stdoutLogger - , dirDebugLogger - ) where + Builder, + DebugLogger, + bhow, + stdoutLogger, + dirDebugLogger, +) where -import System.FilePath -import System.Log.FastLogger import Data.ByteString.Builder (byteString, toLazyByteString) import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as BL +import System.FilePath +import System.Log.FastLogger import Network.QUIC.Imports import Network.QUIC.Types diff --git a/Network/QUIC/Packet.hs b/Network/QUIC/Packet.hs --- a/Network/QUIC/Packet.hs +++ b/Network/QUIC/Packet.hs @@ -1,39 +1,43 @@ module Network.QUIC.Packet ( - -- * Encode - encodeVersionNegotiationPacket - , encodeRetryPacket - , encodePlainPacket - -- * Decode - , decodePacket - , decodePackets - , decodeCryptPackets - , decryptCrypt - , decodeStatelessResetToken - -- * Frame - , encodeFrames - , decodeFramesBuffer - , decodeFramesBS - , countZero -- testing - -- * Header - , isLong - , isShort - , protectFlags - , unprotectFlags - , encodeLongHeaderFlags - , encodeShortHeaderFlags - , decodeLongHeaderPacketType - , encodePktNumLength - , decodePktNumLength - , versionNegotiationPacketType - , retryPacketType - -- * Token - , CryptoToken(..) - , isRetryToken - , generateToken - , generateRetryToken - , encryptToken - , decryptToken - ) where + -- * Encode + encodeVersionNegotiationPacket, + encodeRetryPacket, + encodePlainPacket, + + -- * Decode + decodePacket, + decodePackets, + decodeCryptPackets, + decryptCrypt, + decodeStatelessResetToken, + + -- * Frame + encodeFrames, + decodeFramesBuffer, + decodeFramesBS, + countZero, -- testing + + -- * Header + isLong, + isShort, + protectFlags, + unprotectFlags, + encodeLongHeaderFlags, + encodeShortHeaderFlags, + decodeLongHeaderPacketType, + encodePktNumLength, + decodePktNumLength, + versionNegotiationPacketType, + retryPacketType, + + -- * Token + CryptoToken (..), + isRetryToken, + generateToken, + generateRetryToken, + encryptToken, + decryptToken, +) where import Network.QUIC.Packet.Decode import Network.QUIC.Packet.Decrypt diff --git a/Network/QUIC/Packet/Decode.hs b/Network/QUIC/Packet/Decode.hs --- a/Network/QUIC/Packet/Decode.hs +++ b/Network/QUIC/Packet/Decode.hs @@ -1,11 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Packet.Decode ( - decodePacket - , decodePackets - , decodeCryptPackets - , decodeStatelessResetToken - ) where + decodePacket, + decodePackets, + decodeCryptPackets, + decodeStatelessResetToken, +) where import qualified Data.ByteString as BS import qualified Data.ByteString.Short as Short @@ -18,12 +18,12 @@ ---------------------------------------------------------------- -- Server uses this. -decodeCryptPackets :: ByteString -> IO [(CryptPacket,EncryptionLevel,Int)] +decodeCryptPackets :: ByteString -> IO [(CryptPacket, EncryptionLevel, Int)] decodeCryptPackets bs0 = unwrap <$> decodePackets bs0 where - unwrap (PacketIC c l s:xs) = (c,l,s) : unwrap xs - unwrap (_:xs) = unwrap xs - unwrap [] = [] + unwrap (PacketIC c l s : xs) = (c, l, s) : unwrap xs + unwrap (_ : xs) = unwrap xs + unwrap [] = [] -- Client uses this. decodePackets :: ByteString -> IO [PacketI] @@ -52,29 +52,29 @@ decode rbuf proFlags False = do (ver, dCID, sCID) <- decodeLongHeader rbuf case ver of - Negotiation -> do - decodeVersionNegotiationPacket rbuf dCID sCID - _ -> case decodeLongHeaderPacketType ver proFlags of - RetryPacketType -> do - decodeRetryPacket rbuf proFlags ver dCID sCID - RTT0PacketType -> do - let header = RTT0 ver dCID sCID - cpkt <- CryptPacket header <$> makeLongCrypt bs rbuf - siz <- savingSize rbuf - return $ PacketIC cpkt RTT0Level siz - InitialPacketType -> do - tokenLen <- fromIntegral <$> decodeInt' rbuf - token <- extractByteString rbuf tokenLen - let header = Initial ver dCID sCID token - cpkt <- CryptPacket header <$> makeLongCrypt bs rbuf - siz <- savingSize rbuf - return $ PacketIC cpkt InitialLevel siz - HandshakePacketType -> do - let header = Handshake ver dCID sCID - crypt <- CryptPacket header <$> makeLongCrypt bs rbuf - siz <- savingSize rbuf - return $ PacketIC crypt HandshakeLevel siz - handler BufferOverrun = return (PacketIB BrokenPacket,"") + Negotiation -> do + decodeVersionNegotiationPacket rbuf dCID sCID + _ -> case decodeLongHeaderPacketType ver proFlags of + RetryPacketType -> do + decodeRetryPacket rbuf proFlags ver dCID sCID + RTT0PacketType -> do + let header = RTT0 ver dCID sCID + cpkt <- CryptPacket header <$> makeLongCrypt bs rbuf + siz <- savingSize rbuf + return $ PacketIC cpkt RTT0Level siz + InitialPacketType -> do + tokenLen <- fromIntegral <$> decodeInt' rbuf + token <- extractByteString rbuf tokenLen + let header = Initial ver dCID sCID token + cpkt <- CryptPacket header <$> makeLongCrypt bs rbuf + siz <- savingSize rbuf + return $ PacketIC cpkt InitialLevel siz + HandshakePacketType -> do + let header = Handshake ver dCID sCID + crypt <- CryptPacket header <$> makeLongCrypt bs rbuf + siz <- savingSize rbuf + return $ PacketIC crypt HandshakeLevel siz + handler BufferOverrun = return (PacketIB BrokenPacket, "") makeShortCrypt :: ByteString -> ReadBuffer -> IO Crypt makeShortCrypt bs rbuf = do @@ -94,12 +94,12 @@ ---------------------------------------------------------------- decodeLongHeader :: ReadBuffer -> IO (Version, CID, CID) -decodeLongHeader rbuf = do - ver <- Version <$> read32 rbuf +decodeLongHeader rbuf = do + ver <- Version <$> read32 rbuf dcidlen <- fromIntegral <$> read8 rbuf - dCID <- makeCID <$> extractShortByteString rbuf dcidlen + dCID <- makeCID <$> extractShortByteString rbuf dcidlen scidlen <- fromIntegral <$> read8 rbuf - sCID <- makeCID <$> extractShortByteString rbuf scidlen + sCID <- makeCID <$> extractShortByteString rbuf scidlen return (ver, dCID, sCID) decodeVersionNegotiationPacket :: ReadBuffer -> CID -> CID -> IO PacketI @@ -109,26 +109,27 @@ return $ PacketIV $ VersionNegotiationPacket dCID sCID vers where decodeVersions siz vers - | siz >= 4 = do + | siz >= 4 = do ver <- Version <$> read32 rbuf decodeVersions (siz - 4) ((ver :) . vers) - | otherwise = return $ vers [] + | otherwise = return $ vers [] -decodeRetryPacket :: ReadBuffer -> Flags Protected -> Version -> CID -> CID -> IO PacketI +decodeRetryPacket + :: ReadBuffer -> Flags Protected -> Version -> CID -> CID -> IO PacketI decodeRetryPacket rbuf _proFlags version dCID sCID = do rsiz <- remainingSize rbuf token <- extractByteString rbuf (rsiz - 16) siz <- savingSize rbuf pseudo <- extractByteString rbuf $ negate siz tag <- extractByteString rbuf 16 - return $ PacketIR $ RetryPacket version dCID sCID token (Right (pseudo,tag)) + return $ PacketIR $ RetryPacket version dCID sCID token (Right (pseudo, tag)) ---------------------------------------------------------------- decodeStatelessResetToken :: ByteString -> Maybe StatelessResetToken decodeStatelessResetToken bs - | len < 21 = Nothing - | otherwise = Just $ StatelessResetToken $ Short.toShort token + | len < 21 = Nothing + | otherwise = Just $ StatelessResetToken $ Short.toShort token where len = BS.length bs - (_,token) = BS.splitAt (len - 16) bs + (_, token) = BS.splitAt (len - 16) bs diff --git a/Network/QUIC/Packet/Decrypt.hs b/Network/QUIC/Packet/Decrypt.hs --- a/Network/QUIC/Packet/Decrypt.hs +++ b/Network/QUIC/Packet/Decrypt.hs @@ -1,10 +1,10 @@ +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ExistentialQuantification #-} module Network.QUIC.Packet.Decrypt ( - decryptCrypt - ) where + decryptCrypt, +) where import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BS @@ -32,40 +32,44 @@ makeMask = unprotect protector Mask mask = makeMask sample case BS.uncons mask of - Nothing -> return Nothing - Just (mask1,mask2) -> do - let rawFlags@(Flags flags) = unprotectFlags proFlags mask1 - epnLen = decodePktNumLength rawFlags - epn = BS.take epnLen $ BS.drop cryptPktNumOffset cryptPacket - bytePN = bsXOR mask2 epn - headerLen = cryptPktNumOffset + epnLen - (proHeader, ciphertext) = BS.splitAt headerLen cryptPacket - peerPN <- if lvl == RTT1Level then getPeerPacketNumber conn else return 0 - let pn = decodePacketNumber peerPN (toEncodedPacketNumber bytePN) epnLen - header <- BS.create headerLen $ \p -> do - void $ copy p proHeader - poke8 flags p 0 - void $ copy (p `plusPtr` cryptPktNumOffset) $ BS.take epnLen bytePN - let keyPhase | lvl == RTT1Level = flags `testBit` 2 - | otherwise = False - coder <- getCoder conn lvl keyPhase - siz <- decrypt coder (decryptBuf conn) ciphertext (AssDat header) pn - let rrMask | lvl == RTT1Level = 0x18 - | otherwise = 0x0c - marks | flags .&. rrMask == 0 = defaultPlainMarks - | otherwise = setIllegalReservedBits defaultPlainMarks - if siz < 0 then - return Nothing - else do - mframes <- decodeFramesBuffer (decryptBuf conn) siz - case mframes of - Nothing -> do - let marks' = setUnknownFrame marks - return $ Just $ Plain rawFlags pn [] marks' - Just frames -> do - let marks' | null frames = setNoFrames marks - | otherwise = marks - return $ Just $ Plain rawFlags pn frames marks' + Nothing -> return Nothing + Just (mask1, mask2) -> do + let rawFlags@(Flags flags) = unprotectFlags proFlags mask1 + epnLen = decodePktNumLength rawFlags + epn = BS.take epnLen $ BS.drop cryptPktNumOffset cryptPacket + bytePN = bsXOR mask2 epn + headerLen = cryptPktNumOffset + epnLen + (proHeader, ciphertext) = BS.splitAt headerLen cryptPacket + peerPN <- if lvl == RTT1Level then getPeerPacketNumber conn else return 0 + let pn = decodePacketNumber peerPN (toEncodedPacketNumber bytePN) epnLen + header <- BS.create headerLen $ \p -> do + void $ copy p proHeader + poke8 flags p 0 + void $ copy (p `plusPtr` cryptPktNumOffset) $ BS.take epnLen bytePN + let keyPhase + | lvl == RTT1Level = flags `testBit` 2 + | otherwise = False + coder <- getCoder conn lvl keyPhase + siz <- decrypt coder (decryptBuf conn) ciphertext (AssDat header) pn + let rrMask + | lvl == RTT1Level = 0x18 + | otherwise = 0x0c + marks + | flags .&. rrMask == 0 = defaultPlainMarks + | otherwise = setIllegalReservedBits defaultPlainMarks + if siz < 0 + then return Nothing + else do + mframes <- decodeFramesBuffer (decryptBuf conn) siz + case mframes of + Nothing -> do + let marks' = setUnknownFrame marks + return $ Just $ Plain rawFlags pn [] marks' + Just frames -> do + let marks' + | null frames = setNoFrames marks + | otherwise = marks + return $ Just $ Plain rawFlags pn frames marks' toEncodedPacketNumber :: ByteString -> EncodedPacketNumber toEncodedPacketNumber bs = foldl' (\b a -> b * 256 + fromIntegral a) 0 $ BS.unpack bs diff --git a/Network/QUIC/Packet/Encode.hs b/Network/QUIC/Packet/Encode.hs --- a/Network/QUIC/Packet/Encode.hs +++ b/Network/QUIC/Packet/Encode.hs @@ -1,11 +1,11 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Packet.Encode ( --- encodePacket - encodeVersionNegotiationPacket - , encodeRetryPacket - , encodePlainPacket - ) where + -- encodePacket + encodeVersionNegotiationPacket, + encodeRetryPacket, + encodePlainPacket, +) where import qualified Data.ByteString as BS import Foreign.ForeignPtr @@ -24,6 +24,7 @@ ---------------------------------------------------------------- -- | This is not used internally. + {- encodePacket :: Connection -> PacketO -> IO [ByteString] encodePacket _ (PacketOV pkt) = (:[]) <$> encodeVersionNegotiationPacket pkt @@ -42,6 +43,7 @@ -- vers mapM_ (\(Version ver) -> write32 wbuf ver) vers -- no header protection + return () ---------------------------------------------------------------- @@ -57,8 +59,9 @@ let tag = calculateIntegrityTag ver odCID pseudo0 copyByteString wbuf tag -- no header protection + return () -- only for testing -encodeRetryPacket (RetryPacket ver dCID sCID token (Right (_,tag))) = withWriteBuffer maximumQUICHeaderSize $ \wbuf -> do +encodeRetryPacket (RetryPacket ver dCID sCID token (Right (_, tag))) = withWriteBuffer maximumQUICHeaderSize $ \wbuf -> do save wbuf Flags flags <- retryPacketType ver write8 wbuf flags @@ -66,64 +69,112 @@ copyByteString wbuf token copyByteString wbuf tag -- no header protection + return () ---------------------------------------------------------------- -- WriteBuffer: protect(header) + encrypt(plain_frames) -- encodeBuf: plain_frames -encodePlainPacket :: Connection -> SizedBuffer -> PlainPacket -> Maybe Int -> IO (Int,Int) +encodePlainPacket + :: Connection -> SizedBuffer -> PlainPacket -> Maybe Int -> IO (Int, Int) encodePlainPacket conn (SizedBuffer buf bufsiz) ppkt@(PlainPacket _ plain) mlen = do - let mlen' | isNoPaddings (plainMarks plain) = Nothing - | otherwise = mlen + let mlen' + | isNoPaddings (plainMarks plain) = Nothing + | otherwise = mlen wbuf <- newWriteBuffer buf bufsiz encodePlainPacket' conn wbuf ppkt mlen' -encodePlainPacket' :: Connection -> WriteBuffer -> PlainPacket -> Maybe Int -> IO (Int,Int) +encodePlainPacket' + :: Connection -> WriteBuffer -> PlainPacket -> Maybe Int -> IO (Int, Int) encodePlainPacket' conn wbuf (PlainPacket (Initial ver dCID sCID token) (Plain flags pn frames _)) mlen = do headerBeg <- currentOffset wbuf -- flag ... sCID - (epn, epnLen) <- encodeLongHeaderPP conn wbuf InitialPacketType ver dCID sCID flags pn + (epn, epnLen) <- + encodeLongHeaderPP conn wbuf InitialPacketType ver dCID sCID flags pn -- token encodeInt' wbuf $ fromIntegral $ BS.length token copyByteString wbuf token -- length .. payload - protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen InitialLevel False - + protectPayloadHeader + conn + wbuf + frames + pn + epn + epnLen + headerBeg + mlen + InitialLevel + False encodePlainPacket' conn wbuf (PlainPacket (RTT0 ver dCID sCID) (Plain flags pn frames _)) mlen = do headerBeg <- currentOffset wbuf -- flag ... sCID - (epn, epnLen) <- encodeLongHeaderPP conn wbuf RTT0PacketType ver dCID sCID flags pn + (epn, epnLen) <- + encodeLongHeaderPP conn wbuf RTT0PacketType ver dCID sCID flags pn -- length .. payload - protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen RTT0Level False - + protectPayloadHeader + conn + wbuf + frames + pn + epn + epnLen + headerBeg + mlen + RTT0Level + False encodePlainPacket' conn wbuf (PlainPacket (Handshake ver dCID sCID) (Plain flags pn frames _)) mlen = do headerBeg <- currentOffset wbuf -- flag ... sCID - (epn, epnLen) <- encodeLongHeaderPP conn wbuf HandshakePacketType ver dCID sCID flags pn + (epn, epnLen) <- + encodeLongHeaderPP conn wbuf HandshakePacketType ver dCID sCID flags pn -- length .. payload - protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen HandshakeLevel False - + protectPayloadHeader + conn + wbuf + frames + pn + epn + epnLen + headerBeg + mlen + HandshakeLevel + False encodePlainPacket' conn wbuf (PlainPacket (Short dCID) (Plain flags pn frames marks)) mlen = do headerBeg <- currentOffset wbuf -- flag - let (epn, epnLen) | is4bytesPN marks = (fromIntegral pn, 4) - | otherwise = encodePacketNumber 0 {- dummy -} pn + let (epn, epnLen) + | is4bytesPN marks = (fromIntegral pn, 4) + | otherwise = encodePacketNumber 0 {- dummy -} pn pp = encodePktNumLength epnLen quicBit <- greaseQuicBit <$> getPeerParameters conn - (keyPhase,_) <- getCurrentKeyPhase conn + (keyPhase, _) <- getCurrentKeyPhase conn Flags flags' <- encodeShortHeaderFlags flags pp quicBit keyPhase write8 wbuf flags' -- dCID let (dcid, _) = unpackCID dCID copyShortByteString wbuf dcid - protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen RTT1Level keyPhase + protectPayloadHeader + conn + wbuf + frames + pn + epn + epnLen + headerBeg + mlen + RTT1Level + keyPhase ---------------------------------------------------------------- -encodeLongHeader :: WriteBuffer - -> Version -> CID -> CID - -> IO () +encodeLongHeader + :: WriteBuffer + -> Version + -> CID + -> CID + -> IO () encodeLongHeader wbuf (Version ver) dCID sCID = do write32 wbuf ver let (dcid, dcidlen) = unpackCID dCID @@ -135,11 +186,16 @@ ---------------------------------------------------------------- -encodeLongHeaderPP :: Connection -> WriteBuffer - -> LongHeaderPacketType -> Version -> CID -> CID - -> Flags Raw - -> PacketNumber - -> IO (EncodedPacketNumber, Int) +encodeLongHeaderPP + :: Connection + -> WriteBuffer + -> LongHeaderPacketType + -> Version + -> CID + -> CID + -> Flags Raw + -> PacketNumber + -> IO (EncodedPacketNumber, Int) encodeLongHeaderPP conn wbuf pkttyp ver dCID sCID flags pn = do let el@(_, pnLen) = encodePacketNumber 0 {- dummy -} pn pp = encodePktNumLength pnLen @@ -151,17 +207,28 @@ ---------------------------------------------------------------- -protectPayloadHeader :: Connection -> WriteBuffer -> [Frame] -> PacketNumber -> EncodedPacketNumber -> Int -> Buffer -> Maybe Int -> EncryptionLevel -> Bool -> IO (Int,Int) +protectPayloadHeader + :: Connection + -> WriteBuffer + -> [Frame] + -> PacketNumber + -> EncodedPacketNumber + -> Int + -> Buffer + -> Maybe Int + -> EncryptionLevel + -> Bool + -> IO (Int, Int) protectPayloadHeader conn wbuf frames pn epn epnLen headerBeg mlen lvl keyPhase = do -- Real size is maximumUdpPayloadSize. But smaller is better. - let encBuf = encodeBuf conn + let encBuf = encodeBuf conn encBufLen = 1500 - 20 - 8 payloadWithoutPaddingSiz <- encodeFramesWithPadding encBuf encBufLen frames cipher <- getCipher conn lvl -- before length or packer number lengthOrPNBeg <- currentOffset wbuf - (packetLen, headerLen, plainLen, tagLen, padLen) - <- calcLen cipher lengthOrPNBeg payloadWithoutPaddingSiz + (packetLen, headerLen, plainLen, tagLen, padLen) <- + calcLen cipher lengthOrPNBeg payloadWithoutPaddingSiz when (lvl /= RTT1Level) $ writeLen (epnLen + plainLen + tagLen) pnBeg <- currentOffset wbuf writeEpn epnLen @@ -177,28 +244,29 @@ len <- encrypt coder cryptoBeg plaintext (AssDat header) pn maskBeg <- getMask protector -- - if len < 0 || maskBeg == nullPtr then - return (-1, -1) - else do - -- protecting header - protectHeader headerBeg pnBeg epnLen maskBeg - return (packetLen, padLen) + if len < 0 || maskBeg == nullPtr + then return (-1, -1) + else do + -- protecting header + protectHeader headerBeg pnBeg epnLen maskBeg + return (packetLen, padLen) where calcLen cipher lengthOrPNBeg payloadWithoutPaddingSiz = do - let headerLen = (lengthOrPNBeg `minusPtr` headerBeg) - -- length: assuming 2byte length - + (if lvl /= RTT1Level then 2 else 0) - + epnLen + let headerLen = + (lengthOrPNBeg `minusPtr` headerBeg) + -- length: assuming 2byte length + + (if lvl /= RTT1Level then 2 else 0) + + epnLen let tagLen = tagLength cipher plainLen = case mlen of - Nothing -> payloadWithoutPaddingSiz + Nothing -> payloadWithoutPaddingSiz Just expectedLen -> expectedLen - headerLen - tagLen packetLen = headerLen + plainLen + tagLen padLen = plainLen - payloadWithoutPaddingSiz return (packetLen, headerLen, plainLen, tagLen, padLen) -- length: assuming 2byte length writeLen len = encodeInt'2 wbuf $ fromIntegral len - writeEpn 1 = write8 wbuf $ fromIntegral epn + writeEpn 1 = write8 wbuf $ fromIntegral epn writeEpn 2 = write16 wbuf $ fromIntegral epn writeEpn 3 = write24 wbuf epn writeEpn _ = write32 wbuf epn diff --git a/Network/QUIC/Packet/Frame.hs b/Network/QUIC/Packet/Frame.hs --- a/Network/QUIC/Packet/Frame.hs +++ b/Network/QUIC/Packet/Frame.hs @@ -1,17 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Packet.Frame ( - encodeFrames - , encodeFramesWithPadding - , decodeFramesBS - , decodeFramesBuffer - , countZero -- testing - ) where + encodeFrames, + encodeFramesWithPadding, + decodeFramesBS, + decodeFramesBuffer, + countZero, -- testing +) where import qualified Data.ByteString as BS import qualified Data.ByteString.Short as Short -import Foreign.Ptr (Ptr, plusPtr, minusPtr, alignPtr, castPtr) -import Foreign.Storable (peek, alignment) +import Foreign.Ptr (Ptr, alignPtr, castPtr, minusPtr, plusPtr) +import Foreign.Storable (alignment, peek) import Network.Socket.Internal (zeroMemory) import Network.QUIC.Imports @@ -21,12 +21,14 @@ encodeFrames :: [Frame] -> IO ByteString encodeFrames frames = withWriteBuffer 2048 $ \wbuf -> - mapM_ (encodeFrame wbuf) frames + mapM_ (encodeFrame wbuf) frames -encodeFramesWithPadding :: Buffer - -> BufferSize - -> [Frame] - -> IO Int -- ^ payload size without paddings +encodeFramesWithPadding + :: Buffer + -> BufferSize + -> [Frame] + -> IO Int + -- ^ payload size without paddings encodeFramesWithPadding buf siz frames = do zeroMemory buf $ fromIntegral siz -- padding wbuf <- newWriteBuffer buf siz @@ -45,7 +47,7 @@ encodeInt' wbuf $ fromIntegral range1 mapM_ putRanges ranges where - putRanges (gap,rng) = do + putRanges (gap, rng) = do encodeInt' wbuf $ fromIntegral gap encodeInt' wbuf $ fromIntegral rng encodeFrame wbuf (ResetStream sid (ApplicationProtocolError err) finalLen) = do @@ -68,10 +70,12 @@ copyByteString wbuf token encodeFrame wbuf (StreamF sid off dats fin) = do let flag0 = 0x08 .|. 0x02 -- len - flag1 | off /= 0 = flag0 .|. 0x04 -- off - | otherwise = flag0 - flag2 | fin = flag1 .|. 0x01 -- fin - | otherwise = flag1 + flag1 + | off /= 0 = flag0 .|. 0x04 -- off + | otherwise = flag0 + flag2 + | fin = flag1 .|. 0x01 -- fin + | otherwise = flag1 write8 wbuf flag2 encodeInt' wbuf $ fromIntegral sid when (off /= 0) $ encodeInt' wbuf $ fromIntegral off @@ -86,8 +90,8 @@ encodeInt' wbuf $ fromIntegral n encodeFrame wbuf (MaxStreams dir ms) = do case dir of - Bidirectional -> write8 wbuf 0x12 - Unidirectional -> write8 wbuf 0x13 + Bidirectional -> write8 wbuf 0x12 + Unidirectional -> write8 wbuf 0x13 encodeInt' wbuf $ fromIntegral ms encodeFrame wbuf (DataBlocked n) = do write8 wbuf 0x14 @@ -98,8 +102,8 @@ encodeInt' wbuf $ fromIntegral n encodeFrame wbuf (StreamsBlocked dir ms) = do case dir of - Bidirectional -> write8 wbuf 0x16 - Unidirectional -> write8 wbuf 0x17 + Bidirectional -> write8 wbuf 0x16 + Unidirectional -> write8 wbuf 0x17 encodeInt' wbuf $ fromIntegral ms encodeFrame wbuf (NewConnectionID cidInfo rpt) = do write8 wbuf 0x18 @@ -148,47 +152,47 @@ where loop frames = do ok <- (>= 1) <$> remainingSize rbuf - if ok then do - frame <- decodeFrame rbuf - case frame of - UnknownFrame _ -> return Nothing - _ -> loop (frames . (frame:)) - else - return $ Just $ frames [] + if ok + then do + frame <- decodeFrame rbuf + case frame of + UnknownFrame _ -> return Nothing + _ -> loop (frames . (frame :)) + else return $ Just $ frames [] decodeFrame :: ReadBuffer -> IO Frame decodeFrame rbuf = do ftyp <- fromIntegral <$> decodeInt' rbuf case ftyp :: FrameType of - 0x00 -> decodePadding rbuf - 0x01 -> return Ping - 0x02 -> decodeAck rbuf - -- 0x03 -> Ack with ECN Counts - 0x04 -> decodeResetStream rbuf - 0x05 -> decodeStopSending rbuf - 0x06 -> decodeCrypto rbuf - 0x07 -> decodeNewToken rbuf - x | 0x08 <= x && x <= 0x0f -> do - let off = testBit x 2 - len = testBit x 1 - fin = testBit x 0 - decodeStream rbuf off len fin - 0x10 -> decodeMaxData rbuf - 0x11 -> decodeMaxStreamData rbuf - 0x12 -> decodeMaxStreams rbuf Bidirectional - 0x13 -> decodeMaxStreams rbuf Unidirectional - 0x14 -> decodeDataBlocked rbuf - 0x15 -> decodeStreamDataBlocked rbuf - 0x16 -> decodeStreamsBlocked rbuf Bidirectional - 0x17 -> decodeStreamsBlocked rbuf Unidirectional - 0x18 -> decodeNewConnectionID rbuf - 0x19 -> decodeRetireConnectionID rbuf - 0x1a -> decodePathChallenge rbuf - 0x1b -> decodePathResponse rbuf - 0x1c -> decodeConnectionClose rbuf - 0x1d -> decodeConnectionCloseApp rbuf - 0x1e -> return HandshakeDone - x -> return $ UnknownFrame x + 0x00 -> decodePadding rbuf + 0x01 -> return Ping + 0x02 -> decodeAck rbuf + -- 0x03 -> Ack with ECN Counts + 0x04 -> decodeResetStream rbuf + 0x05 -> decodeStopSending rbuf + 0x06 -> decodeCrypto rbuf + 0x07 -> decodeNewToken rbuf + x | 0x08 <= x && x <= 0x0f -> do + let off = testBit x 2 + len = testBit x 1 + fin = testBit x 0 + decodeStream rbuf off len fin + 0x10 -> decodeMaxData rbuf + 0x11 -> decodeMaxStreamData rbuf + 0x12 -> decodeMaxStreams rbuf Bidirectional + 0x13 -> decodeMaxStreams rbuf Unidirectional + 0x14 -> decodeDataBlocked rbuf + 0x15 -> decodeStreamDataBlocked rbuf + 0x16 -> decodeStreamsBlocked rbuf Bidirectional + 0x17 -> decodeStreamsBlocked rbuf Unidirectional + 0x18 -> decodeNewConnectionID rbuf + 0x19 -> decodeRetireConnectionID rbuf + 0x1a -> decodePathChallenge rbuf + 0x1b -> decodePathResponse rbuf + 0x1c -> decodeConnectionClose rbuf + 0x1d -> decodeConnectionCloseApp rbuf + 0x1e -> return HandshakeDone + x -> return $ UnknownFrame x decodePadding :: ReadBuffer -> IO Frame decodePadding rbuf = do @@ -201,39 +205,38 @@ countZero :: Ptr Word8 -> Ptr Word8 -> IO Int countZero beg0 end0 - | (end0 `minusPtr` beg0) <= ali = fst <$> countBy1 beg0 end0 0 - | otherwise = do - let beg1 = alignPtr beg0 ali - end1' = alignPtr end0 ali - end1 | end0 == end1' = end1' - | otherwise = end1' `plusPtr` negate ali - (n1,cont1) <- countBy1 beg0 beg1 0 - if not cont1 then - return n1 - else do - (n2,beg2) <- countBy8 (castPtr beg1) (castPtr end1) 0 - (n3,_) <- countBy1 (castPtr beg2) end0 0 - return (n1 + n2 + n3) + | (end0 `minusPtr` beg0) <= ali = fst <$> countBy1 beg0 end0 0 + | otherwise = do + let beg1 = alignPtr beg0 ali + end1' = alignPtr end0 ali + end1 + | end0 == end1' = end1' + | otherwise = end1' `plusPtr` negate ali + (n1, cont1) <- countBy1 beg0 beg1 0 + if not cont1 + then return n1 + else do + (n2, beg2) <- countBy8 (castPtr beg1) (castPtr end1) 0 + (n3, _) <- countBy1 (castPtr beg2) end0 0 + return (n1 + n2 + n3) where ali = alignment (0 :: Word64) - countBy1 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Int,Bool) + countBy1 :: Ptr Word8 -> Ptr Word8 -> Int -> IO (Int, Bool) countBy1 beg end n - | beg < end = do + | beg < end = do ftyp <- peek beg - if ftyp == 0 then - countBy1 (beg `plusPtr` 1) end (n + 1) - else - return (n, False) - | otherwise = return (n, True) + if ftyp == 0 + then countBy1 (beg `plusPtr` 1) end (n + 1) + else return (n, False) + | otherwise = return (n, True) countBy8 :: Ptr Word64 -> Ptr Word64 -> Int -> IO (Int, Ptr Word64) countBy8 beg end n - | beg < end = do + | beg < end = do ftyp <- peek beg - if ftyp == 0 then - countBy8 (beg `plusPtr` ali) end (n + ali) - else - return (n, beg) - | otherwise = return (n, beg) + if ftyp == 0 + then countBy8 (beg `plusPtr` ali) end (n + ali) + else return (n, beg) + | otherwise = return (n, beg) decodeCrypto :: ReadBuffer -> IO Frame decodeCrypto rbuf = do @@ -245,10 +248,10 @@ decodeAck :: ReadBuffer -> IO Frame decodeAck rbuf = do largest <- fromIntegral <$> decodeInt' rbuf - delay <- fromIntegral <$> decodeInt' rbuf - count <- fromIntegral <$> decodeInt' rbuf - range1 <- fromIntegral <$> decodeInt' rbuf - ranges <- getRanges count id + delay <- fromIntegral <$> decodeInt' rbuf + count <- fromIntegral <$> decodeInt' rbuf + range1 <- fromIntegral <$> decodeInt' rbuf + ranges <- getRanges count id return $ Ack (AckInfo largest range1 ranges) $ Milliseconds delay where getRanges 0 build = return $ build [] @@ -279,16 +282,18 @@ decodeStream :: ReadBuffer -> Bool -> Bool -> Bool -> IO Frame decodeStream rbuf hasOff hasLen fin = do sID <- fromIntegral <$> decodeInt' rbuf - off <- if hasOff then - fromIntegral <$> decodeInt' rbuf - else - return 0 - dat <- if hasLen then do - len <- fromIntegral <$> decodeInt' rbuf - extractByteString rbuf len - else do - len <- remainingSize rbuf - extractByteString rbuf len + off <- + if hasOff + then fromIntegral <$> decodeInt' rbuf + else return 0 + dat <- + if hasLen + then do + len <- fromIntegral <$> decodeInt' rbuf + extractByteString rbuf len + else do + len <- remainingSize rbuf + extractByteString rbuf len return $ StreamF sID off [dat] fin ---------------------------------------------------------------- @@ -323,16 +328,16 @@ decodeConnectionClose :: ReadBuffer -> IO Frame decodeConnectionClose rbuf = do - err <- TransportError . fromIntegral <$> decodeInt' rbuf - ftyp <- fromIntegral <$> decodeInt' rbuf - len <- fromIntegral <$> decodeInt' rbuf + err <- TransportError . fromIntegral <$> decodeInt' rbuf + ftyp <- fromIntegral <$> decodeInt' rbuf + len <- fromIntegral <$> decodeInt' rbuf reason <- extractShortByteString rbuf len return $ ConnectionClose err ftyp reason -decodeConnectionCloseApp :: ReadBuffer -> IO Frame +decodeConnectionCloseApp :: ReadBuffer -> IO Frame decodeConnectionCloseApp rbuf = do - err <- ApplicationProtocolError . fromIntegral <$> decodeInt' rbuf - len <- fromIntegral <$> decodeInt' rbuf + err <- ApplicationProtocolError . fromIntegral <$> decodeInt' rbuf + len <- fromIntegral <$> decodeInt' rbuf reason <- extractShortByteString rbuf len return $ ConnectionCloseApp err reason diff --git a/Network/QUIC/Packet/Header.hs b/Network/QUIC/Packet/Header.hs --- a/Network/QUIC/Packet/Header.hs +++ b/Network/QUIC/Packet/Header.hs @@ -1,18 +1,18 @@ {-# LANGUAGE BinaryLiterals #-} module Network.QUIC.Packet.Header ( - isLong - , isShort - , protectFlags - , unprotectFlags - , encodeLongHeaderFlags - , encodeShortHeaderFlags - , decodeLongHeaderPacketType - , encodePktNumLength - , decodePktNumLength - , versionNegotiationPacketType - , retryPacketType - ) where + isLong, + isShort, + protectFlags, + unprotectFlags, + encodeLongHeaderFlags, + encodeShortHeaderFlags, + decodeLongHeaderPacketType, + encodePktNumLength, + decodePktNumLength, + versionNegotiationPacketType, + retryPacketType, +) where import Network.QUIC.Imports import Network.QUIC.Types @@ -39,43 +39,56 @@ mask = mask1 .&. flagBits flags proFlags = flags `xor` mask - {-# INLINE flagBits #-} +{- FOURMOLU_DISABLE -} flagBits :: Word8 -> Word8 flagBits flags - | isLong flags = 0b00001111 -- long header - | otherwise = 0b00011111 -- short header + | isLong flags = 0b00001111 -- long header + | otherwise = 0b00011111 -- short header +{- FOURMOLU_ENABLE -} ---------------------------------------------------------------- randomizeQuicBit :: Word8 -> Bool -> IO Word8 randomizeQuicBit flags quicBit - | quicBit = do + | quicBit = do r <- getRandomOneByte return ((flags .&. 0b10111111) .|. (r .&. 0b01000000)) - | otherwise = return flags + | otherwise = return flags {-# INLINE encodeShortHeaderFlags #-} -encodeShortHeaderFlags :: Flags Raw -> Flags Raw -> Bool -> Bool -> IO (Flags Raw) +{- FOURMOLU_DISABLE -} +encodeShortHeaderFlags + :: Flags Raw -> Flags Raw -> Bool -> Bool -> IO (Flags Raw) encodeShortHeaderFlags (Flags fg) (Flags pp) quicBit keyPhase = Flags <$> randomizeQuicBit flags quicBit where - flags = 0b01000000 - .|. (fg .&. 0b00111100) - .|. (pp .&. 0b00000011) - .|. (if keyPhase then 0b00000100 else 0b00000000) + flags = + 0b01000000 + .|. (fg .&. 0b00111100) + .|. (pp .&. 0b00000011) + .|. (if keyPhase then 0b00000100 else 0b00000000) +{- FOURMOLU_ENABLE -} {-# INLINE encodeLongHeaderFlags #-} -encodeLongHeaderFlags :: Version -> LongHeaderPacketType -> Flags Raw -> Flags Raw -> Bool -> IO (Flags Raw) +encodeLongHeaderFlags + :: Version + -> LongHeaderPacketType + -> Flags Raw + -> Flags Raw + -> Bool + -> IO (Flags Raw) encodeLongHeaderFlags ver typ (Flags fg) (Flags pp) quicBit = Flags <$> randomizeQuicBit flags quicBit where Flags tp = longHeaderPacketType ver typ - flags = tp - .|. (fg .&. 0b00001100) - .|. (pp .&. 0b00000011) + flags = + tp + .|. (fg .&. 0b00001100) + .|. (pp .&. 0b00000011) {-# INLINE longHeaderPacketType #-} +{- FOURMOLU_DISABLE -} longHeaderPacketType :: Version -> LongHeaderPacketType -> Flags Raw longHeaderPacketType Version2 InitialPacketType = Flags 0b11010000 longHeaderPacketType Version2 RTT0PacketType = Flags 0b11100000 @@ -85,6 +98,7 @@ longHeaderPacketType _ RTT0PacketType = Flags 0b11010000 longHeaderPacketType _ HandshakePacketType = Flags 0b11100000 longHeaderPacketType _ RetryPacketType = Flags 0b11110000 +{- FOURMOLU_ENABLE -} retryPacketType :: Version -> IO (Flags Raw) retryPacketType Version2 = do @@ -103,6 +117,7 @@ return $ Flags flags {-# INLINE decodeLongHeaderPacketType #-} +{- FOURMOLU_DISABLE -} decodeLongHeaderPacketType :: Version -> Flags Protected -> LongHeaderPacketType decodeLongHeaderPacketType Version2 (Flags flags) = case flags .&. 0b00110000 of 0b00010000 -> InitialPacketType @@ -114,6 +129,7 @@ 0b00010000 -> RTT0PacketType 0b00100000 -> HandshakePacketType _ -> RetryPacketType +{- FOURMOLU_ENABLE -} {-# INLINE encodePktNumLength #-} encodePktNumLength :: Int -> Flags Raw diff --git a/Network/QUIC/Packet/Number.hs b/Network/QUIC/Packet/Number.hs --- a/Network/QUIC/Packet/Number.hs +++ b/Network/QUIC/Packet/Number.hs @@ -1,7 +1,7 @@ module Network.QUIC.Packet.Number ( - encodePacketNumber - , decodePacketNumber - ) where + encodePacketNumber, + decodePacketNumber, +) where import Network.QUIC.Imports import Network.QUIC.Types @@ -16,6 +16,7 @@ -- True -- >>> encodePacketNumber 0xabe8bc 0xace8fe == (0xace8fe, 3) -- True +{- FOURMOLU_DISABLE -} encodePacketNumber :: PacketNumber -> PacketNumber -> (EncodedPacketNumber, Int) encodePacketNumber largestPN pn = (diff, bytes) where @@ -26,6 +27,7 @@ | enoughRange < 16777216 = (0x00ffffff, 3) | otherwise = (0xffffffff, 4) diff = fromIntegral (pn .&. pnMask) +{- FOURMOLU_ENABLE -} ---------------------------------------------------------------- @@ -37,6 +39,7 @@ -- True -- >>> decodePacketNumber 0xabe8bc 0xace8fe 3 == 0xace8fe -- True +{- FOURMOLU_DISABLE -} decodePacketNumber :: PacketNumber -> EncodedPacketNumber -> Int -> PacketNumber decodePacketNumber largestPN truncatedPN bytes | candidatePN <= expectedPN - pnHwin @@ -53,3 +56,4 @@ pnMask = pnWin - 1 candidatePN = (expectedPN .&. complement pnMask) .|. fromIntegral truncatedPN +{- FOURMOLU_ENABLE -} diff --git a/Network/QUIC/Packet/Token.hs b/Network/QUIC/Packet/Token.hs --- a/Network/QUIC/Packet/Token.hs +++ b/Network/QUIC/Packet/Token.hs @@ -1,11 +1,11 @@ module Network.QUIC.Packet.Token ( - CryptoToken(..) - , isRetryToken - , generateToken - , generateRetryToken - , encryptToken - , decryptToken - ) where + CryptoToken (..), + isRetryToken, + generateToken, + generateRetryToken, + encryptToken, + decryptToken, +) where import qualified Crypto.Token as CT import Data.UnixTime @@ -19,11 +19,11 @@ ---------------------------------------------------------------- -data CryptoToken = CryptoToken { - tokenQUICVersion :: Version - , tokenCreatedTime :: TimeMicrosecond - , tokenCIDs :: Maybe (CID, CID, CID) -- local, remote, orig local - } +data CryptoToken = CryptoToken + { tokenQUICVersion :: Version + , tokenCreatedTime :: TimeMicrosecond + , tokenCIDs :: Maybe (CID, CID, CID) -- local, remote, orig local + } isRetryToken :: CryptoToken -> Bool isRetryToken token = isJust $ tokenCIDs token @@ -38,7 +38,7 @@ generateRetryToken :: Version -> CID -> CID -> CID -> IO CryptoToken generateRetryToken ver l r o = do t <- getTimeMicrosecond - return $ CryptoToken ver t $ Just (l,r,o) + return $ CryptoToken ver t $ Just (l, r, o) ---------------------------------------------------------------- @@ -55,21 +55,21 @@ -- length includes its field instance Storable CryptoToken where - sizeOf ~_ = cryptoTokenSize + sizeOf ~_ = cryptoTokenSize alignment ~_ = 4 peek ptr = do rbuf <- newReadBuffer (castPtr ptr) cryptoTokenSize - ver <- Version <$> read32 rbuf + ver <- Version <$> read32 rbuf s <- CTime . fromIntegral <$> read64 rbuf let tim = UnixTime s 0 typ <- read8 rbuf case typ of - 0 -> return $ CryptoToken ver tim Nothing - _ -> do - l <- pick rbuf - r <- pick rbuf - o <- pick rbuf - return $ CryptoToken ver tim $ Just (l,r,o) + 0 -> return $ CryptoToken ver tim Nothing + _ -> do + l <- pick rbuf + r <- pick rbuf + o <- pick rbuf + return $ CryptoToken ver tim $ Just (l, r, o) where pick rbuf = do xlen0 <- fromIntegral <$> read8 rbuf @@ -83,12 +83,12 @@ let CTime s = utSeconds tim write64 wbuf $ fromIntegral s case mcids of - Nothing -> write8 wbuf 0 - Just (l,r,o) -> do - write8 wbuf 1 - bury wbuf l - bury wbuf r - bury wbuf o + Nothing -> write8 wbuf 0 + Just (l, r, o) -> do + write8 wbuf 1 + bury wbuf l + bury wbuf r + bury wbuf o where bury wbuf x = do let (xcid, xlen) = unpackCID x diff --git a/Network/QUIC/Parameters.hs b/Network/QUIC/Parameters.hs --- a/Network/QUIC/Parameters.hs +++ b/Network/QUIC/Parameters.hs @@ -1,18 +1,18 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} module Network.QUIC.Parameters ( - Parameters(..) - , defaultParameters - , baseParameters -- only for Connection - , encodeParameters - , decodeParameters - , AuthCIDs(..) - , defaultAuthCIDs - , setCIDsToParameters - , getCIDsToParameters - ) where + Parameters (..), + defaultParameters, + baseParameters, -- only for Connection + encodeParameters, + decodeParameters, + AuthCIDs (..), + defaultAuthCIDs, + setCIDsToParameters, + getCIDsToParameters, +) where import qualified Data.ByteString as BS import qualified Data.ByteString.Short as Short @@ -30,8 +30,9 @@ newtype Key = Key Word32 deriving (Eq, Show) type Value = ByteString -type ParameterList = [(Key,Value)] +type ParameterList = [(Key, Value)] +{- FOURMOLU_DISABLE -} pattern OriginalDestinationConnectionId :: Key pattern OriginalDestinationConnectionId = Key 0x00 pattern MaxIdleTimeout :: Key @@ -72,56 +73,58 @@ pattern Grease = Key 0xff pattern GreaseQuicBit :: Key pattern GreaseQuicBit = Key 0x2ab2 - +{- FOURMOLU_ENABLE -} -- | QUIC transport parameters. -data Parameters = Parameters { - originalDestinationConnectionId :: Maybe CID - , maxIdleTimeout :: Milliseconds - , statelessResetToken :: Maybe StatelessResetToken -- 16 bytes - , maxUdpPayloadSize :: Int - , initialMaxData :: Int - , initialMaxStreamDataBidiLocal :: Int - , initialMaxStreamDataBidiRemote :: Int - , initialMaxStreamDataUni :: Int - , initialMaxStreamsBidi :: Int - , initialMaxStreamsUni :: Int - , ackDelayExponent :: Int - , maxAckDelay :: Milliseconds - , disableActiveMigration :: Bool - , preferredAddress :: Maybe ByteString -- fixme - , activeConnectionIdLimit :: Int - , initialSourceConnectionId :: Maybe CID - , retrySourceConnectionId :: Maybe CID - , grease :: Maybe ByteString - , greaseQuicBit :: Bool - , versionInformation :: Maybe VersionInfo - } deriving (Eq,Show) +data Parameters = Parameters + { originalDestinationConnectionId :: Maybe CID + , maxIdleTimeout :: Milliseconds + , statelessResetToken :: Maybe StatelessResetToken -- 16 bytes + , maxUdpPayloadSize :: Int + , initialMaxData :: Int + , initialMaxStreamDataBidiLocal :: Int + , initialMaxStreamDataBidiRemote :: Int + , initialMaxStreamDataUni :: Int + , initialMaxStreamsBidi :: Int + , initialMaxStreamsUni :: Int + , ackDelayExponent :: Int + , maxAckDelay :: Milliseconds + , disableActiveMigration :: Bool + , preferredAddress :: Maybe ByteString -- fixme + , activeConnectionIdLimit :: Int + , initialSourceConnectionId :: Maybe CID + , retrySourceConnectionId :: Maybe CID + , grease :: Maybe ByteString + , greaseQuicBit :: Bool + , versionInformation :: Maybe VersionInfo + } + deriving (Eq, Show) -- | The default value for QUIC transport parameters. baseParameters :: Parameters -baseParameters = Parameters { - originalDestinationConnectionId = Nothing - , maxIdleTimeout = Milliseconds 0 -- disabled - , statelessResetToken = Nothing - , maxUdpPayloadSize = 65527 - , initialMaxData = 0 - , initialMaxStreamDataBidiLocal = 0 - , initialMaxStreamDataBidiRemote = 0 - , initialMaxStreamDataUni = 0 - , initialMaxStreamsBidi = 0 - , initialMaxStreamsUni = 0 - , ackDelayExponent = 3 - , maxAckDelay = Milliseconds 25 - , disableActiveMigration = False - , preferredAddress = Nothing - , activeConnectionIdLimit = 2 - , initialSourceConnectionId = Nothing - , retrySourceConnectionId = Nothing - , grease = Nothing - , greaseQuicBit = False - , versionInformation = Nothing - } +baseParameters = + Parameters + { originalDestinationConnectionId = Nothing + , maxIdleTimeout = Milliseconds 0 -- disabled + , statelessResetToken = Nothing + , maxUdpPayloadSize = 65527 + , initialMaxData = 0 + , initialMaxStreamDataBidiLocal = 0 + , initialMaxStreamDataBidiRemote = 0 + , initialMaxStreamDataUni = 0 + , initialMaxStreamsBidi = 0 + , initialMaxStreamsUni = 0 + , ackDelayExponent = 3 + , maxAckDelay = Milliseconds 25 + , disableActiveMigration = False + , preferredAddress = Nothing + , activeConnectionIdLimit = 2 + , initialSourceConnectionId = Nothing + , retrySourceConnectionId = Nothing + , grease = Nothing + , greaseQuicBit = False + , versionInformation = Nothing + } decInt :: ByteString -> Int decInt = fromIntegral . decodeInt @@ -136,7 +139,7 @@ encMilliseconds (Milliseconds n) = encodeInt $ fromIntegral n fromVersionInfo :: Maybe VersionInfo -> Value -fromVersionInfo Nothing = "" -- never reach +fromVersionInfo Nothing = "" -- never reach fromVersionInfo (Just VersionInfo{..}) = unsafeDupablePerformIO $ withWriteBuffer len $ \wbuf -> do let putVersion (Version ver) = write32 wbuf ver @@ -147,95 +150,112 @@ toVersionInfo :: Value -> Maybe VersionInfo toVersionInfo bs - | len < 3 || remainder /= 0 = Just brokenVersionInfo - | otherwise = Just $ unsafeDupablePerformIO $ - withReadBuffer bs $ \rbuf -> do - let getVersion = Version <$> read32 rbuf - VersionInfo <$> getVersion <*> replicateM (cnt - 1) getVersion + | len < 3 || remainder /= 0 = Just brokenVersionInfo + | otherwise = Just $ + unsafeDupablePerformIO $ + withReadBuffer bs $ \rbuf -> do + let getVersion = Version <$> read32 rbuf + VersionInfo <$> getVersion <*> replicateM (cnt - 1) getVersion where len = BS.length bs - (cnt,remainder) = len `divMod` 4 + (cnt, remainder) = len `divMod` 4 fromParameterList :: ParameterList -> Parameters fromParameterList kvs = foldl' update params kvs where params = baseParameters - update x (OriginalDestinationConnectionId,v) - = x { originalDestinationConnectionId = Just (toCID v) } - update x (MaxIdleTimeout,v) - = x { maxIdleTimeout = decMilliseconds v } - update x (StateLessResetToken,v) - = x { statelessResetToken = Just (StatelessResetToken $ Short.toShort v) } - update x (MaxUdpPayloadSize,v) - = x { maxUdpPayloadSize = decInt v } - update x (InitialMaxData,v) - = x { initialMaxData = decInt v } - update x (InitialMaxStreamDataBidiLocal,v) - = x { initialMaxStreamDataBidiLocal = decInt v } - update x (InitialMaxStreamDataBidiRemote,v) - = x { initialMaxStreamDataBidiRemote = decInt v } - update x (InitialMaxStreamDataUni,v) - = x { initialMaxStreamDataUni = decInt v } - update x (InitialMaxStreamsBidi,v) - = x { initialMaxStreamsBidi = decInt v } - update x (InitialMaxStreamsUni,v) - = x { initialMaxStreamsUni = decInt v } - update x (AckDelayExponent,v) - = x { ackDelayExponent = decInt v } - update x (MaxAckDelay,v) - = x { maxAckDelay = decMilliseconds v } - update x (DisableActiveMigration,_) - = x { disableActiveMigration = True } - update x (PreferredAddress,v) - = x { preferredAddress = Just v } - update x (ActiveConnectionIdLimit,v) - = x { activeConnectionIdLimit = decInt v } - update x (InitialSourceConnectionId,v) - = x { initialSourceConnectionId = Just (toCID v) } - update x (RetrySourceConnectionId,v) - = x { retrySourceConnectionId = Just (toCID v) } - update x (Grease,v) - = x { grease = Just v } - update x (GreaseQuicBit,_) - = x { greaseQuicBit = True } - update x (VersionInformation,v) - = x { versionInformation = toVersionInfo v } + update x (OriginalDestinationConnectionId, v) = + x{originalDestinationConnectionId = Just (toCID v)} + update x (MaxIdleTimeout, v) = + x{maxIdleTimeout = decMilliseconds v} + update x (StateLessResetToken, v) = + x{statelessResetToken = Just (StatelessResetToken $ Short.toShort v)} + update x (MaxUdpPayloadSize, v) = + x{maxUdpPayloadSize = decInt v} + update x (InitialMaxData, v) = + x{initialMaxData = decInt v} + update x (InitialMaxStreamDataBidiLocal, v) = + x{initialMaxStreamDataBidiLocal = decInt v} + update x (InitialMaxStreamDataBidiRemote, v) = + x{initialMaxStreamDataBidiRemote = decInt v} + update x (InitialMaxStreamDataUni, v) = + x{initialMaxStreamDataUni = decInt v} + update x (InitialMaxStreamsBidi, v) = + x{initialMaxStreamsBidi = decInt v} + update x (InitialMaxStreamsUni, v) = + x{initialMaxStreamsUni = decInt v} + update x (AckDelayExponent, v) = + x{ackDelayExponent = decInt v} + update x (MaxAckDelay, v) = + x{maxAckDelay = decMilliseconds v} + update x (DisableActiveMigration, _) = + x{disableActiveMigration = True} + update x (PreferredAddress, v) = + x{preferredAddress = Just v} + update x (ActiveConnectionIdLimit, v) = + x{activeConnectionIdLimit = decInt v} + update x (InitialSourceConnectionId, v) = + x{initialSourceConnectionId = Just (toCID v)} + update x (RetrySourceConnectionId, v) = + x{retrySourceConnectionId = Just (toCID v)} + update x (Grease, v) = + x{grease = Just v} + update x (GreaseQuicBit, _) = + x{greaseQuicBit = True} + update x (VersionInformation, v) = + x{versionInformation = toVersionInfo v} update x _ = x -diff :: Eq a => Parameters -> (Parameters -> a) -> Key -> (a -> Value) -> Maybe (Key,Value) +diff + :: Eq a + => Parameters + -> (Parameters -> a) + -> Key + -> (a -> Value) + -> Maybe (Key, Value) diff params label key enc - | val == val0 = Nothing - | otherwise = Just (key, enc val) + | val == val0 = Nothing + | otherwise = Just (key, enc val) where val = label params val0 = label baseParameters toParameterList :: Parameters -> ParameterList -toParameterList p = catMaybes [ - diff p originalDestinationConnectionId - OriginalDestinationConnectionId (fromCID . fromJust) - , diff p maxIdleTimeout MaxIdleTimeout encMilliseconds - , diff p statelessResetToken StateLessResetToken encSRT - , diff p maxUdpPayloadSize MaxUdpPayloadSize encInt - , diff p initialMaxData InitialMaxData encInt - , diff p initialMaxStreamDataBidiLocal InitialMaxStreamDataBidiLocal encInt - , diff p initialMaxStreamDataBidiRemote InitialMaxStreamDataBidiRemote encInt - , diff p initialMaxStreamDataUni InitialMaxStreamDataUni encInt - , diff p initialMaxStreamsBidi InitialMaxStreamsBidi encInt - , diff p initialMaxStreamsUni InitialMaxStreamsUni encInt - , diff p ackDelayExponent AckDelayExponent encInt - , diff p maxAckDelay MaxAckDelay encMilliseconds - , diff p disableActiveMigration DisableActiveMigration (const "") - , diff p preferredAddress PreferredAddress fromJust - , diff p activeConnectionIdLimit ActiveConnectionIdLimit encInt - , diff p initialSourceConnectionId - InitialSourceConnectionId (fromCID . fromJust) - , diff p retrySourceConnectionId - RetrySourceConnectionId (fromCID . fromJust) - , diff p greaseQuicBit GreaseQuicBit (const "") - , diff p grease Grease fromJust - , diff p versionInformation VersionInformation fromVersionInfo - ] +toParameterList p = + catMaybes + [ diff + p + originalDestinationConnectionId + OriginalDestinationConnectionId + (fromCID . fromJust) + , diff p maxIdleTimeout MaxIdleTimeout encMilliseconds + , diff p statelessResetToken StateLessResetToken encSRT + , diff p maxUdpPayloadSize MaxUdpPayloadSize encInt + , diff p initialMaxData InitialMaxData encInt + , diff p initialMaxStreamDataBidiLocal InitialMaxStreamDataBidiLocal encInt + , diff p initialMaxStreamDataBidiRemote InitialMaxStreamDataBidiRemote encInt + , diff p initialMaxStreamDataUni InitialMaxStreamDataUni encInt + , diff p initialMaxStreamsBidi InitialMaxStreamsBidi encInt + , diff p initialMaxStreamsUni InitialMaxStreamsUni encInt + , diff p ackDelayExponent AckDelayExponent encInt + , diff p maxAckDelay MaxAckDelay encMilliseconds + , diff p disableActiveMigration DisableActiveMigration (const "") + , diff p preferredAddress PreferredAddress fromJust + , diff p activeConnectionIdLimit ActiveConnectionIdLimit encInt + , diff + p + initialSourceConnectionId + InitialSourceConnectionId + (fromCID . fromJust) + , diff + p + retrySourceConnectionId + RetrySourceConnectionId + (fromCID . fromJust) + , diff p greaseQuicBit GreaseQuicBit (const "") + , diff p grease Grease fromJust + , diff p versionInformation VersionInformation fromVersionInfo + ] encSRT :: Maybe StatelessResetToken -> ByteString encSRT (Just (StatelessResetToken srt)) = Short.fromShort srt @@ -243,10 +263,11 @@ encodeParameterList :: ParameterList -> ByteString encodeParameterList kvs = unsafeDupablePerformIO $ - withWriteBuffer 4096 $ \wbuf -> do -- for grease + withWriteBuffer 4096 $ \wbuf -> do + -- for grease mapM_ (put wbuf) kvs where - put wbuf (Key k,v) = do + put wbuf (Key k, v) = do encodeInt' wbuf $ fromIntegral k encodeInt' wbuf $ fromIntegral $ BS.length v copyByteString wbuf v @@ -255,49 +276,53 @@ decodeParameterList bs = unsafeDupablePerformIO $ withReadBuffer bs (`go` id) where go rbuf build = do - rest1 <- remainingSize rbuf - if rest1 == 0 then - return $ Just (build []) - else do - key <- fromIntegral <$> decodeInt' rbuf - len <- fromIntegral <$> decodeInt' rbuf - val <- extractByteString rbuf len - go rbuf (build . ((Key key,val):)) + rest1 <- remainingSize rbuf + if rest1 == 0 + then return $ Just (build []) + else do + key <- fromIntegral <$> decodeInt' rbuf + len <- fromIntegral <$> decodeInt' rbuf + val <- extractByteString rbuf len + go rbuf (build . ((Key key, val) :)) -- | An example parameters obsoleted in the near future. defaultParameters :: Parameters -defaultParameters = baseParameters { - maxIdleTimeout = microToMilli idleTimeout -- 30000 - , maxUdpPayloadSize = maximumUdpPayloadSize -- 2048 - , initialMaxData = 1048576 - , initialMaxStreamDataBidiLocal = 262144 - , initialMaxStreamDataBidiRemote = 262144 - , initialMaxStreamDataUni = 262144 - , initialMaxStreamsBidi = 100 - , initialMaxStreamsUni = 3 - , activeConnectionIdLimit = 3 - , greaseQuicBit = True - } +defaultParameters = + baseParameters + { maxIdleTimeout = microToMilli idleTimeout -- 30000 + , maxUdpPayloadSize = maximumUdpPayloadSize -- 2048 + , initialMaxData = 1048576 + , initialMaxStreamDataBidiLocal = 262144 + , initialMaxStreamDataBidiRemote = 262144 + , initialMaxStreamDataUni = 262144 + , initialMaxStreamsBidi = 100 + , initialMaxStreamsUni = 3 + , activeConnectionIdLimit = 3 + , greaseQuicBit = True + } -data AuthCIDs = AuthCIDs { - initSrcCID :: Maybe CID - , origDstCID :: Maybe CID - , retrySrcCID :: Maybe CID - } deriving (Eq, Show) +data AuthCIDs = AuthCIDs + { initSrcCID :: Maybe CID + , origDstCID :: Maybe CID + , retrySrcCID :: Maybe CID + } + deriving (Eq, Show) defaultAuthCIDs :: AuthCIDs defaultAuthCIDs = AuthCIDs Nothing Nothing Nothing setCIDsToParameters :: AuthCIDs -> Parameters -> Parameters -setCIDsToParameters AuthCIDs{..} params = params { - originalDestinationConnectionId = origDstCID - , initialSourceConnectionId = initSrcCID - , retrySourceConnectionId = retrySrcCID - } +setCIDsToParameters AuthCIDs{..} params = + params + { originalDestinationConnectionId = origDstCID + , initialSourceConnectionId = initSrcCID + , retrySourceConnectionId = retrySrcCID + } getCIDsToParameters :: Parameters -> AuthCIDs -getCIDsToParameters Parameters{..} = AuthCIDs { - origDstCID = originalDestinationConnectionId - , initSrcCID = initialSourceConnectionId - , retrySrcCID = retrySourceConnectionId - } +getCIDsToParameters Parameters{..} = + AuthCIDs + { origDstCID = originalDestinationConnectionId + , initSrcCID = initialSourceConnectionId + , retrySrcCID = retrySourceConnectionId + } diff --git a/Network/QUIC/QLogger.hs b/Network/QUIC/QLogger.hs --- a/Network/QUIC/QLogger.hs +++ b/Network/QUIC/QLogger.hs @@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.QLogger ( - QLogger - , dirQLogger - ) where + QLogger, + dirQLogger, +) where import System.FilePath import System.Log.FastLogger @@ -12,7 +12,8 @@ import Network.QUIC.Qlog import Network.QUIC.Types -dirQLogger :: Maybe FilePath -> TimeMicrosecond -> CID -> ByteString -> IO (QLogger, IO ()) +dirQLogger + :: Maybe FilePath -> TimeMicrosecond -> CID -> ByteString -> IO (QLogger, IO ()) dirQLogger Nothing _ _ _ = do let qLog ~_ = return () clean = return () diff --git a/Network/QUIC/Qlog.hs b/Network/QUIC/Qlog.hs --- a/Network/QUIC/Qlog.hs +++ b/Network/QUIC/Qlog.hs @@ -3,23 +3,23 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Qlog ( - QLogger - , newQlogger - , Qlog(..) - , KeepQlog(..) - , QlogMsg(..) - , qlogReceived - , qlogDropped - , qlogRecvInitial - , qlogSentRetry - , qlogParamsSet - , qlogDebug - , qlogCIDUpdate - , Debug(..) - , LR(..) - , packetType - , sw - ) where + QLogger, + newQlogger, + Qlog (..), + KeepQlog (..), + QlogMsg (..), + qlogReceived, + qlogDropped, + qlogRecvInitial, + qlogSentRetry, + qlogParamsSet, + qlogDebug, + qlogCIDUpdate, + Debug (..), + LR (..), + packetType, + sw, +) where import qualified Data.ByteString as BS @@ -44,14 +44,15 @@ qlog (Debug msg) = "{\"message\":\"" <> msg <> "\"}" instance Qlog LR where - qlog (Local cid) = "{\"owner\":\"local\",\"new\":\"" <> sw cid <> "\"}" + qlog (Local cid) = "{\"owner\":\"local\",\"new\":\"" <> sw cid <> "\"}" qlog (Remote cid) = "{\"owner\":\"remote\",\"new\":\"" <> sw cid <> "\"}" instance Qlog RetryPacket where qlog RetryPacket{} = "{\"header\":{\"packet_type\":\"retry\",\"packet_number\":\"\"}}" instance Qlog VersionNegotiationPacket where - qlog VersionNegotiationPacket{} = "{\"header\":{\"packet_type\":\"version_negotiation\",\"packet_number\":\"\"}}" + qlog VersionNegotiationPacket{} = + "{\"header\":{\"packet_type\":\"version_negotiation\",\"packet_number\":\"\"}}" instance Qlog Header where qlog hdr = "{\"header\":{\"packet_type\":\"" <> packetType hdr <> "\"}}" @@ -60,90 +61,126 @@ qlog (CryptPacket hdr _) = qlog hdr instance Qlog PlainPacket where - qlog (PlainPacket hdr Plain{..}) = "{\"header\":{\"packet_type\":\"" <> toLogStr (packetType hdr) <> "\",\"packet_number\":\"" <> sw plainPacketNumber <> "\",\"dcid\":\"" <> sw (headerMyCID hdr) <> "\"},\"frames\":[" <> foldr (<>) "" (intersperse "," (map qlog plainFrames)) <> "]}" + qlog (PlainPacket hdr Plain{..}) = + "{\"header\":{\"packet_type\":\"" + <> toLogStr (packetType hdr) + <> "\",\"packet_number\":\"" + <> sw plainPacketNumber + <> "\",\"dcid\":\"" + <> sw (headerMyCID hdr) + <> "\"},\"frames\":[" + <> foldr (<>) "" (intersperse "," (map qlog plainFrames)) + <> "]}" instance Qlog StatelessReset where qlog StatelessReset = "{\"header\":{\"packet_type\":\"stateless_reset\",\"packet_number\":\"\"}}" packetType :: Header -> LogStr -packetType Initial{} = "initial" -packetType RTT0{} = "0RTT" +packetType Initial{} = "initial" +packetType RTT0{} = "0RTT" packetType Handshake{} = "handshake" -packetType Short{} = "1RTT" +packetType Short{} = "1RTT" instance Qlog Frame where qlog frame = "{\"frame_type\":\"" <> frameType frame <> "\"" <> frameExtra frame <> "}" frameType :: Frame -> LogStr -frameType Padding{} = "padding" -frameType Ping = "ping" -frameType Ack{} = "ack" -frameType ResetStream{} = "reset_stream" -frameType StopSending{} = "stop_sending" -frameType CryptoF{} = "crypto" -frameType NewToken{} = "new_token" -frameType StreamF{} = "stream" -frameType MaxData{} = "max_data" -frameType MaxStreamData{} = "max_stream_data" -frameType MaxStreams{} = "max_streams" -frameType DataBlocked{} = "data_blocked" -frameType StreamDataBlocked{} = "stream_data_blocked" -frameType StreamsBlocked{} = "streams_blocked" -frameType NewConnectionID{} = "new_connection_id" -frameType RetireConnectionID{} = "retire_connection_id" -frameType PathChallenge{} = "path_challenge" -frameType PathResponse{} = "path_response" -frameType ConnectionClose{} = "connection_close" -frameType ConnectionCloseApp{} = "connection_close" -frameType HandshakeDone{} = "handshake_done" -frameType UnknownFrame{} = "unknown" +frameType Padding{} = "padding" +frameType Ping = "ping" +frameType Ack{} = "ack" +frameType ResetStream{} = "reset_stream" +frameType StopSending{} = "stop_sending" +frameType CryptoF{} = "crypto" +frameType NewToken{} = "new_token" +frameType StreamF{} = "stream" +frameType MaxData{} = "max_data" +frameType MaxStreamData{} = "max_stream_data" +frameType MaxStreams{} = "max_streams" +frameType DataBlocked{} = "data_blocked" +frameType StreamDataBlocked{} = "stream_data_blocked" +frameType StreamsBlocked{} = "streams_blocked" +frameType NewConnectionID{} = "new_connection_id" +frameType RetireConnectionID{} = "retire_connection_id" +frameType PathChallenge{} = "path_challenge" +frameType PathResponse{} = "path_response" +frameType ConnectionClose{} = "connection_close" +frameType ConnectionCloseApp{} = "connection_close" +frameType HandshakeDone{} = "handshake_done" +frameType UnknownFrame{} = "unknown" {-# INLINE frameExtra #-} frameExtra :: Frame -> LogStr frameExtra (Padding n) = ",\"payload_length\":" <> sw n -frameExtra Ping = "" +frameExtra Ping = "" frameExtra (Ack ai _Delay) = ",\"acked_ranges\":" <> ack ai frameExtra ResetStream{} = "" frameExtra (StopSending _StreamId _ApplicationError) = "" -frameExtra (CryptoF off dat) = ",\"offset\":\"" <> sw off <> "\",\"length\":" <> sw (BS.length dat) +frameExtra (CryptoF off dat) = ",\"offset\":\"" <> sw off <> "\",\"length\":" <> sw (BS.length dat) frameExtra (NewToken _Token) = "" -frameExtra (StreamF sid off dat fin) = ",\"stream_id\":\"" <> sw sid <> "\",\"offset\":\"" <> sw off <> "\",\"length\":" <> sw (sum' $ map BS.length dat) <> ",\"fin\":" <> if fin then "true" else "false" +frameExtra (StreamF sid off dat fin) = + ",\"stream_id\":\"" + <> sw sid + <> "\",\"offset\":\"" + <> sw off + <> "\",\"length\":" + <> sw (sum' $ map BS.length dat) + <> ",\"fin\":" + <> if fin then "true" else "false" frameExtra (MaxData mx) = ",\"maximum\":\"" <> sw mx <> "\"" frameExtra (MaxStreamData sid mx) = ",\"stream_id\":\"" <> sw sid <> "\",\"maximum\":\"" <> sw mx <> "\"" frameExtra (MaxStreams _Direction ms) = ",\"maximum\":\"" <> sw ms <> "\"" frameExtra DataBlocked{} = "" frameExtra StreamDataBlocked{} = "" frameExtra StreamsBlocked{} = "" -frameExtra (NewConnectionID (CIDInfo sn cid _) rpt) = ",\"sequence_number\":\"" <> sw sn <> "\",\"connection_id:\":\"" <> sw cid <> "\",\"retire_prior_to\":\"" <> sw rpt <> "\"" +frameExtra (NewConnectionID (CIDInfo sn cid _) rpt) = + ",\"sequence_number\":\"" + <> sw sn + <> "\",\"connection_id:\":\"" + <> sw cid + <> "\",\"retire_prior_to\":\"" + <> sw rpt + <> "\"" frameExtra (RetireConnectionID sn) = ",\"sequence_number\":\"" <> sw sn <> "\"" frameExtra (PathChallenge _PathData) = "" frameExtra (PathResponse _PathData) = "" -frameExtra (ConnectionClose err _FrameType reason) = ",\"error_space\":\"transport\",\"error_code\":\"" <> transportError err <> "\",\"raw_error_code\":" <> transportError' err <> ",\"reason\":\"" <> toLogStr (Short.fromShort reason) <> "\"" -frameExtra (ConnectionCloseApp err reason) = ",\"error_space\":\"application\",\"error_code\":" <> applicationProtoclError err <> ",\"reason\":\"" <> toLogStr (Short.fromShort reason) <> "\"" -- fixme +frameExtra (ConnectionClose err _FrameType reason) = + ",\"error_space\":\"transport\",\"error_code\":\"" + <> transportError err + <> "\",\"raw_error_code\":" + <> transportError' err + <> ",\"reason\":\"" + <> toLogStr (Short.fromShort reason) + <> "\"" +frameExtra (ConnectionCloseApp err reason) = + ",\"error_space\":\"application\",\"error_code\":" + <> applicationProtoclError err + <> ",\"reason\":\"" + <> toLogStr (Short.fromShort reason) + <> "\"" -- fixme frameExtra HandshakeDone{} = "" frameExtra (UnknownFrame _Int) = "" transportError :: TransportError -> LogStr -transportError NoError = "no_error" -transportError InternalError = "internal_error" -transportError ConnectionRefused = "connection_refused" -transportError FlowControlError = "flow_control_error" -transportError StreamLimitError = "stream_limit_error" -transportError StreamStateError = "stream_state_error" -transportError FinalSizeError = "final_size_error" -transportError FrameEncodingError = "frame_encoding_error" +transportError NoError = "no_error" +transportError InternalError = "internal_error" +transportError ConnectionRefused = "connection_refused" +transportError FlowControlError = "flow_control_error" +transportError StreamLimitError = "stream_limit_error" +transportError StreamStateError = "stream_state_error" +transportError FinalSizeError = "final_size_error" +transportError FrameEncodingError = "frame_encoding_error" transportError TransportParameterError = "transport_parameter_err" -transportError ConnectionIdLimitError = "connection_id_limit_error" -transportError ProtocolViolation = "protocol_violation" -transportError InvalidToken = "invalid_migration" -transportError CryptoBufferExceeded = "crypto_buffer_exceeded" -transportError KeyUpdateError = "key_update_error" -transportError AeadLimitReached = "aead_limit_reached" -transportError NoViablePath = "no_viablpath" -transportError (TransportError n) = sw n +transportError ConnectionIdLimitError = "connection_id_limit_error" +transportError ProtocolViolation = "protocol_violation" +transportError InvalidToken = "invalid_migration" +transportError CryptoBufferExceeded = "crypto_buffer_exceeded" +transportError KeyUpdateError = "key_update_error" +transportError AeadLimitReached = "aead_limit_reached" +transportError NoViablePath = "no_viablpath" +transportError (TransportError n) = sw n transportError' :: TransportError -> LogStr -transportError' (TransportError n) = sw n +transportError' (TransportError n) = sw n applicationProtoclError :: ApplicationProtocolError -> LogStr applicationProtoclError (ApplicationProtocolError n) = sw n @@ -153,12 +190,13 @@ ack (AckInfo lpn r rs) = "[" <> ack1 fr fpn rs <> "]" where fpn = fromIntegral lpn - r - fr | r == 0 = "[" <> sw lpn <> "]" - | otherwise = "[" <> sw fpn <> "," <> sw lpn <> "]" + fr + | r == 0 = "[" <> sw lpn <> "]" + | otherwise = "[" <> sw fpn <> "," <> sw lpn <> "]" ack1 :: LogStr -> Range -> [(Gap, Range)] -> LogStr -ack1 ret _ [] = ret -ack1 ret fpn ((g,r):grs) = ack1 ret' f grs +ack1 ret _ [] = ret +ack1 ret fpn ((g, r) : grs) = ack1 ret' f grs where ret' = "[" <> sw f <> "," <> sw l <> "]," <> ret l = fpn - g - 2 @@ -166,29 +204,35 @@ ---------------------------------------------------------------- -instance Qlog (Parameters,String) where - qlog (Parameters{..},owner) = - "{\"owner\":\"" <> toLogStr owner - <> "\",\"initial_max_data\":\"" <> sw initialMaxData - <> "\",\"initial_max_stream_data_bidi_local\":\"" <> sw initialMaxStreamDataBidiLocal - <> "\",\"initial_max_stream_data_bidi_remote\":\"" <> sw initialMaxStreamDataBidiRemote - <> "\",\"initial_max_stream_data_uni\":\"" <> sw initialMaxStreamDataUni - <> "\"}" +instance Qlog (Parameters, String) where + qlog (Parameters{..}, owner) = + "{\"owner\":\"" + <> toLogStr owner + <> "\",\"initial_max_data\":\"" + <> sw initialMaxData + <> "\",\"initial_max_stream_data_bidi_local\":\"" + <> sw initialMaxStreamDataBidiLocal + <> "\",\"initial_max_stream_data_bidi_remote\":\"" + <> sw initialMaxStreamDataBidiRemote + <> "\",\"initial_max_stream_data_uni\":\"" + <> sw initialMaxStreamDataUni + <> "\"}" ---------------------------------------------------------------- -data QlogMsg = QRecvInitial - | QSentRetry - | QSent LogStr TimeMicrosecond - | QReceived LogStr TimeMicrosecond - | QDropped LogStr TimeMicrosecond - | QMetricsUpdated LogStr TimeMicrosecond - | QPacketLost LogStr TimeMicrosecond - | QCongestionStateUpdated LogStr TimeMicrosecond - | QLossTimerUpdated LogStr TimeMicrosecond - | QDebug LogStr TimeMicrosecond - | QParamsSet LogStr TimeMicrosecond - | QCIDUpdate LogStr TimeMicrosecond +data QlogMsg + = QRecvInitial + | QSentRetry + | QSent LogStr TimeMicrosecond + | QReceived LogStr TimeMicrosecond + | QDropped LogStr TimeMicrosecond + | QMetricsUpdated LogStr TimeMicrosecond + | QPacketLost LogStr TimeMicrosecond + | QCongestionStateUpdated LogStr TimeMicrosecond + | QLossTimerUpdated LogStr TimeMicrosecond + | QDebug LogStr TimeMicrosecond + | QParamsSet LogStr TimeMicrosecond + | QCIDUpdate LogStr TimeMicrosecond {-# INLINE toLogStrTime #-} toLogStrTime :: QlogMsg -> TimeMicrosecond -> LogStr @@ -197,25 +241,65 @@ toLogStrTime QSentRetry _ = "{\"time\":0,\"name\":\"transport:packet_sent\",\"data\":{\"header\":{\"packet_type\":\"retry\",\"packet_number\":\"\"}}}\n" toLogStrTime (QReceived msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"transport:packet_received\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"transport:packet_received\",\"data\":" + <> msg + <> "}\n" toLogStrTime (QSent msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"transport:packet_sent\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"transport:packet_sent\",\"data\":" + <> msg + <> "}\n" toLogStrTime (QDropped msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"transport:packet_dropped\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"transport:packet_dropped\",\"data\":" + <> msg + <> "}\n" toLogStrTime (QParamsSet msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"transport:parameters_set\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"transport:parameters_set\",\"data\":" + <> msg + <> "}\n" toLogStrTime (QMetricsUpdated msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"recovery:metrics_updated\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"recovery:metrics_updated\",\"data\":" + <> msg + <> "}\n" toLogStrTime (QPacketLost msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"recovery:packet_lost\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"recovery:packet_lost\",\"data\":" + <> msg + <> "}\n" toLogStrTime (QCongestionStateUpdated msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"recovery:congestion_state_updated\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"recovery:congestion_state_updated\",\"data\":" + <> msg + <> "}\n" toLogStrTime (QLossTimerUpdated msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"recovery:loss_timer_updated\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"recovery:loss_timer_updated\",\"data\":" + <> msg + <> "}\n" toLogStrTime (QDebug msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"debug\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"debug\",\"data\":" + <> msg + <> "}\n" toLogStrTime (QCIDUpdate msg tim) base = - "{\"time\":" <> swtim tim base <> ",\"name\":\"connectivity:connection_id_updated\",\"data\":" <> msg <> "}\n" + "{\"time\":" + <> swtim tim base + <> ",\"name\":\"connectivity:connection_id_updated\",\"data\":" + <> msg + <> "}\n" ---------------------------------------------------------------- @@ -228,7 +312,7 @@ swtim tim base = toLogStr (show m ++ "." ++ show u) where Microseconds x = elapsedTimeMicrosecond tim base - (m,u) = x `divMod` 1000 + (m, u) = x `divMod` 1000 ---------------------------------------------------------------- @@ -237,7 +321,16 @@ newQlogger :: TimeMicrosecond -> ByteString -> CID -> FastLogger -> IO QLogger newQlogger base rl ocid fastLogger = do let ocid' = toLogStr $ enc16 $ fromCID ocid - fastLogger $ "{\"qlog_format\":\"NDJSON\",\"qlog_version\":\"draft-02\",\"title\":\"Haskell quic qlog\",\"trace\":{\"vantage_point\":{\"type\":\"" <> toLogStr rl <> "\"},\"common_fields\":{\"ODCID\":\"" <> ocid' <> "\",\"group_id\":\"" <> ocid' <> "\",\"reference_time\":" <> swtim base timeMicrosecond0 <> "}}}\n" + fastLogger $ + "{\"qlog_format\":\"NDJSON\",\"qlog_version\":\"draft-02\",\"title\":\"Haskell quic qlog\",\"trace\":{\"vantage_point\":{\"type\":\"" + <> toLogStr rl + <> "\"},\"common_fields\":{\"ODCID\":\"" + <> ocid' + <> "\",\"group_id\":\"" + <> ocid' + <> "\",\"reference_time\":" + <> swtim base timeMicrosecond0 + <> "}}}\n" let qlogger qmsg = do let msg = toLogStrTime qmsg base fastLogger msg @@ -262,7 +355,7 @@ qlogSentRetry :: KeepQlog q => q -> IO () qlogSentRetry q = keepQlog q QSentRetry -qlogParamsSet :: KeepQlog q => q -> (Parameters,String) -> IO () +qlogParamsSet :: KeepQlog q => q -> (Parameters, String) -> IO () qlogParamsSet q params = do tim <- getTimeMicrosecond keepQlog q $ QParamsSet (qlog params) tim diff --git a/Network/QUIC/Receiver.hs b/Network/QUIC/Receiver.hs --- a/Network/QUIC/Receiver.hs +++ b/Network/QUIC/Receiver.hs @@ -2,11 +2,12 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Receiver ( - receiver - ) where + receiver, +) where import qualified Data.ByteString as BS -import Network.TLS (AlertDescription(..)) +import Network.Control +import Network.TLS (AlertDescription (..)) import UnliftIO.Concurrent (forkIO) import qualified UnliftIO.Exception as E @@ -23,7 +24,7 @@ import Network.QUIC.Recovery import Network.QUIC.Server.Reader (runNewServerReader) import Network.QUIC.Stream -import Network.QUIC.Types +import Network.QUIC.Types as QUIC receiver :: Connection -> IO () receiver conn = handleLogT logAction body @@ -37,13 +38,14 @@ ito <- readMinIdleTimeout conn mx <- timeout ito "recvTimeout" $ connRecv conn -- fixme: taking minimum with peer's one case mx of - Nothing -> do - st <- getConnectionState conn - let msg0 | isClient conn = "Client" - | otherwise = "Server" - msg = msg0 ++ " " ++ show st - E.throwIO $ ConnectionIsTimeout msg - Just x -> return x + Nothing -> do + st <- getConnectionState conn + let msg0 + | isClient conn = "Client" + | otherwise = "Server" + msg = msg0 ++ " " ++ show st + E.throwIO $ ConnectionIsTimeout msg + Just x -> return x loopHandshake = do rpkt <- recvTimeout processReceivedPacketHandshake conn rpkt @@ -55,70 +57,88 @@ cid = headerMyCID hdr included <- myCIDsInclude conn cid case included of - Just nseq -> do - shouldUpdate <- shouldUpdateMyCID conn nseq - when shouldUpdate $ do - setMyCID conn cid - cidInfo <- getNewMyCID conn - when (isServer conn) $ do - register <- getRegister conn - register (cidInfoCID cidInfo) conn - sendFrames conn RTT1Level [NewConnectionID cidInfo 0] - processReceivedPacket conn rpkt - shouldUpdatePeer <- if shouldUpdate then shouldUpdatePeerCID conn - else return False - when shouldUpdatePeer $ choosePeerCIDForPrivacy conn - _ -> do - qlogDropped conn hdr - connDebugLog conn $ bhow cid <> " is unknown" + Just nseq -> do + shouldUpdate <- shouldUpdateMyCID conn nseq + when shouldUpdate $ do + setMyCID conn cid + cidInfo <- getNewMyCID conn + when (isServer conn) $ do + register <- getRegister conn + register (cidInfoCID cidInfo) conn + sendFrames conn RTT1Level [NewConnectionID cidInfo 0] + processReceivedPacket conn rpkt + shouldUpdatePeer <- + if shouldUpdate + then shouldUpdatePeerCID conn + else return False + when shouldUpdatePeer $ choosePeerCIDForPrivacy conn + _ -> do + qlogDropped conn hdr + connDebugLog conn $ bhow cid <> " is unknown" logAction msg = connDebugLog conn ("debug: receiver: " <> msg) processReceivedPacketHandshake :: Connection -> ReceivedPacket -> IO () processReceivedPacketHandshake conn rpkt = do let CryptPacket hdr _ = rpCryptPacket rpkt lvl = rpEncryptionLevel rpkt - msg = "processReceivedPacketHandshake " ++ if isServer conn then "Server" else "Client" + msg = + "processReceivedPacketHandshake " + ++ if isServer conn then "Server" else "Client" mx <- timeout (Microseconds 10000) msg $ waitEncryptionLevel conn lvl case mx of - Nothing -> do - putOffCrypto conn lvl rpkt - when (isClient conn) $ do - lvl' <- getEncryptionLevel conn - speedup (connLDCC conn) lvl' "not decryptable" - Just () - | isClient conn -> do - when (lvl == InitialLevel) $ do - peercid <- getPeerCID conn - let newPeerCID = headerPeerCID hdr - when (peercid /= headerPeerCID hdr) $ - resetPeerCID conn newPeerCID - setPeerAuthCIDs conn $ \auth -> - auth { initSrcCID = Just newPeerCID } - case hdr of - Initial peerVer _ _ _ -> do - myVer <- getVersion conn - let myOrigiVer = getOriginalVersion conn - firstTime = myVer == myOrigiVer - when (firstTime && myVer /= peerVer) $ do - setVersion conn peerVer - dcid <- getClientDstCID conn - initializeCoder conn InitialLevel $ initialSecrets peerVer dcid - _ -> return () - processReceivedPacket conn rpkt - | otherwise -> do - mycid <- getMyCID conn - when (lvl == HandshakeLevel - || (lvl == InitialLevel && mycid == headerMyCID hdr)) $ do - setAddressValidated conn - when (lvl == HandshakeLevel) $ do - let ldcc = connLDCC conn - discarded <- getAndSetPacketNumberSpaceDiscarded ldcc InitialLevel - unless discarded $ fire conn (Microseconds 100000) $ do - dropSecrets conn InitialLevel - clearCryptoStream conn InitialLevel - onPacketNumberSpaceDiscarded ldcc InitialLevel - processReceivedPacket conn rpkt + Nothing -> do + putOffCrypto conn lvl rpkt + when (isClient conn) $ do + lvl' <- getEncryptionLevel conn + speedup (connLDCC conn) lvl' "not decryptable" + Just () + | isClient conn -> do + when (lvl == InitialLevel) $ do + peercid <- getPeerCID conn + let newPeerCID = headerPeerCID hdr + when (peercid /= headerPeerCID hdr) $ + resetPeerCID conn newPeerCID + setPeerAuthCIDs conn $ \auth -> + auth{initSrcCID = Just newPeerCID} + case hdr of + Initial peerVer _ _ _ -> do + myVer <- getVersion conn + let myOrigiVer = getOriginalVersion conn + firstTime = myVer == myOrigiVer + when (firstTime && myVer /= peerVer) $ do + setVersion conn peerVer + dcid <- getClientDstCID conn + initializeCoder conn InitialLevel $ initialSecrets peerVer dcid + _ -> return () + processReceivedPacket conn rpkt + | otherwise -> do + mycid <- getMyCID conn + when + ( lvl == HandshakeLevel + || (lvl == InitialLevel && mycid == headerMyCID hdr) + ) + $ do + setAddressValidated conn + when (lvl == HandshakeLevel) $ do + let ldcc = connLDCC conn + discarded <- getAndSetPacketNumberSpaceDiscarded ldcc InitialLevel + unless discarded $ fire conn (Microseconds 100000) $ do + dropSecrets conn InitialLevel + clearCryptoStream conn InitialLevel + onPacketNumberSpaceDiscarded ldcc InitialLevel + processReceivedPacket conn rpkt +rateLimit :: Int +rateLimit = 10 + +checkRate :: [Frame] -> Int +checkRate fs0 = go fs0 0 + where + go [] n = n + go (f : fs) n + | rateControled f = go fs (n + 1) + | otherwise = go fs n + processReceivedPacket :: Connection -> ReceivedPacket -> IO () processReceivedPacket conn rpkt = do let CryptPacket hdr crypt = rpCryptPacket rpkt @@ -126,69 +146,82 @@ tim = rpTimeRecevied rpkt mplain <- decryptCrypt conn crypt lvl case mplain of - Just plain@Plain{..} -> do - addRxBytes conn $ rpReceivedBytes rpkt - when (isIllegalReservedBits plainMarks || isNoFrames plainMarks) $ - closeConnection ProtocolViolation "Non 0 RR bits or no frames" - when (isUnknownFrame plainMarks) $ - closeConnection FrameEncodingError "Unknown frame" - -- For Ping, record PPN first, then send an ACK. - onPacketReceived (connLDCC conn) lvl plainPacketNumber - when (lvl == RTT1Level) $ setPeerPacketNumber conn plainPacketNumber - qlogReceived conn (PlainPacket hdr plain) tim - let ackEli = any ackEliciting plainFrames - case cryptMigraionInfo crypt of - Nothing -> return () - Just miginfo -> - void . forkIO $ runNewServerReader conn miginfo - (ckp,cpn) <- getCurrentKeyPhase conn - let Flags flags = plainFlags - nkp = flags `testBit` 2 - when (nkp /= ckp && plainPacketNumber > cpn) $ do - setCurrentKeyPhase conn nkp plainPacketNumber - updateCoder1RTT conn ckp -- ckp is now next - mapM_ (processFrame conn lvl) plainFrames - when ackEli $ do - case lvl of - RTT0Level -> return () - RTT1Level -> delayedAck conn - _ -> do - sup <- getSpeedingUp (connLDCC conn) - when sup $ do - 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 + Just plain@Plain{..} -> do + addRxBytes conn $ rpReceivedBytes rpkt + when (isIllegalReservedBits plainMarks || isNoFrames plainMarks) $ + closeConnection ProtocolViolation "Non 0 RR bits or no frames" + when (isUnknownFrame plainMarks) $ + closeConnection FrameEncodingError "Unknown frame" + let controlled = checkRate plainFrames + when (controlled /= 0) $ do + rate <- addRate (controlRate conn) controlled + when (rate > rateLimit) $ do + closeConnection QUIC.InternalError "Rate control" + -- For Ping, record PPN first, then send an ACK. + onPacketReceived (connLDCC conn) lvl plainPacketNumber + when (lvl == RTT1Level) $ setPeerPacketNumber conn plainPacketNumber + qlogReceived conn (PlainPacket hdr plain) tim + let ackEli = any ackEliciting plainFrames + case cryptMigraionInfo crypt of + Nothing -> return () + Just miginfo -> + void . forkIO $ runNewServerReader conn miginfo + (ckp, cpn) <- getCurrentKeyPhase conn + let Flags flags = plainFlags + nkp = flags `testBit` 2 + when (nkp /= ckp && plainPacketNumber > cpn) $ do + setCurrentKeyPhase conn nkp plainPacketNumber + updateCoder1RTT conn ckp -- ckp is now next + mapM_ (processFrame conn lvl) plainFrames + when ackEli $ do + case lvl of + RTT0Level -> return () + RTT1Level -> delayedAck conn + _ -> do + sup <- getSpeedingUp (connLDCC conn) + when sup $ do + 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 + isSendOnly :: Connection -> StreamId -> Bool isSendOnly conn sid - | isClient conn = isClientInitiatedUnidirectional sid - | otherwise = isServerInitiatedUnidirectional sid + | isClient conn = isClientInitiatedUnidirectional sid + | otherwise = isServerInitiatedUnidirectional sid isReceiveOnly :: Connection -> StreamId -> Bool isReceiveOnly conn sid - | isClient conn = isServerInitiatedUnidirectional sid - | otherwise = isClientInitiatedUnidirectional sid + | isClient conn = isServerInitiatedUnidirectional sid + | otherwise = isClientInitiatedUnidirectional sid isInitiated :: Connection -> StreamId -> Bool isInitiated conn sid - | isClient conn = isClientInitiated sid - | otherwise = isServerInitiated sid + | isClient conn = isClientInitiated sid + | otherwise = isServerInitiated sid guardStream :: Connection -> StreamId -> Maybe Stream -> IO () guardStream conn sid Nothing - | isInitiated conn sid = do + | isInitiated conn sid = do curSid <- getMyStreamId conn when (sid > curSid) $ - closeConnection StreamStateError "a locally-initiated stream that has not yet been created" + closeConnection + StreamStateError + "a locally-initiated stream that has not yet been created" guardStream _ _ _ = return () processFrame :: Connection -> EncryptionLevel -> Frame -> IO () @@ -206,12 +239,12 @@ closeConnection StreamStateError "Received in a send-only stream" mstrm <- findStream conn sid case mstrm of - Nothing -> return () - Just strm -> do - onResetStreamReceived (connHooks conn) strm aerr - setTxStreamClosed strm - setRxStreamClosed strm - delStream conn strm + Nothing -> return () + Just strm -> do + onResetStreamReceived (connHooks conn) strm aerr + setTxStreamClosed strm + setRxStreamClosed strm + delStream conn strm processFrame conn lvl (StopSending sid err) = do when (lvl == InitialLevel || lvl == HandshakeLevel) $ closeConnection ProtocolViolation "STOP_SENDING" @@ -219,10 +252,10 @@ closeConnection StreamStateError "Receive-only stream" mstrm <- findStream conn sid case mstrm of - Nothing -> do - when (isInitiated conn sid) $ - closeConnection StreamStateError "No such stream for STOP_SENDING" - Just _strm -> sendFrames conn lvl [ResetStream sid err 0] + Nothing -> do + when (isInitiated conn sid) $ + closeConnection StreamStateError "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) $ @@ -230,24 +263,24 @@ let len = BS.length cdat rx = RxStreamData cdat off len False case lvl of - InitialLevel -> do - dup <- putRxCrypto conn lvl rx - when dup $ speedup (connLDCC conn) lvl "duplicated" - RTT0Level -> do - connDebugLog conn $ "processFrame: invalid packet type " <> bhow lvl - HandshakeLevel -> do - dup <- putRxCrypto conn lvl rx - when dup $ speedup (connLDCC conn) lvl "duplicated" - RTT1Level - | isClient conn -> - void $ putRxCrypto conn lvl rx - | otherwise -> - closeConnection (cryptoError UnexpectedMessage) "CRYPTO in 1-RTT" + InitialLevel -> do + dup <- putRxCrypto conn lvl rx + when dup $ speedup (connLDCC conn) lvl "duplicated" + RTT0Level -> do + connDebugLog conn $ "processFrame: invalid packet type " <> bhow lvl + HandshakeLevel -> do + dup <- putRxCrypto conn lvl rx + when dup $ speedup (connLDCC conn) lvl "duplicated" + RTT1Level + | isClient conn -> + void $ putRxCrypto conn lvl rx + | otherwise -> + closeConnection (cryptoError UnexpectedMessage) "CRYPTO in 1-RTT" processFrame conn lvl (NewToken token) = do when (isServer conn || lvl /= RTT1Level) $ closeConnection ProtocolViolation "NEW_TOKEN for server or in 1-RTT" when (isClient conn) $ setNewToken conn token -processFrame conn RTT0Level (StreamF sid off (dat:_) fin) = do +processFrame conn RTT0Level (StreamF sid off (dat : _) fin) = do when (off == 0) $ updatePeerStreamId conn sid -- FLOW CONTROL: MAX_STREAMS: recv: rejecting if over my limit ok <- checkRxMaxStreams conn sid @@ -261,13 +294,14 @@ rx = RxStreamData dat off len fin fc <- putRxStreamData strm rx case fc of - -- FLOW CONTROL: MAX_STREAM_DATA: recv: rejecting if over my limit - OverLimit -> closeConnection FlowControlError "Flow control error for stream in 0-RTT" - Duplicated -> return () - Reassembled -> do - ok' <- checkRxMaxData conn len - -- FLOW CONTROL: MAX_DATA: send: respecting peer's limit - unless ok' $ closeConnection FlowControlError "Flow control error for connection in 0-RTT" + -- FLOW CONTROL: MAX_STREAM_DATA: recv: rejecting if over my limit + OverLimit -> closeConnection FlowControlError "Flow control error for stream in 0-RTT" + Duplicated -> return () + Reassembled -> do + ok' <- checkRxMaxData conn len + -- FLOW CONTROL: MAX_DATA: send: respecting peer's limit + unless ok' $ + closeConnection FlowControlError "Flow control error for connection in 0-RTT" processFrame conn RTT1Level (StreamF sid _ [""] False) = do -- FLOW CONTROL: MAX_STREAMS: recv: rejecting if over my limit ok <- checkRxMaxStreams conn sid @@ -276,7 +310,7 @@ closeConnection StreamStateError "send-only stream" mstrm <- findStream conn sid guardStream conn sid mstrm -processFrame conn RTT1Level (StreamF sid off (dat:_) fin) = do +processFrame conn RTT1Level (StreamF sid off (dat : _) fin) = do when (off == 0) $ updatePeerStreamId conn sid -- FLOW CONTROL: MAX_STREAMS: recv: rejecting if over my limit ok <- checkRxMaxStreams conn sid @@ -290,13 +324,14 @@ rx = RxStreamData dat off len fin fc <- putRxStreamData strm rx case fc of - -- FLOW CONTROL: MAX_STREAM_DATA: recv: rejecting if over my limit - OverLimit -> closeConnection FlowControlError "Flow control error for stream in 1-RTT" - Duplicated -> return () - Reassembled -> do - ok' <- checkRxMaxData conn len - -- FLOW CONTROL: MAX_DATA: send: respecting peer's limit - unless ok' $ closeConnection FlowControlError "Flow control error for connection in 1-RTT" + -- FLOW CONTROL: MAX_STREAM_DATA: recv: rejecting if over my limit + OverLimit -> closeConnection FlowControlError "Flow control error for stream in 1-RTT" + Duplicated -> return () + Reassembled -> do + ok' <- checkRxMaxData conn len + -- FLOW CONTROL: MAX_DATA: send: respecting peer's limit + unless ok' $ + closeConnection FlowControlError "Flow control error for connection in 1-RTT" processFrame conn lvl (MaxData n) = do when (lvl == InitialLevel || lvl == HandshakeLevel) $ closeConnection ProtocolViolation "MAX_DATA in Initial or Handshake" @@ -308,25 +343,24 @@ closeConnection StreamStateError "Receive-only stream" mstrm <- findStream conn sid case mstrm of - Nothing -> do - when (isInitiated conn sid) $ - closeConnection StreamStateError "No such stream for MAX_STREAM_DATA" - Just strm -> setTxMaxStreamData strm n + Nothing -> do + when (isInitiated conn sid) $ + closeConnection StreamStateError "No such stream for MAX_STREAM_DATA" + Just strm -> setTxMaxStreamData strm n processFrame conn lvl (MaxStreams dir n) = do when (lvl == InitialLevel || lvl == HandshakeLevel) $ closeConnection ProtocolViolation "MAX_STREAMS in Initial or Handshake" - when (n > 2^(60 :: Int)) $ + when (n > 2 ^ (60 :: Int)) $ closeConnection FrameEncodingError "Too large MAX_STREAMS" - if dir == Bidirectional then - setTxMaxStreams conn n - else - setTxUniMaxStreams conn n + if dir == Bidirectional + then setTxMaxStreams conn n + else setTxUniMaxStreams conn n processFrame _conn _lvl DataBlocked{} = return () processFrame _conn _lvl (StreamDataBlocked _sid _) = return () processFrame _conn lvl (StreamsBlocked _dir n) = do when (lvl == InitialLevel || lvl == HandshakeLevel) $ closeConnection ProtocolViolation "STREAMS_BLOCKED in Initial or Handshake" - when (n > 2^(60 :: Int)) $ + when (n > 2 ^ (60 :: Int)) $ closeConnection FrameEncodingError "Too large STREAMS_BLOCKED" processFrame conn lvl (NewConnectionID cidInfo rpt) = do when (lvl == InitialLevel || lvl == HandshakeLevel) $ @@ -341,11 +375,11 @@ processFrame conn RTT1Level (RetireConnectionID sn) = do mcidInfo <- retireMyCID conn sn case mcidInfo of - Nothing -> return () - Just (CIDInfo _ cid _) -> do - when (isServer conn) $ do - unregister <- getUnregister conn - unregister cid + Nothing -> return () + Just (CIDInfo _ cid _) -> do + when (isServer conn) $ do + unregister <- getUnregister conn + unregister cid processFrame conn RTT1Level (PathChallenge dat) = sendFrames conn RTT1Level [PathResponse dat] processFrame conn RTT1Level (PathResponse dat) = @@ -384,21 +418,21 @@ 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 + 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 putRxCrypto conn lvl rx = do mstrm <- getCryptoStream conn lvl case mstrm of - Nothing -> return False - Just strm -> do - let put = putCrypto conn . InpHandshake lvl - putFin = return () - tryReassemble strm rx put putFin + Nothing -> return False + Just strm -> do + let put = putCrypto conn . InpHandshake lvl + putFin = return () + tryReassemble strm rx put putFin killHandshaker :: Connection -> EncryptionLevel -> IO () killHandshaker conn lvl = putCrypto conn $ InpHandshake lvl "" diff --git a/Network/QUIC/Recovery.hs b/Network/QUIC/Recovery.hs --- a/Network/QUIC/Recovery.hs +++ b/Network/QUIC/Recovery.hs @@ -1,51 +1,51 @@ module Network.QUIC.Recovery ( - -- Interface - checkWindowOpenSTM - , takePingSTM - , speedup - , resender - -- LossRecovery.hs - , onPacketSent - , onPacketReceived - , onAckReceived - , onPacketNumberSpaceDiscarded - -- Metrics - , setInitialCongestionWindow - -- Misc - , getPreviousRTT1PPNs - , setPreviousRTT1PPNs - , getSpeedingUp - , getPacketNumberSpaceDiscarded - , getAndSetPacketNumberSpaceDiscarded - , setMaxAckDaley - -- PeerPacketNumbers - , getPeerPacketNumbers - , fromPeerPacketNumbers - , nullPeerPacketNumbers - -- Persistent - , findDuration - , getPTO - -- Release - , releaseByRetry - , releaseOldest - -- Timer - , beforeAntiAmp - , ldccTimer - -- Types - , SentPacket - , spPlainPacket - , spTimeSent - , spSentBytes - , spEncryptionLevel - , spPacketNumber - , spPeerPacketNumbers - , spAckEliciting - , mkSentPacket - , fixSentPacket - , LDCC - , newLDCC - , qlogSent - ) where + -- Interface + checkWindowOpenSTM, + takePingSTM, + speedup, + resender, + -- LossRecovery.hs + onPacketSent, + onPacketReceived, + onAckReceived, + onPacketNumberSpaceDiscarded, + -- Metrics + setInitialCongestionWindow, + -- Misc + getPreviousRTT1PPNs, + setPreviousRTT1PPNs, + getSpeedingUp, + getPacketNumberSpaceDiscarded, + getAndSetPacketNumberSpaceDiscarded, + setMaxAckDaley, + -- PeerPacketNumbers + getPeerPacketNumbers, + fromPeerPacketNumbers, + nullPeerPacketNumbers, + -- Persistent + findDuration, + getPTO, + -- Release + releaseByRetry, + releaseOldest, + -- Timer + beforeAntiAmp, + ldccTimer, + -- Types + SentPacket, + spPlainPacket, + spTimeSent, + spSentBytes, + spEncryptionLevel, + spPacketNumber, + spPeerPacketNumbers, + spAckEliciting, + mkSentPacket, + fixSentPacket, + LDCC, + newLDCC, + qlogSent, +) where import Network.QUIC.Recovery.Interface import Network.QUIC.Recovery.LossRecovery diff --git a/Network/QUIC/Recovery/Constants.hs b/Network/QUIC/Recovery/Constants.hs --- a/Network/QUIC/Recovery/Constants.hs +++ b/Network/QUIC/Recovery/Constants.hs @@ -15,7 +15,6 @@ -- | Maximum reordering in time before time threshold loss detection -- considers a packet lost. Specified as an RTT multiplier. - kTimeThreshold :: Microseconds -> Microseconds kTimeThreshold x = x + (x !>>. 3) -- 9/8 @@ -26,7 +25,7 @@ -- | Default limit on the initial bytes in flight. kInitialWindow :: Int -> Int ---kInitialWindow pktSiz = min 14720 (10 * pktSiz) +-- kInitialWindow pktSiz = min 14720 (10 * pktSiz) kInitialWindow pktSiz = pktSiz !<<. 2 -- !<<. 1 is not good enough -- | Minimum congestion window in bytes. diff --git a/Network/QUIC/Recovery/Detect.hs b/Network/QUIC/Recovery/Detect.hs --- a/Network/QUIC/Recovery/Detect.hs +++ b/Network/QUIC/Recovery/Detect.hs @@ -2,12 +2,12 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Recovery.Detect ( - releaseByPredicate - , detectAndRemoveLostPackets - , removePacketNumbers - ) where + releaseByPredicate, + detectAndRemoveLostPackets, + removePacketNumbers, +) where -import Data.Sequence (Seq, ViewL(..)) +import Data.Sequence (Seq, ViewL (..)) import qualified Data.Sequence as Seq import Network.QUIC.Imports @@ -17,11 +17,12 @@ import Network.QUIC.Recovery.Types import Network.QUIC.Types -releaseByPredicate :: LDCC -> EncryptionLevel -> (SentPacket -> Bool) -> IO (Seq SentPacket) +releaseByPredicate + :: LDCC -> EncryptionLevel -> (SentPacket -> Bool) -> IO (Seq SentPacket) releaseByPredicate ldcc@LDCC{..} lvl predicate = do packets <- atomicModifyIORef' (sentPackets ! lvl) $ \(SentPackets db) -> - let (pkts, db') = Seq.partition predicate db - in (SentPackets db', pkts) + let (pkts, db') = Seq.partition predicate db + in (SentPackets db', pkts) removePacketNumbers ldcc lvl packets return packets @@ -29,48 +30,57 @@ detectAndRemoveLostPackets ldcc@LDCC{..} lvl = do lae <- timeOfLastAckElicitingPacket <$> readIORef (lossDetection ! lvl) when (lae == timeMicrosecond0) $ - qlogDebug ldcc $ Debug "detectAndRemoveLostPackets: timeOfLastAckElicitingPacket: 0" - atomicModifyIORef'' (lossDetection ! lvl) $ \ld -> ld { - lossTime = Nothing - } + qlogDebug ldcc $ + Debug "detectAndRemoveLostPackets: timeOfLastAckElicitingPacket: 0" + atomicModifyIORef'' (lossDetection ! lvl) $ \ld -> + ld + { lossTime = Nothing + } RTT{..} <- readIORef recoveryRTT LossDetection{..} <- readIORef (lossDetection ! lvl) when (largestAckedPacket == -1) $ - qlogDebug ldcc $ Debug "detectAndRemoveLostPackets: largestAckedPacket: -1" + qlogDebug ldcc $ + Debug "detectAndRemoveLostPackets: largestAckedPacket: -1" -- Sec 6.1.2. Time Threshold -- max(kTimeThreshold * max(smoothed_rtt, latest_rtt), kGranularity) let lossDelay0 = kTimeThreshold $ max latestRTT smoothedRTT let lossDelay = max lossDelay0 kGranularity tm <- getPastTimeMicrosecond lossDelay - let predicate ent = (spPacketNumber ent <= largestAckedPacket - kPacketThreshold) - || (spPacketNumber ent <= largestAckedPacket && spTimeSent ent <= tm) + let predicate ent = + (spPacketNumber ent <= largestAckedPacket - kPacketThreshold) + || (spPacketNumber ent <= largestAckedPacket && spTimeSent ent <= tm) lostPackets <- releaseByPredicate ldcc lvl predicate mx <- findOldest ldcc lvl (\x -> spPacketNumber x <= largestAckedPacket) case mx of - -- No gap packet. PTO turn. - Nothing -> return () - -- There are gap packets which are not declared lost. - -- Set lossTime to next. - Just x -> do - let next = spTimeSent x `addMicroseconds` lossDelay - atomicModifyIORef'' (lossDetection ! lvl) $ \ld -> ld { - lossTime = Just next - } + -- No gap packet. PTO turn. + Nothing -> return () + -- There are gap packets which are not declared lost. + -- Set lossTime to next. + Just x -> do + let next = spTimeSent x `addMicroseconds` lossDelay + atomicModifyIORef'' (lossDetection ! lvl) $ \ld -> + ld + { lossTime = Just next + } unless (Seq.null lostPackets) $ qlogDebug ldcc $ Debug "loss detected" return lostPackets -findOldest :: LDCC -> EncryptionLevel -> (SentPacket -> Bool) - -> IO (Maybe SentPacket) +findOldest + :: LDCC + -> EncryptionLevel + -> (SentPacket -> Bool) + -> IO (Maybe SentPacket) findOldest LDCC{..} lvl p = oldest <$> readIORef (sentPackets ! lvl) where oldest (SentPackets db) = case Seq.viewl $ Seq.filter p db of - EmptyL -> Nothing - x :< _ -> Just x + EmptyL -> Nothing + x :< _ -> Just x -removePacketNumbers :: Foldable t => LDCC -> EncryptionLevel -> t SentPacket -> IO () +removePacketNumbers + :: Foldable t => LDCC -> EncryptionLevel -> t SentPacket -> IO () removePacketNumbers ldcc lvl packets = mapM_ reduce packets where reduce x = reducePeerPacketNumbers ldcc lvl ppns diff --git a/Network/QUIC/Recovery/Interface.hs b/Network/QUIC/Recovery/Interface.hs --- a/Network/QUIC/Recovery/Interface.hs +++ b/Network/QUIC/Recovery/Interface.hs @@ -2,11 +2,11 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Recovery.Interface ( - checkWindowOpenSTM - , takePingSTM - , speedup - , resender - ) where + checkWindowOpenSTM, + takePingSTM, + speedup, + resender, +) where import qualified Data.Sequence as Seq import System.Log.FastLogger (LogStr) @@ -38,7 +38,7 @@ setSpeedingUp ldcc qlogDebug ldcc $ Debug desc packets <- atomicModifyIORef' (sentPackets ! lvl) $ - \(SentPackets db) -> (emptySentPackets, db) + \(SentPackets db) -> (emptySentPackets, db) -- don't clear PeerPacketNumbers. unless (null packets) $ do onPacketsLost ldcc packets diff --git a/Network/QUIC/Recovery/LossRecovery.hs b/Network/QUIC/Recovery/LossRecovery.hs --- a/Network/QUIC/Recovery/LossRecovery.hs +++ b/Network/QUIC/Recovery/LossRecovery.hs @@ -2,13 +2,13 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Recovery.LossRecovery ( - onPacketSent - , onPacketReceived - , onAckReceived - , onPacketNumberSpaceDiscarded - ) where + onPacketSent, + onPacketReceived, + onAckReceived, + onPacketNumberSpaceDiscarded, +) where -import Data.Sequence (Seq, (|>), ViewR(..)) +import Data.Sequence (Seq, ViewR (..), (|>)) import qualified Data.Sequence as Seq import UnliftIO.STM @@ -31,25 +31,29 @@ onPacketSent :: LDCC -> SentPacket -> IO () onPacketSent ldcc@LDCC{..} sentPacket = do let lvl0 = spEncryptionLevel sentPacket - let lvl | lvl0 == RTT0Level = RTT1Level - | otherwise = lvl0 + let lvl + | lvl0 == RTT0Level = RTT1Level + | otherwise = lvl0 discarded <- getPacketNumberSpaceDiscarded ldcc lvl unless discarded $ do onPacketSentCC ldcc sentPacket when (spAckEliciting sentPacket) $ - atomicModifyIORef'' (lossDetection ! lvl) $ \ld -> ld { - timeOfLastAckElicitingPacket = spTimeSent sentPacket - } + atomicModifyIORef'' (lossDetection ! lvl) $ \ld -> + ld + { timeOfLastAckElicitingPacket = spTimeSent sentPacket + } atomicModifyIORef'' (sentPackets ! lvl) $ \(SentPackets db) -> SentPackets (db |> sentPacket) setLossDetectionTimer ldcc lvl onPacketSentCC :: LDCC -> SentPacket -> IO () onPacketSentCC ldcc@LDCC{..} sentPacket = metricsUpdated ldcc $ - atomically $ modifyTVar' recoveryCC $ \cc -> cc { - bytesInFlight = bytesInFlight cc + sentBytes - , numOfAckEliciting = numOfAckEliciting cc + countAckEli sentPacket - } + atomically $ + modifyTVar' recoveryCC $ \cc -> + cc + { bytesInFlight = bytesInFlight cc + sentBytes + , numOfAckEliciting = numOfAckEliciting cc + countAckEli sentPacket + } where sentBytes = spSentBytes sentPacket @@ -68,64 +72,72 @@ when changed $ do let predicate = fromAckInfoToPred ackInfo . spPacketNumber releaseLostCandidates ldcc lvl predicate >>= updateCConAck - releaseByPredicate ldcc lvl predicate >>= detectLossUpdateCC + releaseByPredicate ldcc lvl predicate >>= detectLossUpdateCC where update ld@LossDetection{..} = (ld', changed) where - ld' = ld { largestAckedPacket = max largestAckedPacket largestAcked - , previousAckInfo = ackInfo - } + ld' = + ld + { largestAckedPacket = max largestAckedPacket largestAcked + , previousAckInfo = ackInfo + } changed = previousAckInfo /= ackInfo detectLossUpdateCC newlyAckedPackets = case Seq.viewr newlyAckedPackets of - EmptyR -> return () - _ :> lastPkt -> do - -- If the largest acknowledged is newly acked and - -- at least one ack-eliciting was newly acked, update the RTT. - when (spPacketNumber lastPkt == largestAcked - && any spAckEliciting newlyAckedPackets) $ do - rtt <- getElapsedTimeMicrosecond $ spTimeSent lastPkt - let latestRtt = max rtt kGranularity - updateRTT ldcc lvl latestRtt ackDelay + EmptyR -> return () + _ :> lastPkt -> do + -- If the largest acknowledged is newly acked and + -- at least one ack-eliciting was newly acked, update the RTT. + when + ( spPacketNumber lastPkt == largestAcked + && any spAckEliciting newlyAckedPackets + ) + $ do + rtt <- getElapsedTimeMicrosecond $ spTimeSent lastPkt + let latestRtt = max rtt kGranularity + updateRTT ldcc lvl latestRtt ackDelay - {- fimxe - -- Process ECN information if present. - if (ACK frame contains ECN information): - ProcessECN(ack, lvl) - -} + {- fimxe + -- Process ECN information if present. + if (ACK frame contains ECN information): + ProcessECN(ack, lvl) + -} - lostPackets <- detectAndRemoveLostPackets ldcc lvl - unless (null lostPackets) $ do - mode <- ccMode <$> readTVarIO recoveryCC - if lvl == RTT1Level && mode /= SlowStart then - mergeLostCandidates ldcc lostPackets - else do - -- just in case - lostPackets' <- mergeLostCandidatesAndClear ldcc lostPackets - onPacketsLost ldcc lostPackets' - retransmit ldcc lostPackets' - -- setLossDetectionTimer in updateCConAck - updateCConAck newlyAckedPackets + lostPackets <- detectAndRemoveLostPackets ldcc lvl + unless (null lostPackets) $ do + mode <- ccMode <$> readTVarIO recoveryCC + if lvl == RTT1Level && mode /= SlowStart + then mergeLostCandidates ldcc lostPackets + else do + -- just in case + lostPackets' <- mergeLostCandidatesAndClear ldcc lostPackets + onPacketsLost ldcc lostPackets' + retransmit ldcc lostPackets' + -- setLossDetectionTimer in updateCConAck + updateCConAck newlyAckedPackets updateCConAck newlyAckedPackets - | newlyAckedPackets == Seq.empty = return () - | otherwise = do - onPacketsAcked ldcc newlyAckedPackets + | newlyAckedPackets == Seq.empty = return () + | otherwise = do + onPacketsAcked ldcc newlyAckedPackets - -- Sec 6.2.1. Computing PTO - -- "The PTO backoff factor is reset when an acknowledgement is - -- received, except in the following case. A server might - -- take longer to respond to packets during the handshake - -- than otherwise. To protect such a server from repeated - -- client probes, the PTO backoff is not reset at a client - -- that is not yet certain that the server has finished - -- validating the client's address." - validated <- peerCompletedAddressValidation ldcc - when validated $ metricsUpdated ldcc $ - atomicModifyIORef'' recoveryRTT $ \rtt -> rtt { ptoCount = 0 } + -- Sec 6.2.1. Computing PTO + -- "The PTO backoff factor is reset when an acknowledgement is + -- received, except in the following case. A server might + -- take longer to respond to packets during the handshake + -- than otherwise. To protect such a server from repeated + -- client probes, the PTO backoff is not reset at a client + -- that is not yet certain that the server has finished + -- validating the client's address." + validated <- peerCompletedAddressValidation ldcc + when validated $ + metricsUpdated ldcc $ + atomicModifyIORef'' recoveryRTT $ + \rtt -> rtt{ptoCount = 0} - setLossDetectionTimer ldcc lvl + setLossDetectionTimer ldcc lvl -releaseLostCandidates :: LDCC -> EncryptionLevel -> (SentPacket -> Bool) -> IO (Seq SentPacket) +releaseLostCandidates + :: LDCC -> EncryptionLevel -> (SentPacket -> Bool) -> IO (Seq SentPacket) releaseLostCandidates ldcc@LDCC{..} lvl predicate = do packets <- atomically $ do SentPackets db <- readTVar lostCandidates @@ -142,46 +154,51 @@ atomically $ modifyTVar' recoveryCC $ modify maxPktSiz newcc <- readTVarIO recoveryCC when (ccMode oldcc /= ccMode newcc) $ - qlogContestionStateUpdated ldcc $ ccMode newcc + qlogContestionStateUpdated ldcc $ + ccMode newcc where - modify maxPktSiz cc@CC{..} = cc { - bytesInFlight = bytesInFlight' - , congestionWindow = congestionWindow' - , bytesAcked = bytesAcked' - , ccMode = ccMode' - , numOfAckEliciting = numOfAckEliciting' - } + modify maxPktSiz cc@CC{..} = + cc + { bytesInFlight = bytesInFlight' + , congestionWindow = congestionWindow' + , bytesAcked = bytesAcked' + , ccMode = ccMode' + , numOfAckEliciting = numOfAckEliciting' + } where - (bytesInFlight',congestionWindow',bytesAcked',ccMode',numOfAckEliciting') = - foldl' (.+) (bytesInFlight,congestionWindow,bytesAcked,ccMode,numOfAckEliciting) ackedPackets - (bytes,cwin,acked,_,cnt) .+ sp@SentPacket{..} = (bytes',cwin',acked',mode',cnt') + (bytesInFlight', congestionWindow', bytesAcked', ccMode', numOfAckEliciting') = + foldl' + (.+) + (bytesInFlight, congestionWindow, bytesAcked, ccMode, numOfAckEliciting) + ackedPackets + (bytes, cwin, acked, _, cnt) .+ sp@SentPacket{..} = (bytes', cwin', acked', mode', cnt') where isRecovery = inCongestionRecovery spTimeSent congestionRecoveryStartTime bytes' = bytes - spSentBytes ackedA = acked + spSentBytes cnt' = cnt - countAckEli sp - (cwin',acked',mode') - -- Do not increase congestion window in recovery period. - | isRecovery = (cwin, acked, Recovery) - -- fixme: Do not increase congestion_window if application - -- limited or flow control limited. - -- - -- Slow start. - | cwin < ssthresh = (cwin + spSentBytes, acked, SlowStart) - -- Congestion avoidance. - -- In this implementation, maxPktSiz == spSentBytes. - -- spSentBytes is large enough, so we don't care - -- the roundup issue of `div`. - | ackedA >= cwin = (cwin + maxPktSiz, ackedA - cwin, Avoidance) - | otherwise = (cwin, ackedA, Avoidance) + (cwin', acked', mode') + -- Do not increase congestion window in recovery period. + | isRecovery = (cwin, acked, Recovery) + -- fixme: Do not increase congestion_window if application + -- limited or flow control limited. + -- + -- Slow start. + | cwin < ssthresh = (cwin + spSentBytes, acked, SlowStart) + -- Congestion avoidance. + -- In this implementation, maxPktSiz == spSentBytes. + -- spSentBytes is large enough, so we don't care + -- the roundup issue of `div`. + | ackedA >= cwin = (cwin + maxPktSiz, ackedA - cwin, Avoidance) + | otherwise = (cwin, ackedA, Avoidance) ---------------------------------------------------------------- onPacketNumberSpaceDiscarded :: LDCC -> EncryptionLevel -> IO () onPacketNumberSpaceDiscarded ldcc lvl = do - let (lvl',label) = case lvl of - InitialLevel -> (HandshakeLevel,"initial") - _ -> (RTT1Level, "handshake") + let (lvl', label) = case lvl of + InitialLevel -> (HandshakeLevel, "initial") + _ -> (RTT1Level, "handshake") qlogDebug ldcc $ Debug (label <> " discarded") void $ discard ldcc lvl setLossDetectionTimer ldcc lvl' diff --git a/Network/QUIC/Recovery/Metrics.hs b/Network/QUIC/Recovery/Metrics.hs --- a/Network/QUIC/Recovery/Metrics.hs +++ b/Network/QUIC/Recovery/Metrics.hs @@ -1,13 +1,13 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE NamedFieldPuns #-} module Network.QUIC.Recovery.Metrics ( - updateRTT - , updateCC - , metricsUpdated - , setInitialCongestionWindow - ) where + updateRTT, + updateCC, + metricsUpdated, + setInitialCongestionWindow, +) where import Data.Sequence (Seq) import UnliftIO.STM @@ -35,19 +35,26 @@ -- -- smoothed_rtt = rtt_sample -- rttvar = rtt_sample / 2 - update rtt@RTT{..} | latestRTT == Microseconds 0 = (rtt { - latestRTT = latestRTT0 - , minRTT = latestRTT0 - , smoothedRTT = latestRTT0 - , rttvar = latestRTT0 `unsafeShiftR` 1 - }, True) + update rtt@RTT{..} + | latestRTT == Microseconds 0 = + ( rtt + { latestRTT = latestRTT0 + , minRTT = latestRTT0 + , smoothedRTT = latestRTT0 + , rttvar = latestRTT0 `unsafeShiftR` 1 + } + , True + ) -- Others: - update rtt@RTT{..} = (rtt { - latestRTT = latestRTT0 - , minRTT = minRTT' - , smoothedRTT = smoothedRTT' - , rttvar = rttvar' - }, False) + update rtt@RTT{..} = + ( rtt + { latestRTT = latestRTT0 + , minRTT = minRTT' + , smoothedRTT = smoothedRTT' + , rttvar = rttvar' + } + , False + ) where -- minRTT ignores ack delay. minRTT' = min minRTT latestRTT0 @@ -59,15 +66,19 @@ -- if (latest_rtt >= min_rtt + ack_delay): -- adjusted_rtt = latest_rtt - ack_delay adjustedRTT - | latestRTT0 >= minRTT + ackDelay = latestRTT0 - ackDelay - | otherwise = latestRTT0 + | latestRTT0 >= minRTT + ackDelay = latestRTT0 - ackDelay + | otherwise = latestRTT0 -- rttvar_sample = abs(smoothed_rtt - adjusted_rtt) -- rttvar = 3/4 * rttvar + 1/4 * rttvar_sample - rttvar' = rttvar - (rttvar !>>. 2) + rttvar' = + rttvar + - (rttvar !>>. 2) + (abs (smoothedRTT - adjustedRTT) !>>. 2) -- smoothed_rtt = 7/8 * smoothed_rtt + 1/8 * adjusted_rtt - smoothedRTT' = smoothedRTT - (smoothedRTT !>>. 3) - + (adjustedRTT !>>. 3) + smoothedRTT' = + smoothedRTT + - (smoothedRTT !>>. 3) + + (adjustedRTT !>>. 3) updateCC :: LDCC -> Seq SentPacket -> Bool -> IO () updateCC ldcc@LDCC{..} lostPackets isRecovery = do @@ -78,27 +89,29 @@ metricsUpdated ldcc $ atomically $ modifyTVar' recoveryCC $ \cc@CC{..} -> let halfWindow = max minWindow $ kLossReductionFactor congestionWindow cwin - | persistent = minWindow - | otherwise = halfWindow - sst = halfWindow + | persistent = minWindow + | otherwise = halfWindow + sst = halfWindow mode - | cwin < sst = SlowStart -- persistent - | otherwise = Recovery - in cc { - congestionRecoveryStartTime = Just now - , congestionWindow = cwin - , ssthresh = sst - , ccMode = mode - , bytesAcked = 0 - } + | cwin < sst = SlowStart -- persistent + | otherwise = Recovery + in cc + { congestionRecoveryStartTime = Just now + , congestionWindow = cwin + , ssthresh = sst + , ccMode = mode + , bytesAcked = 0 + } CC{ccMode} <- readTVarIO recoveryCC qlogContestionStateUpdated ldcc ccMode setInitialCongestionWindow :: LDCC -> Int -> IO () setInitialCongestionWindow ldcc@LDCC{..} pktSiz = metricsUpdated ldcc $ - atomically $ do modifyTVar' recoveryCC $ \cc -> cc { - congestionWindow = kInitialWindow pktSiz - } + atomically $ do + modifyTVar' recoveryCC $ \cc -> + cc + { congestionWindow = kInitialWindow pktSiz + } ---------------------------------------------------------------- @@ -109,21 +122,22 @@ body rtt1 <- readIORef recoveryRTT cc1 <- readTVarIO recoveryCC - let ~diff = catMaybes [ - time "min_rtt" (minRTT rtt0) (minRTT rtt1) - , time "smoothed_rtt" (smoothedRTT rtt0) (smoothedRTT rtt1) - , time "latest_rtt" (latestRTT rtt0) (latestRTT rtt1) - , time "rtt_variance" (rttvar rtt0) (rttvar rtt1) - , numb "pto_count" (ptoCount rtt0) (ptoCount rtt1) - , numb "bytes_in_flight" (bytesInFlight cc0) (bytesInFlight cc1) - , numb "congestion_window" (congestionWindow cc0) (congestionWindow cc1) - , numb "ssthresh" (ssthresh cc0) (ssthresh cc1) - ] + let ~diff = + catMaybes + [ time "min_rtt" (minRTT rtt0) (minRTT rtt1) + , time "smoothed_rtt" (smoothedRTT rtt0) (smoothedRTT rtt1) + , time "latest_rtt" (latestRTT rtt0) (latestRTT rtt1) + , time "rtt_variance" (rttvar rtt0) (rttvar rtt1) + , numb "pto_count" (ptoCount rtt0) (ptoCount rtt1) + , numb "bytes_in_flight" (bytesInFlight cc0) (bytesInFlight cc1) + , numb "congestion_window" (congestionWindow cc0) (congestionWindow cc1) + , numb "ssthresh" (ssthresh cc0) (ssthresh cc1) + ] unless (null diff) $ qlogMetricsUpdated ldcc $ MetricsDiff diff where time tag (Microseconds v0) (Microseconds v1) - | v0 == v1 = Nothing - | otherwise = Just (tag,v1) + | v0 == v1 = Nothing + | otherwise = Just (tag, v1) numb tag v0 v1 - | v0 == v1 = Nothing - | otherwise = Just (tag,v1) + | v0 == v1 = Nothing + | otherwise = Just (tag, v1) diff --git a/Network/QUIC/Recovery/Misc.hs b/Network/QUIC/Recovery/Misc.hs --- a/Network/QUIC/Recovery/Misc.hs +++ b/Network/QUIC/Recovery/Misc.hs @@ -2,14 +2,14 @@ {-# LANGUAGE TupleSections #-} module Network.QUIC.Recovery.Misc ( - getPktNumPersistent - , setPktNumPersistent - , setSpeedingUp - , getSpeedingUp - , getPacketNumberSpaceDiscarded - , getAndSetPacketNumberSpaceDiscarded - , setMaxAckDaley - ) where + getPktNumPersistent, + setPktNumPersistent, + setSpeedingUp, + getSpeedingUp, + getPacketNumberSpaceDiscarded, + getAndSetPacketNumberSpaceDiscarded, + setMaxAckDaley, +) where import Data.IORef @@ -50,4 +50,4 @@ setMaxAckDaley :: LDCC -> Microseconds -> IO () setMaxAckDaley LDCC{..} delay0 = - atomicModifyIORef'' recoveryRTT $ \rtt -> rtt { maxAckDelay1RTT = delay0 } + atomicModifyIORef'' recoveryRTT $ \rtt -> rtt{maxAckDelay1RTT = delay0} diff --git a/Network/QUIC/Recovery/PeerPacketNumbers.hs b/Network/QUIC/Recovery/PeerPacketNumbers.hs --- a/Network/QUIC/Recovery/PeerPacketNumbers.hs +++ b/Network/QUIC/Recovery/PeerPacketNumbers.hs @@ -1,16 +1,16 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Recovery.PeerPacketNumbers ( - getPeerPacketNumbers - , addPeerPacketNumbers - , delPeerPacketNumbers - , clearPeerPacketNumbers - , reducePeerPacketNumbers - , setPreviousRTT1PPNs - , getPreviousRTT1PPNs - , nullPeerPacketNumbers - , fromPeerPacketNumbers - ) where + getPeerPacketNumbers, + addPeerPacketNumbers, + delPeerPacketNumbers, + clearPeerPacketNumbers, + reducePeerPacketNumbers, + setPreviousRTT1PPNs, + getPreviousRTT1PPNs, + nullPeerPacketNumbers, + fromPeerPacketNumbers, +) where import qualified Data.IntSet as IntSet diff --git a/Network/QUIC/Recovery/Persistent.hs b/Network/QUIC/Recovery/Persistent.hs --- a/Network/QUIC/Recovery/Persistent.hs +++ b/Network/QUIC/Recovery/Persistent.hs @@ -2,15 +2,15 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Recovery.Persistent ( - getMaxAckDelay - , calcPTO - , backOff - , inPersistentCongestion - , findDuration -- for testing - , getPTO - ) where + getMaxAckDelay, + calcPTO, + backOff, + inPersistentCongestion, + findDuration, -- for testing + getPTO, +) where -import Data.Sequence (Seq, ViewL(..)) +import Data.Sequence (Seq, ViewL (..)) import qualified Data.Sequence as Seq import Data.UnixTime @@ -23,8 +23,8 @@ getMaxAckDelay :: Maybe EncryptionLevel -> Microseconds -> Microseconds getMaxAckDelay Nothing n = n getMaxAckDelay (Just lvl) n - | lvl `elem` [InitialLevel,HandshakeLevel] = 0 - | otherwise = n + | lvl `elem` [InitialLevel, HandshakeLevel] = 0 + | otherwise = n -- Sec 6.2.1. Computing PTO -- PTO = smoothed_rtt + max(4*rttvar, kGranularity) + max_ack_delay @@ -42,48 +42,46 @@ pn <- getPktNumPersistent ldcc let mduration = findDuration lostPackets pn case mduration of - Nothing -> return False - Just duration -> do - rtt <- readIORef recoveryRTT - let pto = calcPTO rtt Nothing - Microseconds congestionPeriod = kPersistentCongestionThreshold pto - threshold = microSecondsToUnixDiffTime congestionPeriod - return (duration > threshold) + Nothing -> return False + Just duration -> do + rtt <- readIORef recoveryRTT + let pto = calcPTO rtt Nothing + Microseconds congestionPeriod = kPersistentCongestionThreshold pto + threshold = microSecondsToUnixDiffTime congestionPeriod + return (duration > threshold) findDuration :: Seq SentPacket -> PacketNumber -> Maybe UnixDiffTime findDuration pkts0 pn = leftEdge pkts0 Nothing where leftEdge pkts mdiff = case Seq.viewl pkts' of - EmptyL -> mdiff + EmptyL -> mdiff l :< pkts'' -> case rightEdge (spPacketNumber l) pkts'' Nothing of - (Nothing, pkts''') -> leftEdge pkts''' mdiff - (Just r, pkts''') -> - let diff' = spTimeSent r `diffUnixTime` spTimeSent l - in case mdiff of - Nothing -> leftEdge pkts''' $ Just diff' - Just diff - | diff' > diff -> leftEdge pkts''' $ Just diff' - | otherwise -> leftEdge pkts''' $ Just diff + (Nothing, pkts''') -> leftEdge pkts''' mdiff + (Just r, pkts''') -> + let diff' = spTimeSent r `diffUnixTime` spTimeSent l + in case mdiff of + Nothing -> leftEdge pkts''' $ Just diff' + Just diff + | diff' > diff -> leftEdge pkts''' $ Just diff' + | otherwise -> leftEdge pkts''' $ Just diff where (_, pkts') = Seq.breakl (\x -> spAckEliciting x && spPacketNumber x >= pn) pkts rightEdge n pkts Nothing = case Seq.viewl pkts of EmptyL -> (Nothing, Seq.empty) r :< pkts' - | spPacketNumber r == n + 1 -> - if spAckEliciting r then - rightEdge (n + 1) pkts' $ Just r - else - rightEdge (n + 1) pkts' Nothing - | otherwise -> (Nothing, pkts) + | spPacketNumber r == n + 1 -> + if spAckEliciting r + then rightEdge (n + 1) pkts' $ Just r + else rightEdge (n + 1) pkts' Nothing + | otherwise -> (Nothing, pkts) rightEdge n pkts mr0 = case Seq.viewl pkts of EmptyL -> (mr0, Seq.empty) r :< pkts' - | spPacketNumber r == n + 1 -> - if spAckEliciting r then - rightEdge (n + 1) pkts' $ Just r - else - rightEdge (n + 1) pkts' mr0 - | otherwise -> (mr0, pkts) + | spPacketNumber r == n + 1 -> + if spAckEliciting r + then rightEdge (n + 1) pkts' $ Just r + else rightEdge (n + 1) pkts' mr0 + | otherwise -> (mr0, pkts) getPTO :: LDCC -> IO Microseconds getPTO LDCC{..} = do diff --git a/Network/QUIC/Recovery/Release.hs b/Network/QUIC/Recovery/Release.hs --- a/Network/QUIC/Recovery/Release.hs +++ b/Network/QUIC/Recovery/Release.hs @@ -2,13 +2,13 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Recovery.Release ( - releaseByRetry - , releaseOldest - , discard - , onPacketsLost - ) where + releaseByRetry, + releaseOldest, + discard, + onPacketsLost, +) where -import Data.Sequence (Seq, (><), ViewL(..), ViewR(..)) +import Data.Sequence (Seq, ViewL (..), ViewR (..), (><)) import qualified Data.Sequence as Seq import UnliftIO.STM @@ -27,7 +27,8 @@ decreaseCC ldcc packets writeIORef (lossDetection ! lvl) initialLossDetection metricsUpdated ldcc $ - atomicModifyIORef'' recoveryRTT $ \rtt -> rtt { ptoCount = 0 } + atomicModifyIORef'' recoveryRTT $ + \rtt -> rtt{ptoCount = 0} return packets releaseByClear :: LDCC -> EncryptionLevel -> IO (Seq SentPacket) @@ -48,16 +49,17 @@ releaseOldest ldcc@LDCC{..} lvl = do mr <- atomicModifyIORef' (sentPackets ! lvl) oldest case mr of - Nothing -> return () - Just spkt -> do - delPeerPacketNumbers ldcc lvl $ spPacketNumber spkt - decreaseCC ldcc [spkt] + Nothing -> return () + Just spkt -> do + delPeerPacketNumbers ldcc lvl $ spPacketNumber spkt + decreaseCC ldcc [spkt] return mr where oldest (SentPackets db) = case Seq.viewl db2 of - x :< db2' -> let db' = db1 >< db2' - in (SentPackets db', Just x) - _ -> (SentPackets db, Nothing) + x :< db2' -> + let db' = db1 >< db2' + in (SentPackets db', Just x) + _ -> (SentPackets db, Nothing) where (db1, db2) = Seq.breakl spAckEliciting db @@ -65,12 +67,14 @@ onPacketsLost :: LDCC -> Seq SentPacket -> IO () onPacketsLost ldcc@LDCC{..} lostPackets = case Seq.viewr lostPackets of - EmptyR -> return () - _ :> lastPkt -> do - decreaseCC ldcc lostPackets - isRecovery <- inCongestionRecovery (spTimeSent lastPkt) . congestionRecoveryStartTime <$> readTVarIO recoveryCC - onCongestionEvent ldcc lostPackets isRecovery - mapM_ (qlogPacketLost ldcc . LostPacket) lostPackets + EmptyR -> return () + _ :> lastPkt -> do + decreaseCC ldcc lostPackets + isRecovery <- + inCongestionRecovery (spTimeSent lastPkt) . congestionRecoveryStartTime + <$> readTVarIO recoveryCC + onCongestionEvent ldcc lostPackets isRecovery + mapM_ (qlogPacketLost ldcc . LostPacket) lostPackets where onCongestionEvent = updateCC @@ -81,9 +85,9 @@ let sentBytes = sum' (spSentBytes <$> packets) num = sum' (countAckEli <$> packets) metricsUpdated ldcc $ - atomically $ modifyTVar' recoveryCC $ \cc -> - cc { - bytesInFlight = bytesInFlight cc - sentBytes - - , numOfAckEliciting = numOfAckEliciting cc - num - } + atomically $ + modifyTVar' recoveryCC $ \cc -> + cc + { bytesInFlight = bytesInFlight cc - sentBytes + , numOfAckEliciting = numOfAckEliciting cc - num + } diff --git a/Network/QUIC/Recovery/Timer.hs b/Network/QUIC/Recovery/Timer.hs --- a/Network/QUIC/Recovery/Timer.hs +++ b/Network/QUIC/Recovery/Timer.hs @@ -3,12 +3,12 @@ {-# LANGUAGE TupleSections #-} module Network.QUIC.Recovery.Timer ( - getLossTimeAndSpace - , getPtoTimeAndSpace - , setLossDetectionTimer - , beforeAntiAmp - , ldccTimer - ) where + getLossTimeAndSpace, + getPtoTimeAndSpace, + setLossDetectionTimer, + beforeAntiAmp, + ldccTimer, +) where import qualified Data.Sequence as Seq import Network.QUIC.Event @@ -17,6 +17,7 @@ import Network.QUIC.Connector import Network.QUIC.Imports import Network.QUIC.Qlog +import Network.QUIC.Recovery.Constants import Network.QUIC.Recovery.Detect import Network.QUIC.Recovery.Metrics import Network.QUIC.Recovery.Misc @@ -24,7 +25,6 @@ import Network.QUIC.Recovery.Release import Network.QUIC.Recovery.Types import Network.QUIC.Recovery.Utils -import Network.QUIC.Recovery.Constants import Network.QUIC.Types ---------------------------------------------------------------- @@ -34,20 +34,20 @@ SentPackets db <- readIORef (sentPackets ! lvl) return $ Seq.null db -getLossTimeAndSpace :: LDCC -> IO (Maybe (TimeMicrosecond,EncryptionLevel)) +getLossTimeAndSpace :: LDCC -> IO (Maybe (TimeMicrosecond, EncryptionLevel)) getLossTimeAndSpace LDCC{..} = loop [InitialLevel, HandshakeLevel, RTT1Level] Nothing where - loop [] r = return r - loop (l:ls) r = do + loop [] r = return r + loop (l : ls) r = do mt <- lossTime <$> readIORef (lossDetection ! l) case mt of - Nothing -> loop ls r - Just t -> case r of - Nothing -> loop ls $ Just (t,l) - Just (t0,_) - | t < t0 -> loop ls $ Just (t,l) - | otherwise -> loop ls r + Nothing -> loop ls r + Just t -> case r of + Nothing -> loop ls $ Just (t, l) + Just (t0, _) + | t < t0 -> loop ls $ Just (t, l) + | otherwise -> loop ls r ---------------------------------------------------------------- @@ -55,39 +55,42 @@ getPtoTimeAndSpace ldcc@LDCC{..} = do -- Arm PTO from now when there are no inflight packets. CC{..} <- readTVarIO recoveryCC - if bytesInFlight <= 0 then do - validated <- peerCompletedAddressValidation ldcc - if validated then do - qlogDebug ldcc $ Debug "getPtoTimeAndSpace: validated" - return Nothing - else do - rtt <- readIORef recoveryRTT - lvl <- getEncryptionLevel ldcc - let pto = backOff (calcPTO rtt $ Just lvl) (ptoCount rtt) - ptoTime <- getFutureTimeMicrosecond pto - return $ Just (ptoTime, lvl) - else do - completed <- isConnectionEstablished ldcc - let lvls | completed = [InitialLevel, HandshakeLevel, RTT1Level] - | otherwise = [InitialLevel, HandshakeLevel] - loop lvls + if bytesInFlight <= 0 + then do + validated <- peerCompletedAddressValidation ldcc + if validated + then do + qlogDebug ldcc $ Debug "getPtoTimeAndSpace: validated" + return Nothing + else do + rtt <- readIORef recoveryRTT + lvl <- getEncryptionLevel ldcc + let pto = backOff (calcPTO rtt $ Just lvl) (ptoCount rtt) + ptoTime <- getFutureTimeMicrosecond pto + return $ Just (ptoTime, lvl) + else do + completed <- isConnectionEstablished ldcc + let lvls + | completed = [InitialLevel, HandshakeLevel, RTT1Level] + | otherwise = [InitialLevel, HandshakeLevel] + loop lvls where loop :: [EncryptionLevel] -> IO (Maybe (TimeMicrosecond, EncryptionLevel)) loop [] = return Nothing - loop (l:ls) = do + loop (l : ls) = do notInFlight <- noInFlightPacket ldcc l - if notInFlight then - loop ls - else do - LossDetection{..} <- readIORef (lossDetection ! l) - if timeOfLastAckElicitingPacket == timeMicrosecond0 then - loop ls - else do - rtt <- readIORef recoveryRTT - let pto0 = backOff (calcPTO rtt $ Just l) (ptoCount rtt) - pto = max pto0 kGranularity - ptoTime = timeOfLastAckElicitingPacket `addMicroseconds` pto - return $ Just (ptoTime, l) + if notInFlight + then loop ls + else do + LossDetection{..} <- readIORef (lossDetection ! l) + if timeOfLastAckElicitingPacket == timeMicrosecond0 + then loop ls + else do + rtt <- readIORef recoveryRTT + let pto0 = backOff (calcPTO rtt $ Just l) (ptoCount rtt) + pto = max pto0 kGranularity + ptoTime = timeOfLastAckElicitingPacket `addMicroseconds` pto + return $ Just (ptoTime, l) ---------------------------------------------------------------- @@ -105,10 +108,9 @@ updateLossDetectionTimer ldcc@LDCC{..} tmi = do mtmi <- readIORef timerInfo when (mtmi /= Just tmi) $ do - if timerLevel tmi == RTT1Level then - atomically $ writeTVar timerInfoQ $ Next tmi - else - updateLossDetectionTimer' ldcc tmi + if timerLevel tmi == RTT1Level + then atomically $ writeTVar timerInfoQ $ Next tmi + else updateLossDetectionTimer' ldcc tmi ldccTimer :: LDCC -> IO () ldccTimer ldcc@LDCC{..} = forever $ do @@ -122,16 +124,17 @@ updateWithNext ldcc@LDCC{..} = do x <- readTVarIO timerInfoQ case x of - Empty -> return () - Next tmi -> updateLossDetectionTimer' ldcc tmi + Empty -> return () + Next tmi -> updateLossDetectionTimer' ldcc tmi updateLossDetectionTimer' :: LDCC -> TimerInfo -> IO () updateLossDetectionTimer' ldcc@LDCC{..} tmi = do atomically $ writeTVar timerInfoQ Empty let tim = timerTime tmi Microseconds us0 <- getTimeoutInMicrosecond tim - let us | us0 <= 0 = 10000 -- fixme - | otherwise = us0 + let us + | us0 <= 0 = 10000 -- fixme + | otherwise = us0 update us qlogLossTimerUpdated ldcc (tmi, Microseconds us) -- fixme tmi where @@ -148,30 +151,30 @@ setLossDetectionTimer ldcc@LDCC{..} lvl0 = do mtl <- getLossTimeAndSpace ldcc case mtl of - Just (earliestLossTime,lvl) -> do - when (lvl0 == lvl) $ do - -- Time threshold loss detection. - let tmi = TimerInfo earliestLossTime lvl LossTime - updateLossDetectionTimer ldcc tmi - Nothing -> do - -- See beforeAntiAmp - CC{..} <- readTVarIO recoveryCC - validated <- peerCompletedAddressValidation ldcc - if numOfAckEliciting <= 0 && validated then - -- There is nothing to detect lost, so no timer is - -- set. However, we only do this if the peer has - -- been validated, to prevent the server from being - -- blocked by the anti-amplification limit. - cancelLossDetectionTimer ldcc - else do - -- Determine which PN space to arm PTO for. - mx <- getPtoTimeAndSpace ldcc - case mx of - Nothing -> return () - Just (ptoTime, lvl) -> do - when (lvl0 == lvl) $ do - let tmi = TimerInfo ptoTime lvl PTO - updateLossDetectionTimer ldcc tmi + Just (earliestLossTime, lvl) -> do + when (lvl0 == lvl) $ do + -- Time threshold loss detection. + let tmi = TimerInfo earliestLossTime lvl LossTime + updateLossDetectionTimer ldcc tmi + Nothing -> do + -- See beforeAntiAmp + CC{..} <- readTVarIO recoveryCC + validated <- peerCompletedAddressValidation ldcc + if numOfAckEliciting <= 0 && validated + then -- There is nothing to detect lost, so no timer is + -- set. However, we only do this if the peer has + -- been validated, to prevent the server from being + -- blocked by the anti-amplification limit. + cancelLossDetectionTimer ldcc + else do + -- Determine which PN space to arm PTO for. + mx <- getPtoTimeAndSpace ldcc + case mx of + Nothing -> return () + Just (ptoTime, lvl) -> do + when (lvl0 == lvl) $ do + let tmi = TimerInfo ptoTime lvl PTO + updateLossDetectionTimer ldcc tmi beforeAntiAmp :: LDCC -> IO () beforeAntiAmp ldcc = cancelLossDetectionTimer ldcc @@ -187,42 +190,42 @@ when alive $ do mtmi <- readIORef timerInfo case mtmi of - Nothing -> return () - Just tmi -> do - let lvl = timerLevel tmi - discarded <- getPacketNumberSpaceDiscarded ldcc lvl - if discarded then - updateWithNext ldcc - else - lossTimeOrPTO lvl tmi + Nothing -> return () + Just tmi -> do + let lvl = timerLevel tmi + discarded <- getPacketNumberSpaceDiscarded ldcc lvl + if discarded + then updateWithNext ldcc + else lossTimeOrPTO lvl tmi where lossTimeOrPTO lvl tmi = do qlogLossTimerExpired ldcc case timerType tmi of - LossTime -> do - -- Time threshold loss Detection - lostPackets <- detectAndRemoveLostPackets ldcc lvl - lostPackets' <- mergeLostCandidatesAndClear ldcc lostPackets - when (null lostPackets') $ qlogDebug ldcc $ Debug "onLossDetectionTimeout: null" - onPacketsLost ldcc lostPackets' - retransmit ldcc lostPackets' - setLossDetectionTimer ldcc lvl - PTO -> do - CC{..} <- readTVarIO recoveryCC - if bytesInFlight > 0 then do - -- PTO. Send new data if available, else retransmit old data. - -- If neither is available, send a single PING frame. - sendPing ldcc lvl - else do - -- Client sends an anti-deadlock packet: Initial is padded - -- to earn more anti-amplification credit, - -- a Handshake packet proves address ownership. - validated <- peerCompletedAddressValidation ldcc - when validated $ qlogDebug ldcc $ Debug "onLossDetectionTimeout: RTT1" - lvl' <- getEncryptionLevel ldcc -- fixme - sendPing ldcc lvl' + LossTime -> do + -- Time threshold loss Detection + lostPackets <- detectAndRemoveLostPackets ldcc lvl + lostPackets' <- mergeLostCandidatesAndClear ldcc lostPackets + when (null lostPackets') $ qlogDebug ldcc $ Debug "onLossDetectionTimeout: null" + onPacketsLost ldcc lostPackets' + retransmit ldcc lostPackets' + setLossDetectionTimer ldcc lvl + PTO -> do + CC{..} <- readTVarIO recoveryCC + if bytesInFlight > 0 + then do + -- PTO. Send new data if available, else retransmit old data. + -- If neither is available, send a single PING frame. + sendPing ldcc lvl + else do + -- Client sends an anti-deadlock packet: Initial is padded + -- to earn more anti-amplification credit, + -- a Handshake packet proves address ownership. + validated <- peerCompletedAddressValidation ldcc + when validated $ qlogDebug ldcc $ Debug "onLossDetectionTimeout: RTT1" + lvl' <- getEncryptionLevel ldcc -- fixme + sendPing ldcc lvl' - metricsUpdated ldcc $ - atomicModifyIORef'' recoveryRTT $ - \rtt -> rtt { ptoCount = ptoCount rtt + 1 } - setLossDetectionTimer ldcc lvl + metricsUpdated ldcc $ + atomicModifyIORef'' recoveryRTT $ + \rtt -> rtt{ptoCount = ptoCount rtt + 1} + setLossDetectionTimer ldcc lvl diff --git a/Network/QUIC/Recovery/Types.hs b/Network/QUIC/Recovery/Types.hs --- a/Network/QUIC/Recovery/Types.hs +++ b/Network/QUIC/Recovery/Types.hs @@ -3,37 +3,37 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Recovery.Types ( - SentPacket(..) - , mkSentPacket - , fixSentPacket - , LostPacket(..) - , SentPackets(..) - , emptySentPackets - , RTT(..) - , initialRTT - , CCMode(..) - , CC(..) - , initialCC - , LossDetection(..) - , initialLossDetection - , MetricsDiff(..) - , TimerType(..) - , TimerInfo(..) - , TimerInfoQ(..) - , TimerCancelled - , TimerExpired - , makeSentPackets - , makeLossDetection - , LDCC(..) - , newLDCC - , qlogSent - , qlogMetricsUpdated - , qlogPacketLost - , qlogContestionStateUpdated - , qlogLossTimerUpdated - , qlogLossTimerCancelled - , qlogLossTimerExpired - ) where + SentPacket (..), + mkSentPacket, + fixSentPacket, + LostPacket (..), + SentPackets (..), + emptySentPackets, + RTT (..), + initialRTT, + CCMode (..), + CC (..), + initialCC, + LossDetection (..), + initialLossDetection, + MetricsDiff (..), + TimerType (..), + TimerInfo (..), + TimerInfoQ (..), + TimerCancelled, + TimerExpired, + makeSentPackets, + makeLossDetection, + LDCC (..), + newLDCC, + qlogSent, + qlogMetricsUpdated, + qlogPacketLost, + qlogContestionStateUpdated, + qlogLossTimerUpdated, + qlogLossTimerCancelled, + qlogLossTimerExpired, +) where import Data.IORef import Data.List (intersperse) @@ -50,178 +50,199 @@ ---------------------------------------------------------------- -data SentPacket = SentPacket { - spPlainPacket :: PlainPacket - , spTimeSent :: TimeMicrosecond - , spSentBytes :: Int - , spEncryptionLevel :: EncryptionLevel - , spPacketNumber :: PacketNumber - , spPeerPacketNumbers :: PeerPacketNumbers - , spAckEliciting :: Bool - } deriving (Eq, Show) +data SentPacket = SentPacket + { spPlainPacket :: PlainPacket + , spTimeSent :: TimeMicrosecond + , spSentBytes :: Int + , spEncryptionLevel :: EncryptionLevel + , spPacketNumber :: PacketNumber + , spPeerPacketNumbers :: PeerPacketNumbers + , spAckEliciting :: Bool + } + deriving (Eq, Show) instance Ord SentPacket where x <= y = spPacketNumber x <= spPacketNumber y newtype LostPacket = LostPacket SentPacket -mkSentPacket :: PacketNumber -> EncryptionLevel -> PlainPacket -> PeerPacketNumbers -> Bool -> SentPacket -mkSentPacket mypn lvl ppkt ppns ackeli = SentPacket { - spPlainPacket = ppkt - , spTimeSent = timeMicrosecond0 - , spSentBytes = 0 - , spEncryptionLevel = lvl - , spPacketNumber = mypn - , spPeerPacketNumbers = ppns - , spAckEliciting = ackeli - } +mkSentPacket + :: PacketNumber + -> EncryptionLevel + -> PlainPacket + -> PeerPacketNumbers + -> Bool + -> SentPacket +mkSentPacket mypn lvl ppkt ppns ackeli = + SentPacket + { spPlainPacket = ppkt + , spTimeSent = timeMicrosecond0 + , spSentBytes = 0 + , spEncryptionLevel = lvl + , spPacketNumber = mypn + , spPeerPacketNumbers = ppns + , spAckEliciting = ackeli + } fixSentPacket :: SentPacket -> Int -> Int -> SentPacket -fixSentPacket spkt bytes padLen = spkt { - spPlainPacket = if padLen /= 0 then addPadding padLen $ spPlainPacket spkt - else spPlainPacket spkt - , spSentBytes = bytes - } +fixSentPacket spkt bytes padLen = + spkt + { spPlainPacket = + if padLen /= 0 + then addPadding padLen $ spPlainPacket spkt + else spPlainPacket spkt + , spSentBytes = bytes + } addPadding :: Int -> PlainPacket -> PlainPacket addPadding n (PlainPacket hdr plain) = PlainPacket hdr plain' where - plain' = plain { - plainFrames = plainFrames plain ++ [Padding n] - } + plain' = + plain + { plainFrames = plainFrames plain ++ [Padding n] + } ---------------------------------------------------------------- -newtype SentPackets = SentPackets (Seq SentPacket) deriving Eq +newtype SentPackets = SentPackets (Seq SentPacket) deriving (Eq) emptySentPackets :: SentPackets emptySentPackets = SentPackets Seq.empty ---------------------------------------------------------------- -data RTT = RTT { - -- | The most recent RTT measurement made when receiving an ack for - -- a previously unacked packet. - latestRTT :: Microseconds - -- | The smoothed RTT of the connection. - , smoothedRTT :: Microseconds - -- | The RTT variation. - , rttvar :: Microseconds - -- | The minimum RTT seen in the connection, ignoring ack delay. - , minRTT :: Microseconds - -- | The maximum amount of time by which the receiver intends to - -- delay acknowledgments for packets in the ApplicationData packet - -- number space. The actual ack_delay in a received ACK frame may - -- be larger due to late timers, reordering, or lost ACK frames. - , maxAckDelay1RTT :: Microseconds - -- | The number of times a PTO has been sent without receiving - -- an ack. - , ptoCount :: Int - } deriving Show +data RTT = RTT + { latestRTT :: Microseconds + -- ^ The most recent RTT measurement made when receiving an ack for + -- a previously unacked packet. + , smoothedRTT :: Microseconds + -- ^ The smoothed RTT of the connection. + , rttvar :: Microseconds + -- ^ The RTT variation. + , minRTT :: Microseconds + -- ^ The minimum RTT seen in the connection, ignoring ack delay. + , maxAckDelay1RTT :: Microseconds + -- ^ The maximum amount of time by which the receiver intends to + -- delay acknowledgments for packets in the ApplicationData packet + -- number space. The actual ack_delay in a received ACK frame may + -- be larger due to late timers, reordering, or lost ACK frames. + , ptoCount :: Int + -- ^ The number of times a PTO has been sent without receiving + -- an ack. + } + deriving (Show) -- | The RTT used before an RTT sample is taken. kInitialRTT :: Microseconds kInitialRTT = Microseconds 333000 initialRTT :: RTT -initialRTT = RTT { - latestRTT = Microseconds 0 - , smoothedRTT = kInitialRTT - , rttvar = kInitialRTT !>>. 1 - , minRTT = Microseconds 0 - , maxAckDelay1RTT = Microseconds 0 - , ptoCount = 0 - } +initialRTT = + RTT + { latestRTT = Microseconds 0 + , smoothedRTT = kInitialRTT + , rttvar = kInitialRTT !>>. 1 + , minRTT = Microseconds 0 + , maxAckDelay1RTT = Microseconds 0 + , ptoCount = 0 + } ---------------------------------------------------------------- -data CCMode = SlowStart - | Avoidance - | Recovery - deriving (Eq) +data CCMode + = SlowStart + | Avoidance + | Recovery + deriving (Eq) instance Show CCMode where show SlowStart = "slow_start" show Avoidance = "avoidance" - show Recovery = "recovery" + show Recovery = "recovery" -data CC = CC { - -- | The sum of the size in bytes of all sent packets that contain - -- at least one ack-eliciting or PADDING frame, and have not been - -- acked or declared lost. The size does not include IP or UDP - -- overhead, but does include the QUIC header and AEAD overhead. - -- Packets only containing ACK frames do not count towards - -- bytes_in_flight to ensure congestion control does not impede - -- congestion feedback. - bytesInFlight :: Int - -- | Maximum number of bytes-in-flight that may be sent. - , congestionWindow :: Int - -- | The time when QUIC first detects congestion due to loss or ECN, - -- causing it to enter congestion recovery. When a packet sent - -- after this time is acknowledged, QUIC exits congestion - -- recovery. - , congestionRecoveryStartTime :: Maybe TimeMicrosecond - -- | Slow start threshold in bytes. When the congestion window is - -- below ssthresh, the mode is slow start and the window grows by - -- the number of bytes acknowledged. - , ssthresh :: Int - -- | Records number of bytes acked, and used for incrementing - -- the congestion window during congestion avoidance. - , bytesAcked :: Int - , numOfAckEliciting :: Int - , ccMode :: CCMode - } deriving Show +data CC = CC + { bytesInFlight :: Int + -- ^ The sum of the size in bytes of all sent packets that contain + -- at least one ack-eliciting or PADDING frame, and have not been + -- acked or declared lost. The size does not include IP or UDP + -- overhead, but does include the QUIC header and AEAD overhead. + -- Packets only containing ACK frames do not count towards + -- bytes_in_flight to ensure congestion control does not impede + -- congestion feedback. + , congestionWindow :: Int + -- ^ Maximum number of bytes-in-flight that may be sent. + , congestionRecoveryStartTime :: Maybe TimeMicrosecond + -- ^ The time when QUIC first detects congestion due to loss or ECN, + -- causing it to enter congestion recovery. When a packet sent + -- after this time is acknowledged, QUIC exits congestion + -- recovery. + , ssthresh :: Int + -- ^ Slow start threshold in bytes. When the congestion window is + -- below ssthresh, the mode is slow start and the window grows by + -- the number of bytes acknowledged. + , bytesAcked :: Int + -- ^ Records number of bytes acked, and used for incrementing + -- the congestion window during congestion avoidance. + , numOfAckEliciting :: Int + , ccMode :: CCMode + } + deriving (Show) initialCC :: CC -initialCC = CC { - bytesInFlight = 0 - , congestionWindow = 0 - , congestionRecoveryStartTime = Nothing - , ssthresh = maxBound - , bytesAcked = 0 - , numOfAckEliciting = 0 - , ccMode = SlowStart - } +initialCC = + CC + { bytesInFlight = 0 + , congestionWindow = 0 + , congestionRecoveryStartTime = Nothing + , ssthresh = maxBound + , bytesAcked = 0 + , numOfAckEliciting = 0 + , ccMode = SlowStart + } ---------------------------------------------------------------- -data LossDetection = LossDetection { - largestAckedPacket :: PacketNumber - , previousAckInfo :: AckInfo - , timeOfLastAckElicitingPacket :: TimeMicrosecond - , lossTime :: Maybe TimeMicrosecond - } deriving Show +data LossDetection = LossDetection + { largestAckedPacket :: PacketNumber + , previousAckInfo :: AckInfo + , timeOfLastAckElicitingPacket :: TimeMicrosecond + , lossTime :: Maybe TimeMicrosecond + } + deriving (Show) initialLossDetection :: LossDetection initialLossDetection = LossDetection (-1) ackInfo0 timeMicrosecond0 Nothing ---------------------------------------------------------------- -newtype MetricsDiff = MetricsDiff [(String,Int)] +newtype MetricsDiff = MetricsDiff [(String, Int)] ---------------------------------------------------------------- -data TimerType = LossTime - | PTO - deriving Eq +data TimerType + = LossTime + | PTO + deriving (Eq) instance Show TimerType where show LossTime = "loss_time" - show PTO = "pto" + show PTO = "pto" data TimerExpired = TimerExpired data TimerCancelled = TimerCancelled -data TimerInfo = TimerInfo { - timerTime :: TimeMicrosecond - , timerLevel :: EncryptionLevel - , timerType :: TimerType - } deriving (Eq, Show) +data TimerInfo = TimerInfo + { timerTime :: TimeMicrosecond + , timerLevel :: EncryptionLevel + , timerType :: TimerType + } + deriving (Eq, Show) -data TimerInfoQ = Empty - | Next TimerInfo - deriving (Eq) +data TimerInfoQ + = Empty + | Next TimerInfo + deriving (Eq) ---------------------------------------------------------------- @@ -231,8 +252,8 @@ i2 <- newIORef False i3 <- newIORef False i4 <- newIORef False - let lst = [(InitialLevel,i1),(RTT0Level,i2),(HandshakeLevel,i3),(RTT1Level,i4)] - arr = array (InitialLevel,RTT1Level) lst + let lst = [(InitialLevel, i1), (RTT0Level, i2), (HandshakeLevel, i3), (RTT1Level, i4)] + arr = array (InitialLevel, RTT1Level) lst return arr makeSentPackets :: IO (Array EncryptionLevel (IORef SentPackets)) @@ -240,8 +261,8 @@ i1 <- newIORef emptySentPackets i2 <- newIORef emptySentPackets i3 <- newIORef emptySentPackets - let lst = [(InitialLevel,i1),(HandshakeLevel,i2),(RTT1Level,i3)] - arr = array (InitialLevel,RTT1Level) lst + let lst = [(InitialLevel, i1), (HandshakeLevel, i2), (RTT1Level, i3)] + arr = array (InitialLevel, RTT1Level) lst return arr makeLossDetection :: IO (Array EncryptionLevel (IORef LossDetection)) @@ -249,32 +270,32 @@ i1 <- newIORef initialLossDetection i2 <- newIORef initialLossDetection i3 <- newIORef initialLossDetection - let lst = [(InitialLevel,i1),(HandshakeLevel,i2),(RTT1Level,i3)] - arr = array (InitialLevel,RTT1Level) lst + let lst = [(InitialLevel, i1), (HandshakeLevel, i2), (RTT1Level, i3)] + arr = array (InitialLevel, RTT1Level) lst return arr -data LDCC = LDCC { - ldccState :: ConnState - , ldccQlogger :: QLogger - , putRetrans :: PlainPacket -> IO () - , recoveryRTT :: IORef RTT - , recoveryCC :: TVar CC - , spaceDiscarded :: Array EncryptionLevel (IORef Bool) - , sentPackets :: Array EncryptionLevel (IORef SentPackets) - , lossDetection :: Array EncryptionLevel (IORef LossDetection) - -- The current timer key - , timerKey :: IORef (Maybe TimeoutKey) - -- The current timer value - , timerInfo :: IORef (Maybe TimerInfo) - , lostCandidates :: TVar SentPackets - , ptoPing :: TVar (Maybe EncryptionLevel) - , speedingUp :: IORef Bool - , pktNumPersistent :: IORef PacketNumber - , peerPacketNumbers :: Array EncryptionLevel (IORef PeerPacketNumbers) - , previousRTT1PPNs :: IORef PeerPacketNumbers -- for RTT1 - -- Pending timer value - , timerInfoQ :: TVar TimerInfoQ - } +data LDCC = LDCC + { ldccState :: ConnState + , ldccQlogger :: QLogger + , putRetrans :: PlainPacket -> IO () + , recoveryRTT :: IORef RTT + , recoveryCC :: TVar CC + , spaceDiscarded :: Array EncryptionLevel (IORef Bool) + , sentPackets :: Array EncryptionLevel (IORef SentPackets) + , lossDetection :: Array EncryptionLevel (IORef LossDetection) + , -- The current timer key + timerKey :: IORef (Maybe TimeoutKey) + , -- The current timer value + timerInfo :: IORef (Maybe TimerInfo) + , lostCandidates :: TVar SentPackets + , ptoPing :: TVar (Maybe EncryptionLevel) + , speedingUp :: IORef Bool + , pktNumPersistent :: IORef PacketNumber + , peerPacketNumbers :: Array EncryptionLevel (IORef PeerPacketNumbers) + , previousRTT1PPNs :: IORef PeerPacketNumbers -- for RTT1 + -- Pending timer value + , timerInfoQ :: TVar TimerInfoQ + } makePPN :: IO (Array EncryptionLevel (IORef PeerPacketNumbers)) makePPN = do @@ -282,62 +303,81 @@ ref2 <- newIORef emptyPeerPacketNumbers ref3 <- newIORef emptyPeerPacketNumbers -- using the ref for RTT0Level and RTT1Level - let lst = [(InitialLevel, ref1) - ,(RTT0Level, ref3) - ,(HandshakeLevel, ref2) - ,(RTT1Level, ref3)] - arr = array (InitialLevel,RTT1Level) lst + let lst = + [ (InitialLevel, ref1) + , (RTT0Level, ref3) + , (HandshakeLevel, ref2) + , (RTT1Level, ref3) + ] + arr = array (InitialLevel, RTT1Level) lst return arr newLDCC :: ConnState -> QLogger -> (PlainPacket -> IO ()) -> IO LDCC -newLDCC cs qLog put = LDCC cs qLog put - <$> newIORef initialRTT - <*> newTVarIO initialCC - <*> makeSpaceDiscarded - <*> makeSentPackets - <*> makeLossDetection - <*> newIORef Nothing - <*> newIORef Nothing - <*> newTVarIO emptySentPackets - <*> newTVarIO Nothing - <*> newIORef False - <*> newIORef maxBound - <*> makePPN - <*> newIORef emptyPeerPacketNumbers - <*> newTVarIO Empty +newLDCC cs qLog put = + LDCC cs qLog put + <$> newIORef initialRTT + <*> newTVarIO initialCC + <*> makeSpaceDiscarded + <*> makeSentPackets + <*> makeLossDetection + <*> newIORef Nothing + <*> newIORef Nothing + <*> newTVarIO emptySentPackets + <*> newTVarIO Nothing + <*> newIORef False + <*> newIORef maxBound + <*> makePPN + <*> newIORef emptyPeerPacketNumbers + <*> newTVarIO Empty instance KeepQlog LDCC where keepQlog = ldccQlogger instance Connector LDCC where - getRole = role . ldccState + getRole = role . ldccState getEncryptionLevel = readTVarIO . encryptionLevel . ldccState - getMaxPacketSize = readIORef . maxPacketSize . ldccState + getMaxPacketSize = readIORef . maxPacketSize . ldccState getConnectionState = readTVarIO . connectionState . ldccState - getPacketNumber = readIORef . packetNumber . ldccState - getAlive = readIORef . connectionAlive . ldccState + getPacketNumber = readIORef . packetNumber . ldccState + getAlive = readIORef . connectionAlive . ldccState ---------------------------------------------------------------- instance Qlog SentPacket where - qlog SentPacket{..} = "{\"raw\":{\"length\":" <> sw spSentBytes <> "},\"header\":{\"packet_type\":\"" <> toLogStr (packetType hdr) <> "\",\"packet_number\":\"" <> sw plainPacketNumber <> "\",\"dcid\":\"" <> sw (headerMyCID hdr) <> "\"},\"frames\":" <> "[" <> foldr (<>) "" (intersperse "," (map qlog plainFrames)) <> "]" <> "}" + qlog SentPacket{..} = + "{\"raw\":{\"length\":" + <> sw spSentBytes + <> "},\"header\":{\"packet_type\":\"" + <> toLogStr (packetType hdr) + <> "\",\"packet_number\":\"" + <> sw plainPacketNumber + <> "\",\"dcid\":\"" + <> sw (headerMyCID hdr) + <> "\"},\"frames\":" + <> "[" + <> foldr (<>) "" (intersperse "," (map qlog plainFrames)) + <> "]" + <> "}" where PlainPacket hdr Plain{..} = spPlainPacket instance Qlog LostPacket where qlog (LostPacket SentPacket{..}) = - "{\"header\":{\"packet_type\":\"" <> toLogStr (packetType hdr) <> "\"" <> - ",\"packet_number\":" <> sw spPacketNumber <> - "}}" + "{\"header\":{\"packet_type\":\"" + <> toLogStr (packetType hdr) + <> "\"" + <> ",\"packet_number\":" + <> sw spPacketNumber + <> "}}" where PlainPacket hdr _ = spPlainPacket instance Qlog MetricsDiff where qlog (MetricsDiff []) = "{}" - qlog (MetricsDiff (x:xs)) = "{" <> tv0 x <> foldr tv "" xs <> "}" + qlog (MetricsDiff (x : xs)) = "{" <> tv0 x <> foldr tv "" xs <> "}" where - tv0 (tag,val) = "\"" <> toLogStr tag <> "\":" <> sw val - tv (tag,val) pre = ",\"" <> toLogStr tag <> "\":" <> sw val <> pre + tv0 (tag, val) = "\"" <> toLogStr tag <> "\":" <> sw val + tv (tag, val) pre = ",\"" <> toLogStr tag <> "\":" <> sw val <> pre instance Qlog CCMode where qlog mode = "{\"new\":\"" <> sw mode <> "\"}" @@ -346,20 +386,26 @@ qlog TimerCancelled = "{\"event_type\":\"cancelled\"}" instance Qlog TimerExpired where - qlog TimerExpired = "{\"event_type\":\"expired\"}" + qlog TimerExpired = "{\"event_type\":\"expired\"}" -instance Qlog (TimerInfo,Microseconds) where - qlog (TimerInfo{..},us) = "{\"event_type\":\"set\"" <> - ",\"timer_type\":\"" <> sw timerType <> "\"" <> - ",\"packet_number_space\":\"" <> packetNumberSpace timerLevel <> "\"" <> - ",\"delta\":" <> delta us <> - "}" +instance Qlog (TimerInfo, Microseconds) where + qlog (TimerInfo{..}, us) = + "{\"event_type\":\"set\"" + <> ",\"timer_type\":\"" + <> sw timerType + <> "\"" + <> ",\"packet_number_space\":\"" + <> packetNumberSpace timerLevel + <> "\"" + <> ",\"delta\":" + <> delta us + <> "}" packetNumberSpace :: EncryptionLevel -> LogStr -packetNumberSpace InitialLevel = "initial" -packetNumberSpace RTT0Level = "application_data" +packetNumberSpace InitialLevel = "initial" +packetNumberSpace RTT0Level = "application_data" packetNumberSpace HandshakeLevel = "handshake" -packetNumberSpace RTT1Level = "application_data" +packetNumberSpace RTT1Level = "application_data" delta :: Microseconds -> LogStr delta (Microseconds n) = sw n @@ -382,7 +428,7 @@ tim <- getTimeMicrosecond keepQlog q $ QCongestionStateUpdated (qlog mode) tim -qlogLossTimerUpdated :: KeepQlog q => q -> (TimerInfo,Microseconds) -> IO () +qlogLossTimerUpdated :: KeepQlog q => q -> (TimerInfo, Microseconds) -> IO () qlogLossTimerUpdated q tmi = do tim <- getTimeMicrosecond keepQlog q $ QLossTimerUpdated (qlog tmi) tim diff --git a/Network/QUIC/Recovery/Utils.hs b/Network/QUIC/Recovery/Utils.hs --- a/Network/QUIC/Recovery/Utils.hs +++ b/Network/QUIC/Recovery/Utils.hs @@ -2,17 +2,17 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Recovery.Utils ( - retransmit - , sendPing - , mergeLostCandidates - , mergeLostCandidatesAndClear - , peerCompletedAddressValidation - , countAckEli - , inCongestionRecovery - , delay - ) where + retransmit, + sendPing, + mergeLostCandidates, + mergeLostCandidatesAndClear, + peerCompletedAddressValidation, + countAckEli, + inCongestionRecovery, + delay, +) where -import Data.Sequence (Seq, (<|), ViewL(..)) +import Data.Sequence (Seq, ViewL (..), (<|)) import qualified Data.Sequence as Seq import UnliftIO.Concurrent import UnliftIO.STM @@ -26,8 +26,8 @@ retransmit :: LDCC -> Seq SentPacket -> IO () retransmit ldcc lostPackets - | null packetsToBeResent = getEncryptionLevel ldcc >>= sendPing ldcc - | otherwise = mapM_ put packetsToBeResent + | null packetsToBeResent = getEncryptionLevel ldcc >>= sendPing ldcc + | otherwise = mapM_ put packetsToBeResent where packetsToBeResent = Seq.filter spAckEliciting lostPackets put = putRetrans ldcc . spPlainPacket @@ -37,9 +37,10 @@ sendPing :: LDCC -> EncryptionLevel -> IO () sendPing LDCC{..} lvl = do now <- getTimeMicrosecond - atomicModifyIORef'' (lossDetection ! lvl) $ \ld -> ld { - timeOfLastAckElicitingPacket = now - } + atomicModifyIORef'' (lossDetection ! lvl) $ \ld -> + ld + { timeOfLastAckElicitingPacket = now + } atomically $ writeTVar ptoPing $ Just lvl ---------------------------------------------------------------- @@ -58,12 +59,12 @@ merge :: Seq SentPacket -> Seq SentPacket -> Seq SentPacket merge s1 s2 = case Seq.viewl s1 of - EmptyL -> s2 - x :< s1' -> case Seq.viewl s2 of - EmptyL -> s1 - y :< s2' - | spPacketNumber x < spPacketNumber y -> x <| merge s1' s2 - | otherwise -> y <| merge s1 s2' + EmptyL -> s2 + x :< s1' -> case Seq.viewl s2 of + EmptyL -> s1 + y :< s2' + | spPacketNumber x < spPacketNumber y -> x <| merge s1' s2 + | otherwise -> y <| merge s1 s2' ---------------------------------------------------------------- @@ -75,7 +76,7 @@ peerCompletedAddressValidation :: LDCC -> IO Bool -- For servers: assume clients validate the server's address implicitly. peerCompletedAddressValidation ldcc - | isServer ldcc = return True + | isServer ldcc = return True -- For clients: servers complete address validation when a protected -- packet is received. peerCompletedAddressValidation ldcc = isConnectionEstablished ldcc @@ -84,8 +85,8 @@ countAckEli :: SentPacket -> Int countAckEli sentPacket - | spAckEliciting sentPacket = 1 - | otherwise = 0 + | spAckEliciting sentPacket = 1 + | otherwise = 0 ---------------------------------------------------------------- diff --git a/Network/QUIC/Sender.hs b/Network/QUIC/Sender.hs --- a/Network/QUIC/Sender.hs +++ b/Network/QUIC/Sender.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Sender ( - sender - , mkHeader - , sendFinal - ) where + sender, + mkHeader, + sendFinal, +) where import qualified Data.ByteString as BS import Foreign.Ptr (plusPtr) @@ -30,10 +30,10 @@ let len = BS.length crypto mstrm <- getCryptoStream conn lvl case mstrm of - Nothing -> E.throwIO MustNotReached - Just strm -> do - off <- getTxStreamOffset strm len - return $ CryptoF off crypto + Nothing -> E.throwIO MustNotReached + Just strm -> do + off <- getTxStreamOffset strm len + return $ CryptoF off crypto ---------------------------------------------------------------- @@ -44,141 +44,152 @@ SizedBuffer buf0 bufsiz0 = encryptRes conn ldcc = connLDCC conn go maxSiz = do - mx <- atomically ((Just <$> takePingSTM ldcc) - `orElse` (Nothing <$ checkWindowOpenSTM ldcc maxSiz)) + mx <- + atomically + ( (Just <$> takePingSTM ldcc) + `orElse` (Nothing <$ checkWindowOpenSTM ldcc maxSiz) + ) case mx of - Just lvl | lvl `elem` [InitialLevel,HandshakeLevel] -> do - sendPingPacket conn lvl - go maxSiz - _ -> do - 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 - now <- getTimeMicrosecond - connSend conn buf0 bytes - addTxBytes conn bytes - forM_ sentPackets $ \sentPacket0 -> do - let sentPacket = sentPacket0 { spTimeSent = now } - qlogSent conn sentPacket now - onPacketSent ldcc sentPacket + Just lvl | lvl `elem` [InitialLevel, HandshakeLevel] -> do + sendPingPacket conn lvl + go maxSiz + _ -> do + 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 + now <- getTimeMicrosecond + connSend conn buf0 bytes + addTxBytes conn bytes + forM_ sentPackets $ \sentPacket0 -> do + let sentPacket = sentPacket0{spTimeSent = now} + qlogSent conn sentPacket now + onPacketSent ldcc sentPacket buildPackets _ _ _ [] _ = error "sendPacket: buildPackets" buildPackets buf bufsiz siz [spkt] build0 = do let pkt = spPlainPacket spkt - (bytes,padlen) <- encodePlainPacket conn (SizedBuffer buf bufsiz) pkt $ Just siz - if bytes < 0 then - return (build0 [], bufsiz) - else do - let sentPacket = fixSentPacket spkt bytes padlen - return (build0 [sentPacket], bufsiz - bytes) - buildPackets buf bufsiz siz (spkt:spkts) build0 = do + (bytes, padlen) <- + encodePlainPacket conn (SizedBuffer buf bufsiz) pkt $ Just siz + if bytes < 0 + then return (build0 [], bufsiz) + else do + let sentPacket = fixSentPacket spkt bytes padlen + return (build0 [sentPacket], bufsiz - bytes) + buildPackets buf bufsiz siz (spkt : spkts) build0 = do let pkt = spPlainPacket spkt - (bytes,padlen) <- encodePlainPacket conn (SizedBuffer buf bufsiz) pkt Nothing - if bytes < 0 then - buildPackets buf bufsiz siz spkts build0 - else do - let sentPacket = fixSentPacket spkt bytes padlen - let build0' = build0 . (sentPacket :) - buf' = buf `plusPtr` bytes - bufsiz' = bufsiz - bytes - siz' = siz - spSentBytes sentPacket - buildPackets buf' bufsiz' siz' spkts build0' + (bytes, padlen) <- encodePlainPacket conn (SizedBuffer buf bufsiz) pkt Nothing + if bytes < 0 + then buildPackets buf bufsiz siz spkts build0 + else do + let sentPacket = fixSentPacket spkt bytes padlen + let build0' = build0 . (sentPacket :) + buf' = buf `plusPtr` bytes + bufsiz' = bufsiz - bytes + siz' = siz - spSentBytes sentPacket + buildPackets buf' bufsiz' siz' spkts build0' ---------------------------------------------------------------- sendPingPacket :: Connection -> EncryptionLevel -> IO () sendPingPacket conn lvl = do maxSiz <- getMaxPacketSize conn - ok <- if isClient conn then return True - else checkAntiAmplificationFree conn maxSiz + ok <- + if isClient conn + then return True + else checkAntiAmplificationFree conn maxSiz when ok $ do let ldcc = connLDCC conn mp <- releaseOldest ldcc lvl frames <- case mp of - Nothing -> do - qlogDebug conn $ Debug "probe ping" - return [Ping] - Just spkt -> do - qlogDebug conn $ Debug "probe old" - let PlainPacket _ plain0 = spPlainPacket spkt - adjustForRetransmit conn $ plainFrames plain0 + Nothing -> do + qlogDebug conn $ Debug "probe ping" + return [Ping] + Just spkt -> do + qlogDebug conn $ Debug "probe old" + let PlainPacket _ plain0 = spPlainPacket spkt + adjustForRetransmit conn $ plainFrames plain0 xs <- construct conn lvl frames - if null xs then - qlogDebug conn $ Debug "ping NULL" - else do - let spkt = last xs - ping = spPlainPacket spkt - let sizbuf@(SizedBuffer buf _) = encryptRes conn - (bytes,padlen) <- encodePlainPacket conn sizbuf ping (Just maxSiz) - when (bytes >= 0) $ do - now <- getTimeMicrosecond - connSend conn buf bytes - addTxBytes conn bytes - let sentPacket0 = fixSentPacket spkt bytes padlen - sentPacket = sentPacket0 { spTimeSent = now } - qlogSent conn sentPacket now - onPacketSent ldcc sentPacket + if null xs + then qlogDebug conn $ Debug "ping NULL" + else do + let spkt = last xs + ping = spPlainPacket spkt + let sizbuf@(SizedBuffer buf _) = encryptRes conn + (bytes, padlen) <- encodePlainPacket conn sizbuf ping (Just maxSiz) + when (bytes >= 0) $ do + now <- getTimeMicrosecond + connSend conn buf bytes + addTxBytes conn bytes + let sentPacket0 = fixSentPacket spkt bytes padlen + sentPacket = sentPacket0{spTimeSent = now} + qlogSent conn sentPacket now + onPacketSent ldcc sentPacket ---------------------------------------------------------------- -construct :: Connection - -> EncryptionLevel - -> [Frame] - -> IO [SentPacket] +construct + :: Connection + -> EncryptionLevel + -> [Frame] + -> IO [SentPacket] construct conn lvl frames = do discarded <- getPacketNumberSpaceDiscarded ldcc lvl - if discarded then - return [] - else do - established <- isConnectionEstablished conn - if established || (isServer conn && lvl == HandshakeLevel) then do - constructTargetPacket - else do - ppkt0 <- constructLowerAckPacket - ppkt1 <- constructTargetPacket - return (ppkt0 ++ ppkt1) + if discarded + then return [] + else do + established <- isConnectionEstablished conn + if established || (isServer conn && lvl == HandshakeLevel) + then do + constructTargetPacket + else do + ppkt0 <- constructLowerAckPacket + ppkt1 <- constructTargetPacket + return (ppkt0 ++ ppkt1) where ldcc = connLDCC conn constructLowerAckPacket = do let lvl' = case lvl of - HandshakeLevel -> InitialLevel - RTT1Level -> HandshakeLevel - _ -> RTT1Level - if lvl' == RTT1Level then - return [] - else do - ppns <- getPeerPacketNumbers ldcc lvl' - if nullPeerPacketNumbers ppns then - return [] - else - mkPlainPacket conn lvl' [] ppns + HandshakeLevel -> InitialLevel + RTT1Level -> HandshakeLevel + _ -> RTT1Level + if lvl' == RTT1Level + then return [] + else do + ppns <- getPeerPacketNumbers ldcc lvl' + if nullPeerPacketNumbers ppns + then return [] + else mkPlainPacket conn lvl' [] ppns constructTargetPacket - | null frames = do -- ACK only packet + | null frames = do + -- ACK only packet resetDealyedAck conn ppns <- getPeerPacketNumbers ldcc lvl - if nullPeerPacketNumbers ppns then - return [] - else - if lvl == RTT1Level then do - prevppns <- getPreviousRTT1PPNs ldcc - if ppns /= prevppns then do - setPreviousRTT1PPNs ldcc ppns - mkPlainPacket conn lvl [] ppns - else - return [] - else - mkPlainPacket conn lvl [] ppns - | otherwise = do + if nullPeerPacketNumbers ppns + then return [] + else + if lvl == RTT1Level + then do + prevppns <- getPreviousRTT1PPNs ldcc + if ppns /= prevppns + then do + setPreviousRTT1PPNs ldcc ppns + mkPlainPacket conn lvl [] ppns + else return [] + else mkPlainPacket conn lvl [] ppns + | otherwise = do resetDealyedAck conn ppns <- getPeerPacketNumbers ldcc lvl mkPlainPacket conn lvl frames ppns -mkPlainPacket :: Connection -> EncryptionLevel -> [Frame] -> PeerPacketNumbers -> IO [SentPacket] +mkPlainPacket + :: Connection -> EncryptionLevel -> [Frame] -> PeerPacketNumbers -> IO [SentPacket] mkPlainPacket conn lvl frames0 ppns = do - let ackEli | null frames0 = False - | otherwise = True - frames | nullPeerPacketNumbers ppns = frames0 - | otherwise = mkAck ppns : frames0 + let ackEli + | null frames0 = False + | otherwise = True + frames + | nullPeerPacketNumbers ppns = frames0 + | otherwise = mkAck ppns : frames0 header <- mkHeader conn lvl mypn <- nextPacketNumber conn let convert = onPlainCreated $ connHooks conn @@ -195,16 +206,17 @@ peercid <- getPeerCID conn token <- if lvl == InitialLevel then getToken conn else return "" return $ case lvl of - InitialLevel -> Initial ver peercid mycid token - RTT0Level -> RTT0 ver peercid mycid - HandshakeLevel -> Handshake ver peercid mycid - RTT1Level -> Short peercid + InitialLevel -> Initial ver peercid mycid token + RTT0Level -> RTT0 ver peercid mycid + HandshakeLevel -> Handshake ver peercid mycid + RTT1Level -> Short peercid ---------------------------------------------------------------- -data Switch = SwPing EncryptionLevel - | SwOut Output - | SwStrm TxStreamData +data Switch + = SwPing EncryptionLevel + | SwOut Output + | SwStrm TxStreamData sender :: Connection -> IO () sender conn = handleLogT logAction $ forever $ sendP conn @@ -213,13 +225,16 @@ sendP :: Connection -> IO () sendP conn = do - x <- atomically ((SwPing <$> takePingSTM (connLDCC conn)) - `orElse` (SwOut <$> takeOutputSTM conn) - `orElse` (SwStrm <$> takeSendStreamQSTM conn)) + x <- + atomically + ( (SwPing <$> takePingSTM (connLDCC conn)) + `orElse` (SwOut <$> takeOutputSTM conn) + `orElse` (SwStrm <$> takeSendStreamQSTM conn) + ) case x of - SwPing lvl -> sendPingPacket conn lvl - SwOut out -> sendOutput conn out - SwStrm tx -> sendTxStreamData conn tx + SwPing lvl -> sendPingPacket conn lvl + SwOut out -> sendOutput conn out + SwStrm tx -> sendTxStreamData conn tx sendFinal :: Connection -> IO () sendFinal conn = loop 30 @@ -230,35 +245,34 @@ loop n = do mx <- timeout (Microseconds 10) msg $ sendP conn case mx of - Nothing -> return () - Just () -> loop (n - 1) + Nothing -> return () + Just () -> loop (n - 1) ---------------------------------------------------------------- discardClientInitialPacketNumberSpace :: Connection -> IO () discardClientInitialPacketNumberSpace conn - | isClient conn = do + | isClient conn = do let ldcc = connLDCC conn discarded <- getAndSetPacketNumberSpaceDiscarded ldcc InitialLevel unless discarded $ fire conn (Microseconds 100000) $ do dropSecrets conn InitialLevel clearCryptoStream conn InitialLevel onPacketNumberSpaceDiscarded ldcc InitialLevel - | otherwise = return () + | otherwise = return () sendOutput :: Connection -> Output -> IO () sendOutput conn (OutControl lvl frames action) = do construct conn lvl frames >>= sendPacket conn when (lvl == HandshakeLevel) $ discardClientInitialPacketNumberSpace conn action - sendOutput conn (OutHandshake lcs0) = do let convert = onTLSHandshakeCreated $ connHooks conn - (lcs,wait) = convert lcs0 + (lcs, wait) = convert lcs0 -- only for h3spec when wait $ wait0RTTReady conn sendCryptoFragments conn lcs - when (any (\(l,_) -> l == HandshakeLevel) lcs) $ + when (any (\(l, _) -> l == HandshakeLevel) lcs) $ discardClientInitialPacketNumberSpace conn sendOutput conn (OutRetrans (PlainPacket hdr0 plain0)) = do frames <- adjustForRetransmit conn $ plainFrames plain0 @@ -268,29 +282,29 @@ levelFromHeader :: Header -> EncryptionLevel levelFromHeader hdr | lvl == RTT0Level = RTT1Level - | otherwise = lvl + | otherwise = lvl where lvl = packetEncryptionLevel hdr adjustForRetransmit :: Connection -> [Frame] -> IO [Frame] -adjustForRetransmit _ [] = return [] -adjustForRetransmit conn (Padding{}:xs) = adjustForRetransmit conn xs -adjustForRetransmit conn (Ack{}:xs) = adjustForRetransmit conn xs -adjustForRetransmit conn (MaxStreamData sid _:xs) = do +adjustForRetransmit _ [] = return [] +adjustForRetransmit conn (Padding{} : xs) = adjustForRetransmit conn xs +adjustForRetransmit conn (Ack{} : xs) = adjustForRetransmit conn xs +adjustForRetransmit conn (MaxStreamData sid _ : xs) = do mstrm <- findStream conn sid case mstrm of - Nothing -> adjustForRetransmit conn xs - Just strm -> do - newMax <- getRxMaxStreamData strm - let r = MaxStreamData sid newMax - rs <- adjustForRetransmit conn xs - return (r : rs) -adjustForRetransmit conn (MaxData{}:xs) = do + Nothing -> adjustForRetransmit conn xs + Just strm -> do + newMax <- getRxMaxStreamData strm + let r = MaxStreamData sid newMax + rs <- adjustForRetransmit conn xs + return (r : rs) +adjustForRetransmit conn (MaxData{} : xs) = do newMax <- getRxMaxData conn let r = MaxData newMax rs <- adjustForRetransmit conn xs return (r : rs) -adjustForRetransmit conn (x:xs) = do +adjustForRetransmit conn (x : xs) = do rs <- adjustForRetransmit conn xs return (x : rs) @@ -305,7 +319,11 @@ sendCryptoFragments conn lcs = do loop limitationC id lcs where - loop :: Int -> ([SentPacket] -> [SentPacket]) -> [(EncryptionLevel, CryptoData)] -> IO () + loop + :: Int + -> ([SentPacket] -> [SentPacket]) + -> [(EncryptionLevel, CryptoData)] + -> IO () loop _ build0 [] = do let spkts0 = build0 [] unless (null spkts0) $ sendPacket conn spkts0 @@ -334,29 +352,28 @@ ---------------------------------------------------------------- threshold :: Int -threshold = 832 +threshold = 832 limitation :: Int limitation = 1040 packFin :: Connection -> Stream -> Bool -> IO Bool -packFin _ _ True = return True +packFin _ _ True = return True packFin conn s False = do mx <- tryPeekSendStreamQ conn case mx of - Just (TxStreamData s1 [] 0 True) - | streamId s == streamId s1 -> do + Just (TxStreamData s1 [] 0 True) + | streamId s == streamId s1 -> do _ <- takeSendStreamQ conn return True - _ -> return False + _ -> return False sendTxStreamData :: Connection -> TxStreamData -> IO () sendTxStreamData conn (TxStreamData s dats len fin0) = do fin <- packFin conn s fin0 - if len < limitation then - sendStreamSmall conn s dats fin len - else - sendStreamLarge conn s dats fin + if len < limitation + then sendStreamSmall conn s dats fin len + else sendStreamLarge conn s dats fin sendStreamSmall :: Connection -> Stream -> [StreamData] -> Bool -> Int -> IO () sendStreamSmall conn s0 dats0 fin0 len0 = do @@ -364,9 +381,10 @@ let sid0 = streamId s0 frame0 = StreamF sid0 off0 dats0 fin0 sb = if fin0 then (s0 :) else id - (frames,streams) <- loop s0 frame0 len0 id sb + (frames, streams) <- loop s0 frame0 len0 id sb ready <- isConnection1RTTReady conn - let lvl | ready = RTT1Level + let lvl + | ready = RTT1Level | otherwise = RTT0Level construct conn lvl frames >>= sendPacket conn mapM_ syncFinTx streams @@ -374,40 +392,44 @@ tryPeek = do mx <- tryPeekSendStreamQ conn case mx of - Nothing -> do - yield - tryPeekSendStreamQ conn - Just _ -> return mx - loop :: Stream -> Frame -> Int - -> ([Frame] -> [Frame]) - -> ([Stream] -> [Stream]) - -> IO ([Frame], [Stream]) + Nothing -> do + yield + tryPeekSendStreamQ conn + Just _ -> return mx + loop + :: Stream + -> Frame + -> Int + -> ([Frame] -> [Frame]) + -> ([Stream] -> [Stream]) + -> IO ([Frame], [Stream]) loop s frame total build sb = do mx <- tryPeek case mx of - Nothing -> return (build [frame], sb []) - Just (TxStreamData s1 dats1 len1 fin1) -> do - let total1 = len1 + total - if total1 < limitation then do - _ <- takeSendStreamQ conn -- cf tryPeek - fin1' <- packFin conn s fin1 -- must be after takeSendStreamQ - off1 <- getTxStreamOffset s1 len1 - let sid = streamId s - sid1 = streamId s1 - if sid == sid1 then do - let (off,dats) = case frame of - StreamF _ o d _ -> (o,d) - _ -> error "sendStreamSmall" - frame1 = StreamF sid off (dats ++ dats1) fin1' - sb1 = if fin1 then (sb . (s1 :)) else sb - loop s1 frame1 total1 build sb1 - else do - let frame1 = StreamF sid1 off1 dats1 fin1' - build1 = build . (frame :) - sb1 = if fin1 then (sb . (s1 :)) else sb - loop s1 frame1 total1 build1 sb1 - else - return (build [frame], sb []) + Nothing -> return (build [frame], sb []) + Just (TxStreamData s1 dats1 len1 fin1) -> do + let total1 = len1 + total + if total1 < limitation + then do + _ <- takeSendStreamQ conn -- cf tryPeek + fin1' <- packFin conn s fin1 -- must be after takeSendStreamQ + off1 <- getTxStreamOffset s1 len1 + let sid = streamId s + sid1 = streamId s1 + if sid == sid1 + then do + let (off, dats) = case frame of + StreamF _ o d _ -> (o, d) + _ -> error "sendStreamSmall" + frame1 = StreamF sid off (dats ++ dats1) fin1' + sb1 = if fin1 then (sb . (s1 :)) else sb + loop s1 frame1 total1 build sb1 + else do + let frame1 = StreamF sid1 off1 dats1 fin1' + build1 = build . (frame :) + sb1 = if fin1 then (sb . (s1 :)) else sb + loop s1 frame1 total1 build1 sb1 + else return (build [frame], sb []) sendStreamLarge :: Connection -> Stream -> [ByteString] -> Bool -> IO () sendStreamLarge conn s dats0 fin0 = do @@ -417,30 +439,32 @@ sid = streamId s loop [] = return () loop dats = do - let (dats1,dats2) = splitChunks dats + let (dats1, dats2) = splitChunks dats len = totalLen dats1 off <- getTxStreamOffset s len let fin = fin0 && null dats2 frame = StreamF sid off dats1 fin ready <- isConnection1RTTReady conn - let lvl | ready = RTT1Level + let lvl + | ready = RTT1Level | otherwise = RTT0Level construct conn lvl [frame] >>= sendPacket conn loop dats2 -- Typical case: [3, 1024, 1024, 1024, 200] -splitChunks :: [ByteString] -> ([ByteString],[ByteString]) +splitChunks :: [ByteString] -> ([ByteString], [ByteString]) splitChunks bs0 = loop bs0 0 id where - loop [] _ build = let curr = build [] in (curr, []) - loop bbs@(b:bs) siz0 build - | siz <= threshold = let build' = build . (b :) in loop bs siz build' - | siz <= limitation = let curr = build [b] in (curr, bs) - | len > limitation = let (u,b') = BS.splitAt (limitation - siz0) b - curr = build [u] - bs' = b':bs - in (curr,bs') - | otherwise = let curr = build [] in (curr, bbs) + loop [] _ build = let curr = build [] in (curr, []) + loop bbs@(b : bs) siz0 build + | siz <= threshold = let build' = build . (b :) in loop bs siz build' + | siz <= limitation = let curr = build [b] in (curr, bs) + | len > limitation = + let (u, b') = BS.splitAt (limitation - siz0) b + curr = build [u] + bs' = b' : bs + in (curr, bs') + | otherwise = let curr = build [] in (curr, bbs) where len = BS.length b siz = siz0 + len diff --git a/Network/QUIC/Server.hs b/Network/QUIC/Server.hs --- a/Network/QUIC/Server.hs +++ b/Network/QUIC/Server.hs @@ -1,25 +1,27 @@ -- | This main module provides APIs for QUIC servers. module Network.QUIC.Server ( - -- * Running a QUIC server - run - , stop - -- * Configuration - , ServerConfig - , defaultServerConfig - , scAddresses - , scALPN - , scRequireRetry - , scUse0RTT - , scCiphers - , scGroups - , scVersions --- , scParameters - , scCredentials - , scSessionManager - -- * Certificate - , clientCertificateChain - ) where + -- * Running a QUIC server + run, + stop, + -- * Configuration + ServerConfig, + defaultServerConfig, + scAddresses, + scALPN, + scRequireRetry, + scUse0RTT, + scCiphers, + scGroups, + scVersions, + -- , scParameters + scCredentials, + scSessionManager, + + -- * Certificate + clientCertificateChain, +) where + import Data.X509 (CertificateChain) import Network.QUIC.Config @@ -32,5 +34,5 @@ -- | Getting a certificate chain of a client. clientCertificateChain :: Connection -> IO (Maybe CertificateChain) clientCertificateChain conn - | isClient conn = return Nothing - | otherwise = getCertificateChain conn + | isClient conn = return Nothing + | otherwise = getCertificateChain conn diff --git a/Network/QUIC/Server/Reader.hs b/Network/QUIC/Server/Reader.hs --- a/Network/QUIC/Server/Reader.hs +++ b/Network/QUIC/Server/Reader.hs @@ -23,10 +23,10 @@ import qualified Data.ByteString as BS import Data.Map.Strict (Map) import qualified Data.Map.Strict as M -import Data.OrdPSQ (OrdPSQ) -import qualified Data.OrdPSQ as PSQ import qualified GHC.IO.Exception as E import Network.ByteOrder +import Network.Control (LRUCache) +import qualified Network.Control as LRUCache import Network.UDP (ListenSocket, UDPSocket, ClientSockAddr) import qualified Network.UDP as UDP import qualified System.IO.Error as E @@ -91,29 +91,25 @@ ---------------------------------------------------------------- -- Original destination CID -> RecvQ -data RecvQDict = RecvQDict Int (OrdPSQ CID Int RecvQ) +data RecvQDict = RecvQDict(LRUCache CID RecvQ) recvQDictSize :: Int recvQDictSize = 100 emptyRecvQDict :: RecvQDict -emptyRecvQDict = RecvQDict 0 PSQ.empty +emptyRecvQDict = RecvQDict $ LRUCache.empty recvQDictSize lookupRecvQDict :: IORef RecvQDict -> CID -> IO (Maybe RecvQ) lookupRecvQDict ref dcid = do - RecvQDict _ qt <- readIORef ref - return $ case PSQ.lookup dcid qt of - Nothing -> Nothing - Just (_,q) -> Just q + RecvQDict c <- readIORef ref + return $ case LRUCache.lookup dcid c of + Nothing -> Nothing + Just q -> Just q insertRecvQDict :: IORef RecvQDict -> CID -> RecvQ -> IO () insertRecvQDict ref dcid q = atomicModifyIORef'' ref ins where - ins (RecvQDict p qt0) = let qt1 | PSQ.size qt0 <= recvQDictSize = qt0 - | otherwise = PSQ.deleteMin qt0 - qt2 = PSQ.insert dcid p q qt1 - p' = p + 1 -- fixme: overflow - in RecvQDict p' qt2 + ins (RecvQDict c) = RecvQDict $ LRUCache.insert dcid q c ---------------------------------------------------------------- diff --git a/Network/QUIC/Stream.hs b/Network/QUIC/Stream.hs --- a/Network/QUIC/Stream.hs +++ b/Network/QUIC/Stream.hs @@ -1,50 +1,46 @@ module Network.QUIC.Stream ( - -- * Types - Stream - , streamId - , streamConnection - , newStream - , TxStreamData(..) - , Flow(..) - , defaultFlow - , StreamState(..) - , RecvStreamQ(..) - , RxStreamData(..) - , Length - , syncFinTx - , waitFinTx - -- * Misc - , getTxStreamOffset - , isTxStreamClosed - , setTxStreamClosed - , getRxStreamOffset - , isRxStreamClosed - , setRxStreamClosed - , readStreamFlowTx - , addTxStreamData - , setTxMaxStreamData - , readStreamFlowRx - , addRxStreamData - , setRxMaxStreamData - , addRxMaxStreamData - , getRxMaxStreamData - , getRxStreamWindow - , flowWindow - -- * Reass - , takeRecvStreamQwithSize - , putRxStreamData - , FlowCntl(..) - , tryReassemble - -- * Table - , StreamTable - , emptyStreamTable - , lookupStream - , insertStream - , deleteStream - , insertCryptoStreams - , deleteCryptoStream - , lookupCryptoStream - ) where + -- * Types + Stream, + streamId, + streamConnection, + newStream, + TxStreamData (..), + StreamState (..), + RecvStreamQ (..), + RxStreamData (..), + Length, + syncFinTx, + waitFinTx, + + -- * Misc + getTxStreamOffset, + isTxStreamClosed, + setTxStreamClosed, + getRxStreamOffset, + isRxStreamClosed, + setRxStreamClosed, + readStreamFlowTx, + addTxStreamData, + setTxMaxStreamData, + getRxMaxStreamData, + updateStreamFlowRx, + + -- * Reass + takeRecvStreamQwithSize, + putRxStreamData, + FlowCntl (..), + tryReassemble, + + -- * Table + StreamTable, + emptyStreamTable, + lookupStream, + insertStream, + deleteStream, + insertCryptoStreams, + deleteCryptoStream, + lookupCryptoStream, +) where import Network.QUIC.Stream.Misc import Network.QUIC.Stream.Reass diff --git a/Network/QUIC/Stream/Frag.hs b/Network/QUIC/Stream/Frag.hs --- a/Network/QUIC/Stream/Frag.hs +++ b/Network/QUIC/Stream/Frag.hs @@ -1,33 +1,41 @@ module Network.QUIC.Stream.Frag where -import Data.Sequence (Seq, viewl, viewr, ViewL(..), ViewR(..), (<|), dropWhileL) +import Data.Sequence ( + Seq, + ViewL (..), + ViewR (..), + dropWhileL, + viewl, + viewr, + (<|), + ) class Frag a where currOff :: a -> Int nextOff :: a -> Int - shrink :: Int -> a -> a + shrink :: Int -> a -> a instance Frag a => Frag (Seq a) where currOff s = case viewl s of - EmptyL -> error "Seq is empty (1)" - x :< _ -> currOff x + EmptyL -> error "Seq is empty (1)" + x :< _ -> currOff x nextOff s = case viewr s of - EmptyR -> error "Seq is empty (2)" - _ :> x -> nextOff x + EmptyR -> error "Seq is empty (2)" + _ :> x -> nextOff x shrink = shrinkSeq shrinkSeq :: Frag a => Int -> Seq a -> Seq a shrinkSeq n s0 = case viewl s of - EmptyL -> error "shrinkSeq" - x :< xs - | nextOff x == n -> xs - | otherwise -> shrink n x <| xs + EmptyL -> error "shrinkSeq" + x :< xs + | nextOff x == n -> xs + | otherwise -> shrink n x <| xs where s = dropWhileL (\y -> not (currOff y <= n && n <= nextOff y)) s0 -data F = F Int Int deriving Show +data F = F Int Int deriving (Show) instance Frag F where - currOff (F s _) = s - nextOff (F _ e) = e - shrink n (F s e) = if s <= n && n <= e then F n e else error "shrink" + currOff (F s _) = s + nextOff (F _ e) = e + shrink n (F s e) = if s <= n && n <= e then F n e else error "shrink" diff --git a/Network/QUIC/Stream/Misc.hs b/Network/QUIC/Stream/Misc.hs --- a/Network/QUIC/Stream/Misc.hs +++ b/Network/QUIC/Stream/Misc.hs @@ -2,24 +2,23 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Stream.Misc ( - getTxStreamOffset - , isTxStreamClosed - , setTxStreamClosed - , getRxStreamOffset - , isRxStreamClosed - , setRxStreamClosed - -- - , readStreamFlowTx - , addTxStreamData - , setTxMaxStreamData - , readStreamFlowRx - , addRxStreamData - , setRxMaxStreamData - , addRxMaxStreamData - , getRxMaxStreamData - , getRxStreamWindow - ) where + getTxStreamOffset, + isTxStreamClosed, + setTxStreamClosed, + getRxStreamOffset, + isRxStreamClosed, + setRxStreamClosed, + -- + readStreamFlowTx, + addTxStreamData, + setTxMaxStreamData, + -- + getRxMaxStreamData, + addRxStreamData, + updateStreamFlowRx, +) where +import Network.Control import UnliftIO.STM import Network.QUIC.Imports @@ -66,7 +65,7 @@ ---------------------------------------------------------------- -readStreamFlowTx :: Stream -> STM Flow +readStreamFlowTx :: Stream -> STM TxFlow readStreamFlowTx Stream{..} = readTVar streamFlowTx ---------------------------------------------------------------- @@ -74,38 +73,31 @@ addTxStreamData :: Stream -> Int -> STM () addTxStreamData Stream{..} n = modifyTVar' streamFlowTx add where - add flow = flow { flowData = flowData flow + n } + add flow = flow{txfSent = txfSent flow + n} setTxMaxStreamData :: Stream -> Int -> IO () setTxMaxStreamData Stream{..} n = atomically $ modifyTVar' streamFlowTx set where set flow - | flowMaxData flow < n = flow { flowMaxData = n } - | otherwise = flow + | txfLimit flow < n = flow{txfLimit = n} + | otherwise = flow ---------------------------------------------------------------- +getRxMaxStreamData :: Stream -> IO Int +getRxMaxStreamData Stream{..} = rxfLimit <$> readIORef streamFlowRx + addRxStreamData :: Stream -> Int -> IO () addRxStreamData Stream{..} n = atomicModifyIORef'' streamFlowRx add where - add flow = flow { flowData = flowData flow + n } - -setRxMaxStreamData :: Stream -> Int -> IO () -setRxMaxStreamData Stream{..} n = atomicModifyIORef'' streamFlowRx - $ \flow -> flow { flowMaxData = n } - -addRxMaxStreamData :: Stream -> Int -> IO Int -addRxMaxStreamData Stream{..} n = atomicModifyIORef' streamFlowRx add - where - add flow = (flow { flowMaxData = m }, m) - where - m = flowMaxData flow + n - -getRxMaxStreamData :: Stream -> IO Int -getRxMaxStreamData Stream{..} = flowMaxData <$> readIORef streamFlowRx + add flow = flow{rxfReceived = rxfReceived flow + n} -getRxStreamWindow :: Stream -> IO Int -getRxStreamWindow Stream{..} = flowWindow <$> readIORef streamFlowRx +updateStreamFlowRx :: Stream -> Int -> IO (Maybe Int) +updateStreamFlowRx Stream{..} consumed = + atomicModifyIORef' streamFlowRx $ maybeOpenRxWindow consumed FCTMaxData -readStreamFlowRx :: Stream -> IO Flow -readStreamFlowRx Stream{..} = readIORef streamFlowRx +{- cannot be used due to reassemble. +checkRxMaxStreamData :: Stream -> Int -> IO Bool +checkRxMaxStreamData Stream{..} len = + atomicModifyIORef' streamFlowRx $ checkRxLimit len +-} diff --git a/Network/QUIC/Stream/Reass.hs b/Network/QUIC/Stream/Reass.hs --- a/Network/QUIC/Stream/Reass.hs +++ b/Network/QUIC/Stream/Reass.hs @@ -2,17 +2,18 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Stream.Reass ( - takeRecvStreamQwithSize - , putRxStreamData - , FlowCntl(..) - , tryReassemble - ) where + takeRecvStreamQwithSize, + putRxStreamData, + FlowCntl (..), + tryReassemble, +) where +import qualified Data.ByteString as BS import Data.Sequence (Seq) import qualified Data.Sequence as Seq -import qualified Data.ByteString as BS import Network.QUIC.Imports + -- import Network.QUIC.Logger import Network.QUIC.Stream.Frag import Network.QUIC.Stream.Misc @@ -43,47 +44,49 @@ takeRecvStreamQwithSize :: Stream -> Int -> IO ByteString takeRecvStreamQwithSize strm siz0 = do eos <- getEndOfStream strm - if eos then - return "" - else do - mb <- readPendingData strm - case mb of - Nothing -> do - b0 <- takeRecvStreamQ strm - if b0 == "" then do - setEndOfStream strm - return "" - else do - let len = BS.length b0 - case len `compare` siz0 of - LT -> tryRead (siz0 - len) (b0 :) - EQ -> return b0 - GT -> do - let (b1,b2) = BS.splitAt siz0 b0 - writePendingData strm b2 - return b1 - Just b0 -> do - clearPendingData strm - let len = BS.length b0 - tryRead (siz0 - len) (b0 :) + if eos + then return "" + else do + mb <- readPendingData strm + case mb of + Nothing -> do + b0 <- takeRecvStreamQ strm + if b0 == "" + then do + setEndOfStream strm + return "" + else do + let len = BS.length b0 + case len `compare` siz0 of + LT -> tryRead (siz0 - len) (b0 :) + EQ -> return b0 + GT -> do + let (b1, b2) = BS.splitAt siz0 b0 + writePendingData strm b2 + return b1 + Just b0 -> do + clearPendingData strm + let len = BS.length b0 + tryRead (siz0 - len) (b0 :) where tryRead siz build = do mb <- tryTakeRecvStreamQ strm case mb of - Nothing -> return $ BS.concat $ build [] - Just b -> do - if b == "" then do - setEndOfStream strm - return $ BS.concat $ build [] - else do - let len = BS.length b - case len `compare` siz of - LT -> tryRead (siz - len) (build . (b :)) - EQ -> return $ BS.concat $ build [b] - GT -> do - let (b1,b2) = BS.splitAt siz b - writePendingData strm b2 - return $ BS.concat $ build [b1] + Nothing -> return $ BS.concat $ build [] + Just b -> do + if b == "" + then do + setEndOfStream strm + return $ BS.concat $ build [] + else do + let len = BS.length b + case len `compare` siz of + LT -> tryRead (siz - len) (build . (b :)) + EQ -> return $ BS.concat $ build [b] + GT -> do + let (b1, b2) = BS.splitAt siz b + writePendingData strm b2 + return $ BS.concat $ build [b1] ---------------------------------------------------------------- ---------------------------------------------------------------- @@ -93,80 +96,87 @@ putRxStreamData :: Stream -> RxStreamData -> IO FlowCntl putRxStreamData s rx@(RxStreamData _ off len _) = do lim <- getRxMaxStreamData s - if len + off > lim then - return OverLimit - else do - dup <- tryReassemble s rx put putFin - return $ if dup then Duplicated else Reassembled + if len + off > lim + then return OverLimit + else do + dup <- tryReassemble s rx put putFin + if dup + then return Duplicated + else return Reassembled where put "" = return () - put d = putRecvStreamQ s d + put d = do + addRxStreamData s $ BS.length d + putRecvStreamQ s d putFin = putRecvStreamQ s "" -- fin of StreamState off fin means see-fin-already. -- return value indicates duplication -tryReassemble :: Stream -> RxStreamData -> (StreamData -> IO ()) -> IO () -> IO Bool -tryReassemble Stream{} (RxStreamData "" _ _ False) _ _ = return True +tryReassemble + :: Stream -> RxStreamData -> (StreamData -> IO ()) -> IO () -> IO Bool +tryReassemble Stream{} (RxStreamData "" _ _ False) _ _ = return True tryReassemble Stream{..} x@(RxStreamData "" off _ True) _ putFin = do si0@(StreamState off0 fin0) <- readIORef streamStateRx - let si1 = si0 { streamFin = True } - if fin0 then do - -- stdoutLogger "Illegal Fin" -- fixme - return True - else case off `compare` off0 of + let si1 = si0{streamFin = True} + if fin0 + then do + -- stdoutLogger "Illegal Fin" -- fixme + return True + else case off `compare` off0 of + LT -> return True + EQ -> do + writeIORef streamStateRx si1 + putFin + return False + GT -> do + writeIORef streamStateRx si1 + atomicModifyIORef'' streamReass (Skew.insert x) + return False +tryReassemble Stream{..} x@(RxStreamData dat off len False) put putFin = do + si0@(StreamState off0 _) <- readIORef streamStateRx + case off `compare` off0 of LT -> return True EQ -> do - writeIORef streamStateRx si1 - putFin + put dat + loop si0 (off0 + len) return False GT -> do - writeIORef streamStateRx si1 atomicModifyIORef'' streamReass (Skew.insert x) return False -tryReassemble Stream{..} x@(RxStreamData dat off len False) put putFin = do - si0@(StreamState off0 _) <- readIORef streamStateRx - case off `compare` off0 of - LT -> return True - EQ -> do - put dat - loop si0 (off0 + len) - return False - GT -> do - atomicModifyIORef'' streamReass (Skew.insert x) - return False where loop si0 xff = do mrxs <- atomicModifyIORef' streamReass (Skew.deleteMinIf xff) case mrxs of - Nothing -> writeIORef streamStateRx si0 { streamOffset = xff } - Just rxs -> do - mapM_ (put . rxstrmData) rxs - let xff1 = nextOff rxs - if hasFin rxs then do - putFin - else do - loop si0 xff1 - + Nothing -> writeIORef streamStateRx si0{streamOffset = xff} + Just rxs -> do + mapM_ (put . rxstrmData) rxs + let xff1 = nextOff rxs + if hasFin rxs + then do + putFin + else do + loop si0 xff1 tryReassemble Stream{..} x@(RxStreamData dat off len True) put putFin = do si0@(StreamState off0 fin0) <- readIORef streamStateRx - let si1 = si0 { streamFin = True } - if fin0 then do - -- stdoutLogger "Illegal Fin" -- fixme - return True - else case off `compare` off0 of - LT -> return True - EQ -> do - let off1 = off0 + len - writeIORef streamStateRx si1 { streamOffset = off1 } - put dat - putFin - return False - GT -> do - writeIORef streamStateRx si1 - atomicModifyIORef'' streamReass (Skew.insert x) - return False + let si1 = si0{streamFin = True} + if fin0 + then do + -- stdoutLogger "Illegal Fin" -- fixme + return True + else case off `compare` off0 of + LT -> return True + EQ -> do + let off1 = off0 + len + writeIORef streamStateRx si1{streamOffset = off1} + put dat + putFin + return False + GT -> do + writeIORef streamStateRx si1 + atomicModifyIORef'' streamReass (Skew.insert x) + return False hasFin :: Seq RxStreamData -> Bool hasFin s = case Seq.viewr s of - Seq.EmptyR -> False - _ Seq.:> x -> rxstrmFin x + Seq.EmptyR -> False + _ Seq.:> x -> rxstrmFin x diff --git a/Network/QUIC/Stream/Skew.hs b/Network/QUIC/Stream/Skew.hs --- a/Network/QUIC/Stream/Skew.hs +++ b/Network/QUIC/Stream/Skew.hs @@ -1,12 +1,12 @@ module Network.QUIC.Stream.Skew ( - Skew(..) - , empty - , insert - , deleteMin - , deleteMinIf --- , deleteMin' --- , showSkew - ) where + Skew (..), + empty, + insert, + deleteMin, + deleteMinIf, + -- , deleteMin' + -- , showSkew +) where import Data.Maybe import Data.Sequence (Seq, (><)) @@ -17,7 +17,7 @@ ---------------------------------------------------------------- -data Skew a = Leaf | Node (Skew a) (Seq a) (Skew a) deriving Show +data Skew a = Leaf | Node (Skew a) (Seq a) (Skew a) deriving (Show) empty :: Skew a empty = Leaf @@ -32,14 +32,14 @@ -- | Finding the minimum element. Worst-case: O(1). minimum :: Skew a -> Maybe (Seq a) -minimum Leaf = Nothing +minimum Leaf = Nothing minimum (Node _ f _) = Just f ---------------------------------------------------------------- -- | Deleting the minimum element. Worst-case: O(N), amortized: O(log N). deleteMin' :: Frag a => Skew a -> Skew a -deleteMin' Leaf = Leaf +deleteMin' Leaf = Leaf deleteMin' (Node l _ r) = merge l r deleteMin :: Frag a => Skew a -> (Skew a, Maybe (Seq a)) @@ -47,11 +47,11 @@ deleteMinIf :: Frag a => Int -> Skew a -> (Skew a, Maybe (Seq a)) deleteMinIf off h = case minimum h of - jf@(Just f) - | currOff f == off -> (deleteMin' h, jf) - | currOff f < off && off < nextOff f -> (deleteMin' h, shrink off <$> jf) - | nextOff f <= off -> (deleteMin' h, Nothing) - _ -> (h, Nothing) + jf@(Just f) + | currOff f == off -> (deleteMin' h, jf) + | currOff f < off && off < nextOff f -> (deleteMin' h, shrink off <$> jf) + | nextOff f <= off -> (deleteMin' h, Nothing) + _ -> (h, Nothing) ---------------------------------------------------------------- @@ -60,15 +60,17 @@ merge t1 Leaf = t1 merge Leaf t2 = t2 merge t1@(Node l1 f1 r1) t2@(Node l2 f2 r2) - | e1 < s2 = Node r1 f1 (merge l1 t2) - | e2 < s1 = Node r2 f2 (merge l2 t1) - | otherwise = let f12 | e1 == s2 = f1 >< f2 - | s1 == e2 = f2 >< f1 - | s1 <= s2 && e2 <= e1 = f1 - | s2 <= s1 && e1 <= e2 = f2 - | s1 <= s2 = f1 >< shrink e1 f2 - | otherwise = f2 >< shrink e2 f1 - in Node (merge l1 l2) f12 (merge r1 r2) + | e1 < s2 = Node r1 f1 (merge l1 t2) + | e2 < s1 = Node r2 f2 (merge l2 t1) + | otherwise = + let f12 + | e1 == s2 = f1 >< f2 + | s1 == e2 = f2 >< f1 + | s1 <= s2 && e2 <= e1 = f1 + | s2 <= s1 && e1 <= e2 = f2 + | s1 <= s2 = f1 >< shrink e1 f2 + | otherwise = f2 >< shrink e2 f1 + in Node (merge l1 l2) f12 (merge r1 r2) where s1 = currOff f1 e1 = nextOff f1 diff --git a/Network/QUIC/Stream/Table.hs b/Network/QUIC/Stream/Table.hs --- a/Network/QUIC/Stream/Table.hs +++ b/Network/QUIC/Stream/Table.hs @@ -1,20 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} module Network.QUIC.Stream.Table ( - StreamTable - , emptyStreamTable - , lookupStream - , insertStream - , deleteStream - , insertCryptoStreams - , deleteCryptoStream - , lookupCryptoStream - ) where + StreamTable, + emptyStreamTable, + lookupStream, + insertStream, + deleteStream, + insertCryptoStreams, + deleteCryptoStream, + lookupCryptoStream, +) where import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as Map -import {-# Source #-} Network.QUIC.Connection.Types +import {-# SOURCE #-} Network.QUIC.Connection.Types import Network.QUIC.Stream.Types import Network.QUIC.Types @@ -38,34 +38,35 @@ ---------------------------------------------------------------- -initialCryptoStreamId,handshakeCryptoStreamId,rtt1CryptoStreamId :: StreamId -initialCryptoStreamId = -1 +initialCryptoStreamId, handshakeCryptoStreamId, rtt1CryptoStreamId :: StreamId +initialCryptoStreamId = -1 handshakeCryptoStreamId = -2 -rtt1CryptoStreamId = -3 +rtt1CryptoStreamId = -3 toCryptoStreamId :: EncryptionLevel -> StreamId -toCryptoStreamId InitialLevel = initialCryptoStreamId +toCryptoStreamId InitialLevel = initialCryptoStreamId -- This is to generate an error packet of CRYPTO in 0-RTT -toCryptoStreamId RTT0Level = rtt1CryptoStreamId +toCryptoStreamId RTT0Level = rtt1CryptoStreamId toCryptoStreamId HandshakeLevel = handshakeCryptoStreamId -toCryptoStreamId RTT1Level = rtt1CryptoStreamId +toCryptoStreamId RTT1Level = rtt1CryptoStreamId ---------------------------------------------------------------- insertCryptoStreams :: Connection -> StreamTable -> IO StreamTable insertCryptoStreams conn stbl = do - strm1 <- newStream conn initialCryptoStreamId - strm2 <- newStream conn handshakeCryptoStreamId - strm3 <- newStream conn rtt1CryptoStreamId - return $ insertStream initialCryptoStreamId strm1 - $ insertStream handshakeCryptoStreamId strm2 - $ insertStream rtt1CryptoStreamId strm3 stbl + strm1 <- newStream conn initialCryptoStreamId 0 0 + strm2 <- newStream conn handshakeCryptoStreamId 0 0 + strm3 <- newStream conn rtt1CryptoStreamId 0 0 + return $ + insertStream initialCryptoStreamId strm1 $ + insertStream handshakeCryptoStreamId strm2 $ + insertStream rtt1CryptoStreamId strm3 stbl deleteCryptoStream :: EncryptionLevel -> StreamTable -> StreamTable -deleteCryptoStream InitialLevel = deleteStream initialCryptoStreamId -deleteCryptoStream RTT0Level = deleteStream rtt1CryptoStreamId +deleteCryptoStream InitialLevel = deleteStream initialCryptoStreamId +deleteCryptoStream RTT0Level = deleteStream rtt1CryptoStreamId deleteCryptoStream HandshakeLevel = deleteStream handshakeCryptoStreamId -deleteCryptoStream RTT1Level = deleteStream rtt1CryptoStreamId +deleteCryptoStream RTT1Level = deleteStream rtt1CryptoStreamId ---------------------------------------------------------------- diff --git a/Network/QUIC/Stream/Types.hs b/Network/QUIC/Stream/Types.hs --- a/Network/QUIC/Stream/Types.hs +++ b/Network/QUIC/Stream/Types.hs @@ -1,25 +1,23 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.Stream.Types ( - Stream(..) - , newStream - , TxStreamData(..) - , Flow(..) - , defaultFlow - , flowWindow - , StreamState(..) - , RecvStreamQ(..) - , RxStreamData(..) - , Length - , syncFinTx - , waitFinTx - ) where + Stream (..), + newStream, + TxStreamData (..), + StreamState (..), + RecvStreamQ (..), + RxStreamData (..), + Length, + syncFinTx, + waitFinTx, +) where import qualified Data.ByteString as BS +import Network.Control import UnliftIO.Concurrent import UnliftIO.STM -import {-# Source #-} Network.QUIC.Connection.Types +import {-# SOURCE #-} Network.QUIC.Connection.Types import Network.QUIC.Imports import Network.QUIC.Stream.Frag import Network.QUIC.Stream.Skew @@ -29,31 +27,34 @@ ---------------------------------------------------------------- -- | An abstract data type for streams. -data Stream = Stream { - streamId :: StreamId -- ^ Getting stream identifier. - , streamConnection :: Connection - -- "counter" is equivalent to "offset". - -- It is duplicated but used for API level flow control. - , streamFlowTx :: TVar Flow -- counter, maxDax - , streamFlowRx :: IORef Flow -- counter, maxDax - , streamStateTx :: IORef StreamState -- offset, fin - , streamStateRx :: IORef StreamState -- offset, fin - , streamRecvQ :: RecvStreamQ -- input bytestring - , streamReass :: IORef (Skew RxStreamData) -- input stream fragments to streamQ - , streamSyncFinTx :: MVar () - } +data Stream = Stream + { streamId :: StreamId + -- ^ Getting stream identifier. + , streamConnection :: Connection + , -- "counter" is equivalent to "offset". + -- It is duplicated but used for API level flow control. + streamFlowTx :: TVar TxFlow -- counter, maxDax + , streamFlowRx :: IORef RxFlow -- counter, maxDax + , streamStateTx :: IORef StreamState -- offset, fin + , streamStateRx :: IORef StreamState -- offset, fin + , streamRecvQ :: RecvStreamQ -- input bytestring + , streamReass :: IORef (Skew RxStreamData) -- input stream fragments to streamQ + , streamSyncFinTx :: MVar () + } instance Show Stream where show s = show $ streamId s -newStream :: Connection -> StreamId -> IO Stream -newStream conn sid = Stream sid conn <$> newTVarIO defaultFlow - <*> newIORef defaultFlow - <*> newIORef emptyStreamState - <*> newIORef emptyStreamState - <*> newRecvStreamQ - <*> newIORef Skew.empty - <*> newEmptyMVar +newStream :: Connection -> Int -> Int -> StreamId -> IO Stream +newStream conn sid txLim rxLim = + Stream sid conn + <$> newTVarIO (newTxFlow txLim) + <*> newIORef (newRxFlow rxLim) + <*> newIORef emptyStreamState + <*> newIORef emptyStreamState + <*> newRecvStreamQ + <*> newIORef Skew.empty + <*> newEmptyMVar syncFinTx :: Stream -> IO () syncFinTx s = void $ tryPutMVar (streamSyncFinTx s) () @@ -67,52 +68,41 @@ data TxStreamData = TxStreamData Stream [StreamData] Length Fin -data RxStreamData = RxStreamData { - rxstrmData :: StreamData - , rxstrmOff :: Offset - , rxstrmLen :: Length - , rxstrmFin :: Fin - } deriving (Eq, Show) +data RxStreamData = RxStreamData + { rxstrmData :: StreamData + , rxstrmOff :: Offset + , rxstrmLen :: Length + , rxstrmFin :: Fin + } + deriving (Eq, Show) instance Frag RxStreamData where currOff r = rxstrmOff r nextOff r = rxstrmOff r + rxstrmLen r - shrink off' (RxStreamData bs off len fin) = + shrink off' (RxStreamData bs off len fin) = let n = off' - off - bs' = BS.drop n bs + bs' = BS.drop n bs len' = len - n - in RxStreamData bs' off' len' fin - ----------------------------------------------------------------- - -data Flow = Flow { - flowData :: Int - , flowMaxData :: Int - } deriving (Eq, Show) - -defaultFlow :: Flow -defaultFlow = Flow 0 0 - -flowWindow :: Flow -> Int -flowWindow Flow{..} = flowMaxData - flowData + in RxStreamData bs' off' len' fin ---------------------------------------------------------------- -data StreamState = StreamState { - streamOffset :: Offset - , streamFin :: Fin - } deriving (Eq, Show) +data StreamState = StreamState + { streamOffset :: Offset + , streamFin :: Fin + } + deriving (Eq, Show) emptyStreamState :: StreamState emptyStreamState = StreamState 0 False ---------------------------------------------------------------- -data RecvStreamQ = RecvStreamQ { - recvStreamQ :: TQueue ByteString - , pendingData :: IORef (Maybe ByteString) - , endOfStream :: IORef Bool - } +data RecvStreamQ = RecvStreamQ + { recvStreamQ :: TQueue ByteString + , pendingData :: IORef (Maybe ByteString) + , endOfStream :: IORef Bool + } newRecvStreamQ :: IO RecvStreamQ newRecvStreamQ = RecvStreamQ <$> newTQueueIO <*> newIORef Nothing <*> newIORef False diff --git a/Network/QUIC/TLS.hs b/Network/QUIC/TLS.hs --- a/Network/QUIC/TLS.hs +++ b/Network/QUIC/TLS.hs @@ -2,9 +2,9 @@ {-# LANGUAGE RecordWildCards #-} module Network.QUIC.TLS ( - clientHandshaker - , serverHandshaker - ) where + clientHandshaker, + serverHandshaker, +) where import Data.Default.Class import Network.TLS hiding (Version) @@ -16,52 +16,59 @@ import Network.QUIC.Types sessionManager :: SessionEstablish -> SessionManager -sessionManager establish = SessionManager { - sessionEstablish = establish - , sessionResume = \_ -> return Nothing - , sessionResumeOnlyOnce = \_ -> return Nothing - , sessionInvalidate = \_ -> return () - } +sessionManager establish = + SessionManager + { sessionEstablish = establish + , sessionResume = \_ -> return Nothing + , sessionResumeOnlyOnce = \_ -> return Nothing + , sessionInvalidate = \_ -> return () + } -clientHandshaker :: QUICCallbacks - -> ClientConfig - -> Version - -> AuthCIDs - -> SessionEstablish - -> Bool - -> IO () +clientHandshaker + :: QUICCallbacks + -> ClientConfig + -> Version + -> AuthCIDs + -> SessionEstablish + -> Bool + -> IO () clientHandshaker callbacks ClientConfig{..} ver myAuthCIDs establish use0RTT = do caStore <- if ccValidate then getSystemCertificateStore else return mempty tlsQUICClient (cparams caStore) callbacks where - cparams caStore = (defaultParamsClient ccServerName "") { - clientShared = cshared caStore - , clientHooks = hook - , clientSupported = supported - , clientDebug = debug - , clientWantSessionResume = resumptionSession ccResumption - , clientEarlyData = if use0RTT then Just "" else Nothing - } + cparams caStore = + (defaultParamsClient ccServerName "") + { clientShared = cshared caStore + , clientHooks = hook + , clientSupported = supported + , clientDebug = debug + , clientWantSessionResume = resumptionSession ccResumption + , clientEarlyData = if use0RTT then Just "" else Nothing + } convTP = onTransportParametersCreated ccHooks params = convTP $ setCIDsToParameters myAuthCIDs ccParameters convExt = onTLSExtensionCreated ccHooks skipValidation = ValidationCache (\_ _ _ -> return ValidationCachePass) (\_ _ _ -> return ()) - cshared caStore = def { - sharedValidationCache = if ccValidate then def else skipValidation - , sharedCAStore = caStore - , sharedHelloExtensions = convExt $ parametersToExtensionRaw ver params - , sharedSessionManager = sessionManager establish - } - hook = def { - onSuggestALPN = ccALPN ver - } - supported = defaultSupported { - supportedCiphers = ccCiphers - , supportedGroups = ccGroups - } - debug = def { - debugKeyLogger = ccKeyLog - } + cshared caStore = + def + { sharedValidationCache = if ccValidate then def else skipValidation + , sharedCAStore = caStore + , sharedHelloExtensions = convExt $ parametersToExtensionRaw ver params + , sharedSessionManager = sessionManager establish + } + hook = + def + { onSuggestALPN = ccALPN ver + } + supported = + defaultSupported + { supportedCiphers = ccCiphers + , supportedGroups = ccGroups + } + debug = + def + { debugKeyLogger = ccKeyLog + } parametersToExtensionRaw :: Version -> Parameters -> [ExtensionRaw] parametersToExtensionRaw ver params = [ExtensionRaw tpId eParams] @@ -69,41 +76,47 @@ tpId = extensionIDForTtransportParameter ver eParams = encodeParameters params -serverHandshaker :: QUICCallbacks - -> ServerConfig - -> Version - -> IO Parameters - -> IO () +serverHandshaker + :: QUICCallbacks + -> ServerConfig + -> Version + -> IO Parameters + -> IO () serverHandshaker callbacks ServerConfig{..} ver getParams = tlsQUICServer sparams callbacks where - sparams = def { - serverShared = sshared - , serverHooks = hook - , serverSupported = supported - , serverDebug = debug - , serverEarlyDataSize = if scUse0RTT then quicMaxEarlyDataSize else 0 - } + sparams = + def + { serverShared = sshared + , serverHooks = hook + , serverSupported = supported + , serverDebug = debug + , serverEarlyDataSize = if scUse0RTT then quicMaxEarlyDataSize else 0 + } convTP = onTransportParametersCreated scHooks convExt = onTLSExtensionCreated scHooks - sshared = def { - sharedCredentials = scCredentials - , sharedSessionManager = scSessionManager - } - hook = def { - onALPNClientSuggest = case scALPN of - Nothing -> Nothing - Just io -> Just $ io ver - , onEncryptedExtensionsCreating = \exts0 -> do - params <- getParams - let exts = convExt $ parametersToExtensionRaw ver $ convTP params - return $ exts ++ exts0 - } - supported = def { - supportedVersions = [TLS13] - , supportedCiphers = scCiphers - , supportedGroups = scGroups - } - debug = def { - debugKeyLogger = scKeyLog - } + sshared = + def + { sharedCredentials = scCredentials + , sharedSessionManager = scSessionManager + } + hook = + def + { onALPNClientSuggest = case scALPN of + Nothing -> Nothing + Just io -> Just $ io ver + , onEncryptedExtensionsCreating = \exts0 -> do + params <- getParams + let exts = convExt $ parametersToExtensionRaw ver $ convTP params + return $ exts ++ exts0 + } + supported = + def + { supportedVersions = [TLS13] + , supportedCiphers = scCiphers + , supportedGroups = scGroups + } + debug = + def + { debugKeyLogger = scKeyLog + } diff --git a/Network/QUIC/Types.hs b/Network/QUIC/Types.hs --- a/Network/QUIC/Types.hs +++ b/Network/QUIC/Types.hs @@ -1,20 +1,20 @@ module Network.QUIC.Types ( - Bytes - , Close - , Direction(..) - , SizedBuffer(..) - , module Network.QUIC.Types.Ack - , module Network.QUIC.Types.CID - , module Network.QUIC.Types.Constants - , module Network.QUIC.Types.Error - , module Network.QUIC.Types.Exception - , module Network.QUIC.Types.Frame - , module Network.QUIC.Types.Integer - , module Network.QUIC.Types.Packet - , module Network.QUIC.Types.Queue - , module Network.QUIC.Types.Resumption - , module Network.QUIC.Types.Time - ) where + Bytes, + Close, + Direction (..), + SizedBuffer (..), + module Network.QUIC.Types.Ack, + module Network.QUIC.Types.CID, + module Network.QUIC.Types.Constants, + module Network.QUIC.Types.Error, + module Network.QUIC.Types.Exception, + module Network.QUIC.Types.Frame, + module Network.QUIC.Types.Integer, + module Network.QUIC.Types.Packet, + module Network.QUIC.Types.Queue, + module Network.QUIC.Types.Resumption, + module Network.QUIC.Types.Time, +) where import Network.QUIC.Imports import Network.QUIC.Types.Ack diff --git a/Network/QUIC/Types/Ack.hs b/Network/QUIC/Types/Ack.hs --- a/Network/QUIC/Types/Ack.hs +++ b/Network/QUIC/Types/Ack.hs @@ -6,10 +6,10 @@ type PacketNumber = Int type Range = Int -type Gap = Int +type Gap = Int -data AckInfo = AckInfo PacketNumber Range [(Gap,Range)] - deriving (Eq, Show) +data AckInfo = AckInfo PacketNumber Range [(Gap, Range)] + deriving (Eq, Show) ackInfo0 :: AckInfo ackInfo0 = AckInfo (-1) 0 [] @@ -24,18 +24,18 @@ -- >>> toAckInfo [9,8,7,5,4] -- AckInfo 9 2 [(0,1)] toAckInfo :: [PacketNumber] -> AckInfo -toAckInfo [] = error "toAckInfo" +toAckInfo [] = error "toAckInfo" toAckInfo [l] = AckInfo l 0 [] -toAckInfo (l:ls) = ack l ls 0 +toAckInfo (l : ls) = ack l ls 0 where - ack _ [] fr = AckInfo l fr [] - ack p (x:xs) fr - | p - 1 == x = ack x xs (fr+1) - | otherwise = AckInfo l fr $ ranges x xs (fromIntegral (p - x) - 2) 0 + ack _ [] fr = AckInfo l fr [] + ack p (x : xs) fr + | p - 1 == x = ack x xs (fr + 1) + | otherwise = AckInfo l fr $ ranges x xs (fromIntegral (p - x) - 2) 0 ranges _ [] g r = [(g, r)] - ranges p (x:xs) g r - | p - 1 == x = ranges x xs g (r+1) - | otherwise = (g, r) : ranges x xs (fromIntegral (p - x) - 2) 0 + ranges p (x : xs) g r + | p - 1 == x = ranges x xs g (r + 1) + | otherwise = (g, r) : ranges x xs (fromIntegral (p - x) - 2) 0 -- | -- >>> fromAckInfo $ AckInfo 9 0 [] @@ -50,9 +50,9 @@ fromAckInfo (AckInfo lpn fr grs) = loop grs [stt .. lpn] where stt = lpn - fromIntegral fr - loop _ [] = error "loop" - loop [] acc = acc - loop ((g,r):xs) acc@(s:_) = loop xs ([z - fromIntegral r .. z] ++ acc) + loop _ [] = error "loop" + loop [] acc = acc + loop ((g, r) : xs) acc@(s : _) = loop xs ([z - fromIntegral r .. z] ++ acc) where z = s - fromIntegral g - 2 @@ -67,36 +67,35 @@ -- [8,9] fromAckInfoWithMin :: AckInfo -> PacketNumber -> [PacketNumber] fromAckInfoWithMin (AckInfo lpn fr grs) lim - | stt < lim = [lim .. lpn] - | otherwise = loop grs [stt .. lpn] + | stt < lim = [lim .. lpn] + | otherwise = loop grs [stt .. lpn] where stt = lpn - fromIntegral fr - loop _ [] = error "loop" - loop [] acc = acc - loop ((g,r):xs) acc@(s:_) - | z < lim = acc - |otherwise = loop xs ([r' .. z] ++ acc) + loop _ [] = error "loop" + loop [] acc = acc + loop ((g, r) : xs) acc@(s : _) + | z < lim = acc + | otherwise = loop xs ([r' .. z] ++ acc) where z = s - fromIntegral g - 2 r' = max lim (z - fromIntegral r) fromAckInfoToPred :: AckInfo -> (PacketNumber -> Bool) fromAckInfoToPred (AckInfo lpn fr grs) = - \x -> any (f x) $ loop grs [(stt,lpn)] + \x -> any (f x) $ loop grs [(stt, lpn)] where - f x (l,u) = l <= x && x <= u + f x (l, u) = l <= x && x <= u stt = lpn - fromIntegral fr - loop _ [] = error "loop" - loop [] acc = acc - loop ((g,r):xs) acc@((s,_):_) = loop xs $ (z - fromIntegral r, z) : acc + loop _ [] = error "loop" + loop [] acc = acc + loop ((g, r) : xs) acc@((s, _) : _) = loop xs $ (z - fromIntegral r, z) : acc where z = s - fromIntegral g - 2 ---------------------------------------------------------------- newtype PeerPacketNumbers = PeerPacketNumbers IntSet - deriving (Eq, Show) + deriving (Eq, Show) emptyPeerPacketNumbers :: PeerPacketNumbers emptyPeerPacketNumbers = PeerPacketNumbers IntSet.empty - diff --git a/Network/QUIC/Types/CID.hs b/Network/QUIC/Types/CID.hs --- a/Network/QUIC/Types/CID.hs +++ b/Network/QUIC/Types/CID.hs @@ -1,17 +1,17 @@ module Network.QUIC.Types.CID ( - CID(..) - , myCIDLength - , newCID - , fromCID - , toCID - , makeCID - , unpackCID - , StatelessResetToken(..) - , newStatelessResetToken - , PathData(..) - , newPathData - , CIDInfo(..) - ) where + CID (..), + myCIDLength, + newCID, + fromCID, + toCID, + makeCID, + unpackCID, + StatelessResetToken (..), + newStatelessResetToken, + PathData (..), + newPathData, + CIDInfo (..), +) where import qualified Data.ByteString.Short as Short @@ -45,19 +45,20 @@ len = fromIntegral $ Short.length sbs -- 16 bytes -newtype StatelessResetToken = StatelessResetToken Bytes deriving (Eq,Ord,Show) +newtype StatelessResetToken = StatelessResetToken Bytes deriving (Eq, Ord, Show) newStatelessResetToken :: IO StatelessResetToken newStatelessResetToken = StatelessResetToken <$> getRandomBytes 16 -- 8 bytes -newtype PathData = PathData Bytes deriving (Eq,Show) +newtype PathData = PathData Bytes deriving (Eq, Show) newPathData :: IO PathData newPathData = PathData <$> getRandomBytes 8 -data CIDInfo = CIDInfo { - cidInfoSeq :: Int - , cidInfoCID :: CID - , cidInfoSRT :: StatelessResetToken - } deriving (Eq, Ord, Show) +data CIDInfo = CIDInfo + { cidInfoSeq :: Int + , cidInfoCID :: CID + , cidInfoSRT :: StatelessResetToken + } + deriving (Eq, Ord, Show) diff --git a/Network/QUIC/Types/Error.hs b/Network/QUIC/Types/Error.hs --- a/Network/QUIC/Types/Error.hs +++ b/Network/QUIC/Types/Error.hs @@ -9,6 +9,7 @@ -- | Transport errors of QUIC. newtype TransportError = TransportError Int deriving (Eq) +{- FOURMOLU_DISABLE -} pattern NoError :: TransportError pattern NoError = TransportError 0x0 @@ -87,6 +88,7 @@ Just e -> "TLS " ++ show e Nothing -> "TLS Alert " ++ show x | otherwise = "TransportError " ++ printf "%x" x +{- FOURMOLU_ENABLE -} -- | Converting a TLS alert to a corresponding transport error. cryptoError :: TLS.AlertDescription -> TransportError @@ -95,4 +97,5 @@ ec = 0x100 + fromIntegral (fromAlertDescription ad) -- | Application protocol errors of QUIC. -newtype ApplicationProtocolError = ApplicationProtocolError Int deriving (Eq, Show) +newtype ApplicationProtocolError = ApplicationProtocolError Int + deriving (Eq, Show) diff --git a/Network/QUIC/Types/Exception.hs b/Network/QUIC/Types/Exception.hs --- a/Network/QUIC/Types/Exception.hs +++ b/Network/QUIC/Types/Exception.hs @@ -9,30 +9,31 @@ import Network.QUIC.Types.Packet -- | User level exceptions for QUIC. -data QUICException = - ConnectionIsClosed -- NoError - | TransportErrorIsReceived TransportError ReasonPhrase - | TransportErrorIsSent TransportError ReasonPhrase - | ApplicationProtocolErrorIsReceived ApplicationProtocolError ReasonPhrase - | ApplicationProtocolErrorIsSent ApplicationProtocolError ReasonPhrase - | ConnectionIsTimeout String - | ConnectionIsReset - | StreamIsClosed - | HandshakeFailed TLS.AlertDescription -- failed in my side - | VersionIsUnknown Word32 - | NoVersionIsSpecified - | VersionNegotiationFailed - | BadThingHappen E.SomeException - deriving (Show) +data QUICException + = ConnectionIsClosed -- NoError + | TransportErrorIsReceived TransportError ReasonPhrase + | TransportErrorIsSent TransportError ReasonPhrase + | ApplicationProtocolErrorIsReceived ApplicationProtocolError ReasonPhrase + | ApplicationProtocolErrorIsSent ApplicationProtocolError ReasonPhrase + | ConnectionIsTimeout String + | ConnectionIsReset + | StreamIsClosed + | HandshakeFailed TLS.AlertDescription -- failed in my side + | VersionIsUnknown Word32 + | NoVersionIsSpecified + | VersionNegotiationFailed + | BadThingHappen E.SomeException + deriving (Show) instance E.Exception QUICException -data InternalControl = MustNotReached - | ExitConnection - | WrongTransportParameter - | WrongVersionInformation - | BreakForever - deriving (Eq, Show) +data InternalControl + = MustNotReached + | ExitConnection + | WrongTransportParameter + | WrongVersionInformation + | BreakForever + deriving (Eq, Show) instance E.Exception InternalControl @@ -40,10 +41,11 @@ instance E.Exception NextVersion -data Abort = Abort ApplicationProtocolError ReasonPhrase - | VerNego VersionInfo - deriving (Show) +data Abort + = Abort ApplicationProtocolError ReasonPhrase + | VerNego VersionInfo + deriving (Show) instance E.Exception Abort where - fromException = E.asyncExceptionFromException - toException = E.asyncExceptionToException + fromException = E.asyncExceptionFromException + toException = E.asyncExceptionToException diff --git a/Network/QUIC/Types/Frame.hs b/Network/QUIC/Types/Frame.hs --- a/Network/QUIC/Types/Frame.hs +++ b/Network/QUIC/Types/Frame.hs @@ -18,29 +18,30 @@ type ReasonPhrase = ShortByteString type SeqNum = Int -data Frame = Padding Int - | Ping - | Ack AckInfo Delay - | ResetStream StreamId ApplicationProtocolError Int - | StopSending StreamId ApplicationProtocolError - | CryptoF Offset CryptoData - | NewToken Token - | StreamF StreamId Offset [StreamData] Fin - | MaxData Int - | MaxStreamData StreamId Int - | MaxStreams Direction Int - | DataBlocked Int - | StreamDataBlocked StreamId Int - | StreamsBlocked Direction Int - | NewConnectionID CIDInfo SeqNum -- retire prior to - | RetireConnectionID SeqNum - | PathChallenge PathData - | PathResponse PathData - | ConnectionClose TransportError FrameType ReasonPhrase - | ConnectionCloseApp ApplicationProtocolError ReasonPhrase - | HandshakeDone - | UnknownFrame Int - deriving (Eq,Show) +data Frame + = Padding Int + | Ping + | Ack AckInfo Delay + | ResetStream StreamId ApplicationProtocolError Int + | StopSending StreamId ApplicationProtocolError + | CryptoF Offset CryptoData + | NewToken Token + | StreamF StreamId Offset [StreamData] Fin + | MaxData Int + | MaxStreamData StreamId Int + | MaxStreams Direction Int + | DataBlocked Int + | StreamDataBlocked StreamId Int + | StreamsBlocked Direction Int + | NewConnectionID CIDInfo SeqNum -- retire prior to + | RetireConnectionID SeqNum + | PathChallenge PathData + | PathResponse PathData + | ConnectionClose TransportError FrameType ReasonPhrase + | ConnectionCloseApp ApplicationProtocolError ReasonPhrase + | HandshakeDone + | UnknownFrame Int + deriving (Eq, Show) -- | Stream identifier. -- This should be 62-bit interger. @@ -49,11 +50,11 @@ -- | Checking if a stream is client-initiated bidirectional. isClientInitiatedBidirectional :: StreamId -> Bool -isClientInitiatedBidirectional sid = (0b11 .&. sid) == 0 +isClientInitiatedBidirectional sid = (0b11 .&. sid) == 0 -- | Checking if a stream is server-initiated bidirectional. isServerInitiatedBidirectional :: StreamId -> Bool -isServerInitiatedBidirectional sid = (0b11 .&. sid) == 1 +isServerInitiatedBidirectional sid = (0b11 .&. sid) == 1 -- | Checking if a stream is client-initiated unidirectional. isClientInitiatedUnidirectional :: StreamId -> Bool @@ -86,6 +87,7 @@ emptyToken :: Token emptyToken = "" +{- FOURMOLU_DISABLE -} ackEliciting :: Frame -> Bool ackEliciting Padding{} = False ackEliciting Ack{} = False @@ -103,3 +105,9 @@ inFlight ConnectionClose{} = False inFlight ConnectionCloseApp{} = False inFlight _ = True + +rateControled :: Frame -> Bool +rateControled ResetStream{} = True +rateControled StopSending{} = True +rateControled _ = False +{- FOURMOLU_ENABLE -} diff --git a/Network/QUIC/Types/Integer.hs b/Network/QUIC/Types/Integer.hs --- a/Network/QUIC/Types/Integer.hs +++ b/Network/QUIC/Types/Integer.hs @@ -1,14 +1,14 @@ {-# LANGUAGE BinaryLiterals #-} module Network.QUIC.Types.Integer ( - encodeInt - , encodeInt8 - , encodeInt' - , encodeInt'2 - , encodeInt'4 - , decodeInt - , decodeInt' - ) where + encodeInt, + encodeInt8, + encodeInt', + encodeInt'2, + encodeInt'4, + decodeInt, + decodeInt', +) where import Data.ByteString.Internal (unsafeCreate) import Foreign.Ptr @@ -32,13 +32,13 @@ -- "7bbd" -- >>> enc16 $ encodeInt 37 -- "25" -encodeInt :: Int64 -> ByteString +encodeInt :: Int64 -> ByteString encodeInt i = unsafeCreate n $ go tag n i' where - (tag,n,i') = tagLen i + (tag, n, i') = tagLen i {-# NOINLINE encodeInt #-} -encodeInt8 :: Int64 -> ByteString +encodeInt8 :: Int64 -> ByteString encodeInt8 i = unsafeCreate n $ go tag n i where n = 8 @@ -48,7 +48,7 @@ encodeInt' :: WriteBuffer -> Int64 -> IO () encodeInt' wbuf i = go' tag n i' wbuf where - (tag,n,i') = tagLen i + (tag, n, i') = tagLen i encodeInt'2 :: WriteBuffer -> Int64 -> IO () encodeInt'2 wbuf i = go' tag n i' wbuf @@ -65,10 +65,11 @@ i' = i !<<. 32 tagLen :: Int64 -> (Word8, Int, Int64) -tagLen i | i <= 63 = (0b00000000, 1, i !<<. 56) - | i <= 16383 = (0b01000000, 2, i !<<. 48) - | i <= 1073741823 = (0b10000000, 4, i !<<. 32) - | otherwise = (0b11000000, 8, i) +tagLen i + | i <= 63 = (0b00000000, 1, i !<<. 56) + | i <= 16383 = (0b01000000, 2, i !<<. 48) + | i <= 1073741823 = (0b10000000, 4, i !<<. 32) + | otherwise = (0b11000000, 8, i) {-# INLINE tagLen #-} msb8 :: Int64 -> Word8 @@ -128,13 +129,13 @@ let flag = b0 !>>. 6 b1 = fromIntegral (b0 .&. 0b00111111) case flag of - 0 -> return b1 - 1 -> loop b1 1 - 2 -> loop b1 3 - _ -> loop b1 7 + 0 -> return b1 + 1 -> loop b1 1 + 2 -> loop b1 3 + _ -> loop b1 7 where loop :: Int64 -> Int -> IO Int64 loop r 0 = return r loop r n = do b <- fromIntegral <$> read8 rbuf - loop (r*256 + b) (n - 1) + loop (r * 256 + b) (n - 1) diff --git a/Network/QUIC/Types/Packet.hs b/Network/QUIC/Types/Packet.hs --- a/Network/QUIC/Types/Packet.hs +++ b/Network/QUIC/Types/Packet.hs @@ -4,8 +4,8 @@ module Network.QUIC.Types.Packet where import Data.Ix +import Network.TLS.QUIC (ExtensionID, extensionID_QuicTransportParameters) import Network.UDP -import Network.TLS.QUIC (extensionID_QuicTransportParameters, ExtensionID) import Text.Printf import Network.QUIC.Imports @@ -19,6 +19,7 @@ -- | QUIC version. newtype Version = Version Word32 deriving (Eq, Ord) +{- FOURMOLU_DISABLE -} pattern Negotiation :: Version pattern Negotiation = Version 0 pattern Version1 :: Version @@ -40,16 +41,18 @@ show ver@(Version v) | isGreasingVersion ver = "Greasing 0x" ++ printf "%08x" v | otherwise = "Version 0x" ++ printf "%08x" v +{- FOURMOLU_ENABLE -} isGreasingVersion :: Version -> Bool isGreasingVersion (Version v) = v .&. 0x0a0a0a0a == 0x0a0a0a0a ---------------------------------------------------------------- -data VersionInfo = VersionInfo { - chosenVersion :: Version - , otherVersions :: [Version] - } deriving (Eq, Show) +data VersionInfo = VersionInfo + { chosenVersion :: Version + , otherVersions :: [Version] + } + deriving (Eq, Show) brokenVersionInfo :: VersionInfo brokenVersionInfo = VersionInfo Negotiation [] @@ -59,36 +62,41 @@ extensionIDForTtransportParameter :: Version -> ExtensionID extensionIDForTtransportParameter Version1 = extensionID_QuicTransportParameters extensionIDForTtransportParameter Version2 = extensionID_QuicTransportParameters -extensionIDForTtransportParameter _ = 0xffa5 +extensionIDForTtransportParameter _ = 0xffa5 ---------------------------------------------------------------- -data PacketI = PacketIV VersionNegotiationPacket - | PacketIR RetryPacket - | PacketIC CryptPacket EncryptionLevel Int - | PacketIB BrokenPacket - deriving (Eq, Show) +data PacketI + = PacketIV VersionNegotiationPacket + | PacketIR RetryPacket + | PacketIC CryptPacket EncryptionLevel Int + | PacketIB BrokenPacket + deriving (Eq, Show) -- Not used internally. Only for 'encodePacket'. -data PacketO = PacketOV VersionNegotiationPacket - | PacketOR RetryPacket - | PacketOP PlainPacket - deriving (Eq, Show) +data PacketO + = PacketOV VersionNegotiationPacket + | PacketOR RetryPacket + | PacketOP PlainPacket + deriving (Eq, Show) data VersionNegotiationPacket = VersionNegotiationPacket CID CID [Version] - deriving (Eq, Show) + deriving (Eq, Show) -data RetryPacket = RetryPacket Version CID CID Token (Either CID (ByteString,ByteString)) - deriving (Eq, Show) +data RetryPacket + = RetryPacket Version CID CID Token (Either CID (ByteString, ByteString)) + deriving (Eq, Show) data BrokenPacket = BrokenPacket deriving (Eq, Show) -data Header = Initial Version CID CID Token - | RTT0 Version CID CID - | Handshake Version CID CID - | Short CID - deriving (Eq, Show) +data Header + = Initial Version CID CID Token + | RTT0 Version CID CID + | Handshake Version CID CID + | Short CID + deriving (Eq, Show) +{- FOURMOLU_DISABLE -} headerMyCID :: Header -> CID headerMyCID (Initial _ cid _ _) = cid headerMyCID (RTT0 _ cid _) = cid @@ -100,16 +108,18 @@ headerPeerCID (RTT0 _ _ cid) = cid headerPeerCID (Handshake _ _ cid) = cid headerPeerCID Short{} = CID "" +{- FOURMOLU_ENABLE -} data PlainPacket = PlainPacket Header Plain deriving (Eq, Show) data CryptPacket = CryptPacket Header Crypt deriving (Eq, Show) -data Plain = Plain { - plainFlags :: Flags Raw - , plainPacketNumber :: PacketNumber - , plainFrames :: [Frame] - , plainMarks :: Int - } deriving (Eq, Show) +data Plain = Plain + { plainFlags :: Flags Raw + , plainPacketNumber :: PacketNumber + , plainFrames :: [Frame] + , plainMarks :: Int + } + deriving (Eq, Show) defaultPlainMarks :: Int defaultPlainMarks = 0 @@ -144,57 +154,66 @@ is4bytesPN :: Int -> Bool is4bytesPN = (`testBit` 9) -data MigrationInfo = MigrationInfo ListenSocket ClientSockAddr CID deriving (Eq, Show) +data MigrationInfo = MigrationInfo ListenSocket ClientSockAddr CID + deriving (Eq, Show) -data Crypt = Crypt { - cryptPktNumOffset :: Int - , cryptPacket :: ByteString - , cryptMarks :: Int - , cryptMigraionInfo :: Maybe MigrationInfo - } deriving (Eq, Show) +data Crypt = Crypt + { cryptPktNumOffset :: Int + , cryptPacket :: ByteString + , cryptMarks :: Int + , cryptMigraionInfo :: Maybe MigrationInfo + } + deriving (Eq, Show) isCryptDelayed :: Crypt -> Bool isCryptDelayed crypt = cryptMarks crypt `testBit` 1 setCryptDelayed :: Crypt -> Crypt -setCryptDelayed crypt = crypt { cryptMarks = cryptMarks crypt `setBit` 1 } +setCryptDelayed crypt = crypt{cryptMarks = cryptMarks crypt `setBit` 1} data StatelessReset = StatelessReset deriving (Eq, Show) -data ReceivedPacket = ReceivedPacket { - rpCryptPacket :: CryptPacket - , rpTimeRecevied :: TimeMicrosecond - , rpReceivedBytes :: Int - , rpEncryptionLevel :: EncryptionLevel - } deriving (Eq, Show) +data ReceivedPacket = ReceivedPacket + { rpCryptPacket :: CryptPacket + , rpTimeRecevied :: TimeMicrosecond + , rpReceivedBytes :: Int + , rpEncryptionLevel :: EncryptionLevel + } + deriving (Eq, Show) -mkReceivedPacket :: CryptPacket -> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket -mkReceivedPacket cpkt tim bytes lvl = ReceivedPacket { - rpCryptPacket = cpkt - , rpTimeRecevied = tim - , rpReceivedBytes = bytes - , rpEncryptionLevel = lvl - } +mkReceivedPacket + :: CryptPacket -> TimeMicrosecond -> Int -> EncryptionLevel -> ReceivedPacket +mkReceivedPacket cpkt tim bytes lvl = + ReceivedPacket + { rpCryptPacket = cpkt + , rpTimeRecevied = tim + , rpReceivedBytes = bytes + , rpEncryptionLevel = lvl + } ---------------------------------------------------------------- -data LongHeaderPacketType = InitialPacketType - | RTT0PacketType - | HandshakePacketType - | RetryPacketType - deriving (Eq, Show) +data LongHeaderPacketType + = InitialPacketType + | RTT0PacketType + | HandshakePacketType + | RetryPacketType + deriving (Eq, Show) -data EncryptionLevel = InitialLevel - | RTT0Level - | HandshakeLevel - | RTT1Level - deriving (Eq, Ord, Ix, Show) +data EncryptionLevel + = InitialLevel + | RTT0Level + | HandshakeLevel + | RTT1Level + deriving (Eq, Ord, Ix, Show) +{- FOURMOLU_DISABLE -} packetEncryptionLevel :: Header -> EncryptionLevel packetEncryptionLevel Initial{} = InitialLevel packetEncryptionLevel RTT0{} = RTT0Level packetEncryptionLevel Handshake{} = HandshakeLevel packetEncryptionLevel Short{} = RTT1Level +{- FOURMOLU_ENABLE -} ---------------------------------------------------------------- diff --git a/Network/QUIC/Types/Resumption.hs b/Network/QUIC/Types/Resumption.hs --- a/Network/QUIC/Types/Resumption.hs +++ b/Network/QUIC/Types/Resumption.hs @@ -12,20 +12,22 @@ type SessionEstablish = SessionID -> SessionData -> IO () -- | Information about resumption -data ResumptionInfo = ResumptionInfo { - resumptionVersion :: Version - , resumptionSession :: Maybe (SessionID, SessionData) - , resumptionToken :: Token - , resumptionRetry :: Bool - } deriving (Eq, Show) +data ResumptionInfo = ResumptionInfo + { resumptionVersion :: Version + , resumptionSession :: Maybe (SessionID, SessionData) + , resumptionToken :: Token + , resumptionRetry :: Bool + } + deriving (Eq, Show) defaultResumptionInfo :: ResumptionInfo -defaultResumptionInfo = ResumptionInfo { - resumptionVersion = Version1 - , resumptionSession = Nothing - , resumptionToken = emptyToken - , resumptionRetry = False - } +defaultResumptionInfo = + ResumptionInfo + { resumptionVersion = Version1 + , resumptionSession = Nothing + , resumptionToken = emptyToken + , resumptionRetry = False + } -- | Is 0RTT possible? is0RTTPossible :: ResumptionInfo -> Bool @@ -33,8 +35,8 @@ rtt0OK && (not resumptionRetry || resumptionToken /= emptyToken) where rtt0OK = case resumptionSession of - Nothing -> False - Just (_, sd) -> sessionMaxEarlyDataSize sd == quicMaxEarlyDataSize + Nothing -> False + Just (_, sd) -> sessionMaxEarlyDataSize sd == quicMaxEarlyDataSize -- | Is resumption possible? isResumptionPossible :: ResumptionInfo -> Bool @@ -42,5 +44,5 @@ get0RTTCipher :: ResumptionInfo -> Maybe CipherID get0RTTCipher ri = case resumptionSession ri of - Nothing -> Nothing - Just (_, sd) -> Just $ sessionCipher sd + Nothing -> Nothing + Just (_, sd) -> Just $ sessionCipher sd diff --git a/Network/QUIC/Types/Time.hs b/Network/QUIC/Types/Time.hs --- a/Network/QUIC/Types/Time.hs +++ b/Network/QUIC/Types/Time.hs @@ -1,23 +1,23 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Network.QUIC.Types.Time ( - Milliseconds(..) - , Microseconds(..) - , milliToMicro - , microToMilli - , TimeMicrosecond - , timeMicrosecond0 - , getTimeMicrosecond - , getElapsedTimeMicrosecond - , elapsedTimeMicrosecond - , getTimeoutInMicrosecond - , getPastTimeMicrosecond - , getFutureTimeMicrosecond - , addMicroseconds - ) where + Milliseconds (..), + Microseconds (..), + milliToMicro, + microToMilli, + TimeMicrosecond, + timeMicrosecond0, + getTimeMicrosecond, + getElapsedTimeMicrosecond, + elapsedTimeMicrosecond, + getTimeoutInMicrosecond, + getPastTimeMicrosecond, + getFutureTimeMicrosecond, + addMicroseconds, +) where import Data.UnixTime -import Foreign.C.Types (CTime(..)) +import Foreign.C.Types (CTime (..)) import Network.QUIC.Imports @@ -27,10 +27,10 @@ newtype Microseconds = Microseconds Int deriving (Eq, Ord, Num, Bits) instance Show Milliseconds where - show (Milliseconds n) = show n + show (Milliseconds n) = show n instance Show Microseconds where - show (Microseconds n) = show n + show (Microseconds n) = show n {-# INLINE milliToMicro #-} milliToMicro :: Milliseconds -> Microseconds diff --git a/Network/QUIC/Utils.hs b/Network/QUIC/Utils.hs --- a/Network/QUIC/Utils.hs +++ b/Network/QUIC/Utils.hs @@ -6,7 +6,7 @@ import qualified Data.ByteString as BS import Data.ByteString.Base16 import qualified Data.ByteString.Char8 as C8 -import Data.ByteString.Internal (ByteString(..)) +import Data.ByteString.Internal (ByteString (..)) import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short as Short import Data.Char (chr) @@ -20,7 +20,7 @@ -- GHC 8.0 does not provide fromRight. fromRight :: b -> Either a b -> b fromRight _ (Right b) = b -fromRight b _ = b +fromRight b _ = b dec16 :: ByteString -> ByteString dec16 = fromRight "" . decode @@ -52,7 +52,7 @@ withByteString :: ByteString -> (Ptr Word8 -> IO a) -> IO a withByteString (PS fptr off _) f = withForeignPtr fptr $ \ptr -> - f (ptr `plusPtr` off) + f (ptr `plusPtr` off) shortpack :: String -> ShortByteString shortpack = Short.toShort . C8.pack diff --git a/Network/QUIC/Windows.hs b/Network/QUIC/Windows.hs --- a/Network/QUIC/Windows.hs +++ b/Network/QUIC/Windows.hs @@ -1,6 +1,6 @@ module Network.QUIC.Windows ( - windowsThreadBlockHack - ) where + windowsThreadBlockHack, +) where import Control.Concurrent import qualified Control.Exception as CE @@ -13,5 +13,5 @@ void . forkIO $ CE.try act >>= putMVar var res <- takeMVar var case res of - Left e -> print e >> CE.throwIO e - Right r -> return r + Left e -> print e >> CE.throwIO e + Right r -> return r diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/quic.cabal b/quic.cabal --- a/quic.cabal +++ b/quic.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: quic -version: 0.1.8 +version: 0.1.9 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp @@ -138,9 +138,9 @@ iproute >=1.7.8, memory, network >=3.1.2, + network-control, network-udp, network-byte-order >=0.1.5, - psqueues, random >=1.2, stm, tls >=1.7.0, diff --git a/test/Config.hs b/test/Config.hs --- a/test/Config.hs +++ b/test/Config.hs @@ -1,17 +1,16 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Config ( - makeTestServerConfig - , makeTestServerConfigR - , testClientConfig - , testClientConfigR - , setServerQlog - , setClientQlog - , withPipe - , Scenario(..) - , newSessionManager - ) where + makeTestServerConfig, + makeTestServerConfigR, + testClientConfig, + testClientConfigR, + setServerQlog, + setClientQlog, + withPipe, + Scenario (..), + newSessionManager, +) where import Control.Monad import Data.ByteString (ByteString) @@ -19,7 +18,13 @@ import qualified Data.List as L import Network.Socket import Network.Socket.ByteString -import Network.TLS (Credentials(..), credentialLoadX509, SessionManager(..), SessionData, SessionID) +import Network.TLS ( + Credentials (..), + SessionData, + SessionID, + SessionManager (..), + credentialLoadX509, + ) import UnliftIO.Concurrent import qualified UnliftIO.Exception as E @@ -28,49 +33,59 @@ makeTestServerConfig :: IO ServerConfig makeTestServerConfig = do - cred <- either error id <$> credentialLoadX509 "test/servercert.pem" "test/serverkey.pem" + cred <- + either error id + <$> credentialLoadX509 "test/servercert.pem" "test/serverkey.pem" let credentials = Credentials [cred] - return testServerConfig { - scCredentials = credentials - , scALPN = Just chooseALPN - } + return + testServerConfig + { scCredentials = credentials + , scALPN = Just chooseALPN + } testServerConfig :: ServerConfig -testServerConfig = defaultServerConfig { - -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug) - scAddresses = [("127.0.0.1",50003)] - } +testServerConfig = + defaultServerConfig + { -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug) + scAddresses = [("127.0.0.1", 50003)] + } makeTestServerConfigR :: IO ServerConfig makeTestServerConfigR = do - cred <- either error id <$> credentialLoadX509 "test/servercert.pem" "test/serverkey.pem" + cred <- + either error id + <$> credentialLoadX509 "test/servercert.pem" "test/serverkey.pem" let credentials = Credentials [cred] - return testServerConfigR { - scCredentials = credentials - , scALPN = Just chooseALPN - } + return + testServerConfigR + { scCredentials = credentials + , scALPN = Just chooseALPN + } testServerConfigR :: ServerConfig -testServerConfigR = defaultServerConfig { - -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug) - scAddresses = [("127.0.0.1",50003)] - } +testServerConfigR = + defaultServerConfig + { -- Don't use "0.0.0.0" and "::" for Windows (UDP dispatching bug) + scAddresses = [("127.0.0.1", 50003)] + } testClientConfig :: ClientConfig -testClientConfig = defaultClientConfig { - ccServerName = "127.0.0.1" - , ccPortName = "50003" - , ccValidate = False - , ccDebugLog = True - } +testClientConfig = + defaultClientConfig + { ccServerName = "127.0.0.1" + , ccPortName = "50003" + , ccValidate = False + , ccDebugLog = True + } testClientConfigR :: ClientConfig -testClientConfigR = defaultClientConfig { - ccServerName = "127.0.0.1" - , ccPortName = "50002" - , ccValidate = False - , ccDebugLog = True - } +testClientConfigR = + defaultClientConfig + { ccServerName = "127.0.0.1" + , ccPortName = "50002" + , ccValidate = False + , ccDebugLog = True + } setServerQlog :: ServerConfig -> ServerConfig setServerQlog sc = sc @@ -78,9 +93,10 @@ setClientQlog :: ClientConfig -> ClientConfig setClientQlog cc = cc -data Scenario = Randomly Int - | DropClientPacket [Int] - | DropServerPacket [Int] +data Scenario + = Randomly Int + | DropClientPacket [Int] + | DropServerPacket [Int] withPipe :: Scenario -> IO () -> IO () withPipe scenario body = do @@ -91,65 +107,61 @@ irefC <- newIORef 0 irefS <- newIORef 0 E.bracket (openSocket addrC) close $ \sockC -> - E.bracket (openSocket addrS) close $ \sockS -> do - setSocketOption sockC ReuseAddr 1 - setSocketOption sockS ReuseAddr 1 - bind sockC saC - connect sockS saS - -- from client - tid0 <- forkIO $ do - (bs,saO) <- recvFrom sockC 2048 - connect sockC saO - n0 <- atomicModifyIORef' irefC $ \x -> (x + 1, x) - dropPacket0 <- shouldDrop scenario True n0 - unless dropPacket0 $ void $ send sockS bs - forever $ do - bs1 <- -#if defined(mingw32_HOST_OS) - windowsThreadBlockHack $ -#endif - recv sockC 2048 - n <- atomicModifyIORef' irefC $ \x -> (x + 1, x) - dropPacket <- shouldDrop scenario True n - unless dropPacket $ void $ send sockS bs1 - -- from server - tid1 <- forkIO $ forever $ do - bs <- -#if defined(mingw32_HOST_OS) - windowsThreadBlockHack $ -#endif + E.bracket (openSocket addrS) close $ \sockS -> do + setSocketOption sockC ReuseAddr 1 + setSocketOption sockS ReuseAddr 1 + bind sockC saC + connect sockS saS + -- from client + tid0 <- forkIO $ do + (bs, saO) <- recvFrom sockC 2048 + connect sockC saO + n0 <- atomicModifyIORef' irefC $ \x -> (x + 1, x) + dropPacket0 <- shouldDrop scenario True n0 + unless dropPacket0 $ void $ send sockS bs + forever $ do + bs1 <- + recv sockC 2048 + n <- atomicModifyIORef' irefC $ \x -> (x + 1, x) + dropPacket <- shouldDrop scenario True n + unless dropPacket $ void $ send sockS bs1 + -- from server + tid1 <- forkIO $ forever $ do + bs <- recv sockS 2048 - n <- atomicModifyIORef' irefS $ \x -> (x + 1, x) - dropPacket <- shouldDrop scenario False n - unless dropPacket $ void $ send sockC bs - body - killThread tid0 - killThread tid1 + n <- atomicModifyIORef' irefS $ \x -> (x + 1, x) + dropPacket <- shouldDrop scenario False n + unless dropPacket $ void $ send sockC bs + body + killThread tid0 + killThread tid1 where - hints = defaultHints { addrSocketType = Datagram - , addrFlags = [AI_NUMERICHOST] - , addrFamily = AF_INET - } + hints = + defaultHints + { addrSocketType = Datagram + , addrFlags = [AI_NUMERICHOST] + , addrFamily = AF_INET + } resolve port = head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just port) shouldDrop (Randomly n) _ _ = do w <- getRandomOneByte return ((w `mod` fromIntegral n) == 0) shouldDrop (DropClientPacket ns) fromC pn - | fromC = return (pn `elem` ns) - | otherwise = return False + | fromC = return (pn `elem` ns) + | otherwise = return False shouldDrop (DropServerPacket ns) fromC pn - | fromC = return False - | otherwise = return (pn `elem` ns) + | fromC = return False + | otherwise = return (pn `elem` ns) chooseALPN :: Version -> [ByteString] -> IO ByteString chooseALPN _ver protos = return $ case mh3idx of - Nothing -> case mhqidx of - Nothing -> "" - Just _ -> "hq" - Just h3idx -> case mhqidx of - Nothing -> "h3" - Just hqidx -> if h3idx < hqidx then "h3" else "hq" + Nothing -> case mhqidx of + Nothing -> "" + Just _ -> "hq" + Just h3idx -> case mhqidx of + Nothing -> "h3" + Just hqidx -> if h3idx < hqidx then "h3" else "hq" where mh3idx = "h3" `L.elemIndex` protos mhqidx = "hq" `L.elemIndex` protos @@ -158,18 +170,19 @@ newSessionManager = sessionManager <$> newIORef Nothing sessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager -sessionManager ref = SessionManager { - sessionEstablish = establish - , sessionResume = resume - , sessionResumeOnlyOnce = resume - , sessionInvalidate = \_ -> return () - } +sessionManager ref = + SessionManager + { sessionEstablish = establish + , sessionResume = resume + , sessionResumeOnlyOnce = resume + , sessionInvalidate = \_ -> return () + } where - establish sid sdata = writeIORef ref $ Just (sid,sdata) + establish sid sdata = writeIORef ref $ Just (sid, sdata) resume sid = do mx <- readIORef ref case mx of - Nothing -> return Nothing - Just (s,d) - | s == sid -> return $ Just d - | otherwise -> return Nothing + Nothing -> return Nothing + Just (s, d) + | s == sid -> return $ Just d + | otherwise -> return Nothing diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -16,9 +16,11 @@ setup = do sc' <- makeTestServerConfig smgr <- newSessionManager - let sc = sc' { scSessionManager = smgr - , scUse0RTT = True - } + let sc = + sc' + { scSessionManager = smgr + , scUse0RTT = True + } tid <- forkIO $ run sc loop threadDelay 500000 -- give enough time to the server return tid @@ -29,4 +31,5 @@ teardown tid = killThread tid spec :: Spec -spec = beforeAll setup $ afterAll teardown $ transportErrorSpec testClientConfig 2000 -- 2 seconds +spec = + beforeAll setup $ afterAll teardown $ transportErrorSpec testClientConfig 2000 -- 2 seconds diff --git a/test/FrameSpec.hs b/test/FrameSpec.hs --- a/test/FrameSpec.hs +++ b/test/FrameSpec.hs @@ -17,7 +17,7 @@ let siz = 512 E.bracket (mallocBytes siz) free $ \beg -> do let (+.) = plusPtr - end = beg +. siz + end = beg +. siz fillBytes beg 0 $ fromIntegral siz countZero beg end `shouldReturn` siz countZero (beg +. 1) end `shouldReturn` (siz - 1) diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -4,7 +4,7 @@ import Control.Monad import qualified Data.ByteString as BS -import Network.TLS (HandshakeMode13(..), Group(..)) +import Network.TLS (Group (..), HandshakeMode13 (..)) import qualified Network.TLS as TLS import Test.Hspec import UnliftIO.Concurrent @@ -22,11 +22,14 @@ sc0' <- runIO makeTestServerConfig smgr <- runIO newSessionManager var <- runIO newEmptyMVar - let sc0 = sc0' { scSessionManager = smgr - , scHooks = (scHooks sc0') { - onServerReady = putMVar var () - } - } + let sc0 = + sc0' + { scSessionManager = smgr + , scHooks = + (scHooks sc0') + { onServerReady = putMVar var () + } + } let waitS = takeMVar var :: IO () describe "handshake" $ do it "can handshake in the normal case" $ do @@ -35,11 +38,11 @@ testHandshake cc sc waitS FullHandshake it "can handshake in the case of TLS hello retry" $ do let cc = testClientConfig - sc = sc0 { scGroups = [P256] } + sc = sc0{scGroups = [P256]} testHandshake cc sc waitS HelloRetryRequest it "can handshake in the case of QUIC retry" $ do let cc = testClientConfig - sc = sc0 { scRequireRetry = True } + sc = sc0{scRequireRetry = True} testHandshake cc sc waitS FullHandshake it "can handshake in the case of resumption" $ do let cc = testClientConfig @@ -47,46 +50,52 @@ testHandshake2 cc sc waitS (FullHandshake, PreSharedKey) False it "can handshake in the case of 0-RTT" $ do let cc = testClientConfig - sc = sc0 { scUse0RTT = True } + sc = sc0{scUse0RTT = True} testHandshake2 cc sc waitS (FullHandshake, RTT0) True it "fails with unknown server certificate" $ do - let cc1 = testClientConfig { - ccValidate = True -- ouch, default should be reversed - } + let cc1 = + testClientConfig + { ccValidate = True -- ouch, default should be reversed + } cc2 = testClientConfig - sc = sc0 + sc = sc0 certificateRejected e - | TransportErrorIsSent te@(TransportError _) _ <- e = te == cryptoError TLS.CertificateUnknown + | TransportErrorIsSent te@(TransportError _) _ <- e = + te == cryptoError TLS.CertificateUnknown | otherwise = False testHandshake3 cc1 cc2 sc waitS certificateRejected it "fails with no group in common" $ do - let cc1 = testClientConfig { ccGroups = [X25519] } - cc2 = testClientConfig { ccGroups = [P256] } - sc = sc0 { scGroups = [P256] } + let cc1 = testClientConfig{ccGroups = [X25519]} + cc2 = testClientConfig{ccGroups = [P256]} + sc = sc0{scGroups = [P256]} handshakeFailure e - | TransportErrorIsReceived te@(TransportError _) _ <- e = te == cryptoError TLS.HandshakeFailure + | TransportErrorIsReceived te@(TransportError _) _ <- e = + te == cryptoError TLS.HandshakeFailure | otherwise = False testHandshake3 cc1 cc2 sc waitS handshakeFailure it "can handshake with large HE from a client" $ do let cc0 = testClientConfig - params = (ccParameters cc0) { - grease = Just (BS.pack (replicate 2400 0)) - } - cc = cc0 { ccParameters = params } + params = + (ccParameters cc0) + { grease = Just (BS.pack (replicate 2400 0)) + } + cc = cc0{ccParameters = params} sc = sc0 testHandshake cc sc waitS FullHandshake it "can handshake with large EE from a server (3-times rule)" $ do let cc = testClientConfig - params = (scParameters sc0) { - grease = Just (BS.pack (replicate 3800 0)) - } - sc = sc0 { scParameters = params } + params = + (scParameters sc0) + { grease = Just (BS.pack (replicate 3800 0)) + } + sc = sc0{scParameters = params} testHandshake cc sc waitS FullHandshake onE :: IO b -> IO a -> IO a onE h b = E.onException b h -testHandshake :: ClientConfig -> ServerConfig -> IO () -> HandshakeMode13 -> IO () +testHandshake + :: ClientConfig -> ServerConfig -> IO () -> HandshakeMode13 -> IO () testHandshake cc sc waitS mode = do mvar <- newEmptyMVar E.bracket (forkIO $ server mvar) killThread $ \_ -> client mvar @@ -110,7 +119,13 @@ shutdownStream s void $ recvStream s 1024 -testHandshake2 :: ClientConfig -> ServerConfig -> IO () -> (HandshakeMode13, HandshakeMode13) -> Bool -> IO () +testHandshake2 + :: ClientConfig + -> ServerConfig + -> IO () + -> (HandshakeMode13, HandshakeMode13) + -> Bool + -> IO () testHandshake2 cc1 sc waitS (mode1, mode2) use0RTT = do mvar <- newEmptyMVar E.bracket (forkIO $ server mvar) killThread $ \_ -> client mvar @@ -124,9 +139,11 @@ waitS res <- runClient cc1 mode1 $ query "first" threadDelay 50000 - let cc2 = cc1 { ccResumption = res - , ccUse0RTT = use0RTT - } + let cc2 = + cc1 + { ccResumption = res + , ccUse0RTT = use0RTT + } void $ runClient cc2 mode2 $ query "second" takeMVar mvar server mvar = S.run sc serv @@ -136,16 +153,22 @@ bs <- recvStream s 1024 sendStream s "bye" closeStream s - when (bs == "second") $ putMVar mvar () + when (bs == "second") $ putMVar mvar () -testHandshake3 :: ClientConfig -> ClientConfig -> ServerConfig -> IO () -> (QUICException -> Bool) -> IO () +testHandshake3 + :: ClientConfig + -> ClientConfig + -> ServerConfig + -> IO () + -> (QUICException -> Bool) + -> IO () testHandshake3 cc1 cc2 sc waitS selector = do mvar <- newEmptyMVar E.bracket (forkIO $ server mvar) killThread $ \_ -> client mvar where client mvar = do waitS - C.run cc1 (query "first") `shouldThrow` selector + C.run cc1 (query "first") `shouldThrow` selector C.run cc2 (query "second") `shouldReturn` () takeMVar mvar server mvar = S.run sc $ \conn -> do diff --git a/test/IOSpec.hs b/test/IOSpec.hs --- a/test/IOSpec.hs +++ b/test/IOSpec.hs @@ -19,10 +19,13 @@ spec = do sc0 <- runIO makeTestServerConfigR var <- runIO newEmptyMVar - let sc = sc0 { scHooks = (scHooks sc0) { - onServerReady = putMVar var () - } - } + let sc = + sc0 + { scHooks = + (scHooks sc0) + { onServerReady = putMVar var () + } + } let cc = testClientConfigR let waitS = takeMVar var :: IO () describe "send & recv" $ do @@ -95,7 +98,8 @@ assertEndOfStream :: Stream -> IO () assertEndOfStream strm = recvStream strm 1024 `shouldReturn` "" -testRecvStreamClientStopFirst :: C.ClientConfig -> ServerConfig -> IO () -> IO () +testRecvStreamClientStopFirst + :: C.ClientConfig -> ServerConfig -> IO () -> IO () testRecvStreamClientStopFirst cc sc waitS = do mvar <- newEmptyMVar E.bracket (forkIO $ server mvar) killThread $ \_ -> client mvar @@ -120,7 +124,8 @@ assertEndOfStream strm putMVar mvar () -testRecvStreamServerStopFirst :: C.ClientConfig -> ServerConfig -> IO () -> IO () +testRecvStreamServerStopFirst + :: C.ClientConfig -> ServerConfig -> IO () -> IO () testRecvStreamServerStopFirst cc sc waitS = do mvar <- newEmptyMVar E.bracket (forkIO $ server mvar) killThread $ \_ -> client mvar diff --git a/test/PacketSpec.hs b/test/PacketSpec.hs --- a/test/PacketSpec.hs +++ b/test/PacketSpec.hs @@ -39,11 +39,13 @@ let noLog _ = return () let serverCID = clientChosenCID clientCID = toCID "" - serverAuthCIDs = defaultAuthCIDs { initSrcCID = Just serverCID - , origDstCID = Just serverCID - } - clientAuthCIDs = defaultAuthCIDs { initSrcCID = Just clientCID } - -- dummy + serverAuthCIDs = + defaultAuthCIDs + { initSrcCID = Just serverCID + , origDstCID = Just serverCID + } + clientAuthCIDs = defaultAuthCIDs{initSrcCID = Just clientCID} + -- dummy let clientConf = testClientConfig us <- clientSocket "127.0.0.1" "2000" False q <- newRecvQ @@ -51,15 +53,39 @@ let ver = v verInfo = VersionInfo ver [ver] ---- - clientConn <- clientConnection clientConf verInfo clientAuthCIDs serverAuthCIDs noLog noLog defaultHooks sref q undefined undefined + clientConn <- + clientConnection + clientConf + verInfo + clientAuthCIDs + serverAuthCIDs + noLog + noLog + defaultHooks + sref + q + undefined + undefined initializeCoder clientConn InitialLevel $ initialSecrets ver serverCID - serverConn <- serverConnection conf verInfo serverAuthCIDs clientAuthCIDs noLog noLog defaultHooks sref q undefined undefined + serverConn <- + serverConnection + conf + verInfo + serverAuthCIDs + clientAuthCIDs + noLog + noLog + defaultHooks + sref + q + undefined + undefined initializeCoder serverConn InitialLevel $ initialSecrets ver serverCID ---- return (clientConn, serverConn) -checkBinary :: (Connection,Connection)-> PacketNumber -> ByteString -> IO () -checkBinary (senderConn,recverConn) pn bin = do +checkBinary :: (Connection, Connection) -> PacketNumber -> ByteString -> IO () +checkBinary (senderConn, recverConn) pn bin = do ---- Decoding by the receiver (PacketIC (CryptPacket header crypt) lvl _, _) <- decodePacket bin ---- Cecrypting by the receiver @@ -79,103 +105,111 @@ plainFrames plain' `shouldBe` plainFrames plain clientInitialPacketBinaryV1 :: ByteString -clientInitialPacketBinaryV1 = dec16 $ BS.concat [ - "c000000001088394c8f03e5157080000449e7b9aec34d1b1c98dd7689fb8ec11" - , "d242b123dc9bd8bab936b47d92ec356c0bab7df5976d27cd449f63300099f399" - , "1c260ec4c60d17b31f8429157bb35a1282a643a8d2262cad67500cadb8e7378c" - , "8eb7539ec4d4905fed1bee1fc8aafba17c750e2c7ace01e6005f80fcb7df6212" - , "30c83711b39343fa028cea7f7fb5ff89eac2308249a02252155e2347b63d58c5" - , "457afd84d05dfffdb20392844ae812154682e9cf012f9021a6f0be17ddd0c208" - , "4dce25ff9b06cde535d0f920a2db1bf362c23e596d11a4f5a6cf3948838a3aec" - , "4e15daf8500a6ef69ec4e3feb6b1d98e610ac8b7ec3faf6ad760b7bad1db4ba3" - , "485e8a94dc250ae3fdb41ed15fb6a8e5eba0fc3dd60bc8e30c5c4287e53805db" - , "059ae0648db2f64264ed5e39be2e20d82df566da8dd5998ccabdae053060ae6c" - , "7b4378e846d29f37ed7b4ea9ec5d82e7961b7f25a9323851f681d582363aa5f8" - , "9937f5a67258bf63ad6f1a0b1d96dbd4faddfcefc5266ba6611722395c906556" - , "be52afe3f565636ad1b17d508b73d8743eeb524be22b3dcbc2c7468d54119c74" - , "68449a13d8e3b95811a198f3491de3e7fe942b330407abf82a4ed7c1b311663a" - , "c69890f4157015853d91e923037c227a33cdd5ec281ca3f79c44546b9d90ca00" - , "f064c99e3dd97911d39fe9c5d0b23a229a234cb36186c4819e8b9c5927726632" - , "291d6a418211cc2962e20fe47feb3edf330f2c603a9d48c0fcb5699dbfe58964" - , "25c5bac4aee82e57a85aaf4e2513e4f05796b07ba2ee47d80506f8d2c25e50fd" - , "14de71e6c418559302f939b0e1abd576f279c4b2e0feb85c1f28ff18f58891ff" - , "ef132eef2fa09346aee33c28eb130ff28f5b766953334113211996d20011a198" - , "e3fc433f9f2541010ae17c1bf202580f6047472fb36857fe843b19f5984009dd" - , "c324044e847a4f4a0ab34f719595de37252d6235365e9b84392b061085349d73" - , "203a4a13e96f5432ec0fd4a1ee65accdd5e3904df54c1da510b0ff20dcc0c77f" - , "cb2c0e0eb605cb0504db87632cf3d8b4dae6e705769d1de354270123cb11450e" - , "fc60ac47683d7b8d0f811365565fd98c4c8eb936bcab8d069fc33bd801b03ade" - , "a2e1fbc5aa463d08ca19896d2bf59a071b851e6c239052172f296bfb5e724047" - , "90a2181014f3b94a4e97d117b438130368cc39dbb2d198065ae3986547926cd2" - , "162f40a29f0c3c8745c0f50fba3852e566d44575c29d39a03f0cda721984b6f4" - , "40591f355e12d439ff150aab7613499dbd49adabc8676eef023b15b65bfc5ca0" - , "6948109f23f350db82123535eb8a7433bdabcb909271a6ecbcb58b936a88cd4e" - , "8f2e6ff5800175f113253d8fa9ca8885c2f552e657dc603f252e1a8e308f76f0" - , "be79e2fb8f5d5fbbe2e30ecadd220723c8c0aea8078cdfcb3868263ff8f09400" - , "54da48781893a7e49ad5aff4af300cd804a6b6279ab3ff3afb64491c85194aab" - , "760d58a606654f9f4400e8b38591356fbf6425aca26dc85244259ff2b19c41b9" - , "f96f3ca9ec1dde434da7d2d392b905ddf3d1f9af93d1af5950bd493f5aa731b4" - , "056df31bd267b6b90a079831aaf579be0a39013137aac6d404f518cfd4684064" - , "7e78bfe706ca4cf5e9c5453e9f7cfd2b8b4c8d169a44e55c88d4a9a7f9474241" - , "e221af44860018ab0856972e194cd934" - ] +clientInitialPacketBinaryV1 = + dec16 $ + BS.concat + [ "c000000001088394c8f03e5157080000449e7b9aec34d1b1c98dd7689fb8ec11" + , "d242b123dc9bd8bab936b47d92ec356c0bab7df5976d27cd449f63300099f399" + , "1c260ec4c60d17b31f8429157bb35a1282a643a8d2262cad67500cadb8e7378c" + , "8eb7539ec4d4905fed1bee1fc8aafba17c750e2c7ace01e6005f80fcb7df6212" + , "30c83711b39343fa028cea7f7fb5ff89eac2308249a02252155e2347b63d58c5" + , "457afd84d05dfffdb20392844ae812154682e9cf012f9021a6f0be17ddd0c208" + , "4dce25ff9b06cde535d0f920a2db1bf362c23e596d11a4f5a6cf3948838a3aec" + , "4e15daf8500a6ef69ec4e3feb6b1d98e610ac8b7ec3faf6ad760b7bad1db4ba3" + , "485e8a94dc250ae3fdb41ed15fb6a8e5eba0fc3dd60bc8e30c5c4287e53805db" + , "059ae0648db2f64264ed5e39be2e20d82df566da8dd5998ccabdae053060ae6c" + , "7b4378e846d29f37ed7b4ea9ec5d82e7961b7f25a9323851f681d582363aa5f8" + , "9937f5a67258bf63ad6f1a0b1d96dbd4faddfcefc5266ba6611722395c906556" + , "be52afe3f565636ad1b17d508b73d8743eeb524be22b3dcbc2c7468d54119c74" + , "68449a13d8e3b95811a198f3491de3e7fe942b330407abf82a4ed7c1b311663a" + , "c69890f4157015853d91e923037c227a33cdd5ec281ca3f79c44546b9d90ca00" + , "f064c99e3dd97911d39fe9c5d0b23a229a234cb36186c4819e8b9c5927726632" + , "291d6a418211cc2962e20fe47feb3edf330f2c603a9d48c0fcb5699dbfe58964" + , "25c5bac4aee82e57a85aaf4e2513e4f05796b07ba2ee47d80506f8d2c25e50fd" + , "14de71e6c418559302f939b0e1abd576f279c4b2e0feb85c1f28ff18f58891ff" + , "ef132eef2fa09346aee33c28eb130ff28f5b766953334113211996d20011a198" + , "e3fc433f9f2541010ae17c1bf202580f6047472fb36857fe843b19f5984009dd" + , "c324044e847a4f4a0ab34f719595de37252d6235365e9b84392b061085349d73" + , "203a4a13e96f5432ec0fd4a1ee65accdd5e3904df54c1da510b0ff20dcc0c77f" + , "cb2c0e0eb605cb0504db87632cf3d8b4dae6e705769d1de354270123cb11450e" + , "fc60ac47683d7b8d0f811365565fd98c4c8eb936bcab8d069fc33bd801b03ade" + , "a2e1fbc5aa463d08ca19896d2bf59a071b851e6c239052172f296bfb5e724047" + , "90a2181014f3b94a4e97d117b438130368cc39dbb2d198065ae3986547926cd2" + , "162f40a29f0c3c8745c0f50fba3852e566d44575c29d39a03f0cda721984b6f4" + , "40591f355e12d439ff150aab7613499dbd49adabc8676eef023b15b65bfc5ca0" + , "6948109f23f350db82123535eb8a7433bdabcb909271a6ecbcb58b936a88cd4e" + , "8f2e6ff5800175f113253d8fa9ca8885c2f552e657dc603f252e1a8e308f76f0" + , "be79e2fb8f5d5fbbe2e30ecadd220723c8c0aea8078cdfcb3868263ff8f09400" + , "54da48781893a7e49ad5aff4af300cd804a6b6279ab3ff3afb64491c85194aab" + , "760d58a606654f9f4400e8b38591356fbf6425aca26dc85244259ff2b19c41b9" + , "f96f3ca9ec1dde434da7d2d392b905ddf3d1f9af93d1af5950bd493f5aa731b4" + , "056df31bd267b6b90a079831aaf579be0a39013137aac6d404f518cfd4684064" + , "7e78bfe706ca4cf5e9c5453e9f7cfd2b8b4c8d169a44e55c88d4a9a7f9474241" + , "e221af44860018ab0856972e194cd934" + ] clientInitialPacketBinaryV2 :: ByteString -clientInitialPacketBinaryV2 = dec16 $ BS.concat [ - "d76b3343cf088394c8f03e5157080000449ea0c95e82ffe67b6abcdb4298b485" - , "dd04de806071bf03dceebfa162e75d6c96058bdbfb127cdfcbf903388e99ad04" - , "9f9a3dd4425ae4d0992cfff18ecf0fdb5a842d09747052f17ac2053d21f57c5d" - , "250f2c4f0e0202b70785b7946e992e58a59ac52dea6774d4f03b55545243cf1a" - , "12834e3f249a78d395e0d18f4d766004f1a2674802a747eaa901c3f10cda5500" - , "cb9122faa9f1df66c392079a1b40f0de1c6054196a11cbea40afb6ef5253cd68" - , "18f6625efce3b6def6ba7e4b37a40f7732e093daa7d52190935b8da58976ff33" - , "12ae50b187c1433c0f028edcc4c2838b6a9bfc226ca4b4530e7a4ccee1bfa2a3" - , "d396ae5a3fb512384b2fdd851f784a65e03f2c4fbe11a53c7777c023462239dd" - , "6f7521a3f6c7d5dd3ec9b3f233773d4b46d23cc375eb198c63301c21801f6520" - , "bcfb7966fc49b393f0061d974a2706df8c4a9449f11d7f3d2dcbb90c6b877045" - , "636e7c0c0fe4eb0f697545460c806910d2c355f1d253bc9d2452aaa549e27a1f" - , "ac7cf4ed77f322e8fa894b6a83810a34b361901751a6f5eb65a0326e07de7c12" - , "16ccce2d0193f958bb3850a833f7ae432b65bc5a53975c155aa4bcb4f7b2c4e5" - , "4df16efaf6ddea94e2c50b4cd1dfe06017e0e9d02900cffe1935e0491d77ffb4" - , "fdf85290fdd893d577b1131a610ef6a5c32b2ee0293617a37cbb08b847741c3b" - , "8017c25ca9052ca1079d8b78aebd47876d330a30f6a8c6d61dd1ab5589329de7" - , "14d19d61370f8149748c72f132f0fc99f34d766c6938597040d8f9e2bb522ff9" - , "9c63a344d6a2ae8aa8e51b7b90a4a806105fcbca31506c446151adfeceb51b91" - , "abfe43960977c87471cf9ad4074d30e10d6a7f03c63bd5d4317f68ff325ba3bd" - , "80bf4dc8b52a0ba031758022eb025cdd770b44d6d6cf0670f4e990b22347a7db" - , "848265e3e5eb72dfe8299ad7481a408322cac55786e52f633b2fb6b614eaed18" - , "d703dd84045a274ae8bfa73379661388d6991fe39b0d93debb41700b41f90a15" - , "c4d526250235ddcd6776fc77bc97e7a417ebcb31600d01e57f32162a8560cacc" - , "7e27a096d37a1a86952ec71bd89a3e9a30a2a26162984d7740f81193e8238e61" - , "f6b5b984d4d3dfa033c1bb7e4f0037febf406d91c0dccf32acf423cfa1e70710" - , "10d3f270121b493ce85054ef58bada42310138fe081adb04e2bd901f2f13458b" - , "3d6758158197107c14ebb193230cd1157380aa79cae1374a7c1e5bbcb80ee23e" - , "06ebfde206bfb0fcbc0edc4ebec309661bdd908d532eb0c6adc38b7ca7331dce" - , "8dfce39ab71e7c32d318d136b6100671a1ae6a6600e3899f31f0eed19e3417d1" - , "34b90c9058f8632c798d4490da4987307cba922d61c39805d072b589bd52fdf1" - , "e86215c2d54e6670e07383a27bbffb5addf47d66aa85a0c6f9f32e59d85a44dd" - , "5d3b22dc2be80919b490437ae4f36a0ae55edf1d0b5cb4e9a3ecabee93dfc6e3" - , "8d209d0fa6536d27a5d6fbb17641cde27525d61093f1b28072d111b2b4ae5f89" - , "d5974ee12e5cf7d5da4d6a31123041f33e61407e76cffcdcfd7e19ba58cf4b53" - , "6f4c4938ae79324dc402894b44faf8afbab35282ab659d13c93f70412e85cb19" - , "9a37ddec600545473cfb5a05e08d0b209973b2172b4d21fb69745a262ccde96b" - , "a18b2faa745b6fe189cf772a9f84cbfc" - ] +clientInitialPacketBinaryV2 = + dec16 $ + BS.concat + [ "d76b3343cf088394c8f03e5157080000449ea0c95e82ffe67b6abcdb4298b485" + , "dd04de806071bf03dceebfa162e75d6c96058bdbfb127cdfcbf903388e99ad04" + , "9f9a3dd4425ae4d0992cfff18ecf0fdb5a842d09747052f17ac2053d21f57c5d" + , "250f2c4f0e0202b70785b7946e992e58a59ac52dea6774d4f03b55545243cf1a" + , "12834e3f249a78d395e0d18f4d766004f1a2674802a747eaa901c3f10cda5500" + , "cb9122faa9f1df66c392079a1b40f0de1c6054196a11cbea40afb6ef5253cd68" + , "18f6625efce3b6def6ba7e4b37a40f7732e093daa7d52190935b8da58976ff33" + , "12ae50b187c1433c0f028edcc4c2838b6a9bfc226ca4b4530e7a4ccee1bfa2a3" + , "d396ae5a3fb512384b2fdd851f784a65e03f2c4fbe11a53c7777c023462239dd" + , "6f7521a3f6c7d5dd3ec9b3f233773d4b46d23cc375eb198c63301c21801f6520" + , "bcfb7966fc49b393f0061d974a2706df8c4a9449f11d7f3d2dcbb90c6b877045" + , "636e7c0c0fe4eb0f697545460c806910d2c355f1d253bc9d2452aaa549e27a1f" + , "ac7cf4ed77f322e8fa894b6a83810a34b361901751a6f5eb65a0326e07de7c12" + , "16ccce2d0193f958bb3850a833f7ae432b65bc5a53975c155aa4bcb4f7b2c4e5" + , "4df16efaf6ddea94e2c50b4cd1dfe06017e0e9d02900cffe1935e0491d77ffb4" + , "fdf85290fdd893d577b1131a610ef6a5c32b2ee0293617a37cbb08b847741c3b" + , "8017c25ca9052ca1079d8b78aebd47876d330a30f6a8c6d61dd1ab5589329de7" + , "14d19d61370f8149748c72f132f0fc99f34d766c6938597040d8f9e2bb522ff9" + , "9c63a344d6a2ae8aa8e51b7b90a4a806105fcbca31506c446151adfeceb51b91" + , "abfe43960977c87471cf9ad4074d30e10d6a7f03c63bd5d4317f68ff325ba3bd" + , "80bf4dc8b52a0ba031758022eb025cdd770b44d6d6cf0670f4e990b22347a7db" + , "848265e3e5eb72dfe8299ad7481a408322cac55786e52f633b2fb6b614eaed18" + , "d703dd84045a274ae8bfa73379661388d6991fe39b0d93debb41700b41f90a15" + , "c4d526250235ddcd6776fc77bc97e7a417ebcb31600d01e57f32162a8560cacc" + , "7e27a096d37a1a86952ec71bd89a3e9a30a2a26162984d7740f81193e8238e61" + , "f6b5b984d4d3dfa033c1bb7e4f0037febf406d91c0dccf32acf423cfa1e70710" + , "10d3f270121b493ce85054ef58bada42310138fe081adb04e2bd901f2f13458b" + , "3d6758158197107c14ebb193230cd1157380aa79cae1374a7c1e5bbcb80ee23e" + , "06ebfde206bfb0fcbc0edc4ebec309661bdd908d532eb0c6adc38b7ca7331dce" + , "8dfce39ab71e7c32d318d136b6100671a1ae6a6600e3899f31f0eed19e3417d1" + , "34b90c9058f8632c798d4490da4987307cba922d61c39805d072b589bd52fdf1" + , "e86215c2d54e6670e07383a27bbffb5addf47d66aa85a0c6f9f32e59d85a44dd" + , "5d3b22dc2be80919b490437ae4f36a0ae55edf1d0b5cb4e9a3ecabee93dfc6e3" + , "8d209d0fa6536d27a5d6fbb17641cde27525d61093f1b28072d111b2b4ae5f89" + , "d5974ee12e5cf7d5da4d6a31123041f33e61407e76cffcdcfd7e19ba58cf4b53" + , "6f4c4938ae79324dc402894b44faf8afbab35282ab659d13c93f70412e85cb19" + , "9a37ddec600545473cfb5a05e08d0b209973b2172b4d21fb69745a262ccde96b" + , "a18b2faa745b6fe189cf772a9f84cbfc" + ] serverInitialPacketBinaryV1 :: ByteString -serverInitialPacketBinaryV1 = dec16 $ BS.concat [ - "cf000000010008f067a5502a4262b5004075c0d95a482cd0991cd25b0aac406a" - , "5816b6394100f37a1c69797554780bb38cc5a99f5ede4cf73c3ec2493a1839b3" - , "dbcba3f6ea46c5b7684df3548e7ddeb9c3bf9c73cc3f3bded74b562bfb19fb84" - , "022f8ef4cdd93795d77d06edbb7aaf2f58891850abbdca3d20398c276456cbc4" - , "2158407dd074ee" - ] +serverInitialPacketBinaryV1 = + dec16 $ + BS.concat + [ "cf000000010008f067a5502a4262b5004075c0d95a482cd0991cd25b0aac406a" + , "5816b6394100f37a1c69797554780bb38cc5a99f5ede4cf73c3ec2493a1839b3" + , "dbcba3f6ea46c5b7684df3548e7ddeb9c3bf9c73cc3f3bded74b562bfb19fb84" + , "022f8ef4cdd93795d77d06edbb7aaf2f58891850abbdca3d20398c276456cbc4" + , "2158407dd074ee" + ] serverInitialPacketBinaryV2 :: ByteString -serverInitialPacketBinaryV2 = dec16 $ BS.concat [ - "dc6b3343cf0008f067a5502a4262b5004075d92faaf16f05d8a4398c47089698" - , "baeea26b91eb761d9b89237bbf87263017915358230035f7fd3945d88965cf17" - , "f9af6e16886c61bfc703106fbaf3cb4cfa52382dd16a393e42757507698075b2" - , "c984c707f0a0812d8cd5a6881eaf21ceda98f4bd23f6fe1a3e2c43edd9ce7ca8" - , "4bed8521e2e140" - ] +serverInitialPacketBinaryV2 = + dec16 $ + BS.concat + [ "dc6b3343cf0008f067a5502a4262b5004075d92faaf16f05d8a4398c47089698" + , "baeea26b91eb761d9b89237bbf87263017915358230035f7fd3945d88965cf17" + , "f9af6e16886c61bfc703106fbaf3cb4cfa52382dd16a393e42757507698075b2" + , "c984c707f0a0812d8cd5a6881eaf21ceda98f4bd23f6fe1a3e2c43edd9ce7ca8" + , "4bed8521e2e140" + ] diff --git a/test/RecoverySpec.hs b/test/RecoverySpec.hs --- a/test/RecoverySpec.hs +++ b/test/RecoverySpec.hs @@ -14,44 +14,99 @@ describe "persistent congestion" $ do it "does not find a pair" $ do findDuration (Seq.fromList [sp0]) 0 `shouldBe` Nothing - findDuration (Seq.fromList [sp0,sp1]) 0 `shouldBe` Nothing - findDuration (Seq.fromList [sp0,sp1,sp2]) 0 `shouldBe` Nothing - findDuration (Seq.fromList [sp0,sp2,sp2,sp3]) 0 `shouldBe` Nothing - findDuration (Seq.fromList [sp0,sp2,sp2,sp3,sp4]) 0 `shouldBe` Nothing - findDuration (Seq.fromList [sp0,sp2,sp2,sp3,sp5]) 0 `shouldBe` Nothing - findDuration (Seq.fromList [sp0,sp2,sp2,sp3,sp4,sp5]) 2 `shouldBe` Nothing + findDuration (Seq.fromList [sp0, sp1]) 0 `shouldBe` Nothing + findDuration (Seq.fromList [sp0, sp1, sp2]) 0 `shouldBe` Nothing + findDuration (Seq.fromList [sp0, sp2, sp2, sp3]) 0 `shouldBe` Nothing + findDuration (Seq.fromList [sp0, sp2, sp2, sp3, sp4]) 0 `shouldBe` Nothing + findDuration (Seq.fromList [sp0, sp2, sp2, sp3, sp5]) 0 `shouldBe` Nothing + findDuration (Seq.fromList [sp0, sp2, sp2, sp3, sp4, sp5]) 2 `shouldBe` Nothing it "finds a pair" $ do - findDuration (Seq.fromList [sp0,sp1,sp2,sp3,sp4,sp5]) 0 `shouldBe` Just (UnixDiffTime 4 0) - findDuration (Seq.fromList [sp0,sp1,sp2,sp3,sp4,sp5,sp6]) 0 `shouldBe` Just (UnixDiffTime 4 0) - findDuration (Seq.fromList [sp0,sp1,sp2,sp3,sp4,sp5,sp6,sp7]) 0 `shouldBe` Just (UnixDiffTime 6 0) - findDuration (Seq.fromList [sp0,sp1,sp2,sp3,sp4,sp5,sp6,sp7]) 3 `shouldBe` Just (UnixDiffTime 2 0) - findDuration (Seq.fromList [sp0,sp1,sp2,sp3,sp4,sp5,sp6,sp7,sp8,sp9,sp10]) 2 `shouldBe` Just (UnixDiffTime 5 0) - findDuration (Seq.fromList [sp0,sp1,sp2,sp3,sp4,sp5,sp6,sp7,sp8,sp9]) 0 `shouldBe` Just (UnixDiffTime 6 0) - findDuration (Seq.fromList [sp0,sp1,sp2,sp3,sp4,sp5,sp6,sp7,sp8,sp9,sp10]) 0 `shouldBe` Just (UnixDiffTime 9 0) - findDuration (Seq.fromList [sp0,sp1,sp2,sp3,sp4,sp5,sp6,sp7,sp8,sp9,sp10,sp20,sp21]) 0 `shouldBe` Just (UnixDiffTime 22 0) - findDuration (Seq.fromList [sp0,sp1,sp2,sp3,sp4,sp5,sp6,sp7,sp8,sp9,sp10,sp20,sp21,sp30,sp31,sp32,sp33]) 0 `shouldBe` Just (UnixDiffTime 29 0) + findDuration (Seq.fromList [sp0, sp1, sp2, sp3, sp4, sp5]) 0 + `shouldBe` Just (UnixDiffTime 4 0) + findDuration (Seq.fromList [sp0, sp1, sp2, sp3, sp4, sp5, sp6]) 0 + `shouldBe` Just (UnixDiffTime 4 0) + findDuration (Seq.fromList [sp0, sp1, sp2, sp3, sp4, sp5, sp6, sp7]) 0 + `shouldBe` Just (UnixDiffTime 6 0) + findDuration (Seq.fromList [sp0, sp1, sp2, sp3, sp4, sp5, sp6, sp7]) 3 + `shouldBe` Just (UnixDiffTime 2 0) + findDuration + (Seq.fromList [sp0, sp1, sp2, sp3, sp4, sp5, sp6, sp7, sp8, sp9, sp10]) + 2 + `shouldBe` Just (UnixDiffTime 5 0) + findDuration (Seq.fromList [sp0, sp1, sp2, sp3, sp4, sp5, sp6, sp7, sp8, sp9]) 0 + `shouldBe` Just (UnixDiffTime 6 0) + findDuration + (Seq.fromList [sp0, sp1, sp2, sp3, sp4, sp5, sp6, sp7, sp8, sp9, sp10]) + 0 + `shouldBe` Just (UnixDiffTime 9 0) + findDuration + ( Seq.fromList + [sp0, sp1, sp2, sp3, sp4, sp5, sp6, sp7, sp8, sp9, sp10, sp20, sp21] + ) + 0 + `shouldBe` Just (UnixDiffTime 22 0) + findDuration + ( Seq.fromList + [ sp0 + , sp1 + , sp2 + , sp3 + , sp4 + , sp5 + , sp6 + , sp7 + , sp8 + , sp9 + , sp10 + , sp20 + , sp21 + , sp30 + , sp31 + , sp32 + , sp33 + ] + ) + 0 + `shouldBe` Just (UnixDiffTime 29 0) -sp0,sp1,sp2,sp3,sp4,sp5,sp6,sp7,sp8,sp9,sp10,sp20,sp21,sp30,sp31,sp32,sp33 :: SentPacket -sp0 = sp 0 False $ UnixTime 0 0 -sp1 = sp 1 True $ UnixTime 1 0 -sp2 = sp 2 False $ UnixTime 2 0 -sp3 = sp 3 False $ UnixTime 3 0 -sp4 = sp 4 False $ UnixTime 4 0 -sp5 = sp 5 True $ UnixTime 5 0 -sp6 = sp 6 False $ UnixTime 6 0 -sp7 = sp 7 True $ UnixTime 7 0 -sp8 = sp 8 False $ UnixTime 8 0 -sp9 = sp 9 False $ UnixTime 9 0 -sp10 = sp 10 True $ UnixTime 10 0 -sp20 = sp 20 True $ UnixTime 22 0 -sp21 = sp 21 True $ UnixTime 44 0 +sp0 + , sp1 + , sp2 + , sp3 + , sp4 + , sp5 + , sp6 + , sp7 + , sp8 + , sp9 + , sp10 + , sp20 + , sp21 + , sp30 + , sp31 + , sp32 + , sp33 + :: SentPacket +sp0 = sp 0 False $ UnixTime 0 0 +sp1 = sp 1 True $ UnixTime 1 0 +sp2 = sp 2 False $ UnixTime 2 0 +sp3 = sp 3 False $ UnixTime 3 0 +sp4 = sp 4 False $ UnixTime 4 0 +sp5 = sp 5 True $ UnixTime 5 0 +sp6 = sp 6 False $ UnixTime 6 0 +sp7 = sp 7 True $ UnixTime 7 0 +sp8 = sp 8 False $ UnixTime 8 0 +sp9 = sp 9 False $ UnixTime 9 0 +sp10 = sp 10 True $ UnixTime 10 0 +sp20 = sp 20 True $ UnixTime 22 0 +sp21 = sp 21 True $ UnixTime 44 0 sp30 = sp 30 False $ UnixTime 50 0 -sp31 = sp 31 True $ UnixTime 51 0 +sp31 = sp 31 True $ UnixTime 51 0 sp32 = sp 32 False $ UnixTime 55 0 -sp33 = sp 33 True $ UnixTime 80 0 +sp33 = sp 33 True $ UnixTime 80 0 sp :: PacketNumber -> Bool -> TimeMicrosecond -> SentPacket -sp mypn ackeli tm = spkt { spTimeSent = tm } +sp mypn ackeli tm = spkt{spTimeSent = tm} where ppkt = PlainPacket (Short $ toCID "") (Plain (Flags 0) 0 [] 0) spkt = mkSentPacket mypn InitialLevel ppkt emptyPeerPacketNumbers ackeli diff --git a/test/TLSSpec.hs b/test/TLSSpec.hs --- a/test/TLSSpec.hs +++ b/test/TLSSpec.hs @@ -29,7 +29,9 @@ -- shared keys let dcID = makeCID (dec16s "8394c8f03e515708") let client_initial_secret@(ClientTrafficSecret cis) = clientInitialSecret ver dcID - client_initial_secret `shouldBe` ClientTrafficSecret (dec16 "c00cf151ca5be075ed0ebfb5c80323c42d6b7db67881289af4008f1f6c357aea") + client_initial_secret + `shouldBe` ClientTrafficSecret + (dec16 "c00cf151ca5be075ed0ebfb5c80323c42d6b7db67881289af4008f1f6c357aea") let ckey = aeadKey ver defaultCipher (Secret cis) ckey `shouldBe` Key (dec16 "1f369613dd76d5467730efcbe3b1a22d") let civ = initialVector ver defaultCipher (Secret cis) @@ -37,7 +39,9 @@ let chp = headerProtectionKey ver defaultCipher (Secret cis) chp `shouldBe` Key (dec16 "9f50449e04a0e810283a1e9933adedd2") let server_initial_secret@(ServerTrafficSecret sis) = serverInitialSecret ver dcID - server_initial_secret `shouldBe` ServerTrafficSecret (dec16 "3c199828fd139efd216c155ad844cc81fb82fa8d7446fa7d78be803acdda951b") + server_initial_secret + `shouldBe` ServerTrafficSecret + (dec16 "3c199828fd139efd216c155ad844cc81fb82fa8d7446fa7d78be803acdda951b") let skey = aeadKey ver defaultCipher (Secret sis) skey `shouldBe` Key (dec16 "cf3a5331653c364c88f0f379b6067e37") let siv = initialVector ver defaultCipher (Secret sis) @@ -62,19 +66,20 @@ -- 00 -- scid len -- 00 -- token length -- 449e -- length: decodeInt (dec16 "449e") - -- 1182 = 4 + 1162 + 16 (fixme) + -- 1182 = 4 + 1162 + 16 (fixme) -- 00000002 -- encoded packet number let bodyLen = fromIntegral $ decodeInt (dec16 "449e") - let padLen = bodyLen - - 4 -- packet number length - - 16 -- GCM encrypt expansion - - BS.length clientCRYPTOframe + let padLen = + bodyLen + - 4 -- packet number length + - 16 -- GCM encrypt expansion + - BS.length clientCRYPTOframe clientCRYPTOframePadded = clientCRYPTOframe `BS.append` BS.pack (replicate padLen 0) let plaintext = clientCRYPTOframePadded let nonce = makeNonce civ $ dec16 "00000002" let add = AssDat clientPacketHeader - let (hdr,bdy) = fromJust $ niteEncrypt' defaultCipher ckey nonce plaintext add + let (hdr, bdy) = fromJust $ niteEncrypt' defaultCipher ckey nonce plaintext add ciphertext = hdr `BS.append` bdy let plaintext' = fromJust $ niteDecrypt' defaultCipher ckey nonce ciphertext add plaintext' `shouldBe` plaintext @@ -106,15 +111,16 @@ -- 0001 -- encoded packet number let bodyLen = fromIntegral $ decodeInt (dec16 "4075") - let padLen = bodyLen - - 2 -- packet number length - - 16 -- GCM encrypt expansion - - BS.length serverCRYPTOframe + let padLen = + bodyLen + - 2 -- packet number length + - 16 -- GCM encrypt expansion + - BS.length serverCRYPTOframe serverCRYPTOframePadded = serverCRYPTOframe `BS.append` BS.pack (replicate padLen 0) let plaintext = serverCRYPTOframePadded let nonce = makeNonce siv $ dec16 "0001" let add = AssDat serverPacketHeader - let (hdr,bdy) = fromJust $ niteEncrypt' defaultCipher skey nonce plaintext add + let (hdr, bdy) = fromJust $ niteEncrypt' defaultCipher skey nonce plaintext add ciphertext = hdr `BS.append` bdy let plaintext' = fromJust $ niteDecrypt' defaultCipher skey nonce ciphertext add plaintext' `shouldBe` plaintext @@ -127,17 +133,18 @@ BS.take 5 mask `shouldBe` dec16 "2ec0d8356a" it "describes the examples of Retry" $ do - let wire0 = dec16 "ff000000010008f067a5502a4262b5746f6b656e04a265ba2eff4d829058fb3f0f2496ba" - (ipkt,rest) <- decodePacket wire0 + let wire0 = + dec16 "ff000000010008f067a5502a4262b5746f6b656e04a265ba2eff4d829058fb3f0f2496ba" + (ipkt, rest) <- decodePacket wire0 rest `shouldBe` "" case ipkt of - PacketIR retrypkt -> do - wire1 <- encodeRetryPacket retrypkt - let (f0,r0) = fromJust $ BS.uncons wire0 - (f1,r1) = fromJust $ BS.uncons wire1 - f0 .&. 0xf0 `shouldBe` f1 .&. 0xf0 - r0 `shouldBe` r1 - _ -> error "Retry version 1" + PacketIR retrypkt -> do + wire1 <- encodeRetryPacket retrypkt + let (f0, r0) = fromJust $ BS.uncons wire0 + (f1, r1) = fromJust $ BS.uncons wire1 + f0 .&. 0xf0 `shouldBe` f1 .&. 0xf0 + r0 `shouldBe` r1 + _ -> error "Retry version 1" describe "test vector for version 2" $ do let ver = Version2 @@ -146,7 +153,9 @@ -- shared keys let dcID = makeCID (dec16s "8394c8f03e515708") let client_initial_secret@(ClientTrafficSecret cis) = clientInitialSecret ver dcID - client_initial_secret `shouldBe` ClientTrafficSecret (dec16 "14ec9d6eb9fd7af83bf5a668bc17a7e283766aade7ecd0891f70f9ff7f4bf47b") + client_initial_secret + `shouldBe` ClientTrafficSecret + (dec16 "14ec9d6eb9fd7af83bf5a668bc17a7e283766aade7ecd0891f70f9ff7f4bf47b") let ckey = aeadKey ver defaultCipher (Secret cis) ckey `shouldBe` Key (dec16 "8b1a0bc121284290a29e0971b5cd045d") let civ = initialVector ver defaultCipher (Secret cis) @@ -154,7 +163,9 @@ let chp = headerProtectionKey ver defaultCipher (Secret cis) chp `shouldBe` Key (dec16 "45b95e15235d6f45a6b19cbcb0294ba9") let server_initial_secret@(ServerTrafficSecret sis) = serverInitialSecret ver dcID - server_initial_secret `shouldBe` ServerTrafficSecret (dec16 "0263db1782731bf4588e7e4d93b7463907cb8cd8200b5da55a8bd488eafc37c1") + server_initial_secret + `shouldBe` ServerTrafficSecret + (dec16 "0263db1782731bf4588e7e4d93b7463907cb8cd8200b5da55a8bd488eafc37c1") let skey = aeadKey ver defaultCipher (Secret sis) skey `shouldBe` Key (dec16 "82db637861d55e1d011f19ea71d5d2a7") let siv = initialVector ver defaultCipher (Secret sis) @@ -179,19 +190,20 @@ -- 00 -- scid len -- 00 -- token length -- 449e -- length: decodeInt (dec16 "449e") - -- 1182 = 4 + 1162 + 16 (fixme) + -- 1182 = 4 + 1162 + 16 (fixme) -- 00000002 -- encoded packet number let bodyLen = fromIntegral $ decodeInt (dec16 "449e") - let padLen = bodyLen - - 4 -- packet number length - - 16 -- GCM encrypt expansion - - BS.length clientCRYPTOframe + let padLen = + bodyLen + - 4 -- packet number length + - 16 -- GCM encrypt expansion + - BS.length clientCRYPTOframe clientCRYPTOframePadded = clientCRYPTOframe `BS.append` BS.pack (replicate padLen 0) let plaintext = clientCRYPTOframePadded let nonce = makeNonce civ $ dec16 "00000002" let add = AssDat clientPacketHeader - let (hdr,bdy) = fromJust $ niteEncrypt' defaultCipher ckey nonce plaintext add + let (hdr, bdy) = fromJust $ niteEncrypt' defaultCipher ckey nonce plaintext add ciphertext = hdr `BS.append` bdy let plaintext' = fromJust $ niteDecrypt' defaultCipher ckey nonce ciphertext add plaintext' `shouldBe` plaintext @@ -223,15 +235,16 @@ -- 0001 -- encoded packet number let bodyLen = fromIntegral $ decodeInt (dec16 "4075") - let padLen = bodyLen - - 2 -- packet number length - - 16 -- GCM encrypt expansion - - BS.length serverCRYPTOframe + let padLen = + bodyLen + - 2 -- packet number length + - 16 -- GCM encrypt expansion + - BS.length serverCRYPTOframe serverCRYPTOframePadded = serverCRYPTOframe `BS.append` BS.pack (replicate padLen 0) let plaintext = serverCRYPTOframePadded let nonce = makeNonce siv $ dec16 "0001" let add = AssDat serverPacketHeader - let (hdr,bdy) = fromJust $ niteEncrypt' defaultCipher skey nonce plaintext add + let (hdr, bdy) = fromJust $ niteEncrypt' defaultCipher skey nonce plaintext add ciphertext = hdr `BS.append` bdy let plaintext' = fromJust $ niteDecrypt' defaultCipher skey nonce ciphertext add plaintext' `shouldBe` plaintext @@ -244,35 +257,39 @@ BS.take 5 mask `shouldBe` dec16 "4dd92e91ea" it "describes the examples of Retry" $ do - let wire0 = dec16 "cf6b3343cf0008f067a5502a4262b5746f6b656ec8646ce8bfe33952d955543665dcc7b6" - (ipkt,rest) <- decodePacket wire0 + let wire0 = + dec16 "cf6b3343cf0008f067a5502a4262b5746f6b656ec8646ce8bfe33952d955543665dcc7b6" + (ipkt, rest) <- decodePacket wire0 rest `shouldBe` "" case ipkt of - PacketIR retrypkt -> do - wire1 <- encodeRetryPacket retrypkt - let (f0,r0) = fromJust $ BS.uncons wire0 - (f1,r1) = fromJust $ BS.uncons wire1 - f0 .&. 0xf0 `shouldBe` f1 .&. 0xf0 - r0 `shouldBe` r1 - _ -> error "Retry version 2" - + PacketIR retrypkt -> do + wire1 <- encodeRetryPacket retrypkt + let (f0, r0) = fromJust $ BS.uncons wire0 + (f1, r1) = fromJust $ BS.uncons wire1 + f0 .&. 0xf0 `shouldBe` f1 .&. 0xf0 + r0 `shouldBe` r1 + _ -> error "Retry version 2" serverCRYPTOframe :: BS.ByteString -serverCRYPTOframe = dec16 $ BS.concat [ - "02000000000600405a020000560303eefce7f7b37ba1d1632e96677825ddf739" - , "88cfc79825df566dc5430b9a045a1200130100002e00330024001d00209d3c94" - , "0d89690b84d08a60993c144eca684d1081287c834d5311bcf32bb9da1a002b00" - , "020304" - ] +serverCRYPTOframe = + dec16 $ + BS.concat + [ "02000000000600405a020000560303eefce7f7b37ba1d1632e96677825ddf739" + , "88cfc79825df566dc5430b9a045a1200130100002e00330024001d00209d3c94" + , "0d89690b84d08a60993c144eca684d1081287c834d5311bcf32bb9da1a002b00" + , "020304" + ] clientCRYPTOframe :: BS.ByteString -clientCRYPTOframe = dec16 $ BS.concat [ - "060040f1010000ed0303ebf8fa56f12939b9584a3896472ec40bb863cfd3e868" - , "04fe3a47f06a2b69484c00000413011302010000c000000010000e00000b6578" - , "616d706c652e636f6dff01000100000a00080006001d00170018001000070005" - , "04616c706e000500050100000000003300260024001d00209370b2c9caa47fba" - , "baf4559fedba753de171fa71f50f1ce15d43e994ec74d748002b000302030400" - , "0d0010000e0403050306030203080408050806002d00020101001c0002400100" - , "3900320408ffffffffffffffff05048000ffff07048000ffff08011001048000" - , "75300901100f088394c8f03e51570806048000ffff" - ] +clientCRYPTOframe = + dec16 $ + BS.concat + [ "060040f1010000ed0303ebf8fa56f12939b9584a3896472ec40bb863cfd3e868" + , "04fe3a47f06a2b69484c00000413011302010000c000000010000e00000b6578" + , "616d706c652e636f6dff01000100000a00080006001d00170018001000070005" + , "04616c706e000500050100000000003300260024001d00209370b2c9caa47fba" + , "baf4559fedba753de171fa71f50f1ce15d43e994ec74d748002b000302030400" + , "0d0010000e0403050306030203080408050806002d00020101001c0002400100" + , "3900320408ffffffffffffffff05048000ffff07048000ffff08011001048000" + , "75300901100f088394c8f03e51570806048000ffff" + ] diff --git a/test/TransportError.hs b/test/TransportError.hs --- a/test/TransportError.hs +++ b/test/TransportError.hs @@ -1,14 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} module TransportError ( - transportErrorSpec - ) where + transportErrorSpec, +) where import Control.Monad import Data.ByteString () import qualified Data.ByteString as BS import qualified Network.TLS as TLS -import Network.TLS.QUIC (ExtensionRaw(..)) +import Network.TLS.QUIC (ExtensionRaw (..)) import Test.Hspec import UnliftIO.Concurrent import UnliftIO.Timeout @@ -40,119 +40,184 @@ transportErrorSpec :: ClientConfig -> Millisecond -> SpecWith a transportErrorSpec cc0 ms = do describe "QUIC servers" $ do - it "MUST send FLOW_CONTROL_ERROR if a STREAM frame with a large offset is received [Transport 4.1]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated largeOffset - runCnoOp cc ms `shouldThrow` transportErrorsIn [FlowControlError] + it + "MUST send FLOW_CONTROL_ERROR if a STREAM frame with a large offset is received [Transport 4.1]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated largeOffset + runCnoOp cc ms `shouldThrow` transportErrorsIn [FlowControlError] it "MUST send STREAM_LIMIT_ERROR if a stream ID exceeding the limit" $ \_ -> do let cc = addHook cc0 $ setOnPlainCreated largeStreamId runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamLimitError] - it "MUST send TRANSPORT_PARAMETER_ERROR if initial_source_connection_id is missing [Transport 7.3]" $ \_ -> do - let cc = addHook cc0 $ setOnTransportParametersCreated dropInitialSourceConnectionId - runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] - it "MUST send TRANSPORT_PARAMETER_ERROR if original_destination_connection_id is received [Transport 18.2]" $ \_ -> do - let cc = addHook cc0 $ setOnTransportParametersCreated setOriginalDestinationConnectionId - runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] - it "MUST send TRANSPORT_PARAMETER_ERROR if preferred_address, is received [Transport 18.2]" $ \_ -> do - let cc = addHook cc0 $ setOnTransportParametersCreated setPreferredAddress - runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] - it "MUST send TRANSPORT_PARAMETER_ERROR if retry_source_connection_id is received [Transport 18.2]" $ \_ -> do - let cc = addHook cc0 $ setOnTransportParametersCreated setRetrySourceConnectionId - runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] - it "MUST send TRANSPORT_PARAMETER_ERROR if stateless_reset_token is received [Transport 18.2]" $ \_ -> do - let cc = addHook cc0 $ setOnTransportParametersCreated setStatelessResetToken - runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] - it "MUST send TRANSPORT_PARAMETER_ERROR if max_udp_payload_size < 1200 [Transport 7.4 and 18.2]" $ \_ -> do - let cc = addHook cc0 $ setOnTransportParametersCreated setMaxUdpPayloadSize - runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] - it "MUST send TRANSPORT_PARAMETER_ERROR if ack_delay_exponen > 20 [Transport 7.4 and 18.2]" $ \_ -> do - let cc = addHook cc0 $ setOnTransportParametersCreated setAckDelayExponent - runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] - it "MUST send TRANSPORT_PARAMETER_ERROR if max_ack_delay >= 2^14 [Transport 7.4 and 18.2]" $ \_ -> do - let cc = addHook cc0 $ setOnTransportParametersCreated setMaxAckDelay - runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] - it "MUST send FRAME_ENCODING_ERROR if a frame of unknown type is received [Transport 12.4]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated unknownFrame - runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if initial_source_connection_id is missing [Transport 7.3]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated dropInitialSourceConnectionId + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if original_destination_connection_id is received [Transport 18.2]" + $ \_ -> do + let cc = + addHook cc0 $ setOnTransportParametersCreated setOriginalDestinationConnectionId + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if preferred_address, is received [Transport 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setPreferredAddress + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if retry_source_connection_id is received [Transport 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setRetrySourceConnectionId + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if stateless_reset_token is received [Transport 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setStatelessResetToken + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if max_udp_payload_size < 1200 [Transport 7.4 and 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setMaxUdpPayloadSize + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if ack_delay_exponen > 20 [Transport 7.4 and 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setAckDelayExponent + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send TRANSPORT_PARAMETER_ERROR if max_ack_delay >= 2^14 [Transport 7.4 and 18.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTransportParametersCreated setMaxAckDelay + runCnoOp cc ms `shouldThrow` transportErrorsIn [TransportParameterError] + it + "MUST send FRAME_ENCODING_ERROR if a frame of unknown type is received [Transport 12.4]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated unknownFrame + runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] it "MUST send PROTOCOL_VIOLATION on no frames [Transport 12.4]" $ \_ -> do let cc = addHook cc0 $ setOnPlainCreated noFrames runCnoOp cc ms `shouldThrow` transportError - it "MUST send PROTOCOL_VIOLATION if reserved bits in Handshake are non-zero [Transport 17.2]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated $ rrBits HandshakeLevel - runCnoOp cc ms `shouldThrow` transportError - it "MUST send PROTOCOL_VIOLATION if PATH_CHALLENGE in Handshake is received [Transport 17.2.4]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated handshakePathChallenge - runCnoOp cc ms `shouldThrow` transportError - it "MUST send PROTOCOL_VIOLATION if reserved bits in Short are non-zero [Transport 17.2]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated $ rrBits RTT1Level - runCnoOp cc ms `shouldThrow` transportError - it "MUST send STREAM_STATE_ERROR if RESET_STREAM is received for a send-only stream [Transport 19.4]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated resetStrm - runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] - it "MUST send STREAM_STATE_ERROR if STOP_SENDING is received for a non-existing stream [Transport 19.5]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated stopSending - runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send PROTOCOL_VIOLATION if reserved bits in Handshake are non-zero [Transport 17.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated $ rrBits HandshakeLevel + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send PROTOCOL_VIOLATION if PATH_CHALLENGE in Handshake is received [Transport 17.2.4]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated handshakePathChallenge + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send PROTOCOL_VIOLATION if reserved bits in Short are non-zero [Transport 17.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated $ rrBits RTT1Level + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send STREAM_STATE_ERROR if RESET_STREAM is received for a send-only stream [Transport 19.4]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated resetStrm + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send STREAM_STATE_ERROR if STOP_SENDING is received for a non-existing stream [Transport 19.5]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated stopSending + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] it "MUST send PROTOCOL_VIOLATION if NEW_TOKEN is received [Transport 19.7]" $ \_ -> do let cc = addHook cc0 $ setOnPlainCreated newToken runCnoOp cc ms `shouldThrow` transportError - it "MUST send STREAM_STATE_ERROR if it receives a STREAM frame for a locally-initiated stream that has not yet been created [Transport 19.8]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated localInitiatedNotCreatedYet - runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] - it "MUST send STREAM_STATE_ERROR if it receives a STREAM frame for a send-only stream [Transport 19.8]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated sendOnlyStream - runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] - it "MUST send STREAM_STATE_ERROR if MAX_STREAM_DATA is received for a non-existing stream [Transport 19.10]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated maxStreamData - runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] - it "MUST send STREAM_STATE_ERROR if MAX_STREAM_DATA is received for a receive-only stream [Transport 19.10]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated maxStreamData2 - runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] - it "MUST send FRAME_ENCODING_ERROR if invalid MAX_STREAMS is received [Transport 19.11]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated maxStreams' - runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] - it "MUST send STREAM_LIMIT_ERROR or FRAME_ENCODING_ERROR if invalid STREAMS_BLOCKED is received [Transport 19.14]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated streamsBlocked - runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError,StreamLimitError] - it "MUST send FRAME_ENCODING_ERROR if NEW_CONNECTION_ID with invalid Retire_Prior_To is received [Transport 19.15]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated $ newConnectionID ncidLargeRPT - runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] - it "MUST send FRAME_ENCODING_ERROR if NEW_CONNECTION_ID with 0-byte CID is received [Transport 19.15]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated $ newConnectionID ncidZeroCID - runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] - it "MUST send PROTOCOL_VIOLATION if HANDSHAKE_DONE is received [Transport 19.20]" $ \_ -> do - let cc = addHook cc0 $ setOnPlainCreated handshakeDone - runCnoOp cc ms `shouldThrow` transportError - it "MUST send unexpected_message TLS alert if KeyUpdate in Handshake is received [TLS 6]" $ \_ -> do - let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoKeyUpdate - runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage] - it "MUST send unexpected_message TLS alert if KeyUpdate in 1-RTT is received [TLS 6]" $ \_ -> do - let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoKeyUpdate2 - runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage] - it "MUST send no_application_protocol TLS alert if no application protocols are supported [TLS 8.1]" $ \_ -> do - let cc = cc0 { ccALPN = \_ -> return $ Just ["dummy"] } - runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.NoApplicationProtocol] - it "MUST send missing_extension TLS alert if the quic_transport_parameters extension does not included [TLS 8.2]" $ \_ -> do - let cc = addHook cc0 $ setOnTLSExtensionCreated (const []) - runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.MissingExtension] - it "MUST send missing_extension TLS alert if the quic_transport_parameters extension does not included [TLS 8.2]" $ \_ -> do - let f [ExtensionRaw _ v] = [ExtensionRaw 0xffa5 v] - f _ = error "f" - cc = addHook cc0 $ setOnTLSExtensionCreated f - runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.MissingExtension] - it "MUST send unexpected_message TLS alert if EndOfEarlyData is received [TLS 8.3]" $ \_ -> do - let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoEndOfEarlyData - runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage] + it + "MUST send STREAM_STATE_ERROR if it receives a STREAM frame for a locally-initiated stream that has not yet been created [Transport 19.8]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated localInitiatedNotCreatedYet + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send STREAM_STATE_ERROR if it receives a STREAM frame for a send-only stream [Transport 19.8]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated sendOnlyStream + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send STREAM_STATE_ERROR if MAX_STREAM_DATA is received for a non-existing stream [Transport 19.10]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated maxStreamData + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send STREAM_STATE_ERROR if MAX_STREAM_DATA is received for a receive-only stream [Transport 19.10]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated maxStreamData2 + runCnoOp cc ms `shouldThrow` transportErrorsIn [StreamStateError] + it + "MUST send FRAME_ENCODING_ERROR if invalid MAX_STREAMS is received [Transport 19.11]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated maxStreams' + runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] + it + "MUST send STREAM_LIMIT_ERROR or FRAME_ENCODING_ERROR if invalid STREAMS_BLOCKED is received [Transport 19.14]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated streamsBlocked + runCnoOp cc ms + `shouldThrow` transportErrorsIn [FrameEncodingError, StreamLimitError] + it + "MUST send FRAME_ENCODING_ERROR if NEW_CONNECTION_ID with invalid Retire_Prior_To is received [Transport 19.15]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated $ newConnectionID ncidLargeRPT + runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] + it + "MUST send FRAME_ENCODING_ERROR if NEW_CONNECTION_ID with 0-byte CID is received [Transport 19.15]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated $ newConnectionID ncidZeroCID + runCnoOp cc ms `shouldThrow` transportErrorsIn [FrameEncodingError] + it + "MUST send PROTOCOL_VIOLATION if HANDSHAKE_DONE is received [Transport 19.20]" + $ \_ -> do + let cc = addHook cc0 $ setOnPlainCreated handshakeDone + runCnoOp cc ms `shouldThrow` transportError + it + "MUST send unexpected_message TLS alert if KeyUpdate in Handshake is received [TLS 6]" + $ \_ -> do + let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoKeyUpdate + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage] + it + "MUST send unexpected_message TLS alert if KeyUpdate in 1-RTT is received [TLS 6]" + $ \_ -> do + let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoKeyUpdate2 + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage] + it + "MUST send no_application_protocol TLS alert if no application protocols are supported [TLS 8.1]" + $ \_ -> do + let cc = cc0{ccALPN = \_ -> return $ Just ["dummy"]} + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.NoApplicationProtocol] + it + "MUST send missing_extension TLS alert if the quic_transport_parameters extension does not included [TLS 8.2]" + $ \_ -> do + let cc = addHook cc0 $ setOnTLSExtensionCreated (const []) + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.MissingExtension] + it + "MUST send missing_extension TLS alert if the quic_transport_parameters extension does not included [TLS 8.2]" + $ \_ -> do + let f [ExtensionRaw _ v] = [ExtensionRaw 0xffa5 v] + f _ = error "f" + cc = addHook cc0 $ setOnTLSExtensionCreated f + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.MissingExtension] + it + "MUST send unexpected_message TLS alert if EndOfEarlyData is received [TLS 8.3]" + $ \_ -> do + let cc = addHook cc0 $ setOnTLSHandshakeCreated cryptoEndOfEarlyData + runCnoOp cc ms `shouldThrow` cryptoErrorsIn [TLS.UnexpectedMessage] it "MUST send PROTOCOL_VIOLATION if CRYPTO in 0-RTT is received [TLS 8.3]" $ \_ -> do mres <- runC cc0 ms getResumptionInfo case mres of - Just res - | is0RTTPossible res -> do - let cc1 = addHook cc0 $ setOnTLSHandshakeCreated crypto0RTT - cc = cc1 { ccResumption = res - , ccUse0RTT = True - } - runCnoOp cc ms `shouldThrow` transportError - _ -> do - putStrLn "Warning: 0-RTT is not possible. Skipping this test. Use \"h3spec -s 0-RTT\" next time." + Just res + | is0RTTPossible res -> do + let cc1 = addHook cc0 $ setOnTLSHandshakeCreated crypto0RTT + cc = + cc1 + { ccResumption = res + , ccUse0RTT = True + } + runCnoOp cc ms `shouldThrow` transportError + _ -> do + putStrLn + "Warning: 0-RTT is not possible. Skipping this test. Use \"h3spec -s 0-RTT\" next time." when (ccDebugLog cc0) $ print mres ---------------------------------------------------------------- @@ -160,159 +225,187 @@ addHook :: ClientConfig -> (Hooks -> Hooks) -> ClientConfig addHook cc modify = cc' where - cc' = cc { ccHooks = modify $ ccHooks cc } + cc' = cc{ccHooks = modify $ ccHooks cc} setOnPlainCreated :: (EncryptionLevel -> Plain -> Plain) -> Hooks -> Hooks -setOnPlainCreated f hooks = hooks { onPlainCreated = f } +setOnPlainCreated f hooks = hooks{onPlainCreated = f} setOnTransportParametersCreated :: (Parameters -> Parameters) -> Hooks -> Hooks -setOnTransportParametersCreated f hooks = hooks { onTransportParametersCreated = f } +setOnTransportParametersCreated f hooks = hooks{onTransportParametersCreated = f} setOnTLSExtensionCreated :: ([ExtensionRaw] -> [ExtensionRaw]) -> Hooks -> Hooks -setOnTLSExtensionCreated f params = params { onTLSExtensionCreated = f } +setOnTLSExtensionCreated f params = params{onTLSExtensionCreated = f} -setOnTLSHandshakeCreated :: ([(EncryptionLevel,CryptoData)] -> ([(EncryptionLevel,CryptoData)],Bool)) -> Hooks -> Hooks -setOnTLSHandshakeCreated f hooks = hooks { onTLSHandshakeCreated = f } +setOnTLSHandshakeCreated + :: ([(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool)) + -> Hooks + -> Hooks +setOnTLSHandshakeCreated f hooks = hooks{onTLSHandshakeCreated = f} ---------------------------------------------------------------- rrBits :: EncryptionLevel -> EncryptionLevel -> Plain -> Plain rrBits lvl0 lvl plain - | lvl0 == lvl = if plainPacketNumber plain /= 0 then - plain { plainFlags = Flags 0x08 } - else - plain - | otherwise = plain + | lvl0 == lvl = + if plainPacketNumber plain /= 0 + then plain{plainFlags = Flags 0x08} + else plain + | otherwise = plain dropInitialSourceConnectionId :: Parameters -> Parameters -dropInitialSourceConnectionId params = params { initialSourceConnectionId = Nothing } +dropInitialSourceConnectionId params = params{initialSourceConnectionId = Nothing} dummyCID :: Maybe CID dummyCID = Just $ toCID "DUMMY" setOriginalDestinationConnectionId :: Parameters -> Parameters -setOriginalDestinationConnectionId params = params { originalDestinationConnectionId = dummyCID } +setOriginalDestinationConnectionId params = params{originalDestinationConnectionId = dummyCID} setPreferredAddress :: Parameters -> Parameters -setPreferredAddress params = params { preferredAddress = Just prefAddr } +setPreferredAddress params = params{preferredAddress = Just prefAddr} where - prefAddr = BS.concat - [ "\x7f\x00\x00\x01" - , "\x01\xbb" - , "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00" - , "\x00\x00" - , "\x08" - , "\x00\x01\x02\x03\x04\x05\x06\x07" - , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f" - ] + prefAddr = + BS.concat + [ "\x7f\x00\x00\x01" + , "\x01\xbb" + , "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00" + , "\x00\x00" + , "\x08" + , "\x00\x01\x02\x03\x04\x05\x06\x07" + , "\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\x0f" + ] setRetrySourceConnectionId :: Parameters -> Parameters -setRetrySourceConnectionId params = params { retrySourceConnectionId = dummyCID } +setRetrySourceConnectionId params = params{retrySourceConnectionId = dummyCID} setStatelessResetToken :: Parameters -> Parameters -setStatelessResetToken params = params { statelessResetToken = Just $ StatelessResetToken "DUMMY" } +setStatelessResetToken params = params{statelessResetToken = Just $ StatelessResetToken "DUMMY"} ---------------------------------------------------------------- setMaxUdpPayloadSize :: Parameters -> Parameters -setMaxUdpPayloadSize params = params { maxUdpPayloadSize = 1090 } +setMaxUdpPayloadSize params = params{maxUdpPayloadSize = 1090} setAckDelayExponent :: Parameters -> Parameters -setAckDelayExponent params = params { ackDelayExponent = 30 } +setAckDelayExponent params = params{ackDelayExponent = 30} setMaxAckDelay :: Parameters -> Parameters -setMaxAckDelay params = params { maxAckDelay = 2^(15 :: Int) } +setMaxAckDelay params = params{maxAckDelay = 2 ^ (15 :: Int)} ---------------------------------------------------------------- largeOffset :: EncryptionLevel -> Plain -> Plain largeOffset lvl plain - | lvl == RTT1Level = plain { plainFrames = fake : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = plain{plainFrames = fake : plainFrames plain} + | otherwise = plain where fake = StreamF 0 100000000 ["GET /\r\n"] True largeStreamId :: EncryptionLevel -> Plain -> Plain largeStreamId lvl plain - | lvl == RTT1Level = plain { plainFrames = fake : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = plain{plainFrames = fake : plainFrames plain} + | otherwise = plain where fake = StreamF 1000000000 0 ["GET /\r\n"] True unknownFrame :: EncryptionLevel -> Plain -> Plain unknownFrame lvl plain - | lvl == RTT1Level = plain { plainFrames = UnknownFrame 0x20 : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain{plainFrames = UnknownFrame 0x20 : plainFrames plain} + | otherwise = plain handshakePathChallenge :: EncryptionLevel -> Plain -> Plain handshakePathChallenge lvl plain - | lvl == HandshakeLevel = plain { plainFrames = PathChallenge (PathData "01234567") : plainFrames plain } - | otherwise = plain + | lvl == HandshakeLevel = + plain{plainFrames = PathChallenge (PathData "01234567") : plainFrames plain} + | otherwise = plain noFrames :: EncryptionLevel -> Plain -> Plain noFrames lvl plain - | lvl == RTT1Level = plain { plainFrames = [], plainMarks = set4bytesPN $ setNoPaddings $ plainMarks plain } - | otherwise = plain + | lvl == RTT1Level = + plain + { plainFrames = [] + , plainMarks = set4bytesPN $ setNoPaddings $ plainMarks plain + } + | otherwise = plain handshakeDone :: EncryptionLevel -> Plain -> Plain handshakeDone lvl plain - | lvl == RTT1Level = plain { plainFrames = HandshakeDone : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = plain{plainFrames = HandshakeDone : plainFrames plain} + | otherwise = plain newToken :: EncryptionLevel -> Plain -> Plain newToken lvl plain - | lvl == RTT1Level = plain { plainFrames = NewToken "DUMMY" : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain{plainFrames = NewToken "DUMMY" : plainFrames plain} + | otherwise = plain localInitiatedNotCreatedYet :: EncryptionLevel -> Plain -> Plain localInitiatedNotCreatedYet lvl plain - | lvl == RTT1Level = plain { plainFrames = StreamF 1 0 [""] False : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain{plainFrames = StreamF 1 0 [""] False : plainFrames plain} + | otherwise = plain sendOnlyStream :: EncryptionLevel -> Plain -> Plain sendOnlyStream lvl plain - | lvl == RTT1Level = plain { plainFrames = StreamF 3 0 [""] False : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain{plainFrames = StreamF 3 0 [""] False : plainFrames plain} + | otherwise = plain resetStrm :: EncryptionLevel -> Plain -> Plain resetStrm lvl plain - | lvl == RTT1Level = plain { plainFrames = ResetStream 3 (ApplicationProtocolError 0) 0 : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain + { plainFrames = ResetStream 3 (ApplicationProtocolError 0) 0 : plainFrames plain + } + | otherwise = plain stopSending :: EncryptionLevel -> Plain -> Plain stopSending lvl plain - | lvl == RTT1Level = plain { plainFrames = StopSending 101 (ApplicationProtocolError 0) : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain + { plainFrames = StopSending 101 (ApplicationProtocolError 0) : plainFrames plain + } + | otherwise = plain maxStreamData :: EncryptionLevel -> Plain -> Plain maxStreamData lvl plain - | lvl == RTT1Level = plain { plainFrames = MaxStreamData 101 1000000 : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain{plainFrames = MaxStreamData 101 1000000 : plainFrames plain} + | otherwise = plain maxStreamData2 :: EncryptionLevel -> Plain -> Plain maxStreamData2 lvl plain - | lvl == RTT1Level = plain { plainFrames = MaxStreamData 2 1000000 : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain{plainFrames = MaxStreamData 2 1000000 : plainFrames plain} + | otherwise = plain maxStreams' :: EncryptionLevel -> Plain -> Plain maxStreams' lvl plain - | lvl == RTT1Level = plain { plainFrames = MaxStreams Bidirectional (2^(60 :: Int) + 1) : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain + { plainFrames = MaxStreams Bidirectional (2 ^ (60 :: Int) + 1) : plainFrames plain + } + | otherwise = plain streamsBlocked :: EncryptionLevel -> Plain -> Plain streamsBlocked lvl plain - | lvl == RTT1Level = plain { plainFrames = StreamsBlocked Bidirectional (2^(60 :: Int) + 1) : plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = + plain + { plainFrames = + StreamsBlocked Bidirectional (2 ^ (60 :: Int) + 1) : plainFrames plain + } + | otherwise = plain newConnectionID :: (Frame -> Frame) -> EncryptionLevel -> Plain -> Plain newConnectionID f lvl plain - | lvl == RTT1Level = plain { plainFrames = map f $ plainFrames plain } - | otherwise = plain + | lvl == RTT1Level = plain{plainFrames = map f $ plainFrames plain} + | otherwise = plain ncidZeroCID :: Frame -> Frame ncidZeroCID (NewConnectionID cidinfo0 rpt) = NewConnectionID cidinfo rpt where - cidinfo = cidinfo0 { cidInfoCID = CID "" } + cidinfo = cidinfo0{cidInfoCID = CID ""} ncidZeroCID frame = frame ncidLargeRPT :: Frame -> Frame @@ -321,22 +414,26 @@ ---------------------------------------------------------------- -cryptoKeyUpdate :: [(EncryptionLevel,CryptoData)] -> ([(EncryptionLevel,CryptoData)],Bool) -cryptoKeyUpdate [(HandshakeLevel,fin)] = ([(HandshakeLevel,BS.append fin "\x18\x00\x00\x01\x01")],False) -cryptoKeyUpdate lcs = (lcs,False) +cryptoKeyUpdate + :: [(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool) +cryptoKeyUpdate [(HandshakeLevel, fin)] = ([(HandshakeLevel, BS.append fin "\x18\x00\x00\x01\x01")], False) +cryptoKeyUpdate lcs = (lcs, False) -cryptoKeyUpdate2 :: [(EncryptionLevel,CryptoData)] -> ([(EncryptionLevel,CryptoData)],Bool) +cryptoKeyUpdate2 + :: [(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool) -- [] is intentionally created in RTT1Level for h3spec -cryptoKeyUpdate2 [] = ([(RTT1Level,"\x18\x00\x00\x01\x01")],False) -cryptoKeyUpdate2 lcs = (lcs,False) +cryptoKeyUpdate2 [] = ([(RTT1Level, "\x18\x00\x00\x01\x01")], False) +cryptoKeyUpdate2 lcs = (lcs, False) -cryptoEndOfEarlyData :: [(EncryptionLevel,CryptoData)] -> ([(EncryptionLevel,CryptoData)],Bool) -cryptoEndOfEarlyData [(HandshakeLevel,fin)] = ([(HandshakeLevel,BS.append "\x05\x00\x00\x00" fin)],False) -cryptoEndOfEarlyData lcs = (lcs,False) +cryptoEndOfEarlyData + :: [(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool) +cryptoEndOfEarlyData [(HandshakeLevel, fin)] = ([(HandshakeLevel, BS.append "\x05\x00\x00\x00" fin)], False) +cryptoEndOfEarlyData lcs = (lcs, False) -crypto0RTT :: [(EncryptionLevel,CryptoData)] -> ([(EncryptionLevel,CryptoData)],Bool) -crypto0RTT [(InitialLevel,ch)] = ([(InitialLevel,ch),(RTT0Level,"\x08\x00\x00\x02\x00\x00")],True) -crypto0RTT lcs = (lcs,False) +crypto0RTT + :: [(EncryptionLevel, CryptoData)] -> ([(EncryptionLevel, CryptoData)], Bool) +crypto0RTT [(InitialLevel, ch)] = ([(InitialLevel, ch), (RTT0Level, "\x08\x00\x00\x02\x00\x00")], True) +crypto0RTT lcs = (lcs, False) ---------------------------------------------------------------- @@ -351,7 +448,7 @@ -- of specific error codes. transportErrorsIn :: [TransportError] -> QUICException -> Bool transportErrorsIn tes qe@(TransportErrorIsReceived te _) = (te `elem` tes) || transportError qe -transportErrorsIn _ _ = False +transportErrorsIn _ _ = False cryptoErrorX :: QUICException -> Bool cryptoErrorX (TransportErrorIsReceived te _) = te `elem` [cryptoError TLS.InternalError, cryptoError TLS.HandshakeFailure] @@ -365,4 +462,4 @@ -- information. cryptoErrorsIn :: [TLS.AlertDescription] -> QUICException -> Bool cryptoErrorsIn tes qe@(TransportErrorIsReceived te _) = (te `elem` map cryptoError tes) || cryptoErrorX qe -cryptoErrorsIn _ _ = False +cryptoErrorsIn _ _ = False diff --git a/test/TypesSpec.hs b/test/TypesSpec.hs --- a/test/TypesSpec.hs +++ b/test/TypesSpec.hs @@ -10,6 +10,8 @@ spec = do describe "toAckInfo and fromAckInfo" $ do it "should be dual" $ property $ \xs -> do - let rs = nub . sort . map (getSmall . getNonNegative) . getNonEmpty $ (xs :: NonEmptyList (NonNegative (Small PacketNumber))) + let rs = + nub . sort . map (getSmall . getNonNegative) . getNonEmpty $ + (xs :: NonEmptyList (NonNegative (Small PacketNumber))) rs' = reverse rs fromAckInfo (toAckInfo rs') `shouldBe` rs diff --git a/util/ClientX.hs b/util/ClientX.hs --- a/util/ClientX.hs +++ b/util/ClientX.hs @@ -13,13 +13,13 @@ import H3 import Network.QUIC -data Aux = Aux { - auxPath :: String - , auxAuthority :: String - , auxDebug :: String -> IO () - , auxShow :: ByteString -> IO () - , auxCheckClose :: IO Bool - } +data Aux = Aux + { auxPath :: String + , auxAuthority :: String + , auxDebug :: String -> IO () + , auxShow :: ByteString -> IO () + , auxCheckClose :: IO Bool + } type Cli = Aux -> Connection -> IO () @@ -49,13 +49,13 @@ s6 <- unidirectionalStream conn s10 <- unidirectionalStream conn -- 0: control, 4 settings - sendStream s2 (BS.pack [0,4,8,1,80,0,6,128,0,128,0]) + sendStream s2 (BS.pack [0, 4, 8, 1, 80, 0, 6, 128, 0, 128, 0]) -- 2: from encoder to decoder sendStream s6 (BS.pack [2]) -- 3: from decoder to encoder sendStream s10 (BS.pack [3]) loop n0 hdrblk - where + where loop 0 _ = auxDebug "Connection finished" loop 1 hdrblk = do auxDebug "GET" @@ -74,13 +74,14 @@ consume :: Aux -> Stream -> IO () consume aux@Aux{..} s = do bs <- recvStream s 1024 - if bs == "" then do - auxDebug "Fin received" - closeStream s - else do - auxShow bs - auxDebug $ show (BS.length bs) ++ " bytes received" - consume aux s + if bs == "" + then do + auxDebug "Fin received" + closeStream s + else do + auxShow bs + auxDebug $ show (BS.length bs) ++ " bytes received" + consume aux s clientPF :: Word64 -> Cli clientPF n Aux{..} conn = do @@ -92,9 +93,10 @@ where loop s = do bs <- recvStream s 1024 - if bs == "" then do - auxDebug "Connection finished" - closeStream s - else do - auxShow bs - loop s + if bs == "" + then do + auxDebug "Connection finished" + closeStream s + else do + auxShow bs + loop s diff --git a/util/Common.hs b/util/Common.hs --- a/util/Common.hs +++ b/util/Common.hs @@ -1,10 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} module Common ( - getGroups - , getLogger - , makeProtos - ) where + getGroups, + getLogger, + makeProtos, +) where import Data.Bits import Data.ByteString (ByteString) @@ -22,32 +22,32 @@ , ("ffdhe4096", FFDHE4096) , ("ffdhe6144", FFDHE6144) , ("ffdhe8192", FFDHE8192) - , ("p256", P256) - , ("p384", P384) - , ("p521", P521) - , ("x25519", X25519) - , ("x448", X448) + , ("p256", P256) + , ("p384", P384) + , ("p521", P521) + , ("x25519", X25519) + , ("x448", X448) ] getGroups :: [Group] -> Maybe String -> [Group] -getGroups grps Nothing = grps -getGroups _ (Just gs) = mapMaybe (`lookup` namedGroups) $ split ',' gs +getGroups grps Nothing = grps +getGroups _ (Just gs) = mapMaybe (`lookup` namedGroups) $ split ',' gs split :: Char -> String -> [String] split _ "" = [] -split c s = case break (c==) s of - ("",r) -> split c (tail r) - (s',"") -> [s'] - (s',r) -> s' : split c (tail r) +split c s = case break (c ==) s of + ("", r) -> split c (tail r) + (s', "") -> [s'] + (s', r) -> s' : split c (tail r) getLogger :: Maybe FilePath -> (String -> IO ()) -getLogger Nothing = \_ -> return () +getLogger Nothing = \_ -> return () getLogger (Just file) = \msg -> appendFile file (msg ++ "\n") makeProtos :: Version -> (ByteString, ByteString) -makeProtos Version1 = ("h3","hq-interop") -makeProtos Version2 = ("h3","hq-interop") -makeProtos ver = (h3X,hqX) +makeProtos Version1 = ("h3", "hq-interop") +makeProtos Version2 = ("h3", "hq-interop") +makeProtos ver = (h3X, hqX) where verbs = C8.pack $ show $ fromVersion ver h3X = "h3-" `BS.append` verbs diff --git a/util/H3.hs b/util/H3.hs --- a/util/H3.hs +++ b/util/H3.hs @@ -4,11 +4,11 @@ {-# LANGUAGE StrictData #-} module H3 ( - qpackClient - , qpackServer - , taglen - , html - ) where + qpackClient, + qpackServer, + taglen, + html, +) where import Data.Bits import Data.ByteString (ByteString) @@ -25,37 +25,41 @@ qpackServer :: IO ByteString qpackServer = do let status = 0b11000000 .|. 25 -- :status: 200 - ct = 0b11000000 .|. 52 -- content-type: text/html; charset=utf8 + ct = 0b11000000 .|. 52 -- content-type: text/html; charset=utf8 server <- encStr 92 name - return $ BS.concat [BS.pack[0,0,status,ct],server] + return $ BS.concat [BS.pack [0, 0, status, ct], server] qpackClient :: String -> String -> IO ByteString qpackClient path authority = do let method = 0b11000000 .|. 17 -- :method: GET scheme = 0b11000000 .|. 22 -- :scheme: http - path' <- encStr 1 $ C8.pack path - auth <- encStr 0 $ C8.pack authority - ua <- encStr 95 name - return $ BS.concat [BS.pack [0,0,method,scheme] - ,path' - ,auth - ,ua] + path' <- encStr 1 $ C8.pack path + auth <- encStr 0 $ C8.pack authority + ua <- encStr 95 name + return $ + BS.concat + [ BS.pack [0, 0, method, scheme] + , path' + , auth + , ua + ] encStr :: Int -> ByteString -> IO ByteString encStr idx val = do k <- setQpackTag 0b01010000 <$> encodeInteger 4 idx v <- encodeHuffman val vlen <- setQpackTag 0b10000000 <$> encodeInteger 7 (BS.length v) - return $ BS.concat [k,vlen,v] + return $ BS.concat [k, vlen, v] setQpackTag :: Word8 -> ByteString -> ByteString setQpackTag tag bs = BS.cons (tag .|. BS.head bs) (BS.tail bs) taglen :: Word8 -> ByteString -> ByteString -taglen i bs = BS.concat [tag,len,bs] +taglen i bs = BS.concat [tag, len, bs] where tag = BS.singleton i len = encodeInt $ fromIntegral $ BS.length bs html :: ByteString -html = "Welcome to QUIC in Haskell

Welcome to QUIC in Haskell. This server asks clients to retry if no token/retry_token is provided. HTTP 0.9, HTTP/3 and QPACK implementations are a toy and hard-coded. No path validation at this moment.

" +html = + "Welcome to QUIC in Haskell

Welcome to QUIC in Haskell. This server asks clients to retry if no token/retry_token is provided. HTTP 0.9, HTTP/3 and QPACK implementations are a toy and hard-coded. No path validation at this moment.

" diff --git a/util/ServerX.hs b/util/ServerX.hs --- a/util/ServerX.hs +++ b/util/ServerX.hs @@ -12,9 +12,9 @@ import Network.ByteOrder import qualified UnliftIO.Exception as E +import H3 import Network.QUIC import Network.QUIC.Internal -import H3 serverHQ :: Connection -> IO () serverHQ conn = connDebugLog conn "Connection terminated" `onE` body @@ -28,20 +28,21 @@ closeStream s serverH3 :: Connection -> IO () -serverH3 conn = connDebugLog conn "Connection terminated" `onE` do - s3 <- unidirectionalStream conn - s7 <- unidirectionalStream conn - s11 <- unidirectionalStream conn - -- 0: control, 4 settings - sendStream s3 (BS.pack [0,4,8,1,80,0,6,128,0,128,0]) - -- 2: from encoder to decoder - sendStream s7 (BS.pack [2]) - -- 3: from decoder to encoder - sendStream s11 (BS.pack [3]) - hdrblock <- taglen 1 <$> qpackServer - let bdyblock = taglen 0 html - hdrbdy = [hdrblock,bdyblock] - loop hdrbdy +serverH3 conn = + connDebugLog conn "Connection terminated" `onE` do + s3 <- unidirectionalStream conn + s7 <- unidirectionalStream conn + s11 <- unidirectionalStream conn + -- 0: control, 4 settings + sendStream s3 (BS.pack [0, 4, 8, 1, 80, 0, 6, 128, 0, 128, 0]) + -- 2: from encoder to decoder + sendStream s7 (BS.pack [2]) + -- 3: from decoder to encoder + sendStream s11 (BS.pack [3]) + hdrblock <- taglen 1 <$> qpackServer + let bdyblock = taglen 0 html + hdrbdy = [hdrblock, bdyblock] + loop hdrbdy where loop hdrbdy = do s <- acceptStream conn @@ -54,20 +55,21 @@ loop hdrbdy serverPF :: Connection -> IO () -serverPF conn = connDebugLog conn "Connection terminated" `onE` do - s <- acceptStream conn - let sid = streamId s - when (isClientInitiatedBidirectional sid) $ do - bs <- recvStream s 8 - n <- withReadBuffer bs read64 - loop s n - closeStream s +serverPF conn = + connDebugLog conn "Connection terminated" `onE` do + s <- acceptStream conn + let sid = streamId s + when (isClientInitiatedBidirectional sid) $ do + bs <- recvStream s 8 + n <- withReadBuffer bs read64 + loop s n + closeStream s where bs1024 = BS.replicate 1024 65 loop _ 0 = return () loop s n - | n < 1024 = sendStream s $ BS.replicate (fromIntegral n) 65 - | otherwise = do + | n < 1024 = sendStream s $ BS.replicate (fromIntegral n) 65 + | otherwise = do sendStream s bs1024 loop s (n - 1024) @@ -76,11 +78,11 @@ where loop = do bs <- recvStream s 1024 - if bs == "" then - connDebugLog conn "FIN received" - else do - connDebugLog conn $ byteString bs - loop + if bs == "" + then connDebugLog conn "FIN received" + else do + connDebugLog conn $ byteString bs + loop onE :: IO b -> IO a -> IO a h `onE` b = b `E.onException` h diff --git a/util/client.hs b/util/client.hs --- a/util/client.hs +++ b/util/client.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Strict #-} @@ -26,118 +27,162 @@ import Network.QUIC.Client import Network.QUIC.Internal hiding (RTT0) -data Options = Options { - optDebugLog :: Bool - , optShow :: Bool - , optQLogDir :: Maybe FilePath - , optKeyLogFile :: Maybe FilePath - , optGroups :: Maybe String - , optValidate :: Bool - , optHQ :: Bool - , optVerNego :: Bool - , optResumption :: Bool - , opt0RTT :: Bool - , optRetry :: Bool - , optQuantum :: Bool - , optInteractive :: Bool - , optMigration :: Maybe ConnectionControl - , optPacketSize :: Maybe Int - , optPerformance :: Word64 - , optNumOfReqs :: Int - , optUnconSock :: Bool - } deriving Show +data Options = Options + { optDebugLog :: Bool + , optShow :: Bool + , optQLogDir :: Maybe FilePath + , optKeyLogFile :: Maybe FilePath + , optGroups :: Maybe String + , optValidate :: Bool + , optHQ :: Bool + , optVerNego :: Bool + , optResumption :: Bool + , opt0RTT :: Bool + , optRetry :: Bool + , optQuantum :: Bool + , optInteractive :: Bool + , optMigration :: Maybe ConnectionControl + , optPacketSize :: Maybe Int + , optPerformance :: Word64 + , optNumOfReqs :: Int + , optUnconSock :: Bool + } + deriving (Show) defaultOptions :: Options -defaultOptions = Options { - optDebugLog = False - , optShow = False - , optQLogDir = Nothing - , optKeyLogFile = Nothing - , optGroups = Nothing - , optHQ = False - , optValidate = False - , optVerNego = False - , optResumption = False - , opt0RTT = False - , optRetry = False - , optQuantum = False - , optInteractive = False - , optMigration = Nothing - , optPacketSize = Nothing - , optPerformance = 0 - , optNumOfReqs = 1 - , optUnconSock = True - } +defaultOptions = + Options + { optDebugLog = False + , optShow = False + , optQLogDir = Nothing + , optKeyLogFile = Nothing + , optGroups = Nothing + , optHQ = False + , optValidate = False + , optVerNego = False + , optResumption = False + , opt0RTT = False + , optRetry = False + , optQuantum = False + , optInteractive = False + , optMigration = Nothing + , optPacketSize = Nothing + , optPerformance = 0 + , optNumOfReqs = 1 + , optUnconSock = True + } usage :: String usage = "Usage: client [OPTION] addr port" options :: [OptDescr (Options -> Options)] -options = [ - Option ['d'] ["debug"] - (NoArg (\o -> o { optDebugLog = True })) - "print debug info" - , Option ['v'] ["show-content"] - (NoArg (\o -> o { optShow = True })) - "print downloaded content" - , Option ['q'] ["qlog-dir"] - (ReqArg (\dir o -> o { optQLogDir = Just dir }) "") - "directory to store qlog" - , Option ['l'] ["key-log-file"] - (ReqArg (\file o -> o { optKeyLogFile = Just file }) "") - "a file to store negotiated secrets" - , Option ['g'] ["groups"] - (ReqArg (\gs o -> o { optGroups = Just gs }) "") - "specify groups" - , Option ['c'] ["validate"] - (NoArg (\o -> o { optValidate = True })) - "validate server's certificate" - , Option ['r'] ["hq"] - (NoArg (\o -> o { optHQ = True })) - "prefer hq (HTTP/0.9)" - , Option ['s'] ["packet-size"] - (ReqArg (\n o -> o { optPacketSize = Just (read n) }) "") - "specify QUIC packet size (UDP payload size)" - , Option ['i'] ["interactive"] - (NoArg (\o -> o { optInteractive = True })) - "prefer hq (HTTP/0.9)" - , Option ['V'] ["vernego"] - (NoArg (\o -> o { optVerNego = True })) - "try version negotiation" - , Option ['R'] ["resumption"] - (NoArg (\o -> o { optResumption = True })) - "try session resumption" - , Option ['Z'] ["0rtt"] - (NoArg (\o -> o { opt0RTT = True })) - "try sending early data" - , Option ['S'] ["stateless-retry"] - (NoArg (\o -> o { optRetry = True })) - "check stateless retry" - , Option ['Q'] ["quantum"] - (NoArg (\o -> o { optQuantum = True })) - "try sending large Initials" - , Option ['M'] ["change-server-cid"] - (NoArg (\o -> o { optMigration = Just ChangeServerCID })) - "use a new server CID" - , Option ['N'] ["change-client-cid"] - (NoArg (\o -> o { optMigration = Just ChangeClientCID })) - "use a new client CID" - , Option ['B'] ["nat-rebinding"] - (NoArg (\o -> o { optMigration = Just NATRebinding })) - "use a new local port" - , Option ['A'] ["address-mobility"] - (NoArg (\o -> o { optMigration = Just ActiveMigration })) - "use a new address and a new server CID" - , Option ['t'] ["performance"] - (ReqArg (\n o -> o { optPerformance = read n }) "") - "measure performance" - , Option ['n'] ["number-of-requests"] - (ReqArg (\n o -> o { optNumOfReqs = read n }) "") - "specify the number of requests" - , Option ['m'] ["use-connected-socket"] - (NoArg (\o -> o { optUnconSock = False })) - "use connected sockets instead of unconnected sockets" - ] +options = + [ Option + ['d'] + ["debug"] + (NoArg (\o -> o{optDebugLog = True})) + "print debug info" + , Option + ['v'] + ["show-content"] + (NoArg (\o -> o{optShow = True})) + "print downloaded content" + , Option + ['q'] + ["qlog-dir"] + (ReqArg (\dir o -> o{optQLogDir = Just dir}) "") + "directory to store qlog" + , Option + ['l'] + ["key-log-file"] + (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") + "a file to store negotiated secrets" + , Option + ['g'] + ["groups"] + (ReqArg (\gs o -> o{optGroups = Just gs}) "") + "specify groups" + , Option + ['c'] + ["validate"] + (NoArg (\o -> o{optValidate = True})) + "validate server's certificate" + , Option + ['r'] + ["hq"] + (NoArg (\o -> o{optHQ = True})) + "prefer hq (HTTP/0.9)" + , Option + ['s'] + ["packet-size"] + (ReqArg (\n o -> o{optPacketSize = Just (read n)}) "") + "specify QUIC packet size (UDP payload size)" + , Option + ['i'] + ["interactive"] + (NoArg (\o -> o{optInteractive = True})) + "prefer hq (HTTP/0.9)" + , Option + ['V'] + ["vernego"] + (NoArg (\o -> o{optVerNego = True})) + "try version negotiation" + , Option + ['R'] + ["resumption"] + (NoArg (\o -> o{optResumption = True})) + "try session resumption" + , Option + ['Z'] + ["0rtt"] + (NoArg (\o -> o{opt0RTT = True})) + "try sending early data" + , Option + ['S'] + ["stateless-retry"] + (NoArg (\o -> o{optRetry = True})) + "check stateless retry" + , Option + ['Q'] + ["quantum"] + (NoArg (\o -> o{optQuantum = True})) + "try sending large Initials" + , Option + ['M'] + ["change-server-cid"] + (NoArg (\o -> o{optMigration = Just ChangeServerCID})) + "use a new server CID" + , Option + ['N'] + ["change-client-cid"] + (NoArg (\o -> o{optMigration = Just ChangeClientCID})) + "use a new client CID" + , Option + ['B'] + ["nat-rebinding"] + (NoArg (\o -> o{optMigration = Just NATRebinding})) + "use a new local port" + , Option + ['A'] + ["address-mobility"] + (NoArg (\o -> o{optMigration = Just ActiveMigration})) + "use a new address and a new server CID" + , Option + ['t'] + ["performance"] + (ReqArg (\n o -> o{optPerformance = read n}) "") + "measure performance" + , Option + ['n'] + ["number-of-requests"] + (ReqArg (\n o -> o{optNumOfReqs = read n}) "") + "specify the number of requests" + , Option + ['m'] + ["use-connected-socket"] + (NoArg (\o -> o{optUnconSock = False})) + "use connected sockets instead of unconnected sockets" + ] showUsageAndExit :: String -> IO a showUsageAndExit msg = do @@ -148,8 +193,8 @@ clientOpts :: [String] -> IO (Options, [String]) clientOpts argv = case getOpt Permute options argv of - (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) - (_,_,errs) -> showUsageAndExit $ concat errs + (o, n, []) -> return (foldl (flip id) defaultOptions o, n) + (_, _, errs) -> showUsageAndExit $ concat errs main :: IO () main = do @@ -159,78 +204,89 @@ when (ipslen /= 2 && ipslen /= 3) $ showUsageAndExit "cannot recognize and \n" cmvar <- newEmptyMVar - let path | ipslen == 3 = ips !! 2 - | otherwise = "/" + let path + | ipslen == 3 = ips !! 2 + | otherwise = "/" addr = head ips port = head $ tail ips ccalpn ver - | optPerformance /= 0 = return $ Just ["perf"] - | otherwise = let (h3X, hqX) = makeProtos ver - protos | optHQ = [hqX,h3X] - | otherwise = [h3X,hqX] - in return $ Just protos + | optPerformance /= 0 = return $ Just ["perf"] + | otherwise = + let (h3X, hqX) = makeProtos ver + protos + | optHQ = [hqX, h3X] + | otherwise = [h3X, hqX] + in return $ Just protos gvers vers - | optVerNego = GreasingVersion : vers - | otherwise = vers + | optVerNego = GreasingVersion : vers + | otherwise = vers setTPQuantum params - | optQuantum = let bs = BS.replicate 1200 0 - in params { grease = Just bs } - | otherwise = params + | optQuantum = + let bs = BS.replicate 1200 0 + in params{grease = Just bs} + | otherwise = params cc0 = defaultClientConfig - cc = cc0 { - ccServerName = addr - , ccPortName = port - , ccALPN = ccalpn - , ccValidate = optValidate - , ccPacketSize = optPacketSize - , ccDebugLog = optDebugLog - , ccVersions = gvers $ ccVersions cc0 - , ccParameters = setTPQuantum $ ccParameters cc0 - , ccKeyLog = getLogger optKeyLogFile - , ccGroups = getGroups (ccGroups cc0) optGroups - , ccQLog = optQLogDir - , ccHooks = defaultHooks { - onCloseCompleted = putMVar cmvar () - } - , ccAutoMigration = optUnconSock - } - debug | optDebugLog = putStrLn - | otherwise = \_ -> return () - showContent | optShow = C8.putStrLn - | otherwise = \_ -> return () - aux = Aux { - auxPath = path - , auxAuthority = addr - , auxDebug = debug - , auxShow = showContent - , auxCheckClose = do - mx <- T.timeout 1000000 $ takeMVar cmvar - case mx of - Nothing -> return False - _ -> return True - } + cc = + cc0 + { ccServerName = addr + , ccPortName = port + , ccALPN = ccalpn + , ccValidate = optValidate + , ccPacketSize = optPacketSize + , ccDebugLog = optDebugLog + , ccVersions = gvers $ ccVersions cc0 + , ccParameters = setTPQuantum $ ccParameters cc0 + , ccKeyLog = getLogger optKeyLogFile + , ccGroups = getGroups (ccGroups cc0) optGroups + , ccQLog = optQLogDir + , ccHooks = + defaultHooks + { onCloseCompleted = putMVar cmvar () + } + , ccAutoMigration = optUnconSock + } + debug + | optDebugLog = putStrLn + | otherwise = \_ -> return () + showContent + | optShow = C8.putStrLn + | otherwise = \_ -> return () + aux = + Aux + { auxPath = path + , auxAuthority = addr + , auxDebug = debug + , auxShow = showContent + , auxCheckClose = do + mx <- T.timeout 1000000 $ takeMVar cmvar + case mx of + Nothing -> return False + _ -> return True + } runClient cc opts aux runClient :: ClientConfig -> Options -> Aux -> IO () runClient cc opts@Options{..} aux@Aux{..} = do auxDebug "------------------------" - (info1,info2,res,mig,client') <- run cc $ \conn -> do + (info1, info2, res, mig, client') <- run cc $ \conn -> do i1 <- getConnectionInfo conn let client = case alpn i1 of - Just proto | "hq" `BS.isPrefixOf` proto -> clientHQ optNumOfReqs - | "h3" `BS.isPrefixOf` proto -> clientH3 optNumOfReqs - _ -> clientPF optPerformance + Just proto + | "hq" `BS.isPrefixOf` proto -> clientHQ optNumOfReqs + | "h3" `BS.isPrefixOf` proto -> clientH3 optNumOfReqs + _ -> clientPF optPerformance m <- case optMigration of - Nothing -> return False - Just mtyp -> do - x <- controlConnection conn mtyp - auxDebug $ "Migration by " ++ show mtyp - return x + Nothing -> return False + Just mtyp -> do + x <- controlConnection conn mtyp + auxDebug $ "Migration by " ++ show mtyp + return x t1 <- getUnixTime - if optInteractive then do - console aux client conn - else do - client aux conn + if optInteractive + then do + console aux client conn + else do + client aux conn stats <- getConnectionStats conn print stats t2 <- getUnixTime @@ -238,84 +294,99 @@ r <- getResumptionInfo conn printThroughput t1 t2 stats return (i1, i2, r, m, client) - if optVerNego then do - putStrLn "Result: (V) version negotiation ... OK" - exitSuccess - else if optQuantum then do - putStrLn "Result: (Q) quantum ... OK" - exitSuccess - else if optResumption then do - if isResumptionPossible res then do - info3 <- runClient2 cc opts aux res client' - if handshakeMode info3 == PreSharedKey then do - putStrLn "Result: (R) TLS resumption ... OK" + if + | optVerNego -> do + putStrLn "Result: (V) version negotiation ... OK" + exitSuccess + | optQuantum -> do + putStrLn "Result: (Q) quantum ... OK" + exitSuccess + | optResumption -> do + if isResumptionPossible res + then do + info3 <- runClient2 cc opts aux res client' + if handshakeMode info3 == PreSharedKey + then do + putStrLn "Result: (R) TLS resumption ... OK" + exitSuccess + else do + putStrLn "Result: (R) TLS resumption ... NG" + exitFailure + else do + putStrLn "Result: (R) TLS resumption ... NG" + exitFailure + | opt0RTT -> do + if is0RTTPossible res + then do + info3 <- runClient2 cc opts aux res client' + if handshakeMode info3 == RTT0 + then do + putStrLn "Result: (Z) 0-RTT ... OK" + exitSuccess + else do + putStrLn "Result: (Z) 0-RTT ... NG" + exitFailure + else do + putStrLn "Result: (Z) 0-RTT ... NG" + exitFailure + | optRetry -> do + if retry info1 + then do + putStrLn "Result: (S) retry ... OK" + exitSuccess + else do + putStrLn "Result: (S) retry ... NG" + exitFailure + | otherwise -> case optMigration of + Just ChangeServerCID -> do + let changed = remoteCID info1 /= remoteCID info2 + if mig && remoteCID info1 /= remoteCID info2 + then do + putStrLn "Result: (M) change server CID ... OK" + exitSuccess + else do + putStrLn $ "Result: (M) change server CID ... NG " ++ show (mig, changed) + exitFailure + Just ChangeClientCID -> do + let changed = localCID info1 /= localCID info2 + if mig && changed + then do + putStrLn "Result: (N) change client CID ... OK" + exitSuccess + else do + putStrLn $ "Result: (N) change client CID ... NG " ++ show (mig, changed) + exitFailure + Just NATRebinding -> do + putStrLn "Result: (B) NAT rebinding ... OK" exitSuccess - else do - putStrLn "Result: (R) TLS resumption ... NG" - exitFailure - else do - putStrLn "Result: (R) TLS resumption ... NG" - exitFailure - else if opt0RTT then do - if is0RTTPossible res then do - info3 <- runClient2 cc opts aux res client' - if handshakeMode info3 == RTT0 then do - putStrLn "Result: (Z) 0-RTT ... OK" + Just ActiveMigration -> do + let changed = remoteCID info1 /= remoteCID info2 + if mig && changed + then do + putStrLn "Result: (A) address mobility ... OK" + exitSuccess + else do + putStrLn $ "Result: (A) address mobility ... NG " ++ show (mig, changed) + exitFailure + Nothing -> do + putStrLn "Result: (H) handshake ... OK" + putStrLn "Result: (D) stream data ... OK" + closeCompleted <- auxCheckClose + when closeCompleted $ putStrLn "Result: (C) close completed ... OK" + case alpn info1 of + Nothing -> return () + Just alpn -> + when ("h3" `BS.isPrefixOf` alpn) $ + putStrLn "Result: (3) H3 transaction ... OK" exitSuccess - else do - putStrLn "Result: (Z) 0-RTT ... NG" - exitFailure - else do - putStrLn "Result: (Z) 0-RTT ... NG" - exitFailure - else if optRetry then do - if retry info1 then do - putStrLn "Result: (S) retry ... OK" - exitSuccess - else do - putStrLn "Result: (S) retry ... NG" - exitFailure - else case optMigration of - Just ChangeServerCID -> do - let changed = remoteCID info1 /= remoteCID info2 - if mig && remoteCID info1 /= remoteCID info2 then do - putStrLn "Result: (M) change server CID ... OK" - exitSuccess - else do - putStrLn $ "Result: (M) change server CID ... NG " ++ show (mig,changed) - exitFailure - Just ChangeClientCID -> do - let changed = localCID info1 /= localCID info2 - if mig && changed then do - putStrLn "Result: (N) change client CID ... OK" - exitSuccess - else do - putStrLn $ "Result: (N) change client CID ... NG " ++ show (mig,changed) - exitFailure - Just NATRebinding -> do - putStrLn "Result: (B) NAT rebinding ... OK" - exitSuccess - Just ActiveMigration -> do - let changed = remoteCID info1 /= remoteCID info2 - if mig && changed then do - putStrLn "Result: (A) address mobility ... OK" - exitSuccess - else do - putStrLn $ "Result: (A) address mobility ... NG " ++ show (mig,changed) - exitFailure - Nothing -> do - putStrLn "Result: (H) handshake ... OK" - putStrLn "Result: (D) stream data ... OK" - closeCompleted <- auxCheckClose - when closeCompleted $ putStrLn "Result: (C) close completed ... OK" - case alpn info1 of - Nothing -> return () - Just alpn -> when ("h3" `BS.isPrefixOf` alpn) $ - putStrLn "Result: (3) H3 transaction ... OK" - exitSuccess -runClient2 :: ClientConfig -> Options -> Aux -> ResumptionInfo -> Cli - -> IO ConnectionInfo +runClient2 + :: ClientConfig + -> Options + -> Aux + -> ResumptionInfo + -> Cli + -> IO ConnectionInfo runClient2 cc Options{..} aux@Aux{..} res client = do threadDelay 100000 auxDebug "<<<< next connection >>>>" @@ -324,20 +395,31 @@ void $ client aux conn getConnectionInfo conn where - cc' = cc { - ccResumption = res - , ccUse0RTT = opt0RTT && is0RTTPossible res - } + cc' = + cc + { ccResumption = res + , ccUse0RTT = opt0RTT && is0RTTPossible res + } printThroughput :: UnixTime -> UnixTime -> ConnectionStats -> IO () printThroughput t1 t2 ConnectionStats{..} = - printf "Throughput %.2f Mbps (%d bytes in %d msecs)\n" bytesPerSeconds rxBytes millisecs + printf + "Throughput %.2f Mbps (%d bytes in %d msecs)\n" + bytesPerSeconds + rxBytes + millisecs where UnixDiffTime (CTime s) u = t2 `diffUnixTime` t1 millisecs :: Int millisecs = fromIntegral s * 1000 + fromIntegral u `div` 1000 bytesPerSeconds :: Double - bytesPerSeconds = fromIntegral rxBytes * (1000 :: Double) * 8 / fromIntegral millisecs / 1024 / 1024 + bytesPerSeconds = + fromIntegral rxBytes + * (1000 :: Double) + * 8 + / fromIntegral millisecs + / 1024 + / 1024 console :: Aux -> (Aux -> Connection -> IO ()) -> Connection -> IO () console aux client conn = do @@ -347,25 +429,25 @@ putStrLn "p -- ping" putStrLn "n -- NAT rebinding" loop - where - loop = do - hSetBuffering stdout NoBuffering - putStr "> " - hSetBuffering stdout LineBuffering - l <- getLine - case l of - "q" -> putStrLn "bye" - "g" -> do - putStrLn $ "GET " ++ auxPath aux - _ <- forkIO $ client aux conn - loop - "p" -> do - putStrLn "Ping" - sendFrames conn RTT1Level [Ping] - loop - "n" -> do - controlConnection conn NATRebinding >>= print - loop - _ -> do - putStrLn "No such command" - loop + where + loop = do + hSetBuffering stdout NoBuffering + putStr "> " + hSetBuffering stdout LineBuffering + l <- getLine + case l of + "q" -> putStrLn "bye" + "g" -> do + putStrLn $ "GET " ++ auxPath aux + _ <- forkIO $ client aux conn + loop + "p" -> do + putStrLn "Ping" + sendFrames conn RTT1Level [Ping] + loop + "n" -> do + controlConnection conn NATRebinding >>= print + loop + _ -> do + putStrLn "No such command" + loop diff --git a/util/server.hs b/util/server.hs --- a/util/server.hs +++ b/util/server.hs @@ -11,7 +11,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.List as L -import Network.TLS (credentialLoadX509, Credentials(..)) +import Network.TLS (Credentials (..), credentialLoadX509) import qualified Network.TLS.SessionManager as SM import System.Console.GetOpt import System.Environment (getArgs) @@ -24,51 +24,67 @@ import Network.QUIC.Server import ServerX -data Options = Options { - optDebugLogDir :: Maybe FilePath - , optQLogDir :: Maybe FilePath - , optKeyLogFile :: Maybe FilePath - , optGroups :: Maybe String - , optCertFile :: FilePath - , optKeyFile :: FilePath - , optRetry :: Bool - } deriving Show +data Options = Options + { optDebugLogDir :: Maybe FilePath + , optQLogDir :: Maybe FilePath + , optKeyLogFile :: Maybe FilePath + , optGroups :: Maybe String + , optCertFile :: FilePath + , optKeyFile :: FilePath + , optRetry :: Bool + } + deriving (Show) defaultOptions :: Options -defaultOptions = Options { - optDebugLogDir = Nothing - , optQLogDir = Nothing - , optKeyLogFile = Nothing - , optGroups = Nothing - , optCertFile = "servercert.pem" - , optKeyFile = "serverkey.pem" - , optRetry = False - } +defaultOptions = + Options + { optDebugLogDir = Nothing + , optQLogDir = Nothing + , optKeyLogFile = Nothing + , optGroups = Nothing + , optCertFile = "servercert.pem" + , optKeyFile = "serverkey.pem" + , optRetry = False + } options :: [OptDescr (Options -> Options)] -options = [ - Option ['d'] ["debug-log-dir"] - (ReqArg (\dir o -> o { optDebugLogDir = Just dir }) "") - "directory to store a debug file" - , Option ['q'] ["qlog-dir"] - (ReqArg (\dir o -> o { optQLogDir = Just dir }) "") - "directory to store qlog" - , Option ['l'] ["key-log-file"] - (ReqArg (\file o -> o { optKeyLogFile = Just file }) "") - "a file to store negotiated secrets" - , Option ['g'] ["groups"] - (ReqArg (\gs o -> o { optGroups = Just gs }) "") - "groups for key exchange" - , Option ['c'] ["cert"] - (ReqArg (\fl o -> o { optCertFile = fl }) "") - "certificate file" - , Option ['k'] ["key"] - (ReqArg (\fl o -> o { optKeyFile = fl }) "") - "key file" - , Option ['S'] ["retry"] - (NoArg (\o -> o { optRetry = True })) - "require stateless retry" - ] +options = + [ Option + ['d'] + ["debug-log-dir"] + (ReqArg (\dir o -> o{optDebugLogDir = Just dir}) "") + "directory to store a debug file" + , Option + ['q'] + ["qlog-dir"] + (ReqArg (\dir o -> o{optQLogDir = Just dir}) "") + "directory to store qlog" + , Option + ['l'] + ["key-log-file"] + (ReqArg (\file o -> o{optKeyLogFile = Just file}) "") + "a file to store negotiated secrets" + , Option + ['g'] + ["groups"] + (ReqArg (\gs o -> o{optGroups = Just gs}) "") + "groups for key exchange" + , Option + ['c'] + ["cert"] + (ReqArg (\fl o -> o{optCertFile = fl}) "") + "certificate file" + , Option + ['k'] + ["key"] + (ReqArg (\fl o -> o{optKeyFile = fl}) "") + "key file" + , Option + ['S'] + ["retry"] + (NoArg (\o -> o{optRetry = True})) + "require stateless retry" + ] usage :: String usage = "Usage: server [OPTION] addr [addrs] port" @@ -82,19 +98,19 @@ serverOpts :: [String] -> IO (Options, [String]) serverOpts argv = case getOpt Permute options argv of - (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) - (_,_,errs) -> showUsageAndExit $ concat errs + (o, n, []) -> return (foldl (flip id) defaultOptions o, n) + (_, _, errs) -> showUsageAndExit $ concat errs chooseALPN :: Version -> [ByteString] -> IO ByteString chooseALPN _ protos - | "perf" `elem` protos = return "perf" + | "perf" `elem` protos = return "perf" chooseALPN ver protos = return $ case mh3idx of - Nothing -> case mhqidx of - Nothing -> "" - Just _ -> hqX - Just h3idx -> case mhqidx of - Nothing -> h3X - Just hqidx -> if h3idx < hqidx then h3X else hqX + Nothing -> case mhqidx of + Nothing -> "" + Just _ -> hqX + Just h3idx -> case mhqidx of + Nothing -> h3X + Just hqidx -> if h3idx < hqidx then h3X else hqX where (h3X, hqX) = makeProtos ver mh3idx = h3X `L.elemIndex` protos @@ -110,24 +126,26 @@ addrs = read <$> init ips aps = (,port) <$> addrs smgr <- SM.newSessionManager SM.defaultConfig - Right cred@(!_cc,!_priv) <- credentialLoadX509 optCertFile optKeyFile + Right cred@(!_cc, !_priv) <- credentialLoadX509 optCertFile optKeyFile let sc0 = defaultServerConfig - sc = sc0 { - scAddresses = aps - , scALPN = Just chooseALPN - , scRequireRetry = optRetry - , scSessionManager = smgr - , scUse0RTT = True - , scDebugLog = optDebugLogDir - , scKeyLog = getLogger optKeyLogFile - , scGroups = getGroups (scGroups sc0) optGroups - , scQLog = optQLogDir - , scCredentials = Credentials [cred] - } + sc = + sc0 + { scAddresses = aps + , scALPN = Just chooseALPN + , scRequireRetry = optRetry + , scSessionManager = smgr + , scUse0RTT = True + , scDebugLog = optDebugLogDir + , scKeyLog = getLogger optKeyLogFile + , scGroups = getGroups (scGroups sc0) optGroups + , scQLog = optQLogDir + , scCredentials = Credentials [cred] + } run sc $ \conn -> do info <- getConnectionInfo conn let server = case alpn info of - Just proto | "perf" == proto -> serverPF - | "hq" `BS.isPrefixOf` proto -> serverHQ - _ -> serverH3 + Just proto + | "perf" == proto -> serverPF + | "hq" `BS.isPrefixOf` proto -> serverHQ + _ -> serverH3 server conn