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

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

import Control.Monad.State.Strict

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.Handshake.TranscriptHash
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.Parameters
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)
    -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)
    -> ClientHello
    -> Maybe ClientRandom
    -> IO
        ( SecretTriple ApplicationSecret
        , ClientTrafficSecret HandshakeSecret
        , Bool
        , Bool
        )
sendServerHello13 :: ServerParams
-> Context
-> KeyShareEntry
-> (Cipher, Hash, Bool)
-> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool)
-> ClientHello
-> Maybe ClientRandom
-> IO
     (SecretTriple ApplicationSecret,
      ClientTrafficSecret HandshakeSecret, Bool, Bool)
sendServerHello13 ServerParams
sparams Context
ctx KeyShareEntry
clientKeyShare (Cipher
usedCipher, Hash
usedHash, Bool
rtt0) (SecretPair EarlySecret
earlyKey, [ExtensionRaw]
preSharedKeyExt, Bool
authenticated, Bool
is0RTTvalid) 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 ClientRandom
mOuterClientRandom = do
    let clientEarlySecret :: ClientTrafficSecret EarlySecret
clientEarlySecret = SecretPair EarlySecret -> ClientTrafficSecret EarlySecret
forall a. SecretPair a -> ClientTrafficSecret a
pairClient SecretPair EarlySecret
earlyKey
        earlySecret :: BaseSecret EarlySecret
earlySecret = SecretPair EarlySecret -> BaseSecret EarlySecret
forall a. SecretPair a -> BaseSecret a
pairBase SecretPair EarlySecret
earlyKey
    -- 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)

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

    Context -> IO Session
newSession Context
ctx IO Session -> (Session -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \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
    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
$ do
        Group -> HandshakeM ()
setSupportedGroup (Group -> HandshakeM ()) -> Group -> HandshakeM ()
forall a b. (a -> b) -> a -> b
$ KeyShareEntry -> Group
keyShareEntryGroup KeyShareEntry
clientKeyShare
        Maybe ClientRandom -> HandshakeM ()
setOuterClientRandom Maybe ClientRandom
mOuterClientRandom
    Bool
hrr <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
    Maybe ExtensionRaw
alpnExt <- Context
-> [ExtensionRaw] -> ServerParams -> IO (Maybe ExtensionRaw)
applicationProtocol Context
ctx [ExtensionRaw]
chExtensions ServerParams
sparams
    IO ()
setServerParameter
    let rtt0OK :: Bool
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
    Credentials
extraCreds <-
        Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
getClientSNI IO (Maybe HostName)
-> (Maybe HostName -> IO Credentials) -> IO Credentials
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ServerHooks -> Maybe HostName -> IO Credentials
onServerNameIndication (ServerParams -> ServerHooks
serverHooks ServerParams
sparams)
    let p :: Group -> Bool
p = Version -> [ExtensionRaw] -> Group -> Bool
makeCredentialPredicate Version
TLS13 [ExtensionRaw]
chExtensions
        allCreds :: Credentials
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
established <- Context -> IO Established
ctxEstablished Context
ctx
    if Established
established Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
/= Established
NotEstablished
        then
            if Bool
rtt0OK
                then do
                    Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
RTT0
                    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
$ RTT0Status -> HandshakeM ()
setTLS13RTT0Status RTT0Status
RTT0Accepted
                else do
                    Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
PreSharedKey
                    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
$ RTT0Status -> HandshakeM ()
setTLS13RTT0Status RTT0Status
RTT0Rejected
        else Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
authenticated (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> HandshakeM () -> IO ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> IO ()) -> HandshakeM () -> IO ()
forall a b. (a -> b) -> a -> b
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
PreSharedKey
    -- else : FullHandshake or HelloRetryRequest
    Maybe (Credential, HashAndSignatureAlgorithm)
mCredInfo <-
        if Bool
authenticated then Maybe (Credential, HashAndSignatureAlgorithm)
-> IO (Maybe (Credential, HashAndSignatureAlgorithm))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Credential, HashAndSignatureAlgorithm)
forall a. Maybe a
Nothing else Credentials -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
decideCredentialInfo Credentials
allCreds
    (ByteString
ecdhe, KeyShareEntry
keyShare) <- Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)
makeServerKeyShare Context
ctx KeyShareEntry
clientKeyShare
    Context -> IO ()
forall (m :: * -> *). MonadIO m => Context -> m ()
ensureRecvComplete Context
ctx
    (ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, BaseSecret HandshakeSecret
handSecret) <- Context
-> (forall {b}.
    Monoid b =>
    PacketFlightM
      b
      (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret))
