Skip to content

Commit

Permalink
Merge branch 'refactoring'
Browse files Browse the repository at this point in the history
  • Loading branch information
@kazu-yamamoto
kazu-yamamoto committed Dec 8, 2023
2 parents 303f2d7 + a67b717 commit 644ef3c
Show file tree
Hide file tree
Showing 5 changed files with 152 additions and 126 deletions.
258 changes: 142 additions & 116 deletions core/Network/TLS/Handshake/Client.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,8 @@ import Network.TLS.Util (bytesEq, catchException, mapChunks_)
import Network.TLS.Wire
import Network.TLS.X509

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

handshakeClientWith :: ClientParams -> Context -> Handshake -> IO ()
handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx
handshakeClientWith _ _ _ =
Expand All @@ -61,13 +63,13 @@ handshakeClientWith _ _ _ =
-- values intertwined with response from the server.
handshakeClient :: ClientParams -> Context -> IO ()
handshakeClient cparams ctx = do
let groups = case clientWantSessionResume cparams of
let groupsSupported = supportedGroups (ctxSupported ctx)
groups = case clientWantSessionResume cparams of
Nothing -> groupsSupported
Just (_, sdata) -> case sessionGroup sdata of
Nothing -> [] -- TLS 1.2 or earlier
Just grp -> grp : filter (/= grp) groupsSupported
groupsSupported = supportedGroups (ctxSupported ctx)
handshakeClient' cparams ctx groups Nothing
firstFlight cparams ctx groups Nothing

-- https://tools.ietf.org/html/rfc8446#section-4.1.2 says:
-- "The client will also send a
Expand All @@ -76,17 +78,17 @@ handshakeClient cparams ctx = do
-- ClientHello without modification, except as follows:"
--
-- So, the ClientRandom in the first client hello is necessary.
handshakeClient'
firstFlight
:: ClientParams
-> Context
-> [Group]
-> Maybe (ClientRandom, Session, Version)
-> IO ()
handshakeClient' cparams ctx groups mparams = do
firstFlight cparams ctx groups mparams = do
updateMeasure ctx incrementNbHandshakes
(crand, clientSession) <- generateClientHelloParams
(rtt0, sentExtensions) <- sendClientHello clientSession crand
recvServerHello clientSession sentExtensions
(crand, clientSession) <- generateClientHelloParams mparams
(rtt0, sentExtensions) <- sendClientHello cparams ctx groups clientSession crand
recvServerHello ctx cparams clientSession sentExtensions
ver <- usingState_ ctx getVersion
unless (maybe True (\(_, _, v) -> v == ver) mparams) $
throwCore $
Expand All @@ -98,47 +100,98 @@ handshakeClient' cparams ctx groups mparams = do
if ver == TLS13
then
if hrr
then case drop 1 groups of
[] ->
throwCore $
Error_Protocol "group is exhausted in the client side" IllegalParameter
groups' -> do
when (isJust mparams) $
throwCore $
Error_Protocol "server sent too many hello retries" 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" IllegalParameter
Just _ -> error "handshakeClient': invalid KeyShare value"
Nothing ->
throwCore $
Error_Protocol
"key exchange not implemented in HRR, expected key_share extension"
HandshakeFailure
else handshakeClient13 cparams ctx groupToSend
then helloRetry ver crand clientSession $ drop 1 groups
else secondFlight13 cparams ctx groupToSend
else do
when rtt0 $
throwCore $
Error_Protocol
"server denied TLS 1.3 when connecting with early data"
HandshakeFailure
sessionResuming <- usingState_ ctx isSessionResuming
if sessionResuming
then sendChangeCipherAndFinish ctx ClientRole
else do
sendClientData cparams ctx
sendChangeCipherAndFinish ctx ClientRole
recvChangeCipherAndFinish ctx
handshakeTerminate ctx
secondFlight12 cparams ctx
where
highestVer = maximum $ supportedVersions $ ctxSupported ctx
tls13 = highestVer >= TLS13
ems = supportedExtendedMasterSec $ ctxSupported ctx
groupToSend = listToMaybe groups

-- Client random and session in the second client hello for
-- retry must be the same as the first one.
generateClientHelloParams (Just (crand, clientSession, _)) =
return (crand, clientSession)
generateClientHelloParams Nothing = do
crand <- clientRandom ctx
let paramSession = case clientWantSessionResume cparams of
Nothing -> Session Nothing
Just (sid, sdata)
| sessionVersion sdata >= TLS13 -> Session Nothing
| ems == RequireEMS && noSessionEMS -> Session Nothing
| otherwise -> Session (Just sid)
where
noSessionEMS = SessionEMS `notElem` sessionFlags sdata
-- In compatibility mode a client not offering a pre-TLS 1.3
-- session MUST generate a new 32-byte value
if tls13 && paramSession == Session Nothing && not (ctxQUICMode ctx)
then do
randomSession <- newSession ctx
return (crand, randomSession)
else return (crand, paramSession)

helloRetry _ _ _ [] =
throwCore $
Error_Protocol "group is exhausted in the client side" IllegalParameter
helloRetry ver crand clientSession groups' = do
when (isJust mparams) $
throwCore $
Error_Protocol "server sent too many hello retries" 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
firstFlight cparams' ctx [selectedGroup] (Just (crand, clientSession, ver))
| otherwise ->
throwCore $
Error_Protocol "server-selected group is not supported" IllegalParameter
Just _ -> error "firstFlight: invalid KeyShare value"
Nothing ->
throwCore $
Error_Protocol
"key exchange not implemented in HRR, expected key_share extension"
HandshakeFailure

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

sendClientHello
:: ClientParams
-> Context
-> [Group]
-> Session
-> ClientRandom
-> IO (Bool, [ExtensionID])
sendClientHello cparams ctx groups 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
let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0
extensions <- adjustExtentions pskInfo extensions1 $ mkClientHello extensions1
sendPacket ctx $ Handshake [mkClientHello extensions]
mEarlySecInfo <- case rtt0info of
Nothing -> return Nothing
Just info -> Just <$> send0RTT info
unless hrr $ contextSync ctx $ SendClientHello mEarlySecInfo
return (rtt0, map (\(ExtensionRaw i _) -> i) extensions)
where
ciphers = supportedCiphers $ ctxSupported ctx
compressions = supportedCompressions $ ctxSupported ctx
Expand Down Expand Up @@ -304,50 +357,6 @@ handshakeClient' cparams ctx groups mparams = do
withBinders = replacePSKBinder withoutBinders binder
return exts'

generateClientHelloParams =
case mparams of
-- Client random and session in the second client hello for
-- retry must be the same as the first one.
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
| ems == RequireEMS && noSessionEMS -> Session Nothing
| otherwise -> Session (Just sid)
where
noSessionEMS = SessionEMS `notElem` sessionFlags sdata
-- In compatibility mode a client not offering a pre-TLS 1.3
-- session MUST generate a new 32-byte value
if tls13 && paramSession == Session Nothing && not (ctxQUICMode ctx)
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
let extensions1 = sharedHelloExtensions (clientShared cparams) ++ extensions0
extensions <- adjustExtentions pskInfo extensions1 $ mkClientHello extensions1
sendPacket ctx $ Handshake [mkClientHello extensions]
mEarlySecInfo <- case rtt0info of
Nothing -> return Nothing
Just info -> Just <$> send0RTT info
unless hrr $ contextSync ctx $ SendClientHello mEarlySecInfo
return (rtt0, map (\(ExtensionRaw i _) -> i) extensions)

get0RTTinfo (_, sdata, choice, _) = do
earlyData <- clientEarlyData cparams
guard (B.length earlyData <= sessionMaxEarlyDataSize sdata)
Expand All @@ -370,28 +379,41 @@ handshakeClient' cparams ctx groups mparams = do
usingHState ctx $ setTLS13RTT0Status RTT0Sent
return $ EarlySecretInfo usedCipher clientEarlySecret

recvServerHello clientSession sentExts = runRecvState ctx recvState
where
recvState = RecvStateNext $ \p ->
case p of
Handshake hs ->
onRecvStateHandshake
ctx
(RecvStateHandshake $ onServerHello ctx cparams clientSession sentExts)
hs -- this adds SH to hstHandshakeMessages
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 =
throwCore $
Error_Protocol
("expecting server hello, got alert : " ++ show a)
HandshakeFailure
----------------------------------------------------------------

recvServerHello :: Context -> ClientParams -> Session -> [ExtensionID] -> IO ()
recvServerHello ctx cparams clientSession sentExts = runRecvState ctx recvState
where
recvState = RecvStateNext next
next (Handshake hs) =
onRecvStateHandshake
ctx
(RecvStateHandshake $ onServerHello ctx cparams clientSession sentExts)
hs -- this adds SH to hstHandshakeMessages
next (Alert [(AlertLevel_Warning, UnrecognizedName)])
| clientUseServerNameIndication cparams = return recvState
next (Alert a) = throwAlert a
next p = unexpected (show p) (Just "handshake")
throwAlert a =
throwCore $
Error_Protocol
("expecting server hello, got alert : " ++ show a)
HandshakeFailure

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

