diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,20 @@ # Change log for "tls" +## Version 2.4.12 + +* Authenticate a server that rejects the PSK of 0-RTT. + [#590](https://github.com/haskell-tls/hs-tls/pull/590) +* Require the client Certificate a TLS 1.2 server asked for. + [#591](https://github.com/haskell-tls/hs-tls/pull/591) +* Refuse a TLS 1.3 alert in clear after the handshake. + [#592](https://github.com/haskell-tls/hs-tls/pull/592) +* Require Certificate and ServerKeyExchange from a TLS 1.2 server. + [#593](https://github.com/haskell-tls/hs-tls/pull/593) +* Refuse a TLS 1.2 ChangeCipherSpec before its keys exist. + [#594](https://github.com/haskell-tls/hs-tls/pull/594) +* Answer an unfit ServerKeyExchange algorithm with an alert. + [#595](https://github.com/haskell-tls/hs-tls/pull/595) + ## Version 2.4.11 * Keep preferring AES-GCM on AArch64 with crypton 2.2, which names the diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -422,10 +422,16 @@ else do let reason = "received key update before established" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - -- Client only - loopHandshake13 (hb@(CertRequest13{}, _) : hbs) = - postHandshakeAuthWith ctx hb >> loopHandshake13 hbs - loopHandshake13 (hb@(h, _) : hbs) = do + -- Client only. Before Established, it belongs to the handshake that + -- 0-RTT left to the pending actions. + loopHandshake13 (hb@(CertRequest13{}, _) : hbs) = do + established <- ctxEstablished ctx + if established == Established + then postHandshakeAuthWith ctx hb >> loopHandshake13 hbs + else loopPending hb hbs + loopHandshake13 (hb : hbs) = loopPending hb hbs + + loopPending hb@(h, _) hbs = do rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ case h of ServerHello13 SH{..} -> diff --git a/Network/TLS/Handshake/Client/TLS12.hs b/Network/TLS/Handshake/Client/TLS12.hs --- a/Network/TLS/Handshake/Client/TLS12.hs +++ b/Network/TLS/Handshake/Client/TLS12.hs @@ -49,13 +49,20 @@ doCertificate cparams ctx certs processCertificate ctx ClientRole certs return $ RecvStateHandshake (expectServerKeyExchange ctx) -expectCertificate _ ctx p = expectServerKeyExchange ctx p +-- Every key exchange the client implements authenticates the server with a +-- certificate; see sendClientKeyXchg. +expectCertificate _ _ p = unexpected (show p) (Just "server certificate") expectServerKeyExchange :: Context -> Handshake -> IO (RecvState IO) expectServerKeyExchange ctx (ServerKeyXchg origSkx) = do doServerKeyExchange ctx origSkx return $ RecvStateHandshake (expectCertificateRequest ctx) -expectServerKeyExchange ctx p = expectCertificateRequest ctx p +expectServerKeyExchange ctx p = do + -- (EC)DHE takes its parameters from ServerKeyExchange. + kx <- cipherKeyExchange <$> usingHState ctx getPendingCipher + unless (kx == CipherKeyExchange_RSA) $ + unexpected (show p) (Just "server key exchange") + expectCertificateRequest ctx p expectCertificateRequest :: Context -> Handshake -> IO (RecvState IO) expectCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs --- a/Network/TLS/Handshake/Client/TLS13.hs +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -147,12 +147,16 @@ when (st13 == RTT0Sent) $ case extensionLookup EID_EarlyData eexts of Just _ -> do + -- RFC 8446 Section 4.2.10: early data is accepted only + -- with the first PSK. + mode <- usingHState ctx getTLS13HandshakeMode + unless (mode == PreSharedKey) $ + throwCore $ + Error_Protocol "early data accepted without PSK" IllegalParameter usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Accepted liftIO $ modifyTLS13State ctx $ \st -> st{tls13st0RTTAccepted = True} - Nothing -> do - usingHState ctx $ setTLS13HandshakeMode PreSharedKey - usingHState ctx $ setTLS13RTT0Status RTT0Rejected + Nothing -> usingHState ctx $ setTLS13RTT0Status RTT0Rejected expectEncryptedExtensions _ h = unexpected (show h) (Just "encrypted extensions") ---------------------------------------------------------------- @@ -228,13 +232,19 @@ :: MonadIO m => ClientParams -> Context -> CertificateChain -> RecvHandshake13M m () processCertAndVerify cparams ctx cc = do + pubkey <- processServerCertificate cparams ctx cc + recvHandshake13hash ctx "CertVerify" $ expectCertVerify ctx pubkey + +processServerCertificate + :: MonadIO m => ClientParams -> Context -> CertificateChain -> m PubKey +processServerCertificate cparams ctx cc = do liftIO $ usingState_ ctx $ setServerCertificateChain cc liftIO $ doCertificate cparams ctx cc let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc ver <- liftIO $ usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey - recvHandshake13hash ctx "CertVerify" $ expectCertVerify ctx pubkey + return pubkey ---------------------------------------------------------------- @@ -416,16 +426,42 @@ asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx - [ PendingRecvActionSelfUpdate True expectServerHello - , PendingRecvAction True (expectEncryptedExtensions ctx) - , PendingRecvActionHash True expectFinishedAndSet - ] + [PendingRecvActionSelfUpdate True expectServerHello] where expectServerHello shb@(sh, _) = do setRTT ctx chSentTime processServerHello13 cparams ctx sh updateTranscriptHash13 ctx shb -- update by myself - void $ prepareSecondFlight13 ctx groupSent + resuming <- prepareSecondFlight13 ctx groupSent + -- Without the PSK, the server authenticates with its certificate, + -- as in recvServerSecondFlight13. + setPendingRecvActions ctx $ + if resuming + then + [ PendingRecvAction True (expectEncryptedExtensions ctx) + , PendingRecvActionHash True expectFinishedAndSet + ] + else + [ PendingRecvAction False (expectEncryptedExtensions ctx) + , PendingRecvAction False expectCertRequestAsync + , PendingRecvActionHash True expectFinishedAndSet + ] + -- The actions below put the next one in front of Finished. + expectCertRequestAsync (CertRequest13 token exts) = do + processCertRequest13 ctx token exts + pushPendingRecvAction ctx $ PendingRecvAction False expectCertAsync + expectCertRequestAsync h = do + usingHState ctx $ do + setCertReqToken Nothing + setCertReqCBdata Nothing + expectCertAsync h + expectCertAsync (Certificate13 _ (CertificateChain_ cc) _) = certAsync cc + expectCertAsync (CompressedCertificate13 _ (CertificateChain_ cc) _) = certAsync cc + expectCertAsync h = unexpected (show h) (Just "server certificate") + certAsync cc = do + pubkey <- processServerCertificate cparams ctx cc + pushPendingRecvAction ctx $ + PendingRecvActionHash False (expectCertVerify ctx pubkey) expectFinishedAndSet h sf = do expectFinished cparams ctx h sf liftIO $ diff --git a/Network/TLS/Handshake/Server/ServerHello13.hs b/Network/TLS/Handshake/Server/ServerHello13.hs --- a/Network/TLS/Handshake/Server/ServerHello13.hs +++ b/Network/TLS/Handshake/Server/ServerHello13.hs @@ -94,7 +94,7 @@ usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Accepted else do - usingHState ctx $ setTLS13HandshakeMode PreSharedKey + when authenticated $ usingHState ctx $ setTLS13HandshakeMode PreSharedKey usingHState ctx $ setTLS13RTT0Status RTT0Rejected else when authenticated $ usingHState ctx $ setTLS13HandshakeMode PreSharedKey -- else : FullHandshake or HelloRetryRequest diff --git a/Network/TLS/Handshake/Server/TLS12.hs b/Network/TLS/Handshake/Server/TLS12.hs --- a/Network/TLS/Handshake/Server/TLS12.hs +++ b/Network/TLS/Handshake/Server/TLS12.hs @@ -104,7 +104,12 @@ -- which the hook may have accepted. let followedCertVerify = not $ isNullCertificateChain certs return $ RecvStateHandshake $ expectClientKeyExchange followedCertVerify - expectClientCertificate p = expectClientKeyExchange False p + -- RFC 5246 Section 7.4.6: a client asked for a certificate sends the + -- message, empty if it has none. + expectClientCertificate p = do + certReqSent <- usingHState ctx getCertReqSent + when certReqSent $ unexpected (show p) (Just "client certificate") + expectClientKeyExchange False p -- cannot use RecvStateHandshake, as the next message could be a ChangeCipher, -- so we must process any packet, and in case of handshake call processHandshake manually. diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -106,6 +106,17 @@ keyTypeFits (PubKeyEd448 _) (_, s) = s == SignatureEd448 keyTypeFits _ _ = False +checkKeyTypeFits :: PubKey -> HashAndSignatureAlgorithm -> IO () +checkKeyTypeFits pubKey hs = + unless (pubKey `keyTypeFits` hs) $ + throwCore $ + Error_Protocol + ( "signature algorithm " + ++ showSignatureScheme hs + ++ " is for another type of key" + ) + IllegalParameter + -- 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 @@ -178,11 +189,7 @@ ("signature algorithm " ++ showSignatureScheme hashSigAlg ++ " is not for " ++ show usedVersion) IllegalParameter checkSupportedHashSignature ctx hashSigAlg - unless (pubKey `keyTypeFits` hashSigAlg) $ - throwCore $ - Error_Protocol - ("signature algorithm " ++ showSignatureScheme hashSigAlg ++ " is for another type of key") - IllegalParameter + checkKeyTypeFits pubKey hashSigAlg if pubKey `signatureCompatible` hashSigAlg then doVerify else return False @@ -278,19 +285,24 @@ DigitallySigned malg <$> signPrivate ctx role sigParam toSign signatureVerify :: Context -> DigitallySigned -> PubKey -> ByteString -> IO Bool +-- Checked as checkCertificateVerify does: the peer chose the algorithm, so +-- one that does not fit the key is its error, not ours. signatureVerify ctx digSig@(DigitallySigned hashSigAlg _) pubKey toVerifyData = do usedVersion <- usingState_ ctx getVersion - let (sigParam, toVerify) = - case (usedVersion, hashSigAlg) of - (TLS12, hs) - | pubKey `signatureCompatible` hs -> - (signatureParams pubKey hashSigAlg, toVerifyData) - | otherwise -> - error "expecting different signature algorithm" - _ -> - error - "not expecting hash and signature algorithm in a < TLS12 digitially signed structure" - signatureVerifyWithCertVerifyData ctx digSig (sigParam, toVerify) + unless (usedVersion == TLS12) $ + throwCore $ + Error_Protocol + ("no signature algorithm in a " ++ show usedVersion ++ " digitally-signed") + InternalError + checkSupportedHashSignature ctx hashSigAlg + checkKeyTypeFits pubKey hashSigAlg + if pubKey `signatureCompatible` hashSigAlg + then + signatureVerifyWithCertVerifyData + ctx + digSig + (signatureParams pubKey hashSigAlg, toVerifyData) + else return False signatureVerifyWithCertVerifyData :: Context diff --git a/Network/TLS/Handshake/State13.hs b/Network/TLS/Handshake/State13.hs --- a/Network/TLS/Handshake/State13.hs +++ b/Network/TLS/Handshake/State13.hs @@ -17,6 +17,7 @@ clearRxRecordState, PendingRecvAction (..), setPendingRecvActions, + pushPendingRecvAction, popPendingRecvAction, ) where @@ -140,6 +141,9 @@ setPendingRecvActions :: Context -> [PendingRecvAction] -> IO () setPendingRecvActions ctx = writeIORef (ctxPendingRecvActions ctx) + +pushPendingRecvAction :: Context -> PendingRecvAction -> IO () +pushPendingRecvAction ctx a = modifyIORef' (ctxPendingRecvActions ctx) (a :) popPendingRecvAction :: Context -> IO (Maybe PendingRecvAction) popPendingRecvAction ctx = do diff --git a/Network/TLS/IO/Decode.hs b/Network/TLS/IO/Decode.hs --- a/Network/TLS/IO/Decode.hs +++ b/Network/TLS/IO/Decode.hs @@ -35,17 +35,18 @@ -- 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). + -- middle of a fragmented handshake message (CVE-2004-0079), + -- nor before the keys it switches to are computed. mhs <- getHState ctx (mCont, _) <- usingState_ ctx $ gets stHandshakeRecordCont12 - if isNothing mhs || isJust mCont - then + case mhs >>= hstPendingRxState of + Just rx | isNothing mCont -> do + modifyMVar_ (ctxRxRecordState ctx) (\_ -> return rx) + return $ Right ChangeCipherSpec + _ -> return $ Left $ Error_Packet_unexpected "ChangeCipherSpec" " expected: handshake" - else do - switchRxEncryption ctx - return $ Right ChangeCipherSpec decodePacket12 ctx (Record ProtocolType_Handshake ver fragment) = do mhs <- getHState ctx let keyxchg = mhs >>= hstPendingCipher >>= Just . cipherKeyExchange @@ -92,11 +93,6 @@ bs' = BS.take len bs return ((h, reverse (bs' : wirebytes)) : hbs) decodePacket12 _ (Record ty _ _) = return $ Left $ unknownProtocolType ty - -switchRxEncryption :: Context -> IO () -switchRxEncryption ctx = - usingHState ctx (gets hstPendingRxState) >>= \rx -> - modifyMVar_ (ctxRxRecordState ctx) (\_ -> return $ fromJust rx) ---------------------------------------------------------------- diff --git a/Network/TLS/Record/Decrypt.hs b/Network/TLS/Record/Decrypt.hs --- a/Network/TLS/Record/Decrypt.hs +++ b/Network/TLS/Record/Decrypt.hs @@ -42,7 +42,13 @@ Left message -> throwError $ Error_Protocol message UnexpectedMessage Right (ct', d) -> return $ Record ct' ver $ fragmentPlaintext d ProtocolType_ChangeCipherSpec -> noDecryption - ProtocolType_Alert -> noDecryption + -- A peer that fails before it has keys answers in clear, but after + -- the handshake an alert in clear can only be forged (RFC 8446 + -- Section 5). + ProtocolType_Alert + | stCryptLevel st == CryptApplicationSecret -> + throwError $ Error_Protocol "alert in clear" UnexpectedMessage + | otherwise -> noDecryption _ -> throwError $ Error_Protocol "illegal plain text" UnexpectedMessage diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -120,11 +120,25 @@ handshake12_client_cert_verify_sigalg (HashIntrinsic, SignatureRSApsspssSHA256) rejectedAsDecryptError + it "rejects a TLS 1.2 ServerKeyExchange algorithm for another key type" $ + handshake12_server_key_xchg_sigalg + (HashSHA256, SignatureECDSA) + rejectedAsIllegalParameter + it "rejects a TLS 1.2 ServerKeyExchange that does not fit the RSA key" $ + handshake12_server_key_xchg_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 "rejects a TLS 1.2 client omitting the requested certificate" $ + handshake12_client_cert_omitted + it "rejects a TLS 1.2 server omitting Certificate" $ + handshake12_server_message_omitted 11 + it "rejects a TLS 1.2 server omitting ServerKeyExchange for ECDHE" $ + handshake12_server_message_omitted 12 it "requests only defined certificate types in TLS 1.2" $ handshake12_cert_request_types prop "can handle extended main secret" handshake_ems @@ -173,6 +187,10 @@ it "rejects TLS 1.3 early data when ALPN changes" $ handshake13_0rtt_alpn prop "can handshake with TLS 1.3 0RTT -> PSK" handshake13_0rtt_fallback + it "authenticates a server rejecting the PSK of 0RTT" $ + handshake13_0rtt_psk_rejected False + it "authenticates a server rejecting the PSK of 0RTT, asking a cert" $ + handshake13_0rtt_psk_rejected True 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 @@ -210,6 +228,10 @@ 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 TLS 1.3 alert in clear after the handshake" $ + plaintext_alert13_rejected + it "rejects a TLS 1.2 ChangeCipherSpec before the keys" $ + early_ccs12_rejected it "rejects a ServerHello as the first client message" $ server_first_message_unexpected 2 it "rejects a Finished as the first client message" $ @@ -884,6 +906,90 @@ | isNullCertificateChain chain = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) +-- RFC 5246 Section 7.4.6: a client asked for a certificate sends the +-- message even when it has none. Here it is cut out on the wire; the +-- Finished no longer matches, but the server must stop before that. +handshake12_client_cert_omitted :: IO () +handshake12_client_cert_omitted = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return Nothing + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + ccsSent <- newIORef False + let params = (clientParam', serverParam') + withPairContextWith (dropHandshake12 11 ccsSent, id) params $ + \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` rejectedAsUnexpected) + (void (E.try (handshake cctx) :: IO (Either E.SomeException ()))) + +-- A TLS 1.2 client needs the server's Certificate for every key exchange +-- it implements, and ServerKeyExchange for (EC)DHE. One of them is cut +-- out on the wire, and the client must say so rather than fail later. +handshake12_server_message_omitted :: Word8 -> IO () +handshake12_server_message_omitted typ = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + ccsSent <- newIORef False + withPairContextWith (id, dropHandshake12 typ ccsSent) (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + (void (E.try (handshake sctx) :: IO (Either E.SomeException ()))) + (handshake cctx `shouldThrow` rejectedAsUnexpected) + +-- | Cut the handshake messages of a type out of what a TLS 1.2 peer sends +-- in clear, that is, before its ChangeCipherSpec. +dropHandshake12 :: Word8 -> IORef Bool -> Backend -> Backend +dropHandshake12 typ ccsSent be = + be + { backendSend = \bs -> do + done <- readIORef ccsSent + when (B.take 1 bs == B.singleton 20) $ writeIORef ccsSent True + backendSend be $ if done then bs else stripRecords bs + } + where + stripRecords bs + | B.length bs < 5 = bs + | otherwise = + let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4) + (body, rest) = B.splitAt len $ B.drop 5 bs + body' + | B.head bs == 22 = stripMessages body + | otherwise = body + len' = B.length body' + hdr = B.take 3 bs <> B.pack [fromIntegral (len' `div` 256), fromIntegral len'] + in (if B.null body' then "" else hdr <> body') <> stripRecords rest + stripMessages m + | B.length m < 4 = m + | otherwise = + let len = + fromIntegral (B.index m 1) * 65536 + + fromIntegral (B.index m 2) * 256 + + fromIntegral (B.index m 3) + (msg, rest) = B.splitAt (4 + len) m + in (if B.head m == typ then "" else msg) <> stripMessages rest + -- 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, @@ -980,6 +1086,37 @@ (void (E.try (handshake cctx) :: IO (Either TLSException ()))) r `shouldSatisfy` isJust +-- The same for the signature of ServerKeyExchange, which the client used to +-- answer with an ErrorCall and internal_error. +handshake12_server_key_xchg_sigalg + :: HashAndSignatureAlgorithm -> Selector TLSException -> IO () +handshake12_server_key_xchg_sigalg alg rejected = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + let (HashAlgorithm h, SignatureAlgorithm sa) = alg + unfit (ServerKeyXchg (SKX_ECDHE_RSA params (DigitallySigned _ sig))) = + pure $ ServerKeyXchg (SKX_ECDHE_RSA params (DigitallySigned alg sig)) + -- Arriving with ServerHello, it is decoded before the cipher is + -- known: curve type and group, the point, then the algorithm. + unfit (ServerKeyXchg (SKX_Unparsed bs)) = + let off = 4 + fromIntegral (B.index bs 3) + in pure $ + ServerKeyXchg $ + SKX_Unparsed $ + B.take off bs <> B.pack [h, sa] <> B.drop (off + 2) bs + unfit hs = pure hs + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam, serverParam) $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv cctx unfit + concurrently_ + (void (E.try (handshake sctx) :: IO (Either TLSException ()))) + (handshake cctx `shouldThrow` rejected) + r `shouldSatisfy` isJust + -- A DER ECDSA signature that does not decode is a signature that does not -- verify, a decrypt_error. The client's TLS 1.3 CertificateVerify -- signature is replaced on its way to the server with one that the ASN.1 @@ -2156,6 +2293,40 @@ _ <- recvData ctx bye ctx +-- The server has forgotten the session, so it answers 0-RTT with a full +-- handshake, and the client must check its certificate. +handshake13_0rtt_psk_rejected :: Bool -> IO () +handshake13_0rtt_psk_rejected wantCert = do + (cli, srv) <- generate arbitraryPairParams13 + let supported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params0 = + ( cli{clientSupported = supported} + , srv{serverSupported = supported, serverEarlyDataSize = 2048} + ) + sessionRefs <- twoSessionRefs + let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0 + runTLSSimple13 params FullHandshake + + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + writeIORef (snd sessionRefs) Nothing + earlyData <- B.pack <$> generate (someWords8 256) + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + ps' = + ps + { serverWantClientCert = wantCert + , serverHooks = + (serverHooks ps) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + runTLS0RTT (pc{clientUseEarlyData = True}, ps') FullHandshake earlyData + handshake13_ee_groups :: CSP13 -> IO () handshake13_ee_groups (CSP13 (cli, srv)) = do let -- The client prefers P256 @@ -2381,6 +2552,71 @@ sendData cctx "hello" void (E.try (recvData cctx) :: IO (Either E.SomeException B.ByteString)) ) + +-- RFC 8446 Section 5: once keys are in use, only ChangeCipherSpec may come +-- in clear. An injected close_notify must not read as an orderly close. +plaintext_alert13_rejected :: IO () +plaintext_alert13_rejected = do + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher13_AES_128_GCM_SHA256], [cipher13_AES_128_GCM_SHA256]) + armed <- newIORef False + let injectAlert be = + be + { backendSend = \bs -> do + inject <- readIORef armed + if inject && B.take 1 bs == B.singleton 23 + then do + writeIORef armed False + backendSend be $ B.pack [21, 3, 3, 0, 2, 1, 0] + else backendSend be bs + } + withPairContextWith (injectAlert, id) (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + ( do + handshake sctx + recvData sctx `shouldThrow` rejectedPlaintextAlert + ) + ( do + handshake cctx + writeIORef armed True + sendData cctx "hello" + void (E.try (recvData cctx) :: IO (Either E.SomeException B.ByteString)) + ) + +rejectedPlaintextAlert :: TLSException -> Bool +rejectedPlaintextAlert (Terminated _ _ (Error_Protocol _ UnexpectedMessage)) = True +rejectedPlaintextAlert _ = False + +-- A ChangeCipherSpec ahead of the client's second flight, before the server +-- has the keys to switch to. The handshake would refuse it anyway; this +-- keeps the record layer from switching to keys that do not exist. +early_ccs12_rejected :: IO () +early_ccs12_rejected = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + sent <- newIORef (0 :: Int) + let injectCCS be = + be + { backendSend = \bs -> do + n <- readIORef sent + writeIORef sent (n + 1) + -- The first send is ClientHello. + when (n == 1) $ backendSend be $ B.pack [20, 3, 3, 0, 1, 1] + backendSend be bs + } + withPairContextWith (injectCCS, id) (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` rejectedAsUnexpected) + (void (E.try (handshake cctx) :: IO (Either E.SomeException ()))) serverRejectedShortRecord :: TLSException -> Bool serverRejectedShortRecord (Terminated _ _ (Error_Protocol _ BadRecordMac)) = True diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: tls -version: 2.4.11 +version: 2.4.12 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez