{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.TLS.Handshake.Client.TLS12 (
    recvServerFirstFlight12,
    sendClientSecondFlight12,
    recvServerSecondFlight12,
) where

import Control.Monad.State.Strict
import qualified Data.ByteString as B

import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Crypto
import Network.TLS.Handshake.Client.Common
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.Packet hiding (getExtensions, getSession)
import Network.TLS.Parameters
import Network.TLS.Session
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Types
import Network.TLS.Util (catchException)
import Network.TLS.Wire
import Network.TLS.X509 hiding (Certificate)

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

recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO ()
recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO ()
recvServerFirstFlight12 ClientParams
cparams Context
ctx [Handshake]
hs = do
    resuming <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS12SessionResuming
    if resuming
        then recvNSTandCCSandFinished ctx
        else do
            let st = (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake (ClientParams -> Context -> Handshake -> IO (RecvState IO)
expectCertificate ClientParams
cparams Context
ctx)
            runRecvStateHS ctx st hs

expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)
expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)
expectCertificate ClientParams
cparams Context
ctx (Certificate CertificateChain
certs) = 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
$ CertificateChain -> TLSSt ()
setServerCertificateChain CertificateChain
certs
    ClientParams -> Context -> CertificateChain -> IO ()
doCertificate ClientParams
cparams Context
ctx CertificateChain
certs
    Context -> Role -> CertificateChain -> IO ()
processCertificate Context
ctx Role
ClientRole CertificateChain
certs
    RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake (Context -> Handshake -> IO (RecvState IO)
expectServerKeyExchange Context
ctx)
expectCertificate ClientParams
_ Context
ctx Handshake
p = Context -> Handshake -> IO (RecvState IO)
expectServerKeyExchange Context
ctx Handshake
p

expectServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
expectServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
expectServerKeyExchange Context
ctx (ServerKeyXchg ServerKeyXchgAlgorithmData
origSkx) = do
    Context -> ServerKeyXchgAlgorithmData -> IO ()
doServerKeyExchange Context
ctx ServerKeyXchgAlgorithmData
origSkx
    RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake (Context -> Handshake -> IO (RecvState IO)
expectCertificateRequest Context
ctx)
expectServerKeyExchange Context
ctx Handshake
p = Context -> Handshake -> IO (RecvState IO)
expectCertificateRequest Context
ctx Handshake
p

expectCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
expectCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
expectCertificateRequest Context
ctx (CertRequest [CertificateType]
cTypesSent [HashAndSignatureAlgorithm]
sigAlgs [DistinguishedName]
dNames) = do
    let cTypes :: [CertificateType]
cTypes = (CertificateType -> Bool) -> [CertificateType] -> [CertificateType]
forall a. (a -> Bool) -> [a] -> [a]
filter (CertificateType -> CertificateType -> Bool
forall a. Ord a => a -> a -> Bool
<= CertificateType
lastSupportedCertificateType) [CertificateType]
cTypesSent
    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
$ Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata (Maybe CertReqCBdata -> HandshakeM ())
-> Maybe CertReqCBdata -> HandshakeM ()
forall a b. (a -> b) -> a -> b
$ CertReqCBdata -> Maybe CertReqCBdata
forall a. a -> Maybe a
Just ([CertificateType]
cTypes, [HashAndSignatureAlgorithm] -> Maybe [HashAndSignatureAlgorithm]
forall a. a -> Maybe a
Just [HashAndSignatureAlgorithm]
sigAlgs, [DistinguishedName]
dNames)
    RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake (Context -> Handshake -> IO (RecvState IO)
forall (m :: * -> *). Context -> Handshake -> IO (RecvState m)
expectServerHelloDone Context
ctx)
expectCertificateRequest Context
ctx Handshake
p = 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
$ Maybe CertReqCBdata -> HandshakeM ()
setCertReqCBdata Maybe CertReqCBdata
forall a. Maybe a
Nothing
    Context -> Handshake -> IO (RecvState IO)
forall (m :: * -> *). Context -> Handshake -> IO (RecvState m)
expectServerHelloDone Context
ctx Handshake
p

expectServerHelloDone :: Context -> Handshake -> IO (RecvState m)
expectServerHelloDone :: forall (m :: * -> *). Context -> Handshake -> IO (RecvState m)
expectServerHelloDone Context
_ Handshake
ServerHelloDone = RecvState m -> IO (RecvState m)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return RecvState m
forall (m :: * -> *). RecvState m
RecvStateDone
expectServerHelloDone Context
_ Handshake
p = [Char] -> Maybe [Char] -> IO (RecvState m)
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Handshake -> [Char]
forall a. Show a => a -> [Char]
show Handshake
p) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"server hello data")

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