secondFlight12 :: ClientParams -> Context -> IO ()
secondFlight12 cparams ctx = do
sessionResuming <- usingState_ ctx isSessionResuming
if sessionResuming
then sendChangeCipherAndFinish ctx ClientRole
else do
sendClientData cparams ctx
sendChangeCipherAndFinish ctx ClientRole
recvChangeCipherAndFinish ctx
handshakeDone ctx

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

-- | Store the keypair and check that it is compatible with the current protocol
-- version and a list of 'CertificateType' values.
Expand Down Expand Up @@ -793,7 +815,7 @@ onServerHello ctx cparams clientSession sentExts (ServerHello rver serverRan ser
("server version " ++ show ver ++ " is not supported")
ProtocolVersion
Just _ -> return ()
if ver > TLS12
if ver == TLS13
then do
when (serverSession /= clientSession) $
throwCore $
Expand Down Expand Up @@ -975,14 +997,16 @@ requiredCertKeyUsage cipher =
, KeyUsage_keyAgreement
]

handshakeClient13 :: ClientParams -> Context -> Maybe Group -> IO ()
handshakeClient13 cparams ctx groupSent = do
----------------------------------------------------------------

secondFlight13 :: ClientParams -> Context -> Maybe Group -> IO ()
secondFlight13 cparams ctx groupSent = do
choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher
handshakeClient13' cparams ctx groupSent choice
secondFlight13' cparams ctx groupSent choice

handshakeClient13'
secondFlight13'
:: ClientParams -> Context -> Maybe Group -> CipherChoice -> IO ()
handshakeClient13' cparams ctx groupSent choice = do
secondFlight13' cparams ctx groupSent choice = do
(_, hkey, resuming) <- switchToHandshakeSecret
let handshakeSecret = triBase hkey
clientHandshakeSecret = triClient hkey
Expand All @@ -1007,7 +1031,7 @@ handshakeClient13' cparams ctx groupSent choice = do
setResumptionSecret applicationSecret
let appSecInfo = ApplicationSecretInfo (triClient appKey, triServer appKey)
contextSync ctx $ SendClientFinished eexts appSecInfo
handshakeTerminate13 ctx
handshakeDone13 ctx
where
usedCipher = cCipher choice
usedHash = cHash choice
Expand Down Expand Up @@ -1122,6 +1146,8 @@ handshakeClient13' cparams ctx groupSent choice = do
resumptionSecret <- calculateResumptionSecret ctx choice applicationSecret
usingHState ctx $ setTLS13ResumptionSecret resumptionSecret

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

processCertRequest13
:: MonadIO m => Context -> CertReqContext -> [ExtensionRaw] -> m ()
processCertRequest13 ctx token exts = do
Expand Down
6 changes: 3 additions & 3 deletions core/Network/TLS/Handshake/Common.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -6,7 +6,7 @@ module Network.TLS.Handshake.Common (
handleException,
unexpected,
newSession,
handshakeTerminate,
handshakeDone,

-- * sending packets
sendChangeCipherAndFinish,
Expand Down Expand Up @@ -107,8 +107,8 @@ newSession ctx
| otherwise = return $ Session Nothing

-- | when a new handshake is done, wrap up & clean up.
handshakeTerminate :: Context -> IO ()
handshakeTerminate ctx = do
handshakeDone :: Context -> IO ()
handshakeDone ctx = do
session <- usingState_ ctx getSession
-- only callback the session established if we have a session
case session of
Expand Down
8 changes: 4 additions & 4 deletions core/Network/TLS/Handshake/Common13.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -19,7 +19,7 @@ module Network.TLS.Handshake.Common13 (
makePSKBinder,
replacePSKBinder,
sendChangeCipherSpec13,
handshakeTerminate13,
handshakeDone13,
makeCertRequest,
createTLS13TicketInfo,
ageToObfuscatedAge,
Expand Down Expand Up @@ -243,13 +243,13 @@ sendChangeCipherSpec13 ctx = do

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

-- | TLS13 handshake wrap up & clean up. Contrary to @handshakeTerminate@, this
-- | TLS13 handshake wrap up & clean up. Contrary to @handshakeDone@, this
-- does not handle session, which is managed separately for TLS 1.3. This does
-- not reset byte counters because renegotiation is not allowed. And a few more
-- state attributes are preserved, necessary for TLS13 handshake modes, session
-- tickets and post-handshake authentication.
handshakeTerminate13 :: Context -> IO ()
handshakeTerminate13 ctx = do
handshakeDone13 :: Context -> IO ()
handshakeDone13 ctx = do
-- forget most handshake data
liftIO $ modifyMVar_ (ctxHandshake ctx) $ \mhshake ->
case mhshake of
Expand Down
Loading

0 comments on commit 644ef3c

Please sign in to comment.