-> IO
     (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret)
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx ((forall {b}.
  Monoid b =>
  PacketFlightM
    b
    (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret))
 -> IO
      (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret))
-> (forall {b}.
    Monoid b =>
    PacketFlightM
      b
      (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret))
-> IO
     (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret)
forall a b. (a -> b) -> a -> b
$ do
        KeyShareEntry -> PacketFlightM b ()
forall {b}. Monoid b => KeyShareEntry -> PacketFlightM b ()
sendServerHello KeyShareEntry
keyShare
        Context -> PacketFlightM b ()
forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
        ----------------------------------------------------------------
        SecretTriple HandshakeSecret
handKey <- IO (SecretTriple HandshakeSecret)
-> PacketFlightM b (SecretTriple HandshakeSecret)
forall a. IO a -> PacketFlightM b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (SecretTriple HandshakeSecret)
 -> PacketFlightM b (SecretTriple HandshakeSecret))
-> IO (SecretTriple HandshakeSecret)
-> PacketFlightM b (SecretTriple HandshakeSecret)
forall a b. (a -> b) -> a -> b
$ Context
-> CipherChoice
-> BaseSecret EarlySecret
-> ByteString
-> IO (SecretTriple HandshakeSecret)
calculateHandshakeSecret Context
ctx CipherChoice
choice BaseSecret EarlySecret
earlySecret ByteString
ecdhe
        let serverHandshakeSecret :: ServerTrafficSecret HandshakeSecret
serverHandshakeSecret = SecretTriple HandshakeSecret -> ServerTrafficSecret HandshakeSecret
forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple HandshakeSecret
handKey
            clientHandshakeSecret :: ClientTrafficSecret HandshakeSecret
clientHandshakeSecret = SecretTriple HandshakeSecret -> ClientTrafficSecret HandshakeSecret
forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple HandshakeSecret
handKey
            handSecret :: BaseSecret HandshakeSecret
handSecret = SecretTriple HandshakeSecret -> BaseSecret HandshakeSecret
forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple HandshakeSecret
handKey
        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
$ do
            if Bool
rtt0OK Bool -> Bool -> Bool
&& Bool -> Bool
not (Context -> Bool
ctxQUICMode Context
ctx)
                then Context
-> Hash -> Cipher -> ClientTrafficSecret EarlySecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxRecordState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret EarlySecret
clientEarlySecret
                else Context
-> Hash -> Cipher -> ClientTrafficSecret HandshakeSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setRxRecordState Context
ctx Hash
usedHash Cipher
usedCipher ClientTrafficSecret HandshakeSecret
clientHandshakeSecret
            Context
-> Hash -> Cipher -> ServerTrafficSecret HandshakeSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxRecordState Context
ctx Hash
usedHash Cipher
usedCipher ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
            let mEarlySecInfo :: Maybe EarlySecretInfo
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 :: HandshakeSecretInfo
handSecInfo = Cipher -> TrafficSecrets HandshakeSecret -> HandshakeSecretInfo
HandshakeSecretInfo Cipher
usedCipher (ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, ServerTrafficSecret HandshakeSecret
serverHandshakeSecret)
            Context -> ServerState -> IO ()
contextSync Context
ctx (ServerState -> IO ()) -> ServerState -> IO ()
forall a b. (a -> b) -> a -> b
$ [ExtensionRaw]
-> Maybe EarlySecretInfo -> HandshakeSecretInfo -> ServerState
SendServerHello [ExtensionRaw]
chExtensions Maybe EarlySecretInfo
mEarlySecInfo HandshakeSecretInfo
handSecInfo
        ----------------------------------------------------------------
        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 -> IO ()
enablePeerRecordLimit Context
ctx
        Bool
-> Maybe ExtensionRaw -> Maybe ExtensionRaw -> PacketFlightM b ()
forall {b}.
Monoid b =>
Bool
-> Maybe ExtensionRaw -> Maybe ExtensionRaw -> PacketFlightM b ()
sendExtensions Bool
rtt0OK Maybe ExtensionRaw
alpnExt Maybe ExtensionRaw
recodeSizeLimitExt
        case Maybe (Credential, HashAndSignatureAlgorithm)
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 ByteString
shs = ServerTrafficSecret HandshakeSecret
serverHandshakeSecret
        Handshake13
