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

module Network.TLS.Handshake.Server.ServerHello12 (
    sendServerHello12,
) where

import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Context.Internal
import Network.TLS.Credentials
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake.Certificate
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Random
import Network.TLS.Handshake.Server.Common
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.Parameters
import Network.TLS.Session
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Types
import Network.TLS.X509 hiding (Certificate)

sendServerHello12
    :: ServerParams
    -> Context
    -> (Cipher, Maybe Credential)
    -> CH
    -> IO (Maybe SessionData)
sendServerHello12 :: ServerParams
-> Context
-> (Cipher, Maybe Credential)
-> CH
-> IO (Maybe SessionData)
sendServerHello12 ServerParams
sparams Context
ctx (Cipher
usedCipher, Maybe Credential
mcred) ch :: CH
ch@CH{[CipherID]
[ExtensionRaw]
Session
chSession :: Session
chCiphers :: [CipherID]
chExtensions :: [ExtensionRaw]
chExtensions :: CH -> [ExtensionRaw]
chCiphers :: CH -> [CipherID]
chSession :: CH -> Session
..} = do
    resumeSessionData <- Context -> CH -> IO (Maybe SessionData)
recoverSessionData Context
ctx CH
ch
    case resumeSessionData of
        Maybe SessionData
Nothing -> do
            serverSession <- Context -> IO Session
newSession Context
ctx
            usingState_ ctx $ setSession serverSession
            serverhello <-
                makeServerHello sparams ctx usedCipher mcred chExtensions serverSession
            build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions
            let ff = Handshake
serverhello Handshake -> [Handshake] -> [Handshake]
forall a. a -> [a] -> [a]
: [Handshake] -> [Handshake]
build [Handshake
ServerHelloDone]
            sendPacket12 ctx $ Handshake ff
            contextFlush ctx
        Just SessionData
sessionData -> do
            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
                Session -> TLSSt ()
setSession Session
chSession
                Bool -> TLSSt ()
setTLS12SessionResuming Bool
True
            serverhello <-
                ServerParams
-> Context
-> Cipher
-> Maybe Credential
-> [ExtensionRaw]
-> Session
-> IO Handshake
makeServerHello ServerParams
sparams Context
ctx Cipher
usedCipher Maybe Credential
mcred [ExtensionRaw]
chExtensions Session
chSession
            sendPacket12 ctx $ Handshake [serverhello]
            let mainSecret = SessionData -> ByteString
sessionSecret SessionData
sessionData
            usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret
            logKey ctx $ MainSecret mainSecret
            sendCCSandFinished ctx ServerRole
    return resumeSessionData

recoverSessionData :: Context -> CH -> IO (Maybe SessionData)
recoverSessionData :: Context -> CH -> IO (Maybe SessionData)
recoverSessionData Context
ctx CH{[CipherID]
[ExtensionRaw]
Session
chExtensions :: CH -> [ExtensionRaw]
chCiphers :: CH -> [CipherID]
chSession :: CH -> Session
chSession :: Session
chCiphers :: [CipherID]
chExtensions :: [ExtensionRaw]
..} = do
    serverName <- Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
getClientSNI
    ems <- processExtendedMainSecret ctx TLS12 MsgTClientHello chExtensions
    let mSessionTicket =
            ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_SessionTicket [ExtensionRaw]
chExtensions
                Maybe ByteString
-> (ByteString -> Maybe SessionTicket) -> Maybe SessionTicket
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 SessionTicket
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello
        mticket = case Maybe SessionTicket
mSessionTicket of
            Maybe SessionTicket
Nothing -> Maybe ByteString
forall a. Maybe a
Nothing
            Just (SessionTicket ByteString
ticket) -> ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
ticket
        midentity = Maybe ByteString -> Session -> Maybe ByteString
ticketOrSessionID12 Maybe ByteString
mticket Session
chSession
    case midentity of
        Maybe ByteString
Nothing -> Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
        Just ByteString
identity -> do
            sd <- SessionManager -> ByteString -> IO (Maybe SessionData)
sessionResume (Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx) ByteString
identity
            validateSession chCiphers serverName ems sd

validateSession
    :: [CipherID]
    -> Maybe HostName
    -> Bool
    -> Maybe SessionData
    -> IO (Maybe SessionData)
validateSession :: [CipherID]
-> Maybe HostName
-> Bool
-> Maybe SessionData
-> IO (Maybe SessionData)
validateSession [CipherID]
_ Maybe HostName
_ Bool
_ Maybe SessionData
Nothing = Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
validateSession [CipherID]
ciphers Maybe HostName
sni Bool
ems m :: Maybe SessionData
m@(Just SessionData
sd)
    -- SessionData parameters are assumed to match the local server configuration
    -- so we need to compare only to ClientHello inputs.  Abbreviated handshake
    -- uses the same server_name than full handshake so the same
    -- credentials (and thus ciphers) are available.
    | Version
TLS12 Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< SessionData -> Version
sessionVersion SessionData
sd = Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing -- fixme
    | SessionData -> CipherID
sessionCipher SessionData
sd CipherID -> [CipherID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CipherID]
ciphers = Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
    | Maybe HostName -> Bool
forall a. Maybe a -> Bool
isJust Maybe HostName
sni Bool -> Bool -> Bool
&& SessionData -> Maybe HostName
sessionClientSNI SessionData
sd Maybe HostName -> Maybe HostName -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe HostName
sni = Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
    | Bool
ems Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
emsSession = Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
forall a. Maybe a
Nothing
    | Bool -> Bool
not Bool
ems Bool -> Bool -> Bool
&& Bool
emsSession =
        let err :: HostName
err = HostName
"client resumes an EMS session without EMS"
         in TLSError -> IO (Maybe SessionData)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (Maybe SessionData))
-> TLSError -> IO (Maybe SessionData)
forall a b. (a -> b) -> a -> b
$ HostName -> AlertDescription -> TLSError
Error_Protocol HostName
err AlertDescription
HandshakeFailure
    | Bool
otherwise = Maybe SessionData -> IO (Maybe SessionData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SessionData
m
  where
    emsSession :: Bool
emsSession = SessionFlag
SessionEMS SessionFlag -> [SessionFlag] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` SessionData -> [SessionFlag]
sessionFlags SessionData
sd

sendServerFirstFlight
    :: ServerParams
    -> Context
    -> Cipher
    -> Maybe Credential
    -> [ExtensionRaw]
    -> IO ([Handshake] -> [Handshake])
sendServerFirstFlight :: ServerParams
-> Context
-> Cipher
-> Maybe Credential
-> [ExtensionRaw]
-> IO ([Handshake] -> [Handshake])
sendServerFirstFlight ServerParams
sparams Context
ctx Cipher
usedCipher Maybe Credential
mcred [ExtensionRaw]
chExts = do
    let b0 :: a -> a
b0 = a -> a
forall a. a -> a
id
    let cc :: CertificateChain
cc = case Maybe Credential
mcred of
            Just (CertificateChain
srvCerts, PrivKey
_) -> CertificateChain
srvCerts
            Maybe Credential
_ -> [SignedExact Certificate] -> CertificateChain
CertificateChain []
    let b1 :: [Handshake] -> [Handshake]
b1 = [Handshake] -> [Handshake]
forall a. a -> a
b0 ([Handshake] -> [Handshake])
-> ([Handshake] -> [Handshake]) -> [Handshake] -> [Handshake]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertificateChain -> Handshake
Certificate CertificateChain
cc Handshake -> [Handshake] -> [Handshake]
forall a. a -> [a] -> [a]
:)
    Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setServerCertificateChain CertificateChain
cc

    -- send server key exchange if needed
    skx <- case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
usedCipher of
        CipherKeyExchangeType
CipherKeyExchange_DH_Anon -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
forall a. a -> Maybe a
Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
-> IO ServerKeyXchgAlgorithmData
-> IO (Maybe ServerKeyXchgAlgorithmData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ServerKeyXchgAlgorithmData
generateSKX_DH_Anon
        CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
forall a. a -> Maybe a
Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
-> IO ServerKeyXchgAlgorithmData
-> IO (Maybe ServerKeyXchgAlgorithmData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_DHE KeyExchangeSignatureAlg
KX_RSA
        CipherKeyExchangeType
CipherKeyExchange_DHE_DSA -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
forall a. a -> Maybe a
Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
-> IO ServerKeyXchgAlgorithmData
-> IO (Maybe ServerKeyXchgAlgorithmData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_DHE KeyExchangeSignatureAlg
KX_DSA
        CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
forall a. a -> Maybe a
Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
-> IO ServerKeyXchgAlgorithmData
-> IO (Maybe ServerKeyXchgAlgorithmData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_ECDHE KeyExchangeSignatureAlg
KX_RSA
        CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData
forall a. a -> Maybe a
Just (ServerKeyXchgAlgorithmData -> Maybe ServerKeyXchgAlgorithmData)
-> IO ServerKeyXchgAlgorithmData
-> IO (Maybe ServerKeyXchgAlgorithmData)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_ECDHE KeyExchangeSignatureAlg
KX_ECDSA
        CipherKeyExchangeType
_ -> Maybe ServerKeyXchgAlgorithmData
-> IO (Maybe ServerKeyXchgAlgorithmData)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ServerKeyXchgAlgorithmData
forall a. Maybe a
Nothing
    let b2 = case Maybe ServerKeyXchgAlgorithmData
skx of
            Maybe ServerKeyXchgAlgorithmData
Nothing -> [Handshake] -> [Handshake]
b1
            Just ServerKeyXchgAlgorithmData
kx -> [Handshake] -> [Handshake]
b1 ([Handshake] -> [Handshake])
-> ([Handshake] -> [Handshake]) -> [Handshake] -> [Handshake]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ServerKeyXchgAlgorithmData -> Handshake
ServerKeyXchg ServerKeyXchgAlgorithmData
kx Handshake -> [Handshake] -> [Handshake]
forall a. a -> [a] -> [a]
:)

    -- FIXME we don't do this on a Anonymous server

    -- When configured, send a certificate request with the DNs of all
    -- configured CA certificates.
    --
    -- Client certificates MUST NOT be accepted if not requested.
    --
    if serverWantClientCert sparams
        then do
            let (certTypes, hashSigs) =
                    let as = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
-> Supported -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
                     in (nub $ mapMaybe hashSigToCertType as, as)
                creq =
                    [CertificateType]
-> [HashAndSignatureAlgorithm] -> [DistinguishedName] -> Handshake
CertRequest
                        [CertificateType]
certTypes
                        [HashAndSignatureAlgorithm]
hashSigs
                        ((SignedExact Certificate -> DistinguishedName)
-> [SignedExact Certificate] -> [DistinguishedName]
forall a b. (a -> b) -> [a] -> [b]
map SignedExact Certificate -> DistinguishedName
extractCAname ([SignedExact Certificate] -> [DistinguishedName])
-> [SignedExact Certificate] -> [DistinguishedName]
forall a b. (a -> b) -> a -> b
$ ServerParams -> [SignedExact Certificate]
serverCACertificates ServerParams
sparams)
            usingHState ctx $ setCertReqSent True
            return $ b2 . (creq :)
        else return b2
  where
    setup_DHE :: IO ServerDHParams
setup_DHE = do
        let possibleFFGroups :: [Group]
possibleFFGroups = Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon Context
ctx [ExtensionRaw]
chExts [Group] -> [Group] -> [Group]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableFFGroups
        (dhparams, priv, pub) <-
            case [Group]
possibleFFGroups of
                [] ->
                    let dhparams :: DHParams
dhparams = Maybe DHParams -> DHParams
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe DHParams -> DHParams) -> Maybe DHParams -> DHParams
forall a b. (a -> b) -> a -> b
$ ServerParams -> Maybe DHParams
serverDHEParams ServerParams
sparams
                     in case DHParams -> Maybe Group
findFiniteFieldGroup DHParams
dhparams of
                            Just Group
g -> do
                                Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Group -> HandshakeM ()
setSupportedGroup Group
g
                                Context -> Group -> IO (DHParams, DHPrivate, DHPublic)
generateFFDHE Context
ctx Group
g
                            Maybe Group
Nothing -> do
                                (priv, pub) <- Context -> DHParams -> IO (DHPrivate, DHPublic)
generateDHE Context
ctx DHParams
dhparams
                                return (dhparams, priv, pub)
                Group
g : [Group]
_ -> do
                    Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Group -> HandshakeM ()
setSupportedGroup Group
g
                    Context -> Group -> IO (DHParams, DHPrivate, DHPublic)
generateFFDHE Context
ctx Group
g

        let serverParams = DHParams -> DHPublic -> ServerDHParams
serverDHParamsFrom DHParams
dhparams DHPublic
pub

        usingHState ctx $ setServerDHParams serverParams
        usingHState ctx $ setDHPrivate priv
        return serverParams

    -- Choosing a hash algorithm to sign (EC)DHE parameters
    -- in ServerKeyExchange. Hash algorithm is not suggested by
    -- the chosen cipher suite. So, it should be selected based on
    -- the "signature_algorithms" extension in a client hello.
    -- If RSA is also used for key exchange, this function is
    -- not called.
    decideHashSig :: PubKey -> m HashAndSignatureAlgorithm
decideHashSig PubKey
pubKey = do
        let hashSigs :: [HashAndSignatureAlgorithm]
hashSigs = Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon Context
ctx [ExtensionRaw]
chExts
        case (HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a. (a -> Bool) -> [a] -> [a]
filter (PubKey
pubKey PubKey -> HashAndSignatureAlgorithm -> Bool
`signatureCompatible`) [HashAndSignatureAlgorithm]
hashSigs of
            [] -> HostName -> m HashAndSignatureAlgorithm
forall a. HasCallStack => HostName -> a
error (HostName
"no hash signature for " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ PubKey -> HostName
pubkeyType PubKey
pubKey)
            HashAndSignatureAlgorithm
x : [HashAndSignatureAlgorithm]
_ -> HashAndSignatureAlgorithm -> m HashAndSignatureAlgorithm
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return HashAndSignatureAlgorithm
x

    generateSKX_DHE :: KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_DHE KeyExchangeSignatureAlg
kxsAlg = do
        serverParams <- IO ServerDHParams
setup_DHE
        pubKey <- getLocalPublicKey ctx
        mhashSig <- decideHashSig pubKey
        signed <- digitallySignDHParams ctx serverParams pubKey mhashSig
        case kxsAlg of
            KeyExchangeSignatureAlg
KX_RSA -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData)
-> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
forall a b. (a -> b) -> a -> b
$ ServerDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_DHE_RSA ServerDHParams
serverParams DigitallySigned
signed
            KeyExchangeSignatureAlg
KX_DSA -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData)
-> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
forall a b. (a -> b) -> a -> b
$ ServerDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_DHE_DSA ServerDHParams
serverParams DigitallySigned
signed
            KeyExchangeSignatureAlg
_ ->
                HostName -> IO ServerKeyXchgAlgorithmData
forall a. HasCallStack => HostName -> a
error (HostName
"generate skx_dhe unsupported key exchange signature: " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ KeyExchangeSignatureAlg -> HostName
forall a. Show a => a -> HostName
show KeyExchangeSignatureAlg
kxsAlg)

    generateSKX_DH_Anon :: IO ServerKeyXchgAlgorithmData
generateSKX_DH_Anon = ServerDHParams -> ServerKeyXchgAlgorithmData
SKX_DH_Anon (ServerDHParams -> ServerKeyXchgAlgorithmData)
-> IO ServerDHParams -> IO ServerKeyXchgAlgorithmData
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ServerDHParams
setup_DHE

    setup_ECDHE :: Group -> IO ServerECDHParams
setup_ECDHE Group
grp = do
        Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Group -> HandshakeM ()
setSupportedGroup Group
grp
        (srvpri, srvpub) <- Context -> Group -> IO (GroupPrivate, GroupPublic)
generateECDHE Context
ctx Group
grp
        let serverParams = Group -> GroupPublic -> ServerECDHParams
ServerECDHParams Group
grp GroupPublic
srvpub
        usingHState ctx $ setServerECDHParams serverParams
        usingHState ctx $ setGroupPrivate srvpri
        return serverParams

    generateSKX_ECDHE :: KeyExchangeSignatureAlg -> IO ServerKeyXchgAlgorithmData
generateSKX_ECDHE KeyExchangeSignatureAlg
kxsAlg = do
        let possibleECGroups :: [Group]
possibleECGroups = Context -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon Context
ctx [ExtensionRaw]
chExts [Group] -> [Group] -> [Group]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
availableECGroups
        grp <- case [Group]
possibleECGroups of
            [] -> TLSError -> IO Group
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Group) -> TLSError -> IO Group
forall a b. (a -> b) -> a -> b
$ HostName -> AlertDescription -> TLSError
Error_Protocol HostName
"no common group" AlertDescription
HandshakeFailure
            Group
g : [Group]
_ -> Group -> IO Group
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Group
g
        serverParams <- setup_ECDHE grp
        pubKey <- getLocalPublicKey ctx
        mhashSig <- decideHashSig pubKey
        signed <- digitallySignECDHParams ctx serverParams pubKey mhashSig
        case kxsAlg of
            KeyExchangeSignatureAlg
KX_RSA -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData)
-> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_ECDHE_RSA ServerECDHParams
serverParams DigitallySigned
signed
            KeyExchangeSignatureAlg
KX_ECDSA -> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData)
-> ServerKeyXchgAlgorithmData -> IO ServerKeyXchgAlgorithmData
forall a b. (a -> b) -> a -> b
$ ServerECDHParams -> DigitallySigned -> ServerKeyXchgAlgorithmData
SKX_ECDHE_ECDSA ServerECDHParams
serverParams DigitallySigned
signed
            KeyExchangeSignatureAlg
_ ->
                HostName -> IO ServerKeyXchgAlgorithmData
forall a. HasCallStack => HostName -> a
error (HostName
"generate skx_ecdhe unsupported key exchange signature: " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ KeyExchangeSignatureAlg -> HostName
forall a. Show a => a -> HostName
show KeyExchangeSignatureAlg
kxsAlg)

---
-- When the client sends a certificate, check whether
-- it is acceptable for the application.
--
---
makeServerHello
    :: ServerParams
    -> Context
    -> Cipher
    -> Maybe Credential
    -> [ExtensionRaw]
    -> Session
    -> IO Handshake
makeServerHello :: ServerParams
-> Context
-> Cipher
-> Maybe Credential
-> [ExtensionRaw]
-> Session
-> IO Handshake
makeServerHello ServerParams
sparams Context
ctx Cipher
usedCipher Maybe Credential
mcred [ExtensionRaw]
chExts Session
session = do
    resuming <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS12SessionResuming
    srand <-
        serverRandom ctx TLS12 $ supportedVersions $ serverSupported sparams
    case mcred of
        Just Credential
cred -> Context -> Credential -> IO ()
forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
storePrivInfoServer Context
ctx Credential
cred
        Maybe Credential
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- return a sensible error

    -- in TLS12, we need to check as well the certificates we are sending if they have in the extension
    -- the necessary bits set.
    secReneg <- usingState_ ctx getSecureRenegotiation
    secRengExt <-
        if secReneg
            then do
                vd <- usingState_ ctx $ do
                    cvd <- getVerifyData ClientRole
                    svd <- getVerifyData ServerRole
                    return $ extensionEncode $ SecureRenegotiation cvd svd
                return [ExtensionRaw EID_SecureRenegotiation vd]
            else return []
    ems <- usingHState ctx getExtendedMainSecret
    let emsExt
            | Bool
ems =
                let raw :: ByteString
raw = ExtendedMainSecret -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode ExtendedMainSecret
ExtendedMainSecret
                 in [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_ExtendedMainSecret ByteString
raw]
            | Bool
otherwise = []
    protoExt <- applicationProtocol ctx chExts sparams
    sniExt <- do
        if resuming
            then return []
            else do
                msni <- usingState_ ctx getClientSNI
                case msni of
                    -- RFC6066: In this event, the server SHALL include
                    -- an extension of type "server_name" in the
                    -- (extended) server hello. The "extension_data"
                    -- field of this extension SHALL be empty.
                    Just HostName
_ -> [ExtensionRaw] -> IO [ExtensionRaw]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_ServerName ByteString
""]
                    Maybe HostName
Nothing -> [ExtensionRaw] -> IO [ExtensionRaw]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    let useTicket = SessionManager -> Bool
sessionUseTicket (SessionManager -> Bool) -> SessionManager -> Bool
forall a b. (a -> b) -> a -> b
$ Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ ServerParams -> Shared
serverShared ServerParams
sparams
        ticktExt
            | Bool -> Bool
not Bool
resuming Bool -> Bool -> Bool
&& Bool
useTicket =
                let raw :: ByteString
raw = SessionTicket -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode (SessionTicket -> ByteString) -> SessionTicket -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> SessionTicket
SessionTicket ByteString
""
                 in [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_SessionTicket ByteString
raw]
            | Bool
otherwise = []
    let shExts =
            Shared -> [ExtensionRaw]
sharedHelloExtensions (ServerParams -> Shared
serverShared ServerParams
sparams)
                [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
secRengExt
                [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
emsExt
                [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
protoExt
                [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
sniExt
                [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
ticktExt
    usingState_ ctx $ setVersion TLS12
    usingHState ctx $
        setServerHelloParameters TLS12 srand usedCipher nullCompression
    return $
        ServerHello
            TLS12
            srand
            session
            (cipherID usedCipher)
            (compressionID nullCompression)
            shExts

hashAndSignaturesInCommon
    :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon :: Context -> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon Context
ctx [ExtensionRaw]
chExts =
    let cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_SignatureAlgorithms [ExtensionRaw]
chExts
            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]
chExts = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_SupportedGroups [ExtensionRaw]
chExts
    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
_ -> []