{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.TLS.Handshake.Client.ServerHello (
    receiveServerHello,
    processServerHello13,
) where

import qualified Data.ByteString as B

import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Context.Internal
import Network.TLS.ErrT
import Network.TLS.Extension
import Network.TLS.Handshake.Client.Common
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Random
import Network.TLS.Handshake.State
import Network.TLS.Handshake.TranscriptHash
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.Packet
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types

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

receiveServerHello
    :: ClientParams
    -> Context
    -> Maybe (ClientRandom, Session, Version)
    -> IO (Version, [Handshake], Bool)
receiveServerHello :: ClientParams
-> Context
-> Maybe (ClientRandom, Session, Version)
-> IO (Version, [Handshake], Bool)
receiveServerHello ClientParams
cparams Context
ctx Maybe (ClientRandom, Session, Version)
mparams = do
    Millisecond
chSentTime <- IO Millisecond
getCurrentTimeFromBase
    (Handshake
sh, [Handshake]
hss) <- IO (Handshake, [Handshake])
recvSH
    ClientParams -> Context -> Handshake -> IO ()
processServerHello ClientParams
cparams Context
ctx Handshake
sh
    IO ByteString -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ByteString -> IO ()) -> IO ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Handshake -> IO ByteString
updateTranscriptHash12 Context
ctx Handshake
sh
    Context -> Millisecond -> IO ()
setRTT Context
ctx Millisecond
chSentTime
    Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
-> ((ClientRandom, Session, Version) -> Bool)
-> Maybe (ClientRandom, Session, Version)
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (\(ClientRandom
_, Session
_, Version
v) -> Version
v Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
ver) Maybe (ClientRandom, Session, Version)
mparams) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        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]
"version changed after hello retry" AlertDescription
IllegalParameter
    -- recvServerHello sets TLS13HRR according to the server random.
    -- For 1st server hello, getTLS13HR returns True if it is HRR and
    -- False otherwise.  For 2nd server hello, getTLS13HR returns
    -- False since it is NOT HRR.
    Bool
hrr <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
    (Version, [Handshake], Bool) -> IO (Version, [Handshake], Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Version
ver, [Handshake]
hss, Bool
hrr)
  where
    recvSH :: IO (Handshake, [Handshake])
recvSH = do
        Either TLSError Packet
epkt <- Context -> IO (Either TLSError Packet)
recvPacket12 Context
ctx
        case Either TLSError Packet
epkt of
            Left TLSError
e -> TLSError -> IO (Handshake, [Handshake])
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore TLSError
e
            Right Packet
pkt -> case Packet
pkt of
                Alert [(AlertLevel, AlertDescription)]
a -> [(AlertLevel, AlertDescription)] -> IO (Handshake, [Handshake])
forall {m :: * -> *} {a} {a}. (MonadIO m, Show a) => a -> m a
throwAlert [(AlertLevel, AlertDescription)]
a
                Handshake (Handshake
h : [Handshake]
hs) -> (Handshake, [Handshake]) -> IO (Handshake, [Handshake])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handshake
h, [Handshake]
hs)
                Packet
_ -> [Char] -> Maybe [Char] -> IO (Handshake, [Handshake])
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Packet -> [Char]
forall a. Show a => a -> [Char]
show Packet
pkt) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"handshake")
    throwAlert :: a -> m a
throwAlert a
a =
        TLSError -> m a
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m a) -> TLSError -> m a
forall a b. (a -> b) -> a -> b
$
            [Char] -> AlertDescription -> TLSError
Error_Protocol
                ([Char]
"expecting server hello, got alert : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ a -> [Char]
forall a. Show a => a -> [Char]
show a
a)
                AlertDescription
HandshakeFailure

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

processServerHello13
    :: ClientParams -> Context -> Handshake13 -> IO ()
processServerHello13 :: ClientParams -> Context -> Handshake13 -> IO ()
processServerHello13 ClientParams
cparams Context
ctx (ServerHello13 ServerHello
sh13) = do
    let sh12 :: Handshake
sh12 = ServerHello -> Handshake
ServerHello ServerHello
sh13
    ClientParams -> Context -> Handshake -> IO ()
processServerHello ClientParams
cparams Context
ctx Handshake
sh12
processServerHello13 ClientParams
_ Context
_ Handshake13
h = [Char] -> Maybe [Char] -> IO ()
forall (m :: * -> *) a. MonadIO m => [Char] -> Maybe [Char] -> m a
unexpected (Handshake13 -> [Char]
forall a. Show a => a -> [Char]
show Handshake13
h) ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
"server hello")

-- | processServerHello processes the ServerHello message on the client.
--
-- 1) check the version chosen by the server is one allowed by
--    parameters.
-- 2) check that our compression and cipher algorithms are part of the
--    list we sent
-- 3) check extensions received are part of the one we sent
-- 4) process the session parameter to see if the server want to start
--    a new session or can resume
processServerHello
    :: ClientParams -> Context -> Handshake -> IO ()
processServerHello :: ClientParams -> Context -> Handshake -> IO ()
processServerHello ClientParams
cparams Context
ctx (ServerHello sh :: ServerHello
sh@SH{[ExtensionRaw]
CompressionID
Version
CipherId
Session
ServerRandom
shVersion :: Version
shRandom :: ServerRandom
shSession :: Session
shCipher :: CipherId
shComp :: CompressionID
shExtensions :: [ExtensionRaw]
shVersion :: ServerHello -> Version
shRandom :: ServerHello -> ServerRandom
shSession :: ServerHello -> Session
shCipher :: ServerHello -> CipherId
shComp :: ServerHello -> CompressionID
shExtensions :: ServerHello -> [ExtensionRaw]
..}) = do
    -- A server which receives a legacy_version value not equal to
    -- 0x0303 MUST abort the handshake with an "illegal_parameter"
    -- alert.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
shVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
TLS12) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        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 (Version -> [Char]
forall a. Show a => a -> [Char]
show Version
shVersion [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not supported") AlertDescription
IllegalParameter
    -- find the compression and cipher methods that the server want to use.
    Session
clientSession <- TLS13State -> Session
tls13stSession (TLS13State -> Session) -> IO TLS13State -> IO Session
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
    [ExtensionID]
chExts <- TLS13State -> [ExtensionID]
tls13stSentExtensions (TLS13State -> [ExtensionID]) -> IO TLS13State -> IO [ExtensionID]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> IO TLS13State
getTLS13State Context
ctx
    let clientCiphers :: [Cipher]
clientCiphers = Supported -> [Cipher]
supportedCiphers (Supported -> [Cipher]) -> Supported -> [Cipher]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
    Cipher
usedCipher <- case CipherID -> [Cipher] -> Maybe Cipher
findCipher (CipherId -> CipherID
fromCipherId CipherId
shCipher) [Cipher]
clientCiphers of
        Maybe Cipher
Nothing -> TLSError -> IO Cipher
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Cipher) -> TLSError -> IO Cipher
forall a b. (a -> b) -> a -> b
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"server choose unknown cipher" AlertDescription
IllegalParameter
        Just Cipher
alg -> Cipher -> IO Cipher
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Cipher
alg
    Compression
compressAlg <- case (Compression -> Bool) -> [Compression] -> Maybe Compression
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find
        (CompressionID -> CompressionID -> Bool
forall a. Eq a => a -> a -> Bool
(==) CompressionID
shComp (CompressionID -> Bool)
-> (Compression -> CompressionID) -> Compression -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Compression -> CompressionID
compressionID)
        (Supported -> [Compression]
supportedCompressions (Supported -> [Compression]) -> Supported -> [Compression]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx) of
        Maybe Compression
Nothing ->
            TLSError -> IO Compression
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO Compression) -> TLSError -> IO Compression
forall a b. (a -> b) -> a -> b
$ [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"server choose unknown compression" AlertDescription
IllegalParameter
        Just Compression
alg -> Compression -> IO Compression
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Compression
alg
    CompressionID -> IO ()
forall (m :: * -> *). MonadIO m => CompressionID -> m ()
ensureNullCompression CompressionID
shComp

    -- intersect sent extensions in client and the received extensions
    -- from server.  if server returns extensions that we didn't
    -- request, fail.
    let checkExt :: ExtensionRaw -> Bool
checkExt (ExtensionRaw ExtensionID
i ByteString
_)
            | ExtensionID
i ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
EID_Cookie = Bool
False -- for HRR
            | Bool
otherwise = ExtensionID
i ExtensionID -> [ExtensionID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [ExtensionID]
chExts
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((ExtensionRaw -> Bool) -> [ExtensionRaw] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ExtensionRaw -> Bool
checkExt [ExtensionRaw]
shExtensions) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        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]
"spurious extensions received" AlertDescription
UnsupportedExtension

    let isHRR :: Bool
isHRR = ServerRandom -> Bool
isHelloRetryRequest ServerRandom
shRandom
    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
        Bool -> TLSSt ()
setTLS13HRR Bool
isHRR
        Bool -> TLSSt () -> TLSSt ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHRR (TLSSt () -> TLSSt ()) -> TLSSt () -> TLSSt ()
forall a b. (a -> b) -> a -> b
$
            Maybe Cookie -> TLSSt ()
setTLS13Cookie (Maybe Cookie -> TLSSt ()) -> Maybe Cookie -> TLSSt ()
forall a b. (a -> b) -> a -> b
$
                ExtensionID
-> MessageType
-> [ExtensionRaw]
-> Maybe Cookie
-> (Cookie -> Maybe Cookie)
-> Maybe Cookie
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
                    ExtensionID
EID_Cookie
                    MessageType
MsgTServerHello
                    [ExtensionRaw]
shExtensions
                    Maybe Cookie
forall a. Maybe a
Nothing
                    (\cookie :: Cookie
cookie@(Cookie ByteString
_) -> Cookie -> Maybe Cookie
forall a. a -> Maybe a
Just Cookie
cookie)
        Version -> TLSSt ()
setVersion Version
shVersion -- must be before processing supportedVersions ext
        (ExtensionRaw -> TLSSt ()) -> [ExtensionRaw] -> TLSSt ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ExtensionRaw -> TLSSt ()
processServerExtension [ExtensionRaw]
shExtensions

    Context -> MessageType -> [ExtensionRaw] -> IO ()
setALPN Context
ctx MessageType
MsgTServerHello [ExtensionRaw]
shExtensions

    Version
ver <- Context -> TLSSt Version -> IO Version
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Version
getVersion

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
TLS12) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Context
-> Version -> ServerRandom -> Cipher -> Compression -> IO ()
setServerHelloParameters12 Context
ctx Version
shVersion ServerRandom
shRandom Cipher
usedCipher Compression
compressAlg

    let supportedVers :: [Version]
supportedVers = Supported -> [Version]
supportedVersions (Supported -> [Version]) -> Supported -> [Version]
forall a b. (a -> b) -> a -> b
$ ClientParams -> Supported
clientSupported ClientParams
cparams

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
TLS13) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- TLS 1.3 server MUST echo the session id
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Session
clientSession Session -> Session -> Bool
forall a. Eq a => a -> a -> Bool
/= Session
shSession) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            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]
"session is not matched in compatibility mode"
                    AlertDescription
IllegalParameter
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ver Version -> [Version] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Version]
supportedVers) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            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]
"server version " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Show a => a -> [Char]
show Version
ver [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is not supported")
                    AlertDescription
ProtocolVersion

    -- Some servers set TLS 1.2 as the legacy server hello version,
    -- and TLS 1.3 in the supported_versions extension, *AND ALSO* set
    -- the TLS 1.2 downgrade signal in the server random.  If we
    -- support TLS 1.3 and actually negotiate TLS 1.3, we must ignore
    -- the server random downgrade signal.  Therefore, 'isDowngraded'
    -- needs to take into account the negotiated version and the
    -- server random, as well as the list of client-side enabled
    -- protocol versions.
    --
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version -> [Version] -> ServerRandom -> Bool
isDowngraded Version
ver [Version]
supportedVers ServerRandom
shRandom) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        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]
"version downgrade detected" AlertDescription
IllegalParameter

    if Version
ver Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== Version
TLS13
        then do
            -- Session is dummy in TLS 1.3.
            Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ Session -> TLSSt ()
setSession Session
shSession
            Context -> [ExtensionRaw] -> Bool -> IO ()
processRecordSizeLimit Context
ctx [ExtensionRaw]
shExtensions Bool
True
            Context -> IO ()
enableMyRecordLimit Context
ctx
            Context -> IO ()
enablePeerRecordLimit Context
ctx
            let usedHash :: Hash
usedHash = Cipher -> Hash
cipherHash Cipher
usedCipher
            Context -> [Char] -> Hash -> Bool -> IO ()
transitTranscriptHashI Context
ctx [Char]
"transitI" Hash
usedHash Bool
isHRR
            Bool
accepted <- Context -> Bool -> Hash -> ServerHello -> IO Bool
checkECHacceptance Context
ctx Bool
isHRR Hash
usedHash ServerHello
sh
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
accepted (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                CH{[CompressionID]
[CipherId]
[ExtensionRaw]
Version
Session
ClientRandom
chVersion :: Version
chRandom :: ClientRandom
chSession :: Session
chCiphers :: [CipherId]
chComps :: [CompressionID]
chExtensions :: [ExtensionRaw]
chVersion :: ClientHello -> Version
chRandom :: ClientHello -> ClientRandom
chSession :: ClientHello -> Session
chCiphers :: ClientHello -> [CipherId]
chComps :: ClientHello -> [CompressionID]
chExtensions :: ClientHello -> [ExtensionRaw]
..} <- Maybe ClientHello -> ClientHello
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ClientHello -> ClientHello)
-> IO (Maybe ClientHello) -> IO ClientHello
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> HandshakeM (Maybe ClientHello) -> IO (Maybe ClientHello)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe ClientHello)
getClientHello
                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
$ ClientRandom -> HandshakeM ()
setClientRandom ClientRandom
chRandom -- inner random
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
accepted Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isHRR) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Context -> [Char] -> IO ()
copyTranscriptHash Context
ctx [Char]
"copy"
                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 ()
setECHAccepted Bool
True
            Context -> Cipher -> Bool -> IO ()
updateContext13 Context
ctx Cipher
usedCipher Bool
isHRR
            Context -> [Char] -> ByteString -> IO ()
updateTranscriptHashI Context
ctx [Char]
"ServerHelloI" (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ Handshake -> ByteString
encodeHandshake (Handshake -> ByteString) -> Handshake -> ByteString
forall a b. (a -> b) -> a -> b
$ ServerHello -> Handshake
ServerHello ServerHello
sh
        else do
            let resumingSession :: Maybe SessionData
resumingSession = case ClientParams -> [(ByteString, SessionData)]
clientSessions ClientParams
cparams of
                    (ByteString
_, SessionData
sessionData) : [(ByteString, SessionData)]
_ ->
                        if Session
shSession Session -> Session -> Bool
forall a. Eq a => a -> a -> Bool
== Session
clientSession then SessionData -> Maybe SessionData
forall a. a -> Maybe a
Just SessionData
sessionData else Maybe SessionData
forall a. Maybe a
Nothing
                    [(ByteString, SessionData)]
_ -> Maybe SessionData
forall a. Maybe a
Nothing

            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
shSession
                Bool -> TLSSt ()
setTLS12SessionResuming (Bool -> TLSSt ()) -> Bool -> TLSSt ()
forall a b. (a -> b) -> a -> b
$ Maybe SessionData -> Bool
forall a. Maybe a -> Bool
isJust Maybe SessionData
resumingSession
            Context -> [ExtensionRaw] -> Bool -> IO ()
processRecordSizeLimit Context
ctx [ExtensionRaw]
shExtensions Bool
False
            Context -> [ExtensionRaw] -> Maybe SessionData -> IO ()
updateContext12 Context
ctx [ExtensionRaw]
shExtensions Maybe SessionData
resumingSession
processServerHello ClientParams
_ Context
_ Handshake
p = [Char] -> Maybe [Char] -> 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]
"server hello")

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

