Common13.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module Network.TLS.Handshake.Common13 (
    makeFinished,
    checkFinished,
    makeServerKeyShare,
    makeClientKeyShare,
    fromServerKeyShare,
    makeCertVerify,
    checkCertVerify,
    makePSKBinder,
    replacePSKBinder,
    sendChangeCipherSpec13,
    makeCertRequest,
    createTLS13TicketInfo,
    ageToObfuscatedAge,
    isAgeValid,
    getAge,
    checkFreshness,
    getCurrentTimeFromBase,
    getSessionData13,
    isHashSignatureValid13,
    safeNonNegative32,
    RecvHandshake13M,
    runRecvHandshake13,
    recvHandshake13,
    recvHandshake13hash,
    CipherChoice (..),
    makeCipherChoice,
    initEarlySecret,
    calculateEarlySecret,
    calculateHandshakeSecret,
    calculateApplicationSecret,
    calculateResumptionSecret,
    derivePSK,
    checkClientKeyShareKeyLength,
    checkServerKeyShareKeyLength,
    setRTT,
    computeConfirm,
    updateTranscriptHash13,
    setServerHelloParameters13,
    finishHandshake13,
) where

import Control.Concurrent.MVar
import Control.Monad.State.Strict
import Data.ByteArray (convert)
import qualified Data.ByteString as B
import Data.UnixTime
import Foreign.C.Types (CTime (..))
import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Crypto
import qualified Network.TLS.Crypto.IES as IES

import Network.TLS.Compression
import Network.TLS.Extension
import Network.TLS.Handshake.Certificate (extractCAname)
import Network.TLS.Handshake.Common (unexpected)
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.Handshake.TranscriptHash
import Network.TLS.IO
import Network.TLS.IO.Encode
import Network.TLS.Imports
import Network.TLS.KeySchedule
import Network.TLS.MAC
import Network.TLS.Packet13
import Network.TLS.Parameters
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types
import Network.TLS.Wire

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

makeFinished :: MonadIO m => Context -> Hash -> Secret -> m Handshake13
makeFinished ctx usedHash baseKey = do
    verifyData <-
        VerifyData . makeVerifyData usedHash baseKey
            <$> transcriptHash ctx "makeFinished"
    liftIO $ usingState_ ctx $ setVerifyDataForSend verifyData
    pure $ Finished13 verifyData

checkFinished
    :: MonadIO m
    => Context -> Hash -> Secret -> TranscriptHash -> VerifyData -> m ()