rawFinished <- Context -> Hash -> ByteString -> PacketFlightM b Handshake13
forall (m :: * -> *).
MonadIO m =>
Context -> Hash -> ByteString -> m Handshake13
makeFinished Context
ctx Hash
usedHash ByteString
shs
        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
rawFinished]
        (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret)
-> PacketFlightM
     b (ClientTrafficSecret HandshakeSecret, BaseSecret HandshakeSecret)
forall a. a -> PacketFlightM b a
forall (m :: * -> *) a. Monad m => a -> m a
return (ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, BaseSecret HandshakeSecret
handSecret)
    ----------------------------------------------------------------
    TranscriptHash
hChSf <- Context -> HostName -> IO TranscriptHash
forall (m :: * -> *).
MonadIO m =>
Context -> HostName -> m TranscriptHash
transcriptHash Context
ctx HostName
"CH..SF"
    SecretTriple ApplicationSecret
appKey <- Context
-> CipherChoice
-> BaseSecret HandshakeSecret
-> TranscriptHash
-> IO (SecretTriple ApplicationSecret)
calculateApplicationSecret Context
ctx CipherChoice
choice BaseSecret HandshakeSecret
handSecret TranscriptHash
hChSf
    let clientApplicationSecret0 :: ClientTrafficSecret ApplicationSecret
clientApplicationSecret0 = SecretTriple ApplicationSecret
-> ClientTrafficSecret ApplicationSecret
forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey
        serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret
serverApplicationSecret0 = SecretTriple ApplicationSecret
-> ServerTrafficSecret ApplicationSecret
forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple ApplicationSecret
appKey
    Context
-> Hash -> Cipher -> ServerTrafficSecret ApplicationSecret -> IO ()
forall ty.
TrafficSecret ty =>
Context -> Hash -> Cipher -> ty -> IO ()
setTxRecordState Context
ctx Hash
usedHash Cipher
usedCipher ServerTrafficSecret ApplicationSecret
serverApplicationSecret0
    let appSecInfo :: ApplicationSecretInfo
appSecInfo = TrafficSecrets ApplicationSecret -> ApplicationSecretInfo
ApplicationSecretInfo (ClientTrafficSecret ApplicationSecret
clientApplicationSecret0, ServerTrafficSecret ApplicationSecret
serverApplicationSecret0)
    Context -> ServerState -> IO ()
contextSync Context
ctx (ServerState -> IO ()) -> ServerState -> IO ()
forall a b. (a -> b) -> a -> b
$ ApplicationSecretInfo -> ServerState
SendServerFinished ApplicationSecretInfo
appSecInfo
    ----------------------------------------------------------------
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
rtt0OK (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Context -> Established -> IO ()
setEstablished Context
ctx (Int -> Established
EarlyDataAllowed Int
rtt0max)
    (SecretTriple ApplicationSecret,
 ClientTrafficSecret HandshakeSecret, Bool, Bool)
-> IO
     (SecretTriple ApplicationSecret,
      ClientTrafficSecret HandshakeSecret, Bool, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SecretTriple ApplicationSecret
appKey, ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, Bool
authenticated, Bool
rtt0OK)
  where
    choice :: CipherChoice
choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher

    setServerParameter :: IO ()
setServerParameter = do
        Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ Version -> TLSSt ()
setVersion Version
TLS13
        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
False

    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)

    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

    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
        [HashAndSignatureAlgorithm]
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]
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]
hashSigs = [HashAndSignatureAlgorithm]
sHashSigs [HashAndSignatureAlgorithm]
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [HashAndSignatureAlgorithm]
cHashSigs
            cltCreds :: Credentials
cltCreds = [ExtensionRaw] -> Credentials -> Credentials
filterCredentialsWithHashSignatures [ExtensionRaw]
chExtensions Credentials
allCreds
        case [HashAndSignatureAlgorithm]
-> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
credentialsFindForSigning13 [HashAndSignatureAlgorithm]
hashSigs Credentials
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 -> PacketFlightM b ()
sendServerHello KeyShareEntry
keyShare = 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
            shExts :: [ExtensionRaw]
shExts = ExtensionRaw
keyShareExt ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: ExtensionRaw
versionExt ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: [ExtensionRaw]
preSharedKeyExt
        if Maybe ClientRandom -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ClientRandom -> Bool) -> Maybe ClientRandom -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe ClientRandom
mOuterClientRandom
            then do
                ServerRandom
