tls 2.4.4 → 2.4.5
raw patch · 22 files changed
+605/−50 lines, 22 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Network.TLS: limitKeyUpdate :: Limit -> Maybe Int
Files
- CHANGELOG.md +37/−0
- Network/TLS.hs +1/−0
- Network/TLS/Context.hs +8/−4
- Network/TLS/Context/Internal.hs +14/−0
- Network/TLS/Core.hs +12/−1
- Network/TLS/Extension.hs +37/−22
- Network/TLS/Handshake/Client/Common.hs +22/−7
- Network/TLS/Handshake/Client/ServerHello.hs +6/−0
- Network/TLS/Handshake/Server/ClientHello12.hs +1/−1
- Network/TLS/Handshake/Server/ClientHello13.hs +3/−2
- Network/TLS/Handshake/Server/Common.hs +19/−0
- Network/TLS/Handshake/Server/TLS13.hs +7/−0
- Network/TLS/Packet.hs +12/−1
- Network/TLS/Packet13.hs +12/−1
- Network/TLS/Parameters.hs +9/−0
- Network/TLS/Record/Decrypt.hs +38/−8
- Network/TLS/State.hs +9/−0
- Network/TLS/Types.hs +17/−0
- test/EncodeSpec.hs +92/−0
- test/HandshakeSpec.hs +217/−0
- test/Run.hs +29/−0
- tls.cabal +3/−3
CHANGELOG.md view
@@ -1,5 +1,42 @@ # Change log for "tls" +## Version 2.4.5++* Fix the TLS 1.3 0-RTT session tests racing the NewSessionTicket.+ [#547](https://github.com/haskell-tls/hs-tls/pull/547)+* CI: drop macOS with GHC 9.12, whose compiler install dominated the+ wall clock.+ [#546](https://github.com/haskell-tls/hs-tls/pull/546)+* CI: retry Hackage downloads, keep the cache when a test fails, and run+ doctest on one job.+ [#545](https://github.com/haskell-tls/hs-tls/pull/545)+* `extensionDecode` returns `Nothing`, instead of calling `error`, for a+ message type in which the extension is not defined.+ [#544](https://github.com/haskell-tls/hs-tls/pull/544)+* `getTLSUnique` and `getTLSExporter` return `Nothing` before a handshake,+ instead of calling `error`.+ [#543](https://github.com/haskell-tls/hs-tls/pull/543)+* Take two timing signals out of the CBC record path.+ [#542](https://github.com/haskell-tls/hs-tls/pull/542)+* Bound the size of a handshake message reassembled from records.+ [#541](https://github.com/haskell-tls/hs-tls/pull/541)+* CI: speed up.+ [#540](https://github.com/haskell-tls/hs-tls/pull/540)+* Limit consecutive TLS 1.3 KeyUpdate messages. The new `limitKeyUpdate`+ parameter controls this and is `Just 32` by default, so the limit is on+ unless it is turned off.+ [#539](https://github.com/haskell-tls/hs-tls/pull/539)+* Validate the negotiated ALPN protocol. A client now rejects an+ unsolicited, empty, repeated or unoffered selection instead of ignoring+ it, and a server rejects a callback result the client did not offer.+ [#538](https://github.com/haskell-tls/hs-tls/pull/538)+* Validate the negotiated cipher suite against the negotiated version on+ the client, and constrain `onCipherChoosing` to the candidate list on+ the server.+ [#537](https://github.com/haskell-tls/hs-tls/pull/537)+* Make the session ticket tests deterministic.+ [#536](https://github.com/haskell-tls/hs-tls/pull/536)+ ## Version 2.4.4 * Enforce server certificate purpose
Network/TLS.hs view
@@ -139,6 +139,7 @@ Limit, defaultLimit, limitHandshakeFragment,+ limitKeyUpdate, limitRecordSize, -- * Shared parameters
Network/TLS/Context.hs view
@@ -267,8 +267,11 @@ -- and use the "tls-exporter" channel binding via 'getTLSExporter'. getTLSUnique :: Context -> IO (Maybe ByteString) getTLSUnique ctx = do- ver <- liftIO $ usingState_ ctx getVersion- if ver == TLS12+ -- Nothing rather than error before a version has been negotiated: this+ -- can be called on a context whose handshake has not run, and it already+ -- answers with Maybe.+ mver <- liftIO $ usingState_ ctx getVersionMaybe+ if mver == Just TLS12 then do mx <- usingState_ ctx getFirstVerifyData case mx of@@ -280,8 +283,9 @@ -- For TLS 1.2, 'Nothing' is returned. getTLSExporter :: Context -> IO (Maybe ByteString) getTLSExporter ctx = do- ver <- liftIO $ usingState_ ctx getVersion- if ver == TLS13+ -- As in 'getTLSUnique'.+ mver <- liftIO $ usingState_ ctx getVersionMaybe+ if mver == Just TLS13 then exporter ctx "EXPORTER-Channel-Binding" "" 32 else return Nothing
Network/TLS/Context/Internal.hs view
@@ -67,6 +67,8 @@ defaultTLS13State, getTLS13State, modifyTLS13State,+ incrementTLS13KeyUpdateCount,+ resetTLS13KeyUpdateCount, CipherChoice (..), makeCipherChoice, @@ -201,6 +203,7 @@ data TLS13State = TLS13State { tls13stRecvNST :: Bool -- client+ , tls13stKeyUpdateCount :: Int , tls13stSentClientCert :: Bool -- client , tls13stRecvSF :: Bool -- client , tls13stSentCF :: Bool -- client@@ -222,6 +225,7 @@ defaultTLS13State = TLS13State { tls13stRecvNST = False+ , tls13stKeyUpdateCount = 0 , tls13stSentClientCert = False , tls13stRecvSF = False , tls13stSentCF = False@@ -243,6 +247,16 @@ modifyTLS13State :: Context -> (TLS13State -> TLS13State) -> IO () modifyTLS13State Context{..} f = atomicModifyIORef' ctxTLS13State $ \st -> (f st, ())++incrementTLS13KeyUpdateCount :: Context -> IO Int+incrementTLS13KeyUpdateCount Context{..} =+ atomicModifyIORef' ctxTLS13State $ \st ->+ let count = tls13stKeyUpdateCount st + 1+ in (st{tls13stKeyUpdateCount = count}, count)++resetTLS13KeyUpdateCount :: Context -> IO ()+resetTLS13KeyUpdateCount ctx =+ modifyTLS13State ctx $ \st -> st{tls13stKeyUpdateCount = 0} data HandshakeSync = HandshakeSync
Network/TLS/Core.hs view
@@ -38,6 +38,10 @@ import System.Timeout import Network.TLS.Context+import Network.TLS.Context.Internal (+ incrementTLS13KeyUpdateCount,+ resetTLS13KeyUpdateCount,+ ) import Network.TLS.Extension import Network.TLS.Handshake import Network.TLS.Handshake.Common@@ -338,7 +342,7 @@ | otherwise -> do let reason = "early data deprotect overflow" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason- Established -> return x+ Established -> resetTLS13KeyUpdateCount ctx >> return x _ -> throwCore $ Error_Protocol "data at not-established" UnexpectedMessage process ChangeCipherSpec13 = do established <- ctxEstablished ctx@@ -400,6 +404,13 @@ -- to key update (update_requested) which we sent. if established == Established then do+ case limitKeyUpdate $ sharedLimit $ ctxShared ctx of+ Just limit | limit > 0 -> do+ count <- incrementTLS13KeyUpdateCount ctx+ when (count > limit) $ do+ let reason = "too many consecutive KeyUpdate messages"+ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason+ _ -> return () keyUpdate ctx getRxRecordState setRxRecordState -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is
Network/TLS/Extension.hs view
@@ -428,7 +428,22 @@ -- | Extension class to transform bytes to and from a high level Extension type. class Extension a where extensionID :: a -> ExtensionID++ -- | Decode an extension's body as it appears in the given message.+ --+ -- 'Nothing' covers both ways this can fail to produce a value: a body+ -- that does not parse, and a message the extension is not defined in.+ -- Both reach the peer the same way, as the decode_error alert that+ -- 'lookupAndDecode' and 'lookupAndDecodeAndDo' raise, which is what+ -- either case warrants.+ --+ -- So the last clause of an instance is @Nothing@, never @error@: the+ -- message type is chosen by this library rather than by the peer, so an+ -- unhandled one would be our own bug -- and turning our bug into an+ -- ErrorCall thrown from pure code, out through the handshake and into+ -- the application, is a worse answer than dropping the one connection. extensionDecode :: MessageType -> ByteString -> Maybe a+ extensionEncode :: a -> ByteString data MessageType@@ -438,7 +453,7 @@ | MsgTEncryptedExtensions | MsgTNewSessionTicket | MsgTCertificateRequest- deriving (Eq, Show)+ deriving (Eq, Show, Enum, Bounded) ------------------------------------------------------------ @@ -469,7 +484,7 @@ extensionDecode MsgTClientHello = decodeServerName extensionDecode MsgTServerHello = decodeServerName extensionDecode MsgTEncryptedExtensions = decodeServerName- extensionDecode _ = error "extensionDecode: ServerName"+ extensionDecode _ = const Nothing decodeServerName :: ByteString -> Maybe ServerName decodeServerName "" = Just $ ServerName [] -- dirty hack for servers@@ -521,7 +536,7 @@ extensionDecode MsgTClientHello = decodeMaxFragmentLength extensionDecode MsgTServerHello = decodeMaxFragmentLength extensionDecode MsgTEncryptedExtensions = decodeMaxFragmentLength- extensionDecode _ = error "extensionDecode: MaxFragmentLength"+ extensionDecode _ = const Nothing decodeMaxFragmentLength :: ByteString -> Maybe MaxFragmentLength decodeMaxFragmentLength = runGetMaybe $ toMaxFragmentEnum <$> getWord8@@ -542,7 +557,7 @@ extensionEncode (SupportedGroups groups) = runPut $ putWords16 $ map (\(Group g) -> g) groups extensionDecode MsgTClientHello = decodeSupportedGroups extensionDecode MsgTEncryptedExtensions = decodeSupportedGroups- extensionDecode _ = error "extensionDecode: SupportedGroups"+ extensionDecode _ = const Nothing decodeSupportedGroups :: ByteString -> Maybe SupportedGroups decodeSupportedGroups =@@ -577,7 +592,7 @@ extensionEncode (EcPointFormatsSupported formats) = runPut $ putWords8 $ map fromEcPointFormat formats extensionDecode MsgTClientHello = decodeEcPointFormatsSupported extensionDecode MsgTServerHello = decodeEcPointFormatsSupported- extensionDecode _ = error "extensionDecode: EcPointFormatsSupported"+ extensionDecode _ = const Nothing decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported decodeEcPointFormatsSupported =@@ -596,7 +611,7 @@ >> mapM_ putSignatureHashAlgorithm algs extensionDecode MsgTClientHello = decodeSignatureAlgorithms extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms- extensionDecode _ = error "extensionDecode: SignatureAlgorithms"+ extensionDecode _ = const Nothing decodeSignatureAlgorithms :: ByteString -> Maybe SignatureAlgorithms decodeSignatureAlgorithms = runGetMaybe $ do@@ -632,7 +647,7 @@ extensionEncode (HeartBeat mode) = runPut $ putWord8 $ fromHeartBeatMode mode extensionDecode MsgTClientHello = decodeHeartBeat extensionDecode MsgTServerHello = decodeHeartBeat- extensionDecode _ = error "extensionDecode: HeartBeat"+ extensionDecode _ = const Nothing decodeHeartBeat :: ByteString -> Maybe HeartBeat decodeHeartBeat = runGetMaybe $ HeartBeat . HeartBeatMode <$> getWord8@@ -651,7 +666,7 @@ extensionDecode MsgTClientHello = decodeApplicationLayerProtocolNegotiation extensionDecode MsgTServerHello = decodeApplicationLayerProtocolNegotiation extensionDecode MsgTEncryptedExtensions = decodeApplicationLayerProtocolNegotiation- extensionDecode _ = error "extensionDecode: ApplicationLayerProtocolNegotiation"+ extensionDecode _ = const Nothing decodeApplicationLayerProtocolNegotiation :: ByteString -> Maybe ApplicationLayerProtocolNegotiation@@ -674,7 +689,7 @@ extensionEncode ExtendedMainSecret = B.empty extensionDecode MsgTClientHello "" = Just ExtendedMainSecret extensionDecode MsgTServerHello "" = Just ExtendedMainSecret- extensionDecode _ _ = error "extensionDecode: ExtendedMainSecret"+ extensionDecode _ _ = Nothing ------------------------------------------------------------ @@ -749,7 +764,7 @@ extensionEncode (SessionTicket ticket) = runPut $ putBytes ticket extensionDecode MsgTClientHello = decodeSessionTicket extensionDecode MsgTServerHello = decodeSessionTicket- extensionDecode _ = error "extensionDecode: SessionTicket"+ extensionDecode _ = const Nothing decodeSessionTicket :: ByteString -> Maybe SessionTicket decodeSessionTicket = runGetMaybe $ SessionTicket <$> (remaining >>= getBytes)@@ -792,7 +807,7 @@ fromIntegral w16 extensionDecode MsgTClientHello = decodePreSharedKeyClientHello extensionDecode MsgTServerHello = decodePreSharedKeyServerHello- extensionDecode _ = error "extensionDecode: PreShareKey"+ extensionDecode _ = const Nothing decodePreSharedKeyClientHello :: ByteString -> Maybe PreSharedKey decodePreSharedKeyClientHello = runGetMaybe $ do@@ -837,7 +852,7 @@ extensionDecode MsgTNewSessionTicket = runGetMaybe $ EarlyDataIndication . Just <$> getWord32- extensionDecode _ = error "extensionDecode: EarlyDataIndication"+ extensionDecode _ = const Nothing ------------------------------------------------------------ @@ -860,7 +875,7 @@ putBinaryVersion ver extensionDecode MsgTClientHello = decodeSupportedVersionsClientHello extensionDecode MsgTServerHello = decodeSupportedVersionsServerHello- extensionDecode _ = error "extensionDecode: SupportedVersionsServerHello"+ extensionDecode _ = const Nothing decodeSupportedVersionsClientHello :: ByteString -> Maybe SupportedVersions decodeSupportedVersionsClientHello = runGetMaybe $ do@@ -888,7 +903,7 @@ extensionID _ = EID_Cookie extensionEncode (Cookie opaque) = runPut $ putOpaque16 opaque extensionDecode MsgTServerHello = runGetMaybe (Cookie <$> getOpaque16)- extensionDecode _ = error "extensionDecode: Cookie"+ extensionDecode _ = const Nothing ------------------------------------------------------------ @@ -916,7 +931,7 @@ putWords8 $ map fromPskKexMode pkms extensionDecode MsgTClientHello = decodePskKeyExchangeModes- extensionDecode _ = error "extensionDecode: PskKeyExchangeModes"+ extensionDecode _ = const Nothing decodePskKeyExchangeModes :: ByteString -> Maybe PskKeyExchangeModes decodePskKeyExchangeModes =@@ -935,7 +950,7 @@ putDNames names extensionDecode MsgTClientHello = decodeCertificateAuthorities extensionDecode MsgTCertificateRequest = decodeCertificateAuthorities- extensionDecode _ = error "extensionDecode: CertificateAuthorities"+ extensionDecode _ = const Nothing decodeCertificateAuthorities :: ByteString -> Maybe CertificateAuthorities decodeCertificateAuthorities =@@ -949,7 +964,7 @@ extensionID _ = EID_PostHandshakeAuth extensionEncode _ = B.empty extensionDecode MsgTClientHello = runGetMaybe $ return PostHandshakeAuth- extensionDecode _ = error "extensionDecode: PostHandshakeAuth"+ extensionDecode _ = const Nothing ------------------------------------------------------------ @@ -964,7 +979,7 @@ >> mapM_ putSignatureHashAlgorithm algs extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert- extensionDecode _ = error "extensionDecode: SignatureAlgorithmsCert"+ extensionDecode _ = const Nothing decodeSignatureAlgorithmsCert :: ByteString -> Maybe SignatureAlgorithmsCert decodeSignatureAlgorithmsCert = runGetMaybe $ do@@ -1021,7 +1036,7 @@ extensionDecode MsgTClientHello = decodeKeyShareClientHello extensionDecode MsgTServerHello = decodeKeyShareServerHello extensionDecode MsgTHelloRetryRequest = decodeKeyShareHRR- extensionDecode _ = error "extensionDecode: KeyShare"+ extensionDecode _ = const Nothing decodeKeyShareClientHello :: ByteString -> Maybe KeyShare decodeKeyShareClientHello = runGetMaybe $ do@@ -1059,7 +1074,7 @@ putWord8 $ fromIntegral (length ids * 2) mapM_ (putWord16 . fromExtensionID) ids extensionDecode MsgTClientHello = decodeEchOuterExtensions- extensionDecode _ = error "extensionDecode: EchOuterExtensions"+ extensionDecode _ = const Nothing decodeEchOuterExtensions :: ByteString -> Maybe EchOuterExtensions decodeEchOuterExtensions = runGetMaybe $ do@@ -1120,7 +1135,7 @@ extensionDecode MsgTClientHello = decodeECHClientHello extensionDecode MsgTEncryptedExtensions = decodeECHEncryptedExtensions extensionDecode MsgTHelloRetryRequest = decodeECHHelloRetryRequest- extensionDecode _ = error "extensionDecode: EncryptedClientHello"+ extensionDecode _ = const Nothing decodeECH :: ByteString -> Maybe EncryptedClientHello decodeECH bs =@@ -1172,4 +1187,4 @@ opaque <- getOpaque8 let (cvd, svd) = B.splitAt (B.length opaque `div` 2) opaque return $ SecureRenegotiation cvd svd- extensionDecode _ = error "extensionDecode: SecureRenegotiation"+ extensionDecode _ = const Nothing
Network/TLS/Handshake/Client/Common.hs view
@@ -15,6 +15,7 @@ import qualified Control.Exception as E import Control.Monad.State.Strict+import qualified Data.ByteString as B import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) import Network.TLS.Cipher@@ -344,14 +345,28 @@ (return ()) setAlpn where- setAlpn (ApplicationLayerProtocolNegotiation [proto]) = usingState_ ctx $ do- mprotos <- getClientALPNSuggest+ setAlpn (ApplicationLayerProtocolNegotiation [proto]) = do+ mprotos <- usingState_ ctx getClientALPNSuggest case mprotos of- Just protos -> when (proto `elem` protos) $ do- setExtensionALPN True- setNegotiatedProtocol proto- _ -> return ()- setAlpn _ = return ()+ Nothing ->+ throwCore $+ Error_Protocol+ "server sent ALPN without a client offer"+ UnsupportedExtension+ Just protos+ | not (B.null proto) && proto `elem` protos -> usingState_ ctx $ do+ setExtensionALPN True+ setNegotiatedProtocol proto+ | otherwise ->+ throwCore $+ Error_Protocol+ "server selected an ALPN protocol not offered by the client"+ IllegalParameter+ setAlpn _ =+ throwCore $+ Error_Protocol+ "server ALPN response did not contain exactly one protocol"+ IllegalParameter ----------------------------------------------------------------
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -138,6 +138,12 @@ ver <- usingState_ ctx getVersion + unless (cipherAllowedForVersion ver usedCipher) $+ throwCore $+ Error_Protocol+ "server selected a cipher invalid for the negotiated version"+ IllegalParameter+ when (ver == TLS12) $ setServerHelloParameters12 ctx shVersion shRandom usedCipher compressAlg
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -43,7 +43,7 @@ when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure- let usedCipher = onCipherChoosing hooks TLS12 ciphersFilteredVersion+ usedCipher <- chooseCipher hooks TLS12 ciphersFilteredVersion mcred <- chooseCreds usedCipher creds signatureCreds return (usedCipher, mcred)
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -13,6 +13,7 @@ import Network.TLS.Crypto import Network.TLS.Extension import Network.TLS.Handshake.Common13+import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State import Network.TLS.IO.Encode@@ -49,8 +50,8 @@ when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol "no cipher in common with the TLS 1.3 client" HandshakeFailure- let usedCipher = onCipherChoosing (serverHooks sparams) TLS13 ciphersFilteredVersion- usedHash = cipherHash usedCipher+ usedCipher <- chooseCipher (serverHooks sparams) TLS13 ciphersFilteredVersion+ let usedHash = cipherHash usedCipher rtt0 = lookupAndDecode EID_EarlyData
Network/TLS/Handshake/Server/Common.hs view
@@ -2,6 +2,7 @@ module Network.TLS.Handshake.Server.Common ( applicationProtocol,+ chooseCipher, checkValidClientCertChain, clientCertificate, credentialDigitalSignatureKey,@@ -17,6 +18,7 @@ import Control.Monad.State.Strict import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) +import Network.TLS.Cipher import Network.TLS.Context.Internal import Network.TLS.Credentials import Network.TLS.Crypto@@ -32,6 +34,18 @@ import Network.TLS.Util (catchException) import Network.TLS.X509 +chooseCipher :: ServerHooks -> Version -> [Cipher] -> IO Cipher+chooseCipher hooks ver candidates =+ case find ((== cipherID selected) . cipherID) candidates of+ Just cipher -> return cipher+ Nothing ->+ throwCore $+ Error_Protocol+ "onCipherChoosing selected a cipher outside the candidate list"+ InternalError+ where+ selected = onCipherChoosing hooks ver candidates+ checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain checkValidClientCertChain ctx errmsg = do@@ -132,6 +146,11 @@ when (proto == "") $ throwCore $ Error_Protocol "no supported application protocols" NoApplicationProtocol+ unless (proto `elem` protos) $+ throwCore $+ Error_Protocol+ "ALPN callback selected a protocol not offered by the client"+ NoApplicationProtocol usingState_ ctx $ do setExtensionALPN True setNegotiatedProtocol proto
Network/TLS/Handshake/Server/TLS13.hs view
@@ -274,6 +274,13 @@ Error_Protocol "post handshake authenticated" UnexpectedMessage chk [] = getHandshake ctx ref chk ((KeyUpdate13 mode, _) : hbs) = do+ case limitKeyUpdate $ sharedLimit $ ctxShared ctx of+ Just limit | limit > 0 -> do+ count <- incrementTLS13KeyUpdateCount ctx+ when (count > limit) $+ terminate ctx $+ Error_Protocol "too many consecutive KeyUpdate messages" UnexpectedMessage+ _ -> return () keyUpdate ctx getRxRecordState setRxRecordState -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is
Network/TLS/Packet.hs view
@@ -157,7 +157,18 @@ decodeHandshakeRecord :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord = runGet "handshake-record" $ do ty <- getHandshakeType- content <- getOpaque24+ len <- getWord24+ -- Before the bytes, not after: the length is in the first four octets, so+ -- refusing here is refusing to hold anything. Reassembly keeps every+ -- fragment until the message is whole, and the peer picks the number it+ -- announces.+ when (len > maxHandshakeSize) $+ fail $+ "handshake message of "+ ++ show len+ ++ " octets exceeds the limit of "+ ++ show maxHandshakeSize+ content <- getBytes len return (ty, content) {- FOURMOLU_DISABLE -}
Network/TLS/Packet13.hs view
@@ -116,7 +116,18 @@ decodeHandshakeRecord13 :: ByteString -> GetResult (HandshakeType, ByteString) decodeHandshakeRecord13 = runGet "handshake-record" $ do ty <- getHandshakeType- content <- getOpaque24+ len <- getWord24+ -- Before the bytes, not after: the length is in the first four octets, so+ -- refusing here is refusing to hold anything. Reassembly keeps every+ -- fragment until the message is whole, and the peer picks the number it+ -- announces.+ when (len > maxHandshakeSize) $+ fail $+ "handshake message of "+ ++ show len+ ++ " octets exceeds the limit of "+ ++ show maxHandshakeSize+ content <- getBytes len return (ty, content) {- FOURMOLU_DISABLE -}
Network/TLS/Parameters.hs view
@@ -888,6 +888,14 @@ -- certificate. -- -- Default: 32+ , limitKeyUpdate :: Maybe Int+ -- ^ Maximum number of consecutive TLS 1.3 KeyUpdate messages accepted+ -- without intervening non-empty application data. This bounds the CPU+ -- work and response amplification a peer can trigger while application+ -- code is blocked inside 'recvData'. 'Nothing' and non-positive values+ -- disable the limit; they do not disable KeyUpdate processing.+ --+ -- Default: @Just 32@ } deriving (Eq, Show) @@ -897,4 +905,5 @@ Limit { limitRecordSize = Nothing , limitHandshakeFragment = 32+ , limitKeyUpdate = Just 32 }
Network/TLS/Record/Decrypt.hs view
@@ -59,25 +59,40 @@ nonEmptyContentTypes = [ProtocolType_Handshake, ProtocolType_Alert] unknownContentType13 c = "unknown TLS 1.3 content type: " ++ show c -getCipherData :: Record a -> CipherData -> RecordM ByteString-getCipherData (Record pt ver _) cdata = do+-- | Check a decrypted record.+--+-- The first 'Bool' is what the lengths already said: 'False' when the padding+-- length the record claims cannot be one. It is carried in rather than+-- answered where it was found, so that the MAC is computed either way -- see+-- 'decryptData'.+--+-- Everything is computed before anything is decided, and the verdicts are+-- combined with '&&!', which does not short-circuit.+getCipherData :: Record a -> Bool -> CipherData -> RecordM ByteString+getCipherData (Record pt ver _) lengthValid cdata = do -- check if the MAC is valid. macValid <- case cipherDataMAC cdata of Nothing -> return True Just digest -> do let new_hdr = Header pt ver (fromIntegral $ B.length $ cipherDataContent cdata) expected_digest <- makeDigest new_hdr $ cipherDataContent cdata- return (expected_digest == digest)+ -- constEq rather than (==): (==) on ByteString is memcmp, which+ -- returns as soon as two octets differ, and how soon is a+ -- measurement of how much of the MAC was guessed correctly.+ return (expected_digest `BA.constEq` digest) -- check if the padding is filled with the correct pattern if it exists -- (before TLS10 this checks instead that the padding length is minimal) paddingValid <- case cipherDataPadding cdata of Nothing -> return True Just (pad, _blksz) -> do- let b = B.length pad - 1- return $ B.replicate (B.length pad) (fromIntegral b) == pad+ let b = fromIntegral (B.length pad - 1)+ -- Every octet, and no allocation of a pattern to compare against:+ -- B.all stops at the first wrong octet, and replicating the+ -- pattern costs time in proportion to a length the peer chose.+ return $ B.foldl' (\acc w -> acc .|. (w `xor` b)) 0 pad == 0 - unless (macValid &&! paddingValid) $+ unless (lengthValid &&! macValid &&! paddingValid) $ throwError $ Error_Protocol "bad record mac Stream/Block" BadRecordMac @@ -134,11 +149,25 @@ let (content', iv') = decryptF iv econtent' modify' $ \txs -> txs{stCryptState = cst{cstIV = iv'}} - let paddinglength = fromIntegral (B.last content') + 1- let contentlen = B.length content' - paddinglength - macSize+ -- The last octet of the plaintext says how much padding there is.+ -- It may say more than the record can hold, and that already settles+ -- the record -- but answering it here, by splitting the record and+ -- failing, would answer it *without computing the MAC*. How long a+ -- record takes to reject would then say whether the padding length+ -- was plausible, which is the question the attacker is asking.+ --+ -- So carry the verdict instead and go on with a length that fits.+ -- getCipherData folds it in with the MAC, and the answer is the same+ -- BadRecordMac either way.+ let plainlen = B.length content'+ claimed = fromIntegral (B.last content') + 1+ lengthValid = claimed + macSize <= plainlen+ paddinglength = if lengthValid then claimed else 1+ contentlen = plainlen - paddinglength - macSize (content, mac, padding) <- get3i content' (contentlen, macSize, paddinglength) getCipherData record+ lengthValid CipherData { cipherDataContent = content , cipherDataMAC = Just mac@@ -155,6 +184,7 @@ modify' $ \txs -> txs{stCryptState = cst{cstKey = BulkStateStream bulkStream'}} getCipherData record+ True CipherData { cipherDataContent = content , cipherDataMAC = Just mac
Network/TLS/State.hs view
@@ -25,6 +25,7 @@ setVersion, setVersionIfUnset, getVersion,+ getVersionMaybe, getVersionWithDefault, setSecureRenegotiation, getSecureRenegotiation,@@ -231,6 +232,14 @@ getVersion = fromMaybe (error "internal error: version hasn't been set yet") <$> gets stVersion++-- | The negotiated version, or 'Nothing' before there is one.+--+-- 'getVersion' calls 'error' in that case, which is the right answer inside+-- the handshake -- reaching it there would be a bug -- and the wrong one for+-- anything a user of the library can call before the handshake has run.+getVersionMaybe :: TLSSt (Maybe Version)+getVersionMaybe = gets stVersion getVersionWithDefault :: Version -> TLSSt Version getVersionWithDefault defaultVer = fromMaybe defaultVer <$> gets stVersion
Network/TLS/Types.hs view
@@ -11,6 +11,7 @@ bigNumToInteger, bigNumFromInteger, defaultRecordSizeLimit,+ maxHandshakeSize, TranscriptHash (..), WireBytes, ) where@@ -58,6 +59,22 @@ -- 2^14 + 1 for TLS 1.3 defaultRecordSizeLimit :: Int defaultRecordSizeLimit = 16384++----------------------------------------------------------------++-- | The largest handshake message we will reassemble.+--+-- A handshake message carries a 24-bit length, so a peer may announce close+-- to 16MB and then feed it a record at a time. Records are bounded, but the+-- message they are reassembled into was not, and the fragments are held until+-- it is complete -- before anything has authenticated the peer.+--+-- The largest legitimate one is a Certificate message. A long chain of+-- post-quantum certificates runs to tens of kilobytes, so this leaves an+-- order of magnitude over anything real while taking two orders of magnitude+-- off what a peer can ask us to hold.+maxHandshakeSize :: Int+maxHandshakeSize = 262144 ----------------------------------------------------------------
test/EncodeSpec.hs view
@@ -2,6 +2,7 @@ import Codec.Compression.Zlib (compress) import Control.Exception (bracket_, evaluate)+import Control.Monad (forM_, void) import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL@@ -17,6 +18,36 @@ spec :: Spec spec = do+ describe "extension decoding" $ do+ prop "yields Nothing rather than throwing, for any message type" $+ \ws -> forM_ extensionDecoders $ \(name, decode) ->+ forM_ [minBound .. maxBound] $ \mt ->+ decode mt (B.pack ws) `shouldReturn` name+ describe "handshake record length" $ do+ -- A handshake message carries a 24-bit length, and the fragments are+ -- held until the message is whole. Refusing at the header means+ -- refusing to hold anything: the length arrives in the first four+ -- octets, before any of the body.+ it "refuses a length past the limit, on its header alone" $ do+ let tooBig = maxHandshakeSize + 1+ isGotError (decodeHandshakeRecord (handshakeHeader tooBig)) `shouldBe` True+ isGotError (decodeHandshakeRecord13 (handshakeHeader tooBig)) `shouldBe` True+ it "refuses the largest a 24-bit length can say" $ do+ let header = handshakeHeader 0xffffff+ isGotError (decodeHandshakeRecord header) `shouldBe` True+ isGotError (decodeHandshakeRecord13 header) `shouldBe` True+ -- Still waiting for the body rather than refusing it: at the limit+ -- the header alone is not enough to decide anything is wrong.+ it "asks for more at the limit itself" $ do+ let header = handshakeHeader maxHandshakeSize+ isGotPartial (decodeHandshakeRecord header) `shouldBe` True+ isGotPartial (decodeHandshakeRecord13 header) `shouldBe` True+ it "still decodes a message of an ordinary size" $ do+ let body = B.replicate 1000 0+ record = handshakeHeader (B.length body) `B.append` body+ gotThisMuch (B.length body) (decodeHandshakeRecord record) `shouldBe` True+ gotThisMuch (B.length body) (decodeHandshakeRecord13 record) `shouldBe` True+ describe "encoder/decoder" $ do prop "can encode/decode Header" $ \x -> do decodeHeader (encodeHeader x) `shouldBe` Right x@@ -65,6 +96,28 @@ decodeHs13 :: ByteString -> Either TLSError Handshake13 decodeHs13 b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b +-- | A handshake record header: a type octet then a 24-bit length.+handshakeHeader :: Int -> ByteString+handshakeHeader len =+ B.pack+ [ 1 -- ClientHello+ , fromIntegral (len `div` 65536)+ , fromIntegral ((len `div` 256) `mod` 256)+ , fromIntegral (len `mod` 256)+ ]++isGotError :: GetResult a -> Bool+isGotError (GotError _) = True+isGotError _ = False++isGotPartial :: GetResult a -> Bool+isGotPartial (GotPartial _) = True+isGotPartial _ = False++gotThisMuch :: Int -> GetResult (a, ByteString) -> Bool+gotThisMuch n (GotSuccess (_, content)) = B.length content == n+gotThisMuch _ _ = False+ verifyResult :: (f -> r -> a) -> GetResult (f, r) -> a verifyResult fn result = case result of@@ -78,3 +131,42 @@ bracket_ (setAllocationCounter limit >> enableAllocationLimit) disableAllocationLimit++-- | Every 'Extension' instance, each wrapped so that the decoded value is+-- forced inside IO. A partial 'extensionDecode' therefore surfaces as a+-- thrown exception the test can see, rather than as a thunk nobody looks at.+--+-- The name is threaded through as the return value only so that a failure+-- report says which instance it was.+type Decoder a = MessageType -> ByteString -> Maybe a++extensionDecoders :: [(String, MessageType -> ByteString -> IO String)]+extensionDecoders =+ [+ entry "ServerName" (extensionDecode :: Decoder ServerName),+ entry "MaxFragmentLength" (extensionDecode :: Decoder MaxFragmentLength),+ entry "SecureRenegotiation" (extensionDecode :: Decoder SecureRenegotiation),+ entry "ApplicationLayerProtocolNegotiation" (extensionDecode :: Decoder ApplicationLayerProtocolNegotiation),+ entry "ExtendedMainSecret" (extensionDecode :: Decoder ExtendedMainSecret),+ entry "CompressCertificate" (extensionDecode :: Decoder CompressCertificate),+ entry "SupportedGroups" (extensionDecode :: Decoder SupportedGroups),+ entry "EcPointFormatsSupported" (extensionDecode :: Decoder EcPointFormatsSupported),+ entry "RecordSizeLimit" (extensionDecode :: Decoder RecordSizeLimit),+ entry "SessionTicket" (extensionDecode :: Decoder SessionTicket),+ entry "HeartBeat" (extensionDecode :: Decoder HeartBeat),+ entry "SignatureAlgorithms" (extensionDecode :: Decoder SignatureAlgorithms),+ entry "SignatureAlgorithmsCert" (extensionDecode :: Decoder SignatureAlgorithmsCert),+ entry "SupportedVersions" (extensionDecode :: Decoder SupportedVersions),+ entry "KeyShare" (extensionDecode :: Decoder KeyShare),+ entry "PostHandshakeAuth" (extensionDecode :: Decoder PostHandshakeAuth),+ entry "PskKeyExchangeModes" (extensionDecode :: Decoder PskKeyExchangeModes),+ entry "PreSharedKey" (extensionDecode :: Decoder PreSharedKey),+ entry "EarlyDataIndication" (extensionDecode :: Decoder EarlyDataIndication),+ entry "Cookie" (extensionDecode :: Decoder Cookie),+ entry "CertificateAuthorities" (extensionDecode :: Decoder CertificateAuthorities),+ entry "EchOuterExtensions" (extensionDecode :: Decoder EchOuterExtensions),+ entry "EncryptedClientHello" (extensionDecode :: Decoder EncryptedClientHello)+ ]+ where+ entry name decode = (name, \mt bs -> name <$ evaluate (length (show (decode mt bs))))+
test/HandshakeSpec.hs view
@@ -30,13 +30,28 @@ spec = do describe "pipe" $ do it "can setup a channel" pipe_work+ describe "channel binding" $ do+ prop "is unavailable before the handshake" binding_before_handshake describe "handshake" $ do prop "can run TLS 1.2" handshake_simple prop "can run TLS 1.3" handshake13_simple prop "can update key for TLS 1.3" handshake_update_key+ it+ "rejects more than 32 consecutive TLS 1.3 KeyUpdates"+ handshake_key_update_flood+ it+ "can disable the consecutive TLS 1.3 KeyUpdate limit"+ handshake_key_update_unlimited+ it+ "does not disable TLS 1.3 KeyUpdates with non-positive limits"+ handshake_key_update_non_positive prop "can prevent downgrade attack" handshake13_downgrade prop "can negotiate hash and signature" handshake_hashsignatures prop "can negotiate cipher suite" handshake_ciphersuites+ it "rejects a cipher outside the server callback candidates" $+ handshake_rejects_server_cipher_callback_escape+ it "rejects a TLS 1.2-only cipher selected for TLS 1.3" $+ handshake_rejects_legacy_cipher_in_tls13 prop "can negotiate group" handshake_groups prop "can negotiate elliptic curve" handshake_ec prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher@@ -58,6 +73,10 @@ prop "can handle extended main secret" handshake_ems prop "can resume with extended main secret" handshake_resumption_ems prop "can handle ALPN" handshake_alpn+ it "rejects an unoffered ALPN selection from the server hook" $+ handshake_alpn_rejects_unoffered_server_selection+ it "rejects an unoffered ALPN selection received by the client" $+ handshake_alpn_rejects_unoffered_client_selection prop "can handle SNI" handshake_sni prop "can handshake with TLS 1.2 CBC" handshake_cbc prop "can re-negotiate with TLS 1.2" handshake12_renegotiation@@ -82,6 +101,15 @@ -------------------------------------------------------------- +-- | Both channel bindings already answer with 'Maybe', and a caller may+-- reasonably ask for one on a context whose handshake has not run -- or has+-- failed. The answer is that there is no binding, not a crash.+binding_before_handshake :: (ClientParams, ServerParams) -> IO ()+binding_before_handshake params = withPairContext params $ \(cCtx, sCtx) ->+ forM_ [cCtx, sCtx] $ \ctx -> do+ getTLSUnique ctx `shouldReturn` Nothing+ getTLSExporter ctx `shouldReturn` Nothing+ pipe_work :: IO () pipe_work = do pipe <- newPipe@@ -118,6 +146,136 @@ sgrps = supportedGroups $ serverSupported $ snd params hs = if unsafeHead cgrps `elem` sgrps then FullHandshake else HelloRetryRequest +handshake_rejects_server_cipher_callback_escape :: IO ()+handshake_rejects_server_cipher_callback_escape = do+ (clientParam, serverParam) <- generate arbitraryPairParams13+ let params = cipherSelectionParams clientParam serverParam selectLegacy+ withPairContextWith (id, id) params $ \(cctx, sctx) ->+ concurrently_+ (handshake sctx `shouldThrow` serverRejectedCipherEscape)+ (handshake cctx `shouldThrow` anyTLSException)+ where+ selectLegacy _ _ = cipher_ECDHE_RSA_AES128CBC_SHA256++handshake_rejects_legacy_cipher_in_tls13 :: IO ()+handshake_rejects_legacy_cipher_in_tls13 = do+ (clientParam, serverParam) <- generate arbitraryPairParams13+ let params = cipherSelectionParams clientParam serverParam defaultSelection+ withPairContextWith (id, id) params $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv cctx tamperCipher+ concurrently_+ (handshake sctx `shouldThrow` anyTLSException)+ (handshake cctx `shouldThrow` clientRejectedLegacyCipher)+ where+ defaultSelection _ = unsafeHead+ tamperCipher (ServerHello sh) =+ pure $+ ServerHello+ sh+ { shCipher =+ CipherId $ cipherID cipher_ECDHE_RSA_AES128CBC_SHA256+ }+ tamperCipher hs = pure hs++cipherSelectionParams+ :: ClientParams+ -> ServerParams+ -> (Version -> [Cipher] -> Cipher)+ -> (ClientParams, ServerParams)+cipherSelectionParams clientParam serverParam select =+ ( clientParam{clientSupported = supported}+ , serverParam+ { serverSupported = supported+ , serverHooks =+ (serverHooks serverParam)+ { onCipherChoosing = select+ }+ }+ )+ where+ supported =+ defaultSupported+ { supportedVersions = [TLS13]+ , supportedCiphers =+ [ cipher13_AES_128_GCM_SHA256+ , cipher_ECDHE_RSA_AES128CBC_SHA256+ ]+ }++serverRejectedCipherEscape :: TLSException -> Bool+serverRejectedCipherEscape (HandshakeFailed (Error_Protocol msg alert)) =+ msg == "onCipherChoosing selected a cipher outside the candidate list"+ && alert == InternalError+serverRejectedCipherEscape _ = False++clientRejectedLegacyCipher :: TLSException -> Bool+clientRejectedLegacyCipher (HandshakeFailed (Error_Protocol msg alert)) =+ msg == "server selected a cipher invalid for the negotiated version"+ && alert == IllegalParameter+clientRejectedLegacyCipher _ = False++anyTLSException :: TLSException -> Bool+anyTLSException = const True++handshake_key_update_flood :: IO ()+handshake_key_update_flood = do+ params <- generate arbitraryPairParams13+ withPairContextWith (id, id) params $ \(cctx, sctx) ->+ concurrently_+ ( do+ handshake sctx+ recvData sctx `shouldReturn` "after 32 key updates"+ recvData sctx `shouldThrow` excessiveKeyUpdate+ )+ ( do+ handshake cctx+ replicateM_ 32 $ void $ updateKey cctx OneWay+ sendData cctx "after 32 key updates"+ replicateM_ 33 $ void $ updateKey cctx OneWay+ sendData cctx "after 33 key updates"+ )+ where+ excessiveKeyUpdate+ (Terminated _ _ (Error_Misc "too many consecutive KeyUpdate messages")) = True+ excessiveKeyUpdate _ = False++handshake_key_update_unlimited :: IO ()+handshake_key_update_unlimited = do+ (cparams, sparams0) <- generate arbitraryPairParams13+ let shared0 = serverShared sparams0+ limits = (sharedLimit shared0){limitKeyUpdate = Nothing}+ sparams = sparams0{serverShared = shared0{sharedLimit = limits}}+ withPairContextWith (id, id) (cparams, sparams) $ \(cctx, sctx) ->+ concurrently_+ ( do+ handshake sctx+ recvData sctx `shouldReturn` "after 33 key updates"+ )+ ( do+ handshake cctx+ replicateM_ 33 $ void $ updateKey cctx OneWay+ sendData cctx "after 33 key updates"+ )++handshake_key_update_non_positive :: IO ()+handshake_key_update_non_positive =+ forM_ [0, -1] $ \limit -> do+ (cparams, sparams0) <- generate arbitraryPairParams13+ let shared0 = serverShared sparams0+ limits = (sharedLimit shared0){limitKeyUpdate = Just limit}+ sparams = sparams0{serverShared = shared0{sharedLimit = limits}}+ withPairContextWith (id, id) (cparams, sparams) $ \(cctx, sctx) ->+ concurrently_+ ( do+ handshake sctx+ recvData sctx `shouldReturn` "after key update"+ )+ ( do+ handshake cctx+ void $ updateKey cctx OneWay+ sendData cctx "after key update"+ )+ -------------------------------------------------------------- handshake_cbc :: IO ()@@ -665,6 +823,65 @@ alpn xs | "h2" `elem` xs = return "h2" | otherwise = return "http/1.1"++handshake_alpn_rejects_unoffered_server_selection :: IO ()+handshake_alpn_rejects_unoffered_server_selection = do+ (clientParam, serverParam) <- generate arbitraryPairParams13+ let params = alpnParams clientParam serverParam (const $ pure "h2")+ withPairContextWith (id, id) params $ \(cctx, sctx) ->+ concurrently_+ (handshake sctx `shouldThrow` serverRejectedUnofferedALPN)+ (handshake cctx `shouldThrow` anyTLSException)++handshake_alpn_rejects_unoffered_client_selection :: IO ()+handshake_alpn_rejects_unoffered_client_selection = do+ (clientParam, serverParam) <- generate arbitraryPairParams13+ let params = alpnParams clientParam serverParam (pure . unsafeHead)+ withPairContextWith (id, id) params $ \(cctx, sctx) -> do+ contextHookSetHandshake13Recv cctx tamperALPN+ concurrently_+ (handshake sctx `shouldThrow` anyTLSException)+ (handshake cctx `shouldThrow` clientRejectedUnofferedALPN)+ where+ tamperALPN (EncryptedExtensions13 exts) =+ pure $ EncryptedExtensions13 $ map replaceALPN exts+ tamperALPN hs = pure hs+ replaceALPN ext@(ExtensionRaw eid _)+ | eid == EID_ApplicationLayerProtocolNegotiation =+ toExtensionRaw $ ApplicationLayerProtocolNegotiation ["h2"]+ | otherwise = ext++alpnParams+ :: ClientParams+ -> ServerParams+ -> ([B.ByteString] -> IO B.ByteString)+ -> (ClientParams, ServerParams)+alpnParams clientParam serverParam select =+ ( clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onSuggestALPN = pure $ Just ["http/1.1"]+ }+ }+ , serverParam+ { serverHooks =+ (serverHooks serverParam)+ { onALPNClientSuggest = Just select+ }+ }+ )++serverRejectedUnofferedALPN :: TLSException -> Bool+serverRejectedUnofferedALPN (HandshakeFailed (Error_Protocol msg alert)) =+ msg == "ALPN callback selected a protocol not offered by the client"+ && alert == NoApplicationProtocol+serverRejectedUnofferedALPN _ = False++clientRejectedUnofferedALPN :: TLSException -> Bool+clientRejectedUnofferedALPN (HandshakeFailed (Error_Protocol msg alert)) =+ msg == "server selected an ALPN protocol not offered by the client"+ && alert == IllegalParameter+clientRejectedUnofferedALPN _ = False handshake_sni :: (ClientParams, ServerParams) -> IO () handshake_sni (clientParam, serverParam) = do
test/Run.hs view
@@ -17,6 +17,7 @@ expectMaybe, newPairContext, newPairContextWith,+ withPairContext, withPairContextWith, withDataPipe, byeBye,@@ -158,6 +159,16 @@ handshake ctx sendData ctx $ L.fromStrict earlyData _ <- recvData ctx+ -- One more exchange, and this one the client starts. Our Finished is+ -- not sent by 'handshake' here: 0-RTT defers it, and the receive loop+ -- above is what puts it on the wire. The server emits the+ -- NewSessionTicket when it reads that Finished, which is after it sent+ -- the echo -- so reading the echo is not enough to have seen the+ -- ticket, and neither is a byte the server sends straight after it.+ -- The server cannot answer this without having read past the Finished+ -- first, and records arrive in order.+ sendData ctx "x"+ recvDataAssert ctx "x" bye ctx mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx expectMaybe "C: mode should be Just" mode mmode@@ -167,6 +178,8 @@ chunks <- replicateM (length ls) $ recvData ctx (map B.length chunks, B.concat chunks) `shouldBe` (ls, earlyData) sendData ctx $ L.fromStrict earlyData+ recvDataAssert ctx "x"+ sendData ctx "x" bye ctx mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx expectMaybe "S: mode should be Just" mode mmode@@ -189,6 +202,16 @@ handshake ctx sendData ctx $ L.fromStrict earlyData _ <- recvData ctx+ -- One more exchange, and this one the client starts. Our Finished is+ -- not sent by 'handshake' here: 0-RTT defers it, and the receive loop+ -- above is what puts it on the wire. The server emits the+ -- NewSessionTicket when it reads that Finished, which is after it sent+ -- the echo -- so reading the echo is not enough to have seen the+ -- ticket, and neither is a byte the server sends straight after it.+ -- The server cannot answer this without having read past the Finished+ -- first, and records arrive in order.+ sendData ctx "x"+ recvDataAssert ctx "x" bye ctx minfo <- contextGetInformation ctx let mmode = minfo >>= infoTLS13HandshakeMode@@ -201,6 +224,8 @@ chunks <- replicateM (length ls) $ recvData ctx (map B.length chunks, B.concat chunks) `shouldBe` (ls, earlyData) sendData ctx $ L.fromStrict earlyData+ recvDataAssert ctx "x"+ sendData ctx "x" bye ctx mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx expectMaybe "S: mode should be Just" mode mmode@@ -297,11 +322,15 @@ hsClient ctx d <- readChan queue sendData ctx (L.fromChunks [d])+ -- The server writes after any TLS 1.3 NewSessionTicket, so waiting for+ -- this byte ensures the client session manager received the ticket.+ recvDataAssert ctx "x" checkCtxFinished ctx bye ctx tlsServer ctx queue = do hsServer ctx d <- recvData ctx+ sendData ctx "x" writeChan queue [d] checkCtxFinished ctx bye ctx
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: tls-version: 2.4.4+version: 2.4.5 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -122,7 +122,7 @@ base16-bytestring, bytestring >=0.10 && <0.13, cereal >=0.5.3 && <0.6,- crypton >=1.1.2 && <1.2,+ crypton >=1.1.2 && <2.1, crypton-asn1-encoding >= 0.10.0 && < 0.11, crypton-asn1-types >= 0.4.1 && < 0.5, crypton-x509 >=1.9 && <1.10,@@ -130,7 +130,7 @@ crypton-x509-validation >=1.9 && <1.10, data-default, ech-config,- hpke >=0.1.0 && <0.2,+ hpke >=0.1.0 && <0.3, mlkem >= 0.2.0 && <0.3, mtl >=2.2 && <2.4, network >=3.1,