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