{-# 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]
chSession :: CH -> Session
chCiphers :: CH -> [CipherID]
chExtensions :: CH -> [ExtensionRaw]
..} = do
    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 -> Bool -> TLSSt ()
setSession Session
ss Bool
False
        Bool -> TLSSt ()
setClientSupportsPHA 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
$ Group -> HandshakeM ()
setSupportedGroup (Group -> HandshakeM ()) -> Group -> HandshakeM ()
forall a b. (a -> b) -> a -> b
$ KeyShareEntry -> Group
keyShareEntryGroup KeyShareEntry
clientKeyShare
    ServerRandom
srand <- IO ServerRandom
setServerParameter
    -- ALPN is used in choosePSK
    [ExtensionRaw]
protoExt <- Context -> [ExtensionRaw] -> ServerParams -> IO [ExtensionRaw]
applicationProtocol Context
ctx [ExtensionRaw]
chExtensions ServerParams
sparams
    (ByteString
psk, Maybe (ByteString, Int, Int)
binderInfo, Bool
is0RTTvalid) <- IO (ByteString, Maybe (ByteString, Int, Int), Bool)
choosePSK
    SecretPair EarlySecret
earlyKey <- Context
-> CipherChoice
-> Either ByteString (BaseSecret EarlySecret)
-> Bool
-> IO (SecretPair EarlySecret)
calculateEarlySecret Context
ctx CipherChoice
choice (ByteString -> Either ByteString (BaseSecret EarlySecret)
forall a b. a -> Either a b
Left ByteString
psk) Bool
True
    let earlySecret :: BaseSecret EarlySecret
earlySecret = SecretPair EarlySecret -> BaseSecret EarlySecret
forall a. SecretPair a -> BaseSecret a
pairBase SecretPair EarlySecret
earlyKey
        clientEarlySecret :: ClientTrafficSecret EarlySecret
clientEarlySecret = SecretPair EarlySecret -> ClientTrafficSecret EarlySecret
forall a. SecretPair a -> ClientTrafficSecret a
pairClient SecretPair EarlySecret
earlyKey
    [ExtensionRaw]
extensions <- BaseSecret EarlySecret
-> Maybe (ByteString, Int, Int) -> IO [ExtensionRaw]
forall {b}.
Integral b =>
BaseSecret EarlySecret
-> Maybe (ByteString, b, Int) -> IO [ExtensionRaw]
checkBinder BaseSecret EarlySecret
earlySecret Maybe (ByteString, Int, Int)
binderInfo
    Bool
hrr <- Context -> TLSSt Bool -> IO Bool
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt Bool
getTLS13HRR
    let authenticated :: Bool
authenticated = Maybe (ByteString, Int, Int) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ByteString, Int, Int)
binderInfo
        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 allCreds :: Credentials
allCreds =
            (Credential -> Bool) -> Credentials -> Credentials
filterCredentials (Version -> [ExtensionRaw] -> Credential -> Bool
isCredentialAllowed Version
TLS13 [ExtensionRaw]
chExtensions) (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))
forall {m :: * -> *}.
MonadIO m =>
Credentials -> m (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
-> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
forall {b}.
Monoid b =>
KeyShareEntry
-> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
sendServerHello KeyShareEntry
keyShare ServerRandom
srand [ExtensionRaw]
extensions
        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
        ----------------------------------------------------------------
        Bool -> [ExtensionRaw] -> PacketFlightM b ()
forall {b}.
Monoid b =>
Bool -> [ExtensionRaw] -> PacketFlightM b ()
sendExtensions Bool
rtt0OK [ExtensionRaw]
protoExt
        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 -> PacketFlightM b ()
forall {b}.
Monoid b =>
Credential -> HashAndSignatureAlgorithm -> PacketFlightM b ()
sendCertAndVerify Credential
cred HashAndSignatureAlgorithm
hashSig
        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)
    ----------------------------------------------------------------
    ByteString
hChSf <- Context -> IO ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
    SecretTriple ApplicationSecret
appKey <- Context
-> CipherChoice
-> BaseSecret HandshakeSecret
-> ByteString
-> IO (SecretTriple ApplicationSecret)
calculateApplicationSecret Context
ctx CipherChoice
choice BaseSecret HandshakeSecret
handSecret ByteString
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
    ----------------------------------------------------------------
    if Bool