checkFinished ctx usedHash baseKey (TranscriptHash hashValue) vd@(VerifyData verifyData) = do
    let verifyData' = makeVerifyData usedHash baseKey $ TranscriptHash hashValue
    when (B.length verifyData /= B.length verifyData') $
        throwCore $
            Error_Protocol "broken Finished" DecodeError
    unless (verifyData' == verifyData) $ decryptError "finished verification failed"
    liftIO $ usingState_ ctx $ setVerifyDataForRecv vd

makeVerifyData :: Hash -> Secret -> TranscriptHash -> ByteString
makeVerifyData usedHash baseKey (TranscriptHash th) =
    hmac usedHash finishedKey th
  where
    hashSize = hashDigestSize usedHash
    finishedKey = hkdfExpandLabel usedHash baseKey "finished" "" hashSize

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

makeClientKeyShare
    :: Context -> Group -> IO ((Group, IES.GroupPrivate), KeyShareEntry)
makeClientKeyShare ctx grp = do
    (cpri, cpub) <- generateGroup ctx grp
    let wcpub = IES.groupEncodePublicA cpub
        clientKeyShare = KeyShareEntry grp wcpub
    return ((grp, cpri), clientKeyShare)

makeServerKeyShare :: Context -> KeyShareEntry -> IO (Secret, KeyShareEntry)
makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of
    Left e -> throwCore $ Error_Protocol (show e) IllegalParameter
    Right cpub -> do
        ecdhePair <- encapsulateGroup ctx cpub
        case ecdhePair of
            Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter
            Just (spub, share) ->
                let wspub = IES.groupEncodePublicB spub
                    serverKeyShare = KeyShareEntry grp wspub
                 in return (share, serverKeyShare)
  where
    ecpub = IES.groupDecodePublicA grp wcpub
    msgInvalidPublic = "invalid client " ++ show grp ++ " public key"

fromServerKeyShare
    :: KeyShareEntry -> [(Group, IES.GroupPrivate)] -> IO Secret
fromServerKeyShare (KeyShareEntry grp wspub) grpCpris = case espub of
    Left e -> throwCore $ Error_Protocol (show e) IllegalParameter
    Right spub -> case lookup grp grpCpris of
        Nothing -> throwCore err
        Just cpri -> case IES.groupDecapsulate spub cpri of
            Just shared -> return shared
            Nothing -> throwCore err
  where
    err = Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter
    espub = IES.groupDecodePublicB grp wspub

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

serverContextString :: ByteString
serverContextString = "TLS 1.3, server CertificateVerify"

clientContextString :: ByteString
clientContextString = "TLS 1.3, client CertificateVerify"

makeCertVerify
    :: MonadIO m
    => Context
    -> PubKey
    -> HashAndSignatureAlgorithm
    -> TranscriptHash
    -> m Handshake13
makeCertVerify ctx pub hs (TranscriptHash hashValue) = do
    role <- liftIO $ usingState_ ctx getRole
    let ctxStr
            | role == ClientRole = clientContextString
            | otherwise = serverContextString
        target = makeTarget ctxStr hashValue
    CertVerify13 . DigitallySigned hs <$> sign ctx pub hs target

checkCertVerify
    :: MonadIO m
    => Context
    -> PubKey
    -> HashAndSignatureAlgorithm
    -> Signature
    -> ByteString
    -> m Bool
checkCertVerify ctx pub hs signature hashValue
    | pub `signatureCompatible13` hs = liftIO $ do
        role <- usingState_ ctx getRole
        let ctxStr
                | role == ClientRole = serverContextString -- opposite context
                | otherwise = clientContextString
            target = makeTarget ctxStr hashValue
            sigParams = signatureParams pub hs
        checkHashSignatureValid13 hs
        checkSupportedHashSignature ctx hs
        verifyPublic ctx sigParams target signature
    | otherwise = return False

makeTarget :: ByteString -> ByteString -> ByteString
makeTarget contextString hashValue = runPut $ do
    putBytes $ B.replicate 64 32
    putBytes contextString
    putWord8 0
    putBytes hashValue

sign
    :: MonadIO m
    => Context
    -> PubKey
    -> HashAndSignatureAlgorithm
    -> ByteString
    -> m Signature
sign ctx pub hs target = liftIO $ do
    role <- usingState_ ctx getRole
    let sigParams = signatureParams pub hs
    signPrivate ctx role sigParams target

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

makePSKBinder
    :: BaseSecret EarlySecret
    -> Hash
    -> Int
    -> ByteString
    -- ^ Encoded client hello
    -> ByteString
makePSKBinder (BaseSecret sec) usedHash truncLen ech =
    makeVerifyData usedHash binderKey hChTruncated
  where
    hChTruncated = TranscriptHash $ hash usedHash $ trunc ech
    th = TranscriptHash $ hash usedHash ""
    binderKey = deriveSecret usedHash sec "res binder" th
    trunc x = B.take takeLen x
      where
        totalLen = B.length x
        takeLen = totalLen - truncLen

replacePSKBinder :: ByteString -> [ByteString] -> ByteString
replacePSKBinder pskz bds = tLidentities <> binders
  where
    tLidentities = B.take (B.length pskz - B.length binders) pskz
    -- See instance Extension PreSharedKey
    binders = runPut $ putOpaque16 $ runPut (mapM_ putBinder bds)
    putBinder = putOpaque8

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

sendChangeCipherSpec13 :: Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 ctx = do
    sent <- usingHState ctx $ do
        b <- getCCS13Sent
        unless b $ setCCS13Sent True
        return b
    unless sent $ loadPacket13 ctx ChangeCipherSpec13

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

makeCertRequest
    :: ServerParams -> Context -> CertReqContext -> Bool -> Handshake13
makeCertRequest sparams ctx certReqCtx zlib =
    let sigAlgs = SignatureAlgorithms $ supportedHashSignatures $ ctxSupported ctx
        signatureAlgExt = Just $ toExtensionRaw sigAlgs

        compCertExt
            | zlib = Just $ toExtensionRaw $ CompressCertificate [CCA_Zlib]
            | otherwise = Nothing

        caDns = map extractCAname $ serverCACertificates sparams
        caExt
            | null caDns = Nothing
            | otherwise = Just $ toExtensionRaw $ CertificateAuthorities caDns

        crexts =
            catMaybes
                [ {- 0x0d -} signatureAlgExt
                , {- 0x1b -} compCertExt
                , {- 0x2f -} caExt
                ]
     in CertRequest13 certReqCtx crexts

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

createTLS13TicketInfo
    :: Second -> Either Context Second -> Maybe Millisecond -> IO TLS13TicketInfo
createTLS13TicketInfo life ecw mrtt = do
    -- Left:  serverSendTime
    -- Right: clientReceiveTime
    bTime <- getCurrentTimeFromBase
    add <- case ecw of
        Left ctx -> B.foldl' (*+) 0 <$> getStateRNG ctx 4
        Right ad -> return ad
    return $
        TLS13TicketInfo
            { lifetime = life
            , ageAdd = add
            , txrxTime = bTime
            , estimatedRTT = mrtt
            }
  where
    x *+ y = x * 256 + fromIntegral y

ageToObfuscatedAge :: Second -> TLS13TicketInfo -> Second
ageToObfuscatedAge age TLS13TicketInfo{..} = obfage
  where
    obfage = age + ageAdd

obfuscatedAgeToAge :: Second -> TLS13TicketInfo -> Second
obfuscatedAgeToAge obfage TLS13TicketInfo{..} = age
  where
    age = obfage - ageAdd

isAgeValid :: Second -> TLS13TicketInfo -> Bool
isAgeValid age TLS13TicketInfo{..} = age <= lifetime * 1000

getAge :: TLS13TicketInfo -> IO Second
getAge TLS13TicketInfo{..} = do
    let clientReceiveTime = txrxTime
    clientSendTime <- getCurrentTimeFromBase
    return $ fromIntegral (clientSendTime - clientReceiveTime) -- milliseconds

checkFreshness :: TLS13TicketInfo -> Second -> IO Bool
checkFreshness tinfo@TLS13TicketInfo{..} obfAge = do
    serverReceiveTime <- getCurrentTimeFromBase
    let freshness =
            if expectedArrivalTime > serverReceiveTime
                then expectedArrivalTime - serverReceiveTime
                else serverReceiveTime - expectedArrivalTime
    -- Some implementations round age up to second.
    -- We take max of 2000 and rtt in the case where rtt is too small.
    let tolerance = max 2000 rtt
        isFresh = freshness < tolerance
    return $ isAlive && isFresh
  where
    serverSendTime = txrxTime
    rtt = fromJust estimatedRTT
    age = obfuscatedAgeToAge obfAge tinfo
    expectedArrivalTime = serverSendTime + rtt + fromIntegral age
    isAlive = isAgeValid age tinfo

getCurrentTimeFromBase :: IO Millisecond
getCurrentTimeFromBase = millisecondsFromBase <$> getUnixTime

millisecondsFromBase :: UnixTime -> Millisecond
millisecondsFromBase (UnixTime (CTime s) us) =
    fromIntegral ((s - base) * 1000) + fromIntegral (us `div` 1000)
  where
    base = 1483228800

-- UnixTime (CTime base) _= parseUnixTimeGMT webDateFormat "Sun, 01 Jan 2017 00:00:00 GMT"

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

getSessionData13
    :: Context -> Cipher -> TLS13TicketInfo -> Int -> ByteString -> IO SessionData
getSessionData13 ctx usedCipher tinfo maxSize psk = do
    ver <- usingState_ ctx getVersion
    malpn <- usingState_ ctx getNegotiatedProtocol
    sni <- usingState_ ctx getClientSNI
    mgrp <- usingHState ctx getSupportedGroup
    return
        SessionData
            { sessionVersion = ver
            , sessionCipher = cipherID usedCipher
            , sessionCompression = 0
            , sessionClientSNI = sni
            , sessionSecret = psk
            , sessionGroup = mgrp
            , sessionTicketInfo = Just tinfo
            , sessionALPN = malpn
            , sessionMaxEarlyDataSize = maxSize
            , sessionFlags = []
            }

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

-- Word32 is used in TLS 1.3 protocol.
-- Int is used for API for Haskell TLS because it is natural.
-- If Int is 64 bits, users can specify bigger number than Word32.
-- If Int is 32 bits, 2^31 or larger may be converted into minus numbers.
safeNonNegative32 :: (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 x
    | x <= 0 = 0
    | finiteBitSize x <= 32 = x
    | otherwise = x `min` fromIntegral (maxBound :: Word32)

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

newtype RecvHandshake13M m a
    = RecvHandshake13M (StateT [Handshake13R] m a)
    deriving (Functor, Applicative, Monad, MonadIO)

recvHandshake13
    :: MonadIO m
    => Context
    -> (Handshake13 -> RecvHandshake13M m a)
    -> RecvHandshake13M m a
recvHandshake13 ctx f = getHandshake13 ctx >>= \(h, _b) -> f h

recvHandshake13hash
    :: MonadIO m
    => Context
    -> String
    -> (TranscriptHash -> Handshake13 -> RecvHandshake13M m a)
    -> RecvHandshake13M m a
recvHandshake13hash ctx label f = do
    d <- transcriptHash ctx label
    getHandshake13 ctx >>= \(h, _b) -> f d h

getHandshake13
    :: MonadIO m => Context -> RecvHandshake13M m Handshake13R
getHandshake13 ctx = RecvHandshake13M $ do
    currentState <- get
    case currentState of
        hb : hbs -> found hb hbs
        _ -> recvLoop
  where
    found hb hbs = liftIO (updateTranscriptHash13 ctx hb) >> put hbs >> return hb
    recvLoop = do
        epkt <- liftIO (recvPacket13 ctx)
        case epkt of
            Right (Handshake13 [] _) -> error "invalid recvPacket13 result"
            Right (Handshake13 (h : hs) (b : bs)) -> found (h, b) $ zip hs bs
            Right ChangeCipherSpec13 -> do
                alreadyReceived <- liftIO $ usingHState ctx getCCS13Recv
                if alreadyReceived
                    then
                        liftIO $ throwCore $ Error_Protocol "multiple CSS in TLS 1.3" UnexpectedMessage
                    else do
                        liftIO $ usingHState ctx $ setCCS13Recv True
                        recvLoop
            Right (Alert13 _) -> throwCore Error_TCP_Terminate
            Right x -> unexpected (show x) (Just "handshake 13")
            Left err -> throwCore err

runRecvHandshake13 :: MonadIO m => RecvHandshake13M m a -> m a
runRecvHandshake13 (RecvHandshake13M f) = do
    (result, new) <- runStateT f []
    unless (null new) $ unexpected "spurious handshake 13" Nothing
    return result

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

-- some hash/signature combinations have been deprecated in TLS13 and should
-- not be used
checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO ()
checkHashSignatureValid13 hs =
    unless (isHashSignatureValid13 hs) $
        let msg = "invalid TLS13 hash and signature algorithm: " ++ show hs
         in throwCore $ Error_Protocol msg IllegalParameter

isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 hs = hs `elem` signatureSchemesForTLS13

{-
isHashSignatureValid13 (HashIntrinsic, s) =
    s
        `elem` [ SignatureRSApssRSAeSHA256
               , SignatureRSApssRSAeSHA384
               , SignatureRSApssRSAeSHA512
               , SignatureEd25519
               , SignatureEd448
               , SignatureRSApsspssSHA256
               , SignatureRSApsspssSHA384
               , SignatureRSApsspssSHA512
               ]
isHashSignatureValid13 (h, SignatureECDSA) =
    h `elem` [HashSHA256, HashSHA384, HashSHA512]
isHashSignatureValid13 _ = False
-}

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

calculateEarlySecret
    :: Context
    -> CipherChoice
    -> Either ByteString (BaseSecret EarlySecret)
    -> IO (SecretPair EarlySecret)
calculateEarlySecret ctx choice maux = do
    (_ch, b) <- fromJust <$> usingHState ctx getClientHello
    let hCh = TranscriptHash $ hashChunks usedHash b
    let earlySecret = case maux of
            Right (BaseSecret sec) -> sec
            Left psk -> hkdfExtract usedHash zero (convert psk)
        clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh
        cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret
    logKey ctx cets
    return $ SecretPair (BaseSecret earlySecret) cets
  where
    usedHash = cHash choice
    zero = cZero choice

initEarlySecret :: CipherChoice -> Maybe ByteString -> BaseSecret EarlySecret
initEarlySecret choice mpsk = BaseSecret sec
  where
    sec = hkdfExtract usedHash zero zeroOrPSK
    usedHash = cHash choice
    zero = cZero choice
    zeroOrPSK = fromMaybe zero (convert <$> mpsk)

calculateHandshakeSecret
    :: Context
    -> CipherChoice
    -> BaseSecret EarlySecret
    -> Secret
    -> IO (SecretTriple HandshakeSecret)
calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do
    hChSh <- transcriptHash ctx "CH..SH"
    let th = TranscriptHash $ hash usedHash ""
        handshakeSecret =
            hkdfExtract
                usedHash
                (deriveSecret usedHash sec "derived" th)
                ecdhe
    let clientHandshakeSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh
        serverHandshakeSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh
    let shts =
            ServerTrafficSecret serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
        chts =
            ClientTrafficSecret clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret
    logKey ctx shts
    logKey ctx chts
    return $ SecretTriple (BaseSecret handshakeSecret) chts shts
  where
    usedHash = cHash choice

calculateApplicationSecret
    :: Context
    -> CipherChoice
    -> BaseSecret HandshakeSecret
    -> TranscriptHash
    -> IO (SecretTriple ApplicationSecret)
calculateApplicationSecret ctx choice (BaseSecret sec) hChSf = do
    let th = TranscriptHash $ hash usedHash ""
        applicationSecret =
            hkdfExtract
                usedHash
                (deriveSecret usedHash sec "derived" th)
                zero
    let clientApplicationSecret0 = deriveSecret usedHash applicationSecret "c ap traffic" hChSf
        serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf
        exporterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf
    usingState_ ctx $ setTLS13ExporterSecret exporterSecret
    let sts0 =
            ServerTrafficSecret serverApplicationSecret0
                :: ServerTrafficSecret ApplicationSecret
    let cts0 =
            ClientTrafficSecret clientApplicationSecret0
                :: ClientTrafficSecret ApplicationSecret
    logKey ctx sts0
    logKey ctx cts0
    return $ SecretTriple (BaseSecret applicationSecret) cts0 sts0
  where
    usedHash = cHash choice
    zero = cZero choice

calculateResumptionSecret
    :: Context
    -> CipherChoice
    -> BaseSecret ApplicationSecret
    -> IO (BaseSecret ResumptionSecret)
calculateResumptionSecret ctx choice (BaseSecret sec) = do
    hChCf <- transcriptHash ctx "CH..CF"
    let resumptionSecret = deriveSecret usedHash sec "res master" hChCf
    return $ BaseSecret resumptionSecret
  where
    usedHash = cHash choice

derivePSK
    :: CipherChoice -> BaseSecret ResumptionSecret -> TicketNonce -> ByteString
derivePSK choice (BaseSecret sec) (TicketNonce nonce) =
    hkdfExpandLabel usedHash sec "resumption" nonce hashSize
  where
    usedHash = cHash choice
    hashSize = hashDigestSize usedHash

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

checkClientKeyShareKeyLength :: KeyShareEntry -> Bool
checkClientKeyShareKeyLength ks = clientKeyShareKeyLength grp == B.length key
  where
    grp = keyShareEntryGroup ks
    key = keyShareEntryKeyExchange ks

{- FOURMOLU_DISABLE -}
clientKeyShareKeyLength :: Group -> Int
clientKeyShareKeyLength P256   = 65  -- 32 * 2 + 1
clientKeyShareKeyLength P384   = 97  -- 48 * 2 + 1
clientKeyShareKeyLength P521   = 133 -- 66 * 2 + 1
clientKeyShareKeyLength X25519 = 32
clientKeyShareKeyLength X448   = 56
clientKeyShareKeyLength FFDHE2048 = 256
clientKeyShareKeyLength FFDHE3072 = 384
clientKeyShareKeyLength FFDHE4096 = 512
clientKeyShareKeyLength FFDHE6144 = 768
clientKeyShareKeyLength FFDHE8192 = 1024
clientKeyShareKeyLength MLKEM512  = 800
clientKeyShareKeyLength MLKEM768  = 1184
clientKeyShareKeyLength MLKEM1024 = 1568
clientKeyShareKeyLength X25519MLKEM768 = 1216
clientKeyShareKeyLength P256MLKEM768   = 1249
clientKeyShareKeyLength P384MLKEM1024  = 1665
clientKeyShareKeyLength _ = error "clientKeyShareKeyLength"
{- FOURMOLU_ENABLE -}

checkServerKeyShareKeyLength :: KeyShareEntry -> Bool
checkServerKeyShareKeyLength ks = serverKeyShareKeyLength grp == B.length key
  where
    grp = keyShareEntryGroup ks
    key = keyShareEntryKeyExchange ks

{- FOURMOLU_DISABLE -}
serverKeyShareKeyLength :: Group -> Int
serverKeyShareKeyLength P256   = 65  -- 32 * 2 + 1
serverKeyShareKeyLength P384   = 97  -- 48 * 2 + 1
serverKeyShareKeyLength P521   = 133 -- 66 * 2 + 1
serverKeyShareKeyLength X25519 = 32
serverKeyShareKeyLength X448   = 56
serverKeyShareKeyLength FFDHE2048 = 256
serverKeyShareKeyLength FFDHE3072 = 384
serverKeyShareKeyLength FFDHE4096 = 512
serverKeyShareKeyLength FFDHE6144 = 768
serverKeyShareKeyLength FFDHE8192 = 1024
serverKeyShareKeyLength MLKEM512  = 768
serverKeyShareKeyLength MLKEM768  = 1088
serverKeyShareKeyLength MLKEM1024 = 1568
serverKeyShareKeyLength X25519MLKEM768 = 1120
serverKeyShareKeyLength P256MLKEM768   = 1153
serverKeyShareKeyLength P384MLKEM1024  = 1665
serverKeyShareKeyLength _ = error "clientKeyShareKeyLength"
{- FOURMOLU_ENABLE -}

setRTT :: Context -> Millisecond -> IO ()
setRTT ctx chSentTime = do
    shRecvTime <- getCurrentTimeFromBase
    let rtt' = shRecvTime - chSentTime
        rtt = if rtt' == 0 then 10 else rtt'
    modifyTLS13State ctx $ \st -> st{tls13stRTT = rtt}

computeConfirm
    :: (MonadFail m, MonadIO m)
    => Context -> Hash -> ServerHello -> ByteString -> m ByteString
computeConfirm ctx usedHash sh label = do
    (CH{..}, _b) <- fromJust <$> liftIO (usingHState ctx getClientHello)
    TranscriptHash echConf <-
        transcriptHashWith ctx "ECH acceptance" $ encodeHandshake13 $ ServerHello13 sh
    let prk = hkdfExtract usedHash "" $ unClientRandom chRandom
    return $ hkdfExpandLabel usedHash (convert prk) label echConf 8

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

setServerHelloParameters13
    :: Context -> Cipher -> Bool -> IO (Either TLSError ())
setServerHelloParameters13 ctx cipher isHRR = do
    transitTranscriptHash ctx "transit" (cipherHash cipher) isHRR
    usingHState ctx $ do
        hst <- get
        case hstPendingCipher hst of
            Nothing -> do
                put
                    hst
                        { hstPendingCipher = Just cipher
                        , hstPendingCompression = nullCompression
                        }
                return $ Right ()
            Just oldcipher
                | cipher == oldcipher -> return $ Right ()
                | otherwise ->
                    return $
                        Left $
                            Error_Protocol "TLS 1.3 cipher changed after hello retry" IllegalParameter

-- | TLS13 handshake wrap up & clean up.  Contrary to
-- @finishHandshake12@, this does not handle session, which is managed
-- separately for TLS 1.3.  This does not reset byte counters because
-- renegotiation is not allowed.  And a few more state attributes are
-- preserved, necessary for TLS13 handshake modes, session tickets and
-- post-handshake authentication.
finishHandshake13 :: Context -> IO ()
finishHandshake13 ctx = do
    -- forget most handshake data
    modifyMVar_ (ctxHandshakeState ctx) $ \case
        Nothing -> return Nothing
        Just hshake ->
            return $
                Just
                    (newEmptyHandshake (hstClientVersion hshake) (hstClientRandom hshake))
                        { hstServerRandom = hstServerRandom hshake
                        , hstMainSecret = hstMainSecret hshake
                        , hstSupportedGroup = hstSupportedGroup hshake
                        , hstTransHashState = hstTransHashState hshake
                        , hstTLS13HandshakeMode = hstTLS13HandshakeMode hshake
                        , hstTLS13RTT0Status = hstTLS13RTT0Status hshake
                        , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake
                        , hstTLS13ECHAccepted = hstTLS13ECHAccepted hshake
                        }
    -- forget handshake data stored in TLS state
    usingState_ ctx $ do
        setTLS13KeyShare Nothing
        setTLS13PreSharedKey Nothing
    -- mark the secure connection up and running.
    setEstablished ctx Established