{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.TLS.Handshake.Client
( handshakeClient
, handshakeClientWith
, postHandshakeAuthClientWith
) 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, bracket)
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.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, Session, Version) -> IO ()
handshakeClient' cparams ctx groups mparams = do
updateMeasure ctx incrementNbHandshakes
(crand, clientSession) <- generateClientHelloParams
(rtt0, sentExtensions) <- sendClientHello clientSession crand
recvServerHello clientSession sentExtensions
ver <- usingState_ ctx getVersion
unless (maybe True (\(_, _, v) -> v == ver) mparams) $
throwCore $ Error_Protocol ("version changed after hello retry", True, IllegalParameter)
hrr <- usingState_ ctx getTLS13HRR
if ver == TLS13 then
if hrr then case drop 1 groups of
[] -> throwCore $ Error_Protocol ("group is exhausted in the client side", True, IllegalParameter)
groups' -> do
when (isJust mparams) $
throwCore $ Error_Protocol ("server sent too many hello retries", True, UnexpectedMessage)
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 }
runPacketFlight ctx $ sendChangeCipherSpec13 ctx
handshakeClient' cparams' ctx [selectedGroup] (Just (crand, clientSession, ver))
| 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 groupToSend
else do
when rtt0 $
throwCore $ Error_Protocol ("server denied TLS 1.3 when connecting with early data", True, HandshakeFailure)
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
groupToSend = listToMaybe groups
getExtensions pskInfo rtt0 = sequence
[ sniExtension
, secureReneg
, alpnExtension
, groupExtension
, ecPointExtension
, signatureAlgExtension
, versionExtension
, earlyDataExtension rtt0
, keyshareExtension
, pskExchangeModeExtension
, cookieExtension
, postHandshakeAuthExtension
, preSharedKeyExtension pskInfo
]
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 (>= TLS10) $ supportedVersions $ ctxSupported ctx
return $ Just $ toExtensionRaw $ SupportedVersionsClientHello vers
| otherwise = return Nothing
keyshareExtension
| tls13 = case groupToSend of
Nothing -> return Nothing
Just 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)
getPskInfo =
case sessionAndCipherToResume13 of
Nothing -> return Nothing
Just (sid, sdata, sCipher) -> do
let tinfo = fromJust "sessionTicketInfo" $ sessionTicketInfo sdata
age <- getAge tinfo
return $ if isAgeValid age tinfo
then Just (sid, sdata, makeCipherChoice TLS13 sCipher, ageToObfuscatedAge age tinfo)
else Nothing
preSharedKeyExtension pskInfo =
case pskInfo of
Nothing -> return Nothing
Just (sid, _, choice, obfAge) ->
let zero = cZero choice
identity = PskIdentity sid obfAge
offeredPsks = PreSharedKeyClientHello [identity] [zero]
in return $ Just $ toExtensionRaw offeredPsks
pskExchangeModeExtension
| tls13 = return $ Just $ toExtensionRaw $ PskKeyExchangeModes [PSK_DHE_KE]
| otherwise = return Nothing
earlyDataExtension rtt0
| rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)
| otherwise = return Nothing
cookieExtension = do
mcookie <- usingState_ ctx getTLS13Cookie
case mcookie of
Nothing -> return Nothing
Just cookie -> return $ Just $ toExtensionRaw cookie
postHandshakeAuthExtension
| tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth
| otherwise = return Nothing
adjustExtentions pskInfo exts ch =
case pskInfo of
Nothing -> return exts
Just (_, sdata, choice, _) -> do
let psk = sessionSecret sdata
earlySecret = initEarlySecret choice (Just psk)
usingHState ctx $ setTLS13EarlySecret earlySecret
let ech = encodeHandshake ch
h = cHash choice
siz = hashDigestSize h
binder <- makePSKBinder ctx earlySecret h (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'
generateClientHelloParams =
case mparams of
Just (crand, clientSession, _) -> return (crand, clientSession)
Nothing -> do
crand <- clientRandom ctx
let paramSession = case clientWantSessionResume cparams of
Nothing -> Session Nothing
Just (sid, sdata)
| sessionVersion sdata >= TLS13 -> Session Nothing
| otherwise -> Session (Just sid)
if tls13 && paramSession == Session Nothing
then do
randomSession <- newSession ctx
return (crand, randomSession)
else return (crand, paramSession)
sendClientHello clientSession crand = do
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
pskInfo <- getPskInfo
let rtt0info = pskInfo >>= get0RTTinfo
rtt0 = isJust rtt0info
extensions0 <- catMaybes <$> getExtensions pskInfo rtt0
extensions <- adjustExtentions pskInfo extensions0 $ mkClientHello extensions0
sendPacket ctx $ Handshake [mkClientHello extensions]
mapM_ send0RTT rtt0info
return (rtt0, map (\(ExtensionRaw i _) -> i) extensions)
get0RTTinfo (_, sdata, choice, _) = do
earlyData <- clientEarlyData cparams
guard (B.length earlyData <= sessionMaxEarlyDataSize sdata)
return (choice, earlyData)
send0RTT (choice, earlyData) = do
let usedCipher = cCipher choice
usedHash = cHash choice
Just earlySecret <- usingHState ctx getTLS13EarlySecret
earlyKey <- calculateEarlySecret ctx choice (Right earlySecret) False
let ClientTrafficSecret clientEarlySecret = pairClient earlyKey
runPacketFlight ctx $ sendChangeCipherSpec13 ctx
setTxState ctx usedHash usedCipher clientEarlySecret
mapChunks_ 16384 (sendPacket13 ctx . AppData13) earlyData
usingHState ctx $ setTLS13RTT0Status RTT0Sent
recvServerHello clientSession sentExts = runRecvState ctx recvState
where recvState = RecvStateNext $ \p ->
case p of
Handshake hs -> onRecvStateHandshake ctx (RecvStateHandshake $ onServerHello ctx cparams clientSession sentExts) hs
Alert a ->
case a of
[(AlertLevel_Warning, UnrecognizedName)] ->
if clientUseServerNameIndication cparams
then return recvState
else throwAlert a
_ -> throwAlert a
_ -> unexpected (show p) (Just "handshake")
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
pubkey <- storePrivInfo ctx cc privkey
unless (certificateCompatible pubkey cTypes) $
throwCore $ Error_Protocol
( pubkeyType pubkey ++ " 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]
-> PubKey
-> IO HashAndSignatureAlgorithm
getLocalHashSigAlg ctx cHashSigs pubKey = do
(Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata
let want = (&&) <$> signatureCompatible pubKey
<*> flip elem hashSigs
case find want cHashSigs of
Just best -> return best
Nothing -> throwCore $ Error_Protocol
( keyerr pubKey
, True
, HandshakeFailure
)
where
keyerr k = "no " ++ pubkeyType k ++ " 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, IllegalParameter)
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, IllegalParameter)
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, IllegalParameter)
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
pubKey <- getLocalPublicKey ctx
mhashSig <- case ver of
TLS12 ->
let cHashSigs = supportedHashSignatures $ ctxSupported ctx
in Just <$> getLocalHashSigAlg ctx cHashSigs pubKey
_ -> return Nothing
msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages
sigDig <- createCertificateVerify ctx ver pubKey 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 -> Session -> [ExtensionID] -> Handshake -> IO (RecvState IO)
onServerHello ctx cparams clientSession 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, IllegalParameter)
Just alg -> return alg
compressAlg <- case find ((==) compression . compressionID) (supportedCompressions $ ctxSupported ctx) of
Nothing -> throwCore $ Error_Protocol ("server choose unknown compression", True, IllegalParameter)
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
when (serverSession /= clientSession) $
throwCore $ Error_Protocol ("received mismatched legacy session", True, IllegalParameter)
established <- ctxEstablished ctx
eof <- ctxEOF ctx
when (established == Established && not eof) $
throwCore $ Error_Protocol ("renegotiation to TLS 1.3 or later is not allowed", True, ProtocolVersion)
ensureNullCompression compression
failOnEitherError $ 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
when (isNullCertificateChain certs) $
throwCore $ Error_Protocol ("server certificate missing", True, DecodeError)
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
publicKey <- getSignaturePublicKey kxsAlg
verified <- digitallySignDHParamsVerify ctx dhparams publicKey signature
unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for dhparams " ++ show dhparams)
usingHState ctx $ setServerDHParams dhparams
doECDHESignature ecdhparams signature kxsAlg = do
publicKey <- getSignaturePublicKey kxsAlg
verified <- digitallySignECDHParamsVerify ctx ecdhparams publicKey signature
unless verified $ decryptError ("bad " ++ pubkeyType publicKey ++ " signature for ecdhparams")
usingHState ctx $ setServerECDHParams ecdhparams
getSignaturePublicKey kxsAlg = do
publicKey <- usingHState ctx getRemotePublicKey
unless (isKeyExchangeSignatureKey kxsAlg publicKey) $
throwCore $ Error_Protocol ("server public key algorithm is incompatible with " ++ show kxsAlg, True, HandshakeFailure)
return publicKey
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 -> Maybe Group -> IO ()
handshakeClient13 cparams ctx groupSent = do
choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher
handshakeClient13' cparams ctx groupSent choice
handshakeClient13' :: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO ()
handshakeClient13' cparams ctx groupSent choice = do
(_, hkey, resuming) <- switchToHandshakeSecret
let handshakeSecret = triBase hkey
ClientTrafficSecret clientHandshakeSecret = triClient hkey
ServerTrafficSecret serverHandshakeSecret = triServer hkey
rtt0accepted <- runRecvHandshake13 $ do
accepted <- recvHandshake13 ctx expectEncryptedExtensions
unless resuming $ recvHandshake13 ctx expectCertRequest
recvHandshake13hash ctx $ expectFinished serverHandshakeSecret
return accepted
hChSf <- transcriptHash ctx
runPacketFlight ctx $ sendChangeCipherSpec13 ctx
when rtt0accepted $ sendPacket13 ctx (Handshake13 [EndOfEarlyData13])
setTxState ctx usedHash usedCipher clientHandshakeSecret
sendClientFlight13 cparams ctx usedHash clientHandshakeSecret
appKey <- switchToApplicationSecret handshakeSecret hChSf
let applicationSecret = triBase appKey
setResumptionSecret applicationSecret
handshakeTerminate13 ctx
where
usedCipher = cCipher choice
usedHash = cHash choice
hashSize = hashDigestSize usedHash
switchToHandshakeSecret = do
ensureRecvComplete ctx
ecdhe <- calcSharedKey
(earlySecret, resuming) <- makeEarlySecret
handKey <- calculateHandshakeSecret ctx choice earlySecret ecdhe
let ServerTrafficSecret serverHandshakeSecret = triServer handKey
setRxState ctx usedHash usedCipher serverHandshakeSecret
return (usedCipher, handKey, resuming)
switchToApplicationSecret handshakeSecret hChSf = do
ensureRecvComplete ctx
appKey <- calculateApplicationSecret ctx choice handshakeSecret hChSf
let ServerTrafficSecret serverApplicationSecret0 = triServer appKey
let ClientTrafficSecret clientApplicationSecret0 = triClient appKey
setTxState ctx usedHash usedCipher clientApplicationSecret0
setRxState ctx usedHash usedCipher serverApplicationSecret0
return appKey
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
unless (groupSent == Just grp) $
throwCore $ Error_Protocol ("received incompatible group for (EC)DHE", True, IllegalParameter)
usingHState ctx $ setNegotiatedGroup grp
usingHState ctx getGroupPrivate >>= fromServerKeyShare serverKeyShare
makeEarlySecret = do
mEarlySecretPSK <- usingHState ctx getTLS13EarlySecret
case mEarlySecretPSK of
Nothing -> return (initEarlySecret choice Nothing, False)
Just earlySecretPSK@(BaseSecret sec) -> do
mSelectedIdentity <- usingState_ ctx getTLS13PreSharedKey
case mSelectedIdentity of
Nothing ->
return (initEarlySecret choice Nothing, False)
Just (PreSharedKeyServerHello 0) -> do
unless (B.length sec == hashSize) $
throwCore $ Error_Protocol ("selected cipher is incompatible with selected PSK", True, IllegalParameter)
usingHState ctx $ setTLS13HandshakeMode PreSharedKey
return (earlySecretPSK, True)
Just _ -> throwCore $ Error_Protocol ("selected identity out of range", True, IllegalParameter)
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
processCertRequest13 ctx token exts
recvHandshake13 ctx expectCertAndVerify
expectCertRequest other = do
usingHState ctx $ do
setCertReqToken Nothing
setCertReqCBdata Nothing
expectCertAndVerify other
expectCertAndVerify (Certificate13 _ cc _) = do
_ <- liftIO $ processCertificate cparams ctx (Certificates cc)
let pubkey = certPubKey $ getCertificate $ getCertificateChainLeaf cc
checkDigitalSignatureKey pubkey
usingHState ctx $ setPublicKey pubkey
recvHandshake13hash ctx $ expectCertVerify pubkey
expectCertAndVerify p = unexpected (show p) (Just "server certificate")
expectCertVerify pubkey hChSc (CertVerify13 sigAlg sig) = do
ok <- checkCertVerify ctx pubkey sigAlg sig hChSc
unless ok $ decryptError "cannot verify CertificateVerify"
expectCertVerify _ _ p = unexpected (show p) (Just "certificate verify")
expectFinished baseKey hashValue (Finished13 verifyData) =
checkFinished usedHash baseKey hashValue verifyData
expectFinished _ _ p = unexpected (show p) (Just "server finished")
setResumptionSecret applicationSecret = do
resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret
usingHState ctx $ setTLS13ResumptionSecret resumptionSecret
processCertRequest13 :: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m ()
processCertRequest13 ctx 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)
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
sendClientFlight13 :: ClientParams -> Context -> Hash -> ByteString -> IO ()
sendClientFlight13 cparams ctx usedHash baseKey = do
chain <- clientChain cparams ctx
runPacketFlight ctx $ do
case chain of
Nothing -> return ()
Just cc -> usingHState ctx getCertReqToken >>= sendClientData13 cc
rawFinished <- makeFinished ctx usedHash baseKey
loadPacket13 ctx $ Handshake13 [rawFinished]
where
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
pubKey <- getLocalPublicKey ctx
sigAlg <- liftIO $ getLocalHashSigAlg ctx cHashSigs pubKey
vfy <- makeCertVerify ctx pubKey sigAlg hChSc
loadPacket13 ctx $ Handshake13 [vfy]
sendClientData13 _ _ =
throwCore $ Error_Protocol
( "missing TLS 1.3 certificate request context token"
, True
, InternalError
)
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 ()
postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO ()
postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) =
bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do
processHandshake13 ctx h
processCertRequest13 ctx certReqCtx exts
(usedHash, _, applicationSecretN) <- getTxState ctx
sendClientFlight13 cparams ctx usedHash applicationSecretN
postHandshakeAuthClientWith _ _ _ =
throwCore $ Error_Protocol ("unexpected handshake message received in postHandshakeAuthClientWith", True, UnexpectedMessage)