processServerExtension :: ExtensionRaw -> TLSSt ()
processServerExtension :: ExtensionRaw -> TLSSt ()
processServerExtension (ExtensionRaw ExtensionID
extID ByteString
content)
    | ExtensionID
extID ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
EID_SecureRenegotiation = do
        VerifyData ByteString
cvd <- Role -> TLSSt VerifyData
getVerifyData Role
ClientRole
        VerifyData ByteString
svd <- Role -> TLSSt VerifyData
getVerifyData Role
ServerRole
        let bs :: ByteString
bs = SecureRenegotiation -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode (SecureRenegotiation -> ByteString)
-> SecureRenegotiation -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> SecureRenegotiation
SecureRenegotiation ByteString
cvd ByteString
svd
        Bool -> TLSSt () -> TLSSt ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
bs ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
content) (TLSSt () -> TLSSt ()) -> TLSSt () -> TLSSt ()
forall a b. (a -> b) -> a -> b
$
            TLSError -> TLSSt ()
forall a. TLSError -> TLSSt a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TLSError -> TLSSt ()) -> TLSError -> TLSSt ()
forall a b. (a -> b) -> a -> b
$
                [Char] -> AlertDescription -> TLSError
Error_Protocol [Char]
"server secure renegotiation data not matching" AlertDescription
HandshakeFailure
    | ExtensionID
extID ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
EID_SupportedVersions = case MessageType -> ByteString -> Maybe SupportedVersions
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTServerHello ByteString
content of
        Just (SupportedVersionsServerHello Version
ver) -> Version -> TLSSt ()
setVersion Version
ver
        Maybe SupportedVersions
_ -> () -> TLSSt ()
forall a. a -> TLSSt a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | ExtensionID
extID ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
EID_KeyShare = do
        Bool
hrr <- TLSSt Bool
getTLS13HRR
        let msgt :: MessageType
msgt = if Bool
hrr then MessageType
MsgTHelloRetryRequest else MessageType
MsgTServerHello
        Maybe KeyShare -> TLSSt ()
setTLS13KeyShare (Maybe KeyShare -> TLSSt ()) -> Maybe KeyShare -> TLSSt ()
forall a b. (a -> b) -> a -> b
$ MessageType -> ByteString -> Maybe KeyShare
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
msgt ByteString
content
    | ExtensionID
extID ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
EID_PreSharedKey =
        Maybe PreSharedKey -> TLSSt ()
setTLS13PreSharedKey (Maybe PreSharedKey -> TLSSt ()) -> Maybe PreSharedKey -> TLSSt ()
forall a b. (a -> b) -> a -> b
$ MessageType -> ByteString -> Maybe PreSharedKey
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTServerHello ByteString
content
    | ExtensionID
extID ExtensionID -> ExtensionID -> Bool
forall a. Eq a => a -> a -> Bool
== ExtensionID
EID_SessionTicket = ByteString -> TLSSt ()
setTLS12SessionTicket ByteString
"" -- empty ticket
processServerExtension ExtensionRaw
_ = () -> TLSSt ()
forall a. a -> TLSSt a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

updateContext13 :: Context -> Cipher -> Bool -> IO ()
updateContext13 :: Context -> Cipher -> Bool -> IO ()
updateContext13 Context
ctx Cipher
usedCipher Bool
isHRR = do
    Established
established <- Context -> IO Established
ctxEstablished Context
ctx
    Bool
eof <- Context -> IO Bool
ctxEOF Context
ctx
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
== Established
Established Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
eof) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        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]
"renegotiation to TLS 1.3 or later is not allowed"
                AlertDescription
ProtocolVersion
    IO (Either TLSError ()) -> IO ()