sendClientSecondFlight12 :: ClientParams -> Context -> IO ()
sendClientSecondFlight12 :: ClientParams -> Context -> IO ()
sendClientSecondFlight12 ClientParams
cparams Context
ctx = do
    sessionResuming <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS12SessionResuming
    if sessionResuming
        then sendCCSandFinished ctx ClientRole
        else do
            sendClientCCC cparams ctx
            sendCCSandFinished ctx ClientRole

recvServerSecondFlight12 :: ClientParams -> Context -> IO ()
recvServerSecondFlight12 :: ClientParams -> Context -> IO ()
recvServerSecondFlight12 ClientParams
cparams Context
ctx = do
    sessionResuming <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS12SessionResuming
    unless sessionResuming $ recvNSTandCCSandFinished ctx
    mticket <- usingState_ ctx getTLS12SessionTicket
    session <- usingState_ ctx getSession
    let midentity = Maybe Ticket -> Session -> Maybe Ticket
ticketOrSessionID12 Maybe Ticket
mticket Session
session
    case midentity of
        Maybe Ticket
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Ticket
identity -> do
            sessionData <- Context -> IO (Maybe SessionData)
getSessionData Context
ctx
            void $
                sessionEstablish
                    (sharedSessionManager $ ctxShared ctx)
                    identity
                    (fromJust sessionData)
    handshakeDone12 ctx
    liftIO $ do
        minfo <- contextGetInformation ctx
        case minfo of
            Maybe Information
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just Information
info -> ClientHooks -> Information -> IO ()
onServerFinished (ClientParams -> ClientHooks
clientHooks ClientParams
cparams) Information
info

recvNSTandCCSandFinished :: Context -> IO ()
recvNSTandCCSandFinished :: Context -> IO ()
recvNSTandCCSandFinished Context
ctx = do
    st <- Maybe Ticket -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Ticket -> Bool) -> IO (Maybe Ticket) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> TLSSt (Maybe Ticket) -> IO (Maybe Ticket)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe Ticket)
getTLS12SessionTicket
    if st
        then runRecvState ctx $ RecvStateHandshake expectNewSessionTicket
        else do runRecvState ctx $ RecvStatePacket expectChangeCipher
  where
    expectNewSessionTicket :: Handshake -> IO (RecvState IO)
expectNewSessionTicket (NewSessionTicket Second
_ Ticket
ticket) = 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
$ Ticket -> TLSSt ()
setTLS12SessionTicket Ticket
ticket
        RecvState IO -> IO (RecvState IO)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> IO (RecvState IO))
-> RecvState IO -> IO (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Packet -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Packet -> m (RecvState m)) -> RecvState m
RecvStatePacket Packet -> IO (RecvState IO)
forall {m :: * -> *}. MonadIO m => Packet -> m (RecvState IO)
expectChangeCipher
    expectNewSessionTicket Handshake
p = [Char] -> Maybe [Char] -> IO (RecvState IO)
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Handshake -> [Char]
forall a. Show a => a -> [Char]
show Handshake
p) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"Handshake Finished")

    expectChangeCipher :: Packet -> m (RecvState IO)
expectChangeCipher Packet
ChangeCipherSpec = do
        RecvState IO -> m (RecvState IO)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RecvState IO -> m (RecvState IO))
-> RecvState IO -> m (RecvState IO)
forall a b. (a -> b) -> a -> b
$ (Handshake -> IO (RecvState IO)) -> RecvState IO
forall (m :: * -> *). (Handshake -> m (RecvState m)) -> RecvState m
RecvStateHandshake ((Handshake -> IO (RecvState IO)) -> RecvState IO)
-> (Handshake -> IO (RecvState IO)) -> RecvState IO
forall a b. (a -> b) -> a -> b
$ Context -> Handshake -> IO (RecvState IO)
expectFinished Context
ctx
    expectChangeCipher Packet
p = [Char] -> Maybe [Char] -> m (RecvState IO)
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Packet -> [Char]
forall a. Show a => a -> [Char]
show Packet
p) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"change cipher")

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

-- | TLS 1.2 and below.  Send the client handshake messages that
-- follow the @ServerHello@, etc. except for @CCS@ and @Finished@.
--
-- XXX: Is any buffering done here to combined these messages into
-- a single TCP packet?  Otherwise we're prone to Nagle delays, or
-- in any case needlessly generate multiple small packets, where
-- a single larger packet will do.  The TLS 1.3 code path seems
-- to separating record generation and transmission and sending
-- multiple records in a single packet.
--
--       -> [certificate]
--       -> client key exchange
--       -> [cert verify]
sendClientCCC :: ClientParams -> Context -> IO ()
sendClientCCC :: ClientParams -> Context -> IO ()
sendClientCCC ClientParams
cparams Context
ctx = do
    ClientParams -> Context -> IO ()
