tls 2.4.8 → 2.4.9
raw patch · 30 files changed
+1621/−157 lines, 30 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +60/−37
- Network/TLS/Context.hs +1/−1
- Network/TLS/Context/Internal.hs +1/−1
- Network/TLS/Core.hs +2/−2
- Network/TLS/Crypto/IES.hs +23/−11
- Network/TLS/Extension.hs +27/−6
- Network/TLS/Handshake/Client/ClientHello.hs +13/−5
- Network/TLS/Handshake/Client/TLS13.hs +6/−3
- Network/TLS/Handshake/Common.hs +3/−0
- Network/TLS/Handshake/Common13.hs +19/−12
- Network/TLS/Handshake/Server.hs +1/−1
- Network/TLS/Handshake/Server/ClientHello.hs +17/−2
- Network/TLS/Handshake/Server/ClientHello12.hs +73/−2
- Network/TLS/Handshake/Server/ClientHello13.hs +20/−15
- Network/TLS/Handshake/Server/ServerHello12.hs +12/−2
- Network/TLS/Handshake/Server/TLS12.hs +14/−3
- Network/TLS/Handshake/Server/TLS13.hs +6/−1
- Network/TLS/Handshake/Signature.hs +34/−3
- Network/TLS/IO.hs +30/−2
- Network/TLS/IO/Decode.hs +54/−13
- Network/TLS/Packet.hs +24/−2
- Network/TLS/Packet13.hs +14/−3
- Network/TLS/PostHandshake.hs +3/−3
- Network/TLS/Record/Decrypt.hs +10/−4
- Network/TLS/Record/Recv.hs +23/−2
- test/EncodeSpec.hs +118/−0
- test/HandshakeSpec.hs +839/−0
- tls.cabal +1/−1
- util/Server.hs +5/−2
- util/tls-server.hs +168/−18
CHANGELOG.md view
@@ -1,51 +1,79 @@ # Change log for "tls" +## Version 2.4.9++* Include CertificateRequest in the post-handshake auth transcript.+ This breaks PHA with hs-tls 2.4.8 or earlier.+ [#565](https://github.com/haskell-tls/hs-tls/pull/565)+* Send a TLS 1.2 session ticket only to a client that asked for one.+ [#575](https://github.com/haskell-tls/hs-tls/pull/575)+* Fall back to a full handshake when a PSK finds a TLS 1.2 session.+ [#576](https://github.com/haskell-tls/hs-tls/pull/576)+* Refuse SCSV or a missing renegotiation_info in secure renegotiation.+ [#566](https://github.com/haskell-tls/hs-tls/pull/566)+* Reject a hybrid key share whose classical part fails to derive.+ [#550](https://github.com/haskell-tls/hs-tls/pull/550)+* Send no SNI for an empty server name, and refuse a malformed or+ invalid server_name.+ [#568](https://github.com/haskell-tls/hs-tls/pull/568)+* Refuse a CertificateVerify algorithm that is not offered or does not+ fit the key with illegal_parameter.+ [#562](https://github.com/haskell-tls/hs-tls/pull/562)+ [#578](https://github.com/haskell-tls/hs-tls/pull/578)+* Accept an empty TLS 1.2 client certificate when the hook does.+ [#552](https://github.com/haskell-tls/hs-tls/pull/552)+* Request EdDSA client certificates with ecdsa_sign in TLS 1.2.+ [#553](https://github.com/haskell-tls/hs-tls/pull/553)+* Accept a ClientHello whose legacy_version is above TLS 1.2.+ [#564](https://github.com/haskell-tls/hs-tls/pull/564)+* Answer malformed or misplaced messages with the alerts the RFCs ask for.+ [#554](https://github.com/haskell-tls/hs-tls/pull/554)+ [#555](https://github.com/haskell-tls/hs-tls/pull/555)+ [#556](https://github.com/haskell-tls/hs-tls/pull/556)+ [#557](https://github.com/haskell-tls/hs-tls/pull/557)+ [#558](https://github.com/haskell-tls/hs-tls/pull/558)+ [#559](https://github.com/haskell-tls/hs-tls/pull/559)+ [#560](https://github.com/haskell-tls/hs-tls/pull/560)+ [#561](https://github.com/haskell-tls/hs-tls/pull/561)+ [#563](https://github.com/haskell-tls/hs-tls/pull/563)+ [#567](https://github.com/haskell-tls/hs-tls/pull/567)+ [#569](https://github.com/haskell-tls/hs-tls/pull/569)+ [#570](https://github.com/haskell-tls/hs-tls/pull/570)+ [#571](https://github.com/haskell-tls/hs-tls/pull/571)+* tls-server: new options for tlsfuzzer, which CI runs weekly.+ [#551](https://github.com/haskell-tls/hs-tls/pull/551)+ [#572](https://github.com/haskell-tls/hs-tls/pull/572)+ [#573](https://github.com/haskell-tls/hs-tls/pull/573)+ [#574](https://github.com/haskell-tls/hs-tls/pull/574)+ [#577](https://github.com/haskell-tls/hs-tls/pull/577)+ ## Version 2.4.8 -* Stop printing traffic secrets and the session secret- [#549](https://github.com/haskell-tls/hs-tls/pull/549)+* Stop printing traffic secrets and the session secret.+ [#549](https://github.com/haskell-tls/hs-tls/pull/549) ## Version 2.4.7 -* The AES-GCM and ChaCha20-Poly1305 bulk ciphers go through the one-call- interfaces of crypton 2.1.1 -- `Crypto.Cipher.AES.GCM` and- `Crypto.Cipher.ChaCha.Poly1305` -- rather than the general AEAD one. Two- fixed costs go with every record: the state the key alone determines, which- `aeadInit` rebuilt for each record and `newContext` now builds once; and a- dictionary, which `AEADModeImpl`'s `forall ba. ByteArray ba =>` fields pass- at every call and no pragma can remove. Measured through `BulkAEAD` on an- Apple M4, a 64-byte record is about 73% faster to encrypt and to decrypt, a- 1400-byte one about 30%, and a 16 KiB one 2 to 4%. This needs- `crypton >= 2.1.1`; anyone who cannot move stays on 2.4.6, which is- unaffected+* Use the one-call AES-GCM and ChaCha20-Poly1305 interfaces of crypton.+ This needs crypton 2.1.1 or later.+ [#548](https://github.com/haskell-tls/hs-tls/pull/548) ## Version 2.4.6 -* Accept crypton 2.1, which made `ChaChaPoly1305.initialize` total by- taking a checked key rather than any `ByteArrayAccess`. The ChaCha20- bulk cipher now goes through `aeadChacha20poly1305Init` and the AEAD- interface, as the AES ciphers beside it already did. That function has- one type across every crypton this package accepts, so the bound stays- `>=1.1.2 && <2.2` and nobody is forced to move. The two are the same- computation: crypton's AEAD model for this cipher is `finalizeAAD .- appendAAD`, then encrypt or decrypt, then the whole sixteen-byte- Poly1305 tag whatever length is asked of it.+* Accept crypton 2.1. ## 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.+* CI: drop macOS with GHC 9.12. [#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.+* `extensionDecode` returns `Nothing` instead of calling `error`. [#544](https://github.com/haskell-tls/hs-tls/pull/544)-* `getTLSUnique` and `getTLSExporter` return `Nothing` before a handshake,- instead of calling `error`.+* `getTLSUnique` and `getTLSExporter` return `Nothing` before a handshake. [#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)@@ -53,17 +81,12 @@ [#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.+* Limit consecutive TLS 1.3 KeyUpdate messages with the new+ `limitKeyUpdate` parameter. [#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.+* Validate the negotiated ALPN protocol. [#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.+* Validate the negotiated cipher suite. [#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)
Network/TLS/Context.hs view
@@ -116,7 +116,7 @@ doHandshake :: a -> Context -> IO () doHandshakeWith :: a -> Context -> HandshakeR -> IO () doRequestCertificate :: a -> Context -> IO Bool- doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO ()+ doPostHandshakeAuthWith :: a -> Context -> Handshake13R -> IO () instance TLSParams ClientParams where getTLSCommonParams cparams =
Network/TLS/Context/Internal.hs view
@@ -174,7 +174,7 @@ { doHandshake_ :: Context -> IO () , doHandshakeWith_ :: Context -> HandshakeR -> IO () , doRequestCertificate_ :: Context -> IO Bool- , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO ()+ , doPostHandshakeAuthWith_ :: Context -> Handshake13R -> IO () } data Locks = Locks
Network/TLS/Core.hs view
@@ -423,8 +423,8 @@ let reason = "received key update before established" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- Client only- loopHandshake13 ((h@CertRequest13{}, _b) : hbs) =- postHandshakeAuthWith ctx h >> loopHandshake13 hbs+ loopHandshake13 (hb@(CertRequest13{}, _) : hbs) =+ postHandshakeAuthWith ctx hb >> loopHandshake13 hbs loopHandshake13 (hb@(h, _) : hbs) = do rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ case h of
Network/TLS/Crypto/IES.hs view
@@ -249,20 +249,32 @@ groupEncapsulate (GroupPubA_MLKEM1024 pub) = do (sec, ct) <- ML.encapsulate pub return $ Just (GroupPubB_MLKEM1024 ct, convert sec)+-- The classical part of a hybrid can fail as the group alone does: an+-- all-zero X25519 public key decodes, but the shared secret derived from+-- it is rejected. Nothing is turned into illegal_parameter by the caller. groupEncapsulate (GroupPubA_X25519MLKEM768 (e1, e2)) = do- (c1, k1) <- fromJust <$> getECDHPubShared' x25519 e1- (k2, c2) <- ML.encapsulate e2- -- Sec 4.1: Specifically, the order of shares in the concatenation- -- has been reversed.- return $ Just (GroupPubB_X25519MLKEM768 (c1, c2), convert k2 <> k1)+ mx <- getECDHPubShared' x25519 e1+ case mx of+ Nothing -> return Nothing+ Just (c1, k1) -> do+ (k2, c2) <- ML.encapsulate e2+ -- Sec 4.1: Specifically, the order of shares in the concatenation+ -- has been reversed.+ return $ Just (GroupPubB_X25519MLKEM768 (c1, c2), convert k2 <> k1) groupEncapsulate (GroupPubA_P256MLKEM768 (e1, e2)) = do- (c1, k1) <- fromJust <$> getECDHPubShared' p256 e1- (k2, c2) <- ML.encapsulate e2- return $ Just (GroupPubB_P256MLKEM768 (c1, c2), k1 <> convert k2)+ mx <- getECDHPubShared' p256 e1+ case mx of+ Nothing -> return Nothing+ Just (c1, k1) -> do+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P256MLKEM768 (c1, c2), k1 <> convert k2) groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = do- (c1, k1) <- fromJust <$> getECDHPubShared' p384 e1- (k2, c2) <- ML.encapsulate e2- return $ Just (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> convert k2)+ mx <- getECDHPubShared' p384 e1+ case mx of+ Nothing -> return Nothing+ Just (c1, k1) -> do+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> convert k2) dhGroupGetPubShared :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, GroupKey))
Network/TLS/Extension.hs view
@@ -481,21 +481,32 @@ where encodeNameType (ServerNameHostName hn) = putWord8 0 >> putOpaque16 (BC.pack hn) -- FIXME: should be puny code conversion encodeNameType (ServerNameOther (nt, opaque)) = putWord8 nt >> putBytes opaque- extensionDecode MsgTClientHello = decodeServerName+ extensionDecode MsgTClientHello = decodeServerNameList extensionDecode MsgTServerHello = decodeServerName extensionDecode MsgTEncryptedExtensions = decodeServerName extensionDecode _ = const Nothing decodeServerName :: ByteString -> Maybe ServerName decodeServerName "" = Just $ ServerName [] -- dirty hack for servers-decodeServerName bs = runGetMaybe decode bs+decodeServerName bs = decodeServerNameList bs++-- RFC 6066 Section 3: server_name_list<1..2^16-1> of+-- HostName<1..2^16-1>, which leaves no room for an empty extension, an+-- empty list, an empty host name nor trailing data.+decodeServerNameList :: ByteString -> Maybe ServerName+decodeServerNameList = runGetMaybe decode where decode = do len <- fromIntegral <$> getWord16- ServerName <$> getList len getServerName+ names <- getList len getServerName+ when (null names) $ fail "empty server_name_list"+ r <- remaining+ when (r /= 0) $ fail "trailing data in server_name"+ return $ ServerName names getServerName = do ty <- getWord8 snameParsed <- getOpaque16+ when (ty == 0 && B.null snameParsed) $ fail "empty host_name" let sname = B.copy snameParsed name = case ty of 0 -> ServerNameHostName $ BC.unpack sname -- FIXME: should be puny code conversion@@ -595,8 +606,11 @@ extensionDecode _ = const Nothing decodeEcPointFormatsSupported :: ByteString -> Maybe EcPointFormatsSupported-decodeEcPointFormatsSupported =- runGetMaybe (EcPointFormatsSupported . map EcPointFormat <$> getWords8)+decodeEcPointFormatsSupported = runGetMaybe $ do+ formats <- getWords8+ -- RFC 8422 Section 5.1.2: ec_point_format_list<1..2^8-1>+ when (null formats) $ fail "empty ec_point_format_list"+ return $ EcPointFormatsSupported $ map EcPointFormat formats ------------------------------------------------------------ @@ -672,10 +686,17 @@ :: ByteString -> Maybe ApplicationLayerProtocolNegotiation decodeApplicationLayerProtocolNegotiation = runGetMaybe $ do len <- getWord16- ApplicationLayerProtocolNegotiation <$> getList (fromIntegral len) getALPN+ protos <- getList (fromIntegral len) getALPN+ -- RFC 7301 Section 3.1: protocol_name_list<2..2^16-1> of+ -- ProtocolName<1..2^8-1>, with nothing after it.+ when (null protos) $ fail "empty protocol_name_list"+ r <- remaining+ when (r /= 0) $ fail "trailing data in application_layer_protocol_negotiation"+ return $ ApplicationLayerProtocolNegotiation protos where getALPN = do alpnParsed <- getOpaque8+ when (B.null alpnParsed) $ fail "empty ProtocolName" let alpn = B.copy alpnParsed return (B.length alpn + 1, alpn)
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -215,13 +215,16 @@ -------------------- + -- RFC 6066 Section 3: HostName is <1..2^16-1>, so no server_name+ -- is sent for an empty name. sniExt =- if clientUseServerNameIndication cparams+ if clientUseServerNameIndication cparams && not (null sni) then do- let sni = fst $ clientServerIdentification cparams usingState_ ctx $ setClientSNI sni return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing+ where+ sni = fst $ clientServerIdentification cparams -- RFC 8446 Sec 4.2.8 says: Each KeyShareEntry value MUST correspond -- to a group offered in the "supported_groups" extension and MUST@@ -266,7 +269,8 @@ case clientSessions cparams of (sidOrTkt, _) : _ | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt- _ | clientWantTicket cparams -> return $ Just $ toExtensionRaw $ SessionTicket ""+ _+ | clientWantTicket cparams -> return $ Just $ toExtensionRaw $ SessionTicket "" | otherwise -> return $ Nothing earlyDataExt@@ -507,9 +511,13 @@ step2 (sniExtI@(ExtensionRaw EID_ServerName _) : exts) = (sniExtO : os, sniExtI : is) where- sniExtO = toExtensionRaw $ ServerName [ServerNameHostName host] (os, is) = step3 exts id- step2 _ = error "step2"+ -- No server_name for an empty name: only the outer one names the+ -- public name.+ step2 exts = (sniExtO : os, is)+ where+ (os, is) = step3 exts id+ sniExtO = toExtensionRaw $ ServerName [ServerNameHostName host] step3 [] build = ([], [echOuterExt]) where echOuterExt = toExtensionRaw $ EchOuterExtensions $ build []
Network/TLS/Handshake/Client/TLS13.hs view
@@ -377,10 +377,13 @@ ---------------------------------------------------------------- postHandshakeAuthClientWith- :: ClientParams -> Context -> Handshake13 -> IO ()-postHandshakeAuthClientWith cparams ctx (CertRequest13 certReqCtx exts) =+ :: ClientParams -> Context -> Handshake13R -> IO ()+postHandshakeAuthClientWith cparams ctx hb@(CertRequest13 certReqCtx exts, _) = E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do- -- updateTranscriptHash13 ctx h b+ -- RFC 8446 Section 4.4: the handshake context of+ -- post-handshake authentication is ClientHello ... client+ -- Finished + CertificateRequest.+ updateTranscriptHash13 ctx hb processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx unless (level == CryptApplicationSecret) $
Network/TLS/Handshake/Common.hs view
@@ -103,6 +103,9 @@ errorToAlert (Error_Packet_Parsing msg) | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion) | "request_update" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter)+ | "cannot be decompressed" `isInfixOf` msg = (AlertLevel_Fatal, BadCertificate)+ | "unsupported certificate compression algorithm" `isInfixOf` msg =+ (AlertLevel_Fatal, IllegalParameter) | otherwise = (AlertLevel_Fatal, DecodeError) errorToAlert _ = (AlertLevel_Fatal, InternalError)
Network/TLS/Handshake/Common13.hs view
@@ -175,18 +175,25 @@ -> Signature -> ByteString -> m Bool-checkCertVerify ctx pub hs signature hashValue- | pub `signatureCompatible13` hs = liftIO $ do- role <- usingState_ ctx getRole- let ctxStr- | role == ClientRole = serverContextString -- opposite context- | otherwise = clientContextString- target = makeTarget ctxStr hashValue- sigParams = signatureParams pub hs- checkHashSignatureValid13 hs- checkSupportedHashSignature ctx hs- verifyPublic ctx sigParams target signature- | otherwise = return False+-- RFC 8446 Section 6.2: an algorithm that may not be used -- one TLS 1.3+-- does not allow, one not offered, or one that does not fit the key -- is a+-- field that is incorrect, an illegal_parameter. Only a signature that does+-- not verify is a decrypt_error, which False leads to.+checkCertVerify ctx pub hs signature hashValue = liftIO $ do+ checkHashSignatureValid13 hs+ checkSupportedHashSignature ctx hs+ unless (pub `signatureCompatible13` hs) $+ throwCore $+ Error_Protocol+ ("signature algorithm " ++ show hs ++ " does not fit the public key")+ IllegalParameter+ role <- usingState_ ctx getRole+ let ctxStr+ | role == ClientRole = serverContextString -- opposite context+ | otherwise = clientContextString+ target = makeTarget ctxStr hashValue+ sigParams = signatureParams pub hs+ verifyPublic ctx sigParams target signature makeTarget :: ByteString -> ByteString -> ByteString makeTarget contextString hashValue = runPut $ do
Network/TLS/Handshake/Server.hs view
@@ -86,4 +86,4 @@ resumeSessionData <- sendServerHello12 sparams ctx r chI recvClientSecondFlight12 sparams ctx resumeSessionData-handshake _ _ _ = throwCore $ Error_Protocol "client Hello is expected" HandshakeFailure+handshake _ _ (hs, _) = unexpected (show hs) (Just "client hello")
Network/TLS/Handshake/Server/ClientHello.hs view
@@ -57,7 +57,11 @@ (throwCore $ Error_HandshakePolicy "server: handshake denied") updateMeasure ctx incrementNbHandshakes - when (chVersion /= TLS12) $+ -- A legacy_version below TLS 1.2 is refused. One above it is not: a+ -- server negotiates the highest version it supports (RFC 5246 Appendix+ -- E.1), and with supported_versions present does not use legacy_version+ -- at all (RFC 8446 Section 4.2.1). Both are decided below.+ when (chVersion < TLS12) $ throwCore $ Error_Protocol (show chVersion ++ " is not supported") ProtocolVersion @@ -170,9 +174,20 @@ Nothing extractServerName where- extractServerName (ServerName ns) = listToMaybe (mapMaybe toHostName ns)+ extractServerName (ServerName ns) = case mapMaybe toHostName ns of+ [] -> Nothing+ [hostName]+ | all validChar hostName -> Just hostName+ | otherwise -> illegal "invalid host_name in SNI"+ _ -> illegal "multiple host_names in SNI" toHostName (ServerNameHostName hostName) = Just hostName toHostName (ServerNameOther _) = Nothing+ -- RFC 6066 Section 3: the server_name_list MUST NOT contain more+ -- than one name of the same name_type, and HostName is an ASCII+ -- DNS host name, so it has no control characters, spaces nor+ -- non-ASCII bytes.+ validChar c = c > ' ' && c < '\DEL'+ illegal msg = E.throw $ Uncontextualized $ Error_Protocol msg IllegalParameter findHighestVersionFrom :: Version -> [Version] -> Maybe Version findHighestVersionFrom clientVersion allowedVersions =
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -11,10 +11,12 @@ import Network.TLS.Crypto import Network.TLS.ErrT import Network.TLS.Extension+import Network.TLS.Handshake.Common (ticketOrSessionID12) import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature import Network.TLS.Imports import Network.TLS.Parameters+import Network.TLS.Session (SessionManager (..)) import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types (CipherId (..), Role (..))@@ -32,6 +34,7 @@ processClientHello12 sparams ctx ch = do let secureRenegotiation = supportedSecureRenegotiation $ serverSupported sparams when secureRenegotiation $ checkSecureRenegotiation ctx ch+ checkEcPointFormats ch serverName <- usingState_ ctx getClientSNI let hooks = serverHooks sparams extraCreds <- onServerNameIndication hooks serverName@@ -40,18 +43,58 @@ -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle -- empty lists.- when (null ciphersFilteredVersion) $+ when (null ciphersFilteredVersion) $ do+ checkResumedCipherOffered ctx ch throwCore $ Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure usedCipher <- chooseCipher hooks TLS12 ciphersFilteredVersion mcred <- chooseCreds usedCipher creds signatureCreds return (usedCipher, mcred) +-- RFC 5246 Section 7.4.1.2: a client resuming a session MUST offer the+-- cipher suite of that session. validateSession reports its absence with+-- illegal_parameter once a cipher has been chosen; when none can be chosen,+-- the same is reported here before the missing common cipher is.+checkResumedCipherOffered :: Context -> ClientHello -> IO ()+checkResumedCipherOffered ctx CH{..} = do+ let mticket =+ lookupAndDecode+ EID_SessionTicket+ MsgTClientHello+ chExtensions+ Nothing+ (\(SessionTicket ticket) -> Just ticket)+ case ticketOrSessionID12 mticket chSession of+ Nothing -> return ()+ Just identity -> do+ msd <- sessionResume (sharedSessionManager $ ctxShared ctx) identity+ case msd of+ Just sd+ | sessionVersion sd <= TLS12+ , CipherId (sessionCipher sd) `notElem` chCiphers ->+ throwCore $+ Error_Protocol "new cipher is different from the old one" IllegalParameter+ _ -> return ()+ checkSecureRenegotiation :: Context -> ClientHello -> IO () checkSecureRenegotiation ctx CH{..} = do -- RFC 5746: secure renegotiation -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF}- when (CipherId 0xff `elem` chCiphers) $+ let hasSCSV = CipherId 0xff `elem` chCiphers+ hasExt = isJust $ extensionLookup EID_SecureRenegotiation chExtensions+ established <- ctxEstablished ctx+ secure <- usingState_ ctx getSecureRenegotiation+ -- RFC 5746 Section 3.7: when renegotiating a connection whose+ -- secure_renegotiation flag is set, ClientHello MUST NOT contain+ -- the SCSV and MUST contain the renegotiation_info extension.+ when (established == Established && secure) $ do+ when hasSCSV $+ throwCore $+ Error_Protocol "SCSV in renegotiation" HandshakeFailure+ unless hasExt $+ throwCore $+ Error_Protocol "no renegotiation_info in renegotiation" HandshakeFailure+ when hasSCSV $ usingState_ ctx $ setSecureRenegotiation True case extensionLookup EID_SecureRenegotiation chExtensions of@@ -170,6 +213,34 @@ Error_Protocol "key exchange algorithm not implemented" HandshakeFailure ----------------------------------------------------------------++-- RFC 8422 Section 5.1.2: a client that names a curve of RFC 8422 in+-- supported_groups and sends ec_point_formats without the uncompressed+-- format is refused with illegal_parameter. An empty list is refused+-- with decode_error when decoding it.+checkEcPointFormats :: ClientHello -> IO ()+checkEcPointFormats CH{..} =+ lookupAndDecodeAndDo+ EID_EcPointFormats+ MsgTClientHello+ chExtensions+ (return ())+ $ \(EcPointFormatsSupported formats) ->+ when+ ( EcPointFormat_Uncompressed `notElem` formats+ && any (`elem` rfc8422Groups) groups+ )+ $ throwCore+ $ Error_Protocol "uncompressed point format missing" IllegalParameter+ where+ groups =+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ chExtensions+ []+ (\(SupportedGroups gs) -> gs)+ rfc8422Groups = [P256, P384, P521, X25519, X448] negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group] negotiatedGroupsInCommon serverGroups exts =
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -164,21 +164,26 @@ then sessionResumeOnlyOnce mgr identity else sessionResume mgr identity case msdata of- Just sdata -> do- let tinfo = fromJust $ sessionTicketInfo sdata- psk = sessionSecret sdata- isFresh <- checkFreshness tinfo obfAge- (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata- if isPSKvalid && isFresh- then- return- ( psk- , Just (bnd, 0 :: Int, len)- , is0RTTvalid- , sessionALPN sdata- )- else -- fall back to full handshake- return (zero, Nothing, False, Nothing)+ -- RFC 8446 Section 4.6.1: only a TLS 1.3 session, which+ -- has its ticket information, is resumed with a PSK. A+ -- TLS 1.2 one found under the same identity falls back+ -- to a full handshake.+ Just sdata+ | sessionVersion sdata == TLS13+ , Just tinfo <- sessionTicketInfo sdata -> do+ let psk = sessionSecret sdata+ isFresh <- checkFreshness tinfo obfAge+ (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata+ if isPSKvalid && isFresh+ then+ return+ ( psk+ , Just (bnd, 0 :: Int, len)+ , is0RTTvalid+ , sessionALPN sdata+ )+ else -- fall back to full handshake+ return (zero, Nothing, False, Nothing) _ -> return (zero, Nothing, False, Nothing) else return (zero, Nothing, False, Nothing) selectPSK _ = return (zero, Nothing, False, Nothing)
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -143,7 +143,7 @@ then do let (certTypes, hashSigs) = let as = supportedHashSignatures serverSupported- in (nub $ mapMaybe hashSigToCertType as, as)+ in (nub $ mapMaybe (fmap certTypeOnWire . hashSigToCertType) as, as) creq = CertRequest certTypes@@ -153,6 +153,12 @@ return $ b2 . (creq :) else return b2 where+ -- RFC 8422 Section 3.1: in TLS 1.2, ecdsa_sign asks for a certificate+ -- with an ECDSA- or EdDSA-capable public key. The Ed25519 and Ed448+ -- certificate types are synthetic values with no code point.+ certTypeOnWire CertificateType_Ed25519_Sign = CertificateType_ECDSA_Sign+ certTypeOnWire CertificateType_Ed448_Sign = CertificateType_ECDSA_Sign+ certTypeOnWire t = t commonGroups = negotiatedGroupsInCommon (supportedGroups serverSupported) chExts commonHashSigs = hashAndSignaturesInCommon (supportedHashSignatures serverSupported) chExts setup_DHE = do@@ -267,9 +273,13 @@ | ems = Just $ toExtensionRaw ExtendedMainSecret | otherwise = Nothing + -- RFC 5077 Section 3.2: the extension is sent only to a client that+ -- sent it. let useTicket = sessionUseTicket $ sharedSessionManager $ serverShared sparams+ clientTicket = isJust $ extensionLookup EID_SessionTicket chExts sessionTicketExt- | not resuming && useTicket = Just $ toExtensionRaw $ SessionTicket ""+ | not resuming && useTicket && clientTicket =+ Just $ toExtensionRaw $ SessionTicket "" | otherwise = Nothing -- in TLS12, we need to check as well the certificates we are sending if they have in the extension
Network/TLS/Handshake/Server/TLS12.hs view
@@ -10,6 +10,7 @@ import Network.TLS.Context.Internal import Network.TLS.Crypto+import Network.TLS.Extension import Network.TLS.Handshake.Common import Network.TLS.Handshake.Key import Network.TLS.Handshake.Server.Common@@ -37,11 +38,17 @@ Nothing -> do recvClientCCC sparams ctx mticket <- sessionEstablished ctx+ -- RFC 5077 Section 3.3: NewSessionTicket is sent only after+ -- the session_ticket extension in ServerHello, which only a+ -- client that sent it gets.+ clientTicket <-+ maybe False (isJust . extensionLookup EID_SessionTicket . chExtensions . fst)+ <$> usingHState ctx getClientHello case mticket of- Nothing -> return ()- Just ticket -> do+ Just ticket | clientTicket -> do let life = adjustLifetime $ serverTicketLifetime sparams sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] []+ _ -> return () sendCCSandFinished ctx ServerRole Just _ -> do _ <- sessionEstablished ctx@@ -92,7 +99,11 @@ -- matches our request and that we support -- verifying with that certificate. - return $ RecvStateHandshake $ expectClientKeyExchange True+ -- RFC 5246 Section 7.4.8: CertificateVerify follows only a+ -- certificate with signing capability, so not an empty one,+ -- which the hook may have accepted.+ let followedCertVerify = not $ isNullCertificateChain certs+ return $ RecvStateHandshake $ expectClientKeyExchange followedCertVerify expectClientCertificate p = expectClientKeyExchange False p -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher,
Network/TLS/Handshake/Server/TLS13.hs view
@@ -28,6 +28,7 @@ import Network.TLS.IO import Network.TLS.Imports import Network.TLS.KeySchedule+import Network.TLS.Packet13 (encodeHandshake13) import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State@@ -242,9 +243,13 @@ E.bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do sendPacket13 ctx $ Handshake13 [certReq13] [] withReadLock ctx $ do+ baseHState <- saveHState ctx+ -- RFC 8446 Section 4.4: the handshake context of+ -- post-handshake authentication is ClientHello ... client+ -- Finished + CertificateRequest.+ updateTranscriptHash13 ctx (certReq13, [encodeHandshake13 certReq13]) (clientCert13, bClientCert13) <- getHandshake ctx ref emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13- baseHState <- saveHState ctx updateTranscriptHash13 ctx (clientCert13, bClientCert13) th <- transcriptHash ctx "CH..Cert" unless emptyCert $ do
Network/TLS/Handshake/Signature.hs view
@@ -60,6 +60,25 @@ signatureCompatible (PubKeyEd448 _) (_, SignatureEd448) = True signatureCompatible _ (_, _) = False +-- Whether the signature algorithm is for the type of the key, whatever+-- its other parameters.+keyTypeFits :: PubKey -> SignatureAlgorithm -> Bool+keyTypeFits (PubKeyRSA _) s =+ s+ `elem` [ SignatureRSA+ , SignatureRSApssRSAeSHA256+ , SignatureRSApssRSAeSHA384+ , SignatureRSApssRSAeSHA512+ , SignatureRSApsspssSHA256+ , SignatureRSApsspssSHA384+ , SignatureRSApsspssSHA512+ ]+keyTypeFits (PubKeyDSA _) s = s == SignatureDSA+keyTypeFits (PubKeyEC _) s = s == SignatureECDSA+keyTypeFits (PubKeyEd25519 _) s = s == SignatureEd25519+keyTypeFits (PubKeyEd448 _) s = s == SignatureEd448+keyTypeFits _ _ = False+ -- Same as 'signatureCompatible' but for TLS13: for ECDSA this also checks the -- relation between hash in the HashAndSignatureAlgorithm and elliptic curve signatureCompatible13 :: PubKey -> HashAndSignatureAlgorithm -> Bool@@ -118,9 +137,21 @@ -> ByteString -> DigitallySigned -> IO Bool-checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _)- | pubKey `signatureCompatible` hashSigAlg = doVerify- | otherwise = return False+-- An algorithm not offered in CertificateRequest (RFC 5246 Section+-- 7.4.8), or one for another type of key, is a field that is incorrect,+-- an illegal_parameter. One for the right type of key that still does+-- not fit it, an RSASSA-PSS one for an rsaEncryption key say, is a+-- signature that does not verify, a decrypt_error, which False leads to.+checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg@(_, sigAlg) _) = do+ checkSupportedHashSignature ctx hashSigAlg+ unless (pubKey `keyTypeFits` sigAlg) $+ throwCore $+ Error_Protocol+ ("signature algorithm " ++ show hashSigAlg ++ " is for another type of key")+ IllegalParameter+ if pubKey `signatureCompatible` hashSigAlg+ then doVerify+ else return False where doVerify = prepareCertificateVerifySignatureData ctx usedVersion pubKey hashSigAlg msgs
Network/TLS/IO.hs view
@@ -102,8 +102,15 @@ Left err -> do logPacket ctx $ show err return $ Left err- Right record- | hrr && isCCS record -> loop (count + 1)+ Right record@(Record _ _ fragment)+ -- the ChangeCipherSpec after a HelloRetryRequest is skipped,+ -- but checked like any other+ | hrr && isCCS record ->+ case checkChangeCipherSpec fragment of+ Left err -> do+ logPacket ctx $ show err+ return $ Left err+ Right _ -> loop (count + 1) | otherwise -> do pktRecv <- decodePacket12 ctx record if isEmptyHandshake pktRecv@@ -181,6 +188,9 @@ return $ Right $ Handshake13 hss' bss logPacket ctx $ show pkt return pktRecv'+ Right pkt@(AppData13 _) -> do+ logPacket ctx $ show pkt+ checkNotInterleaved ctx pktRecv Right pkt -> do logPacket ctx $ show pkt return pktRecv@@ -193,6 +203,24 @@ isEmptyHandshake13 _ = False ----------------------------------------------------------------++-- RFC 8446 Section 5.1: handshake messages MUST NOT be interleaved with+-- other record types. Application data that arrives while a handshake+-- message is still incomplete is refused with unexpected_message rather+-- than delivered. TLS 1.3 only: RFC 5246 Section 6.2.1 lets TLS 1.2+-- interleave data of different content types.+checkNotInterleaved :: Context -> Either TLSError a -> IO (Either TLSError a)+checkNotInterleaved ctx pktRecv = do+ complete <- isRecvComplete ctx+ if complete+ then return pktRecv+ else do+ let err =+ Error_Packet_unexpected+ "application data"+ " expected: the rest of a handshake message"+ logPacket ctx $ show err+ return $ Left err isRecvComplete :: Context -> IO Bool isRecvComplete ctx = usingState_ ctx $ do
Network/TLS/IO/Decode.hs view
@@ -3,6 +3,7 @@ module Network.TLS.IO.Decode ( decodePacket12, decodePacket13,+ checkChangeCipherSpec, ) where import Control.Concurrent.MVar@@ -20,6 +21,7 @@ import Network.TLS.State import Network.TLS.Struct import Network.TLS.Struct13+import Network.TLS.Types (Role (..)) import Network.TLS.Util import Network.TLS.Wire @@ -27,46 +29,69 @@ decodePacket12 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData $ fragmentGetBytes fragment decodePacket12 _ (Record ProtocolType_Alert _ fragment) = return (Alert `fmapEither` decodeAlerts (fragmentGetBytes fragment)) decodePacket12 ctx (Record ProtocolType_ChangeCipherSpec _ fragment) =- case decodeChangeCipherSpec $ fragmentGetBytes fragment of+ case checkChangeCipherSpec fragment of Left err -> return $ Left err Right _ -> do- switchRxEncryption ctx- return $ Right ChangeCipherSpec+ -- ChangeCipherSpec comes between complete handshake messages+ -- (RFC 5246 Section 7.1), so not before the first ClientHello+ -- of a server, which has no handshake state yet, nor in the+ -- middle of a fragmented handshake message (CVE-2004-0079).+ mhs <- getHState ctx+ (mCont, _) <- usingState_ ctx $ gets stHandshakeRecordCont12+ if isNothing mhs || isJust mCont+ then+ return $+ Left $+ Error_Packet_unexpected "ChangeCipherSpec" " expected: handshake"+ else do+ switchRxEncryption ctx+ return $ Right ChangeCipherSpec decodePacket12 ctx (Record ProtocolType_Handshake ver fragment) = do- keyxchg <-- getHState ctx >>= \hs -> return (hs >>= hstPendingCipher >>= Just . cipherKeyExchange)+ mhs <- getHState ctx+ let keyxchg = mhs >>= hstPendingCipher >>= Just . cipherKeyExchange usingState ctx $ do+ role <- getRole let currentParams = CurrentParams { cParamsVersion = ver , cParamsKeyXchgType = keyxchg }+ -- A server has no handshake state until its first ClientHello,+ -- and that is the only message it may receive then (RFC 8446+ -- Section 4). Any other is answered with unexpected_message+ -- before its body is decoded, rather than with whatever decoding+ -- the body as that type gives.+ expectClientHello = role == ServerRole && isNothing mhs+ decode ty content+ | expectClientHello && ty /= HandshakeType_ClientHello =+ Left $ Error_Packet_unexpected (show ty) " expected: client hello"+ | otherwise = decodeHandshake currentParams ty content -- get back the optional continuation, and parse as many handshake record as possible. (mCont, wirebytes) <- gets stHandshakeRecordCont12 modify' (\st -> st{stHandshakeRecordCont12 = (Nothing, [])}) (hss, bss) <-- unzip <$> parseMany currentParams mCont wirebytes (fragmentGetBytes fragment)+ unzip <$> parseMany decode mCont wirebytes (fragmentGetBytes fragment) return $ Handshake hss bss where- parseMany currentParams mCont wirebytes bs =+ parseMany decode mCont wirebytes bs = case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err GotPartial cont -> do modify' (\st -> st{stHandshakeRecordCont12 = (Just cont, bs : wirebytes)}) return [] GotSuccess (ty, content) ->- case decodeHandshake currentParams ty content of+ case decode ty content of Left err -> throwError err Right h -> return [(h, reverse (bs : wirebytes))] GotSuccessRemaining (ty, content) left ->- case decodeHandshake currentParams ty content of+ case decode ty content of Left err -> throwError err Right h -> do- hbs <- parseMany currentParams Nothing [] left+ hbs <- parseMany decode Nothing [] left let len = BS.length bs - BS.length left bs' = BS.take len bs return ((h, reverse (bs' : wirebytes)) : hbs)-decodePacket12 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")+decodePacket12 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty switchRxEncryption :: Context -> IO () switchRxEncryption ctx =@@ -77,7 +102,7 @@ decodePacket13 :: Context -> Record Plaintext -> IO (Either TLSError Packet13) decodePacket13 _ (Record ProtocolType_ChangeCipherSpec _ fragment) =- case decodeChangeCipherSpec $ fragmentGetBytes fragment of+ case checkChangeCipherSpec fragment of Left err -> return $ Left err Right _ -> return $ Right ChangeCipherSpec13 decodePacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment@@ -106,4 +131,20 @@ let len = BS.length bs - BS.length left bs' = BS.take len bs return ((h, reverse (bs' : wirebytes)) : hbs)-decodePacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type")+decodePacket13 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty++-- RFC 8446 Section 5: a record of an unexpected type, including the inner+-- type of a TLS 1.3 record, is answered with unexpected_message.+unknownProtocolType :: ProtocolType -> TLSError+unknownProtocolType ty = Error_Packet_unexpected (show ty) " expected: TLS record type"++-- | A ChangeCipherSpec is the single byte 1. RFC 8446 Section 5 answers any+-- other value with unexpected_message, and TLS 1.2, which does not say,+-- is answered the same way: a record of two of them included.+checkChangeCipherSpec :: Fragment a -> Either TLSError ()+checkChangeCipherSpec fragment =+ case decodeChangeCipherSpec $ fragmentGetBytes fragment of+ Left _ ->+ Left $+ Error_Packet_unexpected "ChangeCipherSpec" " expected: the single byte 1"+ Right _ -> Right ()
Network/TLS/Packet.hs view
@@ -76,6 +76,7 @@ import Network.TLS.Struct import Network.TLS.Types import Network.TLS.Util.ASN1+import Network.TLS.Util.Serialization (os2ip) import Network.TLS.Wire ----------------------------------------------------------------@@ -174,6 +175,16 @@ {- FOURMOLU_DISABLE -} decodeHandshake :: CurrentParams -> HandshakeType -> ByteString -> Either TLSError Handshake+-- A ClientKeyExchange is only expected once a cipher, and with it a key+-- exchange, has been negotiated; one that comes without -- after Finished,+-- say -- is out of order rather than malformed.+decodeHandshake cp HandshakeType_ClientKeyXchg+ | isNothing (cParamsKeyXchgType cp) =+ const $+ Left $+ Error_Packet_unexpected+ (show HandshakeType_ClientKeyXchg)+ " expected: no ClientKeyExchange before a key exchange is negotiated" decodeHandshake cp ty = runGetErr ("handshake[" ++ show ty ++ "]") $ case ty of HandshakeType_HelloRequest -> decodeHelloRequest HandshakeType_ClientHello -> decodeClientHello False@@ -348,8 +359,19 @@ parseCKE CipherKeyExchange_ECDHE_RSA = parseClientECDHPublic parseCKE CipherKeyExchange_ECDHE_ECDSA = parseClientECDHPublic parseCKE _ = fail "unsupported client key exchange type"- parseClientDHPublic = CKX_DH . dhPublic <$> getInteger16- parseClientECDHPublic = CKX_ECDH <$> getOpaque8+ -- RFC 5246 Section 7.4.7.2: dh_Yc is <1..2^16-1>, so an empty one is+ -- malformed, a decode_error, before it is a public value that is not+ -- valid.+ parseClientDHPublic = do+ bs <- getOpaque16+ when (B.null bs) $ fail "empty DH public key"+ return $ CKX_DH $ dhPublic $ os2ip bs+ -- RFC 8422 Section 5.7: ecdh_Yc is <1..2^8-1>, so an empty one is+ -- malformed, a decode_error, before it is a point that does not decode.+ parseClientECDHPublic = do+ bs <- getOpaque8+ when (B.null bs) $ fail "empty ECDH public key"+ return $ CKX_ECDH bs decodeFinished :: Get Handshake decodeFinished = Finished . VerifyData <$> (remaining >>= getBytes)
Network/TLS/Packet13.hs view
@@ -220,18 +220,29 @@ 1 -> return $ KeyUpdate13 UpdateRequested x -> fail $ "Unknown request_update: " ++ show x +-- RFC 8879 Section 4: a certificate that cannot be decompressed, or whose+-- decompressed length is not the declared one, is answered with+-- bad_certificate, and an algorithm that was not offered with+-- illegal_parameter. errorToAlert tells them apart by the messages below.+-- A message that is malformed as a whole -- an empty+-- compressed_certificate_message, which its <1..2^24-1> bound forbids, or+-- bytes beyond the declared length -- is a decode_error, and is found+-- before anything is decompressed. decodeCompressedCertificate13 :: Get Handshake13 decodeCompressedCertificate13 = do algo <- getWord16- when (algo /= 1) $ fail "comp algo is not supported" -- fixme+ when (algo /= 1) $ fail "unsupported certificate compression algorithm" -- fixme len <- getWord24 bs <- getOpaque24+ left <- remaining+ when (left /= 0) $ fail "bytes after compressed certificate" if bs == "" then fail "empty compressed certificate" else case decompressIt len bs of- Left e -> fail (show e)+ Left e -> fail $ "certificate cannot be decompressed: " ++ show e Right bs' -> do- when (B.length bs' /= len) $ fail "plain length is wrong"+ when (B.length bs' /= len) $+ fail "certificate cannot be decompressed: wrong uncompressed_length" case runGetMaybe decodeCertificate13 bs' of Just (Certificate13 reqctx certs ess) -> return $ CompressedCertificate13 reqctx certs ess -- _ -> fail "compressed certificate cannot be parsed"
Network/TLS/PostHandshake.hs view
@@ -26,8 +26,8 @@ -- | Handle a post-handshake authentication flight with TLS 1.3. This -- is called automatically by 'recvData', in a context where the read -- lock is already taken. Client only.-postHandshakeAuthWith :: Context -> Handshake13 -> IO ()-postHandshakeAuthWith ctx hs =+postHandshakeAuthWith :: Context -> Handshake13R -> IO ()+postHandshakeAuthWith ctx hb = withWriteLock ctx $ handleException ctx $- doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hs+ doPostHandshakeAuthWith_ (ctxRoleParams ctx) ctx hb
Network/TLS/Record/Decrypt.hs view
@@ -130,9 +130,13 @@ blockSize = bulkBlockSize bulk econtentLen = B.length econtent + -- A record too short for the cipher cannot be deprotected: RFC 5246+ -- Section 7.2.2 and RFC 8446 Section 5.2 answer it with bad_record_mac. sanityCheckError =- throwError- (Error_Packet "encrypted content too small for encryption parameters")+ throwError $+ Error_Protocol+ "encrypted content too small for encryption parameters"+ BadRecordMac decryptOf :: BulkState -> RecordM ByteString decryptOf (BulkStateBlock decryptF) = do@@ -224,9 +228,11 @@ decryptOf BulkStateUninitialized = throwError $ Error_Protocol "decrypt state uninitialized" InternalError - -- handling of outer format can report errors with Error_Packet+ -- the outer format of a record that cannot be deprotected is reported+ -- as an integrity failure too, i.e. BadRecordMac get3o s ls =- maybe (throwError $ Error_Packet "record bad format") return $ partition3 s ls+ maybe (throwError $ Error_Protocol "record bad format" BadRecordMac) return $+ partition3 s ls get2o s (d1, d2) = get3o s (d1, d2, 0) >>= \(r1, r2, _) -> return (r1, r2) -- all format errors related to decrypted content are reported
Network/TLS/Record/Recv.hs view
@@ -50,7 +50,8 @@ -- ^ TLS context -> IO (Either TLSError (Record Plaintext)) recvRecord12 ctx =- readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)+ readExactBytes ctx 5+ >>= either (return . Left) (recvLengthE . (decodeHeader >=> checkType)) where recvLengthE = either (return . Left) recvLength @@ -69,7 +70,9 @@ >>= either (return . Left) (getRecord ctx header) recvRecord13 :: Context -> IO (Either TLSError (Record Plaintext))-recvRecord13 ctx = readExactBytes ctx 5 >>= either (return . Left) (recvLengthE . decodeHeader)+recvRecord13 ctx =+ readExactBytes ctx 5+ >>= either (return . Left) (recvLengthE . (decodeHeader >=> checkType)) where recvLengthE = either (return . Left) recvLength recvLength header@(Header _ _ readlen) = do@@ -90,6 +93,24 @@ maximumSizeExceeded :: TLSError maximumSizeExceeded = Error_Protocol "record exceeding maximum size" RecordOverflow++-- RFC 8446 Section 5: a record of an unexpected type is answered with+-- unexpected_message. Checked on the header, before the body is read, so+-- that what is no TLS record at all -- an SSLv2 ClientHello, say, whose first+-- byte reads as type 0x80 and whose length can ask for bytes that never+-- come -- is answered at once rather than when the peer gives up.+checkType :: Header -> Either TLSError Header+checkType header@(Header ty _ _)+ | ty `elem` known = Right header+ | otherwise =+ Left $ Error_Packet_unexpected (show ty) " expected: TLS record type"+ where+ known =+ [ ProtocolType_ChangeCipherSpec+ , ProtocolType_Alert+ , ProtocolType_Handshake+ , ProtocolType_AppData+ ] ----------------------------------------------------------------
test/EncodeSpec.hs view
@@ -8,9 +8,11 @@ import qualified Data.ByteString.Lazy as BL import Data.Either (isLeft) import Data.Int (Int64)+import Data.Word (Word16) import GHC.Conc (disableAllocationLimit, enableAllocationLimit, setAllocationCounter) import Network.TLS import Network.TLS.Internal+import Network.TLS.QUIC (errorToAlertDescription) import Test.Hspec import Test.Hspec.QuickCheck @@ -71,6 +73,113 @@ putOpaque24 compressed decodeHandshake13 HandshakeType_CompressedCertificate encoded `shouldSatisfy` isLeft+ -- RFC 8879 Section 4: a CompressedCertificate that cannot be+ -- decompressed, or whose decompressed length is not the one+ -- declared, is answered with bad_certificate; one with an algorithm+ -- that was not offered breaks no decoding rule but a field value,+ -- and is answered with illegal_parameter. One malformed as a whole+ -- stays a decode_error.+ it "answers a decompressed length mismatch with bad_certificate" $ do+ let plain = encodeCertificate13 B.empty (CertificateChain []) []+ compressed = BL.toStrict $ compress $ BL.fromStrict plain+ compressedCertificateAlert 1 (B.length plain + 1) compressed+ `shouldBe` Just BadCertificate+ it "answers data that is not zlib with bad_certificate" $+ compressedCertificateAlert 1 16 (B.replicate 16 0xff)+ `shouldBe` Just BadCertificate+ it "answers an empty compressed certificate with decode_error" $+ compressedCertificateAlert 1 16 B.empty+ `shouldBe` Just DecodeError+ it "answers bytes after a compressed certificate with decode_error" $ do+ let plain = encodeCertificate13 B.empty (CertificateChain []) []+ compressed = BL.toStrict $ compress $ BL.fromStrict plain+ either (Just . errorToAlertDescription) (const Nothing)+ ( decodeHandshake13 HandshakeType_CompressedCertificate $+ runPut $ do+ putWord16 1+ putWord24 (B.length plain)+ putOpaque24 (B.drop 2 compressed)+ putBytes (B.take 2 compressed)+ )+ `shouldBe` Just DecodeError+ it "answers an unsupported compression algorithm with illegal_parameter" $ do+ let plain = encodeCertificate13 B.empty (CertificateChain []) []+ compressed = BL.toStrict $ compress $ BL.fromStrict plain+ compressedCertificateAlert 2 (B.length plain) compressed+ `shouldBe` Just IllegalParameter+ -- A ClientKeyExchange is only expected once a cipher, and with it a+ -- key exchange, has been negotiated -- not, say, after Finished.+ -- One that comes without is out of order: unexpected_message.+ it "answers a ClientKeyExchange before a key exchange with unexpected_message" $+ either (Just . errorToAlertDescription) (const Nothing)+ ( decodeHandshake+ CurrentParams{cParamsVersion = TLS12, cParamsKeyXchgType = Nothing}+ HandshakeType_ClientKeyXchg+ (B.replicate 130 1)+ )+ `shouldBe` Just UnexpectedMessage+ -- RFC 7301 Section 3.1: protocol_name_list<2..2^16-1> of+ -- ProtocolName<1..2^8-1>.+ it "refuses a malformed application_layer_protocol_negotiation" $+ forM_+ [ B.empty -- empty extension+ , B.pack [0, 0] -- empty list+ , B.pack [0, 1, 0] -- empty ProtocolName+ , B.pack [0, 2, 1, 104, 2, 104, 50] -- trailing data+ ]+ $ \bs ->+ ( extensionDecode MsgTClientHello bs+ :: Maybe ApplicationLayerProtocolNegotiation+ )+ `shouldBe` Nothing+ it "decodes an application_layer_protocol_negotiation" $+ ( extensionDecode MsgTClientHello (B.pack [0, 3, 2, 104, 50])+ :: Maybe ApplicationLayerProtocolNegotiation+ )+ `shouldBe` Just (ApplicationLayerProtocolNegotiation [B.pack [104, 50]])+ -- RFC 8422 Section 5.7: ecdh_Yc is <1..2^8-1>, so an empty one is+ -- malformed -- a decode_error -- rather than a point that does not+ -- decode, which is an illegal_parameter.+ it "answers an empty ECDH public key with decode_error" $+ either (Just . errorToAlertDescription) (const Nothing)+ ( decodeHandshake+ CurrentParams+ { cParamsVersion = TLS12+ , cParamsKeyXchgType = Just CipherKeyExchange_ECDHE_RSA+ }+ HandshakeType_ClientKeyXchg+ (B.singleton 0)+ )+ `shouldBe` Just DecodeError+ -- RFC 5246 Section 7.4.7.2: dh_Yc is <1..2^16-1>, so an empty one is+ -- malformed -- a decode_error -- rather than a public value that is+ -- not valid, which is an illegal_parameter.+ -- RFC 6066 Section 3: server_name_list<1..2^16-1> of+ -- HostName<1..2^16-1>.+ it "refuses a malformed server_name in ClientHello" $+ forM_+ [ B.empty -- empty extension+ , B.pack [0, 0] -- empty list+ , B.pack [0, 3, 0, 0, 0] -- empty host_name+ , B.pack [0, 4, 0, 0, 1, 101, 120] -- trailing data+ ]+ $ \bs ->+ (extensionDecode MsgTClientHello bs :: Maybe ServerName)+ `shouldBe` Nothing+ it "decodes a server_name in ClientHello" $+ (extensionDecode MsgTClientHello (B.pack [0, 4, 0, 0, 1, 101]) :: Maybe ServerName)+ `shouldBe` Just (ServerName [ServerNameHostName "e"])+ it "answers an empty DH public key with decode_error" $+ either (Just . errorToAlertDescription) (const Nothing)+ ( decodeHandshake+ CurrentParams+ { cParamsVersion = TLS12+ , cParamsKeyXchgType = Just CipherKeyExchange_DHE_RSA+ }+ HandshakeType_ClientKeyXchg+ (B.pack [0, 0])+ )+ `shouldBe` Just DecodeError it "bounds TLS 1.3 certificate decompression by the declared size" $ do let compressed = BL.toStrict $ compress $ BL.replicate (32 * 1024 * 1024) 0 encoded = runPut $ do@@ -83,6 +192,15 @@ evaluate $ decodeHandshake13 HandshakeType_CompressedCertificate encoded decoded `shouldSatisfy` isLeft++compressedCertificateAlert :: Word16 -> Int -> ByteString -> Maybe AlertDescription+compressedCertificateAlert algo len compressed =+ either (Just . errorToAlertDescription) (const Nothing) $+ decodeHandshake13 HandshakeType_CompressedCertificate $+ runPut $ do+ putWord16 algo+ putWord24 len+ putOpaque24 compressed decodeHs :: ByteString -> Either TLSError Handshake decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b
test/HandshakeSpec.hs view
@@ -4,19 +4,28 @@ import Control.Concurrent (threadDelay) import Control.Concurrent.Async (concurrently_)+import qualified Control.Exception as E import Control.Monad+import Crypto.Cipher.AES (AES128)+import Crypto.Cipher.Types (AEADMode (..), AuthTag (..), aeadInit, aeadSimpleEncrypt, cipherInit)+import Crypto.Error (throwCryptoError)+import Data.Bits (shiftR, xor)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.IORef import Data.List import Data.Maybe+import Data.Word (Word16, Word64, Word8) import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Extra.CipherCBC import Network.TLS.Internal+import Network.TLS.QUIC (hkdfExpandLabel) import Test.Hspec import Test.Hspec.QuickCheck+import System.Timeout (timeout) import Test.QuickCheck import API@@ -46,6 +55,16 @@ "does not disable TLS 1.3 KeyUpdates with non-positive limits" handshake_key_update_non_positive prop "can prevent downgrade attack" handshake13_downgrade+ it "negotiates TLS 1.2 with a ClientHello naming a higher version" $+ handshake_high_legacy_version TLS12 (Version 0x0309)+ it "ignores legacy_version when supported_versions is present" $+ handshake_high_legacy_version TLS13 TLS13+ it "rejects ec_point_formats without uncompressed" $+ handshake12_ec_point_formats+ (B.pack [1, 1])+ rejectedAsIllegalParameter+ it "rejects an empty ec_point_formats" $+ handshake12_ec_point_formats (B.pack [0]) rejectedAsDecodeError prop "can negotiate hash and signature" handshake_hashsignatures prop "can negotiate cipher suite" handshake_ciphersuites it "rejects a cipher outside the server callback candidates" $@@ -69,7 +88,23 @@ handshake_server_key_purpose TLS13 KeyUsagePurpose_ClientAuth False prop "can handle client key usage" handshake_client_key_usage prop "can authenticate client" handshake_client_auth+ it "rejects a TLS 1.3 CertificateVerify algorithm unfit for the key" $+ handshake13_client_cert_verify_unfit_sigalg+ it "rejects a TLS 1.2 CertificateVerify algorithm for another key type" $+ handshake12_client_cert_verify_sigalg+ (HashSHA256, SignatureECDSA)+ rejectedAsIllegalParameter+ it "rejects a TLS 1.2 CertificateVerify that does not fit the RSA key" $+ handshake12_client_cert_verify_sigalg+ (HashIntrinsic, SignatureRSApsspssSHA256)+ rejectedAsDecryptError prop "can receive client authentication failure" handshake_client_auth_fail+ it "accepts an empty TLS 1.2 client certificate when the hook does" $+ handshake_client_auth_empty TLS12+ it "accepts an empty TLS 1.3 client certificate when the hook does" $+ handshake_client_auth_empty TLS13+ it "requests only defined certificate types in TLS 1.2" $+ handshake12_cert_request_types prop "can handle extended main secret" handshake_ems prop "can resume with extended main secret" handshake_resumption_ems prop "can handle ALPN" handshake_alpn@@ -78,13 +113,38 @@ it "rejects an unoffered ALPN selection received by the client" $ handshake_alpn_rejects_unoffered_client_selection prop "can handle SNI" handshake_sni+ it "sends no SNI for an empty server name" handshake_sni_empty+ it "rejects multiple host_names in SNI" $+ handshake_sni_illegal ["example.com", "example.org"]+ it "rejects a host_name with a control character in SNI" $+ handshake_sni_illegal ["example\0.com"]+ it "rejects a non-ASCII host_name in SNI" $+ handshake_sni_illegal ["ex\xc4\x85mple.com"] prop "can handshake with TLS 1.2 CBC" handshake_cbc prop "can re-negotiate with TLS 1.2" handshake12_renegotiation+ it "rejects SCSV in a secure renegotiation" $+ handshake12_renegotiation_tampered $ \ch ->+ ch{chCiphers = chCiphers ch ++ [CipherId 0xff]}+ it "rejects a secure renegotiation without renegotiation_info" $+ handshake12_renegotiation_tampered $ \ch ->+ ch+ { chExtensions =+ filter+ (\(ExtensionRaw eid _) -> eid /= EID_SecureRenegotiation)+ (chExtensions ch)+ } prop "can resume session with TLS 1.2" handshake12_session_resumption+ prop+ "rejects resuming a TLS 1.2 session without its cipher"+ handshake12_session_resumption_cipher_missing prop "can resume session ticket with TLS 1.2" handshake12_session_ticket+ it "sends no session ticket to a TLS 1.2 client that did not ask" $+ handshake12_session_ticket_unoffered prop "can handshake with TLS 1.3 Full" handshake13_full prop "can handshake with TLS 1.3 HRR" handshake13_hrr prop "can handshake with TLS 1.3 PSK" handshake13_psk+ it "does not resume a TLS 1.2 session with a TLS 1.3 PSK" $+ handshake13_psk_tls12_session prop "can handshake with TLS 1.3 PSK ticket" handshake13_psk_ticket prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt@@ -94,10 +154,48 @@ prop "can handshake with TLS 1.3 EE" handshake13_ee_groups prop "can handshake with TLS 1.3 EC groups" handshake13_ec prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe+ it "rejects an X25519MLKEM768 key share with a zero X25519 part" $+ handshake13_x25519mlkem768_zero_x25519 prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth it "keeps record alignment when a slow record follows client auth" handshake13_client_auth_slow_record+ it "rejects a too short TLS 1.2 AEAD record with bad_record_mac" $+ short_record_bad_record_mac TLS12 cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+ it "rejects a too short TLS 1.2 CBC record with bad_record_mac" $+ short_record_bad_record_mac TLS12 cipher_ECDHE_RSA_AES128CBC_SHA256+ it "rejects a too short TLS 1.3 record with bad_record_mac" $+ short_record_bad_record_mac TLS13 cipher13_AES_128_GCM_SHA256+ it "rejects a ServerHello as the first client message" $+ server_first_message_unexpected 2+ it "rejects a Finished as the first client message" $+ server_first_message_unexpected 20+ it "rejects an unknown handshake type as the first client message" $+ server_first_message_unexpected 254+ it "rejects a ChangeCipherSpec before the first ClientHello" $+ server_ccs_interleaved 0+ it "rejects a ChangeCipherSpec inside a fragmented ClientHello" $+ server_ccs_interleaved 2+ it "rejects an SSLv2-style record header at once" $+ server_first_record_type_unexpected 0x80 0x3fff+ it "rejects an unknown record type" $+ server_first_record_type_unexpected 24 0+ it "rejects application data inside a TLS 1.3 handshake message" $+ handshake13_interleaved_app_data+ it "rejects a two-byte TLS 1.2 ChangeCipherSpec" $+ malformed_ccs_unexpected+ TLS12+ cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+ [P256]+ [P256]+ it "rejects a two-byte TLS 1.3 ChangeCipherSpec" $+ malformed_ccs_unexpected TLS13 cipher13_AES_128_GCM_SHA256 [X25519] [X25519]+ it "rejects a two-byte TLS 1.3 ChangeCipherSpec after HelloRetryRequest" $+ malformed_ccs_unexpected+ TLS13+ cipher13_AES_128_GCM_SHA256+ [P256, X25519]+ [X25519] -------------------------------------------------------------- @@ -707,6 +805,254 @@ | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) +-- A client without a certificate answers CertificateRequest with an empty+-- Certificate and, in TLS 1.2, sends no CertificateVerify. A server whose+-- hook accepts that must go on to ChangeCipherSpec rather than wait for a+-- CertificateVerify.+handshake_client_auth_empty :: Version -> IO ()+handshake_client_auth_empty version = do+ let cipher+ | version == TLS13 = cipher13_AES_128_GCM_SHA256+ | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([version], [version])+ ([cipher], [cipher])+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onCertificateRequest = \_ -> return Nothing+ }+ }+ serverParam' =+ serverParam+ { serverWantClientCert = True+ , serverHooks =+ (serverHooks serverParam)+ { onClientCertificate = acceptEmpty+ }+ }+ runTLSSimple (clientParam', serverParam')+ where+ acceptEmpty chain+ | isNullCertificateChain chain = return CertificateUsageAccept+ | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA)++-- In TLS 1.2 a client certificate with an Ed25519 or Ed448 key is asked+-- for with ecdsa_sign (RFC 8422 Section 3.1). The Ed25519 and Ed448+-- certificate types of this library are synthetic and have no code point,+-- so they must not reach the wire.+handshake12_cert_request_types :: IO ()+handshake12_cert_request_types = do+ let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([TLS12], [TLS12])+ ([cipher], [cipher])+ ref <- newIORef Nothing+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onCertificateRequest = \_ -> return Nothing+ }+ }+ serverParam' =+ serverParam+ { serverWantClientCert = True+ , serverSupported =+ (serverSupported serverParam)+ { supportedHashSignatures =+ supportedHashSignatures defaultSupported+ }+ , serverHooks =+ (serverHooks serverParam)+ { onClientCertificate = \_ -> return CertificateUsageAccept+ }+ }+ record hs@(CertRequest certTypes _ _) = writeIORef ref (Just certTypes) >> return hs+ record hs = return hs+ withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv cctx record+ concurrently_ (handshake sctx) (handshake cctx)+ mtypes <- readIORef ref+ case mtypes of+ Nothing -> expectationFailure "no CertificateRequest received"+ Just certTypes -> do+ certTypes `shouldSatisfy` all (`elem` defined)+ certTypes `shouldContain` [CertificateType_ECDSA_Sign]+ where+ defined =+ [ CertificateType_RSA_Sign+ , CertificateType_DSA_Sign+ , CertificateType_ECDSA_Sign+ ]++-- RFC 5246 Section 7.4.8: a TLS 1.2 CertificateVerify algorithm for+-- another type of key than the certificate's has a field that is+-- incorrect, an illegal_parameter, even when onUnverifiedClientCert would+-- accept a signature that does not verify. One for an RSA key that still+-- does not fit it, RSASSA-PSS for an rsaEncryption key, is a signature+-- that does not verify, a decrypt_error. The client signs with an+-- rsaEncryption key and the server reads the given algorithm.+handshake12_client_cert_verify_sigalg+ :: HashAndSignatureAlgorithm -> Selector TLSException -> IO ()+handshake12_client_cert_verify_sigalg alg rejected = do+ let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([TLS12], [TLS12])+ ([cipher], [cipher])+ cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onCertificateRequest = \_ -> return $ Just cred+ }+ }+ acceptUnverified = alg == (HashSHA256, SignatureECDSA)+ serverParam' =+ serverParam+ { serverWantClientCert = True+ , serverHooks =+ (serverHooks serverParam)+ { onClientCertificate = \_ -> return CertificateUsageAccept+ , onUnverifiedClientCert = return acceptUnverified+ }+ }+ unfit (CertVerify (DigitallySigned _ sig)) =+ pure $ CertVerify (DigitallySigned alg sig)+ unfit hs = pure hs+ r <- timeout 10000000 $+ withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv sctx unfit+ concurrently_+ (handshake sctx `shouldThrow` rejected)+ (void (E.try (handshake cctx) :: IO (Either TLSException ())))+ r `shouldSatisfy` isJust++rejectedAsDecryptError :: TLSException -> Bool+rejectedAsDecryptError (HandshakeFailed (Error_Protocol _ DecryptError)) = True+rejectedAsDecryptError _ = False++-- RFC 8446 Section 6.2: a CertificateVerify whose algorithm may not be used+-- with the certificate's key has a field that is incorrect, which is an+-- illegal_parameter; decrypt_error is for a signature that does not verify.+-- The client signs with RSA-PSS for an rsaEncryption key and the server+-- reads the algorithm as rsa_pss_pss_sha256, which needs an RSASSA-PSS key.+handshake13_client_cert_verify_unfit_sigalg :: IO ()+handshake13_client_cert_verify_unfit_sigalg = do+ let cipher = cipher13_AES_128_GCM_SHA256+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([TLS13], [TLS13])+ ([cipher], [cipher])+ cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth+ let clientParam' =+ clientParam+ { clientHooks =+ (clientHooks clientParam)+ { onCertificateRequest = \_ -> return $ Just cred+ }+ }+ serverParam' =+ serverParam+ { serverWantClientCert = True+ , serverHooks =+ (serverHooks serverParam)+ { onClientCertificate = \_ -> return CertificateUsageAccept+ }+ }+ unfit (CertVerify13 (DigitallySigned _ sig)) =+ pure $+ CertVerify13 (DigitallySigned (HashIntrinsic, SignatureRSApsspssSHA256) sig)+ unfit hs = pure hs+ r <- timeout 10000000 $+ withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do+ contextHookSetHandshake13Recv sctx unfit+ concurrently_+ ((handshake sctx >> recvData sctx) `shouldThrow` rejectedAsIllegalParameter)+ ( void+ (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString))+ )+ r `shouldSatisfy` isJust++rejectedAsIllegalParameter :: TLSException -> Bool+rejectedAsIllegalParameter (HandshakeFailed (Error_Protocol _ IllegalParameter)) = True+rejectedAsIllegalParameter (Terminated _ _ (Error_Protocol _ IllegalParameter)) = True+rejectedAsIllegalParameter _ = False++-- A server that receives a ClientHello whose legacy_version is higher than+-- its own negotiates the highest version it supports (RFC 5246 Appendix+-- E.1); with supported_versions present it does not use legacy_version at+-- all (RFC 8446 Section 4.2.1). The ClientHello's legacy_version is raised+-- on its way to the server, and the handshake must still reach the version+-- both sides support.+handshake_high_legacy_version :: Version -> Version -> IO ()+handshake_high_legacy_version version legacy = do+ let cipher+ | version == TLS13 = cipher13_AES_128_GCM_SHA256+ | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([version], [version])+ ([cipher], [cipher])+ let raise (ClientHello ch) = pure $ ClientHello ch{chVersion = legacy}+ raise hs = pure hs+ withPairContextWith (id, id) (clientParam, serverParam) $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv sctx raise+ concurrently_ (handshake sctx) (handshake cctx)+ info <- contextGetInformation sctx+ (infoVersion <$> info) `shouldBe` Just version++-- RFC 8422 Section 5.1.2: ec_point_format_list is <1..2^8-1>, and a+-- client naming one of its curves in supported_groups must offer the+-- uncompressed format. The ClientHello's ec_point_formats is replaced+-- on its way to the server, which must refuse it.+handshake12_ec_point_formats+ :: B.ByteString -> Selector TLSException -> IO ()+handshake12_ec_point_formats formats rejected = do+ CSP12 (cparams, sparams) <- generate arbitrary+ let cparams' =+ cparams+ { clientSupported =+ (clientSupported cparams){supportedGroups = [X25519]}+ }+ sparams' =+ sparams+ { serverSupported =+ (serverSupported sparams){supportedGroups = [X25519]}+ }+ replace (ClientHello ch) =+ pure $+ ClientHello+ ch+ { chExtensions =+ filter+ (\(ExtensionRaw eid _) -> eid /= EID_EcPointFormats)+ (chExtensions ch)+ ++ [ExtensionRaw EID_EcPointFormats formats]+ }+ replace hs = pure hs+ r <- timeout 10000000 $+ withPairContextWith (id, id) (cparams', sparams') $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv sctx replace+ concurrently_+ (handshake sctx `shouldThrow` rejected)+ (void (E.try (handshake cctx) :: IO (Either TLSException ())))+ r `shouldSatisfy` isJust++rejectedAsDecodeError :: TLSException -> Bool+rejectedAsDecodeError (HandshakeFailed (Error_Protocol _ DecodeError)) = True+rejectedAsDecodeError _ = False+ handshake_client_auth_fail :: (ClientParams, ServerParams) -> IO () handshake_client_auth_fail (clientParam, serverParam) = do let clientVersions = supportedVersions $ clientSupported clientParam@@ -883,6 +1229,52 @@ && alert == IllegalParameter clientRejectedUnofferedALPN _ = False +-- RFC 6066 Section 3: HostName is <1..2^16-1>, so a client with an+-- empty server name sends no server_name, and the server sees none.+handshake_sni_empty :: IO ()+handshake_sni_empty = do+ CSP12 (clientParam, serverParam) <- generate arbitrary+ let clientParam' = clientParam{clientServerIdentification = ("", "")}+ runTLSSuccess (clientParam', serverParam) hs hs+ where+ hs ctx = do+ handshake ctx+ msni <- getClientSNI ctx+ msni `shouldBe` Nothing++-- RFC 6066 Section 3: the server_name_list MUST NOT contain more than one+-- name of the same name_type, and HostName is an ASCII DNS host name. The+-- ClientHello's server_name is replaced on its way to the server, which+-- must refuse it with illegal_parameter.+handshake_sni_illegal :: [B.ByteString] -> IO ()+handshake_sni_illegal names = do+ CSP12 (clientParam, serverParam) <- generate arbitrary+ let entry name =+ B.concat [B.pack [0, len `shiftR` 8, len], name]+ where+ len = fromIntegral $ B.length name+ list = B.concat $ map entry names+ listLen = fromIntegral $ B.length list+ sni = B.concat [B.pack [listLen `shiftR` 8, listLen], list]+ replace (ClientHello ch) =+ pure $+ ClientHello+ ch+ { chExtensions =+ ExtensionRaw EID_ServerName sni+ : filter+ (\(ExtensionRaw eid _) -> eid /= EID_ServerName)+ (chExtensions ch)+ }+ replace hs = pure hs+ r <- timeout 10000000 $+ withPairContextWith (id, id) (clientParam, serverParam) $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv sctx replace+ concurrently_+ (handshake sctx `shouldThrow` rejectedAsIllegalParameter)+ (void (E.try (handshake cctx) :: IO (Either TLSException ())))+ r `shouldSatisfy` isJust+ handshake_sni :: (ClientParams, ServerParams) -> IO () handshake_sni (clientParam, serverParam) = do ref <- newIORef Nothing@@ -942,6 +1334,49 @@ -- recvData receives the alert from the second handshake hsServer ctx = handshake ctx >> void (recvData ctx) +-- RFC 5746 Section 3.7: when a connection with secure renegotiation is+-- renegotiated, ClientHello must not contain the SCSV and must contain+-- the renegotiation_info extension. The second ClientHello is tampered+-- with on its way to the server, which must abort with handshake_failure.+handshake12_renegotiation_tampered :: (ClientHello -> ClientHello) -> IO ()+handshake12_renegotiation_tampered tamper = do+ CSP12 (cparams, sparams) <- generate arbitrary+ let cparams' =+ cparams+ { clientSupported =+ (clientSupported cparams)+ { supportedSecureRenegotiation = True+ }+ }+ sparams' =+ sparams+ { serverSupported =+ (serverSupported sparams)+ { supportedSecureRenegotiation = True+ , supportedClientInitiatedRenegotiation = True+ }+ }+ count <- newIORef (0 :: Int)+ let tamperSecond (ClientHello ch) = do+ n <- atomicModifyIORef' count $ \i -> (i + 1, i)+ pure $ ClientHello $ if n == 0 then ch else tamper ch+ tamperSecond hs = pure hs+ r <- timeout 10000000 $+ withPairContextWith (id, id) (cparams', sparams') $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv sctx tamperSecond+ concurrently_ (handshake sctx) (handshake cctx)+ concurrently_+ (recvData sctx `shouldThrow` rejectedAsHandshakeFailure)+ ( void+ (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString))+ )+ r `shouldSatisfy` isJust++rejectedAsHandshakeFailure :: TLSException -> Bool+rejectedAsHandshakeFailure (HandshakeFailed (Error_Protocol _ HandshakeFailure)) = True+rejectedAsHandshakeFailure (Terminated _ _ (Error_Protocol _ HandshakeFailure)) = True+rejectedAsHandshakeFailure _ = False+ handshake12_session_resumption :: CSP12 -> IO () handshake12_session_resumption (CSP12 plainParams) = do sessionRefs <- twoSessionRefs@@ -958,6 +1393,69 @@ runTLSPredicate params2 (maybe False infoTLS12Resumption) +-- RFC 5246 Section 7.4.1.2: a client resuming a session MUST offer its+-- cipher suite. When it asks to resume one and offers none the server can+-- use, that is what is reported -- illegal_parameter, as when a cipher could+-- be chosen -- rather than the missing common cipher.+handshake12_session_resumption_cipher_missing :: CSP12 -> IO ()+handshake12_session_resumption_cipher_missing (CSP12 plainParams) = do+ sessionRefs <- twoSessionRefs+ let sessionManagers = twoSessionManagers sessionRefs+ params = setPairParamsSessionManagers sessionManagers plainParams+ runTLSSimple params+ sessionParams <- readClientSessionRef sessionRefs+ expectJust "session param should be Just" sessionParams+ let params2 = setPairParamsSessionResuming (fromJust sessionParams) params+ -- TLS_RSA_WITH_NULL_MD5, which the server does not support+ nullCiphers (ClientHello ch) = pure $ ClientHello ch{chCiphers = [CipherId 0x0001]}+ nullCiphers hs = pure hs+ withPairContextWith (id, id) params2 $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv sctx nullCiphers+ concurrently_+ (handshake sctx `shouldThrow` serverRejectedMissingCipher)+ (handshake cctx `shouldThrow` anyTLSException)++serverRejectedMissingCipher :: TLSException -> Bool+serverRejectedMissingCipher (HandshakeFailed (Error_Protocol _ IllegalParameter)) = True+serverRejectedMissingCipher _ = False++-- RFC 5077 Sections 3.2 and 3.3: a server sends the session_ticket+-- extension and NewSessionTicket only to a client that sent the+-- extension. The client's session_ticket is removed on its way to a+-- server whose session manager uses tickets, and the client must then+-- receive neither.+handshake12_session_ticket_unoffered :: IO ()+handshake12_session_ticket_unoffered = do+ CSP12 (cparams, sparams) <- generate arbitrary+ let sparams' =+ sparams+ { serverShared =+ (serverShared sparams){sharedSessionManager = oneSessionTicket}+ }+ unoffer (ClientHello ch) =+ pure $+ ClientHello+ ch+ { chExtensions =+ filter+ (\(ExtensionRaw eid _) -> eid /= EID_SessionTicket)+ (chExtensions ch)+ }+ unoffer hs = pure hs+ received <- newIORef []+ let record hs = modifyIORef received (hs :) >> pure hs+ withPairContextWith (id, id) (cparams, sparams') $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv sctx unoffer+ contextHookSetHandshakeRecv cctx record+ concurrently_ (handshake sctx) (handshake cctx)+ hss <- readIORef received+ let ticketExt (ServerHello sh) =+ any (\(ExtensionRaw eid _) -> eid == EID_SessionTicket) (shExtensions sh)+ ticketExt _ = False+ newTicket NewSessionTicket{} = True+ newTicket _ = False+ filter (\h -> ticketExt h || newTicket h) hss `shouldBe` []+ handshake12_session_ticket :: CSP12 -> IO () handshake12_session_ticket (CSP12 plainParams) = do sessionRefs <- twoSessionRefs@@ -1047,6 +1545,51 @@ runTLSSimple13 params2 PreSharedKey +-- RFC 8446 Section 4.6.1: a TLS 1.3 PSK resumes only a TLS 1.3 session.+-- The server's session manager answers the client's PSK identity with a+-- TLS 1.2 session, which has no ticket information; the server must+-- fall back to a full handshake rather than fail.+handshake13_psk_tls12_session :: IO ()+handshake13_psk_tls12_session = do+ CSP12 params12 <- generate arbitrary+ refs12 <- twoSessionRefs+ runTLSSimple $ setPairParamsSessionManagers (twoSessionManagers refs12) params12+ Just (_, sdata12) <- readIORef (snd refs12)+ sessionVersion sdata12 `shouldBe` TLS12++ CSP13 (cli, srv) <- generate arbitrary+ let cliSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [P256, X25519]+ }+ svrSupported =+ defaultSupported+ { supportedCiphers = [cipher13_AES_128_GCM_SHA256]+ , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]]+ }+ params0 =+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ refs13 <- twoSessionRefs+ let params = setPairParamsSessionManagers (twoSessionManagers refs13) params0+ runTLSSimple13 params HelloRetryRequest+ Just sessionParams <- readClientSessionRef refs13++ let tls12Manager =+ noSessionManager+ { sessionResume = \_ -> return $ Just sdata12+ , sessionResumeOnlyOnce = \_ -> return $ Just sdata12+ }+ params2 =+ setPairParamsSessionResuming sessionParams $+ setPairParamsSessionManagers (fst (twoSessionManagers refs13), tls12Manager) params0+ -- The key share is for the group of the earlier session, so no+ -- HelloRetryRequest, and the PSK is not used.+ runTLSSimple13 params2 FullHandshake+ handshake13_psk_ticket :: CSP13 -> IO () handshake13_psk_ticket (CSP13 (cli, srv)) = do let cliSupported =@@ -1365,6 +1908,50 @@ ) runTLSSimple13 params FullHandshake +-- An all-zero X25519 public key decodes, but the shared secret computed+-- from it is all zero and is rejected. The server must answer with+-- illegal_parameter, as it does for X25519 alone, rather than crash.+handshake13_x25519mlkem768_zero_x25519 :: IO ()+handshake13_x25519mlkem768_zero_x25519 = do+ CSP13 (cli, srv) <- generate arbitrary+ let cliSupported =+ (clientSupported cli){supportedGroups = [X25519MLKEM768]}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = [X25519MLKEM768]+ , supportedGroupsTLS13 = [[X25519MLKEM768]]+ }+ params =+ ( cli{clientSupported = cliSupported}+ , srv{serverSupported = svrSupported}+ )+ withPairContextWith (id, id) params $ \(cctx, sctx) -> do+ contextHookSetHandshakeRecv sctx zeroX25519+ concurrently_+ (handshake sctx `shouldThrow` serverRejectedZeroX25519)+ (handshake cctx `shouldThrow` anyTLSException)+ where+ zeroX25519 (ClientHello ch) =+ pure $ ClientHello ch{chExtensions = map zeroKeyShare $ chExtensions ch}+ zeroX25519 hs = pure hs+ zeroKeyShare ext@(ExtensionRaw eid bs)+ | eid == EID_KeyShare+ , Just (KeyShareClientHello kses) <- extensionDecode MsgTClientHello bs =+ toExtensionRaw $ KeyShareClientHello $ map zeroEntry kses+ | otherwise = ext+ -- The ML-KEM-768 encapsulation key (1184 bytes) is followed by the+ -- X25519 public key (32 bytes).+ zeroEntry (KeyShareEntry grp key)+ | grp == X25519MLKEM768 =+ KeyShareEntry grp $ B.take 1184 key <> B.replicate 32 0+ zeroEntry kse = kse++serverRejectedZeroX25519 :: TLSException -> Bool+serverRejectedZeroX25519 (HandshakeFailed (Error_Protocol msg alert)) =+ msg == "invalid client X25519MLKEM768 public key"+ && alert == IllegalParameter+serverRejectedZeroX25519 _ = False+ post_handshake_auth :: CSP13 -> IO () post_handshake_auth (CSP13 (clientParam, serverParam)) = do cred <- generate (arbitraryClientCredential TLS13)@@ -1455,6 +2042,258 @@ when (n > 4096) $ threadDelay 300000 backendRecv be n }++-- A protected record too short for the cipher cannot be deprotected, which+-- RFC 5246 Section 7.2.2 and RFC 8446 Section 5.2 answer with+-- bad_record_mac. The client's first application data record is cut down+-- to a single byte of ciphertext on its way to the server.+short_record_bad_record_mac :: Version -> Cipher -> IO ()+short_record_bad_record_mac version cipher = do+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([version], [version])+ ([cipher], [cipher])+ armed <- newIORef False+ let truncateRecord be =+ be+ { backendSend = \bs -> do+ cut <- readIORef armed+ if cut && B.length bs > 6 && B.head bs == 23+ then do+ writeIORef armed False+ backendSend be $ B.take 3 bs <> B.pack [0, 1] <> B.take 1 (B.drop 5 bs)+ else backendSend be bs+ }+ withPairContextWith (truncateRecord, id) (clientParam, serverParam) $+ \(cctx, sctx) ->+ concurrently_+ ( do+ handshake sctx+ recvData sctx `shouldThrow` serverRejectedShortRecord+ )+ ( do+ handshake cctx+ writeIORef armed True+ sendData cctx "hello"+ void (E.try (recvData cctx) :: IO (Either E.SomeException B.ByteString))+ )++serverRejectedShortRecord :: TLSException -> Bool+serverRejectedShortRecord (Terminated _ _ (Error_Protocol _ BadRecordMac)) = True+serverRejectedShortRecord _ = False++-- The first handshake message a server receives must be a ClientHello; any+-- other is out of order and answered with unexpected_message (RFC 8446+-- Section 4), whatever its body would decode to. The handshake type of the+-- client's first record is replaced on its way to the server.+server_first_message_unexpected :: Word8 -> IO ()+server_first_message_unexpected ty = do+ (clientParam, serverParam) <- generate arbitrary+ armed <- newIORef True+ let retype be =+ be+ { backendSend = \bs -> do+ first <- atomicModifyIORef' armed (\a -> (False, a))+ if first && B.length bs > 5 && B.head bs == 22+ then backendSend be $ B.take 5 bs <> B.singleton ty <> B.drop 6 bs+ else backendSend be bs+ }+ withPairContextWith (retype, id) (clientParam, serverParam) $ \(cctx, sctx) ->+ concurrently_+ (handshake sctx `shouldThrow` serverRejectedUnexpectedFirst)+ (handshake cctx `shouldThrow` anyTLSException)++-- ChangeCipherSpec comes between complete handshake messages (RFC 5246+-- Section 7.1), and a server has no handshake state before its first+-- ClientHello (CVE-2004-0079). The client's first record is split after+-- the given number of bytes of its body, and a ChangeCipherSpec record is+-- sent in between; with 0 it is sent before the whole ClientHello.+server_ccs_interleaved :: Int -> IO ()+server_ccs_interleaved n = do+ (clientParam, serverParam) <- generate arbitrary+ armed <- newIORef True+ let interleave be =+ be+ { backendSend = \bs -> do+ first <- atomicModifyIORef' armed (\a -> (False, a))+ if first && B.length bs > 5 + n && B.head bs == 22+ then do+ let (hdr, body) = B.splitAt 5 bs+ (body1, body2) = B.splitAt n body+ record b = B.take 3 hdr <> encodeWord16 (fromIntegral $ B.length b) <> b+ ccs = B.pack [20, 3, 3, 0, 1, 1]+ if n == 0+ then backendSend be $ ccs <> bs+ else backendSend be $ record body1 <> ccs <> record body2+ else backendSend be bs+ }+ withPairContextWith (interleave, id) (clientParam, serverParam) $ \(cctx, sctx) ->+ concurrently_+ (handshake sctx `shouldThrow` serverRejectedUnexpectedFirst)+ (handshake cctx `shouldThrow` anyTLSException)++-- An unknown record type is answered with unexpected_message (RFC 8446+-- Section 5). The type of the client's first record is replaced; with a+-- length larger than what follows, as an SSLv2 ClientHello reads when taken+-- for a TLS record header, the server must answer from the header alone+-- rather than wait for a body that never comes. A length of 0 keeps the+-- original one.+server_first_record_type_unexpected :: Word8 -> Word16 -> IO ()+server_first_record_type_unexpected ty len = do+ (clientParam, serverParam) <- generate arbitrary+ armed <- newIORef True+ let retype be =+ be+ { backendSend = \bs -> do+ first <- atomicModifyIORef' armed (\a -> (False, a))+ if first && B.length bs > 5 && B.head bs == 22+ then do+ let lenBytes+ | len == 0 = B.take 2 (B.drop 3 bs)+ | otherwise =+ B.pack [fromIntegral (len `div` 256), fromIntegral (len `mod` 256)]+ backendSend be $+ B.singleton ty <> B.take 2 (B.drop 1 bs) <> lenBytes <> B.drop 5 bs+ else backendSend be bs+ }+ r <- timeout 5000000 $+ withPairContextWith (retype, id) (clientParam, serverParam) $ \(cctx, sctx) ->+ concurrently_+ (handshake sctx `shouldThrow` serverRejectedUnexpectedFirst)+ (handshake cctx `shouldThrow` anyTLSException)+ r `shouldSatisfy` isJust++-- RFC 8446 Section 5.1: handshake messages MUST NOT be interleaved with+-- other record types. After the handshake the client sends, protected under+-- its application traffic secret, a record holding only the first two bytes+-- of a KeyUpdate and then a record of application data. The server must not+-- deliver the data and must answer with unexpected_message.+handshake13_interleaved_app_data :: IO ()+handshake13_interleaved_app_data = do+ let cipher = cipher13_AES_128_GCM_SHA256+ (clientParam, serverParam) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([TLS13], [TLS13])+ ([cipher], [cipher])+ secretRef <- newIORef Nothing+ sendRef <- newIORef (\_ -> return ())+ let logKey line = case words line of+ ["CLIENT_TRAFFIC_SECRET_0", _, h] -> writeIORef secretRef (Just h)+ _ -> return ()+ clientParam' =+ clientParam+ { clientDebug = (clientDebug clientParam){debugKeyLogger = logKey}+ }+ -- remember the raw sender so that records can be written by hand+ capture be =+ be+ { backendSend = \bs -> do+ writeIORef sendRef (backendSend be)+ backendSend be bs+ }+ withPairContextWith (capture, id) (clientParam', serverParam) $ \(cctx, sctx) ->+ concurrently_+ ( do+ handshake sctx+ r <- E.try (recvData sctx) :: IO (Either TLSException B.ByteString)+ case r of+ Right d -> expectationFailure $ "server delivered " ++ show d+ Left _ -> return ()+ )+ ( do+ handshake cctx+ Just h <- readIORef secretRef+ send <- readIORef sendRef+ let secret = BA.convert (unhex h) :: BA.ScrubbedBytes+ key = hkdfExpandLabel SHA256 secret "key" "" 16 :: B.ByteString+ iv = hkdfExpandLabel SHA256 secret "iv" "" 12 :: B.ByteString+ -- the first two bytes of KeyUpdate(update_not_requested)+ partialKeyUpdate = B.pack [24, 0]+ send $ protect13 key iv 0 22 partialKeyUpdate+ send $ protect13 key iv 1 23 "hello"+ recvData cctx `shouldThrow` peerSentUnexpected+ )+ where+ unhex [] = B.empty+ unhex (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhex rest)+ unhex _ = error "unhex"++-- A ChangeCipherSpec is the single byte 1; any other value is answered with+-- unexpected_message (RFC 8446 Section 5), and so is one carrying two of+-- them. The client's ChangeCipherSpec record is made two bytes long. The+-- groups are fixed so that a TLS 1.3 handshake goes through a+-- HelloRetryRequest -- after which the client sends its ChangeCipherSpec+-- before the second ClientHello -- or not, as the test asks.+malformed_ccs_unexpected :: Version -> Cipher -> [Group] -> [Group] -> IO ()+malformed_ccs_unexpected version cipher cgroups sgroups = do+ (clientParam0, serverParam0) <-+ generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([version], [version])+ ([cipher], [cipher])+ let clientParam =+ clientParam0+ { clientSupported = (clientSupported clientParam0){supportedGroups = cgroups}+ }+ serverParam =+ serverParam0+ { serverSupported =+ (serverSupported serverParam0)+ { supportedGroups = sgroups+ , supportedGroupsTLS13 = [sgroups]+ }+ }+ seen <- newIORef False+ let ccs = B.pack [20, 3, 3, 0, 1, 1]+ doubled = B.pack [20, 3, 3, 0, 2, 1, 1]+ double be =+ be+ { backendSend = \bs ->+ if ccs `B.isPrefixOf` bs+ then do+ writeIORef seen True+ backendSend be $ doubled <> B.drop 6 bs+ else backendSend be bs+ }+ -- a TLS 1.3 server takes the client's ChangeCipherSpec and Finished in+ -- its first recvData, a TLS 1.2 one in handshake+ r <- timeout 10000000 $+ withPairContextWith (double, id) (clientParam, serverParam) $ \(cctx, sctx) ->+ concurrently_+ ((handshake sctx >> recvData sctx) `shouldThrow` rejectedAsUnexpected)+ ( void+ (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString))+ )+ r `shouldSatisfy` isJust+ readIORef seen `shouldReturn` True++rejectedAsUnexpected :: TLSException -> Bool+rejectedAsUnexpected (HandshakeFailed (Error_Packet_unexpected _ _)) = True+rejectedAsUnexpected (Terminated _ _ (Error_Packet_unexpected _ _)) = True+rejectedAsUnexpected _ = False++-- An AES-128-GCM TLS 1.3 record: content and inner type, protected with the+-- record header as additional data and the sequence number in the nonce.+protect13 :: B.ByteString -> B.ByteString -> Word64 -> Word8 -> B.ByteString -> B.ByteString+protect13 key iv sqn innerType content = hdr <> ct <> BA.convert tag+ where+ len = B.length content + 1 + 16+ hdr = B.pack [23, 3, 3, fromIntegral (len `div` 256), fromIntegral (len `mod` 256)]+ sqnBytes = B.pack [fromIntegral (sqn `shiftR` (8 * i)) | i <- [7, 6 .. 0]]+ nonce = B.pack $ B.zipWith xor iv (B.replicate 4 0 <> sqnBytes)+ aes = throwCryptoError (cipherInit key) :: AES128+ aead = throwCryptoError (aeadInit AEAD_GCM aes nonce)+ (AuthTag tag, ct) = aeadSimpleEncrypt aead hdr (content <> B.singleton innerType) 16++peerSentUnexpected :: TLSException -> Bool+peerSentUnexpected (Terminated True _ (Error_Protocol _ UnexpectedMessage)) = True+peerSentUnexpected _ = False++serverRejectedUnexpectedFirst :: TLSException -> Bool+serverRejectedUnexpectedFirst (HandshakeFailed (Error_Packet_unexpected _ _)) = True+serverRejectedUnexpectedFirst _ = False expectJust :: String -> Maybe a -> Expectation expectJust tag mx = case mx of
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: tls-version: 2.4.8+version: 2.4.9 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>
util/Server.hs view
@@ -28,15 +28,18 @@ where body = "<html><<body>Hello world!</body></html>" +-- An HTTP request is answered with HTML, anything else is echoed.+-- tlsfuzzer's test-lengths.py sends "A..A\n", or just "\n", and expects+-- it back. server :: Context -> Bool -> IO () server ctx showRequest = do bs <- recvData ctx case C8.uncons bs of Nothing -> return ()- Just ('A', _) -> do+ Just ('G', _) -> handleHTML ctx showRequest bs+ Just _ -> do sendData ctx $ CL8.fromStrict bs echo ctx- Just _ -> handleHTML ctx showRequest bs echo :: Context -> IO () echo ctx = loop
util/tls-server.hs view
@@ -4,12 +4,16 @@ module Main where +import qualified Control.Exception as E import Data.IORef import qualified Data.Map.Strict as M import Data.X509.CertificateStore import Network.Run.TCP import Network.TLS import Network.TLS.ECH.Config+import Network.TLS.Extra.Cipher+import Network.TLS.Extra.CipherCBC+import Network.TLS.Extra.FFDHE import Network.TLS.Internal import System.Console.GetOpt import System.Environment (getArgs)@@ -27,12 +31,14 @@ , optShow :: Bool , optKeyLogFile :: Maybe FilePath , optTrustedAnchor :: Maybe FilePath- , optGroups :: [Group]+ , optGroups :: Maybe [Group] , optCertFile :: FilePath , optKeyFile :: FilePath , optECHConfigFile :: Maybe FilePath , optECHKeyFile :: Maybe FilePath , optTraceKey :: Bool+ , optUseWeakCiphers :: Bool+ , optServerName :: Maybe HostName } deriving (Show) @@ -44,13 +50,14 @@ , optShow = False , optKeyLogFile = Nothing , optTrustedAnchor = Nothing- , -- excluding FFDHE8192 for retry- optGroups = FFDHE8192 `delete` supportedGroups defaultSupported+ , optGroups = Nothing , optCertFile = "servercert.pem" , optKeyFile = "serverkey.pem" , optECHConfigFile = Nothing , optECHKeyFile = Nothing , optTraceKey = False+ , optUseWeakCiphers = False+ , optServerName = Nothing } options :: [OptDescr (Options -> Options)]@@ -78,7 +85,7 @@ , Option ['g'] ["groups"]- (ReqArg (\gs o -> o{optGroups = readGroups gs}) "<groups>")+ (ReqArg (\gs o -> o{optGroups = Just $ readGroups gs}) "<groups>") "groups for key exchange" , Option ['c']@@ -110,6 +117,16 @@ ["trace-key"] (NoArg (\o -> o{optTraceKey = True})) "Trace transcript hash"+ , Option+ []+ ["use-weak-ciphers"]+ (NoArg (\o -> o{optUseWeakCiphers = True}))+ "accept deprecated ciphers and relax checks (for tlsfuzzer)"+ , Option+ []+ ["server-name"]+ (ReqArg (\n o -> o{optServerName = Just n}) "<name>")+ "refuse other names in SNI with unrecognized_name" ] usage :: String@@ -135,7 +152,12 @@ (host, port) <- case ips of [h, p] -> return (h, p) _ -> showUsageAndExit "cannot recognize <addr> and <port>\n"- when (null optGroups) $ do+ let groups = fromMaybe defaultGroups optGroups+ defaultGroups+ | optUseWeakCiphers = supportedGroups defaultSupported+ -- excluding FFDHE8192 for retry+ | otherwise = FFDHE8192 `delete` supportedGroups defaultSupported+ when (null groups) $ do putStrLn "Error: unsupported groups" exitFailure smgr <- newSessionManager@@ -169,7 +191,8 @@ let sparams = getServerParams creds- optGroups+ optUseWeakCiphers+ groups smgr keyLog optClientAuth@@ -177,6 +200,7 @@ ech printError traceKey+ optServerName ctx <- contextNew sock sparams when optDebugLog $ contextHookSetLogging@@ -196,6 +220,7 @@ getServerParams :: Credentials+ -> Bool -> [Group] -> SessionManager -> (String -> IO ())@@ -204,8 +229,9 @@ -> ([(Word8, ByteString)], ECHConfigList) -> (String -> IO ()) -> (String -> IO ())+ -> Maybe HostName -> ServerParams-getServerParams creds groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey =+getServerParams creds weak groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey mname = defaultParamsServer { serverSupported = supported , serverShared = shared@@ -214,6 +240,7 @@ , serverEarlyDataSize = 2048 , serverWantClientCert = clientAuth , serverECHKey = ekey+ , serverDHEParams = if weak then Just ffdhe2048 else Nothing } where shared =@@ -231,15 +258,26 @@ } supported = defaultSupported- { supportedGroups = groups+ { supportedCiphers = ciphers+ , supportedGroups = groups+ , supportedExtendedMainSecret =+ if weak then AllowEMS else supportedExtendedMainSecret defaultSupported+ , supportedClientInitiatedRenegotiation =+ weak || supportedClientInitiatedRenegotiation defaultSupported }+ ciphers+ | weak = ciphersuite_default ++ ciphersForFuzzer+ | otherwise = ciphersuite_default hooks = defaultServerHooks- { onALPNClientSuggest = Just chooseALPN+ { onALPNClientSuggest = Just $ chooseALPN weak , onClientCertificate = case mstore of Nothing -> onClientCertificate defaultServerHooks- Just _ ->- validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared)+ Just _+ | weak -> acceptEmptyCertificate+ | otherwise ->+ validateClientCertificate (sharedCAStore shared) (sharedValidationCache shared)+ , onServerNameIndication = checkServerName mname } debug = defaultDebugParams@@ -247,12 +285,122 @@ , debugError = printError , debugTraceKey = traceKey }+ acceptEmptyCertificate cc+ | isNullCertificateChain cc = return CertificateUsageAccept+ | otherwise =+ validateClientCertificate+ (sharedCAStore shared)+ (sharedValidationCache shared)+ cc -chooseALPN :: [ByteString] -> IO ByteString-chooseALPN protos- | "http/1.1" `elem` protos = return "http/1.1"- | otherwise = return ""+----------------------------------------------------------------+-- Deprecated ciphers, accepted only with --use-weak-ciphers.+-- tlsfuzzer uses them in its TLS 1.2 tests. +ciphersForFuzzer :: [Cipher]+ciphersForFuzzer =+ [ cipher_ECDHE_RSA_WITH_AES_128_CBC_SHA+ , cipher_DHE_RSA_WITH_AES_128_CBC_SHA+ , cipher_RSA_WITH_AES_256_CBC_SHA+ , cipher_RSA_WITH_AES_128_CBC_SHA+ , cipher_RSA_WITH_AES_128_CBC_SHA256+ , cipher_DHE_RSA_WITH_AES_128_GCM_SHA256+ , cipher_RSA_WITH_AES_128_GCM_SHA256+ , cipher_RSA_WITH_AES_256_GCM_SHA384+ , cipher_DHE_RSA_WITH_CHACHA20_POLY1305_SHA256+ , cipher13_AES_128_CCM_8_SHA256+ ]+ ++ ciphersuite_pfs_sha2_cbc++-- CBC with HMAC-SHA1, derived from the SHA-2 ones in CipherCBC.+cipher_RSA_WITH_AES_128_CBC_SHA :: Cipher+cipher_RSA_WITH_AES_128_CBC_SHA =+ cipher_DHE_RSA_AES128_SHA256+ { cipherID = 0x002F+ , cipherName = "TLS_RSA_WITH_AES_128_CBC_SHA"+ , cipherHash = SHA1+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_RSA+ , cipherMinVer = Just SSL3+ }++cipher_RSA_WITH_AES_256_CBC_SHA :: Cipher+cipher_RSA_WITH_AES_256_CBC_SHA =+ cipher_DHE_RSA_AES256_SHA256+ { cipherID = 0x0035+ , cipherName = "TLS_RSA_WITH_AES_256_CBC_SHA"+ , cipherHash = SHA1+ , cipherPRFHash = Nothing+ , cipherKeyExchange = CipherKeyExchange_RSA+ , cipherMinVer = Just SSL3+ }++-- tlsfuzzer's test-atypical-padding.py and test-lengths.py use this one+-- for an HMAC-SHA256 record.+cipher_RSA_WITH_AES_128_CBC_SHA256 :: Cipher+cipher_RSA_WITH_AES_128_CBC_SHA256 =+ cipher_DHE_RSA_AES128_SHA256+ { cipherID = 0x003C+ , cipherName = "TLS_RSA_WITH_AES_128_CBC_SHA256"+ , cipherKeyExchange = CipherKeyExchange_RSA+ }++cipher_DHE_RSA_WITH_AES_128_CBC_SHA :: Cipher+cipher_DHE_RSA_WITH_AES_128_CBC_SHA =+ cipher_RSA_WITH_AES_128_CBC_SHA+ { cipherID = 0x0033+ , cipherName = "TLS_DHE_RSA_WITH_AES_128_CBC_SHA"+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Nothing+ }++cipher_ECDHE_RSA_WITH_AES_128_CBC_SHA :: Cipher+cipher_ECDHE_RSA_WITH_AES_128_CBC_SHA =+ cipher_RSA_WITH_AES_128_CBC_SHA+ { cipherID = 0xC013+ , cipherName = "TLS_ECDHE_RSA_WITH_AES_128_CBC_SHA"+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS10+ }++-- AES-GCM with RSA key exchange, derived from the DHE ones.+cipher_RSA_WITH_AES_128_GCM_SHA256 :: Cipher+cipher_RSA_WITH_AES_128_GCM_SHA256 =+ cipher_DHE_RSA_WITH_AES_128_GCM_SHA256+ { cipherID = 0x009C+ , cipherName = "TLS_RSA_WITH_AES_128_GCM_SHA256"+ , cipherKeyExchange = CipherKeyExchange_RSA+ }++cipher_RSA_WITH_AES_256_GCM_SHA384 :: Cipher+cipher_RSA_WITH_AES_256_GCM_SHA384 =+ cipher_DHE_RSA_WITH_AES_256_GCM_SHA384+ { cipherID = 0x009D+ , cipherName = "TLS_RSA_WITH_AES_256_GCM_SHA384"+ , cipherKeyExchange = CipherKeyExchange_RSA+ }++-- Only HTTP/1.1 is spoken. With --use-weak-ciphers, the names+-- tlsfuzzer's test-alpn-negotiation.py switches to on renegotiation and+-- resumption are accepted too, in the client's order.+chooseALPN :: Bool -> [ByteString] -> IO ByteString+chooseALPN weak protos = return $ fromMaybe "" $ find (`elem` known) protos+ where+ known+ | weak = ["http/1.1", "h2", "http/2"]+ | otherwise = ["http/1.1"]++-- RFC 6066 Section 3: a server that does not recognize the name may+-- abort with a fatal unrecognized_name, a warning one being NOT+-- RECOMMENDED.+checkServerName :: Maybe HostName -> Maybe HostName -> IO Credentials+checkServerName (Just name) (Just sni)+ | sni /= name =+ E.throwIO $+ Uncontextualized $+ Error_Protocol ("unrecognized name: " ++ sni) UnrecognizedName+checkServerName _ _ = return mempty+ newSessionManager :: IO SessionManager newSessionManager = do ref <- newIORef M.empty@@ -262,9 +410,11 @@ M.lookup key <$> readIORef ref , sessionResumeOnlyOnce = \key -> do M.lookup key <$> readIORef ref- , sessionEstablish = \key val -> do- atomicModifyIORef' ref $ \m -> (M.insert key val m, Nothing)+ , -- The session ID doubles as the ticket, so the table+ -- serves resumption by either.+ sessionEstablish = \key val -> do+ atomicModifyIORef' ref $ \m -> (M.insert key val m, Just key) , sessionInvalidate = \key -> do atomicModifyIORef' ref $ \m -> (M.delete key m, ())- , sessionUseTicket = False+ , sessionUseTicket = True }