{-# 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
    Bool
resuming <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS12SessionResuming
    if Bool
resuming
        then Context -> IO ()
recvNSTandCCSandFinished Context
ctx
        else do
            let st :: RecvState IO
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)
            Context -> RecvState IO -> [Handshake] -> IO ()
runRecvStateHS Context
ctx RecvState IO
st [Handshake]
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
    Bool
sessionResuming <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS12SessionResuming
    if Bool
sessionResuming
        then Context -> Role -> IO ()
sendCCSandFinished Context
ctx Role
ClientRole
        else do
            ClientParams -> Context -> IO ()
sendClientCCC ClientParams
cparams Context
ctx
            Context -> Role -> IO ()
sendCCSandFinished Context
ctx Role
ClientRole

recvServerSecondFlight12 :: ClientParams -> Context -> IO ()
recvServerSecondFlight12 :: ClientParams -> Context -> IO ()
recvServerSecondFlight12 ClientParams
cparams Context
ctx = do
    Bool
sessionResuming <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS12SessionResuming
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
sessionResuming (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> IO ()
recvNSTandCCSandFinished Context
ctx
    Maybe Ticket
mticket <- Context -> TLSSt (Maybe Ticket) -> IO (Maybe Ticket)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe Ticket)
getTLS12SessionTicket
    Session
session <- Context -> TLSSt Session -> IO Session
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Session
getSession
    let midentity :: Maybe Ticket
midentity = Maybe Ticket -> Session -> Maybe Ticket
ticketOrSessionID12 Maybe Ticket
mticket Session
session
    case Maybe Ticket
midentity of
        Maybe Ticket
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Ticket
identity -> do
            Maybe SessionData
sessionData <- Context -> IO (Maybe SessionData)
getSessionData Context
ctx
            IO (Maybe Ticket) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe Ticket) -> IO ()) -> IO (Maybe Ticket) -> IO ()
forall a b. (a -> b) -> a -> b
$
                SessionManager -> Ticket -> SessionData -> IO (Maybe Ticket)
sessionEstablish
                    (Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx)
                    Ticket
identity
                    (Maybe SessionData -> SessionData
forall a. HasCallStack => Maybe a -> a
fromJust Maybe SessionData
sessionData)
    Context -> IO ()
handshakeDone12 Context
ctx
    IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Maybe Information
minfo <- Context -> IO (Maybe Information)
contextGetInformation Context
ctx
        case Maybe Information
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
    Bool
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 Bool
st
        then Context -> RecvState IO -> IO ()
runRecvState Context
ctx (RecvState IO -> IO ()) -> RecvState IO -> 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)
expectNewSessionTicket
        else do Context -> RecvState IO -> IO ()
runRecvState Context
ctx (RecvState IO -> IO ()) -> RecvState IO -> 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
  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
cipher <- Context -> HandshakeM Cipher -> IO Cipher
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Cipher
getPendingCipher
    (ClientKeyXchgAlgorithmData
ckx, HandshakeM Ticket
setMainSec) <- case Cipher -> CipherKeyExchangeType
cipherKeyExchange Cipher
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
    Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [ClientKeyXchgAlgorithmData -> Handshake
ClientKeyXchg ClientKeyXchgAlgorithmData
ckx]
    Ticket
mainSecret <- Context -> HandshakeM Ticket -> IO Ticket
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Ticket
setMainSec
    Context -> MainSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (Ticket -> MainSecret
MainSecret Ticket
mainSecret)

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

getCKX_RSA
    :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_RSA :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_RSA Context
ctx = do
    Version
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
    (Version
xver, Ticket
prerand) <- Context -> TLSSt (Version, Ticket) -> IO (Version, Ticket)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt (Version, Ticket) -> IO (Version, Ticket))
-> TLSSt (Version, Ticket) -> IO (Version, Ticket)
forall a b. (a -> b) -> a -> b
$ (,) (Version -> Ticket -> (Version, Ticket))
-> TLSSt Version -> TLSSt (Ticket -> (Version, Ticket))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TLSSt Version
getVersion TLSSt (Ticket -> (Version, Ticket))
-> TLSSt Ticket -> TLSSt (Version, Ticket)
forall a b. TLSSt (a -> b) -> TLSSt a -> TLSSt b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> TLSSt Ticket
genRandom Int
46

    let preMain :: Ticket
preMain = Version -> Ticket -> Ticket
encodePreMainSecret Version
clientVersion Ticket
prerand
        setMainSec :: HandshakeM Ticket
setMainSec = Version -> Role -> Ticket -> HandshakeM Ticket
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM Ticket
setMainSecretFromPre Version
xver Role
ClientRole Ticket
preMain
    Ticket
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.
        Ticket
e <- Context -> Ticket -> IO Ticket
encryptRSA Context
ctx Ticket
preMain
        let extra :: Ticket
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
        Ticket -> IO Ticket
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticket -> IO Ticket) -> Ticket -> IO Ticket
forall a b. (a -> b) -> a -> b
$ Ticket
extra Ticket -> Ticket -> Ticket
`B.append` Ticket
e
    (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
-> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticket -> ClientKeyXchgAlgorithmData
CKX_RSA Ticket
encryptedPreMain, HandshakeM Ticket
setMainSec)

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

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

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

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool -> (Group -> Bool) -> Maybe Group -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Context -> Group -> Bool
isSupportedGroup Context
ctx) Maybe Group
ffGroup) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        GroupUsage
groupUsage <-
            ClientHooks -> DHParams -> DHPublic -> IO GroupUsage