sendCertificate ClientParams
cparams Context
ctx
    ClientParams -> Context -> IO ()
sendClientKeyXchg ClientParams
cparams Context
ctx
    Context -> IO ()
sendCertificateVerify Context
ctx

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

sendCertificate :: ClientParams -> Context -> IO ()
sendCertificate :: ClientParams -> Context -> IO ()
sendCertificate ClientParams
cparams Context
ctx = 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
$ Bool -> HandshakeM ()
setClientCertSent Bool
False
    ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain ClientParams
cparams Context
ctx IO (Maybe CertificateChain)
-> (Maybe CertificateChain -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe CertificateChain
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just cc :: CertificateChain
cc@(CertificateChain [SignedExact Certificate]
certs) -> do
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SignedExact Certificate] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SignedExact Certificate]
certs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                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 ()
setClientCertSent Bool
True
            Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [CertificateChain -> Handshake
Certificate CertificateChain
cc]

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

sendClientKeyXchg :: ClientParams -> Context -> IO ()
sendClientKeyXchg :: ClientParams -> Context -> IO ()
sendClientKeyXchg ClientParams
cparams Context
ctx = do
    cipher <- Context -> HandshakeM Cipher -> IO Cipher
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
    (ckx, setMainSec) <- case cipherKeyExchange cipher of
        CipherKeyExchangeType
CipherKeyExchange_RSA -> Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_RSA Context
ctx
        CipherKeyExchangeType
CipherKeyExchange_DHE_RSA -> ClientParams
-> Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_DHE ClientParams
cparams Context
ctx
        CipherKeyExchangeType
CipherKeyExchange_DHE_DSA -> ClientParams
-> Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_DHE ClientParams
cparams Context
ctx
        CipherKeyExchangeType
CipherKeyExchange_ECDHE_RSA -> Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_ECDHE Context
ctx
        CipherKeyExchangeType
CipherKeyExchange_ECDHE_ECDSA -> Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_ECDHE Context
ctx
        CipherKeyExchangeType
_ ->
            TLSError -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket))
-> TLSError -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
forall a b. (a -> b) -> a -> b
$
                [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"client key exchange unsupported type" AlertDescription
HandshakeFailure
    sendPacket12 ctx $ Handshake [ClientKeyXchg ckx]
    mainSecret <- usingHState ctx setMainSec
    logKey ctx (MainSecret mainSecret)

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

getCKX_RSA
    :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_RSA :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_RSA Context
ctx = do
    clientVersion <- Context -> HandshakeM Version -> IO Version
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM Version -> IO Version)
-> HandshakeM Version -> IO Version
forall a b. (a -> b) -> a -> b
$ (HandshakeState -> Version) -> HandshakeM Version
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HandshakeState -> Version
hstClientVersion
    (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46

    let preMain = Version -> Ticket -> Ticket
encodePreMainSecret Version
clientVersion Ticket
prerand
        setMainSec = Version -> Role -> Ticket -> HandshakeM Ticket
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM Ticket
setMainSecretFromPre Version
xver Role
ClientRole Ticket
preMain
    encryptedPreMain <- do
        -- SSL3 implementation generally forget this length field since it's redundant,
        -- however TLS10 make it clear that the length field need to be present.
        e <- encryptRSA ctx preMain
        let extra = Word16 -> Ticket
encodeWord16 (Word16 -> Ticket) -> Word16 -> Ticket
forall a b. (a -> b) -> a -> b
$ Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word16) -> Int -> Word16
forall a b. (a -> b) -> a -> b
$ Ticket -> Int
B.length Ticket
e
        return $ extra `B.append` e
    return (CKX_RSA encryptedPreMain, setMainSec)

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

getCKX_DHE
    :: ClientParams
    -> Context
    -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_DHE :: ClientParams
-> Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_DHE ClientParams
cparams Context
ctx = do
    xver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    serverParams <- usingHState ctx getServerDHParams

    let params = ServerDHParams -> DHParams
serverDHParamsToParams ServerDHParams
serverParams
        ffGroup = DHParams -> Maybe Group
findFiniteFieldGroup DHParams
params
        srvpub = ServerDHParams -> DHPublic
