{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.TLS.Handshake.Client
( handshakeClient
, handshakeClientWith
) where
import Network.TLS.Crypto
import Network.TLS.Context.Internal
import Network.TLS.Parameters
import Network.TLS.Struct
import Network.TLS.Struct13
import Network.TLS.Cipher
import Network.TLS.Compression
import Network.TLS.Credentials
import Network.TLS.Packet hiding (getExtensions)
import Network.TLS.ErrT
import Network.TLS.Extension
import Network.TLS.IO
import Network.TLS.Imports
import Network.TLS.State
import Network.TLS.Measurement
import Network.TLS.Util (bytesEq, catchException, fromJust, mapChunks_)
import Network.TLS.Types
import Network.TLS.X509
import qualified Data.ByteString as B
import Data.X509 (ExtKeyUsageFlag(..))
import Control.Monad.State.Strict
import Control.Exception (SomeException)
import Network.TLS.Handshake.Common
import Network.TLS.Handshake.Common13
import Network.TLS.Handshake.Process
import Network.TLS.Handshake.Certificate
import Network.TLS.Handshake.Signature
import Network.TLS.Handshake.Key
import Network.TLS.Handshake.Random
import Network.TLS.Handshake.State
import Network.TLS.Handshake.State13
import Network.TLS.KeySchedule
import Network.TLS.Wire
handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()
handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx
handshakeClientWith _ _ _ = throwCore $ Error_Protocol ("unexpected handshake message received in handshakeClientWith", True, HandshakeFailure)
handshakeClient :: ClientParams -> Context -> IO ()
handshakeClient cparams ctx = do
let groups = case clientWantSessionResume cparams of
Nothing -> groupsSupported
Just (_, sdata) -> case sessionGroup sdata of
Nothing -> []
Just grp -> grp : filter (/= grp) groupsSupported
groupsSupported = supportedGroups (ctxSupported ctx)
handshakeClient' cparams ctx groups Nothing
handshakeClient' :: ClientParams -> Context -> [Group] -> Maybe ClientRandom -> IO ()
handshakeClient' cparams ctx groups mcrand = do
updateMeasure ctx incrementNbHandshakes
sentExtensions <- sendClientHello mcrand
recvServerHello sentExtensions
ver <- usingState_ ctx getVersion
hrr <- usingState_ ctx getTLS13HRR
if ver == TLS13 then do
if hrr then case drop 1 groups of
[] -> throwCore $ Error_Protocol ("group is exhausted in the client side", True, IllegalParameter)
groups' -> do
mks <- usingState_ ctx getTLS13KeyShare
case mks of
Just (KeyShareHRR selectedGroup)
| selectedGroup `elem` groups' -> do
usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest
clearTxState ctx
let cparams' = cparams { clientEarlyData = Nothing }
crand <- usingHState ctx $ hstClientRandom <$> get
handshakeClient' cparams' ctx [selectedGroup] (Just crand)
| otherwise -> throwCore $ Error_Protocol ("server-selected group is not supported", True, IllegalParameter)
Just _ -> error "handshakeClient': invalid KeyShare value"
Nothing -> throwCore $ Error_Protocol ("key exchange not implemented in HRR, expected key_share extension", True, HandshakeFailure)
else do
handshakeClient13 cparams ctx
else do
sessionResuming <- usingState_ ctx isSessionResuming
if sessionResuming
then sendChangeCipherAndFinish ctx ClientRole
else do sendClientData cparams ctx
sendChangeCipherAndFinish ctx ClientRole
recvChangeCipherAndFinish ctx
handshakeTerminate ctx
where ciphers = supportedCiphers $ ctxSupported ctx
compressions = supportedCompressions $ ctxSupported ctx
highestVer = maximum $ supportedVersions $ ctxSupported ctx
tls13 = highestVer >= TLS13
getExtensions = sequence [sniExtension
,secureReneg
,alpnExtension
,groupExtension
,ecPointExtension
,signatureAlgExtension
,versionExtension
,earlyDataExtension
,keyshareExtension
,pskExchangeModeExtension
,cookieExtension
,preSharedKeyExtension
]
toExtensionRaw :: Extension e => e -> ExtensionRaw
toExtensionRaw ext = ExtensionRaw (extensionID ext) (extensionEncode ext)
secureReneg =
if supportedSecureRenegotiation $ ctxSupported ctx
then usingState_ ctx (getVerifiedData ClientRole) >>= \vd -> return $ Just $ toExtensionRaw $ SecureRenegotiation vd Nothing
else return Nothing
alpnExtension = do
mprotos <- onSuggestALPN $ clientHooks cparams
case mprotos of
Nothing -> return Nothing
Just protos -> do
usingState_ ctx $ setClientALPNSuggest protos
return $ Just $ toExtensionRaw $ ApplicationLayerProtocolNegotiation protos
sniExtension = if clientUseServerNameIndication cparams
then do let sni = fst $ clientServerIdentification cparams
usingState_ ctx $ setClientSNI sni
return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni]
else return Nothing
groupExtension = return $ Just $ toExtensionRaw $ NegotiatedGroups (supportedGroups $ ctxSupported ctx)
ecPointExtension = return $ Just $ toExtensionRaw $ EcPointFormatsSupported [EcPointFormat_Uncompressed]
signatureAlgExtension = return $ Just $ toExtensionRaw $ SignatureAlgorithms $ supportedHashSignatures $ clientSupported cparams
versionExtension
| tls13 = do
let vers = filter (>= TLS12) $ supportedVersions $ ctxSupported ctx
return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers
| otherwise = return Nothing
keyshareExtension
| tls13 = case groups of
[] -> return Nothing
grp:_ -> do
(cpri, ent) <- makeClientKeyShare ctx grp
usingHState ctx $ setGroupPrivate cpri
return $ Just $ toExtensionRaw $ KeyShareClientHello [ent]
| otherwise = return Nothing
sessionAndCipherToResume13 = do
guard tls13
(sid, sdata) <- clientWantSessionResume cparams
guard (sessionVersion sdata >= TLS13)
sCipher <- find (\c -> cipherID c == sessionCipher sdata) ciphers
return (sid, sdata, sCipher)
preSharedKeyExtension =
case sessionAndCipherToResume13 of
Nothing -> return Nothing
Just (sid, sdata, sCipher) -> do
let usedHash = cipherHash sCipher
siz = hashDigestSize usedHash
zero = B.replicate siz 0
tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata
age <- getAge tinfo
if isAgeValid age tinfo then do
let obfAge = ageToObfuscatedAge age tinfo
let identity = PskIdentity sid obfAge
offeredPsks = PreSharedKeyClientHello [identity] [zero]
return $ Just $ toExtensionRaw offeredPsks
else
return Nothing
pskExchangeModeExtension
| tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]
| otherwise = return Nothing
earlyDataExtension = case check0RTT of
Nothing -> return Nothing
_ -> return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)
cookieExtension = do
mcookie <- usingState_ ctx getTLS13Cookie
case mcookie of
Nothing -> return Nothing
Just cookie -> return $ Just $ toExtensionRaw cookie
clientSession = case clientWantSessionResume cparams of
Nothing -> Session Nothing
Just (sid, sdata)
| sessionVersion sdata >= TLS13 -> Session Nothing
| otherwise -> Session (Just sid)
adjustExtentions exts ch =
case sessionAndCipherToResume13 of
Nothing -> return exts
Just (_, sdata, sCipher) -> do
let usedHash = cipherHash sCipher
siz = hashDigestSize usedHash
zero = B.replicate siz 0
psk = sessionSecret sdata
earlySecret = hkdfExtract usedHash zero psk
usingHState ctx $ setTLS13Secret (EarlySecret earlySecret)
let ech = encodeHandshake ch
binder <- makePSKBinder ctx earlySecret usedHash (siz + 3) (Just ech)
let exts' = init exts ++ [adjust (last exts)]
adjust (ExtensionRaw eid withoutBinders) = ExtensionRaw eid withBinders
where
withBinders = replacePSKBinder withoutBinders binder
return exts'
sendClientHello mcr = do
crand <- clientRandom ctx mcr
let ver = if tls13 then TLS12 else highestVer
hrr <- usingState_ ctx getTLS13HRR
unless hrr $ startHandshake ctx ver crand
usingState_ ctx $ setVersionIfUnset highestVer
let cipherIds = map cipherID ciphers
compIds = map compressionID compressions
mkClientHello exts = ClientHello ver crand clientSession cipherIds compIds exts Nothing
extensions0 <- catMaybes <$> getExtensions
extensions <- adjustExtentions extensions0 $ mkClientHello extensions0
sendPacket ctx $ Handshake [mkClientHello extensions]
send0RTT
return $ map (\(ExtensionRaw i _) -> i) extensions
check0RTT = do
(_, sdata, sCipher) <- sessionAndCipherToResume13
earlyData <- clientEarlyData cparams
guard (B.length earlyData <= sessionMaxEarlyDataSize sdata)
return (sCipher, earlyData)
send0RTT = case check0RTT of
Nothing -> return ()
Just (usedCipher, earlyData) -> do
let usedHash = cipherHash usedCipher
hmsgs <- usingHState ctx getHandshakeMessages
let hCh = hash usedHash $ B.concat hmsgs
EarlySecret earlySecret <- usingHState ctx getTLS13Secret
let clientEarlyTrafficSecret = deriveSecret usedHash earlySecret "c e traffic" hCh
logKey ctx (ClientEarlyTrafficSecret clientEarlyTrafficSecret)
setTxState ctx usedHash usedCipher clientEarlyTrafficSecret
mapChunks_ 16384 (sendPacket13 ctx . AppData13) earlyData
usingHState ctx $ setTLS13RTT0Status RTT0Sent
recvServerHello sentExts = runRecvState ctx recvState
where recvState = RecvStateNext $ \p ->
case p of
Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams sentExts) hs
Alert a ->
case a of
[(AlertLevel_Warning, UnrecognizedName)] ->
if clientUseServerNameIndication cparams
then return recvState
else throwAlert a
_ -> throwAlert a
_ -> fail ("unexepected type received. expecting handshake and got: " ++ show p)
throwAlert a = usingState_ ctx $ throwError $ Error_Protocol ("expecting server hello, got alert : " ++ show a, True, HandshakeFailure)
storePrivInfoClient :: Context
-> [CertificateType]
-> Credential
-> IO ()
storePrivInfoClient ctx cTypes (cc, privkey) = do
privalg <- storePrivInfo ctx cc privkey
unless (certificateCompatible privalg cTypes) $
throwCore $ Error_Protocol
( show privalg ++ " credential does not match allowed certificate types"
, True
, InternalError )
clientChain :: ClientParams -> Context -> IO (Maybe CertificateChain)
clientChain cparams ctx =
usingHState ctx getCertReqCBdata >>= \case
Nothing -> return Nothing
Just cbdata -> do
let callback = onCertificateRequest $ clientHooks cparams
chain <- liftIO $ callback cbdata `catchException`
throwMiscErrorOnException "certificate request callback failed"
case chain of
Nothing
-> return $ Just $ CertificateChain []
Just (CertificateChain [], _)
-> return $ Just $ CertificateChain []
Just cred@(cc, _)
-> do
let (cTypes, _, _) = cbdata
storePrivInfoClient ctx cTypes cred
return $ Just cc
getLocalHashSigAlg :: Context
-> [HashAndSignatureAlgorithm]
-> DigitalSignatureAlg
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg ctx cHashSigs keyAlg = do
(Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata
let want = (&&) <$> signatureCompatible keyAlg
<*> flip elem hashSigs
case find want cHashSigs of
Just best -> return best
Nothing -> throwCore $ Error_Protocol
( keyerr keyAlg
, True
, HandshakeFailure
)
where
keyerr alg = "no " ++ show alg ++ " hash algorithm in common with the server"
supportedCtypes :: [HashAndSignatureAlgorithm]
-> [CertificateType]
supportedCtypes hashAlgs =
nub $ foldr ctfilter [] hashAlgs
where
ctfilter x acc = case hashSigToCertType x of
Just cType | cType <= lastSupportedCertificateType
-> cType : acc
_ -> acc
clientSupportedCtypes :: Context
-> [CertificateType]
clientSupportedCtypes ctx =
supportedCtypes $ supportedHashSignatures $ ctxSupported ctx
sigAlgsToCertTypes :: Context
-> [HashAndSignatureAlgorithm]
-> [CertificateType]
sigAlgsToCertTypes ctx hashSigs =
filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx
sendClientData :: ClientParams -> Context -> IO ()
sendClientData cparams ctx = sendCertificate >> sendClientKeyXchg >> sendCertificateVerify
where
sendCertificate = do
usingHState ctx $ setClientCertSent False
clientChain cparams ctx >>= \case
Nothing -> return ()
Just cc@(CertificateChain certs) -> do
unless (null certs) $
usingHState ctx $ setClientCertSent True
sendPacket ctx $ Handshake [Certificates cc]
sendClientKeyXchg = do
cipher <- usingHState ctx getPendingCipher
ckx <- case cipherKeyExchange cipher of
CipherKeyExchange_RSA -> do
clientVersion <- usingHState ctx $ gets hstClientVersion
(xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46
let premaster = encodePreMasterSecret clientVersion prerand
masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
logKey ctx (MasterSecret masterSecret)
encryptedPreMaster <- do
e <- encryptRSA ctx premaster
let extra = if xver < TLS10
then B.empty
else encodeWord16 $ fromIntegral $ B.length e
return $ extra `B.append` e
return $ CKX_RSA encryptedPreMaster
CipherKeyExchange_DHE_RSA -> getCKX_DHE
CipherKeyExchange_DHE_DSS -> getCKX_DHE
CipherKeyExchange_ECDHE_RSA -> getCKX_ECDHE
CipherKeyExchange_ECDHE_ECDSA -> getCKX_ECDHE
_ -> throwCore $ Error_Protocol ("client key exchange unsupported type", True, HandshakeFailure)
sendPacket ctx $ Handshake [ClientKeyXchg ckx]
where getCKX_DHE = do
xver <- usingState_ ctx getVersion
serverParams <- usingHState ctx getServerDHParams
let params = serverDHParamsToParams serverParams
ffGroup = findFiniteFieldGroup params
srvpub = serverDHParamsToPublic serverParams
unless (maybe False (isSupportedGroup ctx) ffGroup) $ do
groupUsage <- onCustomFFDHEGroup (clientHooks cparams) params srvpub `catchException`
throwMiscErrorOnException "custom group callback failed"
case groupUsage of
GroupUsageInsecure -> throwCore $ Error_Protocol ("FFDHE group is not secure enough", True, InsufficientSecurity)
GroupUsageUnsupported reason -> throwCore $ Error_Protocol ("unsupported FFDHE group: " ++ reason, True, HandshakeFailure)
GroupUsageInvalidPublic -> throwCore $ Error_Protocol ("invalid server public key", True, HandshakeFailure)
GroupUsageValid -> return ()
(clientDHPub, premaster) <-
case ffGroup of
Nothing -> do
(clientDHPriv, clientDHPub) <- generateDHE ctx params
let premaster = dhGetShared params clientDHPriv srvpub
return (clientDHPub, premaster)
Just grp -> do
usingHState ctx $ setNegotiatedGroup grp
dhePair <- generateFFDHEShared ctx grp srvpub
case dhePair of
Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, HandshakeFailure)
Just pair -> return pair
masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
logKey ctx (MasterSecret masterSecret)
return $ CKX_DH clientDHPub
getCKX_ECDHE = do
ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams
checkSupportedGroup ctx grp
usingHState ctx $ setNegotiatedGroup grp
ecdhePair <- generateECDHEShared ctx srvpub
case ecdhePair of
Nothing -> throwCore $ Error_Protocol ("invalid server " ++ show grp ++ " public key", True, HandshakeFailure)
Just (clipub, premaster) -> do
xver <- usingState_ ctx getVersion
masterSecret <- usingHState ctx $ setMasterSecretFromPre xver ClientRole premaster
logKey ctx (MasterSecret masterSecret)
return $ CKX_ECDH $ encodeGroupPublic clipub
sendCertificateVerify = do
ver <- usingState_ ctx getVersion
certSent <- usingHState ctx getClientCertSent
when certSent $ do
keyAlg <- getLocalDigitalSignatureAlg ctx
mhashSig <- case ver of
TLS12 ->
let cHashSigs = supportedHashSignatures $ ctxSupported ctx
in Just <$> getLocalHashSigAlg ctx cHashSigs keyAlg
_ -> return Nothing
msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages
sigDig <- createCertificateVerify ctx ver keyAlg mhashSig msgs
sendPacket ctx $ Handshake [CertVerify sigDig]
processServerExtension :: ExtensionRaw -> TLSSt ()
processServerExtension (ExtensionRaw extID content)
| extID == extensionID_SecureRenegotiation = do
cv <- getVerifiedData ClientRole
sv <- getVerifiedData ServerRole
let bs = extensionEncode (SecureRenegotiation cv $ Just sv)
unless (bs `bytesEq` content) $ throwError $ Error_Protocol ("server secure renegotiation data not matching", True, HandshakeFailure)
| extID == extensionID_SupportedVersions = case extensionDecode MsgTServerHello content of
Just (SupportedVersionsServerHello ver) -> setVersion ver
_ -> return ()
| extID == extensionID_KeyShare = do
hrr <- getTLS13HRR
let msgt = if hrr then MsgTHelloRetryRequest else MsgTServerHello
setTLS13KeyShare $ extensionDecode msgt content
| extID == extensionID_PreSharedKey =
setTLS13PreSharedKey $ extensionDecode MsgTServerHello content
processServerExtension _ = return ()
throwMiscErrorOnException :: String -> SomeException -> IO a
throwMiscErrorOnException msg e =
throwCore $ Error_Misc $ msg ++ ": " ++ show e
onServerHello :: Context -> ClientParams -> [ExtensionID] -> Handshake -> IO (RecvState IO)
onServerHello ctx cparams sentExts (ServerHello rver serverRan serverSession cipher compression exts) = do
when (rver == SSL2) $ throwCore $ Error_Protocol ("ssl2 is not supported", True, ProtocolVersion)
cipherAlg <- case find ((==) cipher . cipherID) (supportedCiphers $ ctxSupported ctx) of
Nothing -> throwCore $ Error_Protocol ("server choose unknown cipher", True, HandshakeFailure)
Just alg -> return alg
compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of
Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, HandshakeFailure)
Just alg -> return alg
let checkExt (ExtensionRaw i _)
| i == extensionID_Cookie = False
| otherwise = i `notElem` sentExts
when (any checkExt exts) $
throwCore $ Error_Protocol ("spurious extensions received", True, UnsupportedExtension)
let resumingSession =
case clientWantSessionResume cparams of
Just (sessionId, sessionData) -> if serverSession == Session (Just sessionId) then Just sessionData else Nothing
Nothing -> Nothing
isHRR = isHelloRetryRequest serverRan
usingState_ ctx $ do
setTLS13HRR isHRR
setTLS13Cookie (guard isHRR >> extensionLookup extensionID_Cookie exts >>= extensionDecode MsgTServerHello)
setSession serverSession (isJust resumingSession)
setVersion rver
mapM_ processServerExtension exts
setALPN ctx exts
ver <- usingState_ ctx getVersion
when (isDowngraded ver (supportedVersions $ clientSupported cparams) serverRan) $
throwCore $ Error_Protocol ("version downgrade detected", True, IllegalParameter)
case find (== ver) (supportedVersions $ ctxSupported ctx) of
Nothing -> throwCore $ Error_Protocol ("server version " ++ show ver ++ " is not supported", True, ProtocolVersion)
Just _ -> return ()
if ver > TLS12 then do
ensureNullCompression compression
usingHState ctx $ setHelloParameters13 cipherAlg
return RecvStateDone
else do
usingHState ctx $ setServerHelloParameters rver serverRan cipherAlg compressAlg
case resumingSession of
Nothing -> return $ RecvStateHandshake (processCertificate cparams ctx)
Just sessionData -> do
let masterSecret = sessionSecret sessionData
usingHState ctx $ setMasterSecret rver ClientRole masterSecret
logKey ctx (MasterSecret masterSecret)
return $ RecvStateNext expectChangeCipher
onServerHello _ _ _ p = unexpected (show p) (Just "server hello")
processCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO)
processCertificate cparams ctx (Certificates certs) = do
ctxWithHooks ctx (`hookRecvCertificates` certs)
usage <- catchException (wrapCertificateChecks <$> checkCert) rejectOnException
case usage of
CertificateUsageAccept -> checkLeafCertificateKeyUsage
CertificateUsageReject reason -> certificateRejected reason
return $ RecvStateHandshake (processServerKeyExchange ctx)
where shared = clientShared cparams
checkCert = onServerCertificate (clientHooks cparams) (sharedCAStore shared)
(sharedValidationCache shared)
(clientServerIdentification cparams)
certs
checkLeafCertificateKeyUsage = do
cipher <- usingHState ctx getPendingCipher
case requiredCertKeyUsage cipher of
[] -> return ()
flags -> verifyLeafKeyUsage flags certs
processCertificate _ ctx p = processServerKeyExchange ctx p
expectChangeCipher :: Packet -> IO (RecvState IO)
expectChangeCipher ChangeCipherSpec = return $ RecvStateHandshake expectFinish
expectChangeCipher p = unexpected (show p) (Just "change cipher")
expectFinish :: Handshake -> IO (RecvState IO)
expectFinish (Finished _) = return RecvStateDone
expectFinish p = unexpected (show p) (Just "Handshake Finished")
processServerKeyExchange :: Context -> Handshake -> IO (RecvState IO)
processServerKeyExchange ctx (ServerKeyXchg origSkx) = do
cipher <- usingHState ctx getPendingCipher
processWithCipher cipher origSkx
return $ RecvStateHandshake (processCertificateRequest ctx)
where processWithCipher cipher skx =
case (cipherKeyExchange cipher, skx) of
(CipherKeyExchange_DHE_RSA, SKX_DHE_RSA dhparams signature) ->
doDHESignature dhparams signature KX_RSA
(CipherKeyExchange_DHE_DSS, SKX_DHE_DSS dhparams signature) ->
doDHESignature dhparams signature KX_DSS
(CipherKeyExchange_ECDHE_RSA, SKX_ECDHE_RSA ecdhparams signature) ->
doECDHESignature ecdhparams signature KX_RSA
(CipherKeyExchange_ECDHE_ECDSA, SKX_ECDHE_ECDSA ecdhparams signature) ->
doECDHESignature ecdhparams signature KX_ECDSA
(cke, SKX_Unparsed bytes) -> do
ver <- usingState_ ctx getVersion
case decodeReallyServerKeyXchgAlgorithmData ver cke bytes of
Left _ -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show cke, True, HandshakeFailure)
Right realSkx -> processWithCipher cipher realSkx
(c,_) -> throwCore $ Error_Protocol ("unknown server key exchange received, expecting: " ++ show c, True, HandshakeFailure)
doDHESignature dhparams signature kxsAlg = do
signatureType <- getSignatureType kxsAlg
verified <- digitallySignDHParamsVerify ctx dhparams signatureType signature
unless verified $ decryptError ("bad " ++ show signatureType ++ " signature for dhparams " ++ show dhparams)
usingHState ctx $ setServerDHParams dhparams
doECDHESignature ecdhparams signature kxsAlg = do
signatureType <- getSignatureType kxsAlg
verified <- digitallySignECDHParamsVerify ctx ecdhparams signatureType signature
unless verified $ decryptError ("bad " ++ show signatureType ++ " signature for ecdhparams")
usingHState ctx $ setServerECDHParams ecdhparams
getSignatureType kxsAlg = do
publicKey <- usingHState ctx getRemotePublicKey
case (kxsAlg, publicKey) of
(KX_RSA, PubKeyRSA _) -> return DS_RSA
(KX_DSS, PubKeyDSA _) -> return DS_DSS
(KX_ECDSA, PubKeyEC _) -> return DS_ECDSA
(KX_ECDSA, PubKeyEd25519 _) -> return DS_Ed25519
(KX_ECDSA, PubKeyEd448 _) -> return DS_Ed448
_ -> throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure)
processServerKeyExchange ctx p = processCertificateRequest ctx p
processCertificateRequest :: Context -> Handshake -> IO (RecvState IO)
processCertificateRequest ctx (CertRequest cTypesSent sigAlgs dNames) = do
ver <- usingState_ ctx getVersion
when (ver == TLS12 && isNothing sigAlgs) $
throwCore $ Error_Protocol
( "missing TLS 1.2 certificate request signature algorithms"
, True
, InternalError
)
let cTypes = filter (<= lastSupportedCertificateType) cTypesSent
usingHState ctx $ setCertReqCBdata $ Just (cTypes, sigAlgs, dNames)
return $ RecvStateHandshake (processServerHelloDone ctx)
processCertificateRequest ctx p = do
usingHState ctx $ setCertReqCBdata Nothing
processServerHelloDone ctx p
processServerHelloDone :: Context -> Handshake -> IO (RecvState m)
processServerHelloDone _ ServerHelloDone = return RecvStateDone
processServerHelloDone _ p = unexpected (show p) (Just "server hello data")
requiredCertKeyUsage :: Cipher -> [ExtKeyUsageFlag]
requiredCertKeyUsage cipher =
case cipherKeyExchange cipher of
CipherKeyExchange_RSA -> rsaCompatibility
CipherKeyExchange_DH_Anon -> []
CipherKeyExchange_DHE_RSA -> rsaCompatibility
CipherKeyExchange_ECDHE_RSA -> rsaCompatibility
CipherKeyExchange_DHE_DSS -> [ KeyUsage_digitalSignature ]
CipherKeyExchange_DH_DSS -> [ KeyUsage_keyAgreement ]
CipherKeyExchange_DH_RSA -> rsaCompatibility
CipherKeyExchange_ECDH_ECDSA -> [ KeyUsage_keyAgreement ]
CipherKeyExchange_ECDH_RSA -> rsaCompatibility
CipherKeyExchange_ECDHE_ECDSA -> [ KeyUsage_digitalSignature ]
CipherKeyExchange_TLS13 -> [ KeyUsage_digitalSignature ]
where rsaCompatibility = [ KeyUsage_digitalSignature
, KeyUsage_keyEncipherment
, KeyUsage_keyAgreement
]
handshakeClient13 :: ClientParams -> Context -> IO ()
handshakeClient13 _cparams ctx = do
usedCipher <- usingHState ctx getPendingCipher
let usedHash = cipherHash usedCipher
handshakeClient13' _cparams ctx usedCipher usedHash
handshakeClient13' :: ClientParams -> Context -> Cipher -> Hash -> IO ()
handshakeClient13' cparams ctx usedCipher usedHash = do
(resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret) <- switchToHandshakeSecret
rtt0accepted <- runRecvHandshake13 $ do
accepted <- recvHandshake13preUpdate ctx expectEncryptedExtensions
unless resuming $ recvHandshake13preUpdate ctx expectCertRequest
recvFinished serverHandshakeTrafficSecret
return accepted
hChSf <- transcriptHash ctx
when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13])
setTxState ctx usedHash usedCipher clientHandshakeTrafficSecret
chain <- clientChain cparams ctx
runPacketFlight ctx $ do
case chain of
Nothing -> return ()
Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc
rawFinished <- makeFinished ctx usedHash clientHandshakeTrafficSecret
loadPacket13 ctx $ Handshake13 [rawFinished]
masterSecret <- switchToTrafficSecret handshakeSecret hChSf
setResumptionSecret masterSecret
setEstablished ctx Established
where
hashSize = hashDigestSize usedHash
zero = B.replicate hashSize 0
sendClientData13 chain (Just token) = do
let (CertificateChain certs) = chain
certExts = replicate (length certs) []
cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx
loadPacket13 ctx $ Handshake13 [Certificate13 token chain certExts]
case certs of
[] -> return ()
_ -> do
hChSc <- transcriptHash ctx
keyAlg <- getLocalDigitalSignatureAlg ctx
sigAlg <- liftIO $ getLocalHashSigAlg ctx cHashSigs keyAlg
vfy <- makeCertVerify ctx keyAlg sigAlg hChSc
loadPacket13 ctx $ Handshake13 [vfy]
sendClientData13 _ _ =
throwCore $ Error_Protocol
( "missing TLS 1.3 certificate request context token"
, True
, InternalError
)
switchToHandshakeSecret = do
ecdhe <- calcSharedKey
(earlySecret, resuming) <- makeEarlySecret
let handshakeSecret = hkdfExtract usedHash (deriveSecret usedHash earlySecret "derived" (hash usedHash "")) ecdhe
hChSh <- transcriptHash ctx
let clientHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "c hs traffic" hChSh
serverHandshakeTrafficSecret = deriveSecret usedHash handshakeSecret "s hs traffic" hChSh
logKey ctx (ServerHandshakeTrafficSecret serverHandshakeTrafficSecret)
logKey ctx (ClientHandshakeTrafficSecret clientHandshakeTrafficSecret)
setRxState ctx usedHash usedCipher serverHandshakeTrafficSecret
return (resuming, handshakeSecret, clientHandshakeTrafficSecret, serverHandshakeTrafficSecret)
switchToTrafficSecret handshakeSecret hChSf = do
let masterSecret = hkdfExtract usedHash (deriveSecret usedHash handshakeSecret "derived" (hash usedHash "")) zero
let clientApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "c ap traffic" hChSf
serverApplicationTrafficSecret0 = deriveSecret usedHash masterSecret "s ap traffic" hChSf
exporterMasterSecret = deriveSecret usedHash masterSecret "exp master" hChSf
usingState_ ctx $ setExporterMasterSecret exporterMasterSecret
logKey ctx (ServerTrafficSecret0 serverApplicationTrafficSecret0)
logKey ctx (ClientTrafficSecret0 clientApplicationTrafficSecret0)
setTxState ctx usedHash usedCipher clientApplicationTrafficSecret0
setRxState ctx usedHash usedCipher serverApplicationTrafficSecret0
return masterSecret
calcSharedKey = do
serverKeyShare <- do
mks <- usingState_ ctx getTLS13KeyShare
case mks of
Just (KeyShareServerHello ks) -> return ks
Just _ -> error "calcSharedKey: invalid KeyShare value"
Nothing -> throwCore $ Error_Protocol ("key exchange not implemented, expected key_share extension", True, HandshakeFailure)
let grp = keyShareEntryGroup serverKeyShare
checkSupportedGroup ctx grp
usingHState ctx $ setNegotiatedGroup grp
usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare
makeEarlySecret = do
secret <- usingHState ctx getTLS13Secret
case secret of
EarlySecret sec -> do
mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey
case mSelectedIdentity of
Nothing ->
return (hkdfExtract usedHash zero zero, False)
Just (PreSharedKeyServerHello 0) -> do
usingHState ctx $ setTLS13HandshakeMode PreSharedKey
return (sec, True)
Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter)
_ -> return (hkdfExtract usedHash zero zero, False)
expectEncryptedExtensions (EncryptedExtensions13 eexts) = do
liftIO $ setALPN ctx eexts
st <- usingHState ctx getTLS13RTT0Status
if st == RTT0Sent then
case extensionLookup extensionID_EarlyData eexts of
Just _ -> do
usingHState ctx $ setTLS13HandshakeMode RTT0
usingHState ctx $ setTLS13RTT0Status RTT0Accepted
return True
Nothing -> do
usingHState ctx $ setTLS13HandshakeMode RTT0
usingHState ctx $ setTLS13RTT0Status RTT0Rejected
return False
else
return False
expectEncryptedExtensions p = unexpected (show p) (Just "encrypted extensions")
expectCertRequest (CertRequest13 token exts) = do
let hsextID = extensionID_SignatureAlgorithms
dNames <- canames
hsAlgs <- extalgs hsextID unsighash
cTypes <- case hsAlgs of
Just as ->
let validAs = filter isHashSignatureValid13 as
in return $ sigAlgsToCertTypes ctx validAs
Nothing -> throwCore $ Error_Protocol
( "invalid certificate request"
, True
, HandshakeFailure )
usingHState ctx $ do
setCertReqToken $ Just token
setCertReqCBdata $ Just (cTypes, hsAlgs, dNames)
recvHandshake13preUpdate ctx expectCertAndVerify
where
canames = case extensionLookup
extensionID_CertificateAuthorities exts of
Nothing -> return []
Just ext -> case extensionDecode MsgTCertificateRequest ext of
Just (CertificateAuthorities names) -> return names
_ -> throwCore $ Error_Protocol
( "invalid certificate request"
, True
, HandshakeFailure )
extalgs extID decons = case extensionLookup extID exts of
Nothing -> return Nothing
Just ext -> case extensionDecode MsgTCertificateRequest ext of
Just e
-> return $ decons e
_ -> throwCore $ Error_Protocol
( "invalid certificate request"
, True
, HandshakeFailure )
unsighash :: SignatureAlgorithms
-> Maybe [HashAndSignatureAlgorithm]
unsighash (SignatureAlgorithms a) = Just a
expectCertRequest other = do
usingHState ctx $ do
setCertReqToken Nothing
setCertReqCBdata Nothing
expectCertAndVerify other
expectCertAndVerify (Certificate13 _ cc@(CertificateChain certChain) _) = do
_ <- liftIO $ processCertificate cparams ctx (Certificates cc)
pubkey <- case certChain of
[] -> throwCore $ Error_Protocol ("server certificate missing", True, HandshakeFailure)
c:_ -> return $ certPubKey $ getCertificate c
usingHState ctx $ setPublicKey pubkey
hChSc <- transcriptHash ctx
recvHandshake13preUpdate ctx $ expectCertVerify pubkey hChSc
expectCertAndVerify p = unexpected (show p) (Just "server certificate")
expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do
let keyAlg = fromJust "fromPubKey" (fromPubKey pubkey)
ok <- checkCertVerify ctx keyAlg sigAlg sig hChSc
unless ok $ decryptError "cannot verify CertificateVerify"
expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify")
recvFinished serverHandshakeTrafficSecret = do
hChSv <- transcriptHash ctx
let verifyData' = makeVerifyData usedHash serverHandshakeTrafficSecret hChSv
recvHandshake13preUpdate ctx $ expectFinished verifyData'
expectFinished verifyData' (Finished13 verifyData) =
when (verifyData' /= verifyData) $ decryptError "cannot verify finished"
expectFinished _ p = unexpected (show p) (Just "server finished")
setResumptionSecret masterSecret = do
hChCf <- transcriptHash ctx
let resumptionMasterSecret = deriveSecret usedHash masterSecret "res master" hChCf
usingHState ctx $ setTLS13Secret $ ResuptionSecret resumptionMasterSecret
setALPN :: Context -> [ExtensionRaw] -> IO ()
setALPN ctx exts = case extensionLookup extensionID_ApplicationLayerProtocolNegotiation exts >>= extensionDecode MsgTServerHello of
Just (ApplicationLayerProtocolNegotiation [proto]) -> usingState_ ctx $ do
mprotos <- getClientALPNSuggest
case mprotos of
Just protos -> when (proto `elem` protos) $ do
setExtensionALPN True
setNegotiatedProtocol proto
_ -> return ()
_ -> return ()