{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.TLS.Handshake.Server.ClientHello12 (
    processClinetHello12,
) 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
import Network.TLS.Handshake.Server.Common
import Network.TLS.Handshake.Signature
import Network.TLS.Imports
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Types (Role (..))

----------------------------------------------------------------

-- TLS 1.2 or earlier
processClinetHello12
    :: ServerParams
    -> Context
    -> CH
    -> IO (Cipher, Maybe Credential)
processClinetHello12 :: ServerParams -> Context -> CH -> IO (Cipher, Maybe Credential)
processClinetHello12 ServerParams
sparams Context
ctx CH
ch = do
    let secureRenegotiation :: Bool
secureRenegotiation = Supported -> Bool
supportedSecureRenegotiation (Supported -> Bool) -> Supported -> Bool
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
secureRenegotiation (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> CH -> IO ()
checkSesecureRenegotiation Context
ctx CH
ch
    Maybe [Char]
serverName <- Context -> TLSSt (Maybe [Char]) -> IO (Maybe [Char])
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe [Char])
getClientSNI
    Credentials
extraCreds <- ServerHooks -> Maybe [Char] -> IO Credentials
onServerNameIndication (ServerParams -> ServerHooks
serverHooks ServerParams
sparams) Maybe [Char]
serverName
    let (Credentials
creds, Credentials
signatureCreds, [Cipher]
ciphersFilteredVersion) =
            ServerParams
-> Context
-> CH
-> Credentials
-> (Credentials, Credentials, [Cipher])
credsTriple ServerParams
sparams Context
ctx CH
ch Credentials
extraCreds
    -- The shared cipherlist can become empty after filtering for compatible
    -- creds, check now before calling onCipherChoosing, which does not handle
    -- empty lists.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Cipher] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Cipher]
ciphersFilteredVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"no cipher in common with the TLS 1.2 client" AlertDescription
HandshakeFailure
    let usedCipher :: Cipher
usedCipher = ServerHooks -> Version -> [Cipher] -> Cipher
onCipherChoosing (ServerParams -> ServerHooks
serverHooks ServerParams
sparams) Version
TLS12 [Cipher]
ciphersFilteredVersion
    Maybe Credential
mcred <- Cipher -> Credentials -> Credentials -> IO (Maybe Credential)
chooseCreds Cipher
usedCipher Credentials
creds Credentials
signatureCreds
    (Cipher, Maybe Credential) -> IO (Cipher, Maybe Credential)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cipher
usedCipher, Maybe Credential
mcred)

checkSesecureRenegotiation :: Context -> CH -> IO ()
checkSesecureRenegotiation :: Context -> CH -> IO ()
checkSesecureRenegotiation Context
ctx CH{[CipherID]
[ExtensionRaw]
Session
chSession :: Session
chCiphers :: [CipherID]
chExtensions :: [ExtensionRaw]
chSession :: CH -> Session
chCiphers :: CH -> [CipherID]
chExtensions :: CH -> [ExtensionRaw]
..} = do
    -- RFC 5746: secure renegotiation
    -- TLS_EMPTY_RENEGOTIATION_INFO_SCSV: {0x00, 0xFF}
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (CipherID
0xff CipherID -> [CipherID] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CipherID]
chCiphers) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Bool -> TLSSt ()
setSecureRenegotiation Bool
True
    case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_SecureRenegotiation [ExtensionRaw]
chExtensions of
        Just ByteString
content -> Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            ByteString
cvd <- Role -> TLSSt ByteString
getVerifyData Role
ClientRole
            let bs :: ByteString
bs = SecureRenegotiation -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode (ByteString -> ByteString -> SecureRenegotiation
SecureRenegotiation ByteString
cvd ByteString
"")
            Bool -> TLSSt () -> TLSSt ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
content) (TLSSt () -> TLSSt ()) -> TLSSt () -> TLSSt ()
forall a b. (a -> b) -> a -> b
$
                TLSError -> TLSSt ()
forall a. TLSError -> TLSSt a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TLSError -> TLSSt ()) -> TLSError -> TLSSt ()
forall a b. (a -> b) -> a -> b
$
                    [Char] -> AlertDescription -> TLSError
Error_Protocol
                        ([Char]
"client verified data not matching: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
cvd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
content)
                        AlertDescription
HandshakeFailure

            Bool -> TLSSt ()
setSecureRenegotiation Bool
True
        Maybe ByteString
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

----------------------------------------------------------------

credsTriple
    :: ServerParams
    -> Context
    -> CH
    -> Credentials
    -> (Credentials, Credentials, [Cipher])