srand <- IO ServerRandom -> PacketFlightM b ServerRandom
forall a. IO a -> PacketFlightM b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ServerRandom -> PacketFlightM b ServerRandom)
-> IO ServerRandom -> PacketFlightM b ServerRandom
forall a b. (a -> b) -> a -> b
$ Context -> IO ServerRandom
serverRandomECH Context
ctx
                let cipherId :: CipherId
cipherId = Word16 -> CipherId
CipherId (Cipher -> Word16
cipherID Cipher
usedCipher)
                    sh :: ServerHello
sh =
                        SH
                            { shVersion :: Version
shVersion = Version
TLS12
                            , shRandom :: ServerRandom
shRandom = ServerRandom
srand
                            , shSession :: Session
shSession = Session
chSession
                            , shCipher :: CipherId
shCipher = CipherId
cipherId
                            , shComp :: CompressionID
shComp = CompressionID
0
                            , shExtensions :: [ExtensionRaw]
shExtensions = [ExtensionRaw]
shExts
                            }
                ByteString
suffix <- Context
-> Hash -> ServerHello -> ByteString -> PacketFlightM b ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
Context -> Hash -> ServerHello -> ByteString -> m ByteString
computeConfirm Context
ctx Hash
usedHash ServerHello
sh ByteString
"ech accept confirmation"
                let srand' :: ServerRandom
srand' = ServerRandom -> ByteString -> ServerRandom
replaceServerRandomECH ServerRandom
srand ByteString
suffix
                    sh' :: ServerHello
sh' =
                        SH
                            { shVersion :: Version
shVersion = Version
TLS12
                            , shRandom :: ServerRandom
shRandom = ServerRandom
srand'
                            , shSession :: Session
shSession = Session
chSession
                            , shCipher :: CipherId
shCipher = CipherId
cipherId
                            , shComp :: CompressionID
shComp = CompressionID
0
                            , shExtensions :: [ExtensionRaw]
shExtensions = [ExtensionRaw]
shExts
                            }
                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 ()
setECHAccepted 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 [ServerHello -> Handshake13
ServerHello13 ServerHello
sh']
            else do
                ServerRandom
srand <-
                    IO ServerRandom -> PacketFlightM b ServerRandom
forall a. IO a -> PacketFlightM b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ServerRandom -> PacketFlightM b ServerRandom)
-> IO ServerRandom -> PacketFlightM b ServerRandom
forall a b. (a -> b) -> a -> b
$
                        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
                let sh :: ServerHello
sh =
                        SH
                            { shVersion :: Version
shVersion = Version
TLS12
                            , shRandom :: ServerRandom
shRandom = ServerRandom
srand
                            , shSession :: Session
shSession = Session
chSession
                            , shCipher :: CipherId
shCipher = Word16 -> CipherId
CipherId (Cipher -> Word16
cipherID Cipher
usedCipher)
                            , shComp :: CompressionID
shComp = CompressionID
0
                            , shExtensions :: [ExtensionRaw]
shExtensions = [ExtensionRaw]
shExts
                            }
                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 [ServerHello -> Handshake13
ServerHello13 ServerHello
sh]

    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 -> CertificateChain_ -> [[ExtensionRaw]] -> Handshake13
