ClientHello13.hs

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

module Network.TLS.Handshake.Server.ClientHello13 (
    processClientHello13,
    SelectKeyShareResult (..),
) where

import qualified Data.ByteString as B

import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Server.Common
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.IO.Encode
import Network.TLS.Imports
import Network.TLS.Parameters
import Network.TLS.Session
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Types

limitSupportedGroups :: Int
limitSupportedGroups = 64

-- TLS 1.3 or later
processClientHello13
    :: ServerParams
    -> Context
    -> ClientHello
    -> IO
        ( SelectKeyShareResult
        , (Cipher, Hash, Bool) -- rtt0
        , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)
          -- authenticated, is0RTTvalid, ticket ALPN
        )
processClientHello13 sparams ctx ch@CH{..} = do
    when
        (any (\(ExtensionRaw eid _) -> eid == EID_PreSharedKey) $ init chExtensions)
        $ throwCore
        $ Error_Protocol "extension pre_shared_key must be last" IllegalParameter
    -- Deciding cipher.
    -- The shared cipherlist can become empty after filtering for compatible
    -- creds, check now before calling onCipherChoosing, which does not handle
    -- empty lists.
    when (null ciphersFilteredVersion) $
        throwCore $
            Error_Protocol "no cipher in common with the TLS 1.3 client" HandshakeFailure
    usedCipher <- chooseCipher (serverHooks sparams) TLS13 ciphersFilteredVersion
    let usedHash = cipherHash usedCipher
        rtt0 =
            lookupAndDecode
                EID_EarlyData
                MsgTClientHello
                chExtensions
                False
                (\(EarlyDataIndication _) -> True)
    if rtt0
        then
            -- mark a 0-RTT attempt before a possible HRR, and before updating the
            -- status again if 0-RTT successful
            setEstablished ctx (EarlyDataNotAllowed 3) -- hardcoding
        else
            -- In the case of HRR, EarlyDataNotAllowed is already set.
            -- It should be cleared here.
            setEstablished ctx NotEstablished
    -- Deciding key exchange from key shares
    let require =
            throwCore $
                Error_Protocol
                    "key exchange not implemented, expected key_share extension"
                    MissingExtension
        extract (KeyShareClientHello kses) = return kses
        extract _ = require
    keyShares <-
        lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract
    let clientGroups =
            take limitSupportedGroups $
                lookupAndDecode
                    EID_SupportedGroups
                    MsgTClientHello
                    chExtensions
                    []
                    (\(SupportedGroups gs) -> gs)
    (mgroup, doHRR) <-
        onSelectKeyShare
            (serverHooks sparams)
            serverGroups
            clientGroups
            $ map keyShareEntryGroup keyShares
    keyshareResult <- case mgroup of
        Nothing -> return SelectKeyShareNotFound
        Just g
            | doHRR -> return $ SelectKeyShareHRR g
            | otherwise -> case filter (\e -> keyShareEntryGroup e == g) keyShares of
                [] -> return SelectKeyShareNotFound
                [x] -> return $ SelectKeyShareFound x
                _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter

    let triple = (usedCipher, usedHash, rtt0)
    pskEarlySecret <- pskAndEarlySecret sparams ctx triple ch
    (ich, b) <- fromJust <$> usingHState ctx getClientHello
    updateTranscriptHash12 ctx (ClientHello ich, b)
    return (keyshareResult, triple, pskEarlySecret)
  where
    ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers
    serverCiphers =
        filter
            (cipherAllowedForVersion TLS13)
            (supportedCiphers $ serverSupported sparams)
    serverGroups = supportedGroupsTLS13 $ serverSupported sparams

data SelectKeyShareResult
    = -- | Negotiation failure
      SelectKeyShareNotFound
    | -- | Send a hello retry request with this group
      SelectKeyShareHRR Group
    | -- | Use this key share
      SelectKeyShareFound KeyShareEntry
    deriving (Eq, Show)

pskAndEarlySecret
    :: ServerParams
    -> Context
    -> (Cipher, Hash, Bool) -- rtt0
    -> ClientHello
    -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool, Maybe ByteString)
    -- authenticated, is0RTTvalid, ticket ALPN
pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do
    (psk, binderInfo, is0RTTvalid, ticketALPN) <- choosePSK
    earlyKey <- calculateEarlySecret ctx choice (Left psk)
    let earlySecret = pairBase earlyKey
        authenticated = isJust binderInfo
    preSharedKeyExt <- checkBinder earlySecret binderInfo
    return (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid, ticketALPN)
  where
    choice = makeCipherChoice TLS13 usedCipher

    choosePSK =
        lookupAndDecodeAndDo
            EID_PreSharedKey
            MsgTClientHello
            chExtensions
            (return (zero, Nothing, False, Nothing))
            selectPSK

    selectPSK (PreSharedKeyClientHello (PskIdentity identity obfAge : _) bnds@(bnd : _)) = do
        when (null dhModes) $
            throwCore $
                Error_Protocol "no psk_key_exchange_modes extension" MissingExtension
        if PSK_DHE_KE `elem` dhModes
            then do
                let len = sum (map (\x -> B.length x + 1) bnds) + 2
                    mgr = sharedSessionManager $ serverShared sparams
                -- sessionInvalidate is not used for TLS 1.3
                -- because PSK is always changed.
                -- So, identity is not stored in Context.
                msdata <-
                    if rtt0
                        then sessionResumeOnlyOnce mgr identity
                        else sessionResume mgr identity
                case msdata of
                    Just sdata -> do
                        let tinfo = fromJust $ sessionTicketInfo sdata
                            psk = sessionSecret sdata
                        isFresh <- checkFreshness tinfo obfAge
                        (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata
                        if isPSKvalid && isFresh
                            then
                                return
                                    ( psk
                                    , Just (bnd, 0 :: Int, len)
                                    , is0RTTvalid
                                    , sessionALPN sdata
                                    )
                            else -- fall back to full handshake
                                return (zero, Nothing, False, Nothing)
                    _ -> return (zero, Nothing, False, Nothing)
            else return (zero, Nothing, False, Nothing)
    selectPSK _ = return (zero, Nothing, False, Nothing)

    checkBinder _ Nothing = return []
    checkBinder earlySecret (Just (binder, n, tlen)) = do
        (_, b) <- fromJust <$> usingHState ctx getClientHello
        let binder' = makePSKBinder earlySecret usedHash tlen $ B.concat b --- xxx
        unless (binder == binder') $
            decryptError "PSK binder validation failed"
        return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n]

    checkSessionEquality sdata = do
        msni <- usingState_ ctx getClientSNI
        let isSameSNI = sessionClientSNI sdata == msni
            isSameCipher = sessionCipher sdata == cipherID usedCipher
            ciphers = supportedCiphers $ serverSupported sparams
            scid = sessionCipher sdata
            isSameKDF = case findCipher scid ciphers of
                Nothing -> False
                Just c -> cipherHash c == cipherHash usedCipher
            isSameVersion = TLS13 == sessionVersion sdata
            isPSKvalid = isSameKDF && isSameSNI -- fixme: SNI is not required
            is0RTTvalid = isSameVersion && isSameCipher
        return (isPSKvalid, is0RTTvalid)

    dhModes =
        lookupAndDecode
            EID_PskKeyExchangeModes
            MsgTClientHello
            chExtensions
            []
            (\(PskKeyExchangeModes ms) -> ms)

    hashSize = hashDigestSize usedHash
    zero = B.replicate hashSize 0