diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,42 @@ # Change log for "tls" +## Version 2.4.14 + +* Require hpke 0.4. +* Bind the PSK to the transcript after HelloRetryRequest. + This breaks a PSK after HRR with hs-tls 2.4.13 or earlier. + [#597](https://github.com/haskell-tls/hs-tls/pull/597) +* Let application data and HelloRequest come during a TLS 1.2 handshake. + [#601](https://github.com/haskell-tls/hs-tls/pull/601) +* Tell why a certificate is rejected, and give the chain to `debugError` in PEM. + [#606](https://github.com/haskell-tls/hs-tls/pull/606) +* Give each PSK identity its own binder, and accept HelloRetryRequest with only a cookie. + [#612](https://github.com/haskell-tls/hs-tls/pull/612) +* Check the versions and extensions of the hello messages as RFC 9846 does. + [#614](https://github.com/haskell-tls/hs-tls/pull/614) +* Answer a certificate that is not DER with bad_certificate instead of decode_error. + [#617](https://github.com/haskell-tls/hs-tls/pull/617) +* Answer an empty certificate with decode_error. + [#618](https://github.com/haskell-tls/hs-tls/pull/618) +* Check the second ClientHello after HelloRetryRequest. + [#619](https://github.com/haskell-tls/hs-tls/pull/619) +* Answer an empty cipher_suites or compression_methods with decode_error. + [#620](https://github.com/haskell-tls/hs-tls/pull/620) +* Refuse data after the content of an extension. + [#621](https://github.com/haskell-tls/hs-tls/pull/621) +* Answer a protected change_cipher_spec with unexpected_message. + [#622](https://github.com/haskell-tls/hs-tls/pull/622) +* Answer an unexpected post-handshake message with unexpected_message instead of dropping it. + [#623](https://github.com/haskell-tls/hs-tls/pull/623) +* Ignore the alert level in TLS 1.3: a warning-level error alert is an error, and a fatal-level close_notify is a closure. + [#624](https://github.com/haskell-tls/hs-tls/pull/624) +* Answer several KeyUpdates with update_requested with a single KeyUpdate. + [#631](https://github.com/haskell-tls/hs-tls/pull/631) +* Add `closeNotifyReceived` to tell close_notify from an EOF without it. + [#635](https://github.com/haskell-tls/hs-tls/pull/635) +* Resume a session only with its SNI on the client. + [#636](https://github.com/haskell-tls/hs-tls/pull/636) + ## Version 2.4.13 * Keep the CBC MAC check from timing the padding (Lucky Thirteen). diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -26,6 +26,7 @@ handshake, sendData, recvData, + closeNotifyReceived, bye, -- * Exceptions diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -11,11 +11,13 @@ PendingRecv (..), RecordLayer (..), ctxEOF, + ctxCloseNotify, ctxEstablished, withLog, ctxWithHooks, contextModifyHooks, setEOF, + setCloseNotify, setEstablished, contextFlush, contextClose, @@ -168,6 +170,7 @@ tlsstate <- newMVar st eof <- newIORef False + closeNotify <- newIORef False established <- newIORef NotEstablished stats <- newIORef newMeasurement needEmptyPacket <- newIORef False @@ -176,6 +179,7 @@ rx <- newMVar newRecordState hs <- newMVar Nothing recvActionsRef <- newIORef [] + appDataRef <- newIORef [] sendActionRef <- newIORef Nothing locks <- Locks <$> newMVar () <*> newMVar () <*> newMVar () st13ref <- newIORef defaultTLS13State @@ -205,11 +209,13 @@ , ctxRoleParams = roleParams , ctxMeasurement = stats , ctxEOF_ = eof + , ctxCloseNotify_ = closeNotify , ctxEstablished_ = established , ctxNeedEmptyPacket = needEmptyPacket , ctxHooks = hooks , ctxLocks = locks , ctxPendingRecvActions = recvActionsRef + , ctxPendingAppData = appDataRef , ctxPendingSendAction = sendActionRef , ctxRecordLayer = recordLayer , ctxHandshakeSync = HandshakeSync syncNoOp syncNoOp diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -23,11 +23,13 @@ Locks (..), RoleParams (..), ctxEOF, + ctxCloseNotify, ctxEstablished, withLog, ctxWithHooks, contextModifyHooks, setEOF, + setCloseNotify, setEstablished, skipEarlyData, contextFlush, @@ -131,6 +133,8 @@ , ctxMeasurement :: IORef Measurement , ctxEOF_ :: IORef Bool -- ^ has the handle EOFed or not. + , ctxCloseNotify_ :: IORef Bool + -- ^ has close_notify been received or not. , ctxEstablished_ :: IORef Established -- ^ has the handshake been done and been successful. , ctxTxRecordState :: MVar RecordState @@ -146,6 +150,8 @@ , -- TLS 1.3 ctxTLS13State :: IORef TLS13State , ctxPendingRecvActions :: IORef [PendingRecvAction] + , ctxPendingAppData :: IORef [ByteString] + -- ^ TLS 1.2 application data received during renegotiation, newest first , ctxPendingSendAction :: IORef (Maybe (Context -> IO ())) -- ^ pending post handshake authentication requests , -- QUIC @@ -205,6 +211,8 @@ data TLS13State = TLS13State { tls13stRecvNST :: Bool -- client , tls13stKeyUpdateCount :: Int + , tls13stSentKeyUpdates :: Word64 + , tls13stKeyUpdateResponded :: Bool , tls13stSentClientCert :: Bool -- client , tls13stRecvSF :: Bool -- client , tls13stSentCF :: Bool -- client @@ -227,6 +235,8 @@ TLS13State { tls13stRecvNST = False , tls13stKeyUpdateCount = 0 + , tls13stSentKeyUpdates = 0 + , tls13stKeyUpdateResponded = False , tls13stSentClientCert = False , tls13stRecvSF = False , tls13stSentCF = False @@ -376,6 +386,12 @@ setEOF :: Context -> IO () setEOF ctx = writeIORef (ctxEOF_ ctx) True + +ctxCloseNotify :: Context -> IO Bool +ctxCloseNotify ctx = readIORef $ ctxCloseNotify_ ctx + +setCloseNotify :: Context -> IO () +setCloseNotify ctx = writeIORef (ctxCloseNotify_ ctx) True ctxEstablished :: Context -> IO Established ctxEstablished ctx = readIORef $ ctxEstablished_ ctx diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -22,6 +22,7 @@ sendData, recvData, recvData', + closeNotifyReceived, updateKey, KeyUpdateRequest (..), requestCertificate, @@ -229,6 +230,8 @@ let sendP bs | tls13 = do sendPacket13 ctx $ AppData13 bs + -- a KeyUpdate requested from now on is answered again + modifyTLS13State ctx $ \st -> st{tls13stKeyUpdateResponded = False} role <- usingState_ ctx getRole sentCF <- tls13stSentCF <$> getTLS13State ctx rtt0 <- tls13st0RTT <$> getTLS13State ctx @@ -246,7 +249,8 @@ mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend) -- | Get data out of Data packet, and automatically renegotiate if a Handshake --- ClientHello is received. An empty result means EOF. +-- ClientHello is received. An empty result means EOF. Use +-- 'closeNotifyReceived' to tell an orderly closure from a truncation. recvData :: MonadIO m => Context -> m ByteString recvData ctx = liftIO $ do tls13 <- tls13orLater ctx @@ -263,8 +267,10 @@ recvData12 :: Context -> IO ByteString recvData12 ctx = do - pkt <- recvPacket12 ctx - either (onError terminate12) process pkt + pending <- atomicModifyIORef' (ctxPendingAppData ctx) $ \xs -> ([], reverse xs) + if null pending + then recvPacket12 ctx >>= either (onError terminate12) process + else return $ B.concat pending where process (Handshake [ch@ClientHello{}] [b]) = handshakeWith ctx (ch, b) >> recvData12 ctx @@ -273,7 +279,7 @@ -- UserCanceled should be followed by a close_notify. -- fixme: is it safe to call recvData12? process (Alert [(AlertLevel_Warning, UserCanceled)]) = return B.empty - process (Alert [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty + process (Alert [(AlertLevel_Warning, CloseNotify)]) = setCloseNotify ctx >> tryBye ctx >> setEOF ctx >> return B.empty process (Alert [(AlertLevel_Fatal, desc)]) = do setEOF ctx E.throwIO @@ -308,10 +314,12 @@ where clearPending = modifyTLS13State ctx $ \st -> st{tls13stPendingRecv = NoPendingRecv} + -- RFC 9846 Section 6: the level is ignored. Alerts other than the + -- closure ones are error alerts, even at the warning level. -- UserCanceled MUST be followed by a CloseNotify. - process (Alert13 [(AlertLevel_Warning, UserCanceled)]) = return B.empty - process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx >> return B.empty - process (Alert13 [(AlertLevel_Fatal, desc)]) = do + process (Alert13 [(_, UserCanceled)]) = return B.empty + process (Alert13 [(_, CloseNotify)]) = setCloseNotify ctx >> tryBye ctx >> setEOF ctx >> return B.empty + process (Alert13 [(_, desc)]) = do setEOF ctx E.throwIO ( Terminated @@ -411,9 +419,9 @@ -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is -- updated. - when (mode == UpdateRequested) $ withWriteLock ctx $ do - sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] [] - keyUpdate ctx getTxRecordState setTxRecordState + when (mode == UpdateRequested) $ + withWriteLock ctx $ + respondToKeyUpdate ctx loopHandshake13 hbs else do let reason = "received key update before established" @@ -436,8 +444,8 @@ let reason = "HRR is not allowed for 0-RTT" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason _ -> return () - cont <- popAction ctx hb hbs - when cont $ loopHandshake13 hbs + popAction ctx hb hbs + loopHandshake13 hbs recvHS13 :: Context -> IO Bool -> IO () recvHS13 ctx breakLoop = do @@ -446,8 +454,9 @@ either (\_ -> return ()) process pkt where -- UserCanceled MUST be followed by a CloseNotify. - process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx - process (Alert13 [(AlertLevel_Fatal, _desc)]) = setEOF ctx + process (Alert13 [(_, UserCanceled)]) = recvHS13 ctx breakLoop + process (Alert13 [(_, CloseNotify)]) = setCloseNotify ctx >> tryBye ctx >> setEOF ctx + process (Alert13 [(_, _desc)]) = setEOF ctx process (Handshake13 hs bs) = do loopHandshake13 $ zip hs bs stop <- breakLoop @@ -485,18 +494,22 @@ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} loopHandshake13 hbs loopHandshake13 (hb : hbs) = do - cont <- popAction ctx hb hbs - when cont $ loopHandshake13 hbs + popAction ctx hb hbs + loopHandshake13 hbs terminate13 :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) -popAction :: Context -> Handshake13R -> [Handshake13R] -> IO Bool +popAction :: Context -> Handshake13R -> [Handshake13R] -> IO () popAction ctx hb@(h, _b) hbs = do mPendingRecvAction <- popPendingRecvAction ctx case mPendingRecvAction of - Nothing -> return False + -- RFC 9846 Section 6.2: a message no pending action expects is + -- unexpected_message, not dropped. + Nothing -> do + let reason = "unexpected handshake message " ++ show h + terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Just action -> do -- Pending actions are executed with read+write locks, just -- like regular handshake code. @@ -520,7 +533,6 @@ -- App key must be installed before receiving -- the app data. sendCFifNecessary ctx - return True where -- The write lock is held here, so 'handleException' sends the alert. checkAligned needAligned = when needAligned $ do @@ -580,6 +592,14 @@ setEOF ctx debugError (ctxDebug ctx) reason E.throwIO (Terminated False reason err) + +-- | Whether the peer has sent close_notify. If 'recvData' returns an +-- empty result and this is 'False', the transport was closed without +-- close_notify, so the data received may be truncated. +-- +-- @since 2.4.14 +closeNotifyReceived :: MonadIO m => Context -> m Bool +closeNotifyReceived = liftIO . ctxCloseNotify {-# DEPRECATED recvData' "use recvData that returns strict bytestring" #-} diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -868,12 +868,11 @@ extensionID _ = EID_EarlyData extensionEncode (EarlyDataIndication Nothing) = runPut $ putBytes B.empty extensionEncode (EarlyDataIndication (Just w32)) = runPut $ putWord32 w32 - extensionDecode MsgTClientHello = return $ Just (EarlyDataIndication Nothing) - extensionDecode MsgTEncryptedExtensions = return $ Just (EarlyDataIndication Nothing) - extensionDecode MsgTNewSessionTicket = - runGetMaybe $ - EarlyDataIndication . Just <$> getWord32 - extensionDecode _ = const Nothing + extensionDecode MsgTClientHello "" = Just (EarlyDataIndication Nothing) + extensionDecode MsgTEncryptedExtensions "" = Just (EarlyDataIndication Nothing) + extensionDecode MsgTNewSessionTicket bs = + runGetMaybe (EarlyDataIndication . Just <$> getWord32) bs + extensionDecode _ _ = Nothing ------------------------------------------------------------ diff --git a/Network/TLS/Handshake/Certificate.hs b/Network/TLS/Handshake/Certificate.hs --- a/Network/TLS/Handshake/Certificate.hs +++ b/Network/TLS/Handshake/Certificate.hs @@ -10,30 +10,89 @@ import qualified Control.Exception as E import Control.Monad (unless) import Control.Monad.State.Strict +import Data.ASN1.Types (asn1CharacterToString) +import Data.ByteArray.Encoding (Base (Base64), convertToBase) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import Data.List (intercalate, isInfixOf) import Data.X509 ( ExtExtendedKeyUsage (..), ExtKeyUsage (..), ExtKeyUsageFlag, ExtKeyUsagePurpose (..), + encodeSignedObject, extensionGet, + getDistinguishedElements, ) import Network.TLS.Context.Internal +import Network.TLS.Parameters import Network.TLS.Struct import Network.TLS.X509 --- on certificate reject, throw an exception with the proper protocol alert error. -certificateRejected :: MonadIO m => CertificateRejectReason -> m a -certificateRejected CertificateRejectRevoked = - throwCore $ Error_Protocol "certificate is revoked" CertificateRevoked -certificateRejected CertificateRejectExpired = - throwCore $ Error_Protocol "certificate has expired" CertificateExpired -certificateRejected CertificateRejectUnknownCA = - throwCore $ Error_Protocol "certificate has unknown CA" UnknownCa -certificateRejected CertificateRejectAbsent = - throwCore $ Error_Protocol "certificate is missing" CertificateRequired -certificateRejected (CertificateRejectOther s) = - throwCore $ Error_Protocol ("certificate rejected: " ++ s) CertificateUnknown +-- | On certificate reject, throw an exception with the proper protocol alert +-- error. The message carries the reasons of the validation and the subject +-- and issuer of the leaf; the whole chain goes to 'debugError' in PEM. +certificateRejected + :: MonadIO m + => Context -> [FailedReason] -> CertificateChain -> CertificateRejectReason -> m a +certificateRejected ctx reasons cc reason = do + let ~pem = chainPEM cc + liftIO $ debugError (ctxDebug ctx) $ msg ++ details ++ "\n" ++ pem + throwCore $ Error_Protocol (msg ++ details) alert + where + (msg, alert) = case reason of + CertificateRejectRevoked -> ("certificate is revoked", CertificateRevoked) + CertificateRejectExpired -> ("certificate has expired", CertificateExpired) + CertificateRejectUnknownCA -> ("certificate has unknown CA", UnknownCa) + CertificateRejectAbsent -> ("certificate is missing", CertificateRequired) + CertificateRejectOther s -> ("certificate rejected: " ++ s, CertificateUnknown) + -- wrapCertificateChecks may have put the reasons in the message already + details = + concatMap ("; " ++) $ + [rs | not (null reasons), not (rs `isInfixOf` msg)] ++ leafSummary cc + rs = show reasons + +-- | The subject and issuer of the leaf certificate. +leafSummary :: CertificateChain -> [String] +leafSummary (CertificateChain []) = [] +leafSummary (CertificateChain (signed : _)) = + [ "subject: " ++ showDN (certSubjectDN cert) + , "issuer: " ++ showDN (certIssuerDN cert) + ] + where + cert = getCertificate signed + +showDN :: DistinguishedName -> String +showDN dn = + intercalate + ", " + [name oid ++ "=" ++ value cs | (oid, cs) <- getDistinguishedElements dn] + where + name oid = maybe (intercalate "." $ map show oid) id $ lookup oid names + value = maybe "?" id . asn1CharacterToString + names = + [ ([2, 5, 4, 3], "CN") + , ([2, 5, 4, 6], "C") + , ([2, 5, 4, 7], "L") + , ([2, 5, 4, 8], "ST") + , ([2, 5, 4, 10], "O") + , ([2, 5, 4, 11], "OU") + ] + +-- | The certificates of the chain in PEM, leaf first. +chainPEM :: CertificateChain -> String +chainPEM (CertificateChain certs) = concatMap pem certs + where + pem signed = + "-----BEGIN CERTIFICATE-----\n" + ++ concatMap + ((++ "\n") . C8.unpack) + (lines64 $ convertToBase Base64 $ encodeSignedObject signed) + ++ "-----END CERTIFICATE-----\n" + lines64 bs + | B.null bs = [] + | otherwise = let (l, r) = B.splitAt 64 bs in l : lines64 r badCertificate :: MonadIO m => String -> m a badCertificate msg = throwCore $ Error_Protocol msg BadCertificate diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -141,26 +141,8 @@ -- RFC 8446 Sec 4.1.4: the selected_group MUST be in supported_groups -- and MUST NOT already have been offered in the initial key_share. | selectedGroup `elem` groupsSupported - && selectedGroup `notElem` groupsSelected -> do - usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest - clearTxRecordState ctx - let cparams' = cparams{clientUseEarlyData = False} - runPacketFlight ctx $ sendChangeCipherSpec13 ctx - clientSession <- tls13stSession <$> getTLS13State ctx - -- RFC 8446 Sec 4.1.2: the second ClientHello MUST be identical - -- to the first except for the specific listed changes. - -- supported_groups is NOT on that list, so it must be unchanged. - let grps = - Groups - { grpsSupported = groupsSupported - , grpsSelected = [selectedGroup] - } - - handshake - cparams' - ctx - grps - (Just (crand, clientSession, ver)) + && selectedGroup `notElem` groupsSelected -> + retry [selectedGroup] | selectedGroup `elem` groupsSelected -> throwCore $ Error_Protocol @@ -170,8 +152,33 @@ throwCore $ Error_Protocol "server-selected group is not supported" IllegalParameter Just _ -> error "handshake: invalid KeyShare value" - Nothing -> - throwCore $ - Error_Protocol - "key exchange not implemented in HRR, expected key_share extension" - HandshakeFailure + -- RFC 9846 Section 4.1.4: without key_share, the key shares are + -- sent again, but the HelloRetryRequest must change something. + Nothing -> do + mcookie <- usingState_ ctx getTLS13Cookie + when (isNothing mcookie) $ + throwCore $ + Error_Protocol + "HelloRetryRequest would not change ClientHello" + IllegalParameter + retry groupsSelected + where + retry selected = do + usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest + clearTxRecordState ctx + let cparams' = cparams{clientUseEarlyData = False} + runPacketFlight ctx $ sendChangeCipherSpec13 ctx + clientSession <- tls13stSession <$> getTLS13State ctx + -- RFC 8446 Sec 4.1.2: the second ClientHello MUST be identical + -- to the first except for the specific listed changes. + -- supported_groups is NOT on that list, so it must be unchanged. + let grps = + Groups + { grpsSupported = groupsSupported + , grpsSelected = selected + } + handshake + cparams' + ctx + grps + (Just (crand, clientSession, ver)) diff --git a/Network/TLS/Handshake/Client/ClientHello.hs b/Network/TLS/Handshake/Client/ClientHello.hs --- a/Network/TLS/Handshake/Client/ClientHello.hs +++ b/Network/TLS/Handshake/Client/ClientHello.hs @@ -104,10 +104,7 @@ -> Context -> Groups -> ClientRandom - -> ( Maybe ([ByteString], SessionData, CipherChoice, Word32) - , Maybe CipherChoice - , Bool - ) + -> PreSharedKeyInfo -> IO () sendClientHello' cparams ctx Groups{..} crand (pskInfo, rtt0info, rtt0) = do let ver = if tls13 then TLS12 else highestVer @@ -307,9 +304,18 @@ keyShareExt | tls13 = do - (grpCpris, ents) <- unzip <$> mapM (makeClientKeyShare ctx) grpsSelected - usingHState ctx $ setGroupPrivate grpCpris - return $ Just $ toExtensionRaw $ KeyShareClientHello ents + retried <- usingState_ ctx getTLS13HRR + mks <- usingState_ ctx getTLS13KeyShare + mch <- usingHState ctx getClientHello + case (retried, mks, mch) of + -- A HelloRetryRequest without key_share keeps the key shares. + (True, Nothing, Just (CH{chExtensions = exts}, _)) + | Just ext <- find (\(ExtensionRaw eid _) -> eid == EID_KeyShare) exts -> + return $ Just ext + _ -> do + (grpCpris, ents) <- unzip <$> mapM (makeClientKeyShare ctx) grpsSelected + usingHState ctx $ setGroupPrivate grpCpris + return $ Just $ toExtensionRaw $ KeyShareClientHello ents | otherwise = return Nothing secureRenegExt = @@ -324,60 +330,59 @@ | clientUseECH cparams = return $ Just $ toExtensionRaw ECHClientHelloInner | otherwise = return Nothing - preSharedKeyExt = - case pskInfo of - Nothing -> return Nothing - Just (identities, _, choice, obfAge) -> do - let zero = cZero choice - pskIdentities = map (\x -> PskIdentity x obfAge) identities - -- [zero] is a place holds. - -- adjustPreSharedKeyExt will replace them. - binders = replicate (length pskIdentities) $ convert zero - offeredPsks = PreSharedKeyClientHello pskIdentities binders - return $ Just $ toExtensionRaw offeredPsks + preSharedKeyExt + | null pskInfo = return Nothing + | otherwise = do + let pskIdentities = [PskIdentity x obfAge | (x, _, _, obfAge) <- pskInfo] + -- Zeros are place holders. + -- adjustPreSharedKeyExt will replace them. + binders = [convert $ cZero choice | (_, _, choice, _) <- pskInfo] + offeredPsks = PreSharedKeyClientHello pskIdentities binders + return $ Just $ toExtensionRaw offeredPsks randomPreSharedKeyExt :: IO (Maybe ExtensionRaw) - randomPreSharedKeyExt = - case pskInfo of - Nothing -> return Nothing - Just (identities, _, choice, _) -> do - let zero = cZero choice - zeroR <- getStdRandom $ uniformByteString $ BA.length zero - obfAgeR <- getStdRandom genWord32 - let genPskId x = do - xR <- getStdRandom $ uniformByteString $ B.length x - return $ PskIdentity xR obfAgeR - pskIdentitiesR <- mapM genPskId identities - let bindersR = replicate (length pskIdentitiesR) zeroR - offeredPsksR = PreSharedKeyClientHello pskIdentitiesR bindersR - return $ Just $ toExtensionRaw offeredPsksR + randomPreSharedKeyExt + | null pskInfo = return Nothing + | otherwise = do + let genPsk (x, _, choice, _) = do + xR <- getStdRandom $ uniformByteString $ B.length x + obfAgeR <- getStdRandom genWord32 + zeroR <- getStdRandom $ uniformByteString $ BA.length $ cZero choice + return (PskIdentity xR obfAgeR, zeroR) + (pskIdentitiesR, bindersR) <- unzip <$> mapM genPsk pskInfo + let offeredPsksR = PreSharedKeyClientHello pskIdentitiesR bindersR + return $ Just $ toExtensionRaw offeredPsksR ---------------------------------------- - adjustPreSharedKeyExt exts ch = - case pskInfo of - Nothing -> return exts - Just (identities, sdata, choice, _) -> do - let psk = sessionSecret sdata - earlySecret = initEarlySecret choice (Just psk) - usingHState ctx $ setTLS13EarlySecret earlySecret - let ech = encodeHandshake $ ClientHello ch - h = cHash choice - siz = (hashDigestSize h + 1) * length identities + 2 - binder = makePSKBinder earlySecret h siz ech - -- PSK is shared by the previous TLS session. - -- So, PSK is unique for identities. - let binders = replicate (length identities) binder - let exts' = init exts ++ [adjust (last exts)] - adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders - where - withBinders = replacePSKBinder withoutBinders binders - return exts' + adjustPreSharedKeyExt exts ch + | null pskInfo = return exts + | otherwise = do + -- Each ticket has its own PSK, and so its own binder. + let earlySecrets = + [ initEarlySecret choice (Just $ sessionSecret sdata) + | (_, sdata, choice, _) <- pskInfo + ] + usingHState ctx $ setTLS13EarlySecrets earlySecrets + let ech = encodeHandshake $ ClientHello ch + siz = sum [hashDigestSize (cHash choice) + 1 | (_, _, choice, _) <- pskInfo] + 2 + binders <- + zipWithM + ( \earlySecret (_, _, choice, _) -> makePSKBinder ctx earlySecret (cHash choice) siz ech + ) + earlySecrets + pskInfo + let exts' = init exts ++ [adjust (last exts)] + adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders + where + withBinders = replacePSKBinder withoutBinders binders + return exts' getEarlySecretInfo choice = do let usedCipher = cCipher choice usedHash = cHash choice - Just earlySecret <- usingHState ctx getTLS13EarlySecret + -- Early data is protected with the first PSK. + earlySecret : _ <- usingHState ctx getTLS13EarlySecrets earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) let clientEarlySecret = pairClient earlyKey unless (ctxQUICMode ctx) $ do @@ -390,8 +395,10 @@ ---------------------------------------------------------------- +-- | The PSKs offered, each with its identity, session, cipher and +-- obfuscated ticket age; the cipher of early data; and whether to send it. type PreSharedKeyInfo = - ( Maybe ([SessionIDorTicket], SessionData, CipherChoice, Second) + ( [(SessionIDorTicket, SessionData, CipherChoice, Second)] , Maybe CipherChoice , Bool ) @@ -401,8 +408,19 @@ -> Context -> IO PreSharedKeyInfo getPreSharedKeyInfo cparams ctx = do - pskInfo <- getPskInfo - let rtt0info = pskInfo >>= get0RTTinfo + -- After HelloRetryRequest, the binders are computed with the hash of + -- the cipher it chose, so only the PSKs for that hash are offered. + hrr <- usingState_ ctx getTLS13HRR + mHrrCipher <- + if hrr then (>>= hstPendingCipher) <$> getHState ctx else return Nothing + pskInfo <- + if tls13 + then catMaybes <$> mapM (getPskEntry mHrrCipher) (clientSessions cparams) + else return [] + let rtt0info = case pskInfo of + (_, sdata, choice, _) : _ + | clientUseEarlyData cparams && sessionMaxEarlyDataSize sdata > 0 -> Just choice + _ -> Nothing rtt0 = isJust rtt0info return (pskInfo, rtt0info, rtt0) where @@ -410,35 +428,24 @@ highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 - sessions = case clientSessions cparams of - [] -> Nothing - (sid, sdata) : xs -> do - guard tls13 - guard (sessionVersion sdata >= TLS13) - let cid = sessionCipher sdata - sids = map fst xs - sCipher <- findCipher cid ciphers - Just (sid : sids, sdata, sCipher) - - getPskInfo = case sessions of - Nothing -> return Nothing - Just (identity, sdata, sCipher) -> do - let tinfo = fromJust $ sessionTicketInfo sdata - age <- getAge tinfo - return $ - if isAgeValid age tinfo - then - Just - ( identity - , sdata - , makeCipherChoice TLS13 sCipher - , ageToObfuscatedAge age tinfo - ) - else Nothing - - get0RTTinfo (_, sdata, choice, _) - | clientUseEarlyData cparams && sessionMaxEarlyDataSize sdata > 0 = Just choice - | otherwise = Nothing + getPskEntry mHrrCipher (identity, sdata) = case (sCipher, sessionTicketInfo sdata) of + (Just c, Just tinfo) + | sessionVersion sdata >= TLS13 + , maybe True (\hc -> cipherHash hc == cipherHash c) mHrrCipher -> do + age <- getAge tinfo + return $ + if isAgeValid age tinfo + then + Just + ( identity + , sdata + , makeCipherChoice TLS13 c + , ageToObfuscatedAge age tinfo + ) + else Nothing + _ -> return Nothing + where + sCipher = findCipher (sessionCipher sdata) ciphers ---------------------------------------------------------------- @@ -535,6 +542,7 @@ -> (KDF_ID, AEAD_ID, ECHConfig) -> IO (Maybe (AAD -> PlainText -> IO CipherText, EncodedPublicKey, Int)) getHPKE ctx (kdfid, aeadid, conf) = do + nT <- maybe (E.throwIO $ Unsupported "AEAD") return $ nTag aeadid mfunc <- getTLS13HPKE ctx case mfunc of Nothing -> do @@ -548,7 +556,6 @@ where mpkR = cnfEncodedPublicKey conf kemid = cnfKemId conf - nT = nTag aeadid ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Client/Common.hs b/Network/TLS/Handshake/Client/Common.hs --- a/Network/TLS/Handshake/Client/Common.hs +++ b/Network/TLS/Handshake/Client/Common.hs @@ -123,12 +123,14 @@ -- run certificate recv hook ctxWithHooks ctx (`hookRecvCertificates` certs) -- then run certificate validation - usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException + result <- catchException (Right <$> checkCert) (return . Left) + usage <- either rejectOnException (return . wrapCertificateChecks) result case usage of CertificateUsageAccept -> do verifyLeafKeyUsagePurpose KeyUsagePurpose_ServerAuth certs checkLeafCertificateKeyUsage - CertificateUsageReject reason -> certificateRejected reason + CertificateUsageReject reason -> + certificateRejected ctx (either (const []) id result) certs reason where shared = clientShared cparams checkCert = @@ -374,7 +376,16 @@ contextSync ctx ctl = case ctxHandshakeSync ctx of HandshakeSync sync _ -> sync ctx ctl +-- RFC 9846 Section 4.6.1: a session is resumed only with the SNI it was +-- established with, which its server certificate is valid for. clientSessions :: ClientParams -> [(SessionID, SessionData)] -clientSessions ClientParams{..} = case clientWantSessionResume of - Nothing -> clientWantSessionResumeList - Just ent -> clientWantSessionResumeList ++ [ent] +clientSessions ClientParams{..} = filter sameSNI sessions + where + sessions = case clientWantSessionResume of + Nothing -> clientWantSessionResumeList + Just ent -> clientWantSessionResumeList ++ [ent] + host = fst clientServerIdentification + sni + | clientUseServerNameIndication && not (null host) = Just host + | otherwise = Nothing + sameSNI (_, sd) = sessionClientSNI sd == sni diff --git a/Network/TLS/Handshake/Client/ServerHello.hs b/Network/TLS/Handshake/Client/ServerHello.hs --- a/Network/TLS/Handshake/Client/ServerHello.hs +++ b/Network/TLS/Handshake/Client/ServerHello.hs @@ -22,7 +22,6 @@ import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.TranscriptHash -import Network.TLS.IO import Network.TLS.Imports import Network.TLS.Packet import Network.TLS.Parameters @@ -59,7 +58,7 @@ return (ver, hbs, hrr) where recvSH = do - epkt <- recvPacket12 ctx + epkt <- recvPacket12HS ctx case epkt of Left e -> throwCore e Right pkt -> case pkt of @@ -93,12 +92,13 @@ processServerHello :: ClientParams -> Context -> Handshake -> IO () processServerHello cparams ctx (ServerHello sh@SH{..}) = do - -- A server which receives a legacy_version value not equal to - -- 0x0303 MUST abort the handshake with an "illegal_parameter" - -- alert. + -- A client which receives a TLS 1.3 ServerHello with a legacy_version + -- value not equal to 0x0303 MUST abort the handshake with a + -- "protocol_version" alert (RFC 9846 Section 4.1.3). Nothing below + -- TLS 1.2 is supported either. when (shVersion /= TLS12) $ throwCore $ - Error_Protocol (show shVersion ++ " is not supported") IllegalParameter + Error_Protocol (show shVersion ++ " is not supported") ProtocolVersion -- find the compression and cipher methods that the server want to use. clientSession <- tls13stSession <$> getTLS13State ctx chExts <- tls13stSentExtensions <$> getTLS13State ctx @@ -124,6 +124,25 @@ throwCore $ Error_Protocol "spurious extensions received" UnsupportedExtension + -- RFC 9846 Section 4.3.1: the version selected must be TLS 1.3 or + -- later, and offered. + let supportedVers = supportedVersions $ clientSupported cparams + selected (SupportedVersionsServerHello v) = Just v + selected _ = Nothing + case lookupAndDecode + EID_SupportedVersions + MsgTServerHello + shExtensions + Nothing + selected of + Just v + | v < TLS13 || v `notElem` supportedVers -> + throwCore $ + Error_Protocol + ("supported_versions selecting " ++ show v) + IllegalParameter + _ -> return () + let isHRR = isHelloRetryRequest shRandom usingState_ ctx $ do setTLS13HRR isHRR @@ -142,6 +161,28 @@ ver <- usingState_ ctx getVersion + -- TLS 1.2 without supported_versions, too, must be one we support. + when (ver `notElem` supportedVers) $ + throwCore $ + Error_Protocol + ("server version " ++ show ver ++ " is not supported") + ProtocolVersion + + -- RFC 9846 Section 4.2: an extension recognized but not specified for + -- the message is refused with illegal_parameter. + when (ver == TLS13) $ do + let allowed + | isHRR = + [EID_KeyShare, EID_SupportedVersions, EID_Cookie, EID_EncryptedClientHello] + | otherwise = [EID_KeyShare, EID_PreSharedKey, EID_SupportedVersions] + forbidden (ExtensionRaw eid _) = + eid `elem` supportedExtensions && eid `notElem` allowed + case filter forbidden shExtensions of + [] -> return () + ExtensionRaw eid _ : _ -> + throwCore $ + Error_Protocol (show eid ++ " is not allowed in ServerHello") IllegalParameter + unless (cipherAllowedForVersion ver usedCipher) $ throwCore $ Error_Protocol @@ -151,8 +192,6 @@ when (ver == TLS12) $ setServerHelloParameters12 ctx shVersion shRandom usedCipher compressAlg - let supportedVers = supportedVersions $ clientSupported cparams - when (ver == TLS13) $ do -- TLS 1.3 server MUST echo the session id when (clientSession /= shSession) $ @@ -160,11 +199,6 @@ Error_Protocol "session is not matched in compatibility mode" IllegalParameter - when (ver `notElem` supportedVers) $ - throwCore $ - Error_Protocol - ("server version " ++ show ver ++ " is not supported") - ProtocolVersion -- Some servers set TLS 1.2 as the legacy server hello version, -- and TLS 1.3 in the supported_versions extension, *AND ALSO* set 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 @@ -110,30 +110,48 @@ usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare makeEarlySecret = do - mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret - case mEarlySecretPSK of + earlySecrets <- usingHState ctx getTLS13EarlySecrets + mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey + case mSelectedIdentity of Nothing -> return (initEarlySecret choice Nothing, False) - Just earlySecretPSK@(BaseSecret sec) -> do - mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey - case mSelectedIdentity of - Nothing -> - return (initEarlySecret choice Nothing, False) - Just (PreSharedKeyServerHello 0) -> do - unless (BA.length sec == hashSize) $ - throwCore $ - Error_Protocol - "selected cipher is incompatible with selected PSK" - IllegalParameter - usingHState ctx $ setTLS13HandshakeMode PreSharedKey - return (earlySecretPSK, True) - Just _ -> - throwCore $ Error_Protocol "selected identity out of range" IllegalParameter + Just (PreSharedKeyServerHello n) + | n >= 0 + , earlySecretPSK@(BaseSecret sec) : _ <- drop n earlySecrets -> do + unless (BA.length sec == hashSize) $ + throwCore $ + Error_Protocol + "selected cipher is incompatible with selected PSK" + IllegalParameter + usingHState ctx $ setTLS13HandshakeMode PreSharedKey + return (earlySecretPSK, True) + Just _ -> + throwCore $ Error_Protocol "selected identity out of range" IllegalParameter ---------------------------------------------------------------- expectEncryptedExtensions :: MonadIO m => Context -> Handshake13 -> m () expectEncryptedExtensions ctx (EncryptedExtensions13 eexts) = do + -- RFC 9846 Section 4.2: an extension recognized but not specified for + -- EncryptedExtensions is refused with illegal_parameter. + let allowed = + [ EID_ServerName + , EID_SupportedGroups + , EID_ApplicationLayerProtocolNegotiation + , EID_RecordSizeLimit + , EID_EarlyData + , EID_QuicTransportParameters + , EID_EncryptedClientHello + ] + forbidden (ExtensionRaw eid _) = + eid `elem` supportedExtensions && eid `notElem` allowed + case filter forbidden eexts of + [] -> return () + ExtensionRaw eid _ : _ -> + throwCore $ + Error_Protocol + (show eid ++ " is not allowed in EncryptedExtensions") + IllegalParameter liftIO $ do -- RFC 8449 Section 4: the server's RecordSizeLimit is in -- EncryptedExtensions. Until it is known, our own limit is not @@ -153,6 +171,10 @@ unless (mode == PreSharedKey) $ throwCore $ Error_Protocol "early data accepted without PSK" IllegalParameter + selected <- liftIO $ usingState_ ctx getTLS13PreSharedKey + unless (selected == Just (PreSharedKeyServerHello 0)) $ + throwCore $ + Error_Protocol "early data accepted without the first PSK" IllegalParameter usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Accepted liftIO $ modifyTLS13State ctx $ \st -> st{tls13st0RTTAccepted = True} diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -17,6 +17,7 @@ runRecvState, runRecvStateHS, recvPacketHandshake, + recvPacket12HS, onRecvStateHandshake, ensureRecvComplete, processExtendedMainSecret, @@ -44,6 +45,7 @@ import Control.Monad.State.Strict import Data.ByteArray (convert) import qualified Data.ByteString as B +import Data.IORef (modifyIORef') import Network.TLS.Cipher import Network.TLS.Compression @@ -104,6 +106,8 @@ | "invalid version" `isInfixOf` msg = (AlertLevel_Fatal, ProtocolVersion) | "request_update" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter) | "cannot be decompressed" `isInfixOf` msg = (AlertLevel_Fatal, BadCertificate) + | "error certificate parsing" `isInfixOf` msg = + (AlertLevel_Fatal, BadCertificate) | "unsupported certificate compression algorithm" `isInfixOf` msg = (AlertLevel_Fatal, IllegalParameter) | otherwise = (AlertLevel_Fatal, DecodeError) @@ -146,9 +150,36 @@ | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone +-- | 'recvPacket12' during a TLS 1.2 handshake. A client ignores +-- HelloRequest while negotiating (RFC 5246 Section 7.4.1.1), and +-- application data under the current keys may come during renegotiation +-- (Section 6.2.1); it is kept for 'recvData'. +recvPacket12HS :: Context -> IO (Either TLSError Packet) +recvPacket12HS ctx = do + pkt <- recvPacket12 ctx + role <- usingState_ ctx getRole + case pkt of + Right (Handshake hss bss) + | role == ClientRole && any isHelloRequest hss -> + case unzip $ filter (not . isHelloRequest . fst) $ zip hss bss of + ([], _) -> recvPacket12HS ctx + (hss', bss') -> return $ Right $ Handshake hss' bss' + Right (AppData x) -> do + established <- ctxEstablished ctx + switched <- maybe False hstRxSwitched <$> getHState ctx + if established == Established && not switched + then do + modifyIORef' (ctxPendingAppData ctx) (x :) + recvPacket12HS ctx + else return pkt + _ -> return pkt + where + isHelloRequest HelloRequest = True + isHelloRequest _ = False + recvPacketHandshake :: Context -> IO [HandshakeR] recvPacketHandshake ctx = do - pkts <- recvPacket12 ctx + pkts <- recvPacket12HS ctx case pkts of Right (Handshake hss bss) -> return $ zip hss bss Right x@(AppData bs) -> do @@ -182,7 +213,7 @@ runRecvState :: Context -> RecvState IO -> IO () runRecvState _ RecvStateDone = return () -runRecvState ctx (RecvStatePacket f) = recvPacket12 ctx >>= either throwCore f >>= runRecvState ctx +runRecvState ctx (RecvStatePacket f) = recvPacket12HS ctx >>= either throwCore f >>= runRecvState ctx runRecvState ctx iniState = recvPacketHandshake ctx >>= onRecvStateHandshake ctx iniState diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -216,17 +216,25 @@ ---------------------------------------------------------------- +-- | RFC 8446 Section 4.2.11.2: the binder covers the transcript up to the +-- truncated ClientHello, which after HelloRetryRequest begins with +-- message_hash(ClientHello1) and the HelloRetryRequest. makePSKBinder - :: BaseSecret EarlySecret + :: Context + -> BaseSecret EarlySecret -> Hash -> Int -> ByteString -- ^ Encoded client hello - -> ByteString -makePSKBinder (BaseSecret sec) usedHash truncLen ech = - makeVerifyData usedHash binderKey hChTruncated + -> IO ByteString +makePSKBinder ctx (BaseSecret sec) usedHash truncLen ech = do + hrr <- usingState_ ctx getTLS13HRR + hChTruncated <- + if hrr + then transcriptHashWith ctx "binder" $ trunc ech + else return $ TranscriptHash $ hash usedHash $ trunc ech + return $ makeVerifyData usedHash binderKey hChTruncated where - hChTruncated = TranscriptHash $ hash usedHash $ trunc ech th = TranscriptHash $ hash usedHash "" binderKey = deriveSecret usedHash sec "res binder" th trunc x = B.take takeLen x diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -5,6 +5,8 @@ handshakeServerWith, requestCertificateServer, keyUpdate, + sendKeyUpdate, + respondToKeyUpdate, updateKey, KeyUpdateRequest (..), ) where @@ -56,8 +58,6 @@ (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch bs if chosenVersion == TLS13 then do - -- fixme: we should check if the client random is the same as - -- that in the first client hello in the case of hello retry. -- r0 :: Cipher, Hash, Bool (keyShareResult, r0, r1) <- processClientHello13 sparams ctx chI diff --git a/Network/TLS/Handshake/Server/ClientHello.hs b/Network/TLS/Handshake/Server/ClientHello.hs --- a/Network/TLS/Handshake/Server/ClientHello.hs +++ b/Network/TLS/Handshake/Server/ClientHello.hs @@ -57,10 +57,9 @@ (throwCore $ Error_HandshakePolicy "server: handshake denied") updateMeasure ctx incrementNbHandshakes - -- 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. + -- A legacy_version below TLS 1.2 is refused. One above it is refused + -- only with supported_versions (RFC 9846 Section 4.1.2); without it, a + -- server negotiates TLS 1.2 (Section 4.3.1 and RFC 5246 Appendix E.1). when (chVersion < TLS12) $ throwCore $ Error_Protocol (show chVersion ++ " is not supported") ProtocolVersion @@ -85,10 +84,17 @@ | renegotiation = filter (< TLS13) (supportedVersions $ ctxSupported ctx) | otherwise = supportedVersions $ ctxSupported ctx mVersion = debugVersionForced $ serverDebug sparams + when (clientVersions /= [] && chVersion /= TLS12) $ + throwCore $ + Error_Protocol + ("legacy_version " ++ show chVersion ++ " with supported_versions") + ProtocolVersion chosenVersion <- case mVersion of Just cver -> return cver Nothing -> - if (TLS13 `elem` serverVersions) && clientVersions /= [] + -- With supported_versions, only it is used, whether or not the + -- server supports TLS 1.3 (RFC 9846 Section 4.3.1). + if clientVersions /= [] then case findHighestVersionFrom13 clientVersions serverVersions of Nothing -> throwCore $ @@ -151,7 +157,9 @@ setupI :: Context -> ClientHello -> [ByteString] -> IO () setupI ctx chI@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR - unless hrr $ startHandshake ctx TLS13 chRandom + if hrr + then checkSecondClientHello ctx chI + else startHandshake ctx TLS13 chRandom usingHState ctx $ setClientHello chI b let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName @@ -159,11 +167,37 @@ setupO :: Context -> ClientHello -> [ByteString] -> IO () setupO ctx ch@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR - unless hrr $ startHandshake ctx chVersion chRandom + if hrr + then checkSecondClientHello ctx ch + else startHandshake ctx chVersion chRandom usingHState ctx $ setClientHello ch b let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName +-- RFC 9846 Section 4.1.2: the ClientHello after HelloRetryRequest is the +-- same except for these extensions. Their order is not compared. +checkSecondClientHello :: Context -> ClientHello -> IO () +checkSecondClientHello ctx ch2 = do + mch1 <- usingHState ctx getClientHello + case mch1 of + Just (ch1, _) + | strip ch1 /= strip ch2 -> + throwCore $ + Error_Protocol "second client hello is changed" IllegalParameter + _ -> return () + where + strip ch = ch{chExtensions = sortOn eid $ filter keep $ chExtensions ch} + eid (ExtensionRaw i _) = fromExtensionID i + keep (ExtensionRaw i _) = i `notElem` mutable + mutable = + [ EID_KeyShare + , EID_EarlyData + , EID_Cookie + , EID_PreSharedKey + , EID_Padding + , EID_EncryptedClientHello + ] + -- SNI (Server Name Indication) getServerName :: [ExtensionRaw] -> Maybe HostName getServerName chExts = @@ -306,8 +340,9 @@ let info = "tls ech\x00" <> encodedConfig (kdfid, aeadid) = echCipherSuite ctxR <- setupBaseR kemid kdfid aeadid skR Nothing echEnc info - let nenc = nEnc kemid - func = open ctxR + -- unreachable: setupBaseR has refused an unknown KEM + nenc <- maybe (E.throwIO $ Unsupported "KEM") return $ nEnc kemid + let func = open ctxR setTLS13HPKE ctx func nenc return $ Just (func, nenc) _ -> return Nothing diff --git a/Network/TLS/Handshake/Server/ClientHello13.hs b/Network/TLS/Handshake/Server/ClientHello13.hs --- a/Network/TLS/Handshake/Server/ClientHello13.hs +++ b/Network/TLS/Handshake/Server/ClientHello13.hs @@ -43,6 +43,16 @@ (any (\(ExtensionRaw eid _) -> eid == EID_PreSharedKey) $ init chExtensions) $ throwCore $ Error_Protocol "extension pre_shared_key must be last" IllegalParameter + -- RFC 9846 Section 9.2: the extensions a TLS 1.3 ClientHello must have. + let has eid = isJust $ extensionLookup eid chExtensions + missing reason = throwCore $ Error_Protocol reason MissingExtension + unless (has EID_PreSharedKey) $ do + unless (has EID_SignatureAlgorithms) $ + missing "no signature_algorithms extension without pre_shared_key" + unless (has EID_SupportedGroups) $ + missing "no supported_groups extension without pre_shared_key" + when (has EID_SupportedGroups /= has EID_KeyShare) $ + missing "supported_groups and key_share must come together" -- Deciding cipher. -- The shared cipherlist can become empty after filtering for compatible -- creds, check now before calling onCipherChoosing, which does not handle @@ -81,14 +91,26 @@ extract _ = require keyShares <- lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract - let clientGroups = - take limitSupportedGroups $ - lookupAndDecode - EID_SupportedGroups - MsgTClientHello - chExtensions - [] - (\(SupportedGroups gs) -> gs) + let allClientGroups = + lookupAndDecode + EID_SupportedGroups + MsgTClientHello + chExtensions + [] + (\(SupportedGroups gs) -> gs) + clientGroups = take limitSupportedGroups allClientGroups + -- RFC 9846 Section 4.2.8: after HelloRetryRequest, only the selected + -- group is offered. + hrr <- usingState_ ctx getTLS13HRR + when hrr $ do + mg <- usingHState ctx getSupportedGroup + unless (map (Just . keyShareEntryGroup) keyShares == [mg]) $ + throwCore $ + Error_Protocol "key_share not for the group of hello retry" IllegalParameter + -- RFC 9846 Section 4.2.8: servers MAY check this. + unless (all ((`elem` allClientGroups) . keyShareEntryGroup) keyShares) $ + throwCore $ + Error_Protocol "key_share for a group not in supported_groups" IllegalParameter (mgroup, doHRR) <- onSelectKeyShare (serverHooks sparams) @@ -151,50 +173,56 @@ (return (zero, Nothing, False, Nothing)) selectPSK - selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do + selectPSK (PreSharedKeyClientHello ids bnds) = do when (null dhModes) $ throwCore $ Error_Protocol "no psk_key_exchange_modes extension" MissingExtension if PSK_DHE_KE `elem` dhModes then do let len = sum (map (\x -> B.length x + 1) bnds) + 2 - mgr = sharedSessionManager $ serverShared sparams - -- sessionInvalidate is not used for TLS 1.3 - -- because PSK is always changed. - -- So, identity is not stored in Context. - msdata <- - if rtt0 - then sessionResumeOnlyOnce mgr identity - else sessionResume mgr identity - case msdata of - -- 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) + -- The first identity that can be resumed is chosen, each + -- with its own age and binder. + tryPSK len $ zip3 [0 ..] ids bnds else return (zero, Nothing, False, Nothing) selectPSK _ = return (zero, Nothing, False, Nothing) + tryPSK _ [] = return (zero, Nothing, False, Nothing) + tryPSK len ((n, PskIdentity identity obfAge, bnd) : rest) = do + let mgr = sharedSessionManager $ serverShared sparams + -- sessionInvalidate is not used for TLS 1.3 + -- because PSK is always changed. + -- So, identity is not stored in Context. + -- Early data is only with the first identity. + msdata <- + if rtt0 && n == 0 + then sessionResumeOnlyOnce mgr identity + else sessionResume mgr identity + case msdata of + -- 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, n :: Int, len) + , is0RTTvalid && n == 0 + , sessionALPN sdata + ) + else tryPSK len rest + _ -> tryPSK len rest + checkBinder _ Nothing = return [] checkBinder earlySecret (Just (binder, n, tlen)) = do (_, b) <- fromJust <$> usingHState ctx getClientHello - let binder' = makePSKBinder earlySecret usedHash tlen $ B.concat b --- xxx + binder' <- makePSKBinder ctx earlySecret usedHash tlen $ B.concat b unless (binder == binder') $ decryptError "PSK binder validation failed" return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n] @@ -209,7 +237,9 @@ Nothing -> False Just c -> cipherHash c == cipherHash usedCipher isSameVersion = TLS13 == sessionVersion sdata - isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required + -- RFC 9846 does not require the same SNI, but a session of + -- another name may have other credentials and settings. + isPSKvalid = isSameKDF && isSameSNI is0RTTvalid = isSameVersion && isSameCipher return (isPSKvalid, is0RTTvalid) diff --git a/Network/TLS/Handshake/Server/Common.hs b/Network/TLS/Handshake/Server/Common.hs --- a/Network/TLS/Handshake/Server/Common.hs +++ b/Network/TLS/Handshake/Server/Common.hs @@ -173,7 +173,7 @@ CertificateUsageAccept -> do verifyLeafKeyUsage [KeyUsage_digitalSignature] certs verifyLeafKeyUsagePurpose KeyUsagePurpose_ClientAuth certs - CertificateUsageReject reason -> certificateRejected reason + CertificateUsageReject reason -> certificateRejected ctx [] certs reason -- Remember cert chain for later use. -- 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 @@ -160,8 +160,11 @@ rtt0accept = serverEarlyDataSize sparams > 0 decideCredentialInfo allCreds = do + -- RFC 9846 Section 4.2.3: also with pre_shared_key, which falls + -- back to a certificate here. let err = - throwCore $ Error_Protocol "broken signature_algorithms extension" DecodeError + throwCore $ + Error_Protocol "no signature_algorithms extension" MissingExtension cHashSigs <- lookupAndDecodeAndDo EID_SignatureAlgorithms @@ -330,7 +333,10 @@ usingState_ ctx $ setTLS13HRR True failOnEitherError $ setServerHelloParameters13 ctx usedCipher True hrr <- makeHRR ctx usedCipher usedHash chSession g isEch - usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest + usingHState ctx $ do + setTLS13HandshakeMode HelloRetryRequest + -- Checked against the key_share of the second ClientHello. + setSupportedGroup g runPacketFlight ctx $ do loadPacket13 ctx $ Handshake13 [ServerHello13 hrr] [] sendChangeCipherSpec13 ctx diff --git a/Network/TLS/Handshake/Server/TLS13.hs b/Network/TLS/Handshake/Server/TLS13.hs --- a/Network/TLS/Handshake/Server/TLS13.hs +++ b/Network/TLS/Handshake/Server/TLS13.hs @@ -5,6 +5,8 @@ recvClientSecondFlight13, requestCertificateServer, keyUpdate, + sendKeyUpdate, + respondToKeyUpdate, updateKey, KeyUpdateRequest (..), ) where @@ -296,9 +298,9 @@ -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is -- updated. - when (mode == UpdateRequested) $ withWriteLock ctx $ do - sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] [] - keyUpdate ctx getTxRecordState setTxRecordState + when (mode == UpdateRequested) $ + withWriteLock ctx $ + respondToKeyUpdate ctx chk hbs chk (hb : hbs) = do writeIORef ref hbs @@ -378,6 +380,32 @@ hkdfExpandLabel usedHash applicationSecretN "traffic upd" "" $ hashDigestSize usedHash setState ctx usedHash usedCipher (AnyTrafficSecret applicationSecretN1) + +-- | Sending a KeyUpdate and switching to the next Tx keys, with the write +-- lock held. Nothing is sent and 'False' is returned if the epoch would +-- exceed 2^48-1 (RFC 9846 Section 4.7.3). +sendKeyUpdate :: Context -> KeyUpdate -> IO Bool +sendKeyUpdate ctx req = do + sent <- tls13stSentKeyUpdates <$> getTLS13State ctx + if sent >= 2 ^ (48 :: Int) - 1 + then return False + else do + sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] [] + keyUpdate ctx getTxRecordState setTxRecordState + modifyTLS13State ctx $ \st -> st{tls13stSentKeyUpdates = sent + 1} + return True + +-- | Answers a KeyUpdate with update_requested. RFC 9846 Section 4.6.3: +-- several received while we send no application data get one answer. The +-- request is ignored after 2^48-1 updates. +respondToKeyUpdate :: Context -> IO () +respondToKeyUpdate ctx = do + responded <- tls13stKeyUpdateResponded <$> getTLS13State ctx + unless responded $ do + sent <- sendKeyUpdate ctx UpdateNotRequested + when sent $ + modifyTLS13State ctx $ + \st -> st{tls13stKeyUpdateResponded = True} -- | How to update keys in TLS 1.3 data KeyUpdateRequest diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -68,8 +68,8 @@ getTLS13HandshakeMode, setTLS13RTT0Status, getTLS13RTT0Status, - setTLS13EarlySecret, - getTLS13EarlySecret, + setTLS13EarlySecrets, + getTLS13EarlySecrets, setTLS13ResumptionSecret, getTLS13ResumptionSecret, setTLS13CertComp, @@ -148,13 +148,16 @@ , hstClientCertChain :: Maybe CertificateChain , hstPendingTxState :: Maybe RecordState , hstPendingRxState :: Maybe RecordState + , hstRxSwitched :: Bool + -- ^ Set when the peer's ChangeCipherSpec switched the Rx state , hstPendingCipher :: Maybe Cipher , hstPendingCompression :: Compression , hstExtendedMainSecret :: Bool , hstSupportedGroup :: Maybe Group , hstTLS13HandshakeMode :: HandshakeMode13 , hstTLS13RTT0Status :: RTT0Status - , hstTLS13EarlySecret :: Maybe (BaseSecret EarlySecret) -- xxx + , hstTLS13EarlySecrets :: [BaseSecret EarlySecret] + -- ^ Client: one for each PSK offered , hstTLS13ResumptionSecret :: Maybe (BaseSecret ResumptionSecret) , hstTLS13CertComp :: Bool , hstCCS13Sent :: Bool @@ -248,13 +251,14 @@ , hstClientCertChain = Nothing , hstPendingTxState = Nothing , hstPendingRxState = Nothing + , hstRxSwitched = False , hstPendingCipher = Nothing , hstPendingCompression = nullCompression , hstExtendedMainSecret = False , hstSupportedGroup = Nothing , hstTLS13HandshakeMode = FullHandshake , hstTLS13RTT0Status = RTT0None - , hstTLS13EarlySecret = Nothing + , hstTLS13EarlySecrets = [] , hstTLS13ResumptionSecret = Nothing , hstTLS13CertComp = False , hstCCS13Sent = False @@ -352,11 +356,11 @@ getTLS13RTT0Status :: HandshakeM RTT0Status getTLS13RTT0Status = gets hstTLS13RTT0Status -setTLS13EarlySecret :: BaseSecret EarlySecret -> HandshakeM () -setTLS13EarlySecret secret = modify' (\hst -> hst{hstTLS13EarlySecret = Just secret}) +setTLS13EarlySecrets :: [BaseSecret EarlySecret] -> HandshakeM () +setTLS13EarlySecrets secrets = modify' (\hst -> hst{hstTLS13EarlySecrets = secrets}) -getTLS13EarlySecret :: HandshakeM (Maybe (BaseSecret EarlySecret)) -getTLS13EarlySecret = gets hstTLS13EarlySecret +getTLS13EarlySecrets :: HandshakeM [BaseSecret EarlySecret] +getTLS13EarlySecrets = gets hstTLS13EarlySecrets setTLS13ResumptionSecret :: BaseSecret ResumptionSecret -> HandshakeM () setTLS13ResumptionSecret secret = modify' (\hst -> hst{hstTLS13ResumptionSecret = Just secret}) 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 @@ -42,6 +42,7 @@ case mhs >>= hstPendingRxState of Just rx | isNothing mCont -> do modifyMVar_ (ctxRxRecordState ctx) (\_ -> return rx) + usingHState ctx $ modify' $ \hst -> hst{hstRxSwitched = True} return $ Right ChangeCipherSpec _ -> return $ diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -213,6 +213,10 @@ session <- getSession ciphers <- map CipherId <$> getWords16 compressions <- getWords8 + -- cipher_suites<2..2^16-2> and compression_methods<1..2^8-1>: an empty + -- one is decode_error, not handshake_failure or illegal_parameter. + when (null ciphers) $ fail "no cipher suites" + when (null compressions) $ fail "no compression methods" r <- remaining exts <- if r > 0 @@ -275,7 +279,12 @@ Left (i, s) -> fail ("error certificate parsing " ++ show i ++ ":" ++ s) Right cc -> return $ Certificate $ CertificateChain_ cc where - getCertRaw = getOpaque24 >>= \cert -> return (3 + B.length cert, cert) + getCertRaw = do + cert <- getOpaque24 + -- ASN.1Cert<1..2^24-1>: an empty one is decode_error, not + -- bad_certificate. + when (B.null cert) $ fail "empty certificate" + return (3 + B.length cert, cert) ---- diff --git a/Network/TLS/Packet13.hs b/Network/TLS/Packet13.hs --- a/Network/TLS/Packet13.hs +++ b/Network/TLS/Packet13.hs @@ -193,6 +193,8 @@ where getCert = do l <- fromIntegral <$> getWord24 + -- ASN.1Cert<1..2^24-1>: see decodeCertificate. + when (l == 0) $ fail "empty certificate" cert <- getBytes l len <- fromIntegral <$> getWord16 exts <- getExtensions len 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 @@ -60,6 +60,9 @@ Just (bytes, c) | B.null bytes && ProtocolType c `elem` nonEmptyContentTypes -> Left ("empty " ++ show (ProtocolType c) ++ " record disallowed") + -- RFC 9846 Section 5: change_cipher_spec is only sent in clear. + | ProtocolType c == ProtocolType_ChangeCipherSpec -> + Left "protected change_cipher_spec" | otherwise -> Right (ProtocolType c, bytes) where (dc, _pad) = B.spanEnd (== 0) inner diff --git a/Network/TLS/Wire.hs b/Network/TLS/Wire.hs --- a/Network/TLS/Wire.hs +++ b/Network/TLS/Wire.hs @@ -80,8 +80,14 @@ toSimple (GotSuccessRemaining _ _) = Left (Error_Packet_Parsing (lbl ++ ": parsing error: remaining bytes")) toSimple (GotSuccess r) = Right r +-- | Nothing unless the whole input is consumed: data after an extension's +-- content, or any other structure decoded so, is a decode error. runGetMaybe :: Get a -> ByteString -> Maybe a -runGetMaybe f = either (const Nothing) Just . G.runGet f +runGetMaybe f = either (const Nothing) Just . G.runGet (f <* end) + where + end = do + r <- remaining + when (r /= 0) $ fail "trailing data" tryGet :: Get a -> ByteString -> Maybe a tryGet f = either (const Nothing) Just . G.runGet f diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -139,10 +139,12 @@ ---------------------------------------------------------------- arbitraryCiphersIds :: Gen [CipherId] -arbitraryCiphersIds = map CipherId <$> (choose (0, 200) >>= vector) +-- A ClientHello has at least one of each (cipher_suites<2..2^16-2>, +-- compression_methods<1..2^8-1>). +arbitraryCiphersIds = map CipherId <$> (choose (1, 200) >>= vector) arbitraryCompressionIDs :: Gen [Word8] -arbitraryCompressionIDs = choose (0, 200) >>= vector +arbitraryCompressionIDs = choose (1, 200) >>= vector someWords8 :: Int -> Gen [Word8] someWords8 = vector diff --git a/test/ECHSpec.hs b/test/ECHSpec.hs --- a/test/ECHSpec.hs +++ b/test/ECHSpec.hs @@ -35,6 +35,19 @@ describe "ECH greasing" $ do prop "sends greasing ECH" handshake13_greasing prop "sends greasing ECH HRR" handshake13_greasing_hrr + describe "ECHConfigList decoding" $ do + it "decodes a list" $ + length <$> decodeECHConfigList echConfListRaw `shouldBe` Just 1 + it "refuses data after the list" $ + decodeECHConfigList (B.snoc echConfListRaw 0) `shouldBe` Nothing + it "refuses a config longer than its contents" $ + decodeECHConfigList (list [version13 <> opaque16 (B.snoc echConfBody 0)]) + `shouldBe` Nothing + it "refuses a config that runs past the list" $ + decodeECHConfigList (B.pack [0, 0x42] <> echConf) `shouldBe` Nothing + it "ignores a config of an unknown version" $ + decodeECHConfigList (list [B.pack [0xfe, 0x0e] <> opaque16 "x", echConf]) + `shouldBe` decodeECHConfigList echConfListRaw -------------------------------------------------------------- @@ -439,8 +452,20 @@ echKey = [(0, B64.decodeLenient "GAl/YqzDDnssODe5t+2xlQsbSv26kNlfJ0D+nZbK62I=")] echConfList :: ECHConfigList -echConfList = - fromJust $ - decodeECHConfigList $ - B64.decodeLenient - "AEP+DQA/AAAgACDGNVZWrmqQfzAuYGJNa8+OEc6zaUfzd0ltyJQ2y1U2AwAEAAEAAQAQcHVibGljLWxvY2FsaG9zdAAA" +echConfList = fromJust $ decodeECHConfigList echConfListRaw + +-- An ECHConfigList of one ECHConfig, its version and its contents. +echConfListRaw, echConf, version13, echConfBody :: ByteString +echConfListRaw = + B64.decodeLenient + "AEP+DQA/AAAgACDGNVZWrmqQfzAuYGJNa8+OEc6zaUfzd0ltyJQ2y1U2AwAEAAEAAQAQcHVibGljLWxvY2FsaG9zdAAA" +echConf = B.drop 2 echConfListRaw +version13 = B.take 2 echConf +echConfBody = B.drop 4 echConf + +opaque16 :: ByteString -> ByteString +opaque16 bs = + B.pack [fromIntegral (B.length bs `div` 256), fromIntegral (B.length bs)] <> bs + +list :: [ByteString] -> ByteString +list = opaque16 . B.concat diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs --- a/test/EncodeSpec.hs +++ b/test/EncodeSpec.hs @@ -8,7 +8,7 @@ import qualified Data.ByteString.Lazy as BL import Data.Either (isLeft) import Data.Int (Int64) -import Data.Word (Word16) +import Data.Word (Word16, Word8) import GHC.Conc (disableAllocationLimit, enableAllocationLimit, setAllocationCounter) import Network.TLS import Network.TLS.Internal @@ -50,6 +50,18 @@ gotThisMuch (B.length body) (decodeHandshakeRecord record) `shouldBe` True gotThisMuch (B.length body) (decodeHandshakeRecord13 record) `shouldBe` True + describe "extension trailing data" $ do + it "refuses data after the content of an extension" $ + filter (not . snd) trailingCases `shouldBe` [] + + describe "ClientHello decoding" $ do + it "refuses empty cipher_suites" $ + clientHelloAlert [] [0] `shouldBe` Just DecodeError + it "refuses empty compression_methods" $ + clientHelloAlert [0x1301] [] `shouldBe` Just DecodeError + it "decodes one of each" $ + clientHelloAlert [0x1301] [0] `shouldBe` Nothing + describe "encoder/decoder" $ do prop "can encode/decode Header" $ \x -> do decodeHeader (encodeHeader x) `shouldBe` Right x @@ -201,6 +213,50 @@ putWord16 algo putWord24 len putOpaque24 compressed + +-- | Each extension decodes as encoded, and not with a byte appended. +trailingCases :: [(String, Bool)] +trailingCases = + [ ch "supported_groups" $ SupportedGroups [X25519] + , ch "signature_algorithms" $ SignatureAlgorithms [(HashIntrinsic, SignatureRSApssRSAeSHA256)] + , ch "application_layer_protocol_negotiation" $ + ApplicationLayerProtocolNegotiation [B.pack [0x68, 0x32]] + , ch "record_size_limit" $ RecordSizeLimit 16385 + , ch "supported_versions" $ SupportedVersionsClientHello [TLS13] + , ch "psk_key_exchange_modes" $ PskKeyExchangeModes [PSK_DHE_KE] + , ch "key_share" $ KeyShareClientHello [KeyShareEntry X25519 (B.replicate 32 1)] + , ch "early_data" $ EarlyDataIndication Nothing + , ch "post_handshake_auth" PostHandshakeAuth + , ch "renegotiation_info" $ SecureRenegotiation B.empty B.empty + , + ( "early_data in NewSessionTicket" + , refused MsgTNewSessionTicket $ EarlyDataIndication (Just 1) + ) + , ("cookie in ServerHello", refused MsgTServerHello $ Cookie (B.pack [1, 2, 3])) + ] + where + ch name e = (name, refused MsgTClientHello e) + refused :: (Extension e, Eq e) => MessageType -> e -> Bool + refused mt e = decode bs == Just e && decode (B.snoc bs 0) == Nothing + where + bs = extensionEncode e + decode b = extensionDecode mt b `asTypeOf` Just e + +-- | Decodes a ClientHello without extensions and returns its alert, if any. +clientHelloAlert :: [Word16] -> [Word8] -> Maybe AlertDescription +clientHelloAlert ciphers comps = + either (Just . errorToAlertDescription) (const Nothing) $ + decodeHandshake cp HandshakeType_ClientHello $ + runPut $ do + putWord16 0x0303 + putBytes $ B.replicate 32 0 + putWord8 0 + putWord16 $ fromIntegral $ 2 * length ciphers + mapM_ putWord16 ciphers + putWord8 $ fromIntegral $ length comps + mapM_ putWord8 comps + where + cp = CurrentParams{cParamsVersion = TLS12, cParamsKeyXchgType = Nothing} decodeHs :: ByteString -> Either TLSError Handshake decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -2,13 +2,15 @@ module HandshakeSpec where -import Control.Concurrent (threadDelay) +import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, 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 qualified Crypto.Hash as H +import qualified Crypto.MAC.HMAC as HMAC import Data.Bits (shiftR, xor) import qualified Data.ByteArray as BA import qualified Data.ByteString as B @@ -18,11 +20,12 @@ import Data.Maybe import Data.Word (Word16, Word64, Word8) import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) +import Data.X509.Validation (FailedReason (..)) import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Extra.CipherCBC import Network.TLS.Internal -import Network.TLS.QUIC (hkdfExpandLabel) +import Network.TLS.QUIC (errorToAlertDescription, hkdfExpandLabel, hkdfExtract) import Test.Hspec import Test.Hspec.QuickCheck import System.Timeout (timeout) @@ -45,6 +48,8 @@ prop "can run TLS 1.2" handshake_simple prop "can run TLS 1.3" handshake13_simple prop "can update key for TLS 1.3" handshake_update_key + prop "tells close_notify from an EOF" $ handshake_close_notify True + prop "tells an EOF without close_notify" $ handshake_close_notify False it "rejects more than 32 consecutive TLS 1.3 KeyUpdates" handshake_key_update_flood @@ -57,8 +62,6 @@ 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 "keeps to the TLS 1.3 server's record size limit" $ record_size_limit_negotiated TLS13 False it "keeps to the TLS 1.3 client's record size limit" $ @@ -130,6 +133,8 @@ rejectedAsDecryptError it "refuses a TLS 1.2 signature algorithm it cannot sign with" $ handshake12_unimplemented_sigalg + it "tells why a server certificate is rejected, with the chain in PEM" $ + handshake_certificate_rejection_details 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 @@ -139,6 +144,10 @@ handshake12_client_cert_omitted it "rejects a TLS 1.2 server omitting Certificate" $ handshake12_server_message_omitted 11 + it "answers a corrupt certificate with bad_certificate" $ + handshake12_corrupt_certificate False + it "answers an empty certificate with decode_error" $ + handshake12_corrupt_certificate True 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" $ @@ -160,6 +169,10 @@ 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 "keeps application data that arrives during a TLS 1.2 renegotiation" $ + handshake12_renegotiation_interleaved + it "ignores HelloRequest during a TLS 1.2 handshake" $ + handshake12_hello_request_ignored it "rejects SCSV in a secure renegotiation" $ handshake12_renegotiation_tampered $ \ch -> ch{chCiphers = chCiphers ch ++ [CipherId 0xff]} @@ -185,6 +198,7 @@ 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 + it "binds the PSK to the transcript after HRR" handshake13_psk_hrr_binder prop "can handshake with TLS 1.3 0RTT" handshake13_0rtt it "rejects TLS 1.3 early data when ALPN changes" $ handshake13_0rtt_alpn @@ -256,6 +270,14 @@ server_first_record_type_unexpected 24 0 it "rejects application data inside a TLS 1.3 handshake message" $ handshake13_interleaved_app_data + it "rejects an unexpected handshake message after the handshake" $ + handshake13_unexpected_post_handshake + it "treats a warning-level error alert as an error" $ + handshake13_warning_error_alert + it "treats a fatal-level close_notify as a closure" $ + handshake13_fatal_close_notify + it "rejects a protected change_cipher_spec in the handshake" $ + handshake13_protected_ccs it "rejects an empty handshake record before a ClientHello" $ handshake_empty_handshake_record True it "rejects an empty handshake record inside a ClientHello" $ @@ -274,6 +296,106 @@ handshake13_0rtt_trailing_after_server_hello it "rejects a message after KeyUpdate in its record" $ handshake13_trailing_after_key_update + prop "offers a PSK for the same SNI" $ handshake13_psk_sni True + prop "does not offer a PSK for another SNI" $ handshake13_psk_sni False + it "resumes with the second PSK when the first is unknown" $ + handshake13_second_psk + it "keeps the key shares for a HelloRetryRequest with only a cookie" $ + handshake13_hrr_without_key_share True + it "rejects a HelloRetryRequest that changes nothing" $ + handshake13_hrr_without_key_share False + it "rejects a second ClientHello with another random" $ + handshake13_hrr_second_hello otherRandom (Just "changed") + it "rejects a second ClientHello with an extension added" $ + handshake13_hrr_second_hello extensionAdded (Just "changed") + it "rejects a second ClientHello with the first key_share" $ + handshake13_hrr_second_hello firstKeyShare (Just "key_share") + it "accepts a second ClientHello with extensions reordered" $ + handshake13_hrr_second_hello reordered Nothing + it "rejects a legacy_version above TLS 1.2 with supported_versions" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + serverRefusesHello + params + (\ch -> ch{chVersion = TLS13}) + (refusedWith ProtocolVersion) + it "rejects supported_versions without TLS 1.2 in a TLS 1.2 server" $ do + (cli, srv) <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let cli' = cli{clientSupported = (clientSupported cli){supportedVersions = [TLS13]}} + srv' = srv{serverSupported = (serverSupported srv){supportedVersions = [TLS12]}} + serverRefusesHello (cli', srv') id (refusedWith ProtocolVersion) + it "rejects a ServerHello legacy_version other than TLS 1.2" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + clientRefusesHello + params + (\sh -> sh{shVersion = TLS13}) + (refusedWith ProtocolVersion) + it "rejects supported_versions in a ServerHello choosing TLS 1.2" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let tls12 (ExtensionRaw EID_SupportedVersions _) = + toExtensionRaw $ SupportedVersionsServerHello TLS12 + tls12 e = e + clientRefusesHello + params + (\sh -> sh{shExtensions = map tls12 $ shExtensions sh}) + (refusedFor IllegalParameter "supported_versions") + it "rejects a TLS 1.2 ServerHello in a TLS 1.3 client" $ do + (cli, srv) <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let cli' = cli{clientSupported = (clientSupported cli){supportedVersions = [TLS13]}} + noVersions (ExtensionRaw eid _) = eid /= EID_SupportedVersions + clientRefusesHello + (cli', srv) + (\sh -> sh{shExtensions = filter noVersions $ shExtensions sh}) + (refusedWith ProtocolVersion) + it "rejects ALPN in a TLS 1.3 ServerHello" $ do + (cli, srv) <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let cli' = cli{clientHooks = (clientHooks cli){onSuggestALPN = return $ Just ["h2"]}} + alpn = toExtensionRaw $ ApplicationLayerProtocolNegotiation ["h2"] + clientRefusesHello + (cli', srv) + (\sh -> sh{shExtensions = shExtensions sh ++ [alpn]}) + (refusedWith IllegalParameter) + it "rejects supported_versions in EncryptedExtensions" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let versions = toExtensionRaw $ SupportedVersionsServerHello TLS13 + tamper (EncryptedExtensions13 exts) = + pure $ EncryptedExtensions13 $ exts ++ [versions] + tamper h = pure h + withPairContext params $ \(cctx, sctx) -> do + contextHookSetHandshake13Recv cctx tamper + concurrently_ + (handshake sctx `shouldThrow` anyTLSException) + (handshake cctx `shouldThrow` refusedWith IllegalParameter) + it "rejects a TLS 1.3 ClientHello without signature_algorithms" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + serverRefusesHello + params + (withoutExt EID_SignatureAlgorithms) + (refusedWith MissingExtension) + it "rejects a TLS 1.3 ClientHello with key_share but no supported_groups" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + serverRefusesHello + params + (withoutExt EID_SupportedGroups) + (refusedWith MissingExtension) + it "rejects a key_share for a group not in supported_groups" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let p256 (ExtensionRaw EID_SupportedGroups _) = toExtensionRaw $ SupportedGroups [P256] + p256 e = e + serverRefusesHello + params + (\ch -> ch{chExtensions = map p256 $ chExtensions ch}) + (refusedWith IllegalParameter) + it "rejects data after the content of supported_groups" $ do + params <- fixGroupsX25519 <$> generate arbitraryPairParams13 + let trailing (ExtensionRaw EID_SupportedGroups bs) = + ExtensionRaw EID_SupportedGroups $ B.snoc bs 0 + trailing e = e + serverRefusesHello + params + (\ch -> ch{chExtensions = map trailing $ chExtensions ch}) + (refusedWith DecodeError) + it "answers several update_requested with a single KeyUpdate" $ + handshake13_single_key_update_response it "rejects a two-byte TLS 1.2 ChangeCipherSpec" $ malformed_ccs_unexpected TLS12 @@ -524,6 +646,26 @@ then runTLSFailure params handshake handshake else runTLSSimple params +-- RFC 9846 Section 6.1: an EOF without close_notify may be a truncation. +handshake_close_notify :: Bool -> (ClientParams, ServerParams) -> IO () +handshake_close_notify sendBye params = do + closed <- newIORef False + let close be = + be + { backendRecv = \n -> do + c <- readIORef closed + if c then return "" else backendRecv be n + } + withPairContextWith (id, close) params $ \(cctx, sctx) -> do + concurrently_ (handshake sctx) (handshake cctx) + -- The transport is closed before 'recvData' starts to read. + if sendBye + then concurrently_ (bye cctx) $ recvData sctx `shouldReturn` "" + else do + writeIORef closed True + recvData sctx `shouldReturn` "" + closeNotifyReceived sctx `shouldReturn` sendBye + handshake_update_key :: (ClientParams, ServerParams) -> IO () handshake_update_key = runTLSSimpleKeyUpdate @@ -987,7 +1129,13 @@ -- | 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 = +dropHandshake12 typ = mapHandshake12 $ \m -> if B.head m == typ then "" else m + +-- | Change each handshake message, header included, that a TLS 1.2 peer +-- sends in clear. +mapHandshake12 + :: (B.ByteString -> B.ByteString) -> IORef Bool -> Backend -> Backend +mapHandshake12 f ccsSent be = be { backendSend = \bs -> do done <- readIORef ccsSent @@ -1014,8 +1162,45 @@ + 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 f msg <> stripMessages rest +-- A Certificate message whose lengths are right but whose certificate is +-- not DER is answered with bad_certificate, not decode_error. The server's +-- certificate is zeroed on the wire, or replaced with an empty one. +handshake12_corrupt_certificate :: Bool -> IO () +handshake12_corrupt_certificate empty = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + ccsSent <- newIORef False + let corrupt m + | B.head m == 11 = + let certLen = + fromIntegral (B.index m 7) * 65536 + + fromIntegral (B.index m 8) * 256 + + fromIntegral (B.index m 9) + (hdr, rest) = B.splitAt 10 m + -- The ASN.1Cert vector has at least one byte. + emptyCert = B.pack [11, 0, 0, 6, 0, 0, 3, 0, 0, 0] + in if empty + then emptyCert + else hdr <> B.replicate certLen 0 <> B.drop certLen rest + | otherwise = m + withPairContextWith + (id, mapHandshake12 corrupt ccsSent) + (clientParam, serverParam) $ + \(cctx, sctx) -> + concurrently_ + (void (E.try (handshake sctx) :: IO (Either E.SomeException ()))) + (handshake cctx `shouldThrow` alertOf expected) + where + expected = if empty then DecodeError else BadCertificate + alertOf ad (HandshakeFailed err) = errorToAlertDescription err == ad + alertOf _ _ = False + -- 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, @@ -1176,6 +1361,39 @@ (void (E.try (handshake cctx) :: IO (Either TLSException ()))) r `shouldSatisfy` isJust +-- The exception names the validation failures and the leaf, and debugError +-- gets every certificate of the chain in PEM. +handshake_certificate_rejection_details :: IO () +handshake_certificate_rejection_details = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + logRef <- newIORef [] + chainRef <- newIORef Nothing + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onServerCertificate = \_ _ _ chain -> + writeIORef chainRef (Just chain) >> return [UnknownCA] + } + , clientDebug = + (clientDebug clientParam) + { debugError = \msg -> modifyIORef logRef (msg :) + } + } + withPairContextWith (id, id) (clientParam', serverParam) $ \(cctx, sctx) -> + concurrently_ + (void (E.try (handshake sctx) :: IO (Either TLSException ()))) + (handshake cctx `shouldThrow` rejectedWithDetails) + Just (CertificateChain certs) <- readIORef chainRef + logs <- readIORef logRef + let begin = "-----BEGIN CERTIFICATE-----" + pems = sum [length (filter (== begin) (lines l)) | l <- logs] + pems `shouldBe` length certs + where + rejectedWithDetails (HandshakeFailed (Error_Protocol msg UnknownCa)) = + "[UnknownCA]" `isInfixOf` msg && "subject: " `isInfixOf` msg + rejectedWithDetails _ = False + -- 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 @@ -1272,11 +1490,10 @@ 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. +-- its own, without supported_versions, negotiates the highest version it +-- supports (RFC 5246 Appendix E.1, RFC 9846 Section 4.3.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 @@ -1689,6 +1906,55 @@ -- recvData receives the alert from the second handshake hsServer ctx = handshake ctx >> void (recvData ctx) +-- RFC 5246 Section 6.2.1: application data may come between the handshake +-- messages of a renegotiation. The server sends some before it reads the +-- client's ClientHello, so it reaches the client ahead of ServerHello. +handshake12_renegotiation_interleaved :: IO () +handshake12_renegotiation_interleaved = do + CSP12 (cparams, sparams) <- generate arbitrary + let sparams' = + sparams + { serverSupported = + (serverSupported sparams) + { supportedClientInitiatedRenegotiation = True + } + } + sent <- newEmptyMVar + r <- timeout 10000000 $ + withPairContextWith (id, id) (cparams, sparams') $ \(cctx, sctx) -> do + concurrently_ (handshake sctx) (handshake cctx) + concurrently_ + ( do + sendData sctx "during" + putMVar sent () + recvData sctx `shouldReturn` "after" + ) + ( do + takeMVar sent + handshake cctx + recvData cctx `shouldReturn` "during" + sendData cctx "after" + ) + r `shouldSatisfy` isJust + +-- RFC 5246 Section 7.4.1.1: a client ignores HelloRequest while it is +-- negotiating. One is put ahead of the server's ChangeCipherSpec. +handshake12_hello_request_ignored :: IO () +handshake12_hello_request_ignored = do + CSP12 params <- generate arbitrary + sends <- newIORef (0 :: Int) + let injectHelloRequest be = + be + { backendSend = \bs -> do + n <- atomicModifyIORef' sends $ \i -> (i + 1, i) + when (n == 1) $ backendSend be $ B.pack [22, 3, 3, 0, 4, 0, 0, 0, 0] + backendSend be bs + } + r <- timeout 10000000 $ + withPairContextWith (id, injectHelloRequest) params $ \(cctx, sctx) -> + concurrently_ (handshake sctx) (handshake cctx) + r `shouldSatisfy` isJust + -- 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 @@ -2167,6 +2433,75 @@ runTLSSimple13 (cli2, srv2') HelloRetryRequest +-- RFC 8446 Section 4.2.11.2: after HelloRetryRequest the binder covers +-- message_hash(ClientHello1), the HelloRetryRequest and the truncated +-- ClientHello2. It is computed here from the bytes on the wire, so that +-- the client and the server cannot agree on another definition. +handshake13_psk_hrr_binder :: IO () +handshake13_psk_hrr_binder = do + (cli, srv) <- generate arbitraryPairParams13 + let supported grp = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [grp] + , supportedGroupsTLS13 = [[grp]] + } + params0 = + ( cli{clientSupported = (supported X25519){supportedGroups = [X25519, P256]}} + , srv{serverSupported = supported X25519} + ) + sessionRefs <- twoSessionRefs + let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0 + runTLSSimple13 params FullHandshake + + -- The key share is for X25519, the group of the session, and the server + -- now asks for P-256. + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + psk = sessionSecret $ snd $ fromJust sessionParams + cSent <- newIORef [] + sSent <- newIORef [] + let record ref be = be{backendSend = \bs -> modifyIORef ref (bs :) >> backendSend be bs} + params2 = (pc, ps{serverSupported = supported P256}) + withPairContextWith (record cSent, record sSent) params2 $ \(cctx, sctx) -> + concurrently_ (handshake sctx) (handshake cctx) + ch1 : ch2 : _ <- plainHandshakes . B.concat . reverse <$> readIORef cSent + hrr : _ <- plainHandshakes . B.concat . reverse <$> readIORef sSent + let binderLen = 32 + binder = B.drop (B.length ch2 - binderLen) ch2 + truncated = B.take (B.length ch2 - (2 + 1 + binderLen)) ch2 + sha256 :: B.ByteString -> B.ByteString + sha256 = BA.convert . H.hashWith H.SHA256 + messageHash = B.pack [254, 0, 0, fromIntegral binderLen] <> sha256 ch1 + early = hkdfExtract SHA256 (BA.zero 32) (BA.convert psk) :: BA.ScrubbedBytes + binderKey = hkdfExpandLabel SHA256 early "res binder" (sha256 "") 32 :: BA.ScrubbedBytes + finishedKey = hkdfExpandLabel SHA256 binderKey "finished" "" 32 :: B.ByteString + expected = + BA.convert + ( HMAC.hmac finishedKey (sha256 $ messageHash <> hrr <> truncated) + :: HMAC.HMAC H.SHA256 + ) + binder `shouldBe` expected + where + -- The handshake messages of the plaintext records, in order. + plainHandshakes = messages . B.concat . handshakeRecords + handshakeRecords bs + | B.length bs < 5 = [] + | otherwise = + let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4) + (body, rest) = B.splitAt len $ B.drop 5 bs + in [body | B.head bs == 22] ++ handshakeRecords rest + messages m + | B.length m < 4 = [] + | 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 msg : messages rest + handshake13_0rtt :: CSP13 -> IO () handshake13_0rtt (CSP13 (cli, srv)) = do let cliSupported = @@ -2815,12 +3150,61 @@ 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. +-- other record types. After the handshake the client sends a record holding +-- only the first two bytes of a KeyUpdate and then a record of application +-- data. handshake13_interleaved_app_data :: IO () -handshake13_interleaved_app_data = do +handshake13_interleaved_app_data = + serverRefusesProtected13 [(22, B.pack [24, 0]), (23, "hello")] + +-- RFC 9846 Section 6.2: a handshake message that nothing expects after the +-- handshake is unexpected_message. The client sends a Finished and then a +-- record of application data. +handshake13_unexpected_post_handshake :: IO () +handshake13_unexpected_post_handshake = + serverRefusesProtected13 [(22, finished), (23, "hello")] + where + finished = B.pack [20, 0, 0, 32] <> B.replicate 32 0 + +-- RFC 9846 Section 6: the level of an alert is ignored. A handshake_failure +-- at the warning level is an error alert, which the server reports without +-- answering. A close_notify at the fatal level closes the connection. +handshake13_warning_error_alert :: IO () +handshake13_warning_error_alert = + clientSendsProtected13 + [(21, B.pack [1, 40])] + (\sctx -> recvData sctx `shouldThrow` receivedAlert HandshakeFailure) + (\_ -> return ()) + where + receivedAlert ad (Terminated True _ (Error_Protocol _ ad')) = ad == ad' + receivedAlert _ _ = False + +handshake13_fatal_close_notify :: IO () +handshake13_fatal_close_notify = + clientSendsProtected13 + [(21, B.pack [2, 0])] + (\sctx -> recvData sctx `shouldReturn` "") + (\_ -> return ()) + +-- The server must not deliver the data and must answer with +-- unexpected_message. +serverRefusesProtected13 :: [(Word8, B.ByteString)] -> IO () +serverRefusesProtected13 records = + clientSendsProtected13 records serverSide clientSide + where + serverSide sctx = do + r <- E.try (recvData sctx) :: IO (Either TLSException B.ByteString) + case r of + Right d -> expectationFailure $ "server delivered " ++ show d + Left _ -> return () + clientSide cctx = recvData cctx `shouldThrow` peerSentUnexpected + +-- After the handshake the client sends records of these inner types and +-- contents, protected under its application traffic secret. Then each side +-- checks what it receives. +clientSendsProtected13 + :: [(Word8, B.ByteString)] -> (Context -> IO ()) -> (Context -> IO ()) -> IO () +clientSendsProtected13 records serverSide clientSide = do let cipher = cipher13_AES_128_GCM_SHA256 (clientParam, serverParam) <- generate $ @@ -2845,13 +3229,7 @@ } 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 () - ) + (handshake sctx >> serverSide sctx) ( do handshake cctx Just h <- readIORef secretRef @@ -2859,17 +3237,72 @@ 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 + sequence_ + [ send $ protect13 key iv sqn ty content + | (sqn, (ty, content)) <- zip [0 ..] records + ] + clientSide cctx ) where unhex [] = B.empty unhex (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhex rest) unhex _ = error "unhex" +-- RFC 9846 Section 5: a protected change_cipher_spec is unexpected_message, +-- not dropped like one in clear. The client puts one, under its handshake +-- traffic secret, before its Finished, and never sends a CCS in clear. The +-- Finished then has the wrong sequence number: a server dropping the CCS +-- would fail with bad_record_mac. +handshake13_protected_ccs :: IO () +handshake13_protected_ccs = do + let cipher = cipher13_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher], [cipher]) + secretRef <- newIORef Nothing + injected <- newIORef False + let logKey line = case words line of + ["CLIENT_HANDSHAKE_TRAFFIC_SECRET", _, h] -> writeIORef secretRef (Just h) + _ -> return () + clientParam' = + clientParam + { clientDebug = (clientDebug clientParam){debugKeyLogger = logKey} + } + inject be = + be + { backendSend = \bs -> do + done <- readIORef injected + msecret <- readIORef secretRef + -- the CCS in clear is never sent + let rs = filter ((/= 20) . B.head) $ records bs + case (done, msecret, break ((== 23) . B.head) rs) of + (False, Just h, (clear, protected@(_ : _))) -> do + writeIORef injected True + let secret = BA.convert (unhex h) :: BA.ScrubbedBytes + key = hkdfExpandLabel SHA256 secret "key" "" 16 :: B.ByteString + iv = hkdfExpandLabel SHA256 secret "iv" "" 12 :: B.ByteString + ccs = protect13 key iv 0 20 (B.singleton 1) + backendSend be $ B.concat (clear ++ ccs : protected) + _ -> backendSend be $ B.concat rs + } + withPairContextWith (inject, id) (clientParam', serverParam) $ \(cctx, sctx) -> + concurrently_ + (handshake sctx `shouldThrow` refusedFor UnexpectedMessage "change_cipher_spec") + (void (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString))) + readIORef injected `shouldReturn` True + where + unhex [] = B.empty + unhex (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhex rest) + unhex _ = error "unhex" + records bs + | B.length bs < 5 = [] + | otherwise = + let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4) + (r, rest) = B.splitAt (5 + len) bs + in r : records rest + -- RFC 9846 Section 5.1: the messages before a key change must end their -- record. The record holding the ClientHello (the client's first) gets a -- copy of it, or that holding the ServerHello (the server's first) gets a @@ -2975,6 +3408,256 @@ ) r `shouldSatisfy` isJust +-- RFC 9846 Section 4.6.3: a peer that gets several KeyUpdates with +-- update_requested while it sends nothing answers them once. The server +-- asks twice, and after the client's data once more. It counts the +-- KeyUpdates it receives. +handshake13_single_key_update_response :: IO () +handshake13_single_key_update_response = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + updates <- newIORef (0 :: Int) + let count h = do + case h of + KeyUpdate13 _ -> modifyIORef' updates (+ 1) + _ -> return () + return h + withPairContext (clientParam, serverParam) $ \(cctx, sctx) -> + concurrently_ + ( do + handshake sctx + contextHookSetHandshake13Recv sctx count + updateKey sctx TwoWay `shouldReturn` True + updateKey sctx TwoWay `shouldReturn` True + sendData sctx "hello" + recvData sctx `shouldReturn` "x" + readIORef updates `shouldReturn` 1 + updateKey sctx TwoWay `shouldReturn` True + sendData sctx "again" + recvData sctx `shouldReturn` "y" + ) + ( do + handshake cctx + recvData cctx `shouldReturn` "hello" + sendData cctx "x" + recvData cctx `shouldReturn` "again" + sendData cctx "y" + ) + readIORef updates `shouldReturn` 2 + +-- The client offers an unknown ticket, with a PSK of its own, before the +-- one the server issued. Each PSK has its own binder, and the server +-- resumes with the second. +-- RFC 9846 Section 4.6.1: a client resumes only with the SNI of the session. +handshake13_psk_sni :: Bool -> CSP13 -> IO () +handshake13_psk_sni same (CSP13 (cli, srv)) = do + let withName name c = + c + { clientServerIdentification = (name, snd $ clientServerIdentification c) + , clientUseServerNameIndication = True + } + sessionRefs <- twoSessionRefs + let params = + setPairParamsSessionManagers + (twoSessionManagers sessionRefs) + (withName "a.example" cli, srv) + runTLSSimple params + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + let name = if same then "a.example" else "b.example" + (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params + offered <- newIORef False + let check hs@(ClientHello ch) = do + let psk (ExtensionRaw eid _) = eid == EID_PreSharedKey + writeIORef offered $ any psk $ chExtensions ch + return hs + check hs = return hs + withPairContextWith (id, id) (withName name cli2, srv2) $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx check + concurrently_ (handshake sctx) (handshake cctx) + readIORef offered `shouldReturn` same + +handshake13_second_psk :: IO () +handshake13_second_psk = do + (cli, srv) <- generate arbitraryPairParams13 + sessionRefs <- twoSessionRefs + let params = + setPairParamsSessionManagers (twoSessionManagers sessionRefs) $ + fixGroupsX25519 (cli, srv) + runTLSSimple13 params FullHandshake + Just (sid, sdata) <- readClientSessionRef sessionRefs + let unknown = + ( B.map (xor 0xff) sid + , sdata{sessionSecret = B.map (xor 0xff) (sessionSecret sdata)} + ) + (pc, ps) = params + runTLSSimple13 + (pc{clientWantSessionResumeList = [unknown, (sid, sdata)]}, ps) + PreSharedKey + +-- RFC 9846 Section 4.1.4: a HelloRetryRequest may carry only a cookie, +-- after which the client sends the same key shares again with the cookie. +-- One with neither changes nothing and is refused with illegal_parameter. +-- The server side is played by hand. +handshake13_hrr_without_key_share :: Bool -> IO () +handshake13_hrr_without_key_share withCookie = do + let cipher = cipher13_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher], [cipher]) + let cookie = Cookie "a cookie" + r <- timeout 10000000 $ + withPairContext (clientParam, serverParam) $ \(cctx, sctx) -> do + let be = ctxBackend sctx + recvRecord = do + hdr <- backendRecv be 5 + let len = fromIntegral (B.index hdr 3) * 256 + fromIntegral (B.index hdr 4) + body <- backendRecv be len + return (B.head hdr, body) + recvClientHello = do + (ty, body) <- recvRecord + if ty /= 22 + then recvClientHello + else do + let cp = CurrentParams TLS12 Nothing + case decodeHandshake cp HandshakeType_ClientHello (B.drop 4 body) of + Right (ClientHello ch) -> return ch + x -> error $ show x + sendHandshake h = + let bs = encodeHandshake h + len = B.length bs + in backendSend be $ + B.pack [22, 3, 3, fromIntegral (len `div` 256), fromIntegral (len `mod` 256)] + <> bs + concurrently_ + ( do + ch1 <- recvClientHello + sendHandshake $ + ServerHello + SH + { shVersion = TLS12 + , shRandom = hrrRandom + , shSession = chSession ch1 + , shCipher = CipherId 0x1301 + , shComp = 0 + , shExtensions = + toExtensionRaw (SupportedVersionsServerHello TLS13) + : [toExtensionRaw cookie | withCookie] + } + when withCookie $ do + ch2 <- recvClientHello + findExt EID_KeyShare ch2 `shouldBe` findExt EID_KeyShare ch1 + findExt EID_Cookie ch2 `shouldBe` Just (toExtensionRaw cookie) + -- handshake_failure, to end the client + backendSend be $ B.pack [21, 3, 3, 0, 2, 2, 40] + ) + ( if withCookie + then void (E.try (handshake cctx) :: IO (Either TLSException ())) + else handshake cctx `shouldThrow` illegalParameter + ) + r `shouldSatisfy` isJust + where + findExt i ch = find (\(ExtensionRaw eid _) -> eid == i) (chExtensions ch) + illegalParameter (HandshakeFailed (Error_Protocol _ IllegalParameter)) = True + illegalParameter _ = False + +-- The server refuses the ClientHello the function changes, as the +-- selector expects. +-- RFC 9846 Section 4.1.2: the server changes the second ClientHello after +-- HelloRetryRequest with the function, given the first one, and refuses +-- it for the reason or accepts it. +handshake13_hrr_second_hello + :: (ClientHello -> ClientHello -> ClientHello) -> Maybe String -> IO () +handshake13_hrr_second_hello f mreason = do + (cli, srv) <- generate arbitraryPairParams13 + let supported grps = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = grps + , supportedGroupsTLS13 = [grps] + } + params = + ( cli{clientSupported = (supported [X25519]){supportedGroups = [X25519, P256]}} + , srv{serverSupported = supported [P256]} + ) + ref <- newIORef Nothing + let tamper (ClientHello ch) = do + mch1 <- readIORef ref + case mch1 of + Nothing -> writeIORef ref (Just ch) >> pure (ClientHello ch) + Just ch1 -> pure $ ClientHello $ f ch1 ch + tamper h = pure h + withPairContext params $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx tamper + case mreason of + Nothing -> concurrently_ (handshake sctx) (handshake cctx) + Just why -> + concurrently_ + (handshake sctx `shouldThrow` refusedFor IllegalParameter why) + (handshake cctx `shouldThrow` anyTLSException) + readIORef ref >>= (`shouldSatisfy` isJust) + +otherRandom + , extensionAdded + , firstKeyShare + , reordered + :: ClientHello -> ClientHello -> ClientHello +otherRandom _ ch = ch{chRandom = ClientRandom $ B.replicate 32 0} +extensionAdded _ ch = + ch{chExtensions = ExtensionRaw (ExtensionID 0xfafa) "" : chExtensions ch} +firstKeyShare ch1 ch = ch{chExtensions = map replace $ chExtensions ch} + where + replace (ExtensionRaw EID_KeyShare _) = + fromJust $ find (\(ExtensionRaw eid _) -> eid == EID_KeyShare) $ chExtensions ch1 + replace e = e +reordered _ ch = ch{chExtensions = reverse $ chExtensions ch} + +serverRefusesHello + :: (ClientParams, ServerParams) + -> (ClientHello -> ClientHello) + -> Selector TLSException + -> IO () +serverRefusesHello params f refused = + withPairContext params $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv sctx tamper + concurrently_ + (handshake sctx `shouldThrow` refused) + (handshake cctx `shouldThrow` anyTLSException) + where + tamper (ClientHello ch) = pure $ ClientHello $ f ch + tamper h = pure h + +-- The client refuses the ServerHello the function changes, as the +-- selector expects. +clientRefusesHello + :: (ClientParams, ServerParams) + -> (ServerHello -> ServerHello) + -> Selector TLSException + -> IO () +clientRefusesHello params f refused = + withPairContext params $ \(cctx, sctx) -> do + contextHookSetHandshakeRecv cctx tamper + concurrently_ + (handshake sctx `shouldThrow` anyTLSException) + (handshake cctx `shouldThrow` refused) + where + tamper (ServerHello sh) = pure $ ServerHello $ f sh + tamper h = pure h + +withoutExt :: ExtensionID -> ClientHello -> ClientHello +withoutExt i ch = + ch{chExtensions = filter (\(ExtensionRaw eid _) -> eid /= i) $ chExtensions ch} + +refusedWith :: AlertDescription -> TLSException -> Bool +refusedWith ad = refusedFor ad "" + +-- Refused with the alert, for a reason containing the string. +refusedFor :: AlertDescription -> String -> TLSException -> Bool +refusedFor ad needle (HandshakeFailed (Error_Protocol reason ad')) = + ad == ad' && needle `isInfixOf` reason +refusedFor _ _ _ = False + unhexBytes :: String -> B.ByteString unhexBytes [] = B.empty unhexBytes (a : b : rest) = B.cons (read ['0', 'x', a, b]) (unhexBytes rest) @@ -3137,12 +3820,6 @@ ) r `shouldSatisfy` isJust readIORef seen `shouldReturn` True - --- Refused with the alert, for a reason containing the string. -refusedFor :: AlertDescription -> String -> TLSException -> Bool -refusedFor ad needle (HandshakeFailed (Error_Protocol reason ad')) = - ad == ad' && needle `isInfixOf` reason -refusedFor _ _ _ = False rejectedAsUnexpected :: TLSException -> Bool rejectedAsUnexpected (HandshakeFailed (Error_Packet_unexpected _ _)) = 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.13 +version: 2.4.14 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez @@ -132,7 +132,7 @@ crypton-x509-validation >=1.10 && <1.11, data-default, ech-config, - hpke >=0.3.0 && <0.4, + hpke >=0.4.0 && <0.5, mtl >=2.2 && <2.4, network >=3.1, ram >=0.22.0 && <0.23,