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 shouldFail = null (clientHashSigs `intersect` serverHashSigs) 493 if shouldFail 494 then runTLSInitFailure (clientParam',serverParam') 495 else runTLSPipeSimple (clientParam',serverParam') 496 497-- Tests ability to use or ignore client "signature_algorithms" extension when 498-- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but 499-- the server RSA certificate has a SHA-1 signature that the client does not 500-- support. Server may choose the DSA certificate only when cipher 501-- DHE_DSS_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA 502-- certificate. 503prop_handshake_cert_fallback :: PropertyM IO () 504prop_handshake_cert_fallback = do 505 let clientVersions = [TLS12] 506 serverVersions = [TLS12] 507 commonCiphers = [ cipher_DHE_RSA_AES128_SHA1 ] 508 otherCiphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 509 , cipher_ECDHE_RSA_AES128CBC_SHA 510 , cipher_DHE_DSS_AES128_SHA1 511 ] 512 hashSignatures = [ (HashSHA256, SignatureRSA), (HashSHA1, SignatureDSS) ] 513 chainRef <- run $ newIORef Nothing 514 clientCiphers <- pick $ sublistOf otherCiphers 515 serverCiphers <- pick $ sublistOf otherCiphers 516 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 517 (clientVersions, serverVersions) 518 (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) 519 let clientParam' = clientParam { clientSupported = (clientSupported clientParam) 520 { supportedHashSignatures = hashSignatures } 521 , clientHooks = (clientHooks clientParam) 522 { onServerCertificate = \_ _ _ chain -> 523 writeIORef chainRef (Just chain) >> return [] } 524 } 525 dssDisallowed = cipher_DHE_DSS_AES128_SHA1 `notElem` clientCiphers 526 || cipher_DHE_DSS_AES128_SHA1 `notElem` serverCiphers 527 runTLSPipeSimple (clientParam',serverParam) 528 serverChain <- run $ readIORef chainRef 529 dssDisallowed `assertEq` isLeafRSA serverChain 530 531-- Same as above but testing with supportedHashSignatures directly instead of 532-- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the 533-- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by 534-- both client and server, the Ed25519 certificate is selected. Otherwise the 535-- server fallbacks to RSA. 536-- 537-- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 538-- unless client advertises explicit support. Currently this is not enforced by 539-- the library, which is useful to test this scenario. SHA-1 could be replaced 540-- by another algorithm. 541prop_handshake_cert_fallback_hs :: PropertyM IO () 542prop_handshake_cert_fallback_hs = do 543 tls13 <- pick arbitrary 544 let versions = if tls13 then [TLS13] else [TLS12] 545 ciphers = [ cipher_ECDHE_RSA_AES128GCM_SHA256 546 , cipher_ECDHE_ECDSA_AES128GCM_SHA256 547 , cipher_TLS13_AES128GCM_SHA256 548 ] 549 commonHS = [ (HashSHA256, SignatureRSA) 550 , (HashIntrinsic, SignatureRSApssRSAeSHA256) 551 ] 552 otherHS = [ (HashIntrinsic, SignatureEd25519) ] 553 chainRef <- run $ newIORef Nothing 554 clientHS <- pick $ sublistOf otherHS 555 serverHS <- pick $ sublistOf otherHS 556 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 557 (versions, versions) 558 (ciphers, ciphers) 559 let clientParam' = clientParam { clientSupported = (clientSupported clientParam) 560 { supportedHashSignatures = commonHS ++ clientHS } 561 , clientHooks = (clientHooks clientParam) 562 { onServerCertificate = \_ _ _ chain -> 563 writeIORef chainRef (Just chain) >> return [] } 564 } 565 serverParam' = serverParam { serverSupported = (serverSupported serverParam) 566 { supportedHashSignatures = commonHS ++ serverHS } 567 } 568 eddsaDisallowed = (HashIntrinsic, SignatureEd25519) `notElem` clientHS 569 || (HashIntrinsic, SignatureEd25519) `notElem` serverHS 570 runTLSPipeSimple (clientParam',serverParam') 571 serverChain <- run $ readIORef chainRef 572 eddsaDisallowed `assertEq` isLeafRSA serverChain 573 574prop_handshake_groups :: PropertyM IO () 575prop_handshake_groups = do 576 tls13 <- pick arbitrary 577 let versions = if tls13 then [TLS13] else [TLS12] 578 ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 579 , cipher_ECDHE_RSA_AES128CBC_SHA 580 , cipher_DHE_RSA_AES256GCM_SHA384 581 , cipher_DHE_RSA_AES128_SHA1 582 , cipher_TLS13_AES128GCM_SHA256 583 ] 584 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 585 (versions, versions) 586 (ciphers, ciphers) 587 clientGroups <- pick arbitraryGroups 588 serverGroups <- pick arbitraryGroups 589 denyCustom <- pick arbitrary 590 let groupUsage = if denyCustom then GroupUsageUnsupported "custom group denied" else GroupUsageValid 591 clientParam' = clientParam { clientSupported = (clientSupported clientParam) 592 { supportedGroups = clientGroups } 593 , clientHooks = (clientHooks clientParam) 594 { onCustomFFDHEGroup = \_ _ -> return groupUsage } 595 } 596 serverParam' = serverParam { serverSupported = (serverSupported serverParam) 597 { supportedGroups = serverGroups } 598 } 599 isCustom = maybe True isCustomDHParams (serverDHEParams serverParam') 600 mCustomGroup = serverDHEParams serverParam' >>= dhParamsGroup 601 isClientCustom = maybe True (`notElem` clientGroups) mCustomGroup 602 commonGroups = clientGroups `intersect` serverGroups 603 shouldFail = null commonGroups && (tls13 || isClientCustom && denyCustom) 604 p minfo = isNothing (minfo >>= infoNegotiatedGroup) == (null commonGroups && isCustom) 605 if shouldFail 606 then runTLSInitFailure (clientParam',serverParam') 607 else runTLSPipePredicate (clientParam',serverParam') p 608 609 610prop_handshake_dh :: PropertyM IO () 611prop_handshake_dh = do 612 let clientVersions = [TLS12] 613 serverVersions = [TLS12] 614 ciphers = [ cipher_DHE_RSA_AES128_SHA1 ] 615 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 616 (clientVersions, serverVersions) 617 (ciphers, ciphers) 618 let clientParam' = clientParam { clientSupported = (clientSupported clientParam) 619 { supportedGroups = [] } 620 } 621 let check (dh,shouldFail) = do 622 let serverParam' = serverParam { serverDHEParams = Just dh } 623 if shouldFail 624 then runTLSInitFailure (clientParam',serverParam') 625 else runTLSPipeSimple (clientParam',serverParam') 626 mapM_ check [(dhParams512,True) 627 ,(dhParams768,True) 628 ,(dhParams1024,False)] 629 630prop_handshake_srv_key_usage :: PropertyM IO () 631prop_handshake_srv_key_usage = do 632 tls13 <- pick arbitrary 633 let versions = if tls13 then [TLS13] else [TLS12,TLS11,TLS10,SSL3] 634 ciphers = [ cipher_ECDHE_RSA_AES128CBC_SHA 635 , cipher_TLS13_AES128GCM_SHA256 636 , cipher_DHE_RSA_AES128_SHA1 637 , cipher_AES256_SHA256 638 ] 639 (clientParam,serverParam) <- pick $ arbitraryPairParamsWithVersionsAndCiphers 640 (versions, versions) 641 (ciphers, ciphers) 642 usageFlags <- pick arbitraryKeyUsage 643 cred <- pick $ arbitraryRSACredentialWithUsage usageFlags 644 let serverParam' = serverParam 645 { serverShared = (serverShared serverParam) 646 { sharedCredentials = Credentials [cred] 647 } 648 } 649 hasDS = KeyUsage_digitalSignature `elem` usageFlags 650 hasKE = KeyUsage_keyEncipherment `elem` usageFlags 651 shouldSucceed = hasDS || (hasKE && not tls13) 652 if shouldSucceed 653 then runTLSPipeSimple (clientParam,serverParam') 654 else runTLSInitFailure (clientParam,serverParam') 655 656prop_handshake_client_auth :: PropertyM IO () 657prop_handshake_client_auth = do 658 (clientParam,serverParam) <- pick arbitraryPairParams 659 let clientVersions = supportedVersions $ clientSupported clientParam 660 serverVersions = supportedVersions $ serverSupported serverParam 661 version = maximum (clientVersions `intersect` serverVersions) 662 cred <- pick (arbitraryClientCredential version) 663 let clientParam' = clientParam { clientHooks = (clientHooks clientParam) 664 { onCertificateRequest = \_ -> return $ Just cred } 665 } 666 serverParam' = serverParam { serverWantClientCert = True 667 , serverHooks = (serverHooks serverParam) 668 { onClientCertificate = validateChain cred } 669 } 670 let shouldFail = version == TLS13 && isCredentialDSA cred 671 if shouldFail 672 then runTLSInitFailure (clientParam',serverParam') 673 else runTLSPipeSimple (clientParam',serverParam') 674 where validateChain cred chain 675 | chain == fst cred = return CertificateUsageAccept 676 | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) 677 678prop_post_handshake_auth :: PropertyM IO () 679prop_post_handshake_auth = do 680 (clientParam,serverParam) <- pick arbitraryPairParams13 681 cred <- pick (arbitraryClientCredential TLS13) 682 let clientParam' = clientParam { clientHooks = (clientHooks clientParam) 683 { onCertificateRequest = \_ -> return $ Just cred } 684 } 685 serverParam' = serverParam { serverHooks = (serverHooks serverParam) 686 { onClientCertificate = validateChain cred } 687 } 688 if isCredentialDSA cred 689 then runTLSInitFailureGen (clientParam',serverParam') hsServer hsClient 690 else runTLSPipe (clientParam',serverParam') tlsServer tlsClient 691 where validateChain cred chain 692 | chain == fst cred = return CertificateUsageAccept 693 | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) 694 tlsServer ctx queue = do 695 hsServer ctx 696 d <- recvData ctx 697 writeChan queue [d] 698 bye ctx 699 tlsClient queue ctx = do 700 hsClient ctx 701 d <- readChan queue 702 sendData ctx (L.fromChunks [d]) 703 byeBye ctx 704 hsServer ctx = do 705 handshake ctx 706 recvDataAssert ctx "request 1" 707 _ <- requestCertificate ctx -- single request 708 sendData ctx "response 1" 709 recvDataAssert ctx "request 2" 710 _ <- requestCertificate ctx 711 _ <- requestCertificate ctx -- two simultaneously 712 sendData ctx "response 2" 713 hsClient ctx = do 714 handshake ctx 715 sendData ctx "request 1" 716 recvDataAssert ctx "response 1" 717 sendData ctx "request 2" 718 recvDataAssert ctx "response 2" 719 720prop_handshake_clt_key_usage :: PropertyM IO () 721prop_handshake_clt_key_usage = do 722 (clientParam,serverParam) <- pick arbitraryPairParams 723 usageFlags <- pick arbitraryKeyUsage 724 cred <- pick $ arbitraryRSACredentialWithUsage usageFlags 725 let clientParam' = clientParam { clientHooks = (clientHooks clientParam) 726 { onCertificateRequest = \_ -> return $ Just cred } 727 } 728 serverParam' = serverParam { serverWantClientCert = True 729 , serverHooks = (serverHooks serverParam) 730 { onClientCertificate = \_ -> return CertificateUsageAccept } 731 } 732 shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags 733 if shouldSucceed 734 then runTLSPipeSimple (clientParam',serverParam') 735 else runTLSInitFailure (clientParam',serverParam') 736 737prop_handshake_ems :: PropertyM IO () 738prop_handshake_ems = do 739 (cems, sems) <- pick arbitraryEMSMode 740 params <- pick arbitraryPairParams 741 let params' = setEMSMode (cems, sems) params 742 version = getConnectVersion params' 743 emsVersion = version >= TLS10 && version <= TLS12 744 use = cems /= NoEMS && sems /= NoEMS 745 require = cems == RequireEMS || sems == RequireEMS 746 p info = infoExtendedMasterSec info == (emsVersion && use) 747 if emsVersion && require && not use 748 then runTLSInitFailure params' 749 else runTLSPipePredicate params' (maybe False p) 750 751prop_handshake_session_resumption_ems :: PropertyM IO () 752prop_handshake_session_resumption_ems = do 753 sessionRefs <- run twoSessionRefs 754 let sessionManagers = twoSessionManagers sessionRefs 755 756 plainParams <- pick arbitraryPairParams 757 ems <- pick (arbitraryEMSMode `suchThat` compatible) 758 let params = setEMSMode ems $ 759 setPairParamsSessionManagers sessionManagers plainParams 760 761 runTLSPipeSimple params 762 763 -- and resume 764 sessionParams <- run $ readClientSessionRef sessionRefs 765 assert (isJust sessionParams) 766 ems2 <- pick (arbitraryEMSMode `suchThat` compatible) 767 let params2 = setEMSMode ems2 $ 768 setPairParamsSessionResuming (fromJust sessionParams) params 769 770 let version = getConnectVersion params2 771 emsVersion = version >= TLS10 && version <= TLS12 772 773 if emsVersion && use ems && not (use ems2) 774 then runTLSInitFailure params2 775 else do 776 runTLSPipeSimple params2 777 sessionParams2 <- run $ readClientSessionRef sessionRefs 778 let sameSession = sessionParams == sessionParams2 779 sameUse = use ems == use ems2 780 when emsVersion $ assert (sameSession == sameUse) 781 where 782 compatible (NoEMS, RequireEMS) = False 783 compatible (RequireEMS, NoEMS) = False 784 compatible _ = True 785 786 use (NoEMS, _) = False 787 use (_, NoEMS) = False 788 use _ = True 789 790prop_handshake_alpn :: PropertyM IO () 791prop_handshake_alpn = do 792 (clientParam,serverParam) <- pick arbitraryPairParams 793 let clientParam' = clientParam { clientHooks = (clientHooks clientParam) 794 { onSuggestALPN = return $ Just ["h2", "http/1.1"] } 795 } 796 serverParam' = serverParam { serverHooks = (serverHooks serverParam) 797 { onALPNClientSuggest = Just alpn } 798 } 799 params' = (clientParam',serverParam') 800 runTLSPipe params' tlsServer tlsClient 801 where tlsServer ctx queue = do 802 handshake ctx 803 proto <- getNegotiatedProtocol ctx 804 Just "h2" `assertEq` proto 805 d <- recvData ctx 806 writeChan queue [d] 807 bye ctx 808 tlsClient queue ctx = do 809 handshake ctx 810 proto <- getNegotiatedProtocol ctx 811 Just "h2" `assertEq` proto 812 d <- readChan queue 813 sendData ctx (L.fromChunks [d]) 814 byeBye ctx 815 alpn xs 816 | "h2" `elem` xs = return "h2" 817 | otherwise = return "http/1.1" 818 819prop_handshake_sni :: PropertyM IO () 820prop_handshake_sni = do 821 ref <- run $ newIORef Nothing 822 (clientParam,serverParam) <- pick arbitraryPairParams 823 let clientParam' = clientParam { clientServerIdentification = (serverName, "") 824 } 825 serverParam' = serverParam { serverHooks = (serverHooks serverParam) 826 { onServerNameIndication = onSNI ref } 827 } 828 params' = (clientParam',serverParam') 829 runTLSPipe params' tlsServer tlsClient 830 receivedName <- run $ readIORef ref 831 Just (Just serverName) `assertEq` receivedName 832 where tlsServer ctx queue = do 833 handshake ctx 834 sni <- getClientSNI ctx 835 Just serverName `assertEq` sni 836 d <- recvData ctx 837 writeChan queue [d] 838 bye ctx 839 tlsClient queue ctx = do 840 handshake ctx 841 sni <- getClientSNI ctx 842 Just serverName `assertEq` sni 843 d <- readChan queue 844 sendData ctx (L.fromChunks [d]) 845 byeBye ctx 846 onSNI ref name = assertEmptyRef ref >> writeIORef ref (Just name) >> 847 return (Credentials []) 848 serverName = "haskell.org" 849 850prop_handshake_renegotiation :: PropertyM IO () 851prop_handshake_renegotiation = do 852 renegDisabled <- pick arbitrary 853 (cparams, sparams) <- pick arbitraryPairParams 854 let sparams' = sparams { 855 serverSupported = (serverSupported sparams) { 856 supportedClientInitiatedRenegotiation = not renegDisabled 857 } 858 } 859 if renegDisabled || isVersionEnabled TLS13 (cparams, sparams') 860 then runTLSInitFailureGen (cparams, sparams') hsServer hsClient 861 else runTLSPipe (cparams, sparams') tlsServer tlsClient 862 where tlsServer ctx queue = do 863 hsServer ctx 864 d <- recvData ctx 865 writeChan queue [d] 866 bye ctx 867 tlsClient queue ctx = do 868 hsClient ctx 869 d <- readChan queue 870 sendData ctx (L.fromChunks [d]) 871 byeBye ctx 872 hsServer = handshake 873 hsClient ctx = handshake ctx >> handshake ctx 874 875prop_handshake_session_resumption :: PropertyM IO () 876prop_handshake_session_resumption = do 877 sessionRefs <- run twoSessionRefs 878 let sessionManagers = twoSessionManagers sessionRefs 879 880 plainParams <- pick arbitraryPairParams 881 let params = setPairParamsSessionManagers sessionManagers plainParams 882 883 runTLSPipeSimple params 884 885 -- and resume 886 sessionParams <- run $ readClientSessionRef sessionRefs 887 assert (isJust sessionParams) 888 let params2 = setPairParamsSessionResuming (fromJust sessionParams) params 889 890 runTLSPipeSimple params2 891 892prop_thread_safety :: PropertyM IO () 893prop_thread_safety = do 894 params <- pick arbitraryPairParams 895 runTLSPipe params tlsServer tlsClient 896 where tlsServer ctx queue = do 897 handshake ctx 898 runReaderWriters ctx "client-value" "server-value" 899 d <- recvData ctx 900 writeChan queue [d] 901 bye ctx 902 tlsClient queue ctx = do 903 handshake ctx 904 runReaderWriters ctx "server-value" "client-value" 905 d <- readChan queue 906 sendData ctx (L.fromChunks [d]) 907 byeBye ctx 908 runReaderWriters ctx r w = 909 -- run concurrently 10 readers and 10 writers on the same context 910 let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w] 911 in runConcurrently $ traverse_ Concurrently workers 912 913assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () 914assertEq expected got = unless (expected == got) $ error ("got " ++ show got ++ " but was expecting " ++ show expected) 915 916assertIsLeft :: (Show b, Monad m) => Either a b -> m () 917assertIsLeft (Left _) = return () 918assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure") 919 920assertEmptyRef :: Show a => IORef (Maybe a) -> IO () 921assertEmptyRef ref = readIORef ref >>= maybe (return ()) (\a -> 922 error ("got " ++ show a ++ " but was expecting empty reference")) 923 924recvDataAssert :: Context -> C8.ByteString -> IO () 925recvDataAssert ctx expected = do 926 got <- recvData ctx 927 assertEq expected got 928 929main :: IO () 930main = defaultMain $ testGroup "tls" 931 [ tests_marshalling 932 , tests_ciphers 933 , tests_handshake 934 , tests_thread_safety 935 ] 936 where -- lowlevel tests to check the packet marshalling. 937 tests_marshalling = testGroup "Marshalling" 938 [ testProperty "Header" prop_header_marshalling_id 939 , testProperty "Handshake" prop_handshake_marshalling_id 940 , testProperty "Handshake13" prop_handshake13_marshalling_id 941 ] 942 tests_ciphers = testGroup "Ciphers" 943 [ testProperty "Bulk" propertyBulkFunctional ] 944 945 -- high level tests between a client and server with fake ciphers. 946 tests_handshake = testGroup "Handshakes" 947 [ testProperty "Setup" (monadicIO prop_pipe_work) 948 , testProperty "Initiation" (monadicIO prop_handshake_initiate) 949 , testProperty "Initiation 1.3" (monadicIO prop_handshake13_initiate) 950 , testProperty "Key update 1.3" (monadicIO prop_handshake_keyupdate) 951 , testProperty "Downgrade protection" (monadicIO prop_handshake13_downgrade) 952 , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures) 953 , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites) 954 , testProperty "Groups" (monadicIO prop_handshake_groups) 955 , testProperty "Certificate fallback (ciphers)" (monadicIO prop_handshake_cert_fallback) 956 , testProperty "Certificate fallback (hash and signatures)" (monadicIO prop_handshake_cert_fallback_hs) 957 , testProperty "Server key usage" (monadicIO prop_handshake_srv_key_usage) 958 , testProperty "Client authentication" (monadicIO prop_handshake_client_auth) 959 , testProperty "Client key usage" (monadicIO prop_handshake_clt_key_usage) 960 , testProperty "Extended Master Secret" (monadicIO prop_handshake_ems) 961 , testProperty "Extended Master Secret (resumption)" (monadicIO prop_handshake_session_resumption_ems) 962 , testProperty "ALPN" (monadicIO prop_handshake_alpn) 963 , testProperty "SNI" (monadicIO prop_handshake_sni) 964 , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation) 965 , testProperty "Resumption" (monadicIO prop_handshake_session_resumption) 966 , testProperty "Custom DH" (monadicIO prop_handshake_dh) 967 , testProperty "TLS 1.3 Full" (monadicIO prop_handshake13_full) 968 , testProperty "TLS 1.3 HRR" (monadicIO prop_handshake13_hrr) 969 , testProperty "TLS 1.3 PSK" (monadicIO prop_handshake13_psk) 970 , testProperty "TLS 1.3 PSK -> HRR" (monadicIO prop_handshake13_psk_fallback) 971 , testProperty "TLS 1.3 RTT0" (monadicIO prop_handshake13_rtt0) 972 , testProperty "TLS 1.3 RTT0 -> PSK" (monadicIO prop_handshake13_rtt0_fallback) 973 , testProperty "TLS 1.3 RTT0 length" (monadicIO prop_handshake13_rtt0_length) 974 , testProperty "TLS 1.3 EE groups" (monadicIO prop_handshake13_ee_groups) 975 , testProperty "TLS 1.3 Post-handshake auth" (monadicIO prop_post_handshake_auth) 976 ] 977 978 -- test concurrent reads and writes 979 tests_thread_safety = localOption (QuickCheckTests 10) $ 980 testProperty "Thread safety" (monadicIO prop_thread_safety) 981