diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,10 @@ +# ChangeLog + +## 0.1.23 + +* Introducing `onConnectionEstablished` into `Hooks`. +* Preparing for tls v2.1. + ## 0.1.22 - Incresing activeConnectionIdLimit and fix a bug diff --git a/Network/QUIC.hs b/Network/QUIC.hs --- a/Network/QUIC.hs +++ b/Network/QUIC.hs @@ -36,12 +36,23 @@ sendStreamMany, -- * Information - ConnectionInfo (..), + ConnectionInfo, getConnectionInfo, + version, + cipher, + alpn, + handshakeMode, + retry, + localSockAddr, + remoteSockAddr, + localCID, + remoteCID, -- * Statistics - ConnectionStats (..), + ConnectionStats, getConnectionStats, + txBytes, + rxBytes, -- * Synchronization wait0RTTReady, @@ -79,3 +90,4 @@ import Network.QUIC.Info import Network.QUIC.Stream import Network.QUIC.Types +import Network.QUIC.Types.Info diff --git a/Network/QUIC/Closer.hs b/Network/QUIC/Closer.hs --- a/Network/QUIC/Closer.hs +++ b/Network/QUIC/Closer.hs @@ -4,10 +4,10 @@ module Network.QUIC.Closer (closure) where import Foreign.Marshal.Alloc +import Foreign.Ptr import qualified Network.UDP as UDP import UnliftIO.Concurrent import qualified UnliftIO.Exception as E -import Foreign.Ptr import Network.QUIC.Config import Network.QUIC.Connection @@ -24,18 +24,18 @@ closure' conn ldcc $ ConnectionClose NoError 0 "" return x closure conn ldcc (Left se) - | Just e@(TransportErrorIsSent err desc) <- E.fromException se = do + | Just e@(TransportErrorIsSent err desc) <- E.fromException se = do closure' conn ldcc $ ConnectionClose err 0 desc E.throwIO e - | Just e@(ApplicationProtocolErrorIsSent err desc) <- E.fromException se = do + | Just e@(ApplicationProtocolErrorIsSent err desc) <- E.fromException se = do closure' conn ldcc $ ConnectionCloseApp err desc E.throwIO e - | Just (Abort err desc) <- E.fromException se = do + | Just (Abort err desc) <- E.fromException se = do closure' conn ldcc $ ConnectionCloseApp err desc E.throwIO $ ApplicationProtocolErrorIsSent err desc - | Just (VerNego vers) <- E.fromException se = do + | Just (VerNego vers) <- E.fromException se = do E.throwIO $ NextVersion vers - | otherwise = E.throwIO se + | otherwise = E.throwIO se closure' :: Connection -> LDCC -> Frame -> IO () closure' conn ldcc frame = do @@ -56,8 +56,8 @@ pto <- getPTO ldcc void $ forkFinally (closer conn pto send recv hook) $ \e -> do case e of - Left e' -> connDebugLog conn $ "closure' " <> bhow e' - Right _ -> return () + Left e' -> connDebugLog conn $ "closure' " <> bhow e' + Right _ -> return () free sendBuf free recvBuf clos @@ -65,17 +65,19 @@ encodeCC :: Connection -> SizedBuffer -> Frame -> IO Int encodeCC conn res0@(SizedBuffer sendBuf0 bufsiz0) frame = do lvl0 <- getEncryptionLevel conn - let lvl | lvl0 == RTT0Level = InitialLevel - | otherwise = lvl0 - if lvl == HandshakeLevel then do - siz0 <- encCC res0 InitialLevel - let sendBuf1 = sendBuf0 `plusPtr` siz0 - bufsiz1 = bufsiz0 - siz0 - res1 = SizedBuffer sendBuf1 bufsiz1 - siz1 <- encCC res1 HandshakeLevel - return (siz0 + siz1) - else - encCC res0 lvl + let lvl + | lvl0 == RTT0Level = InitialLevel + | otherwise = lvl0 + if lvl == HandshakeLevel + then do + siz0 <- encCC res0 InitialLevel + let sendBuf1 = sendBuf0 `plusPtr` siz0 + bufsiz1 = bufsiz0 - siz0 + res1 = SizedBuffer sendBuf1 bufsiz1 + siz1 <- encCC res1 HandshakeLevel + return (siz0 + siz1) + else + encCC res0 lvl where encCC res lvl = do header <- mkHeader conn lvl @@ -83,19 +85,20 @@ let plain = Plain (Flags 0) mypn [frame] 0 ppkt = PlainPacket header plain siz <- fst <$> encodePlainPacket conn res ppkt Nothing - if siz >= 0 then do - now <- getTimeMicrosecond - qlogSent conn ppkt now - return siz - else - return 0 + if siz >= 0 + then do + now <- getTimeMicrosecond + qlogSent conn ppkt now + return siz + else + return 0 closer :: Connection -> Microseconds -> IO () -> IO Int -> IO () -> IO () closer _conn (Microseconds pto) send recv hook #if defined(mingw32_HOST_OS) - | isServer _conn = send + | isServer _conn = send #endif - | otherwise = loop (3 :: Int) + | otherwise = loop (3 :: Int) where loop 0 = return () loop n = do @@ -103,15 +106,15 @@ getTimeMicrosecond >>= skip (Microseconds pto) mx <- timeout (Microseconds (pto !>>. 1)) "closer 1" recv case mx of - Nothing -> hook - Just 0 -> return () - Just _ -> loop (n - 1) + Nothing -> hook + Just 0 -> return () + Just _ -> loop (n - 1) skip tmo@(Microseconds duration) base = do mx <- timeout tmo "closer 2" recv case mx of - Nothing -> return () - Just 0 -> return () - Just _ -> do - Microseconds elapsed <- getElapsedTimeMicrosecond base - let duration' = duration - elapsed - when (duration' >= 5000) $ skip (Microseconds duration') base + Nothing -> return () + Just 0 -> return () + Just _ -> do + Microseconds elapsed <- getElapsedTimeMicrosecond base + let duration' = duration - elapsed + when (duration' >= 5000) $ skip (Microseconds duration') base diff --git a/Network/QUIC/Config.hs b/Network/QUIC/Config.hs --- a/Network/QUIC/Config.hs +++ b/Network/QUIC/Config.hs @@ -13,6 +13,7 @@ import Network.QUIC.Parameters import Network.QUIC.Stream import Network.QUIC.Types +import Network.QUIC.Types.Info ---------------------------------------------------------------- @@ -27,6 +28,7 @@ -> ([(EncryptionLevel, CryptoData)], Bool) , onResetStreamReceived :: Stream -> ApplicationProtocolError -> IO () , onServerReady :: IO () + , onConnectionEstablished :: ConnectionInfo -> IO () } -- | Default hooks. @@ -40,6 +42,7 @@ , onTLSHandshakeCreated = (,False) , onResetStreamReceived = \_ _ -> return () , onServerReady = return () + , onConnectionEstablished = \_ -> return () } ---------------------------------------------------------------- @@ -138,6 +141,16 @@ , scDebugLog :: Maybe FilePath , scTicketLifetime :: Int -- ^ A lifetime (in seconds) for TLS session ticket and QUIC token. + , scWildcardSocketonly :: Bool + -- ^ If 'True', only wild sockets are used. + -- Packets are dispatched in Haskell code according to + -- destination connection ID. This is an overhead however + -- clinets can make QUIC connections even if intermediate NATs + -- rebind UDP ports frequently. + -- Otherwise, connected sockets are also used. + -- This means that packets are dispatched by a kernel. + -- But unfortunately, clients cannot make QUIC connections + -- if intermediate NATs rebind UDP ports frequently. } -- | The default value for server configuration. @@ -161,4 +174,5 @@ , scSessionManager = noSessionManager , scDebugLog = Nothing , scTicketLifetime = 7200 + , scWildcardSocketonly = True } diff --git a/Network/QUIC/Handshake.hs b/Network/QUIC/Handshake.hs --- a/Network/QUIC/Handshake.hs +++ b/Network/QUIC/Handshake.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -25,18 +24,18 @@ ---------------------------------------------------------------- newtype HndState = HndState - { hsRecvCnt :: Int -- number of 'recv' calls since last 'send' + { hsRecvCnt :: Int -- number of 'recv' calls since last 'send' } newHndStateRef :: IO (IORef HndState) -newHndStateRef = newIORef HndState { hsRecvCnt = 0 } +newHndStateRef = newIORef HndState{hsRecvCnt = 0} sendCompleted :: IORef HndState -> IO () -sendCompleted hsr = atomicModifyIORef'' hsr $ \hs -> hs { hsRecvCnt = 0 } +sendCompleted hsr = atomicModifyIORef'' hsr $ \hs -> hs{hsRecvCnt = 0} recvCompleted :: IORef HndState -> IO Int recvCompleted hsr = atomicModifyIORef' hsr $ \hs -> - let cnt = hsRecvCnt hs in (hs { hsRecvCnt = cnt + 1 }, cnt) + let cnt = hsRecvCnt hs in (hs{hsRecvCnt = cnt + 1}, cnt) rxLevelChanged :: IORef HndState -> IO () rxLevelChanged = sendCompleted @@ -49,30 +48,43 @@ recvCryptoData :: Connection -> IO Crypto recvCryptoData = takeCrypto -recvTLS :: Connection -> IORef HndState -> CryptLevel -> IO (Either TLS.TLSError ByteString) +recvTLS + :: Connection + -> IORef HndState + -> CryptLevel + -> IO (Either TLS.TLSError ByteString) recvTLS conn hsr level = case level of - CryptInitial -> go InitialLevel - CryptMainSecret -> failure "QUIC does not receive data < TLS 1.3" - CryptEarlySecret -> failure "QUIC does not send early data with TLS library" - CryptHandshakeSecret -> go HandshakeLevel - CryptApplicationSecret -> go RTT1Level + CryptInitial -> go InitialLevel + CryptMainSecret -> failure "QUIC does not receive data < TLS 1.3" + CryptEarlySecret -> failure "QUIC does not send early data with TLS library" + CryptHandshakeSecret -> go HandshakeLevel + CryptApplicationSecret -> go RTT1Level where failure = return . Left . internalError go expected = do InpHandshake actual bs <- recvCryptoData conn - if bs == "" then - return $ Left TLS.Error_EOF - else if actual /= expected then - failure $ "encryption level mismatch: expected " ++ show expected ++ " but got " ++ show actual - else do - when (isClient conn) $ do - n <- recvCompleted hsr - -- Sending ACKs for three times rule - when ((n `mod` 3) == 1) $ - sendCryptoData conn $ OutControl HandshakeLevel [] $ return () - return $ Right bs + if bs == "" + then + return $ Left TLS.Error_EOF + else + if actual /= expected + then + failure $ + "encryption level mismatch: expected " + ++ show expected + ++ " but got " + ++ show actual + else do + when (isClient conn) $ do + n <- recvCompleted hsr + -- Sending ACKs for three times rule + when ((n `mod` 3) == 1) $ + sendCryptoData conn $ + OutControl HandshakeLevel [] $ + return () + return $ Right bs sendTLS :: Connection -> IORef HndState -> [(CryptLevel, ByteString)] -> IO () sendTLS conn hsr x = do @@ -86,11 +98,7 @@ convertLevel (CryptApplicationSecret, bs) = return (RTT1Level, bs) internalError :: String -> TLS.TLSError -#if MIN_VERSION_tls(1,9,0) -internalError msg = TLS.Error_Protocol msg TLS.InternalError -#else -internalError msg = TLS.Error_Protocol (msg, True, TLS.InternalError) -#endif +internalError msg = TLS.Error_Protocol msg TLS.InternalError ---------------------------------------------------------------- @@ -99,16 +107,20 @@ qlogParamsSet conn (ccParameters conf, "local") -- fixme handshakeClient' conf conn myAuthCIDs <$> getVersion conn <*> newHndStateRef -handshakeClient' :: ClientConfig -> Connection -> AuthCIDs -> Version -> IORef HndState -> IO () +handshakeClient' + :: ClientConfig -> Connection -> AuthCIDs -> Version -> IORef HndState -> IO () handshakeClient' conf conn myAuthCIDs ver hsr = handshaker where - handshaker = clientHandshaker qc conf ver myAuthCIDs setter use0RTT `E.catch` sendCCTLSError - qc = QUICCallbacks { quicSend = sendTLS conn hsr - , quicRecv = recvTLS conn hsr - , quicInstallKeys = installKeysClient - , quicNotifyExtensions = setPeerParams conn - , quicDone = done - } + handshaker = + clientHandshaker qc conf ver myAuthCIDs setter use0RTT `E.catch` sendCCTLSError + qc = + QUICCallbacks + { quicSend = sendTLS conn hsr + , quicRecv = recvTLS conn hsr + , quicInstallKeys = installKeysClient + , quicNotifyExtensions = setPeerParams conn + , quicDone = done + } setter = setResumptionSession conn installKeysClient _ctx (InstallEarlyKeys Nothing) = return () installKeysClient _ctx (InstallEarlyKeys (Just (EarlySecretInfo cphr cts))) = do @@ -134,10 +146,10 @@ -- Validating Chosen Version mPeerVerInfo <- versionInformation <$> getPeerParameters conn case mPeerVerInfo of - Nothing -> return () - Just peerVerInfo -> do - hdrVer <- getVersion conn - when (hdrVer /= chosenVersion peerVerInfo) sendCCVNError + Nothing -> return () + Just peerVerInfo -> do + hdrVer <- getVersion conn + when (hdrVer /= chosenVersion peerVerInfo) sendCCVNError info <- getConnectionInfo conn connDebugLog conn $ bhow info use0RTT = ccUse0RTT conf @@ -146,22 +158,31 @@ handshakeServer :: ServerConfig -> Connection -> AuthCIDs -> IO (IO ()) handshakeServer conf conn myAuthCIDs = - handshakeServer' conf conn <$> getVersion conn - <*> newHndStateRef - <*> newIORef params + handshakeServer' conf conn + <$> getVersion conn + <*> newHndStateRef + <*> newIORef params where params = setCIDsToParameters myAuthCIDs $ scParameters conf -handshakeServer' :: ServerConfig -> Connection -> Version -> IORef HndState -> IORef Parameters -> IO () +handshakeServer' + :: ServerConfig + -> Connection + -> Version + -> IORef HndState + -> IORef Parameters + -> IO () handshakeServer' conf conn ver hsRef paramRef = handshaker where handshaker = serverHandshaker qc conf ver getParams `E.catch` sendCCTLSError - qc = QUICCallbacks { quicSend = sendTLS conn hsRef - , quicRecv = recvTLS conn hsRef - , quicInstallKeys = installKeysServer - , quicNotifyExtensions = setPeerParams conn - , quicDone = done - } + qc = + QUICCallbacks + { quicSend = sendTLS conn hsRef + , quicRecv = recvTLS conn hsRef + , quicInstallKeys = installKeysServer + , quicNotifyExtensions = setPeerParams conn + , quicDone = done + } installKeysServer _ctx (InstallEarlyKeys Nothing) = return () installKeysServer _ctx (InstallEarlyKeys (Just (EarlySecretInfo cphr cts))) = do setCipher conn RTT0Level cphr @@ -176,8 +197,8 @@ installKeysServer ctx (InstallApplicationKeys appSecInf@(ApplicationSecretInfo tss)) = do storeNegotiated conn ctx appSecInf initializeCoder1RTT conn tss - -- will switch to RTT1Level after client Finished - -- is received and verified + -- will switch to RTT1Level after client Finished + -- is received and verified done ctx = do setEncryptionLevel conn RTT1Level TLS.getClientCertificateChain ctx >>= setCertificateChain conn @@ -193,14 +214,15 @@ clearCryptoStream conn RTT1Level setConnection1RTTReady conn setConnectionEstablished conn --- sendFrames conn RTT1Level [HandshakeDone] + getConnectionInfo conn >>= onConnectionEstablished (connHooks conn) + -- sendFrames conn RTT1Level [HandshakeDone] -- info <- getConnectionInfo conn connDebugLog conn $ bhow info getParams = do params <- readIORef paramRef verInfo <- getVersionInfo conn - return params { versionInformation = Just verInfo } + return params{versionInformation = Just verInfo} ---------------------------------------------------------------- @@ -208,19 +230,21 @@ setPeerParams conn _ctx peerExts = do tpId <- extensionIDForTtransportParameter <$> getVersion conn case getTP tpId peerExts of - Nothing -> sendCCTLSAlert TLS.MissingExtension "QUIC transport parameters are mssing" - Just (ExtensionRaw _ bs) -> setPP bs + Nothing -> + sendCCTLSAlert TLS.MissingExtension "QUIC transport parameters are mssing" + Just (ExtensionRaw _ bs) -> setPP bs where getTP n = find (\(ExtensionRaw extid _) -> extid == n) setPP bs = case decodeParameters bs of - Nothing -> sendCCParamError - Just params -> do - checkAuthCIDs params - checkInvalid params - setParams params - qlogParamsSet conn (params,"remote") - when (isServer conn) $ - serverVersionNegotiation $ versionInformation params + Nothing -> sendCCParamError + Just params -> do + checkAuthCIDs params + checkInvalid params + setParams params + qlogParamsSet conn (params, "remote") + when (isServer conn) $ + serverVersionNegotiation $ + versionInformation params checkAuthCIDs params = do peerAuthCIDs <- getPeerAuthCIDs conn @@ -230,20 +254,20 @@ ensure (retrySourceConnectionId params) $ retrySrcCID peerAuthCIDs ensure _ Nothing = return () ensure v0 v1 - | v0 == v1 = return () - | otherwise = sendCCParamError + | v0 == v1 = return () + | otherwise = sendCCParamError checkInvalid params = do when (maxUdpPayloadSize params < 1200) sendCCParamError when (ackDelayExponent params > 20) sendCCParamError - when (maxAckDelay params >= 2^(14 :: Int)) sendCCParamError + when (maxAckDelay params >= 2 ^ (14 :: Int)) sendCCParamError when (isServer conn) $ do when (isJust $ originalDestinationConnectionId params) sendCCParamError when (isJust $ preferredAddress params) sendCCParamError when (isJust $ retrySourceConnectionId params) sendCCParamError when (isJust $ statelessResetToken params) sendCCParamError let vi = case versionInformation params of - Nothing -> VersionInfo Version1 [Version1] - Just vi0 -> vi0 + Nothing -> VersionInfo Version1 [Version1] + Just vi0 -> vi0 when (vi == brokenVersionInfo) sendCCParamError when (Negotiation `elem` otherVersions vi) sendCCParamError -- Always False for servers @@ -251,13 +275,12 @@ when isICVN $ do -- Validating Other Version fields. verInfo <- getVersionInfo conn - let myVer = chosenVersion verInfo + let myVer = chosenVersion verInfo myVers = filter (not . isGreasingVersion) $ otherVersions verInfo peerVers = otherVersions vi case myVers `intersect` peerVers of - ver:_ | ver == myVer -> return () - _ -> sendCCVNError - + ver : _ | ver == myVer -> return () + _ -> sendCCVNError setParams params = do setPeerParameters conn params @@ -276,12 +299,12 @@ peerVers = otherVersions peerVerInfo -- Server's preference should be preferred. case myVers `intersect` peerVers of - vers@(serverVer:_) - | clientVer /= serverVer -> do - setVersionInfo conn $ VersionInfo serverVer vers - dcid <- getClientDstCID conn - initializeCoder conn InitialLevel $ initialSecrets serverVer dcid - _ -> return () + vers@(serverVer : _) + | clientVer /= serverVer -> do + setVersionInfo conn $ VersionInfo serverVer vers + dcid <- getClientDstCID conn + initializeCoder conn InitialLevel $ initialSecrets serverVer dcid + _ -> return () storeNegotiated :: Connection -> TLS.Context -> ApplicationSecretInfo -> IO () storeNegotiated conn ctx appSecInf = do @@ -311,16 +334,10 @@ sendCCTLSAlert a msg = closeConnection (cryptoError a) msg getErrorCause :: TLS.TLSException -> TLS.TLSError -getErrorCause (TLS.Terminated _ _ e) = e -getErrorCause (TLS.HandshakeFailed e) = e -#if MIN_VERSION_tls(1,8,0) -getErrorCause (TLS.PostHandshake e) = e +getErrorCause (TLS.Terminated _ _ e) = e +getErrorCause (TLS.HandshakeFailed e) = e +getErrorCause (TLS.PostHandshake e) = e getErrorCause (TLS.Uncontextualized e) = e -#endif getErrorCause e = let msg = "unexpected TLS exception: " ++ show e -#if MIN_VERSION_tls(1,9,0) in TLS.Error_Protocol msg TLS.InternalError -#else - in TLS.Error_Protocol (msg, True, TLS.InternalError) -#endif diff --git a/Network/QUIC/Imports.hs b/Network/QUIC/Imports.hs --- a/Network/QUIC/Imports.hs +++ b/Network/QUIC/Imports.hs @@ -1,31 +1,31 @@ {-# LANGUAGE CPP #-} module Network.QUIC.Imports ( - Bytes - , ByteString(..) - , ShortByteString(..) - , Builder - , module Control.Applicative - , module Control.Monad - , module Data.Bits - , module Data.Foldable - , module Data.IORef - , module Data.Int - , module Data.Monoid - , module Data.Ord - , module Data.Word - , module Data.Array - , module Data.Array.IO - , module Data.Maybe - , module Numeric - , module Network.ByteOrder - , module Network.QUIC.Utils + Bytes, + ByteString (..), + ShortByteString (..), + Builder, + module Control.Applicative, + module Control.Monad, + module Data.Bits, + module Data.Foldable, + module Data.IORef, + module Data.Int, + module Data.Monoid, + module Data.Ord, + module Data.Word, + module Data.Array, + module Data.Array.IO, + module Data.Maybe, + module Numeric, + module Network.ByteOrder, + module Network.QUIC.Utils, #if !MIN_VERSION_base(4,17,0) , (!<<.), (!>>.) #endif - , atomicModifyIORef'' - , copyBS - ) where + atomicModifyIORef'', + copyBS, +) where import Control.Applicative import Control.Monad @@ -33,8 +33,8 @@ import Data.Array.IO import Data.Bits import Data.ByteString.Builder (Builder) -import Data.ByteString.Internal (ByteString(..)) -import Data.ByteString.Short.Internal (ShortByteString(..)) +import Data.ByteString.Internal (ByteString (..)) +import Data.ByteString.Short.Internal (ShortByteString (..)) import Data.Foldable import Data.IORef import Data.Int diff --git a/Network/QUIC/Info.hs b/Network/QUIC/Info.hs --- a/Network/QUIC/Info.hs +++ b/Network/QUIC/Info.hs @@ -3,30 +3,15 @@ module Network.QUIC.Info where -import qualified Data.ByteString.Char8 as C8 -import qualified Network.Socket as NS -import Network.TLS hiding (HandshakeFailed, Version) -import Network.UDP (UDPSocket (..)) - +import Data.ByteString () import Network.QUIC.Connection -import Network.QUIC.Imports import Network.QUIC.Types +import Network.QUIC.Types.Info +import qualified Network.Socket as NS +import Network.UDP (UDPSocket (..)) ---------------------------------------------------------------- --- | 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 - } - -- | Getting information about a connection. getConnectionInfo :: Connection -> IO ConnectionInfo getConnectionInfo conn = do @@ -51,33 +36,6 @@ , 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 "" ---------------------------------------------------------------- diff --git a/Network/QUIC/Receiver.hs b/Network/QUIC/Receiver.hs --- a/Network/QUIC/Receiver.hs +++ b/Network/QUIC/Receiver.hs @@ -17,6 +17,7 @@ import Network.QUIC.Crypto import Network.QUIC.Exception import Network.QUIC.Imports +import Network.QUIC.Info import Network.QUIC.Logger import Network.QUIC.Packet import Network.QUIC.Parameters @@ -411,6 +412,7 @@ clearCryptoStream conn HandshakeLevel clearCryptoStream conn RTT1Level setConnectionEstablished conn + getConnectionInfo conn >>= onConnectionEstablished (connHooks conn) -- to receive NewSessionTicket fire conn (Microseconds 1000000) $ killHandshaker conn lvl processFrame _ _ _ = closeConnection ProtocolViolation "Frame is not allowed" diff --git a/Network/QUIC/Types.hs b/Network/QUIC/Types.hs --- a/Network/QUIC/Types.hs +++ b/Network/QUIC/Types.hs @@ -23,6 +23,7 @@ import Network.QUIC.Types.Error import Network.QUIC.Types.Exception import Network.QUIC.Types.Frame + import Network.QUIC.Types.Integer import Network.QUIC.Types.Packet import Network.QUIC.Types.Queue diff --git a/Network/QUIC/Types/Info.hs b/Network/QUIC/Types/Info.hs new file mode 100644 --- /dev/null +++ b/Network/QUIC/Types/Info.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.QUIC.Types.Info where + +import qualified Data.ByteString.Char8 as C8 +import qualified Network.Socket as NS +import Network.TLS hiding (HandshakeFailed, Version) + +import Network.QUIC.Imports +import Network.QUIC.Types.CID +import Network.QUIC.Types.Packet + +---------------------------------------------------------------- + +-- | 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 + } + +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 "" 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.22 +version: 0.1.23 license: BSD3 license-file: LICENSE maintainer: kazu@iij.ad.jp @@ -113,6 +113,7 @@ Network.QUIC.Types.Error Network.QUIC.Types.Exception Network.QUIC.Types.Frame + Network.QUIC.Types.Info Network.QUIC.Types.Integer Network.QUIC.Types.Packet Network.QUIC.Types.Queue @@ -147,7 +148,7 @@ network-udp >= 0.0.0 && < 0.1, random >= 1.2.1 && < 1.3, serialise, - tls >= 2.0 && < 2.1, + tls >= 2.0 && < 2.2, unliftio >= 0.2 && < 0.3, unliftio-core >= 0.2 && < 0.3 diff --git a/test/Config.hs b/test/Config.hs --- a/test/Config.hs +++ b/test/Config.hs @@ -18,13 +18,7 @@ import qualified Data.List as L import Network.Socket import Network.Socket.ByteString -import Network.TLS ( - Credentials (..), - SessionData, - SessionID, - SessionManager (..), - credentialLoadX509, - ) +import Network.TLS hiding (Version) import UnliftIO.Concurrent import qualified UnliftIO.Exception as E @@ -171,7 +165,7 @@ sessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager sessionManager ref = - SessionManager + noSessionManager { sessionEstablish = establish , sessionResume = resume , sessionResumeOnlyOnce = resume diff --git a/util/quic-client.hs b/util/quic-client.hs --- a/util/quic-client.hs +++ b/util/quic-client.hs @@ -398,11 +398,11 @@ } printThroughput :: UnixTime -> UnixTime -> ConnectionStats -> IO () -printThroughput t1 t2 ConnectionStats{..} = +printThroughput t1 t2 stats = printf "Throughput %.2f Mbps (%d bytes in %d msecs)\n" bytesPerSeconds - rxBytes + (rxBytes stats) millisecs where UnixDiffTime (CTime s) u = t2 `diffUnixTime` t1 @@ -410,7 +410,7 @@ millisecs = fromIntegral s * 1000 + fromIntegral u `div` 1000 bytesPerSeconds :: Double bytesPerSeconds = - fromIntegral rxBytes + fromIntegral (rxBytes stats) * (1000 :: Double) * 8 / fromIntegral millisecs