{-# 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 mticket =
ExtensionID
-> MessageType
-> [ExtensionRaw]
-> Maybe ByteString
-> (SessionTicket -> Maybe ByteString)
-> Maybe ByteString
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
ExtensionID
EID_SessionTicket
MessageType
MsgTClientHello
[ExtensionRaw]
chExtensions
Maybe ByteString
forall a. Maybe a
Nothing
(\(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 ctx chCiphers serverName ems sd
validateSession
:: Context
-> [CipherId]
-> Maybe HostName
-> Bool
-> Maybe SessionData
-> IO (Maybe SessionData)
validateSession :: Context
-> [CipherId]
-> Maybe HostName
-> Bool
-> Maybe SessionData
-> IO (Maybe SessionData)
validateSession Context
_ [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 Context
ctx [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
| Word16 -> CipherId
CipherId (SessionData -> Word16
sessionCipher SessionData
sd) CipherId -> [CipherId] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [CipherId]
ciphers =
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
"new cipher is diffrent from the old one" AlertDescription
IllegalParameter
| 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 = do
Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt ()
clearClientSNI
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{Bool
Int
[SignedCertificate]
Maybe DHParams
Limit
ServerHooks
Shared
Supported
DebugParams
serverWantClientCert :: Bool
serverCACertificates :: [SignedCertificate]
serverDHEParams :: Maybe DHParams
serverHooks :: ServerHooks
serverShared :: Shared
serverSupported :: Supported
serverDebug :: DebugParams
serverEarlyDataSize :: Int
serverTicketLifetime :: Int
serverLimit :: Limit
serverLimit :: ServerParams -> Limit
serverTicketLifetime :: ServerParams -> Int
serverEarlyDataSize :: ServerParams -> Int
serverDebug :: ServerParams -> DebugParams
serverSupported :: ServerParams -> Supported
serverShared :: ServerParams -> Shared
serverHooks :: ServerParams -> ServerHooks
serverDHEParams :: ServerParams -> Maybe DHParams
serverCACertificates :: ServerParams -> [SignedCertificate]
serverWantClientCert :: ServerParams -> Bool
..} 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
_ -> [SignedCertificate] -> 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
. (TLSCertificateChain -> Handshake
Certificate (CertificateChain -> TLSCertificateChain
TLSCertificateChain 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
then do
let (certTypes, hashSigs) =
let as = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures Supported
serverSupported
in (nub $ mapMaybe hashSigToCertType as, as)
creq =
[CertificateType]
-> [HashAndSignatureAlgorithm] -> [DistinguishedName] -> Handshake
CertRequest
[CertificateType]
certTypes
[HashAndSignatureAlgorithm]
hashSigs
((SignedCertificate -> DistinguishedName)
-> [SignedCertificate] -> [DistinguishedName]
forall a b. (a -> b) -> [a] -> [b]
map SignedCertificate -> DistinguishedName
extractCAname [SignedCertificate]
serverCACertificates)
usingHState ctx $ setCertReqSent True
return $ b2 . (creq :)
else return b2
where
commonGroups :: [Group]
commonGroups = [Group] -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon (Supported -> [Group]
supportedGroups Supported
serverSupported) [ExtensionRaw]
chExts
commonHashSigs :: [HashAndSignatureAlgorithm]
commonHashSigs = [HashAndSignatureAlgorithm]
-> [ExtensionRaw] -> [HashAndSignatureAlgorithm]
hashAndSignaturesInCommon (Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures Supported
serverSupported) [ExtensionRaw]
chExts
setup_DHE :: IO ServerDHParams
setup_DHE = do
let possibleFFGroups :: [Group]
possibleFFGroups = [Group]
commonGroups [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
serverDHEParams
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
case (HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a. (a -> Bool) -> [a] -> [a]
filter (PubKey
pubKey PubKey -> HashAndSignatureAlgorithm -> Bool
`signatureCompatible`) [HashAndSignatureAlgorithm]
commonHashSigs 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 = [Group]
commonGroups [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 ()
sniExt <- do
if resuming
then return Nothing
else do
msni <- usingState_ ctx getClientSNI
case msni of
Just HostName
_ -> Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe ExtensionRaw -> IO (Maybe ExtensionRaw))
-> Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall a b. (a -> b) -> a -> b
$ ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ ServerName -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (ServerName -> ExtensionRaw) -> ServerName -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ [ServerNameType] -> ServerName
ServerName []
Maybe HostName
Nothing -> Maybe ExtensionRaw -> IO (Maybe ExtensionRaw)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ExtensionRaw
forall a. Maybe a
Nothing
let ecPointExt = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_EcPointFormats [ExtensionRaw]
chExts of
Maybe ByteString
Nothing -> Maybe ExtensionRaw
forall a. Maybe a
Nothing
Just ByteString
_ -> ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ EcPointFormatsSupported -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (EcPointFormatsSupported -> ExtensionRaw)
-> EcPointFormatsSupported -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ [EcPointFormat] -> EcPointFormatsSupported
EcPointFormatsSupported [EcPointFormat
EcPointFormat_Uncompressed]
alpnExt <- applicationProtocol ctx chExts sparams
ems <- usingHState ctx getExtendedMainSecret
let emsExt
| Bool
ems = ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ ExtendedMainSecret -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw ExtendedMainSecret
ExtendedMainSecret
| Bool
otherwise = Maybe ExtensionRaw
forall a. Maybe a
Nothing
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
sessionTicketExt
| Bool -> Bool
not Bool
resuming Bool -> Bool -> Bool
&& Bool
useTicket = ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ SessionTicket -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (SessionTicket -> ExtensionRaw) -> SessionTicket -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ ByteString -> SessionTicket
SessionTicket ByteString
""
| Bool
otherwise = Maybe ExtensionRaw
forall a. Maybe a
Nothing
secReneg <- usingState_ ctx getSecureRenegotiation
secureRenegExt <-
if secReneg
then do
vd <- usingState_ ctx $ do
VerifyData cvd <- getVerifyData ClientRole
VerifyData svd <- getVerifyData ServerRole
return $ SecureRenegotiation cvd svd
return $ Just $ toExtensionRaw vd
else return Nothing
recodeSizeLimitExt <- processRecordSizeLimit ctx chExts False
let shExts =
Shared -> [ExtensionRaw]
sharedHelloExtensions (ServerParams -> Shared
serverShared ServerParams
sparams)
[ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [Maybe ExtensionRaw] -> [ExtensionRaw]
forall a. [Maybe a] -> [a]
catMaybes
[ Maybe ExtensionRaw
sniExt
, Maybe ExtensionRaw
ecPointExt
, Maybe ExtensionRaw
alpnExt
, Maybe ExtensionRaw
emsExt
, Maybe ExtensionRaw
recodeSizeLimitExt
, Maybe ExtensionRaw
sessionTicketExt
, Maybe ExtensionRaw
secureRenegExt
]
usingState_ ctx $ setVersion TLS12
usingHState ctx $
setServerHelloParameters TLS12 srand usedCipher nullCompression
return $
ServerHello
TLS12
srand
session
(CipherId (cipherID usedCipher))
(compressionID nullCompression)
shExts
negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon :: [Group] -> [ExtensionRaw] -> [Group]
negotiatedGroupsInCommon [Group]
serverGroups [ExtensionRaw]
chExts =
ExtensionID
-> MessageType
-> [ExtensionRaw]
-> [Group]
-> (SupportedGroups -> [Group])
-> [Group]
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
ExtensionID
EID_SupportedGroups
MessageType
MsgTClientHello
[ExtensionRaw]
chExts
[]
SupportedGroups -> [Group]
common
where
common :: SupportedGroups -> [Group]
common (SupportedGroups [Group]
clientGroups) = [Group]
serverGroups [Group] -> [Group] -> [Group]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
clientGroups