rtt0OK
        then Context -> Established -> IO ()
setEstablished Context
ctx (Int -> Established
EarlyDataAllowed Int
rtt0max)
        else
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Established
established Established -> Established -> Bool
forall a. Eq a => a -> a -> Bool
== Established
NotEstablished) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                Context -> Established -> IO ()
setEstablished Context
ctx (Int -> Established
EarlyDataNotAllowed Int
3) -- hardcoding
    (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 ServerRandom
setServerParameter = do
        ServerRandom
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
        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
-> HandshakeM (Either TLSError ()) -> IO (Either TLSError ())
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM (Either TLSError ()) -> IO (Either TLSError ()))
-> HandshakeM (Either TLSError ()) -> IO (Either TLSError ())
forall a b. (a -> b) -> a -> b
$ Cipher -> HandshakeM (Either TLSError ())
setHelloParameters13 Cipher
usedCipher
        ServerRandom -> IO ServerRandom
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerRandom
srand

    supportsPHA :: Bool
supportsPHA = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_PostHandshakeAuth [ExtensionRaw]
chExtensions
        Maybe ByteString
-> (ByteString -> Maybe PostHandshakeAuth)
-> Maybe PostHandshakeAuth
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> ByteString -> Maybe PostHandshakeAuth
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
        Just PostHandshakeAuth
PostHandshakeAuth -> Bool
True
        Maybe PostHandshakeAuth
Nothing -> Bool
False

    choosePSK :: IO (ByteString, Maybe (ByteString, Int, Int), Bool)
choosePSK = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_PreSharedKey [ExtensionRaw]
chExtensions
        Maybe ByteString
-> (ByteString -> Maybe PreSharedKey) -> Maybe PreSharedKey
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> ByteString -> Maybe PreSharedKey
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
        Just (PreSharedKeyClientHello (PskIdentity ByteString
sessionId 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
                    Maybe SessionData
msdata <-
                        if Bool
rtt0
                            then SessionManager -> ByteString -> IO (Maybe SessionData)
sessionResumeOnlyOnce SessionManager
mgr ByteString
sessionId
                            else SessionManager -> ByteString -> IO (Maybe SessionData)
sessionResume SessionManager
mgr ByteString
sessionId
                    case Maybe SessionData
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
                            Bool
isFresh <- TLS13TicketInfo -> Word32 -> IO Bool
checkFreshness TLS13TicketInfo
tinfo Word32
obfAge
                            (Bool
isPSKvalid, Bool
is0RTTvalid) <- SessionData -> IO (Bool, Bool)
checkSessionEquality SessionData
sdata
                            if Bool
isPSKvalid Bool -> Bool -> Bool
&& Bool
isFresh
                                then (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
psk, (ByteString, Int, Int) -> Maybe (ByteString, Int, Int)
forall a. a -> Maybe a
Just (ByteString
bnd, Int
0 :: Int, Int
len), Bool
is0RTTvalid)
                                else -- fall back to full handshake
                                    (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)
                        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)
        Maybe 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)

    checkSessionEquality :: SessionData -> IO (Bool, Bool)
checkSessionEquality SessionData
sdata = do
        Maybe HostName
msni <- Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
getClientSNI
        Maybe ByteString
malpn <- Context -> TLSSt (Maybe ByteString) -> IO (Maybe ByteString)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe ByteString)
getNegotiatedProtocol
        let isSameSNI :: Bool
isSameSNI = SessionData -> Maybe HostName
sessionClientSNI SessionData
sdata Maybe HostName -> Maybe HostName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe HostName
msni
            isSameCipher :: Bool
isSameCipher = SessionData -> CipherID
sessionCipher SessionData
sdata CipherID -> CipherID -> Bool
forall a. Eq a => a -> a -> Bool
== Cipher -> CipherID
cipherID Cipher
usedCipher
            ciphers :: [Cipher]
ciphers = Supported -> [Cipher]
supportedCiphers (Supported -> [Cipher]) -> Supported -> [Cipher]
forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams
            isSameKDF :: Bool