serverDHParamsToPublic ServerDHParams
serverParams

    unless (maybe False (isSupportedGroup ctx) ffGroup) $ do
        groupUsage <-
            onCustomFFDHEGroup (clientHooks cparams) params srvpub
                `catchException` throwMiscErrorOnException "custom group callback failed"
        case groupUsage of
            GroupUsage
GroupUsageInsecure ->
                TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"FFDHE group is not secure enough" AlertDescription
InsufficientSecurity
            GroupUsageUnsupported [Char]
reason ->
                TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
                    [Char] -> AlertDescription -> TLSError
Error_Protocol ([Char]
"unsupported FFDHE group: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
reason) AlertDescription
HandshakeFailure
            GroupUsage
GroupUsageInvalidPublic -> TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"invalid server public key" AlertDescription
IllegalParameter
            GroupUsage
GroupUsageValid -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- When grp is known but not in the supported list we use it
    -- anyway.  This provides additional validation and a more
    -- efficient implementation.
    (clientDHPub, preMain) <-
        case ffGroup of
            Maybe Group
Nothing -> do
                (clientDHPriv, clientDHPub) <- Context -> DHParams -> IO (DHPrivate, DHPublic)
generateDHE Context
ctx DHParams
params
                let preMain = DHParams -> DHPrivate -> DHPublic -> DHKey
dhGetShared DHParams
params DHPrivate
clientDHPriv DHPublic
srvpub
                return (clientDHPub, preMain)
            Just 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
                dhePair <- Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey))
generateFFDHEShared Context
ctx Group
grp DHPublic
srvpub
                case dhePair of
                    Maybe (DHPublic, DHKey)
Nothing ->
                        TLSError -> IO (DHPublic, DHKey)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (DHPublic, DHKey))
-> TLSError -> IO (DHPublic, DHKey)
forall a b. (a -> b) -> a -> b
$
                            [Char] -> AlertDescription -> TLSError
Error_Protocol ([Char]
"invalid server " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Group -> [Char]
forall a. Show a => a -> [Char]
show Group
grp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" public key") AlertDescription
IllegalParameter
                    Just (DHPublic, DHKey)
pair -> (DHPublic, DHKey) -> IO (DHPublic, DHKey)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic, DHKey)
pair

    let setMainSec = Version -> Role -> DHKey -> HandshakeM Ticket
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM Ticket
setMainSecretFromPre Version
xver Role
ClientRole DHKey
preMain
    return (CKX_DH clientDHPub, setMainSec)

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

getCKX_ECDHE
    :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_ECDHE :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_ECDHE Context
ctx = do
    ServerECDHParams grp srvpub <- Context -> HandshakeM ServerECDHParams -> IO ServerECDHParams
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ServerECDHParams
getServerECDHParams
    checkSupportedGroup ctx grp
    usingHState ctx $ setSupportedGroup grp
    ecdhePair <- generateECDHEShared ctx srvpub
    case ecdhePair of
        Maybe (GroupPublic, GroupKey)
Nothing ->
            TLSError -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket))
-> TLSError -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
forall a b. (a -> b) -> a -> b
$
                [Char] -> AlertDescription -> TLSError
Error_Protocol ([Char]
"invalid server " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Group -> [Char]
forall a. Show a => a -> [Char]
show Group
grp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" public key") AlertDescription
IllegalParameter
        Just (GroupPublic
clipub, GroupKey
preMain) -> do
            xver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
            let setMainSec = Version -> Role -> GroupKey -> HandshakeM Ticket
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM Ticket
setMainSecretFromPre Version
xver Role
ClientRole GroupKey
preMain
            return (CKX_ECDH $ encodeGroupPublic clipub, setMainSec)

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

-- In order to send a proper certificate verify message,
-- we have to do the following:
--
-- 1. Determine which signing algorithm(s) the server supports
--    (we currently only support RSA).
-- 2. Get the current handshake hash from the handshake state.
-- 3. Sign the handshake hash
-- 4. Send it to the server.
--
sendCertificateVerify :: Context -> IO ()
sendCertificateVerify :: Context -> IO ()
sendCertificateVerify Context
ctx = do
    ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion

    -- Only send a certificate verify message when we
    -- have sent a non-empty list of certificates.
    --
    certSent <- usingHState ctx getClientCertSent
    when certSent $ do
        pubKey <- getLocalPublicKey ctx
        mhashSig <-
            let cHashSigs = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
-> Supported -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
             in getLocalHashSigAlg ctx signatureCompatible cHashSigs pubKey
        -- Fetch all handshake messages up to now.
        msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages
        sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs
        sendPacket12 ctx $ Handshake [CertVerify sigDig]