forall (m :: * -> *) a. MonadIO m => m (Either TLSError a) -> m a
failOnEitherError (IO (Either TLSError ()) -> IO ())
-> IO (Either TLSError ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Cipher -> Bool -> IO (Either TLSError ())
setServerHelloParameters13 Context
ctx Cipher
usedCipher Bool
isHRR

updateContext12 :: Context -> [ExtensionRaw] -> Maybe SessionData -> IO ()
updateContext12 :: Context -> [ExtensionRaw] -> Maybe SessionData -> IO ()
updateContext12 Context
ctx [ExtensionRaw]
shExtensions Maybe SessionData
resumingSession = do
    Bool
ems <- Context -> Version -> MessageType -> [ExtensionRaw] -> IO Bool
forall (m :: * -> *).
MonadIO m =>
Context -> Version -> MessageType -> [ExtensionRaw] -> m Bool
processExtendedMainSecret Context
ctx Version
TLS12 MessageType
MsgTServerHello [ExtensionRaw]
shExtensions
    case Maybe SessionData
resumingSession of
        Maybe SessionData
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just SessionData
sessionData -> do
            let 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
sessionData
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
ems Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= Bool
emsSession) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                let err :: [Char]
err = [Char]
"server resumes a session which is not EMS consistent"
                 in 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]
err AlertDescription
HandshakeFailure
            let mainSecret :: ByteString
mainSecret = SessionData -> ByteString
sessionSecret SessionData
sessionData
            Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> Role -> ByteString -> HandshakeM ()
setMainSecret Version
TLS12 Role
ClientRole ByteString
mainSecret
            Context -> MainSecret -> IO ()
forall a. LogLabel a => Context -> a -> IO ()
logKey Context
ctx (ByteString -> MainSecret
MainSecret ByteString
mainSecret)

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

processRecordSizeLimit
    :: Context -> [ExtensionRaw] -> Bool -> IO ()
processRecordSizeLimit :: Context -> [ExtensionRaw] -> Bool -> IO ()
processRecordSizeLimit Context
ctx [ExtensionRaw]
shExtensions Bool
tls13 = do
    let mmylim :: Maybe Int
mmylim = Limit -> Maybe Int
limitRecordSize (Limit -> Maybe Int) -> Limit -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Shared -> Limit
sharedLimit (Shared -> Limit) -> Shared -> Limit
forall a b. (a -> b) -> a -> b
$ Context -> Shared
ctxShared Context
ctx
    case Maybe Int
mmylim of
        Maybe Int
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Just Int
mylim -> do
            ExtensionID
-> MessageType
-> [ExtensionRaw]
-> IO ()
-> (RecordSizeLimit -> IO ())
-> IO ()
forall a b.
Extension a =>
ExtensionID
-> MessageType -> [ExtensionRaw] -> IO b -> (a -> IO b) -> IO b
lookupAndDecodeAndDo
                ExtensionID
EID_RecordSizeLimit
                MessageType
MsgTClientHello
                [ExtensionRaw]
shExtensions
                (() -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                (Context -> Bool -> RecordSizeLimit -> IO ()
setPeerRecordSizeLimit Context
ctx Bool
tls13)
            Bool
ack <- Context -> IO Bool
checkPeerRecordLimit Context
ctx
            -- When a client sends RecordSizeLimit, it does not know
            -- which TLS version the server selects.  RecordLimit is
            -- the length of plaintext.  But RecordSizeLimit also
            -- includes CT: and padding for TLS 1.3.  To convert
            -- RecordSizeLimit to RecordLimit, we should reduce the
            -- value by 1, which is the length of CT:.
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
ack Bool -> Bool -> Bool
&& Bool
tls13) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Maybe Int -> IO ()
setMyRecordLimit Context
ctx (Maybe Int -> IO ()) -> Maybe Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
mylim Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

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

