Skip to content

Commit

Permalink
Merge branch 'fix-rtt'
Browse files Browse the repository at this point in the history
  • Loading branch information
@kazu-yamamoto
kazu-yamamoto committed Jan 27, 2024
2 parents 0922ee3 + f42f5e0 commit 7c3566f
Show file tree
Hide file tree
Showing 4 changed files with 60 additions and 49 deletions.
2 changes: 1 addition & 1 deletion core/Network/TLS/Core.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -79,7 +79,7 @@ handshake ctx = do
Just dat -> modifyTLS13State ctx $ \st -> st{tls13stPendingRecvData = Just dat}

rttFactor :: Int
rttFactor = 2
rttFactor = 3

getRTT :: Context -> IO Int
getRTT ctx = do
Expand Down
2 changes: 1 addition & 1 deletion core/Network/TLS/Handshake/Common13.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -586,4 +586,4 @@ setRTT ctx t0 = do
t1 <- getUnixTime
let UnixDiffTime (CTime s) u = t1 `diffUnixTime` t0
rtt = fromIntegral s * 1000000 + fromIntegral u
modifyTLS13State ctx $ \st -> st{tls13stRTT = rtt}
modifyTLS13State ctx $ \st -> st{tls13stRTT = max rtt 50000}
73 changes: 40 additions & 33 deletions core/test/HandshakeSpec.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -522,7 +522,7 @@ handshake_resumption_ems (CompatEMS ems, CompatEMS ems2) = do

-- and resume
sessionParams <- readClientSessionRef sessionRefs
sessionParams `shouldSatisfy` isJust
expectJust "session param should be Just" sessionParams
let params2 =
setEMSMode ems2 $
setPairParamsSessionResuming (fromJust sessionParams) params
Expand All @@ -534,8 +534,8 @@ handshake_resumption_ems (CompatEMS ems, CompatEMS ems2) = do
then runTLSFailure params2 handshake handshake
else do
runTLSSimple params2
sessionParams2 <- readClientSessionRef sessionRefs
let sameSession = sessionParams == sessionParams2
mSessionParams2 <- readClientSessionRef sessionRefs
let sameSession = sessionParams == mSessionParams2
sameUse = use ems == use ems2
when emsVersion (sameSession `shouldBe` sameUse)
where
Expand Down Expand Up @@ -597,12 +597,12 @@ handshake_sni (clientParam, serverParam) = do
where
hsClient ctx = do
handshake ctx
sni <- getClientSNI ctx
sni `shouldBe` Just serverName
msni <- getClientSNI ctx
expectMaybe "C: SNI should be Just" serverName msni
hsServer ctx = do
handshake ctx
sni <- getClientSNI ctx
sni `shouldBe` Just serverName
msni <- getClientSNI ctx
expectMaybe "S: SNI should be Just" serverName msni
onSNI ref name = do
mx <- readIORef ref
mx `shouldBe` Nothing
Expand Down Expand Up @@ -646,7 +646,7 @@ handshake12_session_resumption (CSP12 plainParams) = do

-- and resume
sessionParams <- readClientSessionRef sessionRefs
sessionParams `shouldSatisfy` isJust
expectJust "session param should be Just" sessionParams
let params2 = setPairParamsSessionResuming (fromJust sessionParams) params

runTLSPredicate params2 (maybe False infoTLS12Resumption)
Expand All @@ -663,7 +663,7 @@ handshake12_session_ticket (CSP12 plainParams) = do

-- and resume
sessionParams <- readClientSessionRef sessionRefs
sessionParams `shouldSatisfy` isJust
expectJust "session param should be Just" sessionParams
let params2 = setPairParamsSessionResuming (fromJust sessionParams) params

runTLSPredicate params2 (maybe False infoTLS12Resumption)
Expand Down Expand Up @@ -732,7 +732,7 @@ handshake13_psk (CSP13 (cli, srv)) = do

-- and resume
sessionParams <- readClientSessionRef sessionRefs
sessionParams `shouldSatisfy` isJust
expectJust "session param should be Just" sessionParams
let params2 = setPairParamsSessionResuming (fromJust sessionParams) params

runTLSSimple13 params2 PreSharedKey
Expand Down Expand Up @@ -764,7 +764,7 @@ handshake13_psk_ticket (CSP13 (cli, srv)) = do

-- and resume
sessionParams <- readClientSessionRef sessionRefs
sessionParams `shouldSatisfy` isJust
expectJust "session param should be Just" sessionParams
let params2 = setPairParamsSessionResuming (fromJust sessionParams) params

runTLSSimple13 params2 PreSharedKey
Expand Down Expand Up @@ -800,7 +800,7 @@ handshake13_psk_fallback (CSP13 (cli, srv)) = do
-- handshake is not possible because X25519 has been removed, so we are
-- back with P256 after hello retry
sessionParams <- readClientSessionRef sessionRefs
sessionParams `shouldSatisfy` isJust
expectJust "session param should be Just" sessionParams
let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params
srv2' = srv2{serverSupported = svrSupported'}
svrSupported' =
Expand Down Expand Up @@ -855,8 +855,8 @@ handshake13_0rtt (CSP13 (cli, srv)) = do
runTLS0rtt params sessionRefs = do
-- and resume
sessionParams <- readClientSessionRef sessionRefs
expectJust "session param should be Just" sessionParams
clearClientSessionRef sessionRefs
sessionParams `shouldSatisfy` isJust
earlyData <- B.pack <$> generate (someWords8 256)
let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params
params2 = (pc{clientEarlyData = True}, ps)
Expand Down Expand Up @@ -894,27 +894,29 @@ handshake13_0rtt_fallback (CSP13 (cli, srv)) = do
runTLSSimple13 params mode