credsTriple :: ServerParams
-> Context
-> CH
-> Credentials
-> (Credentials, Credentials, [Cipher])
credsTriple ServerParams
sparams Context
ctx CH{[CipherID]
[ExtensionRaw]
Session
chSession :: CH -> Session
chCiphers :: CH -> [CipherID]
chExtensions :: CH -> [ExtensionRaw]
chSession :: Session
chCiphers :: [CipherID]
chExtensions :: [ExtensionRaw]
..} Credentials
extraCreds
    | [Cipher] -> Bool
cipherListCredentialFallback [Cipher]
cltCiphers = (Credentials
allCreds, Credentials
sigAllCreds, [Cipher]
allCiphers)
    | Bool
otherwise = (Credentials
cltCreds, Credentials
sigCltCreds, [Cipher]
cltCiphers)
  where
    commonCiphers :: Credentials -> Credentials -> [Cipher]
commonCiphers Credentials
creds Credentials
sigCreds = (Cipher -> Bool) -> [Cipher] -> [Cipher]
forall a. (a -> Bool) -> [a] -> [a]
filter ((CipherID -> [CipherID] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CipherID]
chCiphers) (CipherID -> Bool) -> (Cipher -> CipherID) -> Cipher -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cipher -> CipherID
cipherID) (ServerParams -> Credentials -> Credentials -> [Cipher]
getCiphers ServerParams
sparams Credentials
creds Credentials
sigCreds)

    allCreds :: Credentials
allCreds =
        (Credential -> Bool) -> Credentials -> Credentials
filterCredentials (Version -> [ExtensionRaw] -> Credential -> Bool
isCredentialAllowed Version
TLS12 [ExtensionRaw]
chExtensions) (Credentials -> Credentials) -> Credentials -> Credentials
forall a b. (a -> b) -> a -> b
$
            Credentials
extraCreds Credentials -> Credentials -> Credentials
forall a. Monoid a => a -> a -> a
`mappend` Shared -> Credentials
sharedCredentials (Context -> Shared
ctxShared Context
ctx)

    -- 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 evalutated from
    -- the resulting credentials.

    possibleGroups :: [Group]
possibleGroups = Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon Context
ctx [ExtensionRaw]
chExtensions
    possibleECGroups :: [Group]
possibleECGroups = [Group]
possibleGroups [Group] -> [Group] -> [Group]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableECGroups
    possibleFFGroups :: [Group]
possibleFFGroups = [Group]
possibleGroups [Group] -> [Group] -> [Group]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableFFGroups
    hasCommonGroupForECDHE :: Bool
hasCommonGroupForECDHE = Bool -> Bool
not ([Group] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
possibleECGroups)
    hasCommonGroupForFFDHE :: Bool
hasCommonGroupForFFDHE = Bool -> Bool
not ([Group] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
possibleFFGroups)
    hasCustomGroupForFFDHE :: Bool
hasCustomGroupForFFDHE = Maybe DHParams -> Bool
forall a. Maybe a -> Bool
isJust (ServerParams -> Maybe DHParams
serverDHEParams ServerParams
sparams)
    canFFDHE :: Bool
canFFDHE = Bool
hasCustomGroupForFFDHE Bool -> Bool -> Bool
|| Bool
hasCommonGroupForFFDHE
    hasCommonGroup :: Cipher -> Bool
hasCommonGroup Cipher
cipher =
        case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher of
            CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> Bool
canFFDHE
            CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> Bool
canFFDHE
            CipherKeyExchangeType
CipherKeyExchange_DHE_DSA -> Bool
canFFDHE
            CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> Bool
hasCommonGroupForECDHE
            CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> Bool
hasCommonGroupForECDHE
            CipherKeyExchangeType
_ -> Bool
True -- group not used

    -- Ciphers are selected according to TLS version, availability of
    -- (EC)DHE group and credential depending on key exchange.
    cipherAllowed :: Cipher -> Bool
cipherAllowed Cipher
cipher = Version -> Cipher -> Bool
cipherAllowedForVersion Version
TLS12 Cipher
cipher Bool -> Bool -> Bool
&& Cipher -> Bool
hasCommonGroup Cipher
cipher
    selectCipher :: Credentials -> Credentials -> [Cipher]
selectCipher Credentials
credentials Credentials
signatureCredentials = (Cipher -> Bool) -> [Cipher] -> [Cipher]
forall a. (a -> Bool) -> [a] -> [a]
filter Cipher -> Bool
cipherAllowed (Credentials -> Credentials -> [Cipher]
commonCiphers Credentials
credentials Credentials
signatureCredentials)

    -- Build a list of all hash/signature algorithms in common between
    -- client and server.
    possibleHashSigAlgs :: [HashAndSignatureAlgorithm]
possibleHashSigAlgs = Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon Context
ctx [ExtensionRaw]
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 :: Credential -> Maybe Int
signingRank Credential
cred =
        case Credential -> Maybe PubKey