isSameKDF = case (Cipher -> Bool) -> [Cipher] -> Maybe Cipher
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\Cipher
c -> Cipher -> CipherID
cipherID Cipher
c CipherID -> CipherID -> Bool
forall a. Eq a => a -> a -> Bool
== SessionData -> CipherID
sessionCipher SessionData
sdata) [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 :: Bool
isSameVersion = Version
TLS13 Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== SessionData -> Version
sessionVersion SessionData
sdata
            isSameALPN :: Bool
isSameALPN = SessionData -> Maybe ByteString
sessionALPN SessionData
sdata Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
malpn
            isPSKvalid :: Bool
isPSKvalid = Bool
isSameKDF Bool -> Bool -> Bool
&& Bool
isSameSNI -- fixme: SNI is not required
            is0RTTvalid :: Bool
is0RTTvalid = Bool
isSameVersion Bool -> Bool -> Bool
&& Bool
isSameCipher Bool -> Bool -> Bool
&& Bool
isSameALPN
        (Bool, Bool) -> IO (Bool, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isPSKvalid, Bool
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, b, Int) -> IO [ExtensionRaw]
checkBinder BaseSecret EarlySecret
_ Maybe (ByteString, b, 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, b
n, Int
tlen)) = do
        ByteString
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
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString
binder ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
binder') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            HostName -> IO ()
forall (m :: * -> *) a. MonadIO m => HostName -> m a
decryptError HostName
"PSK binder validation failed"
        let selectedIdentity :: ByteString
selectedIdentity = PreSharedKey -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode (PreSharedKey -> ByteString) -> PreSharedKey -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> PreSharedKey
PreSharedKeyServerHello (Int -> PreSharedKey) -> Int -> PreSharedKey
forall a b. (a -> b) -> a -> b
$ b -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral b
n
        [ExtensionRaw] -> IO [ExtensionRaw]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_PreSharedKey ByteString
selectedIdentity]

    decideCredentialInfo :: Credentials -> m (Maybe (Credential, HashAndSignatureAlgorithm))
decideCredentialInfo Credentials
allCreds = do
        [HashAndSignatureAlgorithm]
cHashSigs <- case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_SignatureAlgorithms [ExtensionRaw]
chExtensions of
            Maybe ByteString
Nothing ->
                TLSError -> m [HashAndSignatureAlgorithm]
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m [HashAndSignatureAlgorithm])
-> TLSError -> m [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ HostName -> AlertDescription -> TLSError
Error_Protocol HostName
"no signature_algorithms extension" AlertDescription
MissingExtension
            Just ByteString
sa -> case MessageType -> ByteString -> Maybe SignatureAlgorithms
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello ByteString
sa of
                Maybe SignatureAlgorithms
Nothing ->
                    TLSError -> m [HashAndSignatureAlgorithm]
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m [HashAndSignatureAlgorithm])
-> TLSError -> m [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ HostName -> AlertDescription -> TLSError
Error_Protocol HostName
"broken signature_algorithms extension" AlertDescription
DecodeError
                Just (SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm] -> m [HashAndSignatureAlgorithm]
forall a. a -> m 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 -> m (Maybe (Credential, HashAndSignatureAlgorithm))
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> m (Maybe (Credential, HashAndSignatureAlgorithm)))
-> TLSError -> m (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)
-> m (Maybe (Credential, HashAndSignatureAlgorithm))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Credential, HashAndSignatureAlgorithm)
mcs
            Maybe (Credential, HashAndSignatureAlgorithm)
mcs -> Maybe (Credential, HashAndSignatureAlgorithm)
-> m (Maybe (Credential, HashAndSignatureAlgorithm))
forall a. a -> m 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 serverKeyShare :: ByteString
serverKeyShare = KeyShare -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode (KeyShare -> ByteString) -> KeyShare -> ByteString
forall a b. (a -> b) -> a -> b
$ KeyShareEntry -> KeyShare
KeyShareServerHello KeyShareEntry
keyShare
            selectedVersion :: ByteString
selectedVersion = SupportedVersions -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode (SupportedVersions -> ByteString)
-> SupportedVersions -> ByteString
forall a b. (a -> b) -> a -> b
$ Version -> SupportedVersions
SupportedVersionsServerHello Version
TLS13
            extensions' :: [ExtensionRaw]
