1{-# LANGUAGE OverloadedStrings #-} 2 3import Test.Tasty 4import Test.Tasty.QuickCheck 5import Test.QuickCheck.Monadic 6 7import PipeChan 8import Connection 9import Marshalling 10import Ciphers 11import PubKey 12 13import Data.Foldable (traverse_) 14import Data.Maybe 15import Data.Default.Class 16import Data.List (intersect) 17 18import qualified Data.ByteString as B 19import qualified Data.ByteString.Char8 as C8 20import qualified Data.ByteString.Lazy as L 21import Network.TLS 22import Network.TLS.Extra 23import Network.TLS.Internal 24import Control.Applicative 25import Control.Concurrent 26import Control.Concurrent.Async 27import Control.Monad 28 29import Data.IORef 30import Data.X509 (ExtKeyUsageFlag(..)) 31 32import System.Timeout 33 34prop_pipe_work :: PropertyM IO () 35prop_pipe_work = do 36 pipe <- run newPipe 37 _ <- run (runPipe pipe) 38 39 let bSize = 16 40 n <- pick (choose (1, 32)) 41 42 let d1 = B.replicate (bSize * n) 40 43 let d2 = B.replicate (bSize * n) 45 44 45 d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1)) 46 d1 `assertEq` d1' 47 48 d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2)) 49 d2 `assertEq` d2' 50 51 return () 52 53chunkLengths :: Int -> [Int] 54chunkLengths len 55 | len > 16384 = 16384 : chunkLengths (len - 16384) 56 | len > 0 = [len] 57 | otherwise = [] 58 59runTLSPipeN :: Int -> (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO () 60runTLSPipeN n params tlsServer tlsClient = do 61 -- generate some data to send 62 ds <- replicateM n $ do 63 d <- B.pack <$> pick (someWords8 256) 64 return d 65 -- send it 66 m_dsres <- run $ do 67 withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do 68 forM_ ds $ \d -> do 69 writeStart d 70 -- receive it 71 timeout 60000000 readResult -- 60 sec 72 case m_dsres of 73 Nothing -> error "timed out" 74 Just dsres -> ds `assertEq` dsres 75 76runTLSPipe :: (ClientParams, ServerParams) -> (Context -> Chan [C8.ByteString] -> IO ()) -> (Chan C8.ByteString -> Context -> IO ()) -> PropertyM IO () 77runTLSPipe = runTLSPipeN 1 78 79runTLSPipePredicate :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> PropertyM IO () 80runTLSPipePredicate params p = runTLSPipe params tlsServer tlsClient 81 where tlsServer ctx queue = do 82 handshake ctx 83 checkInfoPredicate ctx 84 d <- recvData ctx 85 writeChan queue [d] 86 bye ctx 87 tlsClient queue ctx = do 88 handshake ctx 89 checkInfoPredicate ctx 90 d <- readChan queue 91 sendData ctx (L.fromChunks [d]) 92 byeBye ctx 93 checkInfoPredicate ctx = do 94 minfo <- contextGetInformation ctx 95 unless (p minfo) $ 96 fail ("unexpected information: " ++ show minfo) 97 98runTLSPipeSimple :: (ClientParams, ServerParams) -> PropertyM IO () 99runTLSPipeSimple params = runTLSPipePredicate params (const True) 100 101runTLSPipeSimple13 :: (ClientParams, ServerParams) -> HandshakeMode13 -> Maybe C8.ByteString -> PropertyM IO () 102runTLSPipeSimple13 params mode mEarlyData = runTLSPipe params tlsServer tlsClient 103 where tlsServer ctx queue = do 104 handshake ctx 105 case mEarlyData of 106 Nothing -> return () 107 Just ed -> do 108 let ls = chunkLengths (B.length ed) 109 chunks <- replicateM (length ls) $ recvData ctx 110 (ls, ed) `assertEq` (map B.length chunks, B.concat chunks) 111 d <- recvData ctx 112 writeChan queue [d] 113 minfo <- contextGetInformation ctx 114 Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) 115 bye ctx 116 tlsClient queue ctx = do 117 handshake ctx 118 d <- readChan queue 119 sendData ctx (L.fromChunks [d]) 120 minfo <- contextGetInformation ctx 121 Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) 122 byeBye ctx 123 124runTLSPipeCapture13 :: (ClientParams, ServerParams) -> PropertyM IO ([Handshake13], [Handshake13]) 125runTLSPipeCapture13 params = do 126 sRef <- run $ newIORef [] 127 cRef <- run $ newIORef [] 128 runTLSPipe params (tlsServer sRef) (tlsClient cRef) 129 sReceived <- run $ readIORef sRef 130 cReceived <- run $ readIORef cRef 131 return (reverse sReceived, reverse cReceived) 132 where tlsServer ref ctx queue = do 133 installHook ctx ref 134 handshake ctx 135 d <- recvData ctx 136 writeChan queue [d] 137 bye ctx 138 tlsClient ref queue ctx = do 139 installHook ctx ref 140 handshake ctx 141 d <- readChan queue 142 sendData ctx (L.fromChunks [d]) 143 byeBye ctx 144 installHook ctx ref = 145 let recv hss = modifyIORef ref (hss :) >> return hss 146 in contextHookSetHandshake13Recv ctx recv 147 148runTLSPipeSimpleKeyUpdate :: (ClientParams, ServerParams) -> PropertyM IO () 149runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient 150 where tlsServer ctx queue = do 151 handshake ctx 152 d0 <- recvData ctx 153 req <- generate $ elements [OneWay, TwoWay] 154 _ <- updateKey ctx req 155 d1 <- recvData ctx 156 d2 <- recvData ctx 157 writeChan queue [d0,d1,d2] 158 bye ctx 159 tlsClient queue ctx = do 160 handshake ctx 161 d0 <- readChan queue 162 sendData ctx (L.fromChunks [d0]) 163 d1 <- readChan queue 164 sendData ctx (L.fromChunks [d1]) 165 req <- generate $ elements [OneWay, TwoWay] 166 _ <- updateKey ctx req 167 d2 <- readChan queue 168 sendData ctx (L.fromChunks [d2]) 169 byeBye ctx 170 171runTLSInitFailureGen :: (ClientParams, ServerParams) -> (Context -> IO s) -> (Context -> IO c) -> PropertyM IO () 172runTLSInitFailureGen params hsServer hsClient = do 173 (cRes, sRes) <- run (initiateDataPipe params tlsServer tlsClient) 174 assertIsLeft cRes 175 assertIsLeft sRes 176 where tlsServer ctx = do 177 _ <- hsServer ctx 178 minfo <- contextGetInformation ctx 179 byeBye ctx 180 return $ "server success: " ++ show minfo 181 tlsClient ctx = do 182 _ <- hsClient ctx 183 minfo <- contextGetInformation ctx 184 byeBye ctx 185 return $ "client success: " ++ show minfo 186 187runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO () 188runTLSInitFailure params = runTLSInitFailureGen params handshake handshake 189 190prop_handshake_initiate :: PropertyM IO () 191prop_handshake_initiate = do 192 params <- pick arbitraryPairParams 193 runTLSPipeSimple params 194 195prop_handshake13_initiate :: PropertyM IO () 196prop_handshake13_initiate = do 197 params <- pick arbitraryPairParams13 198 let cgrps = supportedGroups $ clientSupported $ fst params 199 sgrps = supportedGroups $ serverSupported $ snd params 200 hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest 201 runTLSPipeSimple13 params hs Nothing 202 203prop_handshake_keyupdate :: PropertyM IO () 204prop_handshake_keyupdate = do 205 params <- pick arbitraryPairParams 206 runTLSPipeSimpleKeyUpdate params 207 208prop_handshake13_downgrade :: PropertyM IO () 209prop_handshake13_downgrade = do 210 (cparam,sparam) <- pick arbitraryPairParams 211 versionForced <- pick $ elements (supportedVersions $ clientSupported cparam) 212 let debug' = (serverDebug sparam) { debugVersionForced = Just versionForced } 213 sparam' = sparam { serverDebug = debug' } 214 params = (cparam,sparam') 215 downgraded = (isVersionEnabled TLS13 params && versionForced < TLS13) || 216 (isVersionEnabled TLS12 params && versionForced < TLS12) 217 if downgraded 218 then runTLSInitFailure params 219 else runTLSPipeSimple params 220 221prop_handshake13_full :: PropertyM IO () 222prop_handshake13_full = do 223 (cli, srv) <- pick arbitraryPairParams13 224 let cliSupported = def 225 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 226 , supportedGroups = [X25519] 227 } 228 svrSupported = def 229 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 230 , supportedGroups = [X25519] 231 } 232 params = (cli { clientSupported = cliSupported } 233 ,srv { serverSupported = svrSupported } 234 ) 235 runTLSPipeSimple13 params FullHandshake Nothing 236 237prop_handshake13_hrr :: PropertyM IO () 238prop_handshake13_hrr = do 239 (cli, srv) <- pick arbitraryPairParams13 240 let cliSupported = def 241 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 242 , supportedGroups = [P256,X25519] 243 } 244 svrSupported = def 245 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 246 , supportedGroups = [X25519] 247 } 248 params = (cli { clientSupported = cliSupported } 249 ,srv { serverSupported = svrSupported } 250 ) 251 runTLSPipeSimple13 params HelloRetryRequest Nothing 252 253prop_handshake13_psk :: PropertyM IO () 254prop_handshake13_psk = do 255 (cli, srv) <- pick arbitraryPairParams13 256 let cliSupported = def 257 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 258 , supportedGroups = [P256,X25519] 259 } 260 svrSupported = def 261 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 262 , supportedGroups = [X25519] 263 } 264 params0 = (cli { clientSupported = cliSupported } 265 ,srv { serverSupported = svrSupported } 266 ) 267 268 sessionRefs <- run twoSessionRefs 269 let sessionManagers = twoSessionManagers sessionRefs 270 271 let params = setPairParamsSessionManagers sessionManagers params0 272 273 runTLSPipeSimple13 params HelloRetryRequest Nothing 274 275 -- and resume 276 sessionParams <- run $ readClientSessionRef sessionRefs 277 assert (isJust sessionParams) 278 let params2 = setPairParamsSessionResuming (fromJust sessionParams) params 279 280 runTLSPipeSimple13 params2 PreSharedKey Nothing 281 282prop_handshake13_psk_fallback :: PropertyM IO () 283prop_handshake13_psk_fallback = do 284 (cli, srv) <- pick arbitraryPairParams13 285 let cliSupported = def 286 { supportedCiphers = [ cipher_TLS13_AES128GCM_SHA256 287 , cipher_TLS13_AES128CCM_SHA256 288 ] 289 , supportedGroups = [P256,X25519] 290 } 291 svrSupported = def 292 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 293 , supportedGroups = [X25519] 294 } 295 params0 = (cli { clientSupported = cliSupported } 296 ,srv { serverSupported = svrSupported } 297 ) 298 299 sessionRefs <- run twoSessionRefs 300 let sessionManagers = twoSessionManagers sessionRefs 301 302 let params = setPairParamsSessionManagers sessionManagers params0 303 304 runTLSPipeSimple13 params HelloRetryRequest Nothing 305 306 -- resumption fails because GCM cipher is not supported anymore, full 307 -- handshake is not possible because X25519 has been removed, so we are 308 -- back with P256 after hello retry 309 sessionParams <- run $ readClientSessionRef sessionRefs 310 assert (isJust sessionParams) 311 let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params 312 srv2' = srv2 { serverSupported = svrSupported' } 313 svrSupported' = def 314 { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256] 315 , supportedGroups = [P256] 316 } 317 318 runTLSPipeSimple13 (cli2, srv2') HelloRetryRequest Nothing 319 320prop_handshake13_rtt0 :: PropertyM IO () 321prop_handshake13_rtt0 = do 322 (cli, srv) <- pick arbitraryPairParams13 323 let cliSupported = def 324 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 325 , supportedGroups = [P256,X25519] 326 } 327 svrSupported = def 328 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 329 , supportedGroups = [X25519] 330 } 331 cliHooks = def { 332 onSuggestALPN = return $ Just ["h2"] 333 } 334 svrHooks = def { 335 onALPNClientSuggest = Just (\protos -> return $ head protos) 336 } 337 params0 = (cli { clientSupported = cliSupported 338 , clientHooks = cliHooks 339 } 340 ,srv { serverSupported = svrSupported 341 , serverHooks = svrHooks 342 , serverEarlyDataSize = 2048 } 343 ) 344 345 sessionRefs <- run twoSessionRefs 346 let sessionManagers = twoSessionManagers sessionRefs 347 348 let params = setPairParamsSessionManagers sessionManagers params0 349 350 runTLSPipeSimple13 params HelloRetryRequest Nothing 351 352 -- and resume 353 sessionParams <- run $ readClientSessionRef sessionRefs 354 assert (isJust sessionParams) 355 earlyData <- B.pack <$> pick (someWords8 256) 356 let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params 357 params2 = (pc { clientEarlyData = Just earlyData } , ps) 358 359 runTLSPipeSimple13 params2 RTT0 (Just earlyData) 360 361prop_handshake13_rtt0_fallback :: PropertyM IO () 362prop_handshake13_rtt0_fallback = do 363 ticketSize <- pick $ choose (0, 512) 364 (cli, srv) <- pick arbitraryPairParams13 365 group0 <- pick $ elements [P256,X25519] 366 let cliSupported = def 367 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 368 , supportedGroups = [P256,X25519] 369 } 370 svrSupported = def 371 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 372 , supportedGroups = [group0] 373 } 374 params0 = (cli { clientSupported = cliSupported } 375 ,srv { serverSupported = svrSupported 376 , serverEarlyDataSize = ticketSize } 377 ) 378 379 sessionRefs <- run twoSessionRefs 380 let sessionManagers = twoSessionManagers sessionRefs 381 382 let params = setPairParamsSessionManagers sessionManagers params0 383 384 let mode = if group0 == P256 then FullHandshake else HelloRetryRequest 385 runTLSPipeSimple13 params mode Nothing 386 387 -- and resume 388 sessionParams <- run $ readClientSessionRef sessionRefs 389 assert (isJust sessionParams) 390 earlyData <- B.pack <$> pick (someWords8 256) 391 group2 <- pick $ elements [P256,X25519] 392 let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params 393 svrSupported2 = def 394 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 395 , supportedGroups = [group2] 396 } 397 params2 = (pc { clientEarlyData = Just earlyData } 398 ,ps { serverEarlyDataSize = 0 399 , serverSupported = svrSupported2 400 } 401 ) 402 403 let mode2 = if ticketSize < 256 then PreSharedKey else RTT0 404 runTLSPipeSimple13 params2 mode2 Nothing 405 406prop_handshake13_rtt0_length :: PropertyM IO () 407prop_handshake13_rtt0_length = do 408 serverMax <- pick $ choose (0, 33792) 409 (cli, srv) <- pick arbitraryPairParams13 410 let cliSupported = def 411 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 412 , supportedGroups = [X25519] 413 } 414 svrSupported = def 415 { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] 416 , supportedGroups = [X25519] 417 } 418 params0 = (cli { clientSupported = cliSupported } 419 ,srv { serverSupported = svrSupported 420 , serverEarlyDataSize = serverMax } 421 ) 422 423 sessionRefs <- run twoSessionRefs 424 let sessionManagers = twoSessionManagers sessionRefs 425 let params = setPairParamsSessionManagers sessionManagers params0 426 runTLSPipeSimple13 params FullHandshake Nothing 427 428 -- and resume 429 sessionParams <- run $ readClientSessionRef sessionRefs 430 assert (isJust sessionParams) 431 clientLen <- pick $ choose (0, 33792) 432 earlyData <- B.pack <$> pick (someWords8 clientLen) 433 let (pc,ps) = setPairParamsSessionResuming (fromJust sessionParams) params 434 params2 = (pc { clientEarlyData = Just earlyData } , ps) 435 (mode, mEarlyData) 436 | clientLen > serverMax = (PreSharedKey, Nothing) 437 | otherwise = (RTT0, Just earlyData) 438 runTLSPipeSimple13 params2 mode mEarlyData 439 440prop_handshake13_ee_groups :: PropertyM IO () 441prop_handshake13_ee_groups = do 442 (cli, srv) <- pick arbitraryPairParams13 443 let cliSupported = (clientSupported cli) { supportedGroups = [P256,X25519] } 444 svrSupported = (serverSupported srv) { supportedGroups = [X25519,P256] } 445 params = (cli { clientSupported = cliSupported } 446 ,srv { serverSupported = svrSupported } 447 ) 448 (_, serverMessages) <- runTLSPipeCapture13 params 449 let isNegotiatedGroups (ExtensionRaw eid _) = eid == 0xa 450 eeMessagesHaveExt = [ any isNegotiatedGroups exts | 451 EncryptedExtensions13 exts <- serverMessages ] 452 [True] `assertEq` eeMessagesHaveExt -- one EE message with extension 453 454prop_handshake_ciphersuites :: PropertyM IO () 455prop_handshake_ciphersuites = do 456 tls13 <- pick arbitrary 457 let version = if tls13 then TLS13 else TLS12 458 clientCiphers <- pick arbitraryCiphers 459 serverCiphers <- pick arbitraryCiphers 460 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 461 ([version], [version]) 462 (clientCiphers, serverCiphers) 463 let adequate = cipherAllowedForVersion version 464 shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers) 465 if shouldSucceed 466 then runTLSPipeSimple (clientParam,serverParam) 467 else runTLSInitFailure (clientParam,serverParam) 468 469prop_handshake_hashsignatures :: PropertyM IO () 470prop_handshake_hashsignatures = do 471 tls13 <- pick arbitrary 472 let version = if tls13 then TLS13 else TLS12 473 ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 474 , cipher_ECDHE_ECDSA_AES256GCM_SHA384 475 , cipher_ECDHE_RSA_AES128CBC_SHA 476 , cipher_ECDHE_ECDSA_AES128CBC_SHA 477 , cipher_DHE_RSA_AES128_SHA1 478 , cipher_DHE_DSS_AES128_SHA1 479 , cipher_TLS13_AES128GCM_SHA256 480 ] 481 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 482 ([version], [version]) 483 (ciphers, ciphers) 484 clientHashSigs <- pick $ arbitraryHashSignatures version 485 serverHashSigs <- pick $ arbitraryHashSignatures version 486 let clientParam' = clientParam { clientSupported = (clientSupported clientParam) 487 { supportedHashSignatures = clientHashSigs } 488 } 489 serverParam' = serverParam { serverSupported = (serverSupported serverParam) 490 { supportedHashSignatures = serverHashSigs } 491 } 492 commonHashSigs = clientHashSigs `intersect` serverHashSigs 493 shouldFail 494 | tls13 = all incompatibleWithDefaultCurve commonHashSigs 495 | otherwise = null commonHashSigs 496 if shouldFail 497 then runTLSInitFailure (clientParam',serverParam') 498 else runTLSPipeSimple (clientParam',serverParam') 499 where 500 incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 501 incompatibleWithDefaultCurve _ = False 502 503-- Tests ability to use or ignore client "signature_algorithms" extension when 504-- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but 505-- the server RSA certificate has a SHA-1 signature that the client does not 506-- support. Server may choose the DSA certificate only when cipher 507-- DHE_DSS_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA 508-- certificate. 509prop_handshake_cert_fallback :: PropertyM IO () 510prop_handshake_cert_fallback = do 511 let clientVersions = [TLS12] 512 serverVersions = [TLS12] 513 commonCiphers = [ cipher_DHE_RSA_AES128_SHA1 ] 514 otherCiphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 515 , cipher_ECDHE_RSA_AES128CBC_SHA 516 , cipher_DHE_DSS_AES128_SHA1 517 ] 518 hashSignatures = [ (HashSHA256, SignatureRSA), (HashSHA1, SignatureDSS) ] 519 chainRef <- run $ newIORef Nothing 520 clientCiphers <- pick $ sublistOf otherCiphers 521 serverCiphers <- pick $ sublistOf otherCiphers 522 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 523 (clientVersions, serverVersions) 524 (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) 525 let clientParam' = clientParam { clientSupported = (clientSupported clientParam) 526 { supportedHashSignatures = hashSignatures } 527 , clientHooks = (clientHooks clientParam) 528 { onServerCertificate = \_ _ _ chain -> 529 writeIORef chainRef (Just chain) >> return [] } 530 } 531 dssDisallowed = cipher_DHE_DSS_AES128_SHA1 `notElem` clientCiphers 532 || cipher_DHE_DSS_AES128_SHA1 `notElem` serverCiphers 533 runTLSPipeSimple (clientParam',serverParam) 534 serverChain <- run $ readIORef chainRef 535 dssDisallowed `assertEq` isLeafRSA serverChain 536 537-- Same as above but testing with supportedHashSignatures directly instead of 538-- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the 539-- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by 540-- both client and server, the Ed25519 certificate is selected. Otherwise the 541-- server fallbacks to RSA. 542-- 543-- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 544-- unless client advertises explicit support. Currently this is not enforced by 545-- the library, which is useful to test this scenario. SHA-1 could be replaced 546-- by another algorithm. 547prop_handshake_cert_fallback_hs :: PropertyM IO () 548prop_handshake_cert_fallback_hs = do 549 tls13 <- pick arbitrary 550 let versions = if tls13 then [TLS13] else [TLS12] 551 ciphers = [ cipher_ECDHE_RSA_AES128GCM_SHA256 552 , cipher_ECDHE_ECDSA_AES128GCM_SHA256 553 , cipher_TLS13_AES128GCM_SHA256 554 ] 555 commonHS = [ (HashSHA256, SignatureRSA) 556 , (HashIntrinsic, SignatureRSApssRSAeSHA256) 557 ] 558 otherHS = [ (HashIntrinsic, SignatureEd25519) ] 559 chainRef <- run $ newIORef Nothing 560 clientHS <- pick $ sublistOf otherHS 561 serverHS <- pick $ sublistOf otherHS 562 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 563 (versions, versions) 564 (ciphers, ciphers) 565 let clientParam' = clientParam { clientSupported = (clientSupported clientParam) 566 { supportedHashSignatures = commonHS ++ clientHS } 567 , clientHooks = (clientHooks clientParam) 568 { onServerCertificate = \_ _ _ chain -> 569 writeIORef chainRef (Just chain) >> return [] } 570 } 571 serverParam' = serverParam { serverSupported = (serverSupported serverParam) 572 { supportedHashSignatures = commonHS ++ serverHS } 573 } 574 eddsaDisallowed = (HashIntrinsic, SignatureEd25519) `notElem` clientHS 575 || (HashIntrinsic, SignatureEd25519) `notElem` serverHS 576 runTLSPipeSimple (clientParam',serverParam') 577 serverChain <- run $ readIORef chainRef 578 eddsaDisallowed `assertEq` isLeafRSA serverChain 579 580prop_handshake_groups :: PropertyM IO () 581prop_handshake_groups = do 582 tls13 <- pick arbitrary 583 let versions = if tls13 then [TLS13] else [TLS12] 584 ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 585 , cipher_ECDHE_RSA_AES128CBC_SHA 586 , cipher_DHE_RSA_AES256GCM_SHA384 587 , cipher_DHE_RSA_AES128_SHA1 588 , cipher_TLS13_AES128GCM_SHA256 589 ] 590 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 591 (versions, versions) 592 (ciphers, ciphers) 593 clientGroups <- pick arbitraryGroups 594 serverGroups <- pick arbitraryGroups 595 denyCustom <- pick arbitrary 596 let groupUsage = if denyCustom then GroupUsageUnsupported "custom group denied" else GroupUsageValid 597 clientParam' = clientParam { clientSupported = (clientSupported clientParam) 598 { supportedGroups = clientGroups } 599 , clientHooks = (clientHooks clientParam) 600 { onCustomFFDHEGroup = \_ _ -> return groupUsage } 601 } 602 serverParam' = serverParam { serverSupported = (serverSupported serverParam) 603 { supportedGroups = serverGroups } 604 } 605 isCustom = maybe True isCustomDHParams (serverDHEParams serverParam') 606 mCustomGroup = serverDHEParams serverParam' >>= dhParamsGroup 607 isClientCustom = maybe True (`notElem` clientGroups) mCustomGroup 608 commonGroups = clientGroups `intersect` serverGroups 609 shouldFail = null commonGroups && (tls13 || isClientCustom && denyCustom) 610 p minfo = isNothing (minfo >>= infoNegotiatedGroup) == (null commonGroups && isCustom) 611 if shouldFail 612 then runTLSInitFailure (clientParam',serverParam') 613 else runTLSPipePredicate (clientParam',serverParam') p 614 615 616prop_handshake_dh :: PropertyM IO () 617prop_handshake_dh = do 618 let clientVersions = [TLS12] 619 serverVersions = [TLS12] 620 ciphers = [ cipher_DHE_RSA_AES128_SHA1 ] 621 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 622 (clientVersions, serverVersions) 623 (ciphers, ciphers) 624 let clientParam' = clientParam { clientSupported = (clientSupported clientParam) 625 { supportedGroups = [] } 626 } 627 let check (dh,shouldFail) = do 628 let serverParam' = serverParam { serverDHEParams = Just dh } 629 if shouldFail 630 then runTLSInitFailure (clientParam',serverParam') 631 else runTLSPipeSimple (clientParam',serverParam') 632 mapM_ check [(dhParams512,True) 633 ,(dhParams768,True) 634 ,(dhParams1024,False)] 635 636prop_handshake_srv_key_usage :: PropertyM IO () 637prop_handshake_srv_key_usage = do 638 tls13 <- pick arbitrary 639 let versions = if tls13 then [TLS13] else [TLS12,TLS11,TLS10,SSL3] 640 ciphers = [ cipher_ECDHE_RSA_AES128CBC_SHA 641 , cipher_TLS13_AES128GCM_SHA256 642 , cipher_DHE_RSA_AES128_SHA1 643 , cipher_AES256_SHA256 644 ] 645 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 646 (versions, versions) 647 (ciphers, ciphers) 648 usageFlags <- pick arbitraryKeyUsage 649 cred <- pick $ arbitraryRSACredentialWithUsage usageFlags 650 let serverParam' = serverParam 651 { serverShared = (serverShared serverParam) 652 { sharedCredentials = Credentials [cred] 653 } 654 } 655 hasDS = KeyUsage_digitalSignature `elem` usageFlags 656 hasKE = KeyUsage_keyEncipherment `elem` usageFlags 657 shouldSucceed = hasDS || (hasKE && not tls13) 658 if shouldSucceed 659 then runTLSPipeSimple (clientParam,serverParam') 660 else runTLSInitFailure (clientParam,serverParam') 661 662prop_handshake_ec :: PropertyM IO () 663prop_handshake_ec = do 664 let versions = [TLS10, TLS11, TLS12, TLS13] 665 ciphers = [ cipher_ECDHE_ECDSA_AES256GCM_SHA384 666 , cipher_ECDHE_ECDSA_AES128CBC_SHA 667 , cipher_TLS13_AES128GCM_SHA256 668 ] 669 sigGroups = [P256] 670 ecdhGroups = [X25519, X448] -- always enabled, so no ECDHE failure 671 hashSignatures = [ (HashSHA256, SignatureECDSA) 672 ] 673 clientVersion <- pick $ elements versions 674 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 675 ([clientVersion], versions) 676 (ciphers, ciphers) 677 clientGroups <- pick $ sublistOf sigGroups 678 clientHashSignatures <- pick $ sublistOf hashSignatures 679 serverHashSignatures <- pick $ sublistOf hashSignatures 680 credentials <- pick arbitraryCredentialsOfEachCurve 681 let clientParam' = clientParam { clientSupported = (clientSupported clientParam) 682 { supportedGroups = clientGroups ++ ecdhGroups 683 , supportedHashSignatures = clientHashSignatures 684 } 685 } 686 serverParam' = serverParam { serverSupported = (serverSupported serverParam) 687 { supportedGroups = sigGroups ++ ecdhGroups 688 , supportedHashSignatures = serverHashSignatures 689 } 690 , serverShared = (serverShared serverParam) 691 { sharedCredentials = Credentials credentials } 692 } 693 sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures) 694 ecdsaDenied = (clientVersion < TLS13 && null clientGroups) || 695 (clientVersion >= TLS12 && SignatureECDSA `notElem` sigAlgs) 696 if ecdsaDenied 697 then runTLSInitFailure (clientParam',serverParam') 698 else runTLSPipeSimple (clientParam',serverParam') 699 700prop_handshake_client_auth :: PropertyM IO () 701prop_handshake_client_auth = do 702 (clientParam,serverParam) <- pick arbitraryPairParams 703 let clientVersions = supportedVersions $ clientSupported clientParam 704 serverVersions = supportedVersions $ serverSupported serverParam 705 version = maximum (clientVersions `intersect` serverVersions) 706 cred <- pick (arbitraryClientCredential version) 707 let clientParam' = clientParam { clientHooks = (clientHooks clientParam) 708 { onCertificateRequest = \_ -> return $ Just cred } 709 } 710 serverParam' = serverParam { serverWantClientCert = True 711 , serverHooks = (serverHooks serverParam) 712 { onClientCertificate = validateChain cred } 713 } 714 let shouldFail = version == TLS13 && isCredentialDSA cred 715 if shouldFail 716 then runTLSInitFailure (clientParam',serverParam') 717 else runTLSPipeSimple (clientParam',serverParam') 718 where validateChain cred chain 719 | chain == fst cred = return CertificateUsageAccept 720 | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) 721 722prop_post_handshake_auth :: PropertyM IO () 723prop_post_handshake_auth = do 724 (clientParam,serverParam) <- pick arbitraryPairParams13 725 cred <- pick (arbitraryClientCredential TLS13) 726 let clientParam' = clientParam { clientHooks = (clientHooks clientParam) 727 { onCertificateRequest = \_ -> return $ Just cred } 728 } 729 serverParam' = serverParam { serverHooks = (serverHooks serverParam) 730 { onClientCertificate = validateChain cred } 731 } 732 if isCredentialDSA cred 733 then runTLSInitFailureGen (clientParam',serverParam') hsServer hsClient 734 else runTLSPipe (clientParam',serverParam') tlsServer tlsClient 735 where validateChain cred chain 736 | chain == fst cred = return CertificateUsageAccept 737 | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) 738 tlsServer ctx queue = do 739 hsServer ctx 740 d <- recvData ctx 741 writeChan queue [d] 742 bye ctx 743 tlsClient queue ctx = do 744 hsClient ctx 745 d <- readChan queue 746 sendData ctx (L.fromChunks [d]) 747 byeBye ctx 748 hsServer ctx = do 749 handshake ctx 750 recvDataAssert ctx "request 1" 751 _ <- requestCertificate ctx -- single request 752 sendData ctx "response 1" 753 recvDataAssert ctx "request 2" 754 _ <- requestCertificate ctx 755 _ <- requestCertificate ctx -- two simultaneously 756 sendData ctx "response 2" 757 hsClient ctx = do 758 handshake ctx 759 sendData ctx "request 1" 760 recvDataAssert ctx "response 1" 761 sendData ctx "request 2" 762 recvDataAssert ctx "response 2" 763 764prop_handshake_clt_key_usage :: PropertyM IO () 765prop_handshake_clt_key_usage = do 766 (clientParam,serverParam) <- pick arbitraryPairParams 767 usageFlags <- pick arbitraryKeyUsage 768 cred <- pick $ arbitraryRSACredentialWithUsage usageFlags 769 let clientParam' = clientParam { clientHooks = (clientHooks clientParam) 770 { onCertificateRequest = \_ -> return $ Just cred } 771 } 772 serverParam' = serverParam { serverWantClientCert = True 773 , serverHooks = (serverHooks serverParam) 774 { onClientCertificate = \_ -> return CertificateUsageAccept } 775 } 776 shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags 777 if shouldSucceed 778 then runTLSPipeSimple (clientParam',serverParam') 779 else runTLSInitFailure (clientParam',serverParam') 780 781prop_handshake_ems :: PropertyM IO () 782prop_handshake_ems = do 783 (cems, sems) <- pick arbitraryEMSMode 784 params <- pick arbitraryPairParams 785 let params' = setEMSMode (cems, sems) params 786 version = getConnectVersion params' 787 emsVersion = version >= TLS10 && version <= TLS12 788 use = cems /= NoEMS && sems /= NoEMS 789 require = cems == RequireEMS || sems == RequireEMS 790 p info = infoExtendedMasterSec info == (emsVersion && use) 791 if emsVersion && require && not use 792 then runTLSInitFailure params' 793 else runTLSPipePredicate params' (maybe False p) 794 795prop_handshake_session_resumption_ems :: PropertyM IO () 796prop_handshake_session_resumption_ems = do 797 sessionRefs <- run twoSessionRefs 798 let sessionManagers = twoSessionManagers sessionRefs 799 800 plainParams <- pick arbitraryPairParams 801 ems <- pick (arbitraryEMSMode `suchThat` compatible) 802 let params = setEMSMode ems $ 803 setPairParamsSessionManagers sessionManagers plainParams 804 805 runTLSPipeSimple params 806 807 -- and resume 808 sessionParams <- run $ readClientSessionRef sessionRefs 809 assert (isJust sessionParams) 810 ems2 <- pick (arbitraryEMSMode `suchThat` compatible) 811 let params2 = setEMSMode ems2 $ 812 setPairParamsSessionResuming (fromJust sessionParams) params 813 814 let version = getConnectVersion params2 815 emsVersion = version >= TLS10 && version <= TLS12 816 817 if emsVersion && use ems && not (use ems2) 818 then runTLSInitFailure params2 819 else do 820 runTLSPipeSimple params2 821 sessionParams2 <- run $ readClientSessionRef sessionRefs 822 let sameSession = sessionParams == sessionParams2 823 sameUse = use ems == use ems2 824 when emsVersion $ assert (sameSession == sameUse) 825 where 826 compatible (NoEMS, RequireEMS) = False 827 compatible (RequireEMS, NoEMS) = False 828 compatible _ = True 829 830 use (NoEMS, _) = False 831 use (_, NoEMS) = False 832 use _ = True 833 834prop_handshake_alpn :: PropertyM IO () 835prop_handshake_alpn = do 836 (clientParam,serverParam) <- pick arbitraryPairParams 837 let clientParam' = clientParam { clientHooks = (clientHooks clientParam) 838 { onSuggestALPN = return $ Just ["h2", "http/1.1"] } 839 } 840 serverParam' = serverParam { serverHooks = (serverHooks serverParam) 841 { onALPNClientSuggest = Just alpn } 842 } 843 params' = (clientParam',serverParam') 844 runTLSPipe params' tlsServer tlsClient 845 where tlsServer ctx queue = do 846 handshake ctx 847 proto <- getNegotiatedProtocol ctx 848 Just "h2" `assertEq` proto 849 d <- recvData ctx 850 writeChan queue [d] 851 bye ctx 852 tlsClient queue ctx = do 853 handshake ctx 854 proto <- getNegotiatedProtocol ctx 855 Just "h2" `assertEq` proto 856 d <- readChan queue 857 sendData ctx (L.fromChunks [d]) 858 byeBye ctx 859 alpn xs 860 | "h2" `elem` xs = return "h2" 861 | otherwise = return "http/1.1" 862 863prop_handshake_sni :: PropertyM IO () 864prop_handshake_sni = do 865 ref <- run $ newIORef Nothing 866 (clientParam,serverParam) <- pick arbitraryPairParams 867 let clientParam' = clientParam { clientServerIdentification = (serverName, "") 868 } 869 serverParam' = serverParam { serverHooks = (serverHooks serverParam) 870 { onServerNameIndication = onSNI ref } 871 } 872 params' = (clientParam',serverParam') 873 runTLSPipe params' tlsServer tlsClient 874 receivedName <- run $ readIORef ref 875 Just (Just serverName) `assertEq` receivedName 876 where tlsServer ctx queue = do 877 handshake ctx 878 sni <- getClientSNI ctx 879 Just serverName `assertEq` sni 880 d <- recvData ctx 881 writeChan queue [d] 882 bye ctx 883 tlsClient queue ctx = do 884 handshake ctx 885 sni <- getClientSNI ctx 886 Just serverName `assertEq` sni 887 d <- readChan queue 888 sendData ctx (L.fromChunks [d]) 889 byeBye ctx 890 onSNI ref name = assertEmptyRef ref >> writeIORef ref (Just name) >> 891 return (Credentials []) 892 serverName = "haskell.org" 893 894prop_handshake_renegotiation :: PropertyM IO () 895prop_handshake_renegotiation = do 896 renegDisabled <- pick arbitrary 897 (cparams, sparams) <- pick arbitraryPairParams 898 let sparams' = sparams { 899 serverSupported = (serverSupported sparams) { 900 supportedClientInitiatedRenegotiation = not renegDisabled 901 } 902 } 903 if renegDisabled || isVersionEnabled TLS13 (cparams, sparams') 904 then runTLSInitFailureGen (cparams, sparams') hsServer hsClient 905 else runTLSPipe (cparams, sparams') tlsServer tlsClient 906 where tlsServer ctx queue = do 907 hsServer ctx 908 d <- recvData ctx 909 writeChan queue [d] 910 bye ctx 911 tlsClient queue ctx = do 912 hsClient ctx 913 d <- readChan queue 914 sendData ctx (L.fromChunks [d]) 915 byeBye ctx 916 hsServer = handshake 917 hsClient ctx = handshake ctx >> handshake ctx 918 919prop_handshake_session_resumption :: PropertyM IO () 920prop_handshake_session_resumption = do 921 sessionRefs <- run twoSessionRefs 922 let sessionManagers = twoSessionManagers sessionRefs 923 924 plainParams <- pick arbitraryPairParams 925 let params = setPairParamsSessionManagers sessionManagers plainParams 926 927 runTLSPipeSimple params 928 929 -- and resume 930 sessionParams <- run $ readClientSessionRef sessionRefs 931 assert (isJust sessionParams) 932 let params2 = setPairParamsSessionResuming (fromJust sessionParams) params 933 934 runTLSPipeSimple params2 935 936prop_thread_safety :: PropertyM IO () 937prop_thread_safety = do 938 params <- pick arbitraryPairParams 939 runTLSPipe params tlsServer tlsClient 940 where tlsServer ctx queue = do 941 handshake ctx 942 runReaderWriters ctx "client-value" "server-value" 943 d <- recvData ctx 944 writeChan queue [d] 945 bye ctx 946 tlsClient queue ctx = do 947 handshake ctx 948 runReaderWriters ctx "server-value" "client-value" 949 d <- readChan queue 950 sendData ctx (L.fromChunks [d]) 951 byeBye ctx 952 runReaderWriters ctx r w = 953 -- run concurrently 10 readers and 10 writers on the same context 954 let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w] 955 in runConcurrently $ traverse_ Concurrently workers 956 957assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () 958assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) 959 960assertIsLeft :: (Show b, Monad m) => Either a b -> m () 961assertIsLeft (Left _) = return () 962assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure") 963 964assertEmptyRef :: Show a => IORef (Maybe a) -> IO () 965assertEmptyRef ref = readIORef ref >>= maybe (return ()) (\a -> 966 error ("got " ++ show a ++ " but was expecting empty reference")) 967 968recvDataAssert :: Context -> C8.ByteString -> IO () 969recvDataAssert ctx expected = do 970 got <- recvData ctx 971 assertEq expected got 972 973main :: IO () 974main = defaultMain $ testGroup "tls" 975 [ tests_marshalling 976 , tests_ciphers 977 , tests_handshake 978 , tests_thread_safety 979 ] 980 where -- lowlevel tests to check the packet marshalling. 981 tests_marshalling = testGroup "Marshalling" 982 [ testProperty "Header" prop_header_marshalling_id 983 , testProperty "Handshake" prop_handshake_marshalling_id 984 , testProperty "Handshake13" prop_handshake13_marshalling_id 985 ] 986 tests_ciphers = testGroup "Ciphers" 987 [ testProperty "Bulk" propertyBulkFunctional ] 988 989 -- high level tests between a client and server with fake ciphers. 990 tests_handshake = testGroup "Handshakes" 991 [ testProperty "Setup" (monadicIO prop_pipe_work) 992 , testProperty "Initiation" (monadicIO prop_handshake_initiate) 993 , testProperty "Initiation 1.3" (monadicIO prop_handshake13_initiate) 994 , testProperty "Key update 1.3" (monadicIO prop_handshake_keyupdate) 995 , testProperty "Downgrade protection" (monadicIO prop_handshake13_downgrade) 996 , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures) 997 , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites) 998 , testProperty "Groups" (monadicIO prop_handshake_groups) 999 , testProperty "Elliptic curves" (monadicIO prop_handshake_ec) 1000 , testProperty "Certificate fallback (ciphers)" (monadicIO prop_handshake_cert_fallback) 1001 , testProperty "Certificate fallback (hash and signatures)" (monadicIO prop_handshake_cert_fallback_hs) 1002 , testProperty "Server key usage" (monadicIO prop_handshake_srv_key_usage) 1003 , testProperty "Client authentication" (monadicIO prop_handshake_client_auth) 1004 , testProperty "Client key usage" (monadicIO prop_handshake_clt_key_usage) 1005 , testProperty "Extended Master Secret" (monadicIO prop_handshake_ems) 1006 , testProperty "Extended Master Secret (resumption)" (monadicIO prop_handshake_session_resumption_ems) 1007 , testProperty "ALPN" (monadicIO prop_handshake_alpn) 1008 , testProperty "SNI" (monadicIO prop_handshake_sni) 1009 , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation) 1010 , testProperty "Resumption" (monadicIO prop_handshake_session_resumption) 1011 , testProperty "Custom DH" (monadicIO prop_handshake_dh) 1012 , testProperty "TLS 1.3 Full" (monadicIO prop_handshake13_full) 1013 , testProperty "TLS 1.3 HRR" (monadicIO prop_handshake13_hrr) 1014 , testProperty "TLS 1.3 PSK" (monadicIO prop_handshake13_psk) 1015 , testProperty "TLS 1.3 PSK -> HRR" (monadicIO prop_handshake13_psk_fallback) 1016 , testProperty "TLS 1.3 RTT0" (monadicIO prop_handshake13_rtt0) 1017 , testProperty "TLS 1.3 RTT0 -> PSK" (monadicIO prop_handshake13_rtt0_fallback) 1018 , testProperty "TLS 1.3 RTT0 length" (monadicIO prop_handshake13_rtt0_length) 1019 , testProperty "TLS 1.3 EE groups" (monadicIO prop_handshake13_ee_groups) 1020 , testProperty "TLS 1.3 Post-handshake auth" (monadicIO prop_post_handshake_auth) 1021 ] 1022 1023 -- test concurrent reads and writes 1024 tests_thread_safety = localOption (QuickCheckTests 10) $ 1025 testProperty "Thread safety" (monadicIO prop_thread_safety) 1026