onCustomFFDHEGroup (ClientParams -> ClientHooks
clientHooks ClientParams
cparams) DHParams
params DHPublic
srvpub
                IO GroupUsage -> (SomeException -> IO GroupUsage) -> IO GroupUsage
forall a. IO a -> (SomeException -> IO a) -> IO a
`catchException` [Char] -> SomeException -> IO GroupUsage
forall a. [Char] -> SomeException -> IO a
throwMiscErrorOnException [Char]
"custom group callback failed"
        case GroupUsage
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.
    (DHPublic
clientDHPub, DHKey
preMain) <-
        case Maybe Group
ffGroup of
            Maybe Group
Nothing -> do
                (DHPrivate
clientDHPriv, DHPublic
clientDHPub) <- Context -> DHParams -> IO (DHPrivate, DHPublic)
generateDHE Context
ctx DHParams
params
                let preMain :: DHKey
preMain = DHParams -> DHPrivate -> DHPublic -> DHKey
dhGetShared DHParams
params DHPrivate
clientDHPriv DHPublic
srvpub
                (DHPublic, DHKey) -> IO (DHPublic, DHKey)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic
clientDHPub, DHKey
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
                Maybe (DHPublic, DHKey)
dhePair <- Context -> Group -> DHPublic -> IO (Maybe (DHPublic, DHKey))
generateFFDHEShared Context
ctx Group
grp DHPublic
srvpub
                case Maybe (DHPublic, DHKey)
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 :: HandshakeM Ticket
setMainSec = Version -> Role -> DHKey -> HandshakeM Ticket
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM Ticket
setMainSecretFromPre Version
xver Role
ClientRole DHKey
preMain
    (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
-> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DHPublic -> ClientKeyXchgAlgorithmData
CKX_DH DHPublic
clientDHPub, HandshakeM Ticket
setMainSec)

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

getCKX_ECDHE
    :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)
getCKX_ECDHE :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
getCKX_ECDHE Context
ctx = do
    ServerECDHParams Group
grp GroupPublic
srvpub <- Context -> HandshakeM ServerECDHParams -> IO ServerECDHParams
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM ServerECDHParams
getServerECDHParams
    Context -> Group -> IO ()
checkSupportedGroup Context
ctx Group
grp
    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
    Maybe (GroupPublic, GroupKey)
ecdhePair <- Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey))
generateECDHEShared Context
ctx GroupPublic
srvpub
    case Maybe (GroupPublic, GroupKey)
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
            Version
xver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
            let setMainSec :: HandshakeM Ticket
setMainSec = Version -> Role -> GroupKey -> HandshakeM Ticket
forall preMain.
ByteArrayAccess preMain =>
Version -> Role -> preMain -> HandshakeM Ticket
setMainSecretFromPre Version
xver Role
ClientRole GroupKey
preMain
            (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
-> IO (ClientKeyXchgAlgorithmData, HandshakeM Ticket)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ticket -> ClientKeyXchgAlgorithmData
CKX_ECDH (Ticket -> ClientKeyXchgAlgorithmData)
-> Ticket -> ClientKeyXchgAlgorithmData
forall a b. (a -> b) -> a -> b
$ GroupPublic -> Ticket
encodeGroupPublic GroupPublic
clipub, HandshakeM Ticket
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
    Version
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.
    --
    Bool
certSent <- Context -> HandshakeM Bool -> IO Bool
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getClientCertSent
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
certSent (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        PubKey
pubKey <- Context -> IO PubKey
forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
        HashAndSignatureAlgorithm
mhashSig <-
            let cHashSigs :: [HashAndSignatureAlgorithm]
cHashSigs = Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
-> Supported -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
             in Context
-> (PubKey -> HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg Context
ctx PubKey -> HashAndSignatureAlgorithm -> Bool
signatureCompatible [HashAndSignatureAlgorithm]
cHashSigs PubKey
pubKey
        -- Fetch all handshake messages up to now.
        Ticket
msgs <- Context -> HandshakeM Ticket -> IO Ticket
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM Ticket -> IO Ticket) -> HandshakeM Ticket -> IO Ticket
forall a b. (a -> b) -> a -> b
$ [Ticket] -> Ticket
B.concat ([Ticket] -> Ticket) -> HandshakeM [Ticket] -> HandshakeM Ticket
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HandshakeM [Ticket]
getHandshakeMessages
        DigitallySigned
sigDig <- Context
-> Version
-> PubKey
-> HashAndSignatureAlgorithm
-> Ticket
-> IO DigitallySigned
createCertificateVerify Context
ctx Version
ver PubKey
pubKey HashAndSignatureAlgorithm
mhashSig Ticket
msgs
        Context -> Packet -> IO ()
sendPacket12 Context
ctx (Packet -> IO ()) -> Packet -> IO ()
forall a b. (a -> b) -> a -> b
$ [Handshake] -> Packet
Handshake [DigitallySigned -> Handshake
CertVerify DigitallySigned
sigDig]