certtag = if Bool
zlib then ByteString -> CertificateChain_ -> [[ExtensionRaw]] -> Handshake13
CompressedCertificate13 else ByteString -> CertificateChain_ -> [[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 -> CertificateChain_ -> [[ExtensionRaw]] -> Handshake13
certtag ByteString
"" (CertificateChain -> CertificateChain_
CertificateChain_ 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
        TranscriptHash
hChSc <- Context -> HostName -> PacketFlightM b TranscriptHash
forall (m :: * -> *).
MonadIO m =>
Context -> HostName -> m TranscriptHash
transcriptHash Context
ctx HostName
"CH..SC"
        PubKey
pubkey <- Context -> PacketFlightM b PubKey
forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
        Handshake13
vrfy <- Context
-> PubKey
-> HashAndSignatureAlgorithm
-> TranscriptHash
-> PacketFlightM b Handshake13
forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> TranscriptHash
-> m Handshake13
makeCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
hashSig TranscriptHash
hChSc
        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
vrfy]

    sendExtensions :: Bool
-> Maybe ExtensionRaw -> Maybe ExtensionRaw -> PacketFlightM b ()
sendExtensions Bool
rtt0OK Maybe ExtensionRaw
alpnExt Maybe ExtensionRaw
recodeSizeLimitExt = do
        Maybe HostName
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 :: Maybe ExtensionRaw
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

        Maybe Group
mgroup <- Context
-> HandshakeM (Maybe Group) -> PacketFlightM b (Maybe Group)
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM (Maybe Group)
getSupportedGroup
        let serverGroups :: [Group]
serverGroups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
            groupExt :: Maybe ExtensionRaw
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 :: Maybe ExtensionRaw
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

        Bool
sendECH <- Context -> HandshakeM Bool -> PacketFlightM b Bool
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx HandshakeM Bool
getECHEE
        let echExt :: Maybe ExtensionRaw
echExt
                | Bool
sendECH =
                    ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$
                        EncryptedClientHello -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (EncryptedClientHello -> ExtensionRaw)
-> EncryptedClientHello -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$
                            ECHConfigList -> EncryptedClientHello
ECHEncryptedExtensions (ECHConfigList -> EncryptedClientHello)
-> ECHConfigList -> EncryptedClientHello
forall a b. (a -> b) -> a -> b
$
                                Shared -> ECHConfigList
sharedECHConfigList (Shared -> ECHConfigList) -> Shared -> ECHConfigList
forall a b. (a -> b) -> a -> b
$
                                    ServerParams -> Shared
serverShared ServerParams
sparams
                | Bool
otherwise = Maybe ExtensionRaw
forall a. Maybe a
Nothing
        let eeExtensions :: [ExtensionRaw]
eeExtensions =
                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
                        , {- 0xfe0d -} Maybe ExtensionRaw
echExt
                        ]
        [ExtensionRaw]
eeExtensions' <-
            IO [ExtensionRaw] -> PacketFlightM b [ExtensionRaw]
forall a. IO a -> PacketFlightM b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ExtensionRaw] -> PacketFlightM b [ExtensionRaw])
-> IO [ExtensionRaw] -> PacketFlightM b [ExtensionRaw]
forall a b. (a -> b) -> a -> b
$ ServerHooks -> [ExtensionRaw] -> IO [ExtensionRaw]
onEncryptedExtensionsCreating (ServerParams -> ServerHooks
serverHooks ServerParams
sparams) [ExtensionRaw]
eeExtensions
        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 [[ExtensionRaw] -> Handshake13
EncryptedExtensions13 [ExtensionRaw]
eeExtensions']

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

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

sendHRR :: Context -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()
sendHRR :: forall c.
Context -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()
sendHRR Context
ctx (Cipher
usedCipher, Hash
usedHash, c
_) CH{[CompressionID]
[CipherId]
[ExtensionRaw]
Version
Session
ClientRandom
chVersion :: ClientHello -> Version
chRandom :: ClientHello -> ClientRandom
chSession :: ClientHello -> Session
chCiphers :: ClientHello -> [CipherId]
chComps :: ClientHello -> [CompressionID]
chExtensions :: ClientHello -> [ExtensionRaw]
chVersion :: Version
chRandom :: ClientRandom
chSession :: Session
chCiphers :: [CipherId]
chComps :: [CompressionID]
chExtensions :: [ExtensionRaw]
..} Bool
isEch = do
    Bool
twice <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
twice (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
"Hello retry not allowed again" AlertDescription
HandshakeFailure
    Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> TLSSt ()
setTLS13HRR Bool
True
    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
True
    let clientGroups :: [Group]
clientGroups =
            ExtensionID
-> MessageType
-> [ExtensionRaw]
-> [Group]
-> (SupportedGroups -> [Group])
-> [Group]
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
                ExtensionID
EID_SupportedGroups
                MessageType
MsgTClientHello
                [ExtensionRaw]
chExtensions
                []
                (\(SupportedGroups [Group]
gs) -> [Group]
gs)
        possibleGroups :: [Group]
possibleGroups = [Group]
serverGroups [Group] -> [Group] -> [Group]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Group]
clientGroups
    case [Group]
possibleGroups of
        [] ->
            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 group in common with the client for HRR" AlertDescription
HandshakeFailure
        Group
g : [Group]
_ -> do
            ServerHello
hrr <- Context
-> Cipher -> Hash -> Session -> Group -> Bool -> IO ServerHello
makeHRR Context
ctx Cipher
usedCipher Hash
usedHash Session
chSession Group
g Bool
isEch
            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
$ HandshakeMode13 -> HandshakeM ()
setTLS13HandshakeMode HandshakeMode13
HelloRetryRequest
            Context -> (forall {b}. Monoid b => PacketFlightM b ()) -> IO ()
forall a.
Context -> (forall b. Monoid b => PacketFlightM b a) -> IO a
runPacketFlight Context
ctx ((forall {b}. Monoid b => PacketFlightM b ()) -> IO ())
-> (forall {b}. Monoid b => PacketFlightM b ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                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 [ServerHello -> Handshake13
ServerHello13 ServerHello
hrr]
                Context -> PacketFlightM b ()
forall b. Monoid b => Context -> PacketFlightM b ()
sendChangeCipherSpec13 Context
ctx
  where
    serverGroups :: [Group]
serverGroups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)

makeHRR
    :: Context -> Cipher -> Hash -> Session -> Group -> Bool -> IO ServerHello
makeHRR :: Context
-> Cipher -> Hash -> Session -> Group -> Bool -> IO ServerHello
makeHRR Context
_ Cipher
usedCipher Hash
_ Session
session Group
g Bool
False = ServerHello -> IO ServerHello
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerHello
hrr
  where
    keyShareExt :: ExtensionRaw
keyShareExt = KeyShare -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (KeyShare -> ExtensionRaw) -> KeyShare -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ Group -> KeyShare
KeyShareHRR Group
g
    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
versionExt]
    cipherId :: CipherId
