{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Network.TLS.Handshake.Server.ServerHello13 (
sendServerHello13,
) where
import Control.Monad.State.Strict
import qualified Data.ByteString as B
import Network.TLS.Cipher
import Network.TLS.Context.Internal
import Network.TLS.Credentials
import Network.TLS.Crypto
import Network.TLS.Extension
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Control
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Random
import Network.TLS.Handshake.Server.Common
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.Parameters
import Network.TLS.Session
import Network.TLS.State
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Types
import Network.TLS.X509
sendServerHello13
:: ServerParams
-> Context
-> KeyShareEntry
-> (Cipher, Hash, Bool)
-> CH
-> IO
( SecretTriple ApplicationSecret
, ClientTrafficSecret HandshakeSecret
, Bool
, Bool
)
sendServerHello13 :: ServerParams
-> Context
-> KeyShareEntry
-> (Cipher, Hash, Bool)
-> CH
-> IO
(SecretTriple ApplicationSecret,
ClientTrafficSecret HandshakeSecret, Bool, Bool)
sendServerHello13 ServerParams
sparams Context
ctx KeyShareEntry
clientKeyShare (Cipher
usedCipher, Hash
usedHash, Bool
rtt0) CH{[CipherId]
[ExtensionRaw]
Session
chSession :: Session
chCiphers :: [CipherId]
chExtensions :: [ExtensionRaw]
chExtensions :: CH -> [ExtensionRaw]
chCiphers :: CH -> [CipherId]
chSession :: CH -> Session
..} = do
let zlib :: Bool
zlib =
ExtensionID
-> MessageType
-> [ExtensionRaw]
-> Bool
-> (CompressCertificate -> Bool)
-> Bool
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
ExtensionID
EID_CompressCertificate
MessageType
MsgTClientHello
[ExtensionRaw]
chExtensions
Bool
False
(\(CompressCertificate [CertificateCompressionAlgorithm]
ccas) -> CertificateCompressionAlgorithm
CCA_Zlib CertificateCompressionAlgorithm
-> [CertificateCompressionAlgorithm] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CertificateCompressionAlgorithm]
ccas)
recodeSizeLimitExt <- Context -> [ExtensionRaw] -> Bool -> IO (Maybe ExtensionRaw)
processRecordSizeLimit Context
ctx [ExtensionRaw]
chExtensions Bool
True
enableMyRecordLimit ctx
newSession ctx >>= \Session
ss -> Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Session -> TLSSt ()
setSession Session
ss
Bool -> TLSSt ()
setTLS13ClientSupportsPHA Bool
supportsPHA
usingHState ctx $ setSupportedGroup $ keyShareEntryGroup clientKeyShare
srand <- setServerParameter
alpnExt <- applicationProtocol ctx chExtensions sparams
(psk, binderInfo, is0RTTvalid) <- choosePSK
earlyKey <- calculateEarlySecret ctx choice (Left psk) True
let earlySecret = SecretPair EarlySecret -> BaseSecret EarlySecret
forall a. SecretPair a -> BaseSecret a
pairBase SecretPair EarlySecret
earlyKey
clientEarlySecret = SecretPair EarlySecret -> ClientTrafficSecret EarlySecret
forall a. SecretPair a -> ClientTrafficSecret a
pairClient SecretPair EarlySecret
earlyKey
extensions <- checkBinder earlySecret binderInfo
hrr <- usingState_ ctx getTLS13HRR
let authenticated = Maybe (ByteString, Int, Int) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (ByteString, Int, Int)
binderInfo
rtt0OK = Bool
authenticated Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
hrr Bool -> Bool -> Bool
&& Bool
rtt0 Bool -> Bool -> Bool
&& Bool
rtt0accept Bool -> Bool -> Bool
&& Bool
is0RTTvalid
extraCreds <-
usingState_ ctx getClientSNI >>= onServerNameIndication (serverHooks sparams)
let p = Version -> [ExtensionRaw] -> Group -> Bool
makeCredentialPredicate Version
TLS13 [ExtensionRaw]
chExtensions
allCreds =
(Credential -> Bool) -> Credentials -> Credentials
filterCredentials (Version -> (Group -> Bool) -> Credential -> Bool
isCredentialAllowed Version
TLS13 Group -> Bool
p) (Credentials -> Credentials) -> Credentials -> Credentials
forall a b. (a -> b) -> a -> b
$
Credentials
extraCreds Credentials -> Credentials -> Credentials
forall a. Monoid a => a -> a -> a
`mappend` Shared -> Credentials
sharedCredentials (Context -> Shared
ctxShared Context
ctx)
established <- ctxEstablished ctx
if established /= NotEstablished
then
if rtt0OK
then do
usingHState ctx $ setTLS13HandshakeMode RTT0
usingHState ctx $ setTLS13RTT0Status RTT0Accepted
else do
usingHState ctx $ setTLS13HandshakeMode PreSharedKey
usingHState ctx $ setTLS13RTT0Status RTT0Rejected
else when authenticated $ usingHState ctx $ setTLS13HandshakeMode PreSharedKey
mCredInfo <-
if authenticated then return Nothing else decideCredentialInfo allCreds
(ecdhe, keyShare) <- makeServerKeyShare ctx clientKeyShare
ensureRecvComplete ctx
(clientHandshakeSecret, handSecret) <- runPacketFlight ctx $ do
sendServerHello keyShare srand extensions
sendChangeCipherSpec13 ctx
handKey <- liftIO $ calculateHandshakeSecret ctx choice earlySecret ecdhe
let serverHandshakeSecret = SecretTriple HandshakeSecret -> ServerTrafficSecret HandshakeSecret
forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple HandshakeSecret
handKey
clientHandshakeSecret = SecretTriple HandshakeSecret -> ClientTrafficSecret HandshakeSecret
forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple HandshakeSecret
handKey
handSecret = SecretTriple HandshakeSecret -> BaseSecret HandshakeSecret
forall a. SecretTriple a -> BaseSecret a
triBase SecretTriple HandshakeSecret
handKey
liftIO $ do
if rtt0OK && not (ctxQUICMode ctx)
then setRxRecordState ctx usedHash usedCipher clientEarlySecret
else setRxRecordState ctx usedHash usedCipher clientHandshakeSecret
setTxRecordState ctx usedHash usedCipher serverHandshakeSecret
let mEarlySecInfo
| Bool
rtt0OK = EarlySecretInfo -> Maybe EarlySecretInfo
forall a. a -> Maybe a
Just (EarlySecretInfo -> Maybe EarlySecretInfo)
-> EarlySecretInfo -> Maybe EarlySecretInfo
forall a b. (a -> b) -> a -> b
$ Cipher -> ClientTrafficSecret EarlySecret -> EarlySecretInfo
EarlySecretInfo Cipher
usedCipher ClientTrafficSecret EarlySecret
clientEarlySecret
| Bool
otherwise = Maybe EarlySecretInfo
forall a. Maybe a
Nothing
handSecInfo = Cipher -> TrafficSecrets HandshakeSecret -> HandshakeSecretInfo
HandshakeSecretInfo Cipher
usedCipher (ClientTrafficSecret HandshakeSecret
clientHandshakeSecret, ServerTrafficSecret HandshakeSecret
serverHandshakeSecret)
contextSync ctx $ SendServerHello chExtensions mEarlySecInfo handSecInfo
liftIO $ enablePeerRecordLimit ctx
sendExtensions rtt0OK alpnExt recodeSizeLimitExt
case mCredInfo of
Maybe (Credential, HashAndSignatureAlgorithm)
Nothing -> () -> PacketFlightM b ()
forall a. a -> PacketFlightM b a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just (Credential
cred, HashAndSignatureAlgorithm
hashSig) -> Credential
-> HashAndSignatureAlgorithm -> Bool -> PacketFlightM b ()
forall {b}.
Monoid b =>
Credential
-> HashAndSignatureAlgorithm -> Bool -> PacketFlightM b ()
sendCertAndVerify Credential
cred HashAndSignatureAlgorithm
hashSig Bool
zlib
let ServerTrafficSecret shs = serverHandshakeSecret
rawFinished <- makeFinished ctx usedHash shs
loadPacket13 ctx $ Handshake13 [rawFinished]
return (clientHandshakeSecret, handSecret)
hChSf <- transcriptHash ctx
appKey <- calculateApplicationSecret ctx choice handSecret hChSf
let clientApplicationSecret0 = SecretTriple ApplicationSecret
-> ClientTrafficSecret ApplicationSecret
forall a. SecretTriple a -> ClientTrafficSecret a
triClient SecretTriple ApplicationSecret
appKey
serverApplicationSecret0 = SecretTriple ApplicationSecret
-> ServerTrafficSecret ApplicationSecret
forall a. SecretTriple a -> ServerTrafficSecret a
triServer SecretTriple ApplicationSecret
appKey
setTxRecordState ctx usedHash usedCipher serverApplicationSecret0
let appSecInfo = TrafficSecrets ApplicationSecret -> ApplicationSecretInfo
ApplicationSecretInfo (ClientTrafficSecret ApplicationSecret
clientApplicationSecret0, ServerTrafficSecret ApplicationSecret
serverApplicationSecret0)
contextSync ctx $ SendServerFinished appSecInfo
when rtt0OK $ setEstablished ctx (EarlyDataAllowed rtt0max)
return (appKey, clientHandshakeSecret, authenticated, rtt0OK)
where
choice :: CipherChoice
choice = Version -> Cipher -> CipherChoice
makeCipherChoice Version
TLS13 Cipher
usedCipher
setServerParameter :: IO ServerRandom
setServerParameter = do
srand <-
Context -> Version -> [Version] -> IO ServerRandom
serverRandom Context
ctx Version
TLS13 ([Version] -> IO ServerRandom) -> [Version] -> IO ServerRandom
forall a b. (a -> b) -> a -> b
$ Supported -> [Version]
supportedVersions (Supported -> [Version]) -> Supported -> [Version]
forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams
usingState_ ctx $ setVersion TLS13
failOnEitherError $ usingHState ctx $ setHelloParameters13 usedCipher
return srand
supportsPHA :: Bool
supportsPHA =
ExtensionID
-> MessageType
-> [ExtensionRaw]
-> Bool
-> (PostHandshakeAuth -> Bool)
-> Bool
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
ExtensionID
EID_PostHandshakeAuth
MessageType
MsgTClientHello
[ExtensionRaw]
chExtensions
Bool
False
(\PostHandshakeAuth
PostHandshakeAuth -> Bool
True)
selectPSK :: PreSharedKey -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
selectPSK (PreSharedKeyClientHello (PskIdentity ByteString
identity Word32
obfAge : [PskIdentity]
_) bnds :: [ByteString]
bnds@(ByteString
bnd : [ByteString]
_)) = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([PskKexMode] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PskKexMode]
dhModes) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
TLSError -> IO ()
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO ()) -> TLSError -> IO ()
forall a b. (a -> b) -> a -> b
$
HostName -> AlertDescription -> TLSError
Error_Protocol HostName
"no psk_key_exchange_modes extension" AlertDescription
MissingExtension
if PskKexMode
PSK_DHE_KE PskKexMode -> [PskKexMode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PskKexMode]
dhModes
then do
let len :: Int
len = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((ByteString -> Int) -> [ByteString] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
x -> ByteString -> Int
B.length ByteString
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [ByteString]
bnds) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
mgr :: SessionManager
mgr = Shared -> SessionManager
sharedSessionManager (Shared -> SessionManager) -> Shared -> SessionManager
forall a b. (a -> b) -> a -> b
$ ServerParams -> Shared
serverShared ServerParams
sparams
msdata <-
if Bool
rtt0
then SessionManager -> ByteString -> IO (Maybe SessionData)
sessionResumeOnlyOnce SessionManager
mgr ByteString
identity
else SessionManager -> ByteString -> IO (Maybe SessionData)
sessionResume SessionManager
mgr ByteString
identity
case msdata of
Just SessionData
sdata -> do
let tinfo :: TLS13TicketInfo
tinfo = Maybe TLS13TicketInfo -> TLS13TicketInfo
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe TLS13TicketInfo -> TLS13TicketInfo)
-> Maybe TLS13TicketInfo -> TLS13TicketInfo
forall a b. (a -> b) -> a -> b
$ SessionData -> Maybe TLS13TicketInfo
sessionTicketInfo SessionData
sdata
psk :: ByteString
psk = SessionData -> ByteString
sessionSecret SessionData
sdata
isFresh <- TLS13TicketInfo -> Word32 -> IO Bool
checkFreshness TLS13TicketInfo
tinfo Word32
obfAge
(isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata
if isPSKvalid && isFresh
then return (psk, Just (bnd, 0 :: Int, len), is0RTTvalid)
else
return (zero, Nothing, False)
Maybe SessionData
_ -> (ByteString, Maybe (ByteString, Int, Int), Bool)
-> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
zero, Maybe (ByteString, Int, Int)
forall a. Maybe a
Nothing, Bool
False)
else (ByteString, Maybe (ByteString, Int, Int), Bool)
-> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
zero, Maybe (ByteString, Int, Int)
forall a. Maybe a
Nothing, Bool
False)
selectPSK PreSharedKey
_ = (ByteString, Maybe (ByteString, Int, Int), Bool)
-> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
zero, Maybe (ByteString, Int, Int)
forall a. Maybe a
Nothing, Bool
False)
choosePSK :: IO (ByteString, Maybe (ByteString, Int, Int), Bool)
choosePSK =
ExtensionID
-> MessageType
-> [ExtensionRaw]
-> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
-> (PreSharedKey
-> IO (ByteString, Maybe (ByteString, Int, Int), Bool))
-> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
forall a b.
Extension a =>
ExtensionID
-> MessageType -> [ExtensionRaw] -> IO b -> (a -> IO b) -> IO b
lookupAndDecodeAndDo
ExtensionID
EID_PreSharedKey
MessageType
MsgTClientHello
[ExtensionRaw]
chExtensions
((ByteString, Maybe (ByteString, Int, Int), Bool)
-> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
zero, Maybe (ByteString, Int, Int)
forall a. Maybe a
Nothing, Bool
False))
PreSharedKey -> IO (ByteString, Maybe (ByteString, Int, Int), Bool)
selectPSK
checkSessionEquality :: SessionData -> IO (Bool, Bool)
checkSessionEquality SessionData
sdata = do
msni <- Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
getClientSNI
malpn <- usingState_ ctx getNegotiatedProtocol
let isSameSNI = SessionData -> Maybe HostName
sessionClientSNI SessionData
sdata Maybe HostName -> Maybe HostName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe HostName
msni
isSameCipher = SessionData -> CipherID
sessionCipher SessionData
sdata CipherID -> CipherID -> Bool
forall a. Eq a => a -> a -> Bool
== Cipher -> CipherID
cipherID Cipher
usedCipher
ciphers = Supported -> [Cipher]
supportedCiphers (Supported -> [Cipher]) -> Supported -> [Cipher]
forall a b. (a -> b) -> a -> b
$ ServerParams -> Supported
serverSupported ServerParams
sparams
scid = SessionData -> CipherID
sessionCipher SessionData
sdata
isSameKDF = case CipherID -> [Cipher] -> Maybe Cipher
findCipher CipherID
scid [Cipher]
ciphers of
Maybe Cipher
Nothing -> Bool
False
Just Cipher
c -> Cipher -> Hash
cipherHash Cipher
c Hash -> Hash -> Bool
forall a. Eq a => a -> a -> Bool
== Cipher -> Hash
cipherHash Cipher
usedCipher
isSameVersion = Version
TLS13 Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
== SessionData -> Version
sessionVersion SessionData
sdata
isSameALPN = SessionData -> Maybe ByteString
sessionALPN SessionData
sdata Maybe ByteString -> Maybe ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ByteString
malpn
isPSKvalid = Bool
isSameKDF Bool -> Bool -> Bool
&& Bool
isSameSNI
is0RTTvalid = Bool
isSameVersion Bool -> Bool -> Bool
&& Bool
isSameCipher Bool -> Bool -> Bool
&& Bool
isSameALPN
return (isPSKvalid, is0RTTvalid)
rtt0max :: Int
rtt0max = Int -> Int
forall a. (Num a, Ord a, FiniteBits a) => a -> a
safeNonNegative32 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ ServerParams -> Int
serverEarlyDataSize ServerParams
sparams
rtt0accept :: Bool
rtt0accept = ServerParams -> Int
serverEarlyDataSize ServerParams
sparams Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
checkBinder :: BaseSecret EarlySecret
-> Maybe (ByteString, a, Int) -> IO [ExtensionRaw]
checkBinder BaseSecret EarlySecret
_ Maybe (ByteString, a, Int)
Nothing = [ExtensionRaw] -> IO [ExtensionRaw]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
checkBinder BaseSecret EarlySecret
earlySecret (Just (ByteString
binder, a
n, Int
tlen)) = do
binder' <- Context
-> BaseSecret EarlySecret
-> Hash
-> Int
-> Maybe ByteString
-> IO ByteString
makePSKBinder Context
ctx BaseSecret EarlySecret
earlySecret Hash
usedHash Int
tlen Maybe ByteString
forall a. Maybe a
Nothing
unless (binder == binder') $
decryptError "PSK binder validation failed"
return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n]
decideCredentialInfo :: Credentials -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
decideCredentialInfo Credentials
allCreds = do
let err :: IO a
err =
TLSError -> IO a
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO a) -> TLSError -> IO a
forall a b. (a -> b) -> a -> b
$ HostName -> AlertDescription -> TLSError
Error_Protocol HostName
"broken signature_algorithms extension" AlertDescription
DecodeError
cHashSigs <-
ExtensionID
-> MessageType
-> [ExtensionRaw]
-> IO [HashAndSignatureAlgorithm]
-> (SignatureAlgorithms -> IO [HashAndSignatureAlgorithm])
-> IO [HashAndSignatureAlgorithm]
forall a b.
Extension a =>
ExtensionID
-> MessageType -> [ExtensionRaw] -> IO b -> (a -> IO b) -> IO b
lookupAndDecodeAndDo
ExtensionID
EID_SignatureAlgorithms
MessageType
MsgTClientHello
[ExtensionRaw]
chExtensions
IO [HashAndSignatureAlgorithm]
forall {a}. IO a
err
(\(SignatureAlgorithms [HashAndSignatureAlgorithm]
sas) -> [HashAndSignatureAlgorithm] -> IO [HashAndSignatureAlgorithm]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [HashAndSignatureAlgorithm]
sas)
let sHashSigs = (HashAndSignatureAlgorithm -> Bool)
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a. (a -> Bool) -> [a] -> [a]
filter HashAndSignatureAlgorithm -> Bool
isHashSignatureValid13 ([HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm])
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Supported -> [HashAndSignatureAlgorithm]
supportedHashSignatures (Supported -> [HashAndSignatureAlgorithm])
-> Supported -> [HashAndSignatureAlgorithm]
forall a b. (a -> b) -> a -> b
$ Context -> Supported
ctxSupported Context
ctx
hashSigs = [HashAndSignatureAlgorithm]
sHashSigs [HashAndSignatureAlgorithm]
-> [HashAndSignatureAlgorithm] -> [HashAndSignatureAlgorithm]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [HashAndSignatureAlgorithm]
cHashSigs
cltCreds = [ExtensionRaw] -> Credentials -> Credentials
filterCredentialsWithHashSignatures [ExtensionRaw]
chExtensions Credentials
allCreds
case credentialsFindForSigning13 hashSigs cltCreds of
Maybe (Credential, HashAndSignatureAlgorithm)
Nothing ->
case [HashAndSignatureAlgorithm]
-> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
credentialsFindForSigning13 [HashAndSignatureAlgorithm]
hashSigs Credentials
allCreds of
Maybe (Credential, HashAndSignatureAlgorithm)
Nothing -> TLSError -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
forall (m :: * -> *) a. MonadIO m => TLSError -> m a
throwCore (TLSError -> IO (Maybe (Credential, HashAndSignatureAlgorithm)))
-> TLSError -> IO (Maybe (Credential, HashAndSignatureAlgorithm))
forall a b. (a -> b) -> a -> b
$ HostName -> AlertDescription -> TLSError
Error_Protocol HostName
"credential not found" AlertDescription
HandshakeFailure
Maybe (Credential, HashAndSignatureAlgorithm)
mcs -> Maybe (Credential, HashAndSignatureAlgorithm)
-> IO (Maybe (Credential, HashAndSignatureAlgorithm))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Credential, HashAndSignatureAlgorithm)
mcs
Maybe (Credential, HashAndSignatureAlgorithm)
mcs -> Maybe (Credential, HashAndSignatureAlgorithm)
-> IO (Maybe (Credential, HashAndSignatureAlgorithm))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Credential, HashAndSignatureAlgorithm)
mcs
sendServerHello :: KeyShareEntry
-> ServerRandom -> [ExtensionRaw] -> PacketFlightM b ()
sendServerHello KeyShareEntry
keyShare ServerRandom
srand [ExtensionRaw]
extensions = do
let keyShareExt :: ExtensionRaw
keyShareExt = KeyShare -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (KeyShare -> ExtensionRaw) -> KeyShare -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ KeyShareEntry -> KeyShare
KeyShareServerHello KeyShareEntry
keyShare
versionExt :: ExtensionRaw
versionExt = SupportedVersions -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (SupportedVersions -> ExtensionRaw)
-> SupportedVersions -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ Version -> SupportedVersions
SupportedVersionsServerHello Version
TLS13
extensions' :: [ExtensionRaw]
extensions' = ExtensionRaw
keyShareExt ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: ExtensionRaw
versionExt ExtensionRaw -> [ExtensionRaw] -> [ExtensionRaw]
forall a. a -> [a] -> [a]
: [ExtensionRaw]
extensions
helo :: Handshake13
helo = ServerRandom
-> Session -> CipherId -> [ExtensionRaw] -> Handshake13
ServerHello13 ServerRandom
srand Session
chSession (CipherID -> CipherId
CipherId (Cipher -> CipherID
cipherID Cipher
usedCipher)) [ExtensionRaw]
extensions'
Context -> Packet13 -> PacketFlightM b ()
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
helo]
sendCertAndVerify :: Credential
-> HashAndSignatureAlgorithm -> Bool -> PacketFlightM b ()
sendCertAndVerify cred :: Credential
cred@(CertificateChain
certChain, PrivKey
_) HashAndSignatureAlgorithm
hashSig Bool
zlib = do
Context -> Credential -> PacketFlightM b ()
forall (m :: * -> *). MonadIO m => Context -> Credential -> m ()
storePrivInfoServer Context
ctx Credential
cred
Bool -> PacketFlightM b () -> PacketFlightM b ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ServerParams -> Bool
serverWantClientCert ServerParams
sparams) (PacketFlightM b () -> PacketFlightM b ())
-> PacketFlightM b () -> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$ do
let certReqCtx :: ByteString
certReqCtx = ByteString
""
certReq :: Handshake13
certReq = ServerParams -> Context -> ByteString -> Bool -> Handshake13
makeCertRequest ServerParams
sparams Context
ctx ByteString
certReqCtx Bool
True
Context -> Packet13 -> PacketFlightM b ()
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$ [Handshake13] -> Packet13
Handshake13 [Handshake13
certReq]
Context -> HandshakeM () -> PacketFlightM b ()
forall (m :: * -> *) a. MonadIO m => Context -> HandshakeM a -> m a
usingHState Context
ctx (HandshakeM () -> PacketFlightM b ())
-> HandshakeM () -> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$ Bool -> HandshakeM ()
setCertReqSent Bool
True
let CertificateChain [SignedExact Certificate]
cs = CertificateChain
certChain
ess :: [[a]]
ess = Int -> [a] -> [[a]]
forall a. Int -> a -> [a]
replicate ([SignedExact Certificate] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SignedExact Certificate]
cs) []
let certtag :: ByteString
-> TLSCertificateChain -> [[ExtensionRaw]] -> Handshake13
certtag = if Bool
zlib then ByteString
-> TLSCertificateChain -> [[ExtensionRaw]] -> Handshake13
CompressedCertificate13 else ByteString
-> TLSCertificateChain -> [[ExtensionRaw]] -> Handshake13
Certificate13
Context -> Packet13 -> PacketFlightM b ()
forall b. Monoid b => Context -> Packet13 -> PacketFlightM b ()
loadPacket13 Context
ctx (Packet13 -> PacketFlightM b ()) -> Packet13 -> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$
[Handshake13] -> Packet13
Handshake13 [ByteString
-> TLSCertificateChain -> [[ExtensionRaw]] -> Handshake13
certtag ByteString
"" (CertificateChain -> TLSCertificateChain
TLSCertificateChain CertificateChain
certChain) [[ExtensionRaw]]
forall {a}. [[a]]
ess]
IO () -> PacketFlightM b ()
forall a. IO a -> PacketFlightM b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> PacketFlightM b ()) -> IO () -> PacketFlightM b ()
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt () -> IO ()
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx (TLSSt () -> IO ()) -> TLSSt () -> IO ()
forall a b. (a -> b) -> a -> b
$ CertificateChain -> TLSSt ()
setServerCertificateChain CertificateChain
certChain
hChSc <- Context -> PacketFlightM b ByteString
forall (m :: * -> *). MonadIO m => Context -> m ByteString
transcriptHash Context
ctx
pubkey <- getLocalPublicKey ctx
vrfy <- makeCertVerify ctx pubkey hashSig hChSc
loadPacket13 ctx $ Handshake13 [vrfy]
sendExtensions :: Bool
-> Maybe ExtensionRaw -> Maybe ExtensionRaw -> PacketFlightM b ()
sendExtensions Bool
rtt0OK Maybe ExtensionRaw
alpnExt Maybe ExtensionRaw
recodeSizeLimitExt = do
msni <- IO (Maybe HostName) -> PacketFlightM b (Maybe HostName)
forall a. IO a -> PacketFlightM b a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe HostName) -> PacketFlightM b (Maybe HostName))
-> IO (Maybe HostName) -> PacketFlightM b (Maybe HostName)
forall a b. (a -> b) -> a -> b
$ Context -> TLSSt (Maybe HostName) -> IO (Maybe HostName)
forall a. Context -> TLSSt a -> IO a
usingState_ Context
ctx TLSSt (Maybe HostName)
getClientSNI
let sniExt = case Maybe HostName
msni of
Just HostName
_ -> ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ ServerName -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (ServerName -> ExtensionRaw) -> ServerName -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ [ServerNameType] -> ServerName
ServerName []
Maybe HostName
Nothing -> Maybe ExtensionRaw
forall a. Maybe a
Nothing
mgroup <- usingHState ctx getSupportedGroup
let serverGroups = Supported -> [Group]
supportedGroups (Context -> Supported
ctxSupported Context
ctx)
groupExt = case [Group]
serverGroups of
[] -> Maybe ExtensionRaw
forall a. Maybe a
Nothing
Group
rg : [Group]
_ -> case Maybe Group
mgroup of
Maybe Group
Nothing -> Maybe ExtensionRaw
forall a. Maybe a
Nothing
Just Group
grp
| Group
grp Group -> Group -> Bool
forall a. Eq a => a -> a -> Bool
== Group
rg -> Maybe ExtensionRaw
forall a. Maybe a
Nothing
| Bool
otherwise -> ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ SupportedGroups -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (SupportedGroups -> ExtensionRaw)
-> SupportedGroups -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ [Group] -> SupportedGroups
SupportedGroups [Group]
serverGroups
let earlyDataExt
| Bool
rtt0OK = ExtensionRaw -> Maybe ExtensionRaw
forall a. a -> Maybe a
Just (ExtensionRaw -> Maybe ExtensionRaw)
-> ExtensionRaw -> Maybe ExtensionRaw
forall a b. (a -> b) -> a -> b
$ EarlyDataIndication -> ExtensionRaw
forall e. Extension e => e -> ExtensionRaw
toExtensionRaw (EarlyDataIndication -> ExtensionRaw)
-> EarlyDataIndication -> ExtensionRaw
forall a b. (a -> b) -> a -> b
$ Maybe Word32 -> EarlyDataIndication
EarlyDataIndication Maybe Word32
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe ExtensionRaw
forall a. Maybe a
Nothing
let extensions =
Shared -> [ExtensionRaw]
sharedHelloExtensions (ServerParams -> Shared
serverShared ServerParams
sparams)
[ExtensionRaw] -> [ExtensionRaw] -> [ExtensionRaw]
forall a. [a] -> [a] -> [a]
++ [Maybe ExtensionRaw] -> [ExtensionRaw]
forall a. [Maybe a] -> [a]
catMaybes
[ Maybe ExtensionRaw
sniExt
, Maybe ExtensionRaw
groupExt
, Maybe ExtensionRaw
alpnExt
, Maybe ExtensionRaw
recodeSizeLimitExt
, Maybe ExtensionRaw
earlyDataExt
]
extensions' <-
liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) extensions
loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 extensions']
dhModes :: [PskKexMode]
dhModes =
ExtensionID
-> MessageType
-> [ExtensionRaw]
-> [PskKexMode]
-> (PskKeyExchangeModes -> [PskKexMode])
-> [PskKexMode]
forall e a.
Extension e =>
ExtensionID -> MessageType -> [ExtensionRaw] -> a -> (e -> a) -> a
lookupAndDecode
ExtensionID
EID_PskKeyExchangeModes
MessageType
MsgTClientHello
[ExtensionRaw]
chExtensions
[]
(\(PskKeyExchangeModes [PskKexMode]
ms) -> [PskKexMode]
ms)
hashSize :: Int
hashSize = Hash -> Int
hashDigestSize Hash
usedHash
zero :: ByteString
zero = Int -> Word8 -> ByteString
B.replicate Int
hashSize Word8
0
credentialsFindForSigning13
:: [HashAndSignatureAlgorithm]
-> Credentials
-> Maybe (Credential, HashAndSignatureAlgorithm)
credentialsFindForSigning13 :: [HashAndSignatureAlgorithm]
-> Credentials -> Maybe (Credential, HashAndSignatureAlgorithm)
credentialsFindForSigning13 [HashAndSignatureAlgorithm]
hss0 Credentials
creds = [HashAndSignatureAlgorithm]
-> Maybe (Credential, HashAndSignatureAlgorithm)
loop [HashAndSignatureAlgorithm]
hss0
where
loop :: [HashAndSignatureAlgorithm]
-> Maybe (Credential, HashAndSignatureAlgorithm)
loop [] = Maybe (Credential, HashAndSignatureAlgorithm)
forall a. Maybe a
Nothing
loop (HashAndSignatureAlgorithm
hs : [HashAndSignatureAlgorithm]
hss) = case HashAndSignatureAlgorithm -> Credentials -> Maybe Credential
credentialsFindForSigning13' HashAndSignatureAlgorithm
hs Credentials
creds of
Maybe Credential
Nothing -> [HashAndSignatureAlgorithm]
-> Maybe (Credential, HashAndSignatureAlgorithm)
loop [HashAndSignatureAlgorithm]
hss
Just Credential
cred -> (Credential, HashAndSignatureAlgorithm)
-> Maybe (Credential, HashAndSignatureAlgorithm)
forall a. a -> Maybe a
Just (Credential
cred, HashAndSignatureAlgorithm
hs)
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