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