credentialDigitalSignatureKey Credential
cred of
            Just PubKey
pub -> (HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (PubKey
pub PubKey -> HashAndSignatureAlgorithm -> Bool
`signatureCompatible`) [HashAndSignatureAlgorithm]
possibleHashSigAlgs
            Maybe PubKey
Nothing -> Maybe Int
forall a. Maybe a
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 :: Credentials
cltCreds = [ExtensionRaw] -> Credentials -> Credentials
filterCredentialsWithHashSignatures [ExtensionRaw]
chExtensions Credentials
allCreds
    sigCltCreds :: Credentials
sigCltCreds = (Credential -> Maybe Int) -> Credentials -> Credentials
forall a.
Ord a =>
(Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials Credential -> Maybe Int
signingRank Credentials
cltCreds
    sigAllCreds :: Credentials
sigAllCreds = (Credential -> Maybe Int) -> Credentials -> Credentials
forall a.
Ord a =>
(Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials Credential -> Maybe Int
signingRank Credentials
allCreds
    cltCiphers :: [Cipher]
cltCiphers = Credentials -> Credentials -> [Cipher]
selectCipher Credentials
cltCreds Credentials
sigCltCreds
    allCiphers :: [Cipher]
allCiphers = Credentials -> Credentials -> [Cipher]
selectCipher Credentials
allCreds Credentials
sigAllCreds

chooseCreds :: Cipher -> Credentials -> Credentials -> IO (Maybe Credential)
chooseCreds :: Cipher -> Credentials -> Credentials -> IO (Maybe Credential)
chooseCreds Cipher
usedCipher Credentials
creds Credentials
signatureCreds = case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
usedCipher of
    CipherKeyExchangeType
CipherKeyExchange_RSA -> Maybe Credential -> IO (Maybe Credential)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Credential -> IO (Maybe Credential))
-> Maybe Credential -> IO (Maybe Credential)
forall a b. (a -> b) -> a -> b
$ Credentials -> Maybe Credential
credentialsFindForDecrypting Credentials
creds
    CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> Maybe Credential -> IO (Maybe Credential)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Credential
forall a. Maybe a
Nothing
    CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> Maybe Credential -> IO (Maybe Credential)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Credential -> IO (Maybe Credential))
-> Maybe Credential -> IO (Maybe Credential)
forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_RSA Credentials
signatureCreds
    CipherKeyExchangeType
CipherKeyExchange_DHE_DSA -> Maybe Credential -> IO (Maybe Credential)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Credential -> IO (Maybe Credential))
-> Maybe Credential -> IO (Maybe Credential)
forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_DSA Credentials
signatureCreds
    CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> Maybe Credential -> IO (Maybe Credential)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Credential -> IO (Maybe Credential))
-> Maybe Credential -> IO (Maybe Credential)
forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_RSA Credentials
signatureCreds
    CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> Maybe Credential -> IO (Maybe Credential)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Credential -> IO (Maybe Credential))
-> Maybe Credential -> IO (Maybe Credential)
forall a b. (a -> b) -> a -> b
$ KeyExchangeSignatureAlg -> Credentials -> Maybe Credential
credentialsFindForSigning KeyExchangeSignatureAlg
KX_ECDSA Credentials
signatureCreds
    CipherKeyExchangeType
_ ->
        TLSError -> IO (Maybe Credential)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (Maybe Credential))
-> TLSError -> IO (Maybe Credential)
forall a b. (a -> b) -> a -> b
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"key exchange algorithm not implemented" AlertDescription
HandshakeFailure

----------------------------------------------------------------

hashAndSignaturesInCommon
    :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon Context
ctx [ExtensionRaw]
exts =
    let cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_SignatureAlgorithms [ExtensionRaw]
exts
            Maybe ByteString
-> (ByteString -> Maybe SignatureAlgorithms)
-> Maybe SignatureAlgorithms
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> ByteString -> Maybe SignatureAlgorithms
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
            -- See Section 7.4.1.4.1 of RFC 5246.
            Maybe SignatureAlgorithms
Nothing ->
                [ (HashAlgorithm
HashSHA1, SignatureAlgorithm
SignatureECDSA)
                , (HashAlgorithm
HashSHA1, SignatureAlgorithm
SignatureRSA)
                , (HashAlgorithm
HashSHA1, SignatureAlgorithm
SignatureDSA)
                ]
            Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm]
sas
        sHashSigs :: [HashAndSignatureAlgorithm]
sHashSigs = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
-> Supported -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
     in -- The values in the "signature_algorithms" extension
        -- are in descending order of preference.
        -- However here the algorithms are selected according
        -- to server preference in 'supportedHashSignatures'.
        [HashAndSignatureAlgorithm]
sHashSigs [HashAndSignatureAlgorithm]
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [HashAndSignatureAlgorithm]
cHashSigs

negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon :: Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon Context
ctx [ExtensionRaw]
exts = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_SupportedGroups [ExtensionRaw]
exts
    Maybe ByteString
-> (ByteString -> Maybe SupportedGroups) -> Maybe SupportedGroups
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> ByteString -> Maybe SupportedGroups
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
    Just (SupportedGroups [Group]
clientGroups) ->
        let serverGroups :: [Group]
serverGroups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
         in [Group]
serverGroups [Group] -> [Group] -> [Group]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
clientGroups
    Maybe SupportedGroups
_ -> []

----------------------------------------------------------------

filterSortCredentials
    :: Ord a => (Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials :: forall a.
Ord a =>
(Credential -> Maybe a) -> Credentials -> Credentials
filterSortCredentials Credential -> Maybe a
rankFun (Credentials [Credential]
creds) =
    let orderedPairs :: [(Maybe a, Credential)]
orderedPairs = ((Maybe a, Credential) -> Maybe a)
-> [(Maybe a, Credential)] -> [(Maybe a, Credential)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Maybe a, Credential) -> Maybe a
forall a b. (a, b) -> a
fst [(Credential -> Maybe a
rankFun Credential
cred, Credential
cred) | Credential
cred <- [Credential]
creds]
     in [Credential] -> Credentials
Credentials [Credential
cred | (Just a
_, Credential
cred) <- [(Maybe a, Credential)]
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 :: [Cipher] -> Bool
cipherListCredentialFallback = (Cipher -> Bool) -> [Cipher] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Cipher -> Bool
nonDH
  where
    nonDH :: Cipher -> Bool
nonDH Cipher
x = case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
x of
        CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> Bool
False
        CipherKeyExchangeType
CipherKeyExchange_DHE_DSA -> Bool
False
        CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> Bool
False
        CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> Bool
False
        CipherKeyExchangeType
CipherKeyExchange_TLS13 -> Bool
False
        CipherKeyExchangeType
_ -> Bool
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 :: ServerParams -> Credentials -> Credentials -> [Cipher]
getCiphers :: ServerParams -> Credentials -> Credentials -> [Cipher]
getCiphers ServerParams
sparams Credentials
creds Credentials
sigCreds = (Cipher -> Bool) -> [Cipher] -> [Cipher]
forall a. (a -> Bool) -> [a] -> [a]
filter Cipher -> Bool
authorizedCKE (Supported -> [Cipher]
supportedCiphers (Supported -> [Cipher]) -> Supported -> [Cipher]
forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams)
  where
    authorizedCKE :: Cipher -> Bool
authorizedCKE Cipher
cipher =
        case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
cipher of
            CipherKeyExchangeType
CipherKeyExchange_RSA -> Bool
canEncryptRSA
            CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> Bool
True
            CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> Bool
canSignRSA
            CipherKeyExchangeType
CipherKeyExchange_DHE_DSA -> Bool
canSignDSA
            CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> Bool
canSignRSA
            CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> Bool
canSignECDSA
            -- unimplemented: non ephemeral DH & ECDH.
            -- Note, these *should not* be implemented, and have
            -- (for example) been removed in OpenSSL 1.1.0
            --
            CipherKeyExchangeType
CipherKeyExchange_DH_DSA -> Bool
False
            CipherKeyExchangeType
CipherKeyExchange_DH_RSA -> Bool
False
            CipherKeyExchangeType
CipherKeyExchange_ECDH_ECDSA -> Bool
False
            CipherKeyExchangeType
CipherKeyExchange_ECDH_RSA -> Bool
False
            CipherKeyExchangeType
CipherKeyExchange_TLS13 -> Bool
False -- not reached
    canSignDSA :: Bool
canSignDSA = KeyExchangeSignatureAlg
KX_DSA KeyExchangeSignatureAlg -> [KeyExchangeSignatureAlg] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
    canSignRSA :: Bool
canSignRSA = KeyExchangeSignatureAlg
KX_RSA KeyExchangeSignatureAlg -> [KeyExchangeSignatureAlg] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
    canSignECDSA :: Bool
canSignECDSA = KeyExchangeSignatureAlg
KX_ECDSA KeyExchangeSignatureAlg -> [KeyExchangeSignatureAlg] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyExchangeSignatureAlg]
signingAlgs
    canEncryptRSA :: Bool
canEncryptRSA = Maybe Credential -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Credential -> Bool) -> Maybe Credential -> Bool
forall a b. (a -> b) -> a -> b
$ Credentials -> Maybe Credential
credentialsFindForDecrypting Credentials
creds
    signingAlgs :: [KeyExchangeSignatureAlg]
signingAlgs = Credentials -> [KeyExchangeSignatureAlg]
credentialsListSigningAlgorithms Credentials
sigCreds