extensions' =
                ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_KeyShare ByteString
serverKeyShare
                    ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_SupportedVersions ByteString
selectedVersion
                    ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: [ExtensionRaw]
extensions
            helo :: Handshake13
helo = ServerRandom
-> Session -> CipherID -> [ExtensionRaw] -> Handshake13
ServerHello13 ServerRandom
srand Session
chSession (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 -> PacketFlightM b ()
sendCertAndVerify cred :: Credential
cred@(CertificateChain
certChain, PrivKey
_) HashAndSignatureAlgorithm
hashSig = 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 -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx ByteString
certReqCtx
            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) []
        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
Certificate13 ByteString
"" 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
        ByteString
hChSc <- Context -> PacketFlightM b ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
        PubKey
pubkey <- Context -> PacketFlightM b PubKey
forall (m :: * -> *). MonadIO m => Context -> m PubKey
getLocalPublicKey Context
ctx
        Handshake13
vrfy <- Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> PacketFlightM b Handshake13
forall (m :: * -> *).
MonadIO m =>
Context
-> PubKey
-> HashAndSignatureAlgorithm
-> ByteString
-> m Handshake13
makeCertVerify Context
ctx PubKey
pubkey HashAndSignatureAlgorithm
hashSig ByteString
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 -> [ExtensionRaw] -> PacketFlightM b ()
sendExtensions Bool
rtt0OK [ExtensionRaw]
protoExt = 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 sniExtension :: Maybe ExtensionRaw
sniExtension = 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
$ ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_ServerName ByteString
""
                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)
            groupExtension :: Maybe ExtensionRaw
groupExtension
                | [Group] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Group]
serverGroups = Maybe ExtensionRaw
forall a. Maybe a
Nothing
                | Bool -> (Group -> Bool) -> Maybe Group -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (Group -> Group -> Bool
forall a. Eq a => a -> a -> Bool
== [Group] -> Group
forall a. HasCallStack => [a] -> a
head [Group]
serverGroups) Maybe Group
mgroup = 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
$
                        ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_SupportedGroups (ByteString -> ExtensionRaw) -> ByteString -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$
                            SupportedGroups -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode ([Group] -> SupportedGroups
SupportedGroups [Group]
serverGroups)
        let earlyDataExtension :: Maybe ExtensionRaw
earlyDataExtension
                | Bool
rtt0OK =
                    ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$
                        ExtensionID -> ByteString -> ExtensionRaw
ExtensionRaw ExtensionID
EID_EarlyData (ByteString -> ExtensionRaw) -> ByteString -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$
                            EarlyDataIndication -> ByteString
forall a. Extension a => a -> ByteString
extensionEncode (Maybe Word32 -> EarlyDataIndication
EarlyDataIndication Maybe Word32
forall a. Maybe a
Nothing)
                | Bool
otherwise = Maybe ExtensionRaw
forall a. Maybe a
Nothing
        let extensions :: [ExtensionRaw]
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
                        [ Maybe ExtensionRaw
earlyDataExtension
                        , Maybe ExtensionRaw
groupExtension
                        , Maybe ExtensionRaw
sniExtension
                        ]
                    [ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [ExtensionRaw]
protoExt
        [ExtensionRaw]
extensions' <-
            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]
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 [[ExtensionRaw] -> Handshake13
EncryptedExtensions13 [ExtensionRaw]
extensions']

    dhModes :: [PskKexMode]
dhModes = case ExtensionID -> [ExtensionRaw] -> Maybe ByteString
extensionLookup ExtensionID
EID_PskKeyExchangeModes [ExtensionRaw]
chExtensions
        Maybe ByteString
-> (ByteString -> Maybe PskKeyExchangeModes)
-> Maybe PskKeyExchangeModes
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MessageType -> ByteString -> Maybe PskKeyExchangeModes
forall a. Extension a => MessageType -> ByteString -> Maybe a
extensionDecode MessageType
MsgTClientHello of
        Just (PskKeyExchangeModes [PskKexMode]
ms) -> [PskKexMode]
ms
        Maybe PskKeyExchangeModes
Nothing -> []

    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