-- and resume
sessionParams <- readClientSessionRef sessionRefs
sessionParams `shouldSatisfy` isJust
earlyData <- B.pack <$> generate (someWords8 256)
group1 <- generate $ elements [P256, X25519]
let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params
svrSupported1 =
def
{ supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]
, supportedGroups = [group1]
}
params1 =
( pc{clientEarlyData = True}
, ps
{ serverEarlyDataSize = 0
, serverSupported = svrSupported1
}
)
mSessionParams <- readClientSessionRef sessionRefs
case mSessionParams of
Nothing -> expectationFailure "session params: Just is expected"
Just sessionParams -> do
earlyData <- B.pack <$> generate (someWords8 256)
group1 <- generate $ elements [P256, X25519]
let (pc, ps) = setPairParamsSessionResuming sessionParams params
svrSupported1 =
def
{ supportedCiphers = [cipher_TLS13_AES128GCM_SHA256]
, supportedGroups = [group1]
}
params1 =
( pc{clientEarlyData = True}
, ps
{ serverEarlyDataSize = 0
, serverSupported = svrSupported1
}
)

if group1 == group0
then runTLS0RTT params1 PreSharedKey earlyData
else runTLSFailure params1 (tlsClient earlyData) tlsServer
if group1 == group0
then runTLS0RTT params1 PreSharedKey earlyData
else runTLSFailure params1 (tlsClient earlyData) tlsServer
where
tlsClient earlyData ctx = do
handshake ctx
Expand Down Expand Up @@ -1008,3 +1010,8 @@ post_handshake_auth (CSP13 (clientParam, serverParam)) = do
_ <- requestCertificate ctx
_ <- requestCertificate ctx -- two simultaneously
sendData ctx "response 2"

expectJust :: String -> Maybe a -> Expectation
expectJust tag mx = case mx of
Nothing -> expectationFailure tag
Just _ -> return ()
32 changes: 18 additions & 14 deletions core/test/Run.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ module Run (
runTLSCapture13,
runTLSSuccess,
runTLSFailure,
expectMaybe,
) where

import Control.Concurrent
Expand Down Expand Up @@ -59,19 +60,17 @@ runTLSN n params tlsClient tlsServer = do
withPairContext params $ \(cCtx, sCtx) ->
concurrently_ (server sCtx outputChan) (client inputChan cCtx)
-- read result
m_dsres <- timeout 1000000 $ readChan outputChan -- 60 sec
case m_dsres of
Nothing -> error "timed out"
Just dsres -> dsres `shouldBe` ds
mDs <- timeout 1000000 $ readChan outputChan -- 60 sec
expectMaybe "timeout" ds mDs
where
server sCtx outputChan =
E.catch
(tlsServer sCtx outputChan)
(printAndRaise "server" (serverSupported $ snd params))
(printAndRaise "S: " (serverSupported $ snd params))
client inputChan cCtx =
E.catch
(tlsClient inputChan cCtx)
(printAndRaise "client" (clientSupported $ fst params))
(printAndRaise "C: " (clientSupported $ fst params))
printAndRaise :: String -> Supported -> E.SomeException -> IO ()
printAndRaise s supported e = do
putStrLn $
Expand Down Expand Up @@ -113,12 +112,12 @@ runTLSSimple13 params mode =
where
hsClient ctx = do
handshake ctx
minfo <- contextGetInformation ctx
(minfo >>= infoTLS13HandshakeMode) `shouldBe` Just mode
mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx
expectMaybe "C: mode should be Just" mode mmode
hsServer ctx = do
handshake ctx
minfo <- contextGetInformation ctx
(minfo >>= infoTLS13HandshakeMode) `shouldBe` Just mode
mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx
expectMaybe "S: mode should be Just" mode mmode

runTLS0RTT
:: (ClientParams, ServerParams)
Expand All @@ -134,23 +133,28 @@ runTLS0RTT params mode earlyData =
sendData ctx $ L.fromStrict earlyData
_ <- recvData ctx
bye ctx
minfo <- contextGetInformation ctx
(minfo >>= infoTLS13HandshakeMode) `shouldBe` Just mode
mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx
expectMaybe "C: mode should be Just" mode mmode
tlsServer ctx = do
handshake ctx
let ls = chunkLengths $ B.length earlyData
chunks <- replicateM (length ls) $ recvData ctx
(map B.length chunks, B.concat chunks) `shouldBe` (ls, earlyData)
sendData ctx $ L.fromStrict earlyData
bye ctx
minfo <- contextGetInformation ctx
(minfo >>= infoTLS13HandshakeMode) `shouldBe` Just mode
mmode <- (>>= infoTLS13HandshakeMode) <$> contextGetInformation ctx
expectMaybe "S: mode should be Just" mode mmode
chunkLengths :: Int -> [Int]
chunkLengths len
| len > 16384 = 16384 : chunkLengths (len - 16384)
| len > 0 = [len]
| otherwise = []

expectMaybe :: (Show a, Eq a) => String -> a -> Maybe a -> Expectation
expectMaybe tag e mx = case mx of
Nothing -> expectationFailure tag
Just x -> x `shouldBe` e

runTLSCapture13
:: (ClientParams, ServerParams) -> IO ([Handshake13], [Handshake13])
runTLSCapture13 params = do
Expand Down

0 comments on commit 7c3566f

Please sign in to comment.