{-# 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)
| 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
| 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
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]
:)
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
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)
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 ()
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
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
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
[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
_ -> []