tls 2.4.13 → 2.4.14
raw patch · 31 files changed
+1443/−301 lines, 31 filesdep ~hpkePVP ok
version bump matches the API change (PVP)
Dependency ranges changed: hpke
API changes (from Hackage documentation)
+ Network.TLS: closeNotifyReceived :: MonadIO m => Context -> m Bool
Files
- CHANGELOG.md +37/−0
- Network/TLS.hs +1/−0
- Network/TLS/Context.hs +6/−0
- Network/TLS/Context/Internal.hs +16/−0
- Network/TLS/Core.hs +39/−19
- Network/TLS/Extension.hs +5/−6
- Network/TLS/Handshake/Certificate.hs +71/−12
- Network/TLS/Handshake/Client.hs +32/−25
- Network/TLS/Handshake/Client/ClientHello.hs +92/−85
- Network/TLS/Handshake/Client/Common.hs +16/−5
- Network/TLS/Handshake/Client/ServerHello.hs +47/−13
- Network/TLS/Handshake/Client/TLS13.hs +39/−17
- Network/TLS/Handshake/Common.hs +33/−2
- Network/TLS/Handshake/Common13.hs +13/−5
- Network/TLS/Handshake/Server.hs +2/−2
- Network/TLS/Handshake/Server/ClientHello.hs +44/−9
- Network/TLS/Handshake/Server/ClientHello13.hs +71/−41
- Network/TLS/Handshake/Server/Common.hs +1/−1
- Network/TLS/Handshake/Server/ServerHello13.hs +8/−2
- Network/TLS/Handshake/Server/TLS13.hs +31/−3
- Network/TLS/Handshake/State.hs +12/−8
- Network/TLS/IO/Decode.hs +1/−0
- Network/TLS/Packet.hs +10/−1
- Network/TLS/Packet13.hs +2/−0
- Network/TLS/Record/Decrypt.hs +3/−0
- Network/TLS/Wire.hs +7/−1
- test/Arbitrary.hs +4/−2
- test/ECHSpec.hs +30/−5
- test/EncodeSpec.hs +57/−1
- test/HandshakeSpec.hs +711/−34
- tls.cabal +2/−2
CHANGELOG.md view
@@ -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).
Network/TLS.hs view
@@ -26,6 +26,7 @@ handshake, sendData, recvData,+ closeNotifyReceived, bye, -- * Exceptions
Network/TLS/Context.hs view
@@ -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
Network/TLS/Context/Internal.hs view
@@ -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
Network/TLS/Core.hs view
@@ -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" #-}
Network/TLS/Extension.hs view
@@ -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 ------------------------------------------------------------
Network/TLS/Handshake/Certificate.hs view
@@ -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
Network/TLS/Handshake/Client.hs view
@@ -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))
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -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 ----------------------------------------------------------------
Network/TLS/Handshake/Client/Common.hs view
@@ -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
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -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
Network/TLS/Handshake/Client/TLS13.hs view
@@ -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}
Network/TLS/Handshake/Common.hs view
@@ -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
Network/TLS/Handshake/Common13.hs view
@@ -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
Network/TLS/Handshake/Server.hs view
@@ -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
Network/TLS/Handshake/Server/ClientHello.hs view
@@ -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
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -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)
Network/TLS/Handshake/Server/Common.hs view
@@ -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. --
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -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
Network/TLS/Handshake/Server/TLS13.hs view
@@ -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
Network/TLS/Handshake/State.hs view
@@ -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})
Network/TLS/IO/Decode.hs view
@@ -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 $
Network/TLS/Packet.hs view
@@ -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) ----
Network/TLS/Packet13.hs view
@@ -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
Network/TLS/Record/Decrypt.hs view
@@ -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
Network/TLS/Wire.hs view
@@ -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
test/Arbitrary.hs view
@@ -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
test/ECHSpec.hs view
@@ -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
test/EncodeSpec.hs view
@@ -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
test/HandshakeSpec.hs view
@@ -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
tls.cabal view
@@ -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 <vincent@snarc.org>@@ -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,