checkECHacceptance :: Context -> Bool -> Hash -> ServerHello -> IO Bool
checkECHacceptance :: Context -> Bool -> Hash -> ServerHello -> IO Bool
checkECHacceptance Context
ctx Bool
False Hash
usedHash sh :: ServerHello
sh@SH{[ExtensionRaw]
CompressionID
Version
CipherId
Session
ServerRandom
shVersion :: ServerHello -> Version
shRandom :: ServerHello -> ServerRandom
shSession :: ServerHello -> Session
shCipher :: ServerHello -> CipherId
shComp :: ServerHello -> CompressionID
shExtensions :: ServerHello -> [ExtensionRaw]
shVersion :: Version
shRandom :: ServerRandom
shSession :: Session
shCipher :: CipherId
shComp :: CompressionID
shExtensions :: [ExtensionRaw]
..} = do
    let (ByteString
prefix, ByteString
confirm) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
24 (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ServerRandom -> ByteString
unServerRandom ServerRandom
shRandom
        sr' :: ServerRandom
sr' = ByteString -> ServerRandom
ServerRandom (ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\x00\x00\x00\x00\x00\x00\x00\x00")
    ByteString
verified <-
        Context -> Hash -> ServerHello -> ByteString -> IO ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
Context -> Hash -> ServerHello -> ByteString -> m ByteString
computeConfirm Context
ctx Hash
usedHash ServerHello
sh{shRandom = sr'} ByteString
"ech accept confirmation"
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
confirm ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
verified)
checkECHacceptance Context
ctx Bool
True Hash
usedHash sh :: ServerHello
sh@SH{[ExtensionRaw]
CompressionID
Version
CipherId
Session
ServerRandom
shVersion :: ServerHello -> Version
shRandom :: ServerHello -> ServerRandom
shSession :: ServerHello -> Session
shCipher :: ServerHello -> CipherId
shComp :: ServerHello -> CompressionID
shExtensions :: ServerHello -> [ExtensionRaw]
shVersion :: Version
shRandom :: ServerRandom
shSession :: Session
shCipher :: CipherId
shComp :: CompressionID
shExtensions :: [ExtensionRaw]
..} = do
    case [ExtensionRaw] -> Maybe (ByteString, [ExtensionRaw])
replace [ExtensionRaw]
shExtensions of
        Maybe (ByteString, [ExtensionRaw])
Nothing -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just (ByteString
confirm, [ExtensionRaw]
shExts') -> do
            ByteString
verified <-
                Context -> Hash -> ServerHello -> ByteString -> IO ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
Context -> Hash -> ServerHello -> ByteString -> m ByteString
computeConfirm
                    Context
ctx
                    Hash
usedHash
                    ServerHello
sh{shExtensions = shExts'}
                    ByteString
"hrr ech accept confirmation"
            Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
confirm ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
verified)
  where
    replace :: [ExtensionRaw] -> Maybe (ByteString, [ExtensionRaw])
replace [] = Maybe (ByteString, [ExtensionRaw])
forall a. Maybe a
Nothing
    replace (ExtensionRaw ExtensionID
EID_EncryptedClientHello ByteString
confirm : [ExtensionRaw]
es) =
        (ByteString, [ExtensionRaw]) -> Maybe (ByteString, [ExtensionRaw])
forall a. a -> Maybe a
Just
            ( ByteString
confirm
            , ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_EncryptedClientHello ByteString
"\x00\x00\x00\x00\x00\x00\x00\x00" ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: [ExtensionRaw]
es
            )
    replace (ExtensionRaw
e : [ExtensionRaw]
es) = case [ExtensionRaw] -> Maybe (ByteString, [ExtensionRaw])
replace [ExtensionRaw]
es of
        Maybe (ByteString, [ExtensionRaw])
Nothing -> Maybe (ByteString, [ExtensionRaw])
forall a. Maybe a
Nothing
        Just (ByteString
confirm, [ExtensionRaw]
es') -> (ByteString, [ExtensionRaw]) -> Maybe (ByteString, [ExtensionRaw])
forall a. a -> Maybe a
Just (ByteString
confirm, ExtensionRaw
e ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: [ExtensionRaw]
es')