cipherId = Word16 -> CipherId
CipherId (Word16 -> CipherId) -> Word16 -> CipherId
forall a b. (a -> b) -> a -> b
$ Cipher -> Word16
cipherID Cipher
usedCipher
    hrr :: ServerHello
hrr =
        SH
            { shVersion :: Version
shVersion = Version
TLS12
            , shRandom :: ServerRandom
shRandom = ServerRandom
hrrRandom
            , shSession :: Session
shSession = Session
session
            , shCipher :: CipherId
shCipher = CipherId
cipherId
            , shComp :: CompressionID
shComp = CompressionID
0
            , shExtensions :: [ExtensionRaw]
shExtensions = [ExtensionRaw]
extensions
            }
makeHRR Context
ctx Cipher
usedCipher Hash
usedHash Session
session Group
g Bool
True = do
    ByteString
suffix <- Context -> Hash -> ServerHello -> ByteString -> IO ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
Context -> Hash -> ServerHello -> ByteString -> m ByteString
computeConfirm Context
ctx Hash
usedHash ServerHello
hrr ByteString
"hrr ech accept confirmation"
    let echExt' :: ExtensionRaw
echExt' = EncryptedClientHello -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (EncryptedClientHello -> ExtensionRaw)
-> EncryptedClientHello -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ ByteString -> EncryptedClientHello
ECHHelloRetryRequest ByteString
suffix
        extensions' :: [ExtensionRaw]
extensions' = [ExtensionRaw
keyShareExt, ExtensionRaw
versionExt, ExtensionRaw
echExt']
        hrr' :: ServerHello
hrr' = ServerHello
hrr{shExtensions = extensions'}
    ServerHello -> IO ServerHello
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerHello
hrr'
  where
    keyShareExt :: ExtensionRaw
keyShareExt = KeyShare -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (KeyShare -> ExtensionRaw) -> KeyShare -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ Group -> KeyShare
KeyShareHRR Group
g
    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
    echExt :: ExtensionRaw
echExt = EncryptedClientHello -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (EncryptedClientHello -> ExtensionRaw)
-> EncryptedClientHello -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ ByteString -> EncryptedClientHello
ECHHelloRetryRequest ByteString
"\x00\x00\x00\x00\x00\x00\x00\x00"
    extensions :: [ExtensionRaw]
extensions = [ExtensionRaw
keyShareExt, ExtensionRaw
versionExt, ExtensionRaw
echExt]
    cipherId :: CipherId
cipherId = Word16 -> CipherId
CipherId (Word16 -> CipherId) -> Word16 -> CipherId
forall a b. (a -> b) -> a -> b
$ Cipher -> Word16
cipherID Cipher
usedCipher
    hrr :: ServerHello
hrr =
        SH
            { shVersion :: Version
shVersion = Version
TLS12
            , shRandom :: ServerRandom
shRandom = ServerRandom
hrrRandom
            , shSession :: Session
shSession = Session
session
            , shCipher :: CipherId
shCipher = CipherId
cipherId
            , shComp :: CompressionID
shComp = CompressionID
0
            , shExtensions :: [ExtensionRaw]
shExtensions = [ExtensionRaw]
extensions
            }