{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Network.TLS.Handshake.Client -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unknown -- module Network.TLS.Handshake.Client ( handshakeClient , handshakeClientWith , postHandshakeAuthClientWith ) where import Network.TLS.Crypto import Network.TLS.Context.Internal import Network.TLS.Parameters import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Credentials import Network.TLS.Packet hiding (getExtensions) import Network.TLS.ErrT import Network.TLS.Extension import Network.TLS.IO import Network.TLS.Imports import Network.TLS.State import Network.TLS.Measurement import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_) import Network.TLS.Types import Network.TLS.X509 import qualified Data.ByteString as B import Data.X509 (ExtKeyUsageFlag(..)) import Control.Monad.State.Strict import Control.Exception (SomeException, bracket) import Network.TLS.Handshake.Common import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Process import Network.TLS.Handshake.Certificate import Network.TLS.Handshake.Signature import Network.TLS.Handshake.Key import Network.TLS.Handshake.Random import Network.TLS.Handshake.State import Network.TLS.Handshake.State13 import Network.TLS.Wire handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx handshakeClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeClientWith", True, HandshakeFailure) -- client part of handshake. send a bunch of handshake of client -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do let groups = case clientWantSessionResume cparams of Nothing -> groupsSupported Just (_, sdata) -> case sessionGroup sdata of Nothing -> [] -- TLS 1.2 or earlier Just grp -> grp : filter (/= grp) groupsSupported groupsSupported = supportedGroups (ctxSupported ctx) handshakeClient' cparams ctx groups Nothing -- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: -- "The client will also send a -- ClientHello when the server has responded to its ClientHello with a -- HelloRetryRequest. In that case, the client MUST send the same -- ClientHello without modification, except as follows:" -- -- So, the ClientRandom in the first client hello is necessary. handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe (ClientRandom, Session, Version) -> IO () handshakeClient' cparams ctx groups mparams = do updateMeasure ctx incrementNbHandshakes (crand, clientSession) <- generateClientHelloParams (rtt0, sentExtensions) <- sendClientHello clientSession crand recvServerHello clientSession sentExtensions ver <- usingState_ ctx getVersion unless (maybe True (\(_, _, v) -> v == ver) mparams) $ throwCore $ Error_Protocol ("version changed after hello retry", True, IllegalParameter) -- recvServerHello sets TLS13HRR according to the server random. -- For 1st server hello, getTLS13HR returns True if it is HRR and False otherwise. -- For 2nd server hello, getTLS13HR returns False since it is NOT HRR. hrr <- usingState_ ctx getTLS13HRR if ver == TLS13 then if hrr then case drop 1 groups of [] -> throwCore $ Error_Protocol ("group is exhausted in the client side", True, IllegalParameter) groups' -> do when (isJust mparams) $ throwCore $ Error_Protocol ("server sent too many hello retries", True, UnexpectedMessage) mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup) | selectedGroup `elem` groups' -> do usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest clearTxState ctx let cparams' = cparams { clientEarlyData = Nothing } runPacketFlight ctx $ sendChangeCipherSpec13 ctx handshakeClient' cparams' ctx [selectedGroup] (Just (crand, clientSession, ver)) | otherwise -> throwCore $ Error_Protocol ("server-selected group is not supported", True, IllegalParameter) Just _ -> error "handshakeClient': invalid KeyShare value" Nothing -> throwCore $ Error_Protocol ("key exchange not implemented in HRR, expected key_share extension", True, HandshakeFailure) else do handshakeClient13 cparams ctx groupToSend else do when rtt0 $ throwCore $ Error_Protocol ("server denied TLS 1.3 when connecting with early data", True, HandshakeFailure) sessionResuming <- usingState_ ctx isSessionResuming if sessionResuming then sendChangeCipherAndFinish ctx ClientRole else do sendClientData cparams ctx sendChangeCipherAndFinish ctx ClientRole recvChangeCipherAndFinish ctx handshakeTerminate ctx where ciphers = supportedCiphers $ ctxSupported ctx compressions = supportedCompressions $ ctxSupported ctx highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 ems = supportedExtendedMasterSec $ ctxSupported ctx groupToSend = listToMaybe groups -- List of extensions to send in ClientHello, ordered such that we never -- terminate with a zero-length extension. Some buggy implementations -- are allergic to an extension with empty data at final position. -- -- Without TLS 1.3, the list ends with extension "signature_algorithms" -- with length >= 2 bytes. When TLS 1.3 is enabled, extensions -- "psk_key_exchange_modes" (currently always sent) and "pre_shared_key" -- (not always present) have length > 0. getExtensions pskInfo rtt0 = sequence [ sniExtension , secureReneg , alpnExtension , emsExtension , groupExtension , ecPointExtension --, sessionTicketExtension , signatureAlgExtension --, heartbeatExtension , versionExtension , earlyDataExtension rtt0 , keyshareExtension , cookieExtension , postHandshakeAuthExtension , pskExchangeModeExtension , preSharedKeyExtension pskInfo -- MUST be last (RFC 8446) ] toExtensionRaw :: Extension e => e -> ExtensionRaw toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext) secureReneg = if supportedSecureRenegotiation $ ctxSupported ctx then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing else return Nothing alpnExtension = do mprotos <- onSuggestALPN $ clientHooks cparams case mprotos of Nothing -> return Nothing Just protos -> do usingState_ ctx $ setClientALPNSuggest protos return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos emsExtension = return $ if ems == NoEMS || all (>= TLS13) (supportedVersions $ ctxSupported ctx) then Nothing else Just $ toExtensionRaw ExtendedMasterSecret sniExtension = if clientUseServerNameIndication cparams then do let sni = fst $ clientServerIdentification cparams usingState_ ctx $ setClientSNI sni return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing groupExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups (supportedGroups $ ctxSupported ctx) ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed] --[EcPointFormat_Uncompressed,EcPointFormat_AnsiX962_compressed_prime,EcPointFormat_AnsiX962_compressed_char2] --heartbeatExtension = return $ Just $ toExtensionRaw $ HeartBeat $ HeartBeat_PeerAllowedToSend --sessionTicketExtension = return $ Just $ toExtensionRaw $ SessionTicket signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams versionExtension | tls13 = do let vers = filter (>= TLS10) $ supportedVersions $ ctxSupported ctx return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers | otherwise = return Nothing -- FIXME keyshareExtension | tls13 = case groupToSend of Nothing -> return Nothing Just grp -> do (cpri, ent) <- makeClientKeyShare ctx grp usingHState ctx $ setGroupPrivate cpri return $ Just $ toExtensionRaw $ KeyShareClientHello [ent] | otherwise = return Nothing sessionAndCipherToResume13 = do guard tls13 (sid, sdata) <- clientWantSessionResume cparams guard (sessionVersion sdata >= TLS13) sCipher <- find (\c -> cipherID c == sessionCipher sdata) ciphers return (sid, sdata, sCipher) getPskInfo = case sessionAndCipherToResume13 of Nothing -> return Nothing Just (sid, sdata, sCipher) -> do let tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata age <- getAge tinfo return $ if isAgeValid age tinfo then Just (sid, sdata, makeCipherChoice TLS13 sCipher, ageToObfuscatedAge age tinfo) else Nothing preSharedKeyExtension pskInfo = case pskInfo of Nothing -> return Nothing Just (sid, _, choice, obfAge) -> let zero = cZero choice identity = PskIdentity sid obfAge offeredPsks = PreSharedKeyClientHello [identity] [zero] in return $ Just $ toExtensionRaw offeredPsks pskExchangeModeExtension | tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE] | otherwise = return Nothing earlyDataExtension rtt0 | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing) | otherwise = return Nothing cookieExtension = do mcookie <- usingState_ ctx getTLS13Cookie case mcookie of Nothing -> return Nothing Just cookie -> return $ Just $ toExtensionRaw cookie postHandshakeAuthExtension | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth | otherwise = return Nothing adjustExtentions pskInfo exts ch = case pskInfo of Nothing -> return exts Just (_, sdata, choice, _) -> do let psk = sessionSecret sdata earlySecret = initEarlySecret choice (Just psk) usingHState ctx $ setTLS13EarlySecret earlySecret let ech = encodeHandshake ch h = cHash choice siz = hashDigestSize h binder <- makePSKBinder ctx earlySecret h (siz + 3) (Just ech) let exts' = init exts ++ [adjust (last exts)] adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders where withBinders = replacePSKBinder withoutBinders binder return exts' generateClientHelloParams = case mparams of -- Client random and session in the second client hello for -- retry must be the same as the first one. Just (crand, clientSession, _) -> return (crand, clientSession) Nothing -> do crand <- clientRandom ctx let paramSession = case clientWantSessionResume cparams of Nothing -> Session Nothing Just (sid, sdata) | sessionVersion sdata >= TLS13 -> Session Nothing | ems == RequireEMS && noSessionEMS -> Session Nothing | otherwise -> Session (Just sid) where noSessionEMS = SessionEMS `notElem` sessionFlags sdata -- In compatibility mode a client not offering a pre-TLS 1.3 -- session MUST generate a new 32-byte value if tls13 && paramSession == Session Nothing then do randomSession <- newSession ctx return (crand, randomSession) else return (crand, paramSession) sendClientHello clientSession crand = do let ver = if tls13 then TLS12 else highestVer hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx ver crand usingState_ ctx $ setVersionIfUnset highestVer let cipherIds = map cipherID ciphers compIds = map compressionID compressions mkClientHello exts = ClientHello ver crand clientSession cipherIds compIds exts Nothing pskInfo <- getPskInfo let rtt0info = pskInfo >>= get0RTTinfo rtt0 = isJust rtt0info extensions0 <- catMaybes <$> getExtensions pskInfo rtt0 extensions <- adjustExtentions pskInfo extensions0 $ mkClientHello extensions0 sendPacket ctx $ Handshake [mkClientHello extensions] mapM_ send0RTT rtt0info return (rtt0, map (\(ExtensionRaw i _) -> i) extensions) get0RTTinfo (_, sdata, choice, _) = do earlyData <- clientEarlyData cparams guard (B.length earlyData <= sessionMaxEarlyDataSize sdata) return (choice, earlyData) send0RTT (choice, earlyData) = do let usedCipher = cCipher choice usedHash = cHash choice Just earlySecret <- usingHState ctx getTLS13EarlySecret -- Client hello is stored in hstHandshakeDigest -- But HandshakeDigestContext is not created yet. earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) False let ClientTrafficSecret clientEarlySecret = pairClient earlyKey runPacketFlight ctx $ sendChangeCipherSpec13 ctx setTxState ctx usedHash usedCipher clientEarlySecret mapChunks_ 16384 (sendPacket13 ctx . AppData13) earlyData usingHState ctx $ setTLS13RTT0Status RTT0Sent recvServerHello clientSession sentExts = runRecvState ctx recvState where recvState = RecvStateNext $ \p -> case p of Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams clientSession sentExts) hs -- this adds SH to hstHandshakeMessages Alert a -> case a of [(AlertLevel_Warning, UnrecognizedName)] -> if clientUseServerNameIndication cparams then return recvState else throwAlert a _ -> throwAlert a _ -> unexpected (show p) (Just "handshake") throwAlert a = usingState_ ctx $ throwError $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure) -- | Store the keypair and check that it is compatible with the current protocol -- version and a list of 'CertificateType' values. storePrivInfoClient :: Context -> [CertificateType] -> Credential -> IO () storePrivInfoClient ctx cTypes (cc, privkey) = do pubkey <- storePrivInfo ctx cc privkey unless (certificateCompatible pubkey cTypes) $ throwCore $ Error_Protocol ( pubkeyType pubkey ++ " credential does not match allowed certificate types" , True , InternalError ) ver <- usingState_ ctx getVersion unless (pubkey `versionCompatible` ver) $ throwCore $ Error_Protocol ( pubkeyType pubkey ++ " credential is not supported at version " ++ show ver , True , InternalError ) -- | When the server requests a client certificate, we try to -- obtain a suitable certificate chain and private key via the -- callback in the client parameters. It is OK for the callback -- to return an empty chain, in many cases the client certificate -- is optional. If the client wishes to abort the handshake for -- lack of a suitable certificate, it can throw an exception in -- the callback. -- -- The return value is 'Nothing' when no @CertificateRequest@ was -- received and no @Certificate@ message needs to be sent. An empty -- chain means that an empty @Certificate@ message needs to be sent -- to the server, naturally without a @CertificateVerify@. A non-empty -- 'CertificateChain' is the chain to send to the server along with -- a corresponding 'CertificateVerify'. -- -- With TLS < 1.2 the server's @CertificateRequest@ does not carry -- a signature algorithm list. It has a list of supported public -- key signing algorithms in the @certificate_types@ field. The -- hash is implicit. It is 'SHA1' for DSS and 'SHA1_MD5' for RSA. -- -- With TLS == 1.2 the server's @CertificateRequest@ always has a -- @supported_signature_algorithms@ list, as a fixed component of -- the structure. This list is (wrongly) overloaded to also limit -- X.509 signatures in the client's certificate chain. The BCP -- strategy is to find a compatible chain if possible, but else -- ignore the constraint, and let the server verify the chain as it -- sees fit. The @supported_signature_algorithms@ field is only -- obligatory with respect to signatures on TLS messages, in this -- case the @CertificateVerify@ message. The @certificate_types@ -- field is still included. -- -- With TLS 1.3 the server's @CertificateRequest@ has a mandatory -- @signature_algorithms@ extension, the @signature_algorithms_cert@ -- extension, which is optional, carries a list of algorithms the -- server promises to support in verifying the certificate chain. -- As with TLS 1.2, the client's makes a /best-effort/ to deliver -- a compatible certificate chain where all the CA signatures are -- known to be supported, but it should not abort the connection -- just because the chain might not work out, just send the best -- chain you have and let the server worry about the rest. The -- supported public key algorithms are now inferred from the -- @signature_algorithms@ extension and @certificate_types@ is -- gone. -- -- With TLS 1.3, we synthesize and store a @certificate_types@ -- field at the time that the server's @CertificateRequest@ -- message is received. This is then present across all the -- protocol versions, and can be used to determine whether -- a @CertificateRequest@ was received or not. -- -- If @signature_algorithms@ is 'Nothing', then we're doing -- TLS 1.0 or 1.1. The @signature_algorithms_cert@ extension -- is optional in TLS 1.3, and so the application callback -- will not be able to distinguish between TLS 1.[01] and -- TLS 1.3 with no certificate algorithm hints, but this -- just simplifies the chain selection process, all CA -- signatures are OK. -- clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain) clientChain cparams ctx = usingHState ctx getCertReqCBdata >>= \case Nothing -> return Nothing Just cbdata -> do let callback = onCertificateRequest $ clientHooks cparams chain <- liftIO $ callback cbdata `catchException` throwMiscErrorOnException "certificate request callback failed" case chain of Nothing -> return $ Just $ CertificateChain [] Just (CertificateChain [], _) -> return $ Just $ CertificateChain [] Just cred@(cc, _) -> do let (cTypes, _, _) = cbdata storePrivInfoClient ctx cTypes cred return $ Just cc -- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with -- the local key and server's signature algorithms (both already saved). Must -- only be called for TLS versions 1.2 and up, with compatibility function -- 'signatureCompatible' or 'signatureCompatible13' based on version. -- -- The values in the server's @signature_algorithms@ extension are -- in descending order of preference. However here the algorithms -- are selected by client preference in @cHashSigs@. -- getLocalHashSigAlg :: Context -> (PubKey -> HashAndSignatureAlgorithm -> Bool) -> [HashAndSignatureAlgorithm] -> PubKey -> IO HashAndSignatureAlgorithm getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do -- Must be present with TLS 1.2 and up. (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata let want = (&&) <$> isCompatible pubKey <*> flip elem hashSigs case find want cHashSigs of Just best -> return best Nothing -> throwCore $ Error_Protocol ( keyerr pubKey , True , HandshakeFailure ) where keyerr k = "no " ++ pubkeyType k ++ " hash algorithm in common with the server" -- | Return the supported 'CertificateType' values that are -- compatible with at least one supported signature algorithm. -- supportedCtypes :: [HashAndSignatureAlgorithm] -> [CertificateType] supportedCtypes hashAlgs = nub $ foldr ctfilter [] hashAlgs where ctfilter x acc = case hashSigToCertType x of Just cType | cType <= lastSupportedCertificateType -> cType : acc _ -> acc -- clientSupportedCtypes :: Context -> [CertificateType] clientSupportedCtypes ctx = supportedCtypes $ supportedHashSignatures $ ctxSupported ctx -- sigAlgsToCertTypes :: Context -> [HashAndSignatureAlgorithm] -> [CertificateType] sigAlgsToCertTypes ctx hashSigs = filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx -- | TLS 1.2 and below. Send the client handshake messages that -- follow the @ServerHello@, etc. except for @CCS@ and @Finished@. -- -- XXX: Is any buffering done here to combined these messages into -- a single TCP packet? Otherwise we're prone to Nagle delays, or -- in any case needlessly generate multiple small packets, where -- a single larger packet will do. The TLS 1.3 code path seems -- to separating record generation and transmission and sending -- multiple records in a single packet. -- -- -> [certificate] -- -> client key exchange -- -> [cert verify] sendClientData :: ClientParams -> Context -> IO () sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify where sendCertificate = do usingHState ctx $ setClientCertSent False clientChain cparams ctx >>= \case Nothing -> return () Just cc@(CertificateChain certs) -> do unless (null certs) $ usingHState ctx $ setClientCertSent True sendPacket ctx $ Handshake [Certificates cc] sendClientKeyXchg = do cipher <- usingHState ctx getPendingCipher (ckx, setMasterSec) <- case cipherKeyExchange cipher of CipherKeyExchange_RSA -> do clientVersion <- usingHState ctx $ gets hstClientVersion (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 let premaster = encodePreMasterSecret clientVersion prerand setMasterSec = setMasterSecretFromPre xver ClientRole premaster encryptedPreMaster <- do -- SSL3 implementation generally forget this length field since it's redundant, -- however TLS10 make it clear that the length field need to be present. e <- encryptRSA ctx premaster let extra = if xver < TLS10 then B.empty else encodeWord16 $ fromIntegral $ B.length e return $ extra `B.append` e return (CKX_RSA encryptedPreMaster, setMasterSec) CipherKeyExchange_DHE_RSA -> getCKX_DHE CipherKeyExchange_DHE_DSS -> getCKX_DHE CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE _ -> throwCore $ Error_Protocol ("client key exchange unsupported type", True, HandshakeFailure) sendPacket ctx $ Handshake [ClientKeyXchg ckx] masterSecret <- usingHState ctx setMasterSec logKey ctx (MasterSecret masterSecret) where getCKX_DHE = do xver <- usingState_ ctx getVersion serverParams <- usingHState ctx getServerDHParams let params = serverDHParamsToParams serverParams ffGroup = findFiniteFieldGroup params srvpub = serverDHParamsToPublic serverParams unless (maybe False (isSupportedGroup ctx) ffGroup) $ do groupUsage <- onCustomFFDHEGroup (clientHooks cparams) params srvpub `catchException` throwMiscErrorOnException "custom group callback failed" case groupUsage of GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity) GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure) GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, IllegalParameter) GroupUsageValid -> return () -- When grp is known but not in the supported list we use it -- anyway. This provides additional validation and a more -- efficient implementation. (clientDHPub, premaster) <- case ffGroup of Nothing -> do (clientDHPriv, clientDHPub) <- generateDHE ctx params let premaster = dhGetShared params clientDHPriv srvpub return (clientDHPub, premaster) Just grp -> do usingHState ctx $ setNegotiatedGroup grp dhePair <- generateFFDHEShared ctx grp srvpub case dhePair of Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) Just pair -> return pair let setMasterSec = setMasterSecretFromPre xver ClientRole premaster return (CKX_DH clientDHPub, setMasterSec) getCKX_ECDHE = do ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams checkSupportedGroup ctx grp usingHState ctx $ setNegotiatedGroup grp ecdhePair <- generateECDHEShared ctx srvpub case ecdhePair of Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, IllegalParameter) Just (clipub, premaster) -> do xver <- usingState_ ctx getVersion let setMasterSec = setMasterSecretFromPre xver ClientRole premaster return (CKX_ECDH $ encodeGroupPublic clipub, setMasterSec) -- In order to send a proper certificate verify message, -- we have to do the following: -- -- 1. Determine which signing algorithm(s) the server supports -- (we currently only support RSA). -- 2. Get the current handshake hash from the handshake state. -- 3. Sign the handshake hash -- 4. Send it to the server. -- sendCertificateVerify = do ver <- usingState_ ctx getVersion -- Only send a certificate verify message when we -- have sent a non-empty list of certificates. -- certSent <- usingHState ctx getClientCertSent when certSent $ do pubKey <- getLocalPublicKey ctx mhashSig <- case ver of TLS12 -> let cHashSigs = supportedHashSignatures $ ctxSupported ctx in Just <$> getLocalHashSigAlg ctx signatureCompatible cHashSigs pubKey _ -> return Nothing -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs sendPacket ctx $ Handshake [CertVerify sigDig] processServerExtension :: ExtensionRaw -> TLSSt () processServerExtension (ExtensionRaw extID content) | extID == extensionID_SecureRenegotiation = do cv <- getVerifiedData ClientRole sv <- getVerifiedData ServerRole let bs = extensionEncode (SecureRenegotiation cv $ Just sv) unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure) | extID == extensionID_SupportedVersions = case extensionDecode MsgTServerHello content of Just (SupportedVersionsServerHello ver) -> setVersion ver _ -> return () | extID == extensionID_KeyShare = do hrr <- getTLS13HRR let msgt = if hrr then MsgTHelloRetryRequest else MsgTServerHello setTLS13KeyShare $ extensionDecode msgt content | extID == extensionID_PreSharedKey = setTLS13PreSharedKey $ extensionDecode MsgTServerHello content processServerExtension _ = return () throwMiscErrorOnException :: String -> SomeException -> IO a throwMiscErrorOnException msg e = throwCore $ Error_Misc $ msg ++ ": " ++ show e -- | onServerHello process the ServerHello message on the client. -- -- 1) check the version chosen by the server is one allowed by parameters. -- 2) check that our compression and cipher algorithms are part of the list we sent -- 3) check extensions received are part of the one we sent -- 4) process the session parameter to see if the server want to start a new session or can resume -- 5) if no resume switch to processCertificate SM or in resume switch to expectChangeCipher -- onServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO) onServerHello ctx cparams clientSession sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion) -- find the compression and cipher methods that the server want to use. cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, IllegalParameter) Just alg -> return alg compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, IllegalParameter) Just alg -> return alg -- intersect sent extensions in client and the received extensions from server. -- if server returns extensions that we didn't request, fail. let checkExt (ExtensionRaw i _) | i == extensionID_Cookie = False -- for HRR | otherwise = i `notElem` sentExts when (any checkExt exts) $ throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension) let resumingSession = case clientWantSessionResume cparams of Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing Nothing -> Nothing isHRR = isHelloRetryRequest serverRan usingState_ ctx $ do setTLS13HRR isHRR setTLS13Cookie (guard isHRR >> extensionLookup extensionID_Cookie exts >>= extensionDecode MsgTServerHello) setSession serverSession (isJust resumingSession) setVersion rver -- must be before processing supportedVersions ext mapM_ processServerExtension exts setALPN ctx MsgTServerHello exts ver <- usingState_ ctx getVersion -- Some servers set TLS 1.2 as the legacy server hello version, and TLS 1.3 -- in the supported_versions extension, *AND ALSO* set the TLS 1.2 -- downgrade signal in the server random. If we support TLS 1.3 and -- actually negotiate TLS 1.3, we must ignore the server random downgrade -- signal. Therefore, 'isDowngraded' needs to take into account the -- negotiated version and the server random, as well as the list of -- client-side enabled protocol versions. -- when (isDowngraded ver (supportedVersions $ clientSupported cparams) serverRan) $ throwCore $ Error_Protocol ("version downgrade detected", True, IllegalParameter) case find (== ver) (supportedVersions $ ctxSupported ctx) of Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported", True, ProtocolVersion) Just _ -> return () if ver > TLS12 then do when (serverSession /= clientSession) $ throwCore $ Error_Protocol ("received mismatched legacy session", True, IllegalParameter) established <- ctxEstablished ctx eof <- ctxEOF ctx when (established == Established && not eof) $ throwCore $ Error_Protocol ("renegotiation to TLS 1.3 or later is not allowed", True, ProtocolVersion) ensureNullCompression compression failOnEitherError $ usingHState ctx $ setHelloParameters13 cipherAlg return RecvStateDone else do ems <- processExtendedMasterSec ctx ver MsgTServerHello exts usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg case resumingSession of Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx) Just sessionData -> do let emsSession = SessionEMS `elem` sessionFlags sessionData when (ems /= emsSession) $ let err = "server resumes a session which is not EMS consistent" in throwCore $ Error_Protocol (err, True, HandshakeFailure) let masterSecret = sessionSecret sessionData usingHState ctx $ setMasterSecret rver ClientRole masterSecret logKey ctx (MasterSecret masterSecret) return $ RecvStateNext expectChangeCipher onServerHello _ _ _ _ p = unexpected (show p) (Just "server hello") processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) processCertificate cparams ctx (Certificates certs) = do when (isNullCertificateChain certs) $ throwCore $ Error_Protocol ("server certificate missing", True, DecodeError) -- run certificate recv hook ctxWithHooks ctx (`hookRecvCertificates` certs) -- then run certificate validation usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException case usage of CertificateUsageAccept -> checkLeafCertificateKeyUsage CertificateUsageReject reason -> certificateRejected reason return $ RecvStateHandshake (processServerKeyExchange ctx) where shared = clientShared cparams checkCert = onServerCertificate (clientHooks cparams) (sharedCAStore shared) (sharedValidationCache shared) (clientServerIdentification cparams) certs -- also verify that the certificate optional key usage is compatible -- with the intended key-exchange. This check is not delegated to -- x509-validation 'checkLeafKeyUsage' because it depends on negotiated -- cipher, which is not available from onServerCertificate parameters. -- Additionally, with only one shared ValidationCache, x509-validation -- would cache validation result based on a key usage and reuse it with -- another key usage. checkLeafCertificateKeyUsage = do cipher <- usingHState ctx getPendingCipher case requiredCertKeyUsage cipher of [] -> return () flags -> verifyLeafKeyUsage flags certs processCertificate _ ctx p = processServerKeyExchange ctx p expectChangeCipher :: Packet -> IO (RecvState IO) expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish expectChangeCipher p = unexpected (show p) (Just "change cipher") expectFinish :: Handshake -> IO (RecvState IO) expectFinish (Finished _) = return RecvStateDone expectFinish p = unexpected (show p) (Just "Handshake Finished") processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO) processServerKeyExchange ctx (ServerKeyXchg origSkx) = do cipher <- usingHState ctx getPendingCipher processWithCipher cipher origSkx return $ RecvStateHandshake (processCertificateRequest ctx) where processWithCipher cipher skx = case (cipherKeyExchange cipher, skx) of (CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) -> doDHESignature dhparams signature KX_RSA (CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) -> doDHESignature dhparams signature KX_DSS (CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) -> doECDHESignature ecdhparams signature KX_RSA (CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) -> doECDHESignature ecdhparams signature KX_ECDSA (cke, SKX_Unparsed bytes) -> do ver <- usingState_ ctx getVersion case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of Left _ -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show cke, True, HandshakeFailure) Right realSkx -> processWithCipher cipher realSkx -- we need to resolve the result. and recall processWithCipher .. (c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure) doDHESignature dhparams signature kxsAlg = do -- FF group selected by the server is verified when generating CKX publicKey <- getSignaturePublicKey kxsAlg verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams) usingHState ctx $ setServerDHParams dhparams doECDHESignature ecdhparams signature kxsAlg = do -- EC group selected by the server is verified when generating CKX publicKey <- getSignaturePublicKey kxsAlg verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams") usingHState ctx $ setServerECDHParams ecdhparams getSignaturePublicKey kxsAlg = do publicKey <- usingHState ctx getRemotePublicKey unless (isKeyExchangeSignatureKey kxsAlg publicKey) $ throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure) ver <- usingState_ ctx getVersion unless (publicKey `versionCompatible` ver) $ throwCore $ Error_Protocol (show ver ++ " has no support for " ++ pubkeyType publicKey, True, IllegalParameter) let groups = supportedGroups (ctxSupported ctx) unless (satisfiesEcPredicate (`elem` groups) publicKey) $ throwCore $ Error_Protocol ("server public key has unsupported elliptic curve", True, IllegalParameter) return publicKey processServerKeyExchange ctx p = processCertificateRequest ctx p processCertificateRequest :: Context -> Handshake -> IO (RecvState IO) processCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do ver <- usingState_ ctx getVersion when (ver == TLS12 && isNothing sigAlgs) $ throwCore $ Error_Protocol ( "missing TLS 1.2 certificate request signature algorithms" , True , InternalError ) let cTypes = filter (<= lastSupportedCertificateType) cTypesSent usingHState ctx $ setCertReqCBdata $ Just (cTypes, sigAlgs, dNames) return $ RecvStateHandshake (processServerHelloDone ctx) processCertificateRequest ctx p = do usingHState ctx $ setCertReqCBdata Nothing processServerHelloDone ctx p processServerHelloDone :: Context -> Handshake -> IO (RecvState m) processServerHelloDone _ ServerHelloDone = return RecvStateDone processServerHelloDone _ p = unexpected (show p) (Just "server hello data") -- Unless result is empty, server certificate must be allowed for at least one -- of the returned values. Constraints for RSA-based key exchange are relaxed -- to avoid rejecting certificates having incomplete extension. requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag] requiredCertKeyUsage cipher = case cipherKeyExchange cipher of CipherKeyExchange_RSA -> rsaCompatibility CipherKeyExchange_DH_Anon -> [] -- unrestricted CipherKeyExchange_DHE_RSA -> rsaCompatibility CipherKeyExchange_ECDHE_RSA -> rsaCompatibility CipherKeyExchange_DHE_DSS -> [ KeyUsage_digitalSignature ] CipherKeyExchange_DH_DSS -> [ KeyUsage_keyAgreement ] CipherKeyExchange_DH_RSA -> rsaCompatibility CipherKeyExchange_ECDH_ECDSA -> [ KeyUsage_keyAgreement ] CipherKeyExchange_ECDH_RSA -> rsaCompatibility CipherKeyExchange_ECDHE_ECDSA -> [ KeyUsage_digitalSignature ] CipherKeyExchange_TLS13 -> [ KeyUsage_digitalSignature ] where rsaCompatibility = [ KeyUsage_digitalSignature , KeyUsage_keyEncipherment , KeyUsage_keyAgreement ] handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO () handshakeClient13 cparams ctx groupSent = do choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher handshakeClient13' cparams ctx groupSent choice handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO () handshakeClient13' cparams ctx groupSent choice = do (_, hkey, resuming) <- switchToHandshakeSecret let handshakeSecret = triBase hkey ClientTrafficSecret clientHandshakeSecret = triClient hkey ServerTrafficSecret serverHandshakeSecret = triServer hkey rtt0accepted <- runRecvHandshake13 $ do accepted <- recvHandshake13 ctx expectEncryptedExtensions unless resuming $ recvHandshake13 ctx expectCertRequest recvHandshake13hash ctx $ expectFinished serverHandshakeSecret return accepted hChSf <- transcriptHash ctx runPacketFlight ctx $ sendChangeCipherSpec13 ctx when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) setTxState ctx usedHash usedCipher clientHandshakeSecret sendClientFlight13 cparams ctx usedHash clientHandshakeSecret appKey <- switchToApplicationSecret handshakeSecret hChSf let applicationSecret = triBase appKey setResumptionSecret applicationSecret handshakeTerminate13 ctx where usedCipher = cCipher choice usedHash = cHash choice hashSize = hashDigestSize usedHash switchToHandshakeSecret = do ensureRecvComplete ctx ecdhe <- calcSharedKey (earlySecret, resuming) <- makeEarlySecret handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe let ServerTrafficSecret serverHandshakeSecret = triServer handKey setRxState ctx usedHash usedCipher serverHandshakeSecret return (usedCipher, handKey, resuming) switchToApplicationSecret handshakeSecret hChSf = do ensureRecvComplete ctx appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf let ServerTrafficSecret serverApplicationSecret0 = triServer appKey let ClientTrafficSecret clientApplicationSecret0 = triClient appKey setTxState ctx usedHash usedCipher clientApplicationSecret0 setRxState ctx usedHash usedCipher serverApplicationSecret0 return appKey calcSharedKey = do serverKeyShare <- do mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareServerHello ks) -> return ks Just _ -> error "calcSharedKey: invalid KeyShare value" Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure) let grp = keyShareEntryGroup serverKeyShare unless (groupSent == Just grp) $ throwCore $ Error_Protocol ("received incompatible group for (EC)DHE", True, IllegalParameter) usingHState ctx $ setNegotiatedGroup grp usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare makeEarlySecret = do mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret case mEarlySecretPSK of Nothing -> return (initEarlySecret choice Nothing, False) Just earlySecretPSK@(BaseSecret sec) -> do mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey case mSelectedIdentity of Nothing -> return (initEarlySecret choice Nothing, False) Just (PreSharedKeyServerHello 0) -> do unless (B.length sec == hashSize) $ throwCore $ Error_Protocol ("selected cipher is incompatible with selected PSK", True, IllegalParameter) usingHState ctx $ setTLS13HandshakeMode PreSharedKey return (earlySecretPSK, True) Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter) expectEncryptedExtensions (EncryptedExtensions13 eexts) = do liftIO $ setALPN ctx MsgTEncryptedExtensions eexts st <- usingHState ctx getTLS13RTT0Status if st == RTT0Sent then case extensionLookup extensionID_EarlyData eexts of Just _ -> do usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Accepted return True Nothing -> do usingHState ctx $ setTLS13HandshakeMode RTT0 usingHState ctx $ setTLS13RTT0Status RTT0Rejected return False else return False expectEncryptedExtensions p = unexpected (show p) (Just "encrypted extensions") expectCertRequest (CertRequest13 token exts) = do processCertRequest13 ctx token exts recvHandshake13 ctx expectCertAndVerify expectCertRequest other = do usingHState ctx $ do setCertReqToken Nothing setCertReqCBdata Nothing -- setCertReqSigAlgsCert Nothing expectCertAndVerify other expectCertAndVerify (Certificate13 _ cc _) = do _ <- liftIO $ processCertificate cparams ctx (Certificates cc) let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc ver <- liftIO $ usingState_ ctx getVersion checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey recvHandshake13hash ctx $ expectCertVerify pubkey expectCertAndVerify p = unexpected (show p) (Just "server certificate") expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify" expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify") expectFinished baseKey hashValue (Finished13 verifyData) = checkFinished usedHash baseKey hashValue verifyData expectFinished _ _ p = unexpected (show p) (Just "server finished") setResumptionSecret applicationSecret = do resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret usingHState ctx $ setTLS13ResumptionSecret resumptionSecret processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m () processCertRequest13 ctx token exts = do let hsextID = extensionID_SignatureAlgorithms -- caextID = extensionID_SignatureAlgorithmsCert dNames <- canames -- The @signature_algorithms@ extension is mandatory. hsAlgs <- extalgs hsextID unsighash cTypes <- case hsAlgs of Just as -> let validAs = filter isHashSignatureValid13 as in return $ sigAlgsToCertTypes ctx validAs Nothing -> throwCore $ Error_Protocol ( "invalid certificate request" , True , HandshakeFailure ) -- Unused: -- caAlgs <- extalgs caextID uncertsig usingHState ctx $ do setCertReqToken $ Just token setCertReqCBdata $ Just (cTypes, hsAlgs, dNames) -- setCertReqSigAlgsCert caAlgs where canames = case extensionLookup extensionID_CertificateAuthorities exts of Nothing -> return [] Just ext -> case extensionDecode MsgTCertificateRequest ext of Just (CertificateAuthorities names) -> return names _ -> throwCore $ Error_Protocol ( "invalid certificate request" , True , HandshakeFailure ) extalgs extID decons = case extensionLookup extID exts of Nothing -> return Nothing Just ext -> case extensionDecode MsgTCertificateRequest ext of Just e -> return $ decons e _ -> throwCore $ Error_Protocol ( "invalid certificate request" , True , HandshakeFailure ) unsighash :: SignatureAlgorithms -> Maybe [HashAndSignatureAlgorithm] unsighash (SignatureAlgorithms a) = Just a {- Unused for now uncertsig :: SignatureAlgorithmsCert -> Maybe [HashAndSignatureAlgorithm] uncertsig (SignatureAlgorithmsCert a) = Just a -} sendClientFlight13 :: ClientParams -> Context -> Hash -> ByteString -> IO () sendClientFlight13 cparams ctx usedHash baseKey = do chain <- clientChain cparams ctx runPacketFlight ctx $ do case chain of Nothing -> return () Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc rawFinished <- makeFinished ctx usedHash baseKey loadPacket13 ctx $ Handshake13 [rawFinished] where sendClientData13 chain (Just token) = do let (CertificateChain certs) = chain certExts = replicate (length certs) [] cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts] case certs of [] -> return () _ -> do hChSc <- transcriptHash ctx pubKey <- getLocalPublicKey ctx sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey vfy <- makeCertVerify ctx pubKey sigAlg hChSc loadPacket13 ctx $ Handshake13 [vfy] -- sendClientData13 _ _ = throwCore $ Error_Protocol ( "missing TLS 1.3 certificate request context token" , True , InternalError ) setALPN :: Context -> MessageType -> [ExtensionRaw] -> IO () setALPN ctx msgt exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode msgt of Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do mprotos <- getClientALPNSuggest case mprotos of Just protos -> when (proto `elem` protos) $ do setExtensionALPN True setNegotiatedProtocol proto _ -> return () _ -> return () postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO () postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) = bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do processHandshake13 ctx h processCertRequest13 ctx certReqCtx exts (usedHash, _, applicationSecretN) <- getTxState ctx sendClientFlight13 cparams ctx usedHash applicationSecretN postHandshakeAuthClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthClientWith", True, UnexpectedMessage)