1{-# LANGUAGE LambdaCase #-} 2{-# LANGUAGE OverloadedStrings #-} 3-- | 4-- Module : Network.TLS.Handshake.Client 5-- License : BSD-style 6-- Maintainer : Vincent Hanquez <vincent@snarc.org> 7-- Stability : experimental 8-- Portability : unknown 9-- 10module Network.TLS.Handshake.Client 11 ( handshakeClient 12 , handshakeClientWith 13 , postHandshakeAuthClientWith 14 ) where 15 16import Network.TLS.Crypto 17import Network.TLS.Context.Internal 18import Network.TLS.Parameters 19import Network.TLS.Struct 20import Network.TLS.Struct13 21import Network.TLS.Cipher 22import Network.TLS.Compression 23import Network.TLS.Credentials 24import Network.TLS.Packet hiding (getExtensions) 25import Network.TLS.ErrT 26import Network.TLS.Extension 27import Network.TLS.IO 28import Network.TLS.Imports 29import Network.TLS.State 30import Network.TLS.Measurement 31import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_) 32import Network.TLS.Types 33import Network.TLS.X509 34import qualified Data.ByteString as B 35import Data.X509 (ExtKeyUsageFlag(..)) 36 37import Control.Monad.State.Strict 38import Control.Exception (SomeException, bracket) 39 40import Network.TLS.Handshake.Certificate 41import Network.TLS.Handshake.Common 42import Network.TLS.Handshake.Common13 43import Network.TLS.Handshake.Control 44import Network.TLS.Handshake.Key 45import Network.TLS.Handshake.Process 46import Network.TLS.Handshake.Random 47import Network.TLS.Handshake.Signature 48import Network.TLS.Handshake.State 49import Network.TLS.Handshake.State13 50import Network.TLS.Wire 51 52handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () 53handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx 54handshakeClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeClientWith", True, HandshakeFailure) 55 56-- client part of handshake. send a bunch of handshake of client 57-- values intertwined with response from the server. 58handshakeClient :: ClientParams -> Context -> IO () 59handshakeClient cparams ctx = do 60 let groups = case clientWantSessionResume cparams of 61 Nothing -> groupsSupported 62 Just (_, sdata) -> case sessionGroup sdata of 63 Nothing -> [] -- TLS 1.2 or earlier 64 Just grp -> grp : filter (/= grp) groupsSupported 65 groupsSupported = supportedGroups (ctxSupported ctx) 66 handshakeClient' cparams ctx groups Nothing 67 68-- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: 69-- "The client will also send a 70-- ClientHello when the server has responded to its ClientHello with a 71-- HelloRetryRequest. In that case, the client MUST send the same 72-- ClientHello without modification, except as follows:" 73-- 74-- So, the ClientRandom in the first client hello is necessary. 75handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe (ClientRandom, Session, Version) -> IO () 76handshakeClient' cparams ctx groups mparams = do 77 updateMeasure ctx incrementNbHandshakes 78 (crand, clientSession) <- generateClientHelloParams 79 (rtt0, sentExtensions) <- sendClientHello clientSession crand 80 recvServerHello clientSession sentExtensions 81 ver <- usingState_ ctx getVersion 82 unless (maybe True (\(_, _, v) -> v == ver) mparams) $ 83 throwCore $ Error_Protocol ("version changed after hello retry", True, IllegalParameter) 84 -- recvServerHello sets TLS13HRR according to the server random. 85 -- For 1st server hello, getTLS13HR returns True if it is HRR and False otherwise. 86 -- For 2nd server hello, getTLS13HR returns False since it is NOT HRR. 87 hrr <- usingState_ ctx getTLS13HRR 88 if ver == TLS13 then 89 if hrr then case drop 1 groups of 90 [] -> throwCore $ Error_Protocol ("group is exhausted in the client side", True, IllegalParameter) 91 groups' -> do 92 when (isJust mparams) $ 93 throwCore $ Error_Protocol ("server sent too many hello retries", True, UnexpectedMessage) 94 mks <- usingState_ ctx getTLS13KeyShare 95 case mks of 96 Just (KeyShareHRR selectedGroup) 97 | selectedGroup `elem` groups' -> do 98 usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest 99 clearTxState ctx 100 let cparams' = cparams { clientEarlyData = Nothing } 101 runPacketFlight ctx $ sendChangeCipherSpec13 ctx 102 handshakeClient' cparams' ctx [selectedGroup] (Just (crand, clientSession, ver)) 103 | otherwise -> throwCore $ Error_Protocol ("server-selected group is not supported", True, IllegalParameter) 104 Just _ -> error "handshakeClient': invalid KeyShare value" 105 Nothing -> throwCore $ Error_Protocol ("key exchange not implemented in HRR, expected key_share extension", True, HandshakeFailure) 106 else 107 handshakeClient13 cparams ctx groupToSend 108 else do 109 when rtt0 $ 110 throwCore $ Error_Protocol ("server denied TLS 1.3 when connecting with early data", True, HandshakeFailure) 111 sessionResuming <- usingState_ ctx isSessionResuming 112 if sessionResuming 113 then sendChangeCipherAndFinish ctx ClientRole 114 else do sendClientData cparams ctx 115 sendChangeCipherAndFinish ctx ClientRole 116 recvChangeCipherAndFinish ctx 117 handshakeTerminate ctx 118 where ciphers = supportedCiphers $ ctxSupported ctx 119 compressions = supportedCompressions $ ctxSupported ctx 120 highestVer = maximum $ supportedVersions $ ctxSupported ctx 121 tls13 = highestVer >= TLS13 122 ems = supportedExtendedMasterSec $ ctxSupported ctx 123 groupToSend = listToMaybe groups 124 125 -- List of extensions to send in ClientHello, ordered such that we never 126 -- terminate with a zero-length extension. Some buggy implementations 127 -- are allergic to an extension with empty data at final position. 128 -- 129 -- Without TLS 1.3, the list ends with extension "signature_algorithms" 130 -- with length >= 2 bytes. When TLS 1.3 is enabled, extensions 131 -- "psk_key_exchange_modes" (currently always sent) and "pre_shared_key" 132 -- (not always present) have length > 0. 133 getExtensions pskInfo rtt0 = sequence 134 [ sniExtension 135 , secureReneg 136 , alpnExtension 137 , emsExtension 138 , groupExtension 139 , ecPointExtension 140 --, sessionTicketExtension 141 , signatureAlgExtension 142 --, heartbeatExtension 143 , versionExtension 144 , earlyDataExtension rtt0 145 , keyshareExtension 146 , cookieExtension 147 , postHandshakeAuthExtension 148 , pskExchangeModeExtension 149 , preSharedKeyExtension pskInfo -- MUST be last (RFC 8446) 150 ] 151 152 toExtensionRaw :: Extension e => e -> ExtensionRaw 153 toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext) 154 155 secureReneg = 156 if supportedSecureRenegotiation $ ctxSupported ctx 157 then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing 158 else return Nothing 159 alpnExtension = do 160 mprotos <- onSuggestALPN $ clientHooks cparams 161 case mprotos of 162 Nothing -> return Nothing 163 Just protos -> do 164 usingState_ ctx $ setClientALPNSuggest protos 165 return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos 166 emsExtension = return $ 167 if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx) 168 then Nothing 169 else Just $ toExtensionRaw ExtendedMasterSecret 170 sniExtension = if clientUseServerNameIndication cparams 171 then do let sni = fst $ clientServerIdentification cparams 172 usingState_ ctx $ setClientSNI sni 173 return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] 174 else return Nothing 175 176 groupExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups (supportedGroups $ ctxSupported ctx) 177 ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed] 178 --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2] 179 --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend 180 --sessionTicketExtension = return $ Just $ toExtensionRaw $ SessionTicket 181 182 signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams 183 184 versionExtension 185 | tls13 = do 186 let vers = filter (>= TLS10) $ supportedVersions $ ctxSupported ctx 187 return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers 188 | otherwise = return Nothing 189 190 -- FIXME 191 keyshareExtension 192 | tls13 = case groupToSend of 193 Nothing -> return Nothing 194 Just grp -> do 195 (cpri, ent) <- makeClientKeyShare ctx grp 196 usingHState ctx $ setGroupPrivate cpri 197 return $ Just $ toExtensionRaw $ KeyShareClientHello [ent] 198 | otherwise = return Nothing 199 200 sessionAndCipherToResume13 = do 201 guard tls13 202 (sid, sdata) <- clientWantSessionResume cparams 203 guard (sessionVersion sdata >= TLS13) 204 sCipher <- find (\c -> cipherID c == sessionCipher sdata) ciphers 205 return (sid, sdata, sCipher) 206 207 getPskInfo = 208 case sessionAndCipherToResume13 of 209 Nothing -> return Nothing 210 Just (sid, sdata, sCipher) -> do 211 let tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata 212 age <- getAge tinfo 213 return $ if isAgeValid age tinfo 214 then Just (sid, sdata, makeCipherChoice TLS13 sCipher, ageToObfuscatedAge age tinfo) 215 else Nothing 216 217 preSharedKeyExtension pskInfo = 218 case pskInfo of 219 Nothing -> return Nothing 220 Just (sid, _, choice, obfAge) -> 221 let zero = cZero choice 222 identity = PskIdentity sid obfAge 223 offeredPsks = PreSharedKeyClientHello [identity] [zero] 224 in return $ Just $ toExtensionRaw offeredPsks 225 226 pskExchangeModeExtension 227 | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE] 228 | otherwise = return Nothing 229 230 earlyDataExtension rtt0 231 | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing) 232 | otherwise = return Nothing 233 234 cookieExtension = do 235 mcookie <- usingState_ ctx getTLS13Cookie 236 case mcookie of 237 Nothing -> return Nothing 238 Just cookie -> return $ Just $ toExtensionRaw cookie 239 240 postHandshakeAuthExtension 241 | ctxQUICMode ctx = return Nothing 242 | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth 243 | otherwise = return Nothing 244 245 adjustExtentions pskInfo exts ch = 246 case pskInfo of 247 Nothing -> return exts 248 Just (_, sdata, choice, _) -> do 249 let psk = sessionSecret sdata 250 earlySecret = initEarlySecret choice (Just psk) 251 usingHState ctx $ setTLS13EarlySecret earlySecret 252 let ech = encodeHandshake ch 253 h = cHash choice 254 siz = hashDigestSize h 255 binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech) 256 let exts' = init exts ++ [adjust (last exts)] 257 adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders 258 where 259 withBinders = replacePSKBinder withoutBinders binder 260 return exts' 261 262 generateClientHelloParams = 263 case mparams of 264 -- Client random and session in the second client hello for 265 -- retry must be the same as the first one. 266 Just (crand, clientSession, _) -> return (crand, clientSession) 267 Nothing -> do 268 crand <- clientRandom ctx 269 let paramSession = case clientWantSessionResume cparams of 270 Nothing -> Session Nothing 271 Just (sid, sdata) 272 | sessionVersion sdata >= TLS13 -> Session Nothing 273 | ems == RequireEMS && noSessionEMS -> Session Nothing 274 | otherwise -> Session (Just sid) 275 where noSessionEMS = SessionEMS `notElem` sessionFlags sdata 276 -- In compatibility mode a client not offering a pre-TLS 1.3 277 -- session MUST generate a new 32-byte value 278 if tls13 && paramSession == Session Nothing && not (ctxQUICMode ctx) 279 then do 280 randomSession <- newSession ctx 281 return (crand, randomSession) 282 else return (crand, paramSession) 283 284 sendClientHello clientSession crand = do 285 let ver = if tls13 then TLS12 else highestVer 286 hrr <- usingState_ ctx getTLS13HRR 287 unless hrr $ startHandshake ctx ver crand 288 usingState_ ctx $ setVersionIfUnset highestVer 289 let cipherIds = map cipherID ciphers 290 compIds = map compressionID compressions 291 mkClientHello exts = ClientHello ver crand clientSession cipherIds compIds exts Nothing 292 pskInfo <- getPskInfo 293 let rtt0info = pskInfo >>= get0RTTinfo 294 rtt0 = isJust rtt0info 295 extensions0 <- catMaybes <$> getExtensions pskInfo rtt0 296 let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0 297 extensions <- adjustExtentions pskInfo extensions1 $ mkClientHello extensions1 298 sendPacket ctx $ Handshake [mkClientHello extensions] 299 mEarlySecInfo <- case rtt0info of 300 Nothing -> return Nothing 301 Just info -> Just <$> send0RTT info 302 unless hrr $ contextSync ctx $ SendClientHello mEarlySecInfo 303 return (rtt0, map (\(ExtensionRaw i _) -> i) extensions) 304 305 get0RTTinfo (_, sdata, choice, _) = do 306 earlyData <- clientEarlyData cparams 307 guard (B.length earlyData <= sessionMaxEarlyDataSize sdata) 308 return (choice, earlyData) 309 310 send0RTT (choice, earlyData) = do 311 let usedCipher = cCipher choice 312 usedHash = cHash choice 313 Just earlySecret <- usingHState ctx getTLS13EarlySecret 314 -- Client hello is stored in hstHandshakeDigest 315 -- But HandshakeDigestContext is not created yet. 316 earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) False 317 let clientEarlySecret = pairClient earlyKey 318 unless (ctxQUICMode ctx) $ do 319 runPacketFlight ctx $ sendChangeCipherSpec13 ctx 320 setTxState ctx usedHash usedCipher clientEarlySecret 321 let len = ctxFragmentSize ctx 322 mapChunks_ len (sendPacket13 ctx . AppData13) earlyData 323 -- We set RTT0Sent even in quicMode 324 usingHState ctx $ setTLS13RTT0Status RTT0Sent 325 return $ EarlySecretInfo usedCipher clientEarlySecret 326 327 recvServerHello clientSession sentExts = runRecvState ctx recvState 328 where recvState = RecvStateNext $ \p -> 329 case p of 330 Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams clientSession sentExts) hs -- this adds SH to hstHandshakeMessages 331 Alert a -> 332 case a of 333 [(AlertLevel_Warning, UnrecognizedName)] -> 334 if clientUseServerNameIndication cparams 335 then return recvState 336 else throwAlert a 337 _ -> throwAlert a 338 _ -> unexpected (show p) (Just "handshake") 339 throwAlert a = throwCore $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure) 340 341-- | Store the keypair and check that it is compatible with the current protocol 342-- version and a list of 'CertificateType' values. 343storePrivInfoClient :: Context 344 -> [CertificateType] 345 -> Credential 346 -> IO () 347storePrivInfoClient ctx cTypes (cc, privkey) = do 348 pubkey <- storePrivInfo ctx cc privkey 349 unless (certificateCompatible pubkey cTypes) $ 350 throwCore $ Error_Protocol 351 ( pubkeyType pubkey ++ " credential does not match allowed certificate types" 352 , True 353 , InternalError ) 354 ver <- usingState_ ctx getVersion 355 unless (pubkey `versionCompatible` ver) $ 356 throwCore $ Error_Protocol 357 ( pubkeyType pubkey ++ " credential is not supported at version " ++ show ver 358 , True 359 , InternalError ) 360 361-- | When the server requests a client certificate, we try to 362-- obtain a suitable certificate chain and private key via the 363-- callback in the client parameters. It is OK for the callback 364-- to return an empty chain, in many cases the client certificate 365-- is optional. If the client wishes to abort the handshake for 366-- lack of a suitable certificate, it can throw an exception in 367-- the callback. 368-- 369-- The return value is 'Nothing' when no @CertificateRequest@ was 370-- received and no @Certificate@ message needs to be sent. An empty 371-- chain means that an empty @Certificate@ message needs to be sent 372-- to the server, naturally without a @CertificateVerify@. A non-empty 373-- 'CertificateChain' is the chain to send to the server along with 374-- a corresponding 'CertificateVerify'. 375-- 376-- With TLS < 1.2 the server's @CertificateRequest@ does not carry 377-- a signature algorithm list. It has a list of supported public 378-- key signing algorithms in the @certificate_types@ field. The 379-- hash is implicit. It is 'SHA1' for DSS and 'SHA1_MD5' for RSA. 380-- 381-- With TLS == 1.2 the server's @CertificateRequest@ always has a 382-- @supported_signature_algorithms@ list, as a fixed component of 383-- the structure. This list is (wrongly) overloaded to also limit 384-- X.509 signatures in the client's certificate chain. The BCP 385-- strategy is to find a compatible chain if possible, but else 386-- ignore the constraint, and let the server verify the chain as it 387-- sees fit. The @supported_signature_algorithms@ field is only 388-- obligatory with respect to signatures on TLS messages, in this 389-- case the @CertificateVerify@ message. The @certificate_types@ 390-- field is still included. 391-- 392-- With TLS 1.3 the server's @CertificateRequest@ has a mandatory 393-- @signature_algorithms@ extension, the @signature_algorithms_cert@ 394-- extension, which is optional, carries a list of algorithms the 395-- server promises to support in verifying the certificate chain. 396-- As with TLS 1.2, the client's makes a /best-effort/ to deliver 397-- a compatible certificate chain where all the CA signatures are 398-- known to be supported, but it should not abort the connection 399-- just because the chain might not work out, just send the best 400-- chain you have and let the server worry about the rest. The 401-- supported public key algorithms are now inferred from the 402-- @signature_algorithms@ extension and @certificate_types@ is 403-- gone. 404-- 405-- With TLS 1.3, we synthesize and store a @certificate_types@ 406-- field at the time that the server's @CertificateRequest@ 407-- message is received. This is then present across all the 408-- protocol versions, and can be used to determine whether 409-- a @CertificateRequest@ was received or not. 410-- 411-- If @signature_algorithms@ is 'Nothing', then we're doing 412-- TLS 1.0 or 1.1. The @signature_algorithms_cert@ extension 413-- is optional in TLS 1.3, and so the application callback 414-- will not be able to distinguish between TLS 1.[01] and 415-- TLS 1.3 with no certificate algorithm hints, but this 416-- just simplifies the chain selection process, all CA 417-- signatures are OK. 418-- 419clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain) 420clientChain cparams ctx = 421 usingHState ctx getCertReqCBdata >>= \case 422 Nothing -> return Nothing 423 Just cbdata -> do 424 let callback = onCertificateRequest $ clientHooks cparams 425 chain <- liftIO $ callback cbdata `catchException` 426 throwMiscErrorOnException "certificate request callback failed" 427 case chain of 428 Nothing 429 -> return $ Just $ CertificateChain [] 430 Just (CertificateChain [], _) 431 -> return $ Just $ CertificateChain [] 432 Just cred@(cc, _) 433 -> do 434 let (cTypes, _, _) = cbdata 435 storePrivInfoClient ctx cTypes cred 436 return $ Just cc 437 438-- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with 439-- the local key and server's signature algorithms (both already saved). Must 440-- only be called for TLS versions 1.2 and up, with compatibility function 441-- 'signatureCompatible' or 'signatureCompatible13' based on version. 442-- 443-- The values in the server's @signature_algorithms@ extension are 444-- in descending order of preference. However here the algorithms 445-- are selected by client preference in @cHashSigs@. 446-- 447getLocalHashSigAlg :: Context 448 -> (PubKey -> HashAndSignatureAlgorithm -> Bool) 449 -> [HashAndSignatureAlgorithm] 450 -> PubKey 451 -> IO HashAndSignatureAlgorithm 452getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do 453 -- Must be present with TLS 1.2 and up. 454 (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata 455 let want = (&&) <$> isCompatible pubKey 456 <*> flip elem hashSigs 457 case find want cHashSigs of 458 Just best -> return best 459 Nothing -> throwCore $ Error_Protocol 460 ( keyerr pubKey 461 , True 462 , HandshakeFailure 463 ) 464 where 465 keyerr k = "no " ++ pubkeyType k ++ " hash algorithm in common with the server" 466 467-- | Return the supported 'CertificateType' values that are 468-- compatible with at least one supported signature algorithm. 469-- 470supportedCtypes :: [HashAndSignatureAlgorithm] 471 -> [CertificateType] 472supportedCtypes hashAlgs = 473 nub $ foldr ctfilter [] hashAlgs 474 where 475 ctfilter x acc = case hashSigToCertType x of 476 Just cType | cType <= lastSupportedCertificateType 477 -> cType : acc 478 _ -> acc 479-- 480clientSupportedCtypes :: Context 481 -> [CertificateType] 482clientSupportedCtypes ctx = 483 supportedCtypes $ supportedHashSignatures $ ctxSupported ctx 484-- 485sigAlgsToCertTypes :: Context 486 -> [HashAndSignatureAlgorithm] 487 -> [CertificateType] 488sigAlgsToCertTypes ctx hashSigs = 489 filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx 490 491-- | TLS 1.2 and below. Send the client handshake messages that 492-- follow the @ServerHello@, etc. except for @CCS@ and @Finished@. 493-- 494-- XXX: Is any buffering done here to combined these messages into 495-- a single TCP packet? Otherwise we're prone to Nagle delays, or 496-- in any case needlessly generate multiple small packets, where 497-- a single larger packet will do. The TLS 1.3 code path seems 498-- to separating record generation and transmission and sending 499-- multiple records in a single packet. 500-- 501-- -> [certificate] 502-- -> client key exchange 503-- -> [cert verify] 504sendClientData :: ClientParams -> Context -> IO () 505sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify 506 where 507 sendCertificate = do 508 usingHState ctx $ setClientCertSent False 509 clientChain cparams ctx >>= \case 510 Nothing -> return () 511 Just cc@(CertificateChain certs) -> do 512 unless (null certs) $ 513 usingHState ctx $ setClientCertSent True 514 sendPacket ctx $ Handshake [Certificates cc] 515 516 sendClientKeyXchg = do 517 cipher <- usingHState ctx getPendingCipher 518 (ckx, setMasterSec) <- case cipherKeyExchange cipher of 519 CipherKeyExchange_RSA -> do 520 clientVersion <- usingHState ctx $ gets hstClientVersion 521 (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 522 523 let premaster = encodePreMasterSecret clientVersion prerand 524 setMasterSec = setMasterSecretFromPre xver ClientRole premaster 525 encryptedPreMaster <- do 526 -- SSL3 implementation generally forget this length field since it's redundant, 527 -- however TLS10 make it clear that the length field need to be present. 528 e <- encryptRSA ctx premaster 529 let extra = if xver < TLS10 530 then B.empty 531 else encodeWord16 $ fromIntegral $ B.length e 532 return $ extra `B.append` e 533 return (CKX_RSA encryptedPreMaster, setMasterSec) 534 CipherKeyExchange_DHE_RSA -> getCKX_DHE 535 CipherKeyExchange_DHE_DSS -> getCKX_DHE 536 CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE 537 CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE 538 _ -> throwCore $ Error_Protocol ("client key exchange unsupported type", True, HandshakeFailure) 539 sendPacket ctx $ Handshake [ClientKeyXchg ckx] 540 masterSecret <- usingHState ctx setMasterSec 541 logKey ctx (MasterSecret masterSecret) 542 where getCKX_DHE = do 543 xver <- usingState_ ctx getVersion 544 serverParams <- usingHState ctx getServerDHParams 545 546 let params = serverDHParamsToParams serverParams 547 ffGroup = findFiniteFieldGroup params 548 srvpub = serverDHParamsToPublic serverParams 549 550 unless (maybe False (isSupportedGroup ctx) ffGroup) $ do 551 groupUsage <- onCustomFFDHEGroup (clientHooks cparams) params srvpub `catchException` 552 throwMiscErrorOnException "custom group callback failed" 553 case groupUsage of 554 GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity) 555 GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure) 556 GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, IllegalParameter) 557 GroupUsageValid -> return () 558 559 -- When grp is known but not in the supported list we use it 560 -- anyway. This provides additional validation and a more 561 -- efficient implementation. 562 (clientDHPub, premaster) <- 563 case ffGroup of 564 Nothing -> do 565 (clientDHPriv, clientDHPub) <- generateDHE ctx params 566 let premaster = dhGetShared params clientDHPriv srvpub 567 return (clientDHPub, premaster) 568 Just grp -> do 569 usingHState ctx $ setNegotiatedGroup grp 570 dhePair <- generateFFDHEShared ctx grp srvpub 571 case dhePair of 572 Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) 573 Just pair -> return pair 574 575 let setMasterSec = setMasterSecretFromPre xver ClientRole premaster 576 return (CKX_DH clientDHPub, setMasterSec) 577 578 getCKX_ECDHE = do 579 ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams 580 checkSupportedGroup ctx grp 581 usingHState ctx $ setNegotiatedGroup grp 582 ecdhePair <- generateECDHEShared ctx srvpub 583 case ecdhePair of 584 Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) 585 Just (clipub, premaster) -> do 586 xver <- usingState_ ctx getVersion 587 let setMasterSec = setMasterSecretFromPre xver ClientRole premaster 588 return (CKX_ECDH $ encodeGroupPublic clipub, setMasterSec) 589 590 -- In order to send a proper certificate verify message, 591 -- we have to do the following: 592 -- 593 -- 1. Determine which signing algorithm(s) the server supports 594 -- (we currently only support RSA). 595 -- 2. Get the current handshake hash from the handshake state. 596 -- 3. Sign the handshake hash 597 -- 4. Send it to the server. 598 -- 599 sendCertificateVerify = do 600 ver <- usingState_ ctx getVersion 601 602 -- Only send a certificate verify message when we 603 -- have sent a non-empty list of certificates. 604 -- 605 certSent <- usingHState ctx getClientCertSent 606 when certSent $ do 607 pubKey <- getLocalPublicKey ctx 608 mhashSig <- case ver of 609 TLS12 -> 610 let cHashSigs = supportedHashSignatures $ ctxSupported ctx 611 in Just <$> getLocalHashSigAlg ctx signatureCompatible cHashSigs pubKey 612 _ -> return Nothing 613 614 -- Fetch all handshake messages up to now. 615 msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages 616 sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs 617 sendPacket ctx $ Handshake [CertVerify sigDig] 618 619processServerExtension :: ExtensionRaw -> TLSSt () 620processServerExtension (ExtensionRaw extID content) 621 | extID == extensionID_SecureRenegotiation = do 622 cv <- getVerifiedData ClientRole 623 sv <- getVerifiedData ServerRole 624 let bs = extensionEncode (SecureRenegotiation cv $ Just sv) 625 unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure) 626 | extID == extensionID_SupportedVersions = case extensionDecode MsgTServerHello content of 627 Just (SupportedVersionsServerHello ver) -> setVersion ver 628 _ -> return () 629 | extID == extensionID_KeyShare = do 630 hrr <- getTLS13HRR 631 let msgt = if hrr then MsgTHelloRetryRequest else MsgTServerHello 632 setTLS13KeyShare $ extensionDecode msgt content 633 | extID == extensionID_PreSharedKey = 634 setTLS13PreSharedKey $ extensionDecode MsgTServerHello content 635processServerExtension _ = return () 636 637throwMiscErrorOnException :: String -> SomeException -> IO a 638throwMiscErrorOnException msg e = 639 throwCore $ Error_Misc $ msg ++ ": " ++ show e 640 641-- | onServerHello process the ServerHello message on the client. 642-- 643-- 1) check the version chosen by the server is one allowed by parameters. 644-- 2) check that our compression and cipher algorithms are part of the list we sent 645-- 3) check extensions received are part of the one we sent 646-- 4) process the session parameter to see if the server want to start a new session or can resume 647-- 5) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher 648-- 649onServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO) 650onServerHello ctx cparams clientSession sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do 651 when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) 652 -- find the compression and cipher methods that the server want to use. 653 cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of 654 Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, IllegalParameter) 655 Just alg -> return alg 656 compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of 657 Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, IllegalParameter) 658 Just alg -> return alg 659 660 -- intersect sent extensions in client and the received extensions from server. 661 -- if server returns extensions that we didn't request, fail. 662 let checkExt (ExtensionRaw i _) 663 | i == extensionID_Cookie = False -- for HRR 664 | otherwise = i `notElem` sentExts 665 when (any checkExt exts) $ 666 throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension) 667 668 let resumingSession = 669 case clientWantSessionResume cparams of 670 Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing 671 Nothing -> Nothing 672 isHRR = isHelloRetryRequest serverRan 673 usingState_ ctx $ do 674 setTLS13HRR isHRR 675 setTLS13Cookie (guard isHRR >> extensionLookup extensionID_Cookie exts >>= extensionDecode MsgTServerHello) 676 setSession serverSession (isJust resumingSession) 677 setVersion rver -- must be before processing supportedVersions ext 678 mapM_ processServerExtension exts 679 680 setALPN ctx MsgTServerHello exts 681 682 ver <- usingState_ ctx getVersion 683 684 -- Some servers set TLS 1.2 as the legacy server hello version, and TLS 1.3 685 -- in the supported_versions extension, *AND ALSO* set the TLS 1.2 686 -- downgrade signal in the server random. If we support TLS 1.3 and 687 -- actually negotiate TLS 1.3, we must ignore the server random downgrade 688 -- signal. Therefore, 'isDowngraded' needs to take into account the 689 -- negotiated version and the server random, as well as the list of 690 -- client-side enabled protocol versions. 691 -- 692 when (isDowngraded ver (supportedVersions $ clientSupported cparams) serverRan) $ 693 throwCore $ Error_Protocol ("version downgrade detected", True, IllegalParameter) 694 695 case find (== ver) (supportedVersions $ ctxSupported ctx) of 696 Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported", True, ProtocolVersion) 697 Just _ -> return () 698 if ver > TLS12 then do 699 when (serverSession /= clientSession) $ 700 throwCore $ Error_Protocol ("received mismatched legacy session", True, IllegalParameter) 701 established <- ctxEstablished ctx 702 eof <- ctxEOF ctx 703 when (established == Established && not eof) $ 704 throwCore $ Error_Protocol ("renegotiation to TLS 1.3 or later is not allowed", True, ProtocolVersion) 705 ensureNullCompression compression 706 failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg 707 return RecvStateDone 708 else do 709 ems <- processExtendedMasterSec ctx ver MsgTServerHello exts 710 usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg 711 case resumingSession of 712 Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx) 713 Just sessionData -> do 714 let emsSession = SessionEMS `elem` sessionFlags sessionData 715 when (ems /= emsSession) $ 716 let err = "server resumes a session which is not EMS consistent" 717 in throwCore $ Error_Protocol (err, True, HandshakeFailure) 718 let masterSecret = sessionSecret sessionData 719 usingHState ctx $ setMasterSecret rver ClientRole masterSecret 720 logKey ctx (MasterSecret masterSecret) 721 return $ RecvStateNext expectChangeCipher 722onServerHello _ _ _ _ p = unexpected (show p) (Just "server hello") 723 724processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) 725processCertificate cparams ctx (Certificates certs) = do 726 when (isNullCertificateChain certs) $ 727 throwCore $ Error_Protocol ("server certificate missing", True, DecodeError) 728 -- run certificate recv hook 729 ctxWithHooks ctx (`hookRecvCertificates` certs) 730 -- then run certificate validation 731 usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException 732 case usage of 733 CertificateUsageAccept -> checkLeafCertificateKeyUsage 734 CertificateUsageReject reason -> certificateRejected reason 735 return $ RecvStateHandshake (processServerKeyExchange ctx) 736 where shared = clientShared cparams 737 checkCert = onServerCertificate (clientHooks cparams) (sharedCAStore shared) 738 (sharedValidationCache shared) 739 (clientServerIdentification cparams) 740 certs 741 -- also verify that the certificate optional key usage is compatible 742 -- with the intended key-exchange. This check is not delegated to 743 -- x509-validation 'checkLeafKeyUsage' because it depends on negotiated 744 -- cipher, which is not available from onServerCertificate parameters. 745 -- Additionally, with only one shared ValidationCache, x509-validation 746 -- would cache validation result based on a key usage and reuse it with 747 -- another key usage. 748 checkLeafCertificateKeyUsage = do 749 cipher <- usingHState ctx getPendingCipher 750 case requiredCertKeyUsage cipher of 751 [] -> return () 752 flags -> verifyLeafKeyUsage flags certs 753 754processCertificate _ ctx p = processServerKeyExchange ctx p 755 756expectChangeCipher :: Packet -> IO (RecvState IO) 757expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish 758expectChangeCipher p = unexpected (show p) (Just "change cipher") 759 760expectFinish :: Handshake -> IO (RecvState IO) 761expectFinish (Finished _) = return RecvStateDone 762expectFinish p = unexpected (show p) (Just "Handshake Finished") 763 764processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO) 765processServerKeyExchange ctx (ServerKeyXchg origSkx) = do 766 cipher <- usingHState ctx getPendingCipher 767 processWithCipher cipher origSkx 768 return $ RecvStateHandshake (processCertificateRequest ctx) 769 where processWithCipher cipher skx = 770 case (cipherKeyExchange cipher, skx) of 771 (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) -> 772 doDHESignature dhparams signature KX_RSA 773 (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> 774 doDHESignature dhparams signature KX_DSS 775 (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> 776 doECDHESignature ecdhparams signature KX_RSA 777 (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) -> 778 doECDHESignature ecdhparams signature KX_ECDSA 779 (cke, SKX_Unparsed bytes) -> do 780 ver <- usingState_ ctx getVersion 781 case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of 782 Left _ -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show cke, True, HandshakeFailure) 783 Right realSkx -> processWithCipher cipher realSkx 784 -- we need to resolve the result. and recall processWithCipher .. 785 (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure) 786 doDHESignature dhparams signature kxsAlg = do 787 -- FF group selected by the server is verified when generating CKX 788 publicKey <- getSignaturePublicKey kxsAlg 789 verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature 790 unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams) 791 usingHState ctx $ setServerDHParams dhparams 792 793 doECDHESignature ecdhparams signature kxsAlg = do 794 -- EC group selected by the server is verified when generating CKX 795 publicKey <- getSignaturePublicKey kxsAlg 796 verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature 797 unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams") 798 usingHState ctx $ setServerECDHParams ecdhparams 799 800 getSignaturePublicKey kxsAlg = do 801 publicKey <- usingHState ctx getRemotePublicKey 802 unless (isKeyExchangeSignatureKey kxsAlg publicKey) $ 803 throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure) 804 ver <- usingState_ ctx getVersion 805 unless (publicKey `versionCompatible` ver) $ 806 throwCore $ Error_Protocol (show ver ++ " has no support for " ++ pubkeyType publicKey, True, IllegalParameter) 807 let groups = supportedGroups (ctxSupported ctx) 808 unless (satisfiesEcPredicate (`elem` groups) publicKey) $ 809 throwCore $ Error_Protocol ("server public key has unsupported elliptic curve", True, IllegalParameter) 810 return publicKey 811 812processServerKeyExchange ctx p = processCertificateRequest ctx p 813 814processCertificateRequest :: Context -> Handshake -> IO (RecvState IO) 815processCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do 816 ver <- usingState_ ctx getVersion 817 when (ver == TLS12 && isNothing sigAlgs) $ 818 throwCore $ Error_Protocol 819 ( "missing TLS 1.2 certificate request signature algorithms" 820 , True 821 , InternalError 822 ) 823 let cTypes = filter (<= lastSupportedCertificateType) cTypesSent 824 usingHState ctx $ setCertReqCBdata $ Just (cTypes, sigAlgs, dNames) 825 return $ RecvStateHandshake (processServerHelloDone ctx) 826processCertificateRequest ctx p = do 827 usingHState ctx $ setCertReqCBdata Nothing 828 processServerHelloDone ctx p 829 830processServerHelloDone :: Context -> Handshake -> IO (RecvState m) 831processServerHelloDone _ ServerHelloDone = return RecvStateDone 832processServerHelloDone _ p = unexpected (show p) (Just "server hello data") 833 834-- Unless result is empty, server certificate must be allowed for at least one 835-- of the returned values. Constraints for RSA-based key exchange are relaxed 836-- to avoid rejecting certificates having incomplete extension. 837requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag] 838requiredCertKeyUsage cipher = 839 case cipherKeyExchange cipher of 840 CipherKeyExchange_RSA -> rsaCompatibility 841 CipherKeyExchange_DH_Anon -> [] -- unrestricted 842 CipherKeyExchange_DHE_RSA -> rsaCompatibility 843 CipherKeyExchange_ECDHE_RSA -> rsaCompatibility 844 CipherKeyExchange_DHE_DSS -> [ KeyUsage_digitalSignature ] 845 CipherKeyExchange_DH_DSS -> [ KeyUsage_keyAgreement ] 846 CipherKeyExchange_DH_RSA -> rsaCompatibility 847 CipherKeyExchange_ECDH_ECDSA -> [ KeyUsage_keyAgreement ] 848 CipherKeyExchange_ECDH_RSA -> rsaCompatibility 849 CipherKeyExchange_ECDHE_ECDSA -> [ KeyUsage_digitalSignature ] 850 CipherKeyExchange_TLS13 -> [ KeyUsage_digitalSignature ] 851 where rsaCompatibility = [ KeyUsage_digitalSignature 852 , KeyUsage_keyEncipherment 853 , KeyUsage_keyAgreement 854 ] 855 856handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO () 857handshakeClient13 cparams ctx groupSent = do 858 choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher 859 handshakeClient13' cparams ctx groupSent choice 860 861handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO () 862handshakeClient13' cparams ctx groupSent choice = do 863 (_, hkey, resuming) <- switchToHandshakeSecret 864 let handshakeSecret = triBase hkey 865 clientHandshakeSecret = triClient hkey 866 serverHandshakeSecret = triServer hkey 867 handSecInfo = HandshakeSecretInfo usedCipher (clientHandshakeSecret,serverHandshakeSecret) 868 contextSync ctx $ RecvServerHello handSecInfo 869 (rtt0accepted,eexts) <- runRecvHandshake13 $ do 870 accext <- recvHandshake13 ctx expectEncryptedExtensions 871 unless resuming $ recvHandshake13 ctx expectCertRequest 872 recvHandshake13hash ctx $ expectFinished serverHandshakeSecret 873 return accext 874 hChSf <- transcriptHash ctx 875 unless (ctxQUICMode ctx) $ 876 runPacketFlight ctx $ sendChangeCipherSpec13 ctx 877 when (rtt0accepted && not (ctxQUICMode ctx)) $ 878 sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) 879 setTxState ctx usedHash usedCipher clientHandshakeSecret 880 sendClientFlight13 cparams ctx usedHash clientHandshakeSecret 881 appKey <- switchToApplicationSecret handshakeSecret hChSf 882 let applicationSecret = triBase appKey 883 setResumptionSecret applicationSecret 884 let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey) 885 contextSync ctx $ SendClientFinished eexts appSecInfo 886 handshakeTerminate13 ctx 887 where 888 usedCipher = cCipher choice 889 usedHash = cHash choice 890 891 hashSize = hashDigestSize usedHash 892 893 switchToHandshakeSecret = do 894 ensureRecvComplete ctx 895 ecdhe <- calcSharedKey 896 (earlySecret, resuming) <- makeEarlySecret 897 handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe 898 let serverHandshakeSecret = triServer handKey 899 setRxState ctx usedHash usedCipher serverHandshakeSecret 900 return (usedCipher, handKey, resuming) 901 902 switchToApplicationSecret handshakeSecret hChSf = do 903 ensureRecvComplete ctx 904 appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf 905 let serverApplicationSecret0 = triServer appKey 906 let clientApplicationSecret0 = triClient appKey 907 setTxState ctx usedHash usedCipher clientApplicationSecret0 908 setRxState ctx usedHash usedCipher serverApplicationSecret0 909 return appKey 910 911 calcSharedKey = do 912 serverKeyShare <- do 913 mks <- usingState_ ctx getTLS13KeyShare 914 case mks of 915 Just (KeyShareServerHello ks) -> return ks 916 Just _ -> error "calcSharedKey: invalid KeyShare value" 917 Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure) 918 let grp = keyShareEntryGroup serverKeyShare 919 unless (groupSent == Just grp) $ 920 throwCore $ Error_Protocol ("received incompatible group for (EC)DHE", True, IllegalParameter) 921 usingHState ctx $ setNegotiatedGroup grp 922 usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare 923 924 makeEarlySecret = do 925 mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret 926 case mEarlySecretPSK of 927 Nothing -> return (initEarlySecret choice Nothing, False) 928 Just earlySecretPSK@(BaseSecret sec) -> do 929 mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey 930 case mSelectedIdentity of 931 Nothing -> 932 return (initEarlySecret choice Nothing, False) 933 Just (PreSharedKeyServerHello 0) -> do 934 unless (B.length sec == hashSize) $ 935 throwCore $ Error_Protocol ("selected cipher is incompatible with selected PSK", True, IllegalParameter) 936 usingHState ctx $ setTLS13HandshakeMode PreSharedKey 937 return (earlySecretPSK, True) 938 Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter) 939 940 expectEncryptedExtensions (EncryptedExtensions13 eexts) = do 941 liftIO $ setALPN ctx MsgTEncryptedExtensions eexts 942 st <- usingHState ctx getTLS13RTT0Status 943 if st == RTT0Sent then 944 case extensionLookup extensionID_EarlyData eexts of 945 Just _ -> do 946 usingHState ctx $ setTLS13HandshakeMode RTT0 947 usingHState ctx $ setTLS13RTT0Status RTT0Accepted 948 return (True,eexts) 949 Nothing -> do 950 usingHState ctx $ setTLS13HandshakeMode RTT0 951 usingHState ctx $ setTLS13RTT0Status RTT0Rejected 952 return (False,eexts) 953 else 954 return (False,eexts) 955 expectEncryptedExtensions p = unexpected (show p) (Just "encrypted extensions") 956 957 expectCertRequest (CertRequest13 token exts) = do 958 processCertRequest13 ctx token exts 959 recvHandshake13 ctx expectCertAndVerify 960 961 expectCertRequest other = do 962 usingHState ctx $ do 963 setCertReqToken Nothing 964 setCertReqCBdata Nothing 965 -- setCertReqSigAlgsCert Nothing 966 expectCertAndVerify other 967 968 expectCertAndVerify (Certificate13 _ cc _) = do 969 _ <- liftIO $ processCertificate cparams ctx (Certificates cc) 970 let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc 971 ver <- liftIO $ usingState_ ctx getVersion 972 checkDigitalSignatureKey ver pubkey 973 usingHState ctx $ setPublicKey pubkey 974 recvHandshake13hash ctx $ expectCertVerify pubkey 975 expectCertAndVerify p = unexpected (show p) (Just "server certificate") 976 977 expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do 978 ok <- checkCertVerify ctx pubkey sigAlg sig hChSc 979 unless ok $ decryptError "cannot verify CertificateVerify" 980 expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify") 981 982 expectFinished (ServerTrafficSecret baseKey) hashValue (Finished13 verifyData) = 983 checkFinished usedHash baseKey hashValue verifyData 984 expectFinished _ _ p = unexpected (show p) (Just "server finished") 985 986 setResumptionSecret applicationSecret = do 987 resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret 988 usingHState ctx $ setTLS13ResumptionSecret resumptionSecret 989 990processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m () 991processCertRequest13 ctx token exts = do 992 let hsextID = extensionID_SignatureAlgorithms 993 -- caextID = extensionID_SignatureAlgorithmsCert 994 dNames <- canames 995 -- The @signature_algorithms@ extension is mandatory. 996 hsAlgs <- extalgs hsextID unsighash 997 cTypes <- case hsAlgs of 998 Just as -> 999 let validAs = filter isHashSignatureValid13 as 1000 in return $ sigAlgsToCertTypes ctx validAs 1001 Nothing -> throwCore $ Error_Protocol 1002 ( "invalid certificate request" 1003 , True 1004 , HandshakeFailure ) 1005 -- Unused: 1006 -- caAlgs <- extalgs caextID uncertsig 1007 usingHState ctx $ do 1008 setCertReqToken $ Just token 1009 setCertReqCBdata $ Just (cTypes, hsAlgs, dNames) 1010 -- setCertReqSigAlgsCert caAlgs 1011 where 1012 canames = case extensionLookup 1013 extensionID_CertificateAuthorities exts of 1014 Nothing -> return [] 1015 Just ext -> case extensionDecode MsgTCertificateRequest ext of 1016 Just (CertificateAuthorities names) -> return names 1017 _ -> throwCore $ Error_Protocol 1018 ( "invalid certificate request" 1019 , True 1020 , HandshakeFailure ) 1021 extalgs extID decons = case extensionLookup extID exts of 1022 Nothing -> return Nothing 1023 Just ext -> case extensionDecode MsgTCertificateRequest ext of 1024 Just e 1025 -> return $ decons e 1026 _ -> throwCore $ Error_Protocol 1027 ( "invalid certificate request" 1028 , True 1029 , HandshakeFailure ) 1030 unsighash :: SignatureAlgorithms 1031 -> Maybe [HashAndSignatureAlgorithm] 1032 unsighash (SignatureAlgorithms a) = Just a 1033 {- Unused for now 1034 uncertsig :: SignatureAlgorithmsCert 1035 -> Maybe [HashAndSignatureAlgorithm] 1036 uncertsig (SignatureAlgorithmsCert a) = Just a 1037 -} 1038 1039sendClientFlight13 :: ClientParams -> Context -> Hash -> ClientTrafficSecret a -> IO () 1040sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret baseKey) = do 1041 chain <- clientChain cparams ctx 1042 runPacketFlight ctx $ do 1043 case chain of 1044 Nothing -> return () 1045 Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc 1046 rawFinished <- makeFinished ctx usedHash baseKey 1047 loadPacket13 ctx $ Handshake13 [rawFinished] 1048 where 1049 sendClientData13 chain (Just token) = do 1050 let (CertificateChain certs) = chain 1051 certExts = replicate (length certs) [] 1052 cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx 1053 loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts] 1054 case certs of 1055 [] -> return () 1056 _ -> do 1057 hChSc <- transcriptHash ctx 1058 pubKey <- getLocalPublicKey ctx 1059 sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey 1060 vfy <- makeCertVerify ctx pubKey sigAlg hChSc 1061 loadPacket13 ctx $ Handshake13 [vfy] 1062 -- 1063 sendClientData13 _ _ = 1064 throwCore $ Error_Protocol 1065 ( "missing TLS 1.3 certificate request context token" 1066 , True 1067 , InternalError 1068 ) 1069 1070setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO () 1071setALPN ctx msgt exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode msgt of 1072 Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do 1073 mprotos <- getClientALPNSuggest 1074 case mprotos of 1075 Just protos -> when (proto `elem` protos) $ do 1076 setExtensionALPN True 1077 setNegotiatedProtocol proto 1078 _ -> return () 1079 _ -> return () 1080 1081postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO () 1082postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) = 1083 bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do 1084 processHandshake13 ctx h 1085 processCertRequest13 ctx certReqCtx exts 1086 (usedHash, _, level, applicationSecretN) <- getTxState ctx 1087 unless (level == CryptApplicationSecret) $ 1088 throwCore $ Error_Protocol ("unexpected post-handshake authentication request", True, UnexpectedMessage) 1089 sendClientFlight13 cparams ctx usedHash (ClientTrafficSecret applicationSecretN) 1090 1091postHandshakeAuthClientWith _ _ _ = 1092 throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthClientWith", True, UnexpectedMessage) 1093 1094contextSync :: Context -> ClientState -> IO () 1095contextSync ctx ctl = case ctxHandshakeSync ctx of 1096 HandshakeSync sync _ -> sync ctx ctl 1097