tls-2.4.9: Network/TLS/Handshake/Server/ClientHello12.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.TLS.Handshake.Server.ClientHello12 (
processClientHello12,
) where
import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Credentials
import Network.TLS.Crypto
import Network.TLS.ErrT
import Network.TLS.Extension
import Network.TLS.Handshake.Common (ticketOrSessionID12)
import Network.TLS.Handshake.Server.Common
import Network.TLS.Handshake.Signature
import Network.TLS.Imports
import Network.TLS.Parameters
import Network.TLS.Session (SessionManager (..))
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Types (CipherId (..), Role (..))
----------------------------------------------------------------
-- serverSupported sparams == ctxSupported ctx
-- TLS 1.2 or earlier
processClientHello12
:: ServerParams
-> Context
-> ClientHello
-> IO (Cipher, Maybe Credential)
processClientHello12 sparams ctx ch = do
let secureRenegotiation = supportedSecureRenegotiation $ serverSupported sparams
when secureRenegotiation $ checkSecureRenegotiation ctx ch
checkEcPointFormats ch
serverName <- usingState_ ctx getClientSNI
let hooks = serverHooks sparams
extraCreds <- onServerNameIndication hooks serverName
let (creds, signatureCreds, ciphersFilteredVersion) =
credsTriple sparams ch extraCreds
-- The shared cipherlist can become empty after filtering for compatible
-- creds, check now before calling onCipherChoosing, which does not handle
-- empty lists.
when (null ciphersFilteredVersion) $ do
checkResumedCipherOffered ctx ch
throwCore $
Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure
usedCipher <- chooseCipher hooks TLS12 ciphersFilteredVersion
mcred <- chooseCreds usedCipher creds signatureCreds
return (usedCipher, mcred)
-- RFC 5246 Section 7.4.1.2: a client resuming a session MUST offer the
-- cipher suite of that session. validateSession reports its absence with
-- illegal_parameter once a cipher has been chosen; when none can be chosen,
-- the same is reported here before the missing common cipher is.
checkResumedCipherOffered :: Context -> ClientHello -> IO ()
checkResumedCipherOffered ctx CH{..} = do
let mticket =
lookupAndDecode
EID_SessionTicket
MsgTClientHello
chExtensions
Nothing
(\(SessionTicket ticket) -> Just ticket)
case ticketOrSessionID12 mticket chSession of
Nothing -> return ()
Just identity -> do
msd <- sessionResume (sharedSessionManager $ ctxShared ctx) identity
case msd of
Just sd
| sessionVersion sd <= TLS12
, CipherId (sessionCipher sd) `notElem` chCiphers ->
throwCore $
Error_Protocol "new cipher is different from the old one" IllegalParameter
_ -> return ()
checkSecureRenegotiation :: Context -> ClientHello -> IO ()
checkSecureRenegotiation ctx CH{..} = do
-- RFC 5746: secure renegotiation
-- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF}
let hasSCSV = CipherId 0xff `elem` chCiphers
hasExt = isJust $ extensionLookup EID_SecureRenegotiation chExtensions
established <- ctxEstablished ctx
secure <- usingState_ ctx getSecureRenegotiation
-- RFC 5746 Section 3.7: when renegotiating a connection whose
-- secure_renegotiation flag is set, ClientHello MUST NOT contain
-- the SCSV and MUST contain the renegotiation_info extension.
when (established == Established && secure) $ do
when hasSCSV $
throwCore $
Error_Protocol "SCSV in renegotiation" HandshakeFailure
unless hasExt $
throwCore $
Error_Protocol "no renegotiation_info in renegotiation" HandshakeFailure
when hasSCSV $
usingState_ ctx $
setSecureRenegotiation True
case extensionLookup EID_SecureRenegotiation chExtensions of
Just content -> usingState_ ctx $ do
VerifyData cvd <- getVerifyData ClientRole
let bs = extensionEncode (SecureRenegotiation cvd "")
unless (bs == content) $
throwError $
Error_Protocol
("client verified data not matching: " ++ show cvd ++ ":" ++ show content)
HandshakeFailure
setSecureRenegotiation True
_ -> return ()
----------------------------------------------------------------
credsTriple
:: ServerParams
-> ClientHello
-> Credentials
-> (Credentials, Credentials, [Cipher])
credsTriple sparams CH{..} extraCreds
| cipherListCredentialFallback cltCiphers = (allCreds, sigAllCreds, allCiphers)
| otherwise = (cltCreds, sigCltCreds, cltCiphers)
where
ciphers = supportedCiphers $ serverSupported sparams
commonCiphers creds sigCreds = intersectCiphers chCiphers availableCiphers
where
availableCiphers = getCiphers ciphers creds sigCreds
p = makeCredentialPredicate TLS12 chExtensions
allCreds =
filterCredentials (isCredentialAllowed TLS12 p) $
extraCreds `mappend` sharedCredentials (serverShared sparams)
-- When selecting a cipher we must ensure that it is allowed for the
-- TLS version but also that all its key-exchange requirements
-- will be met.
-- Some ciphers require a signature and a hash. With TLS 1.2 the hash
-- algorithm is selected from a combination of server configuration and
-- the client "supported_signatures" extension. So we cannot pick
-- such a cipher if no hash is available for it. It's best to skip this
-- cipher and pick another one (with another key exchange).
-- Cipher selection is performed in two steps: first server credentials
-- are flagged as not suitable for signature if not compatible with
-- negotiated signature parameters. Then ciphers are evaluated from
-- the resulting credentials.
supported = serverSupported sparams
groups = supportedGroups supported
possibleGroups = negotiatedGroupsInCommon groups chExtensions
possibleECGroups = possibleGroups `intersect` availableECGroups
possibleFFGroups = possibleGroups `intersect` availableFFGroups
hasCommonGroupForECDHE = not (null possibleECGroups)
hasCommonGroupForFFDHE = not (null possibleFFGroups)
hasCustomGroupForFFDHE = isJust (serverDHEParams sparams)
canFFDHE = hasCustomGroupForFFDHE || hasCommonGroupForFFDHE
hasCommonGroup cipher =
case cipherKeyExchange cipher of
CipherKeyExchange_DH_Anon -> canFFDHE
CipherKeyExchange_DHE_RSA -> canFFDHE
CipherKeyExchange_DHE_DSA -> canFFDHE
CipherKeyExchange_ECDHE_RSA -> hasCommonGroupForECDHE
CipherKeyExchange_ECDHE_ECDSA -> hasCommonGroupForECDHE
_ -> True -- group not used
-- Ciphers are selected according to TLS version, availability of
-- (EC)DHE group and credential depending on key exchange.
cipherAllowed cipher = cipherAllowedForVersion TLS12 cipher && hasCommonGroup cipher
selectCipher credentials signatureCredentials = filter cipherAllowed (commonCiphers credentials signatureCredentials)
-- Build a list of all hash/signature algorithms in common between
-- client and server.
hashAndSignatures = supportedHashSignatures supported
possibleHashSigAlgs = hashAndSignaturesInCommon hashAndSignatures chExtensions
-- Check that a candidate signature credential will be compatible with
-- client & server hash/signature algorithms. This returns Just Int
-- in order to sort credentials according to server hash/signature
-- preference. When the certificate has no matching hash/signature in
-- 'possibleHashSigAlgs' the result is Nothing, and the credential will
-- not be used to sign. This avoids a failure later in 'decideHashSig'.
signingRank cred =
case credentialDigitalSignatureKey cred of
Just pub -> findIndex (pub `signatureCompatible`) possibleHashSigAlgs
Nothing -> Nothing
-- Finally compute credential lists and resulting cipher list.
--
-- We try to keep certificates supported by the client, but
-- fallback to all credentials if this produces no suitable result
-- (see RFC 5246 section 7.4.2 and RFC 8446 section 4.4.2.2).
-- The condition is based on resulting (EC)DHE ciphers so that
-- filtering credentials does not give advantage to a less secure
-- key exchange like CipherKeyExchange_RSA or CipherKeyExchange_DH_Anon.
cltCreds = filterCredentialsWithHashSignatures chExtensions allCreds
sigCltCreds = filterSortCredentials signingRank cltCreds
sigAllCreds = filterSortCredentials signingRank allCreds
cltCiphers = selectCipher cltCreds sigCltCreds
allCiphers = selectCipher allCreds sigAllCreds
chooseCreds :: Cipher -> Credentials -> Credentials -> IO (Maybe Credential)
chooseCreds usedCipher creds signatureCreds = case cipherKeyExchange usedCipher of
CipherKeyExchange_RSA -> return $ credentialsFindForDecrypting creds
CipherKeyExchange_DH_Anon -> return Nothing
CipherKeyExchange_DHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds
CipherKeyExchange_DHE_DSA -> return $ credentialsFindForSigning KX_DSA signatureCreds
CipherKeyExchange_ECDHE_RSA -> return $ credentialsFindForSigning KX_RSA signatureCreds
CipherKeyExchange_ECDHE_ECDSA -> return $ credentialsFindForSigning KX_ECDSA signatureCreds
_ ->
throwCore $
Error_Protocol "key exchange algorithm not implemented" HandshakeFailure
----------------------------------------------------------------
-- RFC 8422 Section 5.1.2: a client that names a curve of RFC 8422 in
-- supported_groups and sends ec_point_formats without the uncompressed
-- format is refused with illegal_parameter. An empty list is refused
-- with decode_error when decoding it.
checkEcPointFormats :: ClientHello -> IO ()
checkEcPointFormats CH{..} =
lookupAndDecodeAndDo
EID_EcPointFormats
MsgTClientHello
chExtensions
(return ())
$ \(EcPointFormatsSupported formats) ->
when
( EcPointFormat_Uncompressed `notElem` formats
&& any (`elem` rfc8422Groups) groups
)
$ throwCore
$ Error_Protocol "uncompressed point format missing" IllegalParameter
where
groups =
lookupAndDecode
EID_SupportedGroups
MsgTClientHello
chExtensions
[]
(\(SupportedGroups gs) -> gs)
rfc8422Groups = [P256, P384, P521, X25519, X448]
negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon serverGroups exts =
lookupAndDecode
EID_SupportedGroups
MsgTClientHello
exts
[]
(\(SupportedGroups clientGroups) -> serverGroups `intersect` clientGroups)
----------------------------------------------------------------
filterSortCredentials
:: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials rankFun (Credentials creds) =
let orderedPairs = sortOn fst [(rankFun cred, cred) | cred <- creds]
in Credentials [cred | (Just _, cred) <- orderedPairs]
-- returns True if certificate filtering with "signature_algorithms_cert" /
-- "signature_algorithms" produced no ephemeral D-H nor TLS13 cipher (so
-- handshake with lower security)
cipherListCredentialFallback :: [Cipher] -> Bool
cipherListCredentialFallback = all nonDH
where
nonDH x = case cipherKeyExchange x of
CipherKeyExchange_DHE_RSA -> False
CipherKeyExchange_DHE_DSA -> False
CipherKeyExchange_ECDHE_RSA -> False
CipherKeyExchange_ECDHE_ECDSA -> False
CipherKeyExchange_TLS13 -> False
_ -> True
-- We filter our allowed ciphers here according to dynamic credential lists.
-- Credentials 'creds' come from server parameters but also SNI callback.
-- When the key exchange requires a signature, we use a
-- subset of this list named 'sigCreds'. This list has been filtered in order
-- to remove certificates that are not compatible with hash/signature
-- restrictions (TLS 1.2).
getCiphers :: [Cipher] -> Credentials -> Credentials -> [Cipher]
getCiphers ciphers creds sigCreds = filter authorizedCKE ciphers
where
authorizedCKE cipher =
case cipherKeyExchange cipher of
CipherKeyExchange_RSA -> canEncryptRSA
CipherKeyExchange_DH_Anon -> True
CipherKeyExchange_DHE_RSA -> canSignRSA
CipherKeyExchange_DHE_DSA -> canSignDSA
CipherKeyExchange_ECDHE_RSA -> canSignRSA
CipherKeyExchange_ECDHE_ECDSA -> canSignECDSA
-- unimplemented: non ephemeral DH & ECDH.
-- Note, these *should not* be implemented, and have
-- (for example) been removed in OpenSSL 1.1.0
--
CipherKeyExchange_DH_DSA -> False
CipherKeyExchange_DH_RSA -> False
CipherKeyExchange_ECDH_ECDSA -> False
CipherKeyExchange_ECDH_RSA -> False
CipherKeyExchange_TLS13 -> False -- not reached
canSignDSA = KX_DSA `elem` signingAlgs
canSignRSA = KX_RSA `elem` signingAlgs
canSignECDSA = KX_ECDSA `elem` signingAlgs
canEncryptRSA = isJust $ credentialsFindForDecrypting creds
signingAlgs = credentialsListSigningAlgorithms sigCreds