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