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

    module Network.TLS.Handshake.Server.ServerHello13 (
        sendServerHello13,
    ) where

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

    import Network.TLS.Cipher
    import Network.TLS.Context.Internal
    import Network.TLS.Credentials
    import Network.TLS.Crypto
    import Network.TLS.Extension
    import Network.TLS.Handshake.Common
    import Network.TLS.Handshake.Common13
    import Network.TLS.Handshake.Control
    import Network.TLS.Handshake.Key
    import Network.TLS.Handshake.Random
    import Network.TLS.Handshake.Server.Common
    import Network.TLS.Handshake.Signature
    import Network.TLS.Handshake.State
    import Network.TLS.Handshake.State13
    import Network.TLS.IO
    import Network.TLS.Imports
    import Network.TLS.Parameters
    import Network.TLS.Session
    import Network.TLS.State
    import Network.TLS.Struct
    import Network.TLS.Struct13
    import Network.TLS.Types
    import Network.TLS.X509

    sendServerHello13
        :: ServerParams
        -> Context
        -> KeyShareEntry
        -> (Cipher, Hash, Bool)
        -> CH
        -> IO
            ( SecretTriple ApplicationSecret
            , ClientTrafficSecret HandshakeSecret
            , Bool
            , Bool
            )
    sendServerHello13 :: ServerParams
    -> Context
    -> KeyShareEntry
    -> (Cipher, Hash, Bool)
    -> CH
    -> IO
         (SecretTriple ApplicationSecret,
          ClientTrafficSecret HandshakeSecret, Bool, Bool)
    sendServerHello13 ServerParams
    sparams Context
    ctx KeyShareEntry
    clientKeyShare (Cipher
    usedCipher, Hash
    usedHash, Bool
    rtt0) CH{[CipherId]
    [ExtensionRaw]
    Session
    chSession :: Session
    chCiphers :: [CipherId]
    chExtensions :: [ExtensionRaw]
    chExtensions :: CH -> [ExtensionRaw]
    chCiphers :: CH -> [CipherId]
    chSession :: CH -> Session
    ..} = do
        -- parse CompressCertificate to check if it is broken here
        let zlib :: Bool
    zlib =
                ExtensionID
    -> MessageType
    -> [ExtensionRaw]
    -> Bool
    -> (CompressCertificate -> Bool)
    -> Bool
    forall e a.
    Extension e =>
    ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
    lookupAndDecode
                    ExtensionID
    EID_CompressCertificate
                    MessageType
    MsgTClientHello
                    [ExtensionRaw]
    chExtensions
                    Bool
    False
                    (\(CompressCertificate [CertificateCompressionAlgorithm]
    ccas) -> CertificateCompressionAlgorithm
    CCA_Zlib CertificateCompressionAlgorithm
    -> [CertificateCompressionAlgorithm] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [CertificateCompressionAlgorithm]
    ccas)

        recodeSizeLimitExt <- Context -> [ExtensionRaw] -> Bool -> IO (Maybe ExtensionRaw)
    processRecordSizeLimit Context
    ctx [ExtensionRaw]
    chExtensions Bool
    True
        enableMyRecordLimit ctx

        newSession ctx >>= \Session
    ss -> 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
    ss
            Bool -> TLSSt ()
    setTLS13ClientSupportsPHA Bool
    supportsPHA
        usingHState ctx $ setSupportedGroup $ keyShareEntryGroup clientKeyShare
        srand <- setServerParameter
        -- ALPN is used in choosePSK
        alpnExt <- applicationProtocol ctx chExtensions sparams
        (psk, binderInfo, is0RTTvalid) <- choosePSK
        earlyKey <- calculateEarlySecret ctx choice (Left psk) True
        let earlySecret = SecretPair EarlySecret -> BaseSecret EarlySecret
    forall a. SecretPair a -> BaseSecret a
    pairBase SecretPair EarlySecret
    earlyKey
            clientEarlySecret = SecretPair EarlySecret -> ClientTrafficSecret EarlySecret
    forall a. SecretPair a -> ClientTrafficSecret a
    pairClient SecretPair EarlySecret
    earlyKey
        extensions <- checkBinder earlySecret binderInfo
        hrr <- usingState_ ctx getTLS13HRR
        let authenticated = Maybe (ByteString, Int, Int) -> Bool
    forall a. Maybe a -> Bool
    isJust Maybe (ByteString, Int, Int)
    binderInfo
            rtt0OK = Bool
    authenticated Bool -> Bool -> Bool
    && Bool -> Bool
    not Bool
    hrr Bool -> Bool -> Bool
    && Bool
    rtt0 Bool -> Bool -> Bool
    && Bool
    rtt0accept Bool -> Bool -> Bool
    && Bool
    is0RTTvalid
        extraCreds <-
            usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams)
        let p = Version -> [ExtensionRaw] -> Group -> Bool
    makeCredentialPredicate Version
    TLS13 [ExtensionRaw]
    chExtensions
            allCreds =
                (Credential -> Bool) -> Credentials -> Credentials
    filterCredentials (Version -> (Group -> Bool) -> Credential -> Bool
    isCredentialAllowed Version
    TLS13 Group -> Bool
    p) (Credentials -> Credentials) -> Credentials -> Credentials
    forall a b. (a -> b) -> a -> b
    $
                    Credentials
    extraCreds Credentials -> Credentials -> Credentials
    forall a. Monoid a => a -> a -> a
    `mappend` Shared -> Credentials
    sharedCredentials (Context -> Shared
    ctxShared Context
    ctx)
        ----------------------------------------------------------------
        established <- ctxEstablished ctx
        if established /= NotEstablished
            then
                if rtt0OK
                    then do
                        usingHState ctx $ setTLS13HandshakeMode RTT0
                        usingHState ctx $ setTLS13RTT0Status RTT0Accepted
                    else do
                        usingHState ctx $ setTLS13HandshakeMode PreSharedKey
                        usingHState ctx $ setTLS13RTT0Status RTT0Rejected
            else when authenticated $ usingHState ctx $ setTLS13HandshakeMode PreSharedKey
        -- else : FullHandshake or HelloRetryRequest
        mCredInfo <-
            if authenticated then return Nothing else decideCredentialInfo allCreds
        (ecdhe, keyShare) <- makeServerKeyShare ctx clientKeyShare
        ensureRecvComplete ctx
        (clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do
            sendServerHello keyShare srand extensions
            sendChangeCipherSpec13 ctx
            ----------------------------------------------------------------
            handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe
            let serverHandshakeSecret = SecretTriple HandshakeSecret -> ServerTrafficSecret HandshakeSecret
    forall a. SecretTriple a -> ServerTrafficSecret a
    triServer SecretTriple HandshakeSecret
    handKey
                clientHandshakeSecret = SecretTriple HandshakeSecret -> ClientTrafficSecret HandshakeSecret
    forall a. SecretTriple a -> ClientTrafficSecret a
    triClient SecretTriple HandshakeSecret
    handKey
                handSecret = SecretTriple HandshakeSecret -> BaseSecret HandshakeSecret
    forall a. SecretTriple a -> BaseSecret a
    triBase SecretTriple HandshakeSecret
    handKey
            liftIO $ do
                if rtt0OK && not (ctxQUICMode ctx)
                    then setRxRecordState ctx usedHash usedCipher clientEarlySecret
                    else setRxRecordState ctx usedHash usedCipher clientHandshakeSecret
                setTxRecordState ctx usedHash usedCipher serverHandshakeSecret
                let mEarlySecInfo
                        | Bool
    rtt0OK = EarlySecretInfo -> Maybe EarlySecretInfo
    forall a. a -> Maybe a
    Just (EarlySecretInfo -> Maybe EarlySecretInfo)
    -> EarlySecretInfo -> Maybe EarlySecretInfo
    forall a b. (a -> b) -> a -> b
    $ Cipher -> ClientTrafficSecret EarlySecret -> EarlySecretInfo
    EarlySecretInfo Cipher
    usedCipher ClientTrafficSecret EarlySecret
    clientEarlySecret
                        | Bool
    otherwise = Maybe EarlySecretInfo
    forall a. Maybe a
    Nothing
                    handSecInfo = Cipher -> TrafficSecrets HandshakeSecret -> HandshakeSecretInfo
    HandshakeSecretInfo Cipher
    usedCipher (ClientTrafficSecret HandshakeSecret
    clientHandshakeSecret, ServerTrafficSecret HandshakeSecret
    serverHandshakeSecret)
                contextSync ctx $ SendServerHello chExtensions mEarlySecInfo handSecInfo
            ----------------------------------------------------------------
            liftIO $ enablePeerRecordLimit ctx
            sendExtensions rtt0OK alpnExt recodeSizeLimitExt
            case mCredInfo of
                Maybe (Credential, HashAndSignatureAlgorithm)
    Nothing -> () -> PacketFlightM b ()
    forall a. a -> PacketFlightM b a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
                Just (Credential
    cred, HashAndSignatureAlgorithm
    hashSig) -> Credential
    -> HashAndSignatureAlgorithm -> Bool -> PacketFlightM b ()
    forall {b}.
    Monoid b =>
    Credential
    -> HashAndSignatureAlgorithm -> Bool -> PacketFlightM b ()
    sendCertAndVerify Credential
    cred HashAndSignatureAlgorithm
    hashSig Bool
    zlib
            let ServerTrafficSecret shs = serverHandshakeSecret
            rawFinished <- makeFinished ctx usedHash shs
            loadPacket13 ctx $ Handshake13 [rawFinished]
            return (clientHandshakeSecret, handSecret)
        ----------------------------------------------------------------
        hChSf <- transcriptHash ctx
        appKey <- calculateApplicationSecret ctx choice handSecret hChSf
        let clientApplicationSecret0 = SecretTriple ApplicationSecret
    -> ClientTrafficSecret ApplicationSecret
    forall a. SecretTriple a -> ClientTrafficSecret a
    triClient SecretTriple ApplicationSecret
    appKey
            serverApplicationSecret0 = SecretTriple ApplicationSecret
    -> ServerTrafficSecret ApplicationSecret
    forall a. SecretTriple a -> ServerTrafficSecret a
    triServer SecretTriple ApplicationSecret
    appKey
        setTxRecordState ctx usedHash usedCipher serverApplicationSecret0
        let appSecInfo = TrafficSecrets ApplicationSecret -> ApplicationSecretInfo
    ApplicationSecretInfo (ClientTrafficSecret ApplicationSecret
    clientApplicationSecret0, ServerTrafficSecret ApplicationSecret
    serverApplicationSecret0)
        contextSync ctx $ SendServerFinished appSecInfo
        ----------------------------------------------------------------
        when rtt0OK $ setEstablished ctx (EarlyDataAllowed rtt0max)
        return (appKey, clientHandshakeSecret, authenticated, rtt0OK)
      where
        choice :: CipherChoice
    choice = Version -> Cipher -> CipherChoice
    makeCipherChoice Version
    TLS13 Cipher
    usedCipher

        setServerParameter :: IO ServerRandom
    setServerParameter = do
            srand <-
                Context -> Version -> [Version] -> IO ServerRandom
    serverRandom Context
    ctx Version
    TLS13 ([Version] -> IO ServerRandom) -> [Version] -> IO ServerRandom
    forall a b. (a -> b) -> a -> b
    $ Supported -> [Version]
    supportedVersions (Supported -> [Version]) -> Supported -> [Version]
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Supported
    serverSupported ServerParams
    sparams
            usingState_ ctx $ setVersion TLS13
            failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher
            return srand

        supportsPHA :: Bool
    supportsPHA =
            ExtensionID
    -> MessageType
    -> [ExtensionRaw]
    -> Bool
    -> (PostHandshakeAuth -> Bool)
    -> Bool
    forall e a.
    Extension e =>
    ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
    lookupAndDecode
                ExtensionID
    EID_PostHandshakeAuth
                MessageType
    MsgTClientHello
                [ExtensionRaw]
    chExtensions
                Bool
    False
                (\PostHandshakeAuth
    PostHandshakeAuth -> Bool
    True)

        selectPSK :: PreSharedKey -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    selectPSK (PreSharedKeyClientHello (PskIdentity ByteString
    identity Word32
    obfAge : [PskIdentity]
    _) bnds :: [ByteString]
    bnds@(ByteString
    bnd : [ByteString]
    _)) = do
            Bool -> IO () -> IO ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when ([PskKexMode] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [PskKexMode]
    dhModes) (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
    $
                    HostName -> AlertDescription -> TLSError
    Error_Protocol HostName
    "no psk_key_exchange_modes extension" AlertDescription
    MissingExtension
            if PskKexMode
    PSK_DHE_KE PskKexMode -> [PskKexMode] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [PskKexMode]
    dhModes
                then do
                    let len :: Int
    len = [Int] -> Int
    forall a. Num a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum ((ByteString -> Int) -> [ByteString] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (\ByteString
    x -> ByteString -> Int
    B.length ByteString
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) [ByteString]
    bnds) Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    2
                        mgr :: SessionManager
    mgr = Shared -> SessionManager
    sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Shared
    serverShared ServerParams
    sparams
                    -- sessionInvalidate is not used for TLS 1.3
                    -- because PSK is always changed.
                    -- So, identity is not stored in Context.
                    msdata <-
                        if Bool
    rtt0
                            then SessionManager -> ByteString -> IO (Maybe SessionData)
    sessionResumeOnlyOnce SessionManager
    mgr ByteString
    identity
                            else SessionManager -> ByteString -> IO (Maybe SessionData)
    sessionResume SessionManager
    mgr ByteString
    identity
                    case msdata of
                        Just SessionData
    sdata -> do
                            let tinfo :: TLS13TicketInfo
    tinfo = Maybe TLS13TicketInfo -> TLS13TicketInfo
    forall a. HasCallStack => Maybe a -> a
    fromJust (Maybe TLS13TicketInfo -> TLS13TicketInfo)
    -> Maybe TLS13TicketInfo -> TLS13TicketInfo
    forall a b. (a -> b) -> a -> b
    $ SessionData -> Maybe TLS13TicketInfo
    sessionTicketInfo SessionData
    sdata
                                psk :: ByteString
    psk = SessionData -> ByteString
    sessionSecret SessionData
    sdata
                            isFresh <- TLS13TicketInfo -> Word32 -> IO Bool
    checkFreshness TLS13TicketInfo
    tinfo Word32
    obfAge
                            (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata
                            if isPSKvalid && isFresh
                                then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid)
                                else -- fall back to full handshake
                                    return (zero, Nothing, False)
                        Maybe SessionData
    _ -> (ByteString, Maybe (ByteString, Int, Int), Bool)
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    zero, Maybe (ByteString, Int, Int)
    forall a. Maybe a
    Nothing, Bool
    False)
                else (ByteString, Maybe (ByteString, Int, Int), Bool)
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    zero, Maybe (ByteString, Int, Int)
    forall a. Maybe a
    Nothing, Bool
    False)
        selectPSK PreSharedKey
    _ = (ByteString, Maybe (ByteString, Int, Int), Bool)
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    zero, Maybe (ByteString, Int, Int)
    forall a. Maybe a
    Nothing, Bool
    False)

        choosePSK :: IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    choosePSK =
            ExtensionID
    -> MessageType
    -> [ExtensionRaw]
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    -> (PreSharedKey
        -> IO (ByteString, Maybe (ByteString, Int, Int), Bool))
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a b.
    Extension a =>
    ExtensionID
    -> MessageType -> [ExtensionRaw] -> IO b -> (a -> IO b) -> IO b
    lookupAndDecodeAndDo
                ExtensionID
    EID_PreSharedKey
                MessageType
    MsgTClientHello
                [ExtensionRaw]
    chExtensions
                ((ByteString, Maybe (ByteString, Int, Int), Bool)
    -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (ByteString
    zero, Maybe (ByteString, Int, Int)
    forall a. Maybe a
    Nothing, Bool
    False))
                PreSharedKey -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
    selectPSK

        checkSessionEquality :: SessionData -> IO (Bool, Bool)
    checkSessionEquality SessionData
    sdata = do
            msni <- Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt (Maybe HostName)
    getClientSNI
            malpn <- usingState_ ctx getNegotiatedProtocol
            let isSameSNI = SessionData -> Maybe HostName
    sessionClientSNI SessionData
    sdata Maybe HostName -> Maybe HostName -> Bool
    forall a. Eq a => a -> a -> Bool
    == Maybe HostName
    msni
                isSameCipher = SessionData -> CipherID
    sessionCipher SessionData
    sdata CipherID -> CipherID -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cipher -> CipherID
    cipherID Cipher
    usedCipher
                ciphers = Supported -> [Cipher]
    supportedCiphers (Supported -> [Cipher]) -> Supported -> [Cipher]
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Supported
    serverSupported ServerParams
    sparams
                scid = SessionData -> CipherID
    sessionCipher SessionData
    sdata
                isSameKDF = case CipherID -> [Cipher] -> Maybe Cipher
    findCipher CipherID
    scid [Cipher]
    ciphers of
                    Maybe Cipher
    Nothing -> Bool
    False
                    Just Cipher
    c -> Cipher -> Hash
    cipherHash Cipher
    c Hash -> Hash -> Bool
    forall a. Eq a => a -> a -> Bool
    == Cipher -> Hash
    cipherHash Cipher
    usedCipher
                isSameVersion = Version
    TLS13 Version -> Version -> Bool
    forall a. Eq a => a -> a -> Bool
    == SessionData -> Version
    sessionVersion SessionData
    sdata
                isSameALPN = SessionData -> Maybe ByteString
    sessionALPN SessionData
    sdata Maybe ByteString -> Maybe ByteString -> Bool
    forall a. Eq a => a -> a -> Bool
    == Maybe ByteString
    malpn
                isPSKvalid = Bool
    isSameKDF Bool -> Bool -> Bool
    && Bool
    isSameSNI -- fixme: SNI is not required
                is0RTTvalid = Bool
    isSameVersion Bool -> Bool -> Bool
    && Bool
    isSameCipher Bool -> Bool -> Bool
    && Bool
    isSameALPN
            return (isPSKvalid, is0RTTvalid)

        rtt0max :: Int
    rtt0max = Int -> Int
    forall a. (Num a, Ord a, FiniteBits a) => a -> a
    safeNonNegative32 (Int -> Int) -> Int -> Int
    forall a b. (a -> b) -> a -> b
    $ ServerParams -> Int
    serverEarlyDataSize ServerParams
    sparams
        rtt0accept :: Bool
    rtt0accept = ServerParams -> Int
    serverEarlyDataSize ServerParams
    sparams Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    0

        checkBinder :: BaseSecret EarlySecret
    -> Maybe (ByteString, a, Int) -> IO [ExtensionRaw]
    checkBinder BaseSecret EarlySecret
    _ Maybe (ByteString, a, Int)
    Nothing = [ExtensionRaw] -> IO [ExtensionRaw]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
        checkBinder BaseSecret EarlySecret
    earlySecret (Just (ByteString
    binder, a
    n, Int
    tlen)) = do
            binder' <- Context
    -> BaseSecret EarlySecret
    -> Hash
    -> Int
    -> Maybe ByteString
    -> IO ByteString
    makePSKBinder Context
    ctx BaseSecret EarlySecret
    earlySecret Hash
    usedHash Int
    tlen Maybe ByteString
    forall a. Maybe a
    Nothing
            unless (binder == binder') $
                decryptError "PSK binder validation failed"
            return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n]

        decideCredentialInfo :: Credentials -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
    decideCredentialInfo Credentials
    allCreds = do
            let err :: IO a
    err =
                    TLSError -> IO a
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO a) -> TLSError -> IO a
    forall a b. (a -> b) -> a -> b
    $ HostName -> AlertDescription -> TLSError
    Error_Protocol HostName
    "broken signature_algorithms extension" AlertDescription
    DecodeError
            cHashSigs <-
                ExtensionID
    -> MessageType
    -> [ExtensionRaw]
    -> IO [HashAndSignatureAlgorithm]
    -> (SignatureAlgorithms -> IO [HashAndSignatureAlgorithm])
    -> IO [HashAndSignatureAlgorithm]
    forall a b.
    Extension a =>
    ExtensionID
    -> MessageType -> [ExtensionRaw] -> IO b -> (a -> IO b) -> IO b
    lookupAndDecodeAndDo
                    ExtensionID
    EID_SignatureAlgorithms
                    MessageType
    MsgTClientHello
                    [ExtensionRaw]
    chExtensions
                    IO [HashAndSignatureAlgorithm]
    forall {a}. IO a
    err
                    (\(SignatureAlgorithms [HashAndSignatureAlgorithm]
    sas) -> [HashAndSignatureAlgorithm] -> IO [HashAndSignatureAlgorithm]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [HashAndSignatureAlgorithm]
    sas)
            -- When deciding signature algorithm and certificate, we try to keep
            -- certificates supported by the client, but fallback to all credentials
            -- if this produces no suitable result (see RFC 5246 section 7.4.2 and
            -- RFC 8446 section 4.4.2.2).
            let sHashSigs = (HashAndSignatureAlgorithm -> Bool)
    -> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
    forall a. (a -> Bool) -> [a] -> [a]
    filter HashAndSignatureAlgorithm -> Bool
    isHashSignatureValid13 ([HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm])
    -> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
    forall a b. (a -> b) -> a -> b
    $ Supported -> [HashAndSignatureAlgorithm]
    supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
    -> Supported -> [HashAndSignatureAlgorithm]
    forall a b. (a -> b) -> a -> b
    $ Context -> Supported
    ctxSupported Context
    ctx
                hashSigs = [HashAndSignatureAlgorithm]
    sHashSigs [HashAndSignatureAlgorithm]
    -> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
    forall a. Eq a => [a] -> [a] -> [a]
    `intersect` [HashAndSignatureAlgorithm]
    cHashSigs
                cltCreds = [ExtensionRaw] -> Credentials -> Credentials
    filterCredentialsWithHashSignatures [ExtensionRaw]
    chExtensions Credentials
    allCreds
            case credentialsFindForSigning13 hashSigs cltCreds of
                Maybe (Credential, HashAndSignatureAlgorithm)
    Nothing ->
                    case [HashAndSignatureAlgorithm]
    -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
    credentialsFindForSigning13 [HashAndSignatureAlgorithm]
    hashSigs Credentials
    allCreds of
                        Maybe (Credential, HashAndSignatureAlgorithm)
    Nothing -> TLSError -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
    forall (m :: * -> *) a. MonadIO m => TLSError -> m a
    throwCore (TLSError -> IO (Maybe (Credential, HashAndSignatureAlgorithm)))
    -> TLSError -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
    forall a b. (a -> b) -> a -> b
    $ HostName -> AlertDescription -> TLSError
    Error_Protocol HostName
    "credential not found" AlertDescription
    HandshakeFailure
                        Maybe (Credential, HashAndSignatureAlgorithm)
    mcs -> Maybe (Credential, HashAndSignatureAlgorithm)
    -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Credential, HashAndSignatureAlgorithm)
    mcs
                Maybe (Credential, HashAndSignatureAlgorithm)
    mcs -> Maybe (Credential, HashAndSignatureAlgorithm)
    -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe (Credential, HashAndSignatureAlgorithm)
    mcs

        sendServerHello :: KeyShareEntry
    -> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
    sendServerHello KeyShareEntry
    keyShare ServerRandom
    srand [ExtensionRaw]
    extensions = do
            let keyShareExt :: ExtensionRaw
    keyShareExt = KeyShare -> ExtensionRaw
    forall e. Extension e => e -> ExtensionRaw
    toExtensionRaw (KeyShare -> ExtensionRaw) -> KeyShare -> ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ KeyShareEntry -> KeyShare
    KeyShareServerHello KeyShareEntry
    keyShare
                versionExt :: ExtensionRaw
    versionExt = SupportedVersions -> ExtensionRaw
    forall e. Extension e => e -> ExtensionRaw
    toExtensionRaw (SupportedVersions -> ExtensionRaw)
    -> SupportedVersions -> ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ Version -> SupportedVersions
    SupportedVersionsServerHello Version
    TLS13
                extensions' :: [ExtensionRaw]
    extensions' = ExtensionRaw
    keyShareExt ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. a -> [a] -> [a]
    : ExtensionRaw
    versionExt ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. a -> [a] -> [a]
    : [ExtensionRaw]
    extensions
                helo :: Handshake13
    helo = ServerRandom
    -> Session -> CipherId -> [ExtensionRaw] -> Handshake13
    ServerHello13 ServerRandom
    srand Session
    chSession (CipherID -> CipherId
    CipherId (Cipher -> CipherID
    cipherID Cipher
    usedCipher)) [ExtensionRaw]
    extensions'
            Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    helo]

        sendCertAndVerify :: Credential
    -> HashAndSignatureAlgorithm -> Bool -> PacketFlightM b ()
    sendCertAndVerify cred :: Credential
    cred@(CertificateChain
    certChain, PrivKey
    _) HashAndSignatureAlgorithm
    hashSig Bool
    zlib = do
            Context -> Credential -> PacketFlightM b ()
    forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
    storePrivInfoServer Context
    ctx Credential
    cred
            Bool -> PacketFlightM b () -> PacketFlightM b ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ServerParams -> Bool
    serverWantClientCert ServerParams
    sparams) (PacketFlightM b () -> PacketFlightM b ())
    -> PacketFlightM b () -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ do
                let certReqCtx :: ByteString
    certReqCtx = ByteString
    "" -- this must be zero length here.
                    certReq :: Handshake13
    certReq = ServerParams -> Context -> ByteString -> Bool -> Handshake13
    makeCertRequest ServerParams
    sparams Context
    ctx ByteString
    certReqCtx Bool
    True
                Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ [Handshake13] -> Packet13
    Handshake13 [Handshake13
    certReq]
                Context -> HandshakeM () -> PacketFlightM b ()
    forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
    usingHState Context
    ctx (HandshakeM () -> PacketFlightM b ())
    -> HandshakeM () -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ Bool -> HandshakeM ()
    setCertReqSent Bool
    True

            let CertificateChain [SignedExact Certificate]
    cs = CertificateChain
    certChain
                ess :: [[a]]
    ess = Int -> [a] -> [[a]]
    forall a. Int -> a -> [a]
    replicate ([SignedExact Certificate] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [SignedExact Certificate]
    cs) []
            let certtag :: ByteString
    -> TLSCertificateChain -> [[ExtensionRaw]] -> Handshake13
    certtag = if Bool
    zlib then ByteString
    -> TLSCertificateChain -> [[ExtensionRaw]] -> Handshake13
    CompressedCertificate13 else ByteString
    -> TLSCertificateChain -> [[ExtensionRaw]] -> Handshake13
    Certificate13
            Context -> Packet13 -> PacketFlightM b ()
    forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
    loadPacket13 Context
    ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $
                [Handshake13] -> Packet13
    Handshake13 [ByteString
    -> TLSCertificateChain -> [[ExtensionRaw]] -> Handshake13
    certtag ByteString
    "" (CertificateChain -> TLSCertificateChain
    TLSCertificateChain CertificateChain
    certChain) [[ExtensionRaw]]
    forall {a}. [[a]]
    ess]
            IO () -> PacketFlightM b ()
    forall a. IO a -> PacketFlightM b a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> PacketFlightM b ()) -> IO () -> PacketFlightM b ()
    forall a b. (a -> b) -> a -> b
    $ 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
    certChain
            hChSc <- Context -> PacketFlightM b ByteString
    forall (m :: * -> *). MonadIO m => Context -> m ByteString
    transcriptHash Context
    ctx
            pubkey <- getLocalPublicKey ctx
            vrfy <- makeCertVerify ctx pubkey hashSig hChSc
            loadPacket13 ctx $ Handshake13 [vrfy]

        sendExtensions :: Bool
    -> Maybe ExtensionRaw -> Maybe ExtensionRaw -> PacketFlightM b ()
    sendExtensions Bool
    rtt0OK Maybe ExtensionRaw
    alpnExt Maybe ExtensionRaw
    recodeSizeLimitExt = do
            msni <- IO (Maybe HostName) -> PacketFlightM b (Maybe HostName)
    forall a. IO a -> PacketFlightM b a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO (Maybe HostName) -> PacketFlightM b (Maybe HostName))
    -> IO (Maybe HostName) -> PacketFlightM b (Maybe HostName)
    forall a b. (a -> b) -> a -> b
    $ Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
    forall a. Context -> TLSSt a -> IO a
    usingState_ Context
    ctx TLSSt (Maybe HostName)
    getClientSNI
            let sniExt = case Maybe HostName
    msni of
                    -- RFC6066: In this event, the server SHALL include
                    -- an extension of type "server_name" in the
                    -- (extended) server hello. The "extension_data"
                    -- field of this extension SHALL be empty.
                    Just HostName
    _ -> ExtensionRaw -> Maybe ExtensionRaw
    forall a. a -> Maybe a
    Just (ExtensionRaw -> Maybe ExtensionRaw)
    -> ExtensionRaw -> Maybe ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ ServerName -> ExtensionRaw
    forall e. Extension e => e -> ExtensionRaw
    toExtensionRaw (ServerName -> ExtensionRaw) -> ServerName -> ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ [ServerNameType] -> ServerName
    ServerName []
                    Maybe HostName
    Nothing -> Maybe ExtensionRaw
    forall a. Maybe a
    Nothing

            mgroup <- usingHState ctx getSupportedGroup
            let serverGroups = Supported -> [Group]
    supportedGroups (Context -> Supported
    ctxSupported Context
    ctx)
                groupExt = case [Group]
    serverGroups of
                    [] -> Maybe ExtensionRaw
    forall a. Maybe a
    Nothing
                    Group
    rg : [Group]
    _ -> case Maybe Group
    mgroup of
                        Maybe Group
    Nothing -> Maybe ExtensionRaw
    forall a. Maybe a
    Nothing
                        Just Group
    grp
                            | Group
    grp Group -> Group -> Bool
    forall a. Eq a => a -> a -> Bool
    == Group
    rg -> Maybe ExtensionRaw
    forall a. Maybe a
    Nothing
                            | Bool
    otherwise -> ExtensionRaw -> Maybe ExtensionRaw
    forall a. a -> Maybe a
    Just (ExtensionRaw -> Maybe ExtensionRaw)
    -> ExtensionRaw -> Maybe ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ SupportedGroups -> ExtensionRaw
    forall e. Extension e => e -> ExtensionRaw
    toExtensionRaw (SupportedGroups -> ExtensionRaw)
    -> SupportedGroups -> ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ [Group] -> SupportedGroups
    SupportedGroups [Group]
    serverGroups
            let earlyDataExt
                    | Bool
    rtt0OK = ExtensionRaw -> Maybe ExtensionRaw
    forall a. a -> Maybe a
    Just (ExtensionRaw -> Maybe ExtensionRaw)
    -> ExtensionRaw -> Maybe ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ EarlyDataIndication -> ExtensionRaw
    forall e. Extension e => e -> ExtensionRaw
    toExtensionRaw (EarlyDataIndication -> ExtensionRaw)
    -> EarlyDataIndication -> ExtensionRaw
    forall a b. (a -> b) -> a -> b
    $ Maybe Word32 -> EarlyDataIndication
    EarlyDataIndication Maybe Word32
    forall a. Maybe a
    Nothing
                    | Bool
    otherwise = Maybe ExtensionRaw
    forall a. Maybe a
    Nothing

            let extensions =
                    Shared -> [ExtensionRaw]
    sharedHelloExtensions (ServerParams -> Shared
    serverShared ServerParams
    sparams)
                        [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
    forall a. [a] -> [a] -> [a]
    ++ [Maybe ExtensionRaw] -> [ExtensionRaw]
    forall a. [Maybe a] -> [a]
    catMaybes
                            [ {- 0x00 -} Maybe ExtensionRaw
    sniExt
                            , {- 0x0a -} Maybe ExtensionRaw
    groupExt
                            , {- 0x10 -} Maybe ExtensionRaw
    alpnExt
                            , {- 0x1c -} Maybe ExtensionRaw
    recodeSizeLimitExt
                            , {- 0x2a -} Maybe ExtensionRaw
    earlyDataExt
                            ]
            extensions' <-
                liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) extensions
            loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions']

        dhModes :: [PskKexMode]
    dhModes =
            ExtensionID
    -> MessageType
    -> [ExtensionRaw]
    -> [PskKexMode]
    -> (PskKeyExchangeModes -> [PskKexMode])
    -> [PskKexMode]
    forall e a.
    Extension e =>
    ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
    lookupAndDecode
                ExtensionID
    EID_PskKeyExchangeModes
                MessageType
    MsgTClientHello
                [ExtensionRaw]
    chExtensions
                []
                (\(PskKeyExchangeModes [PskKexMode]
    ms) -> [PskKexMode]
    ms)

        hashSize :: Int
    hashSize = Hash -> Int
    hashDigestSize Hash
    usedHash
        zero :: ByteString
    zero = Int -> Word8 -> ByteString
    B.replicate Int
    hashSize Word8
    0

    credentialsFindForSigning13
        :: [HashAndSignatureAlgorithm]
        -> Credentials
        -> Maybe (Credential, HashAndSignatureAlgorithm)
    credentialsFindForSigning13 :: [HashAndSignatureAlgorithm]
    -> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
    credentialsFindForSigning13 [HashAndSignatureAlgorithm]
    hss0 Credentials
    creds = [HashAndSignatureAlgorithm]
    -> Maybe (Credential, HashAndSignatureAlgorithm)
    loop [HashAndSignatureAlgorithm]
    hss0
      where
        loop :: [HashAndSignatureAlgorithm]
    -> Maybe (Credential, HashAndSignatureAlgorithm)
    loop [] = Maybe (Credential, HashAndSignatureAlgorithm)
    forall a. Maybe a
    Nothing
        loop (HashAndSignatureAlgorithm
    hs : [HashAndSignatureAlgorithm]
    hss) = case HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
    credentialsFindForSigning13' HashAndSignatureAlgorithm
    hs Credentials
    creds of
            Maybe Credential
    Nothing -> [HashAndSignatureAlgorithm]
    -> Maybe (Credential, HashAndSignatureAlgorithm)
    loop [HashAndSignatureAlgorithm]
    hss
            Just Credential
    cred -> (Credential, HashAndSignatureAlgorithm)
    -> Maybe (Credential, HashAndSignatureAlgorithm)
    forall a. a -> Maybe a
    Just (Credential
    cred, HashAndSignatureAlgorithm
    hs)

    -- See credentialsFindForSigning.
    credentialsFindForSigning13'
        :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
    credentialsFindForSigning13' :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
    credentialsFindForSigning13' HashAndSignatureAlgorithm
    sigAlg (Credentials [Credential]
    l) = (Credential -> Bool) -> [Credential] -> Maybe Credential
    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
    find Credential -> Bool
    forSigning [Credential]
    l
      where
        forSigning :: Credential -> Bool
    forSigning Credential
    cred = case Credential -> Maybe PubKey
    credentialDigitalSignatureKey Credential
    cred of
            Maybe PubKey
    Nothing -> Bool
    False
            Just PubKey
    pub -> PubKey
    pub PubKey -> HashAndSignatureAlgorithm -> Bool
    `signatureCompatible13` HashAndSignatureAlgorithm
    sigAlg

    contextSync :: Context -> ServerState -> IO ()
    contextSync :: Context -> ServerState -> IO ()
    contextSync Context
    ctx ServerState
    ctl = case Context -> HandshakeSync
    ctxHandshakeSync Context
    ctx of
        HandshakeSync Context -> ClientState -> IO ()
    _ Context -> ServerState -> IO ()
    sync -> Context -> ServerState -> IO ()
    sync Context
    ctx ServerState
    ctl