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

recoverSessionData :: Context -> CH -> IO (Maybe SessionData)
recoverSessionData :: Context -> CH -> IO (Maybe SessionData)
recoverSessionData Context
ctx CH{[CipherID]
[ExtensionRaw]
Session
chSession :: CH -> Session
chCiphers :: CH -> [CipherID]
chExtensions :: CH -> [ExtensionRaw]
chSession :: Session
chCiphers :: [CipherID]
chExtensions :: [ExtensionRaw]
..} = do
    Maybe HostName
serverName <- Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
getClientSNI
    Bool
ems <- Context -> Version -> MessageType -> [ExtensionRaw] -> IO Bool
forall (m :: * -> *).
MonadIO m =>
Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMainSecret Context
ctx Version
TLS12 MessageType
MsgTClientHello [ExtensionRaw]
chExtensions
    let mticket :: Maybe SessionTicket
mticket =
            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
    case Maybe SessionTicket
mticket of
        Just (SessionTicket ByteString
ticket) | ByteString
ticket ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
"" -> do
            Maybe SessionData
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
ticket
            [CipherID]
-> Maybe HostName
-> Bool
-> Maybe SessionData
-> IO (Maybe SessionData)
validateSession [CipherID]
chCiphers Maybe HostName
serverName Bool
ems Maybe SessionData
sd
        Maybe SessionTicket
_ -> case Session
chSession of
            (Session (Just ByteString
clientSessionId)) -> do
                Maybe SessionData
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
clientSessionId
                [CipherID]
-> Maybe HostName
-> Bool
-> Maybe SessionData
-> IO (Maybe SessionData)
validateSession [CipherID]
chCiphers Maybe HostName
serverName Bool
ems Maybe SessionData
sd
            (Session 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

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
    Maybe ServerKeyXchgAlgorithmData
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 :: [Handshake] -> [Handshake]
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 ServerParams -> Bool
serverWantClientCert ServerParams
sparams
        then do
            let ([CertificateType]
certTypes, [HashAndSignatureAlgorithm]
hashSigs) =
                    let as :: [HashAndSignatureAlgorithm]
as = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
-> Supported -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
                     in ([CertificateType] -> [CertificateType]
forall a. Eq a => [a] -> [a]
nub ([CertificateType] -> [CertificateType])
-> [CertificateType] -> [CertificateType]
forall a b. (a -> b) -> a -> b
$ (HashAndSignatureAlgorithm -> Maybe CertificateType)
-> [HashAndSignatureAlgorithm] -> [CertificateType]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HashAndSignatureAlgorithm -> Maybe CertificateType
hashSigToCertType [HashAndSignatureAlgorithm]
as, [HashAndSignatureAlgorithm]
as)
                creq :: Handshake
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)
            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
$ Bool -> HandshakeM ()
setCertReqSent Bool
True
            ([Handshake] -> [Handshake]) -> IO ([Handshake] -> [Handshake])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Handshake] -> [Handshake]) -> IO ([Handshake] -> [Handshake]))
-> ([Handshake] -> [Handshake]) -> IO ([Handshake] -> [Handshake])
forall a b. (a -> b) -> a -> b
$ [Handshake] -> [Handshake]
b2 ([Handshake] -> [Handshake])
-> ([Handshake] -> [Handshake]) -> [Handshake] -> [Handshake]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Handshake
creq Handshake -> [Handshake] -> [Handshake]
forall a. a -> [a] -> [a]
:)
        else ([Handshake] -> [Handshake]) -> IO ([Handshake] -> [Handshake])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Handshake] -> [Handshake]
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
dhparams, DHPrivate
priv, DHPublic
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
                                (DHPrivate
priv, DHPublic
pub) <- Context -> DHParams -> IO (DHPrivate, DHPublic)
generateDHE Context
ctx DHParams
dhparams
                                (DHParams, DHPrivate, DHPublic)
-> IO (DHParams, DHPrivate, DHPublic)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DHParams
dhparams, DHPrivate
priv, DHPublic
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 :: ServerDHParams
serverParams = DHParams -> DHPublic -> ServerDHParams
serverDHParamsFrom DHParams
dhparams DHPublic
pub

        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
$ ServerDHParams -> HandshakeM ()
setServerDHParams ServerDHParams
serverParams
        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
$ DHPrivate -> HandshakeM ()
setDHPrivate DHPrivate
priv
        ServerDHParams -> IO ServerDHParams
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerDHParams
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
        ServerDHParams
serverParams <- IO ServerDHParams
setup_DHE
        PubKey
pubKey <- Context -> IO PubKey
forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
        HashAndSignatureAlgorithm
mhashSig <- PubKey -> IO HashAndSignatureAlgorithm
forall {m :: * -> *}.
Monad m =>
PubKey -> m HashAndSignatureAlgorithm
decideHashSig PubKey
pubKey
        DigitallySigned
signed <- Context
-> ServerDHParams
-> PubKey
-> HashAndSignatureAlgorithm
-> IO DigitallySigned
digitallySignDHParams Context
ctx ServerDHParams
serverParams PubKey
pubKey HashAndSignatureAlgorithm
mhashSig
        case KeyExchangeSignatureAlg
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
        (GroupPrivate
srvpri, GroupPublic
srvpub) <- Context -> Group -> IO (GroupPrivate, GroupPublic)
generateECDHE Context
ctx Group
grp
        let serverParams :: ServerECDHParams
serverParams = Group -> GroupPublic -> ServerECDHParams
ServerECDHParams Group
grp GroupPublic
srvpub
        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
$ ServerECDHParams -> HandshakeM ()
setServerECDHParams ServerECDHParams
serverParams
        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
$ GroupPrivate -> HandshakeM ()
setGroupPrivate GroupPrivate
srvpri
        ServerECDHParams -> IO ServerECDHParams
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerECDHParams
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
        Group
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
        ServerECDHParams
serverParams <- Group -> IO ServerECDHParams
setup_ECDHE Group
grp
        PubKey
pubKey <- Context -> IO PubKey
forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
        HashAndSignatureAlgorithm
mhashSig <- PubKey -> IO HashAndSignatureAlgorithm
forall {m :: * -> *}.
Monad m =>
PubKey -> m HashAndSignatureAlgorithm
decideHashSig PubKey
pubKey
        DigitallySigned
signed <- Context
-> ServerECDHParams
-> PubKey
-> HashAndSignatureAlgorithm
-> IO DigitallySigned
digitallySignECDHParams Context
ctx ServerECDHParams
serverParams PubKey
pubKey HashAndSignatureAlgorithm
mhashSig
        case KeyExchangeSignatureAlg
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
    Bool
resuming <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
isSessionResuming
    ServerRandom
srand <-
        Context -> Version -> [Version] -> IO ServerRandom
serverRandom Context
ctx Version
TLS12 ([Version] -> IO ServerRandom) -> [Version] -> IO ServerRandom
forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions (Supported -> [Version]) -> Supported -> [Version]
forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams
    case Maybe Credential
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.
    Bool
secReneg <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getSecureRenegotiation
    [ExtensionRaw]
secRengExt <-
        if Bool
secReneg
            then do
                ByteString
vd <- Context -> TLSSt ByteString -> IO ByteString
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt ByteString -> IO ByteString)
-> TLSSt ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ do
                    ByteString
cvd <- Role -> TLSSt ByteString
getVerifyData Role
ClientRole
                    ByteString
svd <- Role -> TLSSt ByteString
getVerifyData Role
ServerRole
                    ByteString -> TLSSt ByteString
forall a. a -> TLSSt a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> TLSSt ByteString) -> ByteString -> TLSSt ByteString
forall a b. (a -> b) -> a -> b
$ SecureRenegotiation -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode (SecureRenegotiation -> ByteString)
-> SecureRenegotiation -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> SecureRenegotiation
SecureRenegotiation ByteString
cvd ByteString
svd
                [ExtensionRaw] -> IO [ExtensionRaw]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_SecureRenegotiation ByteString
vd]
            else [ExtensionRaw] -> IO [ExtensionRaw]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Bool
ems <- Context -> HandshakeM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getExtendedMainSecret
    let emsExt :: [ExtensionRaw]
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 = []
    [ExtensionRaw]
protoExt <- Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
applicationProtocol Context
ctx [ExtensionRaw]
chExts ServerParams
sparams
    [ExtensionRaw]
sniExt <- do
        if Bool
resuming
            then [ExtensionRaw] -> IO [ExtensionRaw]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
            else do
                Maybe HostName
msni <- Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
getClientSNI
                case Maybe HostName
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 :: Bool
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 :: [ExtensionRaw]
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 :: [ExtensionRaw]
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
    Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> TLSSt ()
setVersion Version
TLS12
    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
$
        Version -> ServerRandom -> Cipher -> Compression -> HandshakeM ()
setServerHelloParameters Version
TLS12 ServerRandom
srand Cipher
usedCipher Compression
nullCompression
    Handshake -> IO Handshake
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handshake -> IO Handshake) -> Handshake -> IO Handshake
forall a b. (a -> b) -> a -> b
$
        Version
-> ServerRandom
-> Session
-> CipherID
-> CompressionID
-> [ExtensionRaw]
-> Handshake
ServerHello
            Version
TLS12
            ServerRandom
srand
            Session
session
            (Cipher -> CipherID
cipherID Cipher
usedCipher)
            (Compression -> CompressionID
compressionID Compression
nullCompression)
            [ExtensionRaw]
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
_ -> []