From 73a270a965857139cbfeb8fb45f58dfc927159cf Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 5 Dec 2023 09:13:37 +0900 Subject: [PATCH 01/26] hspec for encoder/decoder --- core/test/Arbitrary.hs | 168 +++++++++++++++++++++++++++++++++++++++ core/test/Certificate.hs | 161 +++++++++++++++++++++++++++++++++++++ core/test/EncodeSpec.hs | 39 +++++++++ core/test/PubKey.hs | 155 ++++++++++++++++++++++++++++++++++++ core/test/Spec.hs | 1 + core/tls.cabal | 34 ++++---- 6 files changed, 539 insertions(+), 19 deletions(-) create mode 100644 core/test/Arbitrary.hs create mode 100644 core/test/Certificate.hs create mode 100644 core/test/EncodeSpec.hs create mode 100644 core/test/PubKey.hs create mode 100644 core/test/Spec.hs diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs new file mode 100644 index 000000000..1f83929fe --- /dev/null +++ b/core/test/Arbitrary.hs @@ -0,0 +1,168 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Arbitrary where + +import Control.Monad +import qualified Data.ByteString as B +import Data.Word +import Data.X509 (CertificateChain (..)) +import Network.TLS +import Network.TLS.Internal +import Test.QuickCheck + +import Certificate + +genByteString :: Int -> Gen B.ByteString +genByteString i = B.pack <$> vector i + +instance Arbitrary Version where + arbitrary = elements [TLS12, TLS13] + +instance Arbitrary ProtocolType where + arbitrary = + elements + [ ProtocolType_ChangeCipherSpec + , ProtocolType_Alert + , ProtocolType_Handshake + , ProtocolType_AppData + ] + +instance Arbitrary Header where + arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary ClientRandom where + arbitrary = ClientRandom <$> genByteString 32 + +instance Arbitrary ServerRandom where + arbitrary = ServerRandom <$> genByteString 32 + +instance Arbitrary Session where + arbitrary = do + i <- choose (1, 2) :: Gen Int + case i of + 2 -> Session . Just <$> genByteString 32 + _ -> return $ Session Nothing + +instance Arbitrary HashAlgorithm where + arbitrary = + elements + [ Network.TLS.HashNone + , Network.TLS.HashMD5 + , Network.TLS.HashSHA1 + , Network.TLS.HashSHA224 + , Network.TLS.HashSHA256 + , Network.TLS.HashSHA384 + , Network.TLS.HashSHA512 + , Network.TLS.HashIntrinsic + ] + +instance Arbitrary SignatureAlgorithm where + arbitrary = + elements + [ SignatureAnonymous + , SignatureRSA + , SignatureDSA + , SignatureECDSA + , SignatureRSApssRSAeSHA256 + , SignatureRSApssRSAeSHA384 + , SignatureRSApssRSAeSHA512 + , SignatureEd25519 + , SignatureEd448 + , SignatureRSApsspssSHA256 + , SignatureRSApsspssSHA384 + , SignatureRSApsspssSHA512 + ] + +instance Arbitrary DigitallySigned where + arbitrary = DigitallySigned <$> arbitrary <*> genByteString 32 + +arbitraryCiphersIDs :: Gen [Word16] +arbitraryCiphersIDs = choose (0, 200) >>= vector + +arbitraryCompressionIDs :: Gen [Word8] +arbitraryCompressionIDs = choose (0, 200) >>= vector + +someWords8 :: Int -> Gen [Word8] +someWords8 = vector + +instance Arbitrary ExtensionRaw where + arbitrary = + let arbitraryContent = choose (0, 40) >>= genByteString + in ExtensionRaw <$> (ExtensionID <$> arbitrary) <*> arbitraryContent + +arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw] +arbitraryHelloExtensions _ver = arbitrary + +instance Arbitrary CertificateType where + arbitrary = + elements + [ CertificateType_RSA_Sign + , CertificateType_DSA_Sign + , CertificateType_ECDSA_Sign + ] + +instance Arbitrary Handshake where + arbitrary = + oneof + [ arbitrary >>= \ver -> + ClientHello ver + <$> arbitrary + <*> arbitrary + <*> arbitraryCiphersIDs + <*> arbitraryCompressionIDs + <*> arbitraryHelloExtensions ver + <*> return Nothing + , arbitrary >>= \ver -> + ServerHello ver + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryHelloExtensions ver + , Certificates . CertificateChain <$> resize 2 (listOf arbitraryX509) + , pure HelloRequest + , pure ServerHelloDone + , ClientKeyXchg . CKX_RSA <$> genByteString 48 + , CertRequest <$> arbitrary <*> arbitrary <*> listOf arbitraryDN + , CertVerify <$> arbitrary + , Finished <$> genByteString 12 + ] + +arbitraryCertReqContext :: Gen B.ByteString +arbitraryCertReqContext = oneof [return B.empty, genByteString 32] + +instance Arbitrary Handshake13 where + arbitrary = + oneof + [ arbitrary >>= \ver -> + ClientHello13 ver + <$> arbitrary + <*> arbitrary + <*> arbitraryCiphersIDs + <*> arbitraryHelloExtensions ver + , arbitrary >>= \ver -> + ServerHello13 + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitraryHelloExtensions ver + , NewSessionTicket13 + <$> arbitrary + <*> arbitrary + <*> genByteString 32 -- nonce + <*> genByteString 32 -- session ID + <*> arbitrary + , pure EndOfEarlyData13 + , EncryptedExtensions13 <$> arbitrary + , CertRequest13 + <$> arbitraryCertReqContext + <*> arbitrary + , resize 2 (listOf arbitraryX509) >>= \certs -> + Certificate13 + <$> arbitraryCertReqContext + <*> return (CertificateChain certs) + <*> replicateM (length certs) arbitrary + , CertVerify13 <$> arbitrary <*> genByteString 32 + , Finished13 <$> genByteString 12 + , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested] + ] diff --git a/core/test/Certificate.hs b/core/test/Certificate.hs new file mode 100644 index 000000000..951d8cb0d --- /dev/null +++ b/core/test/Certificate.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Certificate ( + arbitraryX509, + arbitraryX509WithKey, + arbitraryX509WithKeyAndUsage, + arbitraryDN, + arbitraryKeyUsage, + simpleCertificate, + simpleX509, + toPubKeyEC, + toPrivKeyEC, +) where + +import Crypto.Number.Serialize (i2ospOf_) +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Types as ECC +import Data.ASN1.OID +import qualified Data.ByteString as B +import Data.Hourglass +import Data.X509 +import Test.QuickCheck + +import PubKey + +arbitraryDN :: Gen DistinguishedName +arbitraryDN = return $ DistinguishedName [] + +instance Arbitrary Date where + arbitrary = do + y <- choose (1971, 2035) + m <- elements [January .. December] + d <- choose (1, 30) + return $ normalizeDate $ Date y m d + +normalizeDate :: Date -> Date +normalizeDate d = timeConvert (timeConvert d :: Elapsed) + +instance Arbitrary TimeOfDay where + arbitrary = do + h <- choose (0, 23) + mi <- choose (0, 59) + se <- choose (0, 59) + nsec <- return 0 + return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec + +instance Arbitrary DateTime where + arbitrary = DateTime <$> arbitrary <*> arbitrary + +maxSerial :: Integer +maxSerial = 16777216 + +arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate +arbitraryCertificate usageFlags pubKey = do + serial <- choose (0, maxSerial) + subjectdn <- arbitraryDN + validity <- (,) <$> arbitrary <*> arbitrary + let sigalg = getSignatureALG pubKey + return $ + Certificate + { certVersion = 3 + , certSerial = serial + , certSignatureAlg = sigalg + , certIssuerDN = issuerdn + , certSubjectDN = subjectdn + , certValidity = validity + , certPubKey = pubKey + , certExtensions = + Extensions $ + Just + [ extensionEncode True $ ExtKeyUsage usageFlags + ] + } + where + issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")] + +simpleCertificate :: PubKey -> Certificate +simpleCertificate pubKey = + Certificate + { certVersion = 3 + , certSerial = 0 + , certSignatureAlg = getSignatureALG pubKey + , certIssuerDN = simpleDN + , certSubjectDN = simpleDN + , certValidity = (time1, time2) + , certPubKey = pubKey + , certExtensions = + Extensions $ + Just + [ extensionEncode True $ + ExtKeyUsage [KeyUsage_digitalSignature, KeyUsage_keyEncipherment] + ] + } + where + time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0) + time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0) + simpleDN = DistinguishedName [] + +simpleX509 :: PubKey -> SignedCertificate +simpleX509 pubKey = + let cert = simpleCertificate pubKey + sig = replicate 40 1 + sigalg = getSignatureALG pubKey + (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert + in signedExact + +arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate +arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage + +arbitraryX509WithKeyAndUsage + :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate +arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do + cert <- arbitraryCertificate usageFlags pubKey + sig <- resize 40 $ listOf1 arbitrary + let sigalg = getSignatureALG pubKey + let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig, sigalg, ())) cert + return signedExact + +arbitraryX509 :: Gen SignedCertificate +arbitraryX509 = do + let (pubKey, privKey) = getGlobalRSAPair + arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) + +arbitraryKeyUsage :: Gen [ExtKeyUsageFlag] +arbitraryKeyUsage = sublistOf knownKeyUsage + +knownKeyUsage :: [ExtKeyUsageFlag] +knownKeyUsage = + [ KeyUsage_digitalSignature + , KeyUsage_keyEncipherment + , KeyUsage_keyAgreement + ] + +getSignatureALG :: PubKey -> SignatureALG +getSignatureALG (PubKeyRSA _) = SignatureALG HashSHA1 PubKeyALG_RSA +getSignatureALG (PubKeyDSA _) = SignatureALG HashSHA1 PubKeyALG_DSA +getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC +getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 +getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448 +getSignatureALG pubKey = + error $ "getSignatureALG: unsupported public key: " ++ show pubKey + +toPubKeyEC :: ECC.CurveName -> ECDSA.PublicKey -> PubKey +toPubKeyEC curveName key = + let (x, y) = fromPoint $ ECDSA.public_q key + pub = SerializedPoint bs + bs = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y) + bits = ECC.curveSizeBits (ECC.getCurveByName curveName) + bytes = (bits + 7) `div` 8 + in PubKeyEC (PubKeyEC_Named curveName pub) + +toPrivKeyEC :: ECC.CurveName -> ECDSA.PrivateKey -> PrivKey +toPrivKeyEC curveName key = + let priv = ECDSA.private_d key + in PrivKeyEC (PrivKeyEC_Named curveName priv) + +fromPoint :: ECC.Point -> (Integer, Integer) +fromPoint (ECC.Point x y) = (x, y) +fromPoint _ = error "fromPoint" diff --git a/core/test/EncodeSpec.hs b/core/test/EncodeSpec.hs new file mode 100644 index 000000000..35d0946da --- /dev/null +++ b/core/test/EncodeSpec.hs @@ -0,0 +1,39 @@ +module EncodeSpec where + +import Data.ByteString (ByteString) +import Network.TLS +import Network.TLS.Internal +import Test.Hspec +import Test.QuickCheck + +import Arbitrary () + +spec :: Spec +spec = do + describe "encoder/decoder" $ do + it "can encode/decode Header" $ property $ \x -> do + decodeHeader (encodeHeader x) `shouldBe` Right x + it "can encode/decode Handshake" $ property $ \x -> do + decodeHs (encodeHandshake x) `shouldBe` Right x + it "can encode/decode Handshake13" $ property $ \x -> do + decodeHs13 (encodeHandshake13 x) `shouldBe` Right x + +decodeHs :: ByteString -> Either TLSError Handshake +decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b + where + cp = + CurrentParams + { cParamsVersion = TLS12 + , cParamsKeyXchgType = Just CipherKeyExchange_RSA + } + +decodeHs13 :: ByteString -> Either TLSError Handshake13 +decodeHs13 b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b + +verifyResult :: (f -> r -> a) -> GetResult (f, r) -> a +verifyResult fn result = + case result of + GotPartial _ -> error "got partial" + GotError e -> error ("got error: " ++ show e) + GotSuccessRemaining _ _ -> error "got remaining byte left" + GotSuccess (ty, content) -> fn ty content diff --git a/core/test/PubKey.hs b/core/test/PubKey.hs new file mode 100644 index 000000000..3e2ba415e --- /dev/null +++ b/core/test/PubKey.hs @@ -0,0 +1,155 @@ +module PubKey ( + arbitraryRSAPair, + arbitraryDSAPair, + arbitraryECDSAPair, + arbitraryEd25519Pair, + arbitraryEd448Pair, + globalRSAPair, + getGlobalRSAPair, + knownECCurves, + defaultECCurve, + dhParams512, + dhParams768, + dhParams1024, + dsaParams, + rsaParams, +) where + +import Control.Concurrent.MVar +import Crypto.Error +import qualified Crypto.PubKey.DH as DH +import qualified Crypto.PubKey.DSA as DSA +import qualified Crypto.PubKey.ECC.ECDSA as ECDSA +import qualified Crypto.PubKey.ECC.Prim as ECC +import qualified Crypto.PubKey.ECC.Types as ECC +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.RSA as RSA +import Crypto.Random +import qualified Data.ByteString as B +import System.IO.Unsafe +import Test.QuickCheck + +arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey) +arbitraryRSAPair = (rngToRSA . drgNewTest) `fmap` arbitrary + where + rngToRSA :: ChaChaDRG -> (RSA.PublicKey, RSA.PrivateKey) + rngToRSA rng = fst $ withDRG rng arbitraryRSAPairWithRNG + +arbitraryRSAPairWithRNG :: MonadRandom m => m (RSA.PublicKey, RSA.PrivateKey) +arbitraryRSAPairWithRNG = RSA.generate 256 0x10001 + +{-# NOINLINE globalRSAPair #-} +globalRSAPair :: MVar (RSA.PublicKey, RSA.PrivateKey) +globalRSAPair = unsafePerformIO $ do + drg <- drgNew + newMVar (fst $ withDRG drg arbitraryRSAPairWithRNG) + +{-# NOINLINE getGlobalRSAPair #-} +getGlobalRSAPair :: (RSA.PublicKey, RSA.PrivateKey) +getGlobalRSAPair = unsafePerformIO (readMVar globalRSAPair) + +rsaParams :: (RSA.PublicKey, RSA.PrivateKey) +rsaParams = (pub, priv) + where + priv = + RSA.PrivateKey + { RSA.private_pub = pub + , RSA.private_d = d + , RSA.private_p = 0 + , RSA.private_q = 0 + , RSA.private_dP = 0 + , RSA.private_dQ = 0 + , RSA.private_qinv = 0 + } + pub = + RSA.PublicKey + { RSA.public_size = (1024 `div` 8) + , RSA.public_n = n + , RSA.public_e = e + } + n = + 0x00c086b4c6db28ae578d73766d6fdd04b913808a85bf9ad7bcfc9a6ff04d13d2ff75f761ce7db9ee8996e29dc433d19a2d3f748e8d368ba099781d58276e1863a324ae3fb1a061874cd9f3510e54e49727c68de0616964335371cfb63f15ebff8ce8df09c74fb8625f8f58548b90f079a3405f522e738e664d0c645b015664f7c7 + e = 0x10001 + d = + 0x3edc3cae28e4717818b1385ba7088d0038c3e176a606d2a5dbfc38cc46fe500824e62ec312fde04a803f61afac13a5b95c5c9c26b346879b54429083df488b4f29bb7b9722d366d6f5d2b512150a2e950eacfe0fd9dd56b87b0322f74ae3c8d8674ace62bc723f7c05e9295561efd70d7a924c6abac2e482880fc0149d5ad481 + +dhParams512 :: DH.Params +dhParams512 = + DH.Params + { DH.params_p = + 0x00ccaa3884b50789ebea8d39bef8bbc66e20f2a78f537a76f26b4edde5de8b0ff15a8193abf0873cbdc701323a2bf6e860affa6e043fe8300d47e95baf9f6354cb + , DH.params_g = 0x2 + , DH.params_bits = 512 + } + +-- from RFC 2409 + +dhParams768 :: DH.Params +dhParams768 = + DH.Params + { DH.params_p = + 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a63a3620ffffffffffffffff + , DH.params_g = 0x2 + , DH.params_bits = 768 + } + +dhParams1024 :: DH.Params +dhParams1024 = + DH.Params + { DH.params_p = + 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7edee386bfb5a899fa5ae9f24117c4b1fe649286651ece65381ffffffffffffffff + , DH.params_g = 0x2 + , DH.params_bits = 1024 + } + +dsaParams :: DSA.Params +dsaParams = + DSA.Params + { DSA.params_p = + 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb + , DSA.params_q = 0x00f33a57b47de86ff836f9fe0bb060c54ab293133b + , DSA.params_g = + 0x3bb973c4f6eee92d1530f250487735595d778c2e5c8147d67a46ebcba4e6444350d49da8e7da667f9b1dbb22d2108870b9fcfabc353cdfac5218d829f22f69130317cc3b0d724881e34c34b8a2571d411da6458ef4c718df9e826f73e16a035b1dcbc1c62cac7a6604adb3e7930be8257944c6dfdddd655004b98253185775ff + } + +arbitraryDSAPair :: Gen (DSA.PublicKey, DSA.PrivateKey) +arbitraryDSAPair = do + priv <- choose (1, DSA.params_q dsaParams) + let pub = DSA.calculatePublic dsaParams priv + return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv) + +-- for performance reason P521 is not tested +knownECCurves :: [ECC.CurveName] +knownECCurves = + [ ECC.SEC_p256r1 + , ECC.SEC_p384r1 + ] + +defaultECCurve :: ECC.CurveName +defaultECCurve = ECC.SEC_p256r1 + +arbitraryECDSAPair :: ECC.CurveName -> Gen (ECDSA.PublicKey, ECDSA.PrivateKey) +arbitraryECDSAPair curveName = do + d <- choose (1, n - 1) + let p = ECC.pointBaseMul curve d + return (ECDSA.PublicKey curve p, ECDSA.PrivateKey curve d) + where + curve = ECC.getCurveByName curveName + n = ECC.ecc_n . ECC.common_curve $ curve + +arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey) +arbitraryEd25519Pair = do + bytes <- vectorOf 32 arbitrary + let priv = fromCryptoPassed $ Ed25519.secretKey (B.pack bytes) + return (Ed25519.toPublic priv, priv) + +arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey) +arbitraryEd448Pair = do + bytes <- vectorOf 57 arbitrary + let priv = fromCryptoPassed $ Ed448.secretKey (B.pack bytes) + return (Ed448.toPublic priv, priv) + +fromCryptoPassed :: CryptoFailable a -> a +fromCryptoPassed (CryptoPassed x) = x +fromCryptoPassed _ = error "fromCryptoPassed" diff --git a/core/test/Spec.hs b/core/test/Spec.hs new file mode 100644 index 000000000..a824f8c30 --- /dev/null +++ b/core/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/core/tls.cabal b/core/tls.cabal index 4fc5b1f6f..6f631bcc2 100644 --- a/core/tls.cabal +++ b/core/tls.cabal @@ -122,34 +122,30 @@ library network >= 3.1 && < 3.2, unix-time >= 0.4.11 && < 0.5 -test-suite test-tls - type: exitcode-stdio-1.0 - main-is: Tests.hs - hs-source-dirs: Tests +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover + hs-source-dirs: test other-modules: + EncodeSpec + Arbitrary Certificate - Ciphers - Connection - Marshalling - PipeChan PubKey - default-language: Haskell2010 - ghc-options: -Wall + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts build-depends: - base >=3 && <5, - async >=2.0, - data-default-class, - tasty, - tasty-quickcheck, - tls, + base >=4.9 && <5, QuickCheck, - crypton, + hspec, + tls, bytestring, - asn1-types, crypton-x509, crypton-x509-validation, - hourglass + hourglass, + crypton, + asn1-types benchmark bench-tls type: exitcode-stdio-1.0 From 119c8428a6c97a0e195c0e7b0dbf1d48f2781cdc Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 5 Dec 2023 09:37:03 +0900 Subject: [PATCH 02/26] CiphersSpec --- core/test/CiphersSpec.hs | 74 ++++++++++++++++++++++++++++++++++++++++ core/tls.cabal | 3 +- 2 files changed, 76 insertions(+), 1 deletion(-) create mode 100644 core/test/CiphersSpec.hs diff --git a/core/test/CiphersSpec.hs b/core/test/CiphersSpec.hs new file mode 100644 index 000000000..c36ef77e0 --- /dev/null +++ b/core/test/CiphersSpec.hs @@ -0,0 +1,74 @@ +module CiphersSpec where + +import Test.Hspec +import Test.QuickCheck + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Network.TLS.Cipher +import Network.TLS.Extra.Cipher + +spec :: Spec +spec = do + describe "ciphers" $ do + it "can ecnrypt/decrypt" $ property $ \(BulkTest bulk key iv t additional) -> do + let enc = bulkInit bulk BulkEncrypt key + dec = bulkInit bulk BulkDecrypt key + case (enc, dec) of + (BulkStateBlock encF, BulkStateBlock decF) -> block encF decF iv t + (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF iv t additional + (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF t + _ -> return () + +block + :: BulkBlock + -> BulkBlock + -> BulkIV + -> ByteString + -> IO () +block e d iv t = do + let (etxt, e_iv) = e iv t + (dtxt, d_iv) = d iv etxt + dtxt `shouldBe` t + d_iv `shouldBe` e_iv + +stream + :: (ByteString -> (ByteString, BulkStream)) + -> (ByteString -> (ByteString, BulkStream)) + -> ByteString + -> Expectation +stream e d t = (fst . d . fst . e) t `shouldBe` t + +aead + :: BulkAEAD + -> BulkAEAD + -> BulkNonce + -> ByteString + -> BulkAdditionalData + -> Expectation +aead e d iv t additional = do + let (encrypted, at) = e iv t additional + (decrypted, at2) = d iv encrypted additional + decrypted `shouldBe` t + at `shouldBe` at2 + +arbitraryKey :: Bulk -> Gen B.ByteString +arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk) + +arbitraryIV :: Bulk -> Gen B.ByteString +arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk) + +arbitraryText :: Bulk -> Gen B.ByteString +arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) + +data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString + deriving (Show, Eq) + +instance Arbitrary BulkTest where + arbitrary = do + bulk <- cipherBulk `fmap` elements ciphersuite_all + BulkTest bulk + <$> arbitraryKey bulk + <*> arbitraryIV bulk + <*> arbitraryText bulk + <*> arbitraryText bulk diff --git a/core/tls.cabal b/core/tls.cabal index 6f631bcc2..5ab8f4825 100644 --- a/core/tls.cabal +++ b/core/tls.cabal @@ -128,9 +128,10 @@ test-suite spec build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: test other-modules: - EncodeSpec Arbitrary Certificate + CiphersSpec + EncodeSpec PubKey default-language: Haskell2010 From 398db6699d1cc923a945cdeb5ecd76fa9e00398a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 5 Dec 2023 10:22:17 +0900 Subject: [PATCH 03/26] hspec for thread safety --- core/test/Arbitrary.hs | 334 ++++++++++++++++++++++++++++++++++++++-- core/test/PipeChan.hs | 74 +++++++++ core/test/Run.hs | 161 +++++++++++++++++++ core/test/ThreadSpec.hs | 46 ++++++ core/tls.cabal | 13 +- 5 files changed, 615 insertions(+), 13 deletions(-) create mode 100644 core/test/PipeChan.hs create mode 100644 core/test/Run.hs create mode 100644 core/test/ThreadSpec.hs diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index 1f83929fe..c235afd2e 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -4,13 +4,23 @@ module Arbitrary where import Control.Monad import qualified Data.ByteString as B +import Data.Default.Class +import Data.List import Data.Word -import Data.X509 (CertificateChain (..)) +import Data.X509 ( + CertificateChain (..), + ExtKeyUsageFlag, + certPubKey, + getCertificate, + ) import Network.TLS +import Network.TLS.Extra.Cipher +import Network.TLS.Extra.FFDHE import Network.TLS.Internal import Test.QuickCheck import Certificate +import PubKey genByteString :: Int -> Gen B.ByteString genByteString i = B.pack <$> vector i @@ -46,14 +56,14 @@ instance Arbitrary Session where instance Arbitrary HashAlgorithm where arbitrary = elements - [ Network.TLS.HashNone - , Network.TLS.HashMD5 - , Network.TLS.HashSHA1 - , Network.TLS.HashSHA224 - , Network.TLS.HashSHA256 - , Network.TLS.HashSHA384 - , Network.TLS.HashSHA512 - , Network.TLS.HashIntrinsic + [ HashNone + , HashMD5 + , HashSHA1 + , HashSHA224 + , HashSHA256 + , HashSHA384 + , HashSHA512 + , HashIntrinsic ] instance Arbitrary SignatureAlgorithm where @@ -166,3 +176,309 @@ instance Arbitrary Handshake13 where , Finished13 <$> genByteString 12 , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested] ] + +knownCiphers :: [Cipher] +knownCiphers = ciphersuite_all ++ ciphersuite_weak + where + ciphersuite_weak = + [ cipher_null_SHA1 + ] + +arbitraryCiphers :: Gen [Cipher] +arbitraryCiphers = listOf1 $ elements knownCiphers + +knownVersions :: [Version] +knownVersions = [TLS13, TLS12] + +arbitraryVersions :: Gen [Version] +arbitraryVersions = sublistOf knownVersions + +-- for performance reason ecdsa_secp521r1_sha512 is not tested +knownHashSignatures :: [HashAndSignatureAlgorithm] +knownHashSignatures = + [ (HashIntrinsic, SignatureRSApssRSAeSHA512) + , (HashIntrinsic, SignatureRSApssRSAeSHA384) + , (HashIntrinsic, SignatureRSApssRSAeSHA256) + , (HashIntrinsic, SignatureEd25519) + , (HashIntrinsic, SignatureEd448) + , (HashSHA512, SignatureRSA) + , (HashSHA384, SignatureRSA) + , (HashSHA384, SignatureECDSA) + , (HashSHA256, SignatureRSA) + , (HashSHA256, SignatureECDSA) + , (HashSHA1, SignatureRSA) + , (HashSHA1, SignatureDSA) + ] + +knownHashSignatures13 :: [HashAndSignatureAlgorithm] +knownHashSignatures13 = filter compat knownHashSignatures + where + compat (h, s) = h /= HashSHA1 && s /= SignatureDSA && s /= SignatureRSA + +arbitraryHashSignatures :: Version -> Gen [HashAndSignatureAlgorithm] +arbitraryHashSignatures v = sublistOf l + where + l = if v < TLS13 then knownHashSignatures else knownHashSignatures13 + +-- for performance reason P521, FFDHE6144, FFDHE8192 are not tested +knownGroups, knownECGroups, knownFFGroups :: [Group] +knownECGroups = [P256, P384, X25519, X448] +knownFFGroups = [FFDHE2048, FFDHE3072, FFDHE4096] +knownGroups = knownECGroups ++ knownFFGroups + +defaultECGroup :: Group +defaultECGroup = P256 -- same as defaultECCurve + +otherKnownECGroups :: [Group] +otherKnownECGroups = filter (/= defaultECGroup) knownECGroups + +arbitraryGroups :: Gen [Group] +arbitraryGroups = scale (min 5) $ listOf1 $ elements knownGroups + +isCredentialDSA :: (CertificateChain, PrivKey) -> Bool +isCredentialDSA (_, PrivKeyDSA _) = True +isCredentialDSA _ = False + +arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachType = arbitraryCredentialsOfEachType' >>= shuffle + +arbitraryCredentialsOfEachType' :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachType' = do + let (pubKey, privKey) = getGlobalRSAPair + curveName = defaultECCurve + (dsaPub, dsaPriv) <- arbitraryDSAPair + (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName + (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair + (ed448Pub, ed448Priv) <- arbitraryEd448Pair + mapM + ( \(pub, priv) -> do + cert <- arbitraryX509WithKey (pub, priv) + return (CertificateChain [cert], priv) + ) + [ (PubKeyRSA pubKey, PrivKeyRSA privKey) + , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) + , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) + , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) + , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) + ] + +arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachCurve = arbitraryCredentialsOfEachCurve' >>= shuffle + +arbitraryCredentialsOfEachCurve' :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachCurve' = do + ecdsaPairs <- + mapM + ( \curveName -> do + (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName + return (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) + ) + knownECCurves + (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair + (ed448Pub, ed448Priv) <- arbitraryEd448Pair + mapM + ( \(pub, priv) -> do + cert <- arbitraryX509WithKey (pub, priv) + return (CertificateChain [cert], priv) + ) + $ [ (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) + , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) + ] + ++ ecdsaPairs + +dhParamsGroup :: DHParams -> Maybe Group +dhParamsGroup params + | params == ffdhe2048 = Just FFDHE2048 + | params == ffdhe3072 = Just FFDHE3072 + | otherwise = Nothing + +isCustomDHParams :: DHParams -> Bool +isCustomDHParams params = params == dhParams512 + +leafPublicKey :: CertificateChain -> Maybe PubKey +leafPublicKey (CertificateChain []) = Nothing +leafPublicKey (CertificateChain (leaf : _)) = Just (certPubKey $ getCertificate leaf) + +isLeafRSA :: Maybe CertificateChain -> Bool +isLeafRSA chain = case chain >>= leafPublicKey of + Just (PubKeyRSA _) -> True + _ -> False + +arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) +arbitraryCipherPair connectVersion = do + serverCiphers <- + arbitraryCiphers + `suchThat` (\cs -> or [cipherAllowedForVersion connectVersion x | x <- cs]) + clientCiphers <- + arbitraryCiphers + `suchThat` ( \cs -> + or + [ x `elem` serverCiphers + && cipherAllowedForVersion connectVersion x + | x <- cs + ] + ) + return (clientCiphers, serverCiphers) + +arbitraryPairParams :: Gen (ClientParams, ServerParams) +arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt + +-- Pair of groups so that at least the default EC group P256 and one FF group +-- are in common. This makes DHE and ECDHE ciphers always compatible with +-- extension "Supported Elliptic Curves" / "Supported Groups". +arbitraryGroupPair :: Gen ([Group], [Group]) +arbitraryGroupPair = do + (serverECGroups, clientECGroups) <- + arbitraryGroupPairWith defaultECGroup otherKnownECGroups + (serverFFGroups, clientFFGroups) <- arbitraryGroupPairFrom knownFFGroups + serverGroups <- shuffle (serverECGroups ++ serverFFGroups) + clientGroups <- shuffle (clientECGroups ++ clientFFGroups) + return (clientGroups, serverGroups) + where + arbitraryGroupPairFrom list = + elements list >>= \e -> + arbitraryGroupPairWith e (filter (/= e) list) + arbitraryGroupPairWith e es = do + s <- sublistOf es + c <- sublistOf es + return (e : s, e : c) + +arbitraryPairParams13 :: Gen (ClientParams, ServerParams) +arbitraryPairParams13 = arbitraryPairParamsAt TLS13 + +arbitraryPairParamsAt :: Version -> Gen (ClientParams, ServerParams) +arbitraryPairParamsAt connectVersion = do + (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion + -- Select version lists containing connectVersion, as well as some other + -- versions for which we have compatible ciphers. Criteria about cipher + -- ensure we can test version downgrade. + let allowedVersions = + [ v | v <- knownVersions, or + [ x `elem` serverCiphers + && cipherAllowedForVersion v x + | x <- clientCiphers + ] + ] + allowedVersionsFiltered = filter (<= connectVersion) allowedVersions + -- Server or client is allowed to have versions > connectVersion, but not + -- both simultaneously. + filterSrv <- arbitrary + let (clientAllowedVersions, serverAllowedVersions) + | filterSrv = (allowedVersions, allowedVersionsFiltered) + | otherwise = (allowedVersionsFiltered, allowedVersions) + -- Generate version lists containing less than 127 elements, otherwise the + -- "supported_versions" extension cannot be correctly serialized + clientVersions <- listWithOthers connectVersion 126 clientAllowedVersions + serverVersions <- listWithOthers connectVersion 126 serverAllowedVersions + arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (clientCiphers, serverCiphers) + where + listWithOthers :: a -> Int -> [a] -> Gen [a] + listWithOthers fixedElement maxOthers others + | maxOthers < 1 = return [fixedElement] + | otherwise = sized $ \n -> do + num <- choose (0, min n maxOthers) + pos <- choose (0, num) + prefix <- vectorOf pos $ elements others + suffix <- vectorOf (num - pos) $ elements others + return $ prefix ++ (fixedElement : suffix) + +getConnectVersion :: (ClientParams, ServerParams) -> Version +getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver) + where + sver = supportedVersions (serverSupported sparams) + cver = supportedVersions (clientSupported cparams) + +isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool +isVersionEnabled ver (cparams, sparams) = + (ver `elem` supportedVersions (serverSupported sparams)) + && (ver `elem` supportedVersions (clientSupported cparams)) + +arbitraryHashSignaturePair + :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) +arbitraryHashSignaturePair = do + serverHashSignatures <- shuffle knownHashSignatures + clientHashSignatures <- shuffle knownHashSignatures + return (clientHashSignatures, serverHashSignatures) + +arbitraryPairParamsWithVersionsAndCiphers + :: ([Version], [Version]) + -> ([Cipher], [Cipher]) + -> Gen (ClientParams, ServerParams) +arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do + secNeg <- arbitrary + dhparams <- elements [dhParams512, ffdhe2048, ffdhe3072] + + creds <- arbitraryCredentialsOfEachType + (clientGroups, serverGroups) <- arbitraryGroupPair + (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair + let serverState = + def + { serverSupported = + def + { supportedCiphers = serverCiphers + , supportedVersions = serverVersions + , supportedSecureRenegotiation = secNeg + , supportedGroups = serverGroups + , supportedHashSignatures = serverHashSignatures + } + , serverDHEParams = Just dhparams + , serverShared = def{sharedCredentials = Credentials creds} + } + let clientState = + (defaultParamsClient "" B.empty) + { clientSupported = + def + { supportedCiphers = clientCiphers + , supportedVersions = clientVersions + , supportedSecureRenegotiation = secNeg + , supportedGroups = clientGroups + , supportedHashSignatures = clientHashSignatures + } + , clientShared = + def + { sharedValidationCache = + ValidationCache + { cacheAdd = \_ _ _ -> return () + , cacheQuery = \_ _ _ -> return ValidationCachePass + } + } + } + return (clientState, serverState) + +arbitraryClientCredential :: Version -> Gen Credential +arbitraryClientCredential _ = arbitraryCredentialsOfEachType' >>= elements + +arbitraryRSACredentialWithUsage + :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey) +arbitraryRSACredentialWithUsage usageFlags = do + let (pubKey, privKey) = getGlobalRSAPair + cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ()) + return (CertificateChain [cert], PrivKeyRSA privKey) + +arbitraryEMSMode :: Gen (EMSMode, EMSMode) +arbitraryEMSMode = (,) <$> gen <*> gen + where + gen = elements [NoEMS, AllowEMS, RequireEMS] + +setEMSMode + :: (EMSMode, EMSMode) + -> (ClientParams, ServerParams) + -> (ClientParams, ServerParams) +setEMSMode (cems, sems) (clientParam, serverParam) = (clientParam', serverParam') + where + clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedExtendedMasterSec = cems + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedExtendedMasterSec = sems + } + } diff --git a/core/test/PipeChan.hs b/core/test/PipeChan.hs new file mode 100644 index 000000000..8f04fd840 --- /dev/null +++ b/core/test/PipeChan.hs @@ -0,0 +1,74 @@ +-- create a similar concept than a unix pipe. +module PipeChan ( + PipeChan (..), + newPipe, + runPipe, + readPipeA, + readPipeB, + writePipeA, + writePipeB, +) where + +import Control.Concurrent +import Control.Monad (forever) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.IORef + +-- | represent a unidirectional pipe with a buffered read channel and a write channel +data UniPipeChan = UniPipeChan (Chan ByteString) (Chan ByteString) + +newUniPipeChan :: IO UniPipeChan +newUniPipeChan = UniPipeChan <$> newChan <*> newChan + +runUniPipe :: UniPipeChan -> IO ThreadId +runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w + +getReadUniPipe :: UniPipeChan -> Chan ByteString +getReadUniPipe (UniPipeChan r _) = r + +getWriteUniPipe :: UniPipeChan -> Chan ByteString +getWriteUniPipe (UniPipeChan _ w) = w + +-- | Represent a bidirectional pipe with 2 nodes A and B +data PipeChan + = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan + +newPipe :: IO PipeChan +newPipe = + PipeChan + <$> newIORef B.empty + <*> newIORef B.empty + <*> newUniPipeChan + <*> newUniPipeChan + +runPipe :: PipeChan -> IO ThreadId +runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC + +readPipeA :: PipeChan -> Int -> IO ByteString +readPipeA (PipeChan _ b _ s) sz = readBuffered b (getWriteUniPipe s) sz + +writePipeA :: PipeChan -> ByteString -> IO () +writePipeA (PipeChan _ _ c _) = writeChan $ getWriteUniPipe c + +readPipeB :: PipeChan -> Int -> IO ByteString +readPipeB (PipeChan b _ c _) sz = readBuffered b (getWriteUniPipe c) sz + +writePipeB :: PipeChan -> ByteString -> IO () +writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s + +-- helper to read buffered data. +readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString +readBuffered buf chan sz = do + left <- readIORef buf + if B.length left >= sz + then do + let (ret, nleft) = B.splitAt sz left + writeIORef buf nleft + return ret + else do + let newSize = (sz - B.length left) + newData <- readChan chan + writeIORef buf newData + remain <- readBuffered buf chan newSize + return (left `B.append` remain) diff --git a/core/test/Run.hs b/core/test/Run.hs new file mode 100644 index 000000000..6d9139129 --- /dev/null +++ b/core/test/Run.hs @@ -0,0 +1,161 @@ +module Run ( + checkCtxFinished, + recvDataAssert, + byeBye, + runTLSPipe, +) where + +import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Exception as E +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Default.Class +import Data.Maybe +import Network.TLS +import System.Timeout +import Test.Hspec +import Test.QuickCheck + +import Arbitrary +import PipeChan + +checkCtxFinished :: Context -> IO () +checkCtxFinished ctx = do + ctxFinished <- getFinished ctx + unless (isJust ctxFinished) $ + fail "unexpected ctxFinished" + ctxPeerFinished <- getPeerFinished ctx + unless (isJust ctxPeerFinished) $ + fail "unexpected ctxPeerFinished" + +recvDataAssert :: Context -> ByteString -> IO () +recvDataAssert ctx expected = do + got <- recvData ctx + expected `shouldBe` got + +runTLSPipeN + :: Int + -> (ClientParams, ServerParams) + -> (Context -> Chan [ByteString] -> IO ()) + -> (Chan ByteString -> Context -> IO ()) + -> IO () +runTLSPipeN n params tlsServer tlsClient = do + -- generate some data to send + ds <- replicateM n $ do + d <- B.pack <$> generate (someWords8 256) + return d + -- send it + m_dsres <- do + withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do + forM_ ds $ \d -> do + writeStart d + -- receive it + timeout 60000000 readResult -- 60 sec + case m_dsres of + Nothing -> error "timed out" + Just dsres -> ds `shouldBe` dsres + +runTLSPipe + :: (ClientParams, ServerParams) + -> (Context -> Chan [ByteString] -> IO ()) + -> (Chan ByteString -> Context -> IO ()) + -> IO () +runTLSPipe = runTLSPipeN 1 + +withDataPipe + :: (ClientParams, ServerParams) + -> (Context -> Chan result -> IO ()) + -> (Chan start -> Context -> IO ()) + -> ((start -> IO (), IO result) -> IO a) + -> IO a +withDataPipe params tlsServer tlsClient cont = do + -- initial setup + pipe <- newPipe + _ <- runPipe pipe + startQueue <- newChan + resultQueue <- newChan + + (cCtx, sCtx) <- newPairContext pipe params + + withAsync + ( E.catch + (tlsServer sCtx resultQueue) + (printAndRaise "server" (serverSupported $ snd params)) + ) + $ \sAsync -> withAsync + ( E.catch + (tlsClient startQueue cCtx) + (printAndRaise "client" (clientSupported $ fst params)) + ) + $ \cAsync -> do + let readResult = waitBoth cAsync sAsync >> readChan resultQueue + cont (writeChan startQueue, readResult) + where + printAndRaise :: String -> Supported -> E.SomeException -> IO () + printAndRaise s supported e = do + putStrLn $ + s + ++ " exception: " + ++ show e + ++ ", supported: " + ++ show supported + E.throwIO e + +initiateDataPipe + :: (ClientParams, ServerParams) + -> (Context -> IO a1) + -> (Context -> IO a) + -> IO (Either E.SomeException a, Either E.SomeException a1) +initiateDataPipe params tlsServer tlsClient = do + -- initial setup + pipe <- newPipe + _ <- runPipe pipe + + (cCtx, sCtx) <- newPairContext pipe params + + async (tlsServer sCtx) >>= \sAsync -> + async (tlsClient cCtx) >>= \cAsync -> do + sRes <- waitCatch sAsync + cRes <- waitCatch cAsync + return (cRes, sRes) + +debug :: Bool +debug = False + +newPairContext + :: PipeChan -> (ClientParams, ServerParams) -> IO (Context, Context) +newPairContext pipe (cParams, sParams) = do + let noFlush = return () + let noClose = return () + + let cBackend = Backend noFlush noClose (writePipeA pipe) (readPipeA pipe) + let sBackend = Backend noFlush noClose (writePipeB pipe) (readPipeB pipe) + cCtx' <- contextNew cBackend cParams + sCtx' <- contextNew sBackend sParams + + contextHookSetLogging cCtx' (logging "client: ") + contextHookSetLogging sCtx' (logging "server: ") + + return (cCtx', sCtx') + where + logging pre = + if debug + then + def + { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) + , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) + } + else def + +-- Terminate the write direction and wait to receive the peer EOF. This is +-- necessary in situations where we want to confirm the peer status, or to make +-- sure to receive late messages like session tickets. In the test suite this +-- is used each time application code ends the connection without prior call to +-- 'recvData'. +byeBye :: Context -> IO () +byeBye ctx = do + bye ctx + bs <- recvData ctx + unless (B.null bs) $ fail "byeBye: unexpected application data" diff --git a/core/test/ThreadSpec.hs b/core/test/ThreadSpec.hs new file mode 100644 index 000000000..c34a2f1da --- /dev/null +++ b/core/test/ThreadSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ThreadSpec where + +import Control.Concurrent +import Control.Concurrent.Async +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Foldable (traverse_) +import Network.TLS +import Test.Hspec +import Test.QuickCheck + +import Arbitrary +import Run + +spec :: Spec +spec = do + describe "thread safety" $ do + it "can read/write concurrently" $ do + params <- generate arbitraryPairParams + runTLSPipe params tlsServer tlsClient + +tlsServer :: Context -> Chan [ByteString] -> IO () +tlsServer ctx queue = do + handshake ctx + checkCtxFinished ctx + runReaderWriters ctx "client-value" "server-value" + d <- recvData ctx + writeChan queue [d] + bye ctx + +tlsClient :: Chan ByteString -> Context -> IO () +tlsClient queue ctx = do + handshake ctx + checkCtxFinished ctx + runReaderWriters ctx "server-value" "client-value" + d <- readChan queue + sendData ctx (L.fromChunks [d]) + byeBye ctx + +runReaderWriters :: Context -> ByteString -> L.ByteString -> IO () +runReaderWriters ctx r w = + -- run concurrently 10 readers and 10 writers on the same context + let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w] + in runConcurrently $ traverse_ Concurrently workers diff --git a/core/tls.cabal b/core/tls.cabal index 5ab8f4825..6f90e99d0 100644 --- a/core/tls.cabal +++ b/core/tls.cabal @@ -132,21 +132,26 @@ test-suite spec Certificate CiphersSpec EncodeSpec + PipeChan PubKey + Run + ThreadSpec default-language: Haskell2010 ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5, QuickCheck, - hspec, - tls, + asn1-types, + async, bytestring, + crypton, crypton-x509, crypton-x509-validation, + data-default-class, hourglass, - crypton, - asn1-types + hspec, + tls benchmark bench-tls type: exitcode-stdio-1.0 From 958a1ef3f0aca75c6efd54c4b6aa9b7767106cf4 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 5 Dec 2023 10:40:54 +0900 Subject: [PATCH 04/26] hspec for Handshake --- core/test/HandshakeSpec.hs | 43 +++++++++++++++++ core/test/Run.hs | 94 ++++++++++++++++++++++++++++++++++++++ core/tls.cabal | 1 + 3 files changed, 138 insertions(+) create mode 100644 core/test/HandshakeSpec.hs diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs new file mode 100644 index 000000000..336a2b171 --- /dev/null +++ b/core/test/HandshakeSpec.hs @@ -0,0 +1,43 @@ +module HandshakeSpec where + +import qualified Data.ByteString as B +import Network.TLS +import Test.Hspec +import Test.QuickCheck + +import Arbitrary +import PipeChan +import Run + +spec :: Spec +spec = do + describe "pipe" $ do + it "can setup a channel" $ pipe_work + describe "handshake" $ do + it "can run TLS 1.2" $ do + params <- generate arbitraryPairParams + runTLSPipeSimple params + + it "can run TLS 1.3" $ do + params <- generate arbitraryPairParams13 + let cgrps = supportedGroups $ clientSupported $ fst params + sgrps = supportedGroups $ serverSupported $ snd params + hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest + runTLSPipeSimple13 params hs Nothing + +pipe_work :: IO () +pipe_work = do + pipe <- newPipe + _ <- runPipe pipe + + let bSize = 16 + n <- generate (choose (1, 32)) + + let d1 = B.replicate (bSize * n) 40 + let d2 = B.replicate (bSize * n) 45 + + d1' <- writePipeA pipe d1 >> readPipeB pipe (B.length d1) + d1 `shouldBe` d1' + + d2' <- writePipeB pipe d2 >> readPipeA pipe (B.length d2) + d2 `shouldBe` d2' diff --git a/core/test/Run.hs b/core/test/Run.hs index 6d9139129..40a1e0dbd 100644 --- a/core/test/Run.hs +++ b/core/test/Run.hs @@ -3,6 +3,8 @@ module Run ( recvDataAssert, byeBye, runTLSPipe, + runTLSPipeSimple, + runTLSPipeSimple13, ) where import Control.Concurrent @@ -11,7 +13,9 @@ import qualified Control.Exception as E import Control.Monad import Data.ByteString (ByteString) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L import Data.Default.Class +import Data.IORef import Data.Maybe import Network.TLS import System.Timeout @@ -159,3 +163,93 @@ byeBye ctx = do bye ctx bs <- recvData ctx unless (B.null bs) $ fail "byeBye: unexpected application data" + +runTLSPipePredicate + :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> IO () +runTLSPipePredicate params p = runTLSPipe params tlsServer tlsClient + where + tlsServer ctx queue = do + handshake ctx + checkCtxFinished ctx + checkInfoPredicate ctx + d <- recvData ctx + writeChan queue [d] + bye ctx + tlsClient queue ctx = do + handshake ctx + checkCtxFinished ctx + checkInfoPredicate ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + byeBye ctx + checkInfoPredicate ctx = do + minfo <- contextGetInformation ctx + unless (p minfo) $ + fail ("unexpected information: " ++ show minfo) + +runTLSPipeSimple :: (ClientParams, ServerParams) -> IO () +runTLSPipeSimple params = runTLSPipePredicate params (const True) + +runTLSPipeSimple13 + :: (ClientParams, ServerParams) + -> HandshakeMode13 + -> Maybe ByteString + -> IO () +runTLSPipeSimple13 params mode mEarlyData = runTLSPipe params tlsServer tlsClient + where + tlsServer ctx queue = do + handshake ctx + case mEarlyData of + Nothing -> return () + Just ed -> do + let ls = chunkLengths (B.length ed) + chunks <- replicateM (length ls) $ recvData ctx + (ls, ed) `shouldBe` (map B.length chunks, B.concat chunks) + d <- recvData ctx + checkCtxFinished ctx + writeChan queue [d] + minfo <- contextGetInformation ctx + Just mode `shouldBe` (minfo >>= infoTLS13HandshakeMode) + bye ctx + tlsClient queue ctx = do + handshake ctx + checkCtxFinished ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + minfo <- contextGetInformation ctx + Just mode `shouldBe` (minfo >>= infoTLS13HandshakeMode) + byeBye ctx + +runTLSPipeCapture13 + :: (ClientParams, ServerParams) -> IO ([Handshake13], [Handshake13]) +runTLSPipeCapture13 params = do + sRef <- newIORef [] + cRef <- newIORef [] + runTLSPipe params (tlsServer sRef) (tlsClient cRef) + sReceived <- readIORef sRef + cReceived <- readIORef cRef + return (reverse sReceived, reverse cReceived) + where + tlsServer ref ctx queue = do + installHook ctx ref + handshake ctx + checkCtxFinished ctx + d <- recvData ctx + writeChan queue [d] + bye ctx + tlsClient ref queue ctx = do + installHook ctx ref + handshake ctx + checkCtxFinished ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + byeBye ctx + installHook ctx ref = + let recv hss = modifyIORef ref (hss :) >> return hss + in contextHookSetHandshake13Recv ctx recv + +chunkLengths :: Int -> [Int] +chunkLengths len + | len > 16384 = 16384 : chunkLengths (len - 16384) + | len > 0 = [len] + | otherwise = [] diff --git a/core/tls.cabal b/core/tls.cabal index 6f90e99d0..507e5ea9a 100644 --- a/core/tls.cabal +++ b/core/tls.cabal @@ -132,6 +132,7 @@ test-suite spec Certificate CiphersSpec EncodeSpec + HandshakeSpec PipeChan PubKey Run From 5de477a582db540df135e7b8812ecf071762ec91 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 5 Dec 2023 11:29:56 +0900 Subject: [PATCH 05/26] fix property --- core/test/Arbitrary.hs | 10 ++++++++++ core/test/HandshakeSpec.hs | 9 +++------ core/test/ThreadSpec.hs | 5 ++--- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index c235afd2e..313256e98 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -320,6 +320,11 @@ arbitraryCipherPair connectVersion = do ) return (clientCiphers, serverCiphers) +newtype CSP = CSP (ClientParams, ServerParams) deriving (Show) + +instance Arbitrary CSP where + arbitrary = CSP <$> arbitraryPairParams + arbitraryPairParams :: Gen (ClientParams, ServerParams) arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt @@ -343,6 +348,11 @@ arbitraryGroupPair = do c <- sublistOf es return (e : s, e : c) +newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show) + +instance Arbitrary CSP13 where + arbitrary = CSP13 <$> arbitraryPairParams13 + arbitraryPairParams13 :: Gen (ClientParams, ServerParams) arbitraryPairParams13 = arbitraryPairParamsAt TLS13 diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 336a2b171..522874ff5 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -3,6 +3,7 @@ module HandshakeSpec where import qualified Data.ByteString as B import Network.TLS import Test.Hspec +import Test.Hspec.QuickCheck import Test.QuickCheck import Arbitrary @@ -14,12 +15,8 @@ spec = do describe "pipe" $ do it "can setup a channel" $ pipe_work describe "handshake" $ do - it "can run TLS 1.2" $ do - params <- generate arbitraryPairParams - runTLSPipeSimple params - - it "can run TLS 1.3" $ do - params <- generate arbitraryPairParams13 + prop "can run TLS 1.2" $ \(CSP params) -> runTLSPipeSimple params + prop "can run TLS 1.3" $ \(CSP13 params) -> do let cgrps = supportedGroups $ clientSupported $ fst params sgrps = supportedGroups $ serverSupported $ snd params hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest diff --git a/core/test/ThreadSpec.hs b/core/test/ThreadSpec.hs index c34a2f1da..b4b978382 100644 --- a/core/test/ThreadSpec.hs +++ b/core/test/ThreadSpec.hs @@ -9,7 +9,7 @@ import qualified Data.ByteString.Lazy as L import Data.Foldable (traverse_) import Network.TLS import Test.Hspec -import Test.QuickCheck +import Test.Hspec.QuickCheck import Arbitrary import Run @@ -17,8 +17,7 @@ import Run spec :: Spec spec = do describe "thread safety" $ do - it "can read/write concurrently" $ do - params <- generate arbitraryPairParams + prop "can read/write concurrently" $ \(CSP params) -> runTLSPipe params tlsServer tlsClient tlsServer :: Context -> Chan [ByteString] -> IO () From df4e95f87ec5ab28e09625dc517beaa4883c2b3a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 5 Dec 2023 11:32:57 +0900 Subject: [PATCH 06/26] using prop --- core/test/CiphersSpec.hs | 8 ++++---- core/test/EncodeSpec.hs | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/core/test/CiphersSpec.hs b/core/test/CiphersSpec.hs index c36ef77e0..69f0befa6 100644 --- a/core/test/CiphersSpec.hs +++ b/core/test/CiphersSpec.hs @@ -1,17 +1,17 @@ module CiphersSpec where -import Test.Hspec -import Test.QuickCheck - import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Cipher import Network.TLS.Extra.Cipher +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck spec :: Spec spec = do describe "ciphers" $ do - it "can ecnrypt/decrypt" $ property $ \(BulkTest bulk key iv t additional) -> do + prop "can ecnrypt/decrypt" $ \(BulkTest bulk key iv t additional) -> do let enc = bulkInit bulk BulkEncrypt key dec = bulkInit bulk BulkDecrypt key case (enc, dec) of diff --git a/core/test/EncodeSpec.hs b/core/test/EncodeSpec.hs index 35d0946da..1f1bd28f6 100644 --- a/core/test/EncodeSpec.hs +++ b/core/test/EncodeSpec.hs @@ -4,18 +4,18 @@ import Data.ByteString (ByteString) import Network.TLS import Network.TLS.Internal import Test.Hspec -import Test.QuickCheck +import Test.Hspec.QuickCheck import Arbitrary () spec :: Spec spec = do describe "encoder/decoder" $ do - it "can encode/decode Header" $ property $ \x -> do + prop "can encode/decode Header" $ \x -> do decodeHeader (encodeHeader x) `shouldBe` Right x - it "can encode/decode Handshake" $ property $ \x -> do + prop "can encode/decode Handshake" $ \x -> do decodeHs (encodeHandshake x) `shouldBe` Right x - it "can encode/decode Handshake13" $ property $ \x -> do + prop "can encode/decode Handshake13" $ \x -> do decodeHs13 (encodeHandshake13 x) `shouldBe` Right x decodeHs :: ByteString -> Either TLSError Handshake From 6b28f9026ed308c0cf3fbf0d11bda3dfb047f444 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 5 Dec 2023 12:45:53 +0900 Subject: [PATCH 07/26] hspec for handshake --- core/test/HandshakeSpec.hs | 83 +++++++++++++++++++++++++++++++++++--- core/test/Run.hs | 56 +++++++++++++++++++++++++ 2 files changed, 133 insertions(+), 6 deletions(-) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 522874ff5..07a2decd9 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -1,7 +1,9 @@ module HandshakeSpec where import qualified Data.ByteString as B +import Data.List import Network.TLS +import Network.TLS.Extra.Cipher import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck @@ -15,12 +17,11 @@ spec = do describe "pipe" $ do it "can setup a channel" $ pipe_work describe "handshake" $ do - prop "can run TLS 1.2" $ \(CSP params) -> runTLSPipeSimple params - prop "can run TLS 1.3" $ \(CSP13 params) -> do - let cgrps = supportedGroups $ clientSupported $ fst params - sgrps = supportedGroups $ serverSupported $ snd params - hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest - runTLSPipeSimple13 params hs Nothing + prop "can run TLS 1.2" handshake_simple + prop "can run TLS 1.3" handshake13_simple + prop "can update key for TLS 1.3" handshake_update_key + prop "can prevent downgrade attack" handshake13_downgrade + prop "can select hash and signature" handshake_hashsignatures pipe_work :: IO () pipe_work = do @@ -38,3 +39,73 @@ pipe_work = do d2' <- writePipeB pipe d2 >> readPipeA pipe (B.length d2) d2 `shouldBe` d2' + +handshake_simple :: CSP -> IO () +handshake_simple (CSP params) = runTLSPipeSimple params + +handshake13_simple :: CSP13 -> IO () +handshake13_simple (CSP13 params) = runTLSPipeSimple13 params hs Nothing + where + cgrps = supportedGroups $ clientSupported $ fst params + sgrps = supportedGroups $ serverSupported $ snd params + hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest + +handshake13_downgrade :: CSP -> IO () +handshake13_downgrade (CSP (cparam,sparam)) = do + versionForced <- generate $ elements (supportedVersions $ clientSupported cparam) + let debug' = (serverDebug sparam){debugVersionForced = Just versionForced} + sparam' = sparam{serverDebug = debug'} + params = (cparam, sparam') + downgraded = + (isVersionEnabled TLS13 params && versionForced < TLS13) + || (isVersionEnabled TLS12 params && versionForced < TLS12) + if downgraded + then runTLSInitFailure params + else runTLSPipeSimple params + +handshake_update_key :: CSP -> IO () +handshake_update_key (CSP params) = runTLSPipeSimpleKeyUpdate params + +handshake_hashsignatures :: Bool -> IO () +handshake_hashsignatures tls13 = do + let version = if tls13 then TLS13 else TLS12 + ciphers = + [ cipher_ECDHE_RSA_AES256GCM_SHA384 + , cipher_ECDHE_ECDSA_AES256GCM_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA + , cipher_ECDHE_ECDSA_AES128CBC_SHA + , cipher_DHE_RSA_AES128_SHA1 + , cipher_DHE_DSA_AES128_SHA1 + , cipher_TLS13_AES128GCM_SHA256 + ] + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + (ciphers, ciphers) + clientHashSigs <- generate $ arbitraryHashSignatures version + serverHashSigs <- generate $ arbitraryHashSignatures version + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = clientHashSigs + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedHashSignatures = serverHashSigs + } + } + commonHashSigs = clientHashSigs `intersect` serverHashSigs + shouldFail + | tls13 = all incompatibleWithDefaultCurve commonHashSigs + | otherwise = null commonHashSigs + if shouldFail + then runTLSInitFailure (clientParam', serverParam') + else runTLSPipeSimple (clientParam', serverParam') + where + incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 + incompatibleWithDefaultCurve _ = False diff --git a/core/test/Run.hs b/core/test/Run.hs index 40a1e0dbd..b98aab5a4 100644 --- a/core/test/Run.hs +++ b/core/test/Run.hs @@ -5,6 +5,8 @@ module Run ( runTLSPipe, runTLSPipeSimple, runTLSPipeSimple13, + runTLSPipeSimpleKeyUpdate, + runTLSInitFailure, ) where import Control.Concurrent @@ -15,6 +17,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Default.Class +import Data.Either import Data.IORef import Data.Maybe import Network.TLS @@ -248,8 +251,61 @@ runTLSPipeCapture13 params = do let recv hss = modifyIORef ref (hss :) >> return hss in contextHookSetHandshake13Recv ctx recv +runTLSPipeSimpleKeyUpdate :: (ClientParams, ServerParams) -> IO () +runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient + where + tlsServer ctx queue = do + handshake ctx + checkCtxFinished ctx + d0 <- recvData ctx + req <- generate $ elements [OneWay, TwoWay] + _ <- updateKey ctx req + d1 <- recvData ctx + d2 <- recvData ctx + writeChan queue [d0, d1, d2] + bye ctx + tlsClient queue ctx = do + handshake ctx + checkCtxFinished ctx + d0 <- readChan queue + sendData ctx (L.fromChunks [d0]) + d1 <- readChan queue + sendData ctx (L.fromChunks [d1]) + req <- generate $ elements [OneWay, TwoWay] + _ <- updateKey ctx req + d2 <- readChan queue + sendData ctx (L.fromChunks [d2]) + byeBye ctx + chunkLengths :: Int -> [Int] chunkLengths len | len > 16384 = 16384 : chunkLengths (len - 16384) | len > 0 = [len] | otherwise = [] + + +runTLSInitFailureGen + :: (ClientParams, ServerParams) + -> (Context -> IO s) + -> (Context -> IO c) + -> IO () +runTLSInitFailureGen params hsServer hsClient = do + (cRes, sRes) <- initiateDataPipe params tlsServer tlsClient + cRes `shouldSatisfy` isLeft + sRes `shouldSatisfy` isLeft + where + tlsServer ctx = do + _ <- hsServer ctx + checkCtxFinished ctx + minfo <- contextGetInformation ctx + byeBye ctx + return $ "server success: " ++ show minfo + tlsClient ctx = do + _ <- hsClient ctx + checkCtxFinished ctx + minfo <- contextGetInformation ctx + byeBye ctx + return $ "client success: " ++ show minfo + +runTLSInitFailure :: (ClientParams, ServerParams) -> IO () +runTLSInitFailure params = runTLSInitFailureGen params handshake handshake From 1c5a13bbd03966df952aab12afc80eb95c26f09f Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 5 Dec 2023 15:39:49 +0900 Subject: [PATCH 08/26] using arbitrary efficiently --- core/test/Arbitrary.hs | 23 +++++++----- core/test/HandshakeSpec.hs | 71 ++++++++++++++++++++++++++++++++++++-- core/test/Run.hs | 1 + 3 files changed, 84 insertions(+), 11 deletions(-) diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index 313256e98..57115bc23 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -184,8 +184,8 @@ knownCiphers = ciphersuite_all ++ ciphersuite_weak [ cipher_null_SHA1 ] -arbitraryCiphers :: Gen [Cipher] -arbitraryCiphers = listOf1 $ elements knownCiphers +instance Arbitrary Cipher where + arbitrary = elements knownCiphers knownVersions :: [Version] knownVersions = [TLS13, TLS12] @@ -232,8 +232,8 @@ defaultECGroup = P256 -- same as defaultECCurve otherKnownECGroups :: [Group] otherKnownECGroups = filter (/= defaultECGroup) knownECGroups -arbitraryGroups :: Gen [Group] -arbitraryGroups = scale (min 5) $ listOf1 $ elements knownGroups +instance Arbitrary Group where + arbitrary = elements knownGroups isCredentialDSA :: (CertificateChain, PrivKey) -> Bool isCredentialDSA (_, PrivKeyDSA _) = True @@ -307,10 +307,10 @@ isLeafRSA chain = case chain >>= leafPublicKey of arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) arbitraryCipherPair connectVersion = do serverCiphers <- - arbitraryCiphers + arbitrary `suchThat` (\cs -> or [cipherAllowedForVersion connectVersion x | x <- cs]) clientCiphers <- - arbitraryCiphers + arbitrary `suchThat` ( \cs -> or [ x `elem` serverCiphers @@ -328,17 +328,22 @@ instance Arbitrary CSP where arbitraryPairParams :: Gen (ClientParams, ServerParams) arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt +data GGP = GGP [Group] [Group] deriving (Show) + +instance Arbitrary GGP where + arbitrary = arbitraryGroupPair + -- Pair of groups so that at least the default EC group P256 and one FF group -- are in common. This makes DHE and ECDHE ciphers always compatible with -- extension "Supported Elliptic Curves" / "Supported Groups". -arbitraryGroupPair :: Gen ([Group], [Group]) +arbitraryGroupPair :: Gen GGP arbitraryGroupPair = do (serverECGroups, clientECGroups) <- arbitraryGroupPairWith defaultECGroup otherKnownECGroups (serverFFGroups, clientFFGroups) <- arbitraryGroupPairFrom knownFFGroups serverGroups <- shuffle (serverECGroups ++ serverFFGroups) clientGroups <- shuffle (clientECGroups ++ clientFFGroups) - return (clientGroups, serverGroups) + return $ GGP clientGroups serverGroups where arbitraryGroupPairFrom list = elements list >>= \e -> @@ -421,7 +426,7 @@ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clie dhparams <- elements [dhParams512, ffdhe2048, ffdhe3072] creds <- arbitraryCredentialsOfEachType - (clientGroups, serverGroups) <- arbitraryGroupPair + GGP clientGroups serverGroups <- arbitraryGroupPair (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair let serverState = def diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 07a2decd9..b253e6a79 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -2,6 +2,7 @@ module HandshakeSpec where import qualified Data.ByteString as B import Data.List +import Data.Maybe import Network.TLS import Network.TLS.Extra.Cipher import Test.Hspec @@ -15,13 +16,15 @@ import Run spec :: Spec spec = do describe "pipe" $ do - it "can setup a channel" $ pipe_work + it "can setup a channel" pipe_work describe "handshake" $ do prop "can run TLS 1.2" handshake_simple prop "can run TLS 1.3" handshake13_simple prop "can update key for TLS 1.3" handshake_update_key prop "can prevent downgrade attack" handshake13_downgrade - prop "can select hash and signature" handshake_hashsignatures + prop "can negotiate hash and signature" handshake_hashsignatures + prop "can negotiate cipher suite" handshake_ciphersuites + prop "can negotiate group" handshake_groups pipe_work :: IO () pipe_work = do @@ -109,3 +112,67 @@ handshake_hashsignatures tls13 = do where incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 incompatibleWithDefaultCurve _ = False + +handshake_ciphersuites :: ([Cipher], [Cipher]) -> IO () +handshake_ciphersuites (clientCiphers, serverCiphers) = do + tls13 <- generate arbitrary + let version = if tls13 then TLS13 else TLS12 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + (clientCiphers, serverCiphers) + let adequate = cipherAllowedForVersion version + shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers) + if shouldSucceed + then runTLSPipeSimple (clientParam, serverParam) + else runTLSInitFailure (clientParam, serverParam) + +handshake_groups :: ([Group], [Group]) -> IO () +handshake_groups (clientGroups, serverGroups) = do + tls13 <- generate arbitrary + let versions = if tls13 then [TLS13] else [TLS12] + ciphers = + [ cipher_ECDHE_RSA_AES256GCM_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA + , cipher_DHE_RSA_AES256GCM_SHA384 + , cipher_DHE_RSA_AES128_SHA1 + , cipher_TLS13_AES128GCM_SHA256 + ] + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + denyCustom <- generate arbitrary + let groupUsage = + if denyCustom + then GroupUsageUnsupported "custom group denied" + else GroupUsageValid + clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedGroups = clientGroups + } + , clientHooks = + (clientHooks clientParam) + { onCustomFFDHEGroup = \_ _ -> return groupUsage + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedGroups = serverGroups + } + } + isCustom = maybe True isCustomDHParams (serverDHEParams serverParam') + mCustomGroup = serverDHEParams serverParam' >>= dhParamsGroup + isClientCustom = maybe True (`notElem` clientGroups) mCustomGroup + commonGroups = clientGroups `intersect` serverGroups + shouldFail = null commonGroups && (tls13 || isClientCustom && denyCustom) + p minfo = isNothing (minfo >>= infoSupportedGroup) == (null commonGroups && isCustom) + if shouldFail + then runTLSInitFailure (clientParam', serverParam') + else runTLSPipePredicate (clientParam', serverParam') p diff --git a/core/test/Run.hs b/core/test/Run.hs index b98aab5a4..356efd853 100644 --- a/core/test/Run.hs +++ b/core/test/Run.hs @@ -6,6 +6,7 @@ module Run ( runTLSPipeSimple, runTLSPipeSimple13, runTLSPipeSimpleKeyUpdate, + runTLSPipePredicate, runTLSInitFailure, ) where From 85ce02eb78e49224d894919002a7a31e468f8017 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Tue, 5 Dec 2023 17:43:00 +0900 Subject: [PATCH 09/26] using supportedSignatureSchemes and deleting DSA cipher suite --- core/Network/TLS/Extra/Cipher.hs | 31 +------------------------------ core/test/Arbitrary.hs | 15 +-------------- core/test/HandshakeSpec.hs | 1 - 3 files changed, 2 insertions(+), 45 deletions(-) diff --git a/core/Network/TLS/Extra/Cipher.hs b/core/Network/TLS/Extra/Cipher.hs index 8bc5238f6..a36190a57 100644 --- a/core/Network/TLS/Extra/Cipher.hs +++ b/core/Network/TLS/Extra/Cipher.hs @@ -30,8 +30,6 @@ module Network.TLS.Extra.Cipher ( cipher_DHE_RSA_AES256_SHA1, cipher_DHE_RSA_AES128_SHA256, cipher_DHE_RSA_AES256_SHA256, - cipher_DHE_DSA_AES128_SHA1, - cipher_DHE_DSA_AES256_SHA1, cipher_DHE_RSA_AES128CCM_SHA256, cipher_DHE_RSA_AES128CCM8_SHA256, cipher_DHE_RSA_AES128GCM_SHA256, @@ -345,8 +343,6 @@ complement_all = , cipher_ECDHE_ECDSA_AES256CCM8_SHA256 , cipher_DHE_RSA_AES128CCM8_SHA256 , cipher_DHE_RSA_AES256CCM8_SHA256 - , cipher_DHE_DSA_AES256_SHA1 - , cipher_DHE_DSA_AES128_SHA1 , cipher_AES128CCM8_SHA256 , cipher_AES256CCM8_SHA256 , cipher_TLS13_AES128CCM8_SHA256 @@ -440,10 +436,7 @@ ciphersuite_dhe_rsa = ] ciphersuite_dhe_dss :: [Cipher] -ciphersuite_dhe_dss = - [ cipher_DHE_DSA_AES256_SHA1 - , cipher_DHE_DSA_AES128_SHA1 - ] +ciphersuite_dhe_dss = [ ] -- | all unencrypted ciphers, do not use on insecure network. ciphersuite_unencrypted :: [Cipher] @@ -596,19 +589,6 @@ cipher_null_SHA1 = , cipherMinVer = Nothing } --- | AES cipher (128 bit key), DHE key exchanged signed by DSA and SHA1 for digest -cipher_DHE_DSA_AES128_SHA1 :: Cipher -cipher_DHE_DSA_AES128_SHA1 = - Cipher - { cipherID = 0x0032 - , cipherName = "DHE-DSA-AES128-SHA1" - , cipherBulk = bulk_aes128 - , cipherHash = SHA1 - , cipherPRFHash = Nothing - , cipherKeyExchange = CipherKeyExchange_DHE_DSA - , cipherMinVer = Nothing - } - -- | AES cipher (128 bit key), DHE key exchanged signed by RSA and SHA1 for digest cipher_DHE_RSA_AES128_SHA1 :: Cipher cipher_DHE_RSA_AES128_SHA1 = @@ -622,15 +602,6 @@ cipher_DHE_RSA_AES128_SHA1 = , cipherMinVer = Nothing } --- | AES cipher (256 bit key), DHE key exchanged signed by DSA and SHA1 for digest -cipher_DHE_DSA_AES256_SHA1 :: Cipher -cipher_DHE_DSA_AES256_SHA1 = - cipher_DHE_DSA_AES128_SHA1 - { cipherID = 0x0038 - , cipherName = "DHE-DSA-AES256-SHA1" - , cipherBulk = bulk_aes256 - } - -- | AES cipher (256 bit key), DHE key exchanged signed by RSA and SHA1 for digest cipher_DHE_RSA_AES256_SHA1 :: Cipher cipher_DHE_RSA_AES256_SHA1 = diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index 57115bc23..b50383a57 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -195,20 +195,7 @@ arbitraryVersions = sublistOf knownVersions -- for performance reason ecdsa_secp521r1_sha512 is not tested knownHashSignatures :: [HashAndSignatureAlgorithm] -knownHashSignatures = - [ (HashIntrinsic, SignatureRSApssRSAeSHA512) - , (HashIntrinsic, SignatureRSApssRSAeSHA384) - , (HashIntrinsic, SignatureRSApssRSAeSHA256) - , (HashIntrinsic, SignatureEd25519) - , (HashIntrinsic, SignatureEd448) - , (HashSHA512, SignatureRSA) - , (HashSHA384, SignatureRSA) - , (HashSHA384, SignatureECDSA) - , (HashSHA256, SignatureRSA) - , (HashSHA256, SignatureECDSA) - , (HashSHA1, SignatureRSA) - , (HashSHA1, SignatureDSA) - ] +knownHashSignatures = supportedSignatureSchemes knownHashSignatures13 :: [HashAndSignatureAlgorithm] knownHashSignatures13 = filter compat knownHashSignatures diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index b253e6a79..2fc5859f0 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -78,7 +78,6 @@ handshake_hashsignatures tls13 = do , cipher_ECDHE_RSA_AES128CBC_SHA , cipher_ECDHE_ECDSA_AES128CBC_SHA , cipher_DHE_RSA_AES128_SHA1 - , cipher_DHE_DSA_AES128_SHA1 , cipher_TLS13_AES128GCM_SHA256 ] (clientParam, serverParam) <- From 5edd48bb28bc3f25717a3a2e2dc9cf76b8cc8c8b Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 08:25:30 +0900 Subject: [PATCH 10/26] making handshake_hashsignatures more robust --- core/test/Arbitrary.hs | 60 +++++--------------------------------- core/test/HandshakeSpec.hs | 7 ++--- 2 files changed, 10 insertions(+), 57 deletions(-) diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index b50383a57..b3be93db9 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Arbitrary where @@ -53,38 +54,11 @@ instance Arbitrary Session where 2 -> Session . Just <$> genByteString 32 _ -> return $ Session Nothing -instance Arbitrary HashAlgorithm where - arbitrary = - elements - [ HashNone - , HashMD5 - , HashSHA1 - , HashSHA224 - , HashSHA256 - , HashSHA384 - , HashSHA512 - , HashIntrinsic - ] - -instance Arbitrary SignatureAlgorithm where - arbitrary = - elements - [ SignatureAnonymous - , SignatureRSA - , SignatureDSA - , SignatureECDSA - , SignatureRSApssRSAeSHA256 - , SignatureRSApssRSAeSHA384 - , SignatureRSApssRSAeSHA512 - , SignatureEd25519 - , SignatureEd448 - , SignatureRSApsspssSHA256 - , SignatureRSApsspssSHA384 - , SignatureRSApsspssSHA512 - ] +instance {-# OVERLAPS #-} Arbitrary [HashAndSignatureAlgorithm] where + arbitrary = shuffle supportedSignatureSchemes instance Arbitrary DigitallySigned where - arbitrary = DigitallySigned <$> arbitrary <*> genByteString 32 + arbitrary = DigitallySigned <$> (head <$> arbitrary) <*> genByteString 32 arbitraryCiphersIDs :: Gen [Word16] arbitraryCiphersIDs = choose (0, 200) >>= vector @@ -172,7 +146,7 @@ instance Arbitrary Handshake13 where <$> arbitraryCertReqContext <*> return (CertificateChain certs) <*> replicateM (length certs) arbitrary - , CertVerify13 <$> arbitrary <*> genByteString 32 + , CertVerify13 <$> (head <$> arbitrary) <*> genByteString 32 , Finished13 <$> genByteString 12 , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested] ] @@ -193,20 +167,6 @@ knownVersions = [TLS13, TLS12] arbitraryVersions :: Gen [Version] arbitraryVersions = sublistOf knownVersions --- for performance reason ecdsa_secp521r1_sha512 is not tested -knownHashSignatures :: [HashAndSignatureAlgorithm] -knownHashSignatures = supportedSignatureSchemes - -knownHashSignatures13 :: [HashAndSignatureAlgorithm] -knownHashSignatures13 = filter compat knownHashSignatures - where - compat (h, s) = h /= HashSHA1 && s /= SignatureDSA && s /= SignatureRSA - -arbitraryHashSignatures :: Version -> Gen [HashAndSignatureAlgorithm] -arbitraryHashSignatures v = sublistOf l - where - l = if v < TLS13 then knownHashSignatures else knownHashSignatures13 - -- for performance reason P521, FFDHE6144, FFDHE8192 are not tested knownGroups, knownECGroups, knownFFGroups :: [Group] knownECGroups = [P256, P384, X25519, X448] @@ -397,13 +357,6 @@ isVersionEnabled ver (cparams, sparams) = (ver `elem` supportedVersions (serverSupported sparams)) && (ver `elem` supportedVersions (clientSupported cparams)) -arbitraryHashSignaturePair - :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -arbitraryHashSignaturePair = do - serverHashSignatures <- shuffle knownHashSignatures - clientHashSignatures <- shuffle knownHashSignatures - return (clientHashSignatures, serverHashSignatures) - arbitraryPairParamsWithVersionsAndCiphers :: ([Version], [Version]) -> ([Cipher], [Cipher]) @@ -414,7 +367,8 @@ arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clie creds <- arbitraryCredentialsOfEachType GGP clientGroups serverGroups <- arbitraryGroupPair - (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair + clientHashSignatures <- arbitrary + serverHashSignatures <- arbitrary let serverState = def { serverSupported = diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 2fc5859f0..8004991ac 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -69,8 +69,9 @@ handshake13_downgrade (CSP (cparam,sparam)) = do handshake_update_key :: CSP -> IO () handshake_update_key (CSP params) = runTLSPipeSimpleKeyUpdate params -handshake_hashsignatures :: Bool -> IO () -handshake_hashsignatures tls13 = do +handshake_hashsignatures :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO () +handshake_hashsignatures (clientHashSigs, serverHashSigs) = do + tls13 <- generate arbitrary let version = if tls13 then TLS13 else TLS12 ciphers = [ cipher_ECDHE_RSA_AES256GCM_SHA384 @@ -85,8 +86,6 @@ handshake_hashsignatures tls13 = do arbitraryPairParamsWithVersionsAndCiphers ([version], [version]) (ciphers, ciphers) - clientHashSigs <- generate $ arbitraryHashSignatures version - serverHashSigs <- generate $ arbitraryHashSignatures version let clientParam' = clientParam { clientSupported = From 27c7e4c8974fd24337a2f5927e5b0474ec1e697c Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 08:29:49 +0900 Subject: [PATCH 11/26] style only --- core/test/Arbitrary.hs | 50 ++++++++++++++++++++++++++++-------------- 1 file changed, 33 insertions(+), 17 deletions(-) diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index b3be93db9..adcb4755f 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -23,8 +23,7 @@ import Test.QuickCheck import Certificate import PubKey -genByteString :: Int -> Gen B.ByteString -genByteString i = B.pack <$> vector i +---------------------------------------------------------------- instance Arbitrary Version where arbitrary = elements [TLS12, TLS13] @@ -60,23 +59,11 @@ instance {-# OVERLAPS #-} Arbitrary [HashAndSignatureAlgorithm] where instance Arbitrary DigitallySigned where arbitrary = DigitallySigned <$> (head <$> arbitrary) <*> genByteString 32 -arbitraryCiphersIDs :: Gen [Word16] -arbitraryCiphersIDs = choose (0, 200) >>= vector - -arbitraryCompressionIDs :: Gen [Word8] -arbitraryCompressionIDs = choose (0, 200) >>= vector - -someWords8 :: Int -> Gen [Word8] -someWords8 = vector - instance Arbitrary ExtensionRaw where arbitrary = let arbitraryContent = choose (0, 40) >>= genByteString in ExtensionRaw <$> (ExtensionID <$> arbitrary) <*> arbitraryContent -arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw] -arbitraryHelloExtensions _ver = arbitrary - instance Arbitrary CertificateType where arbitrary = elements @@ -112,9 +99,6 @@ instance Arbitrary Handshake where , Finished <$> genByteString 12 ] -arbitraryCertReqContext :: Gen B.ByteString -arbitraryCertReqContext = oneof [return B.empty, genByteString 32] - instance Arbitrary Handshake13 where arbitrary = oneof @@ -151,6 +135,25 @@ instance Arbitrary Handshake13 where , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested] ] +---------------------------------------------------------------- + +arbitraryCiphersIDs :: Gen [Word16] +arbitraryCiphersIDs = choose (0, 200) >>= vector + +arbitraryCompressionIDs :: Gen [Word8] +arbitraryCompressionIDs = choose (0, 200) >>= vector + +someWords8 :: Int -> Gen [Word8] +someWords8 = vector + +arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw] +arbitraryHelloExtensions _ver = arbitrary + +arbitraryCertReqContext :: Gen B.ByteString +arbitraryCertReqContext = oneof [return B.empty, genByteString 32] + +---------------------------------------------------------------- + knownCiphers :: [Cipher] knownCiphers = ciphersuite_all ++ ciphersuite_weak where @@ -186,6 +189,8 @@ isCredentialDSA :: (CertificateChain, PrivKey) -> Bool isCredentialDSA (_, PrivKeyDSA _) = True isCredentialDSA _ = False +---------------------------------------------------------------- + arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] arbitraryCredentialsOfEachType = arbitraryCredentialsOfEachType' >>= shuffle @@ -233,6 +238,8 @@ arbitraryCredentialsOfEachCurve' = do ] ++ ecdsaPairs +---------------------------------------------------------------- + dhParamsGroup :: DHParams -> Maybe Group dhParamsGroup params | params == ffdhe2048 = Just FFDHE2048 @@ -267,6 +274,8 @@ arbitraryCipherPair connectVersion = do ) return (clientCiphers, serverCiphers) +---------------------------------------------------------------- + newtype CSP = CSP (ClientParams, ServerParams) deriving (Show) instance Arbitrary CSP where @@ -300,6 +309,8 @@ arbitraryGroupPair = do c <- sublistOf es return (e : s, e : c) +---------------------------------------------------------------- + newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show) instance Arbitrary CSP13 where @@ -346,6 +357,8 @@ arbitraryPairParamsAt connectVersion = do suffix <- vectorOf (num - pos) $ elements others return $ prefix ++ (fixedElement : suffix) +---------------------------------------------------------------- + getConnectVersion :: (ClientParams, ServerParams) -> Version getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver) where @@ -438,3 +451,6 @@ setEMSMode (cems, sems) (clientParam, serverParam) = (clientParam', serverParam' { supportedExtendedMasterSec = sems } } + +genByteString :: Int -> Gen B.ByteString +genByteString i = B.pack <$> vector i From c450c5557e85e3af285438b54f4479e54efeaf61 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 08:30:08 +0900 Subject: [PATCH 12/26] fourmolu --- core/Network/TLS/Extra/Cipher.hs | 2 +- core/test/HandshakeSpec.hs | 8 +++++--- core/test/Run.hs | 1 - 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/core/Network/TLS/Extra/Cipher.hs b/core/Network/TLS/Extra/Cipher.hs index a36190a57..3c55c9f46 100644 --- a/core/Network/TLS/Extra/Cipher.hs +++ b/core/Network/TLS/Extra/Cipher.hs @@ -436,7 +436,7 @@ ciphersuite_dhe_rsa = ] ciphersuite_dhe_dss :: [Cipher] -ciphersuite_dhe_dss = [ ] +ciphersuite_dhe_dss = [] -- | all unencrypted ciphers, do not use on insecure network. ciphersuite_unencrypted :: [Cipher] diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 8004991ac..bdad7a5ee 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -54,8 +54,9 @@ handshake13_simple (CSP13 params) = runTLSPipeSimple13 params hs Nothing hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest handshake13_downgrade :: CSP -> IO () -handshake13_downgrade (CSP (cparam,sparam)) = do - versionForced <- generate $ elements (supportedVersions $ clientSupported cparam) +handshake13_downgrade (CSP (cparam, sparam)) = do + versionForced <- + generate $ elements (supportedVersions $ clientSupported cparam) let debug' = (serverDebug sparam){debugVersionForced = Just versionForced} sparam' = sparam{serverDebug = debug'} params = (cparam, sparam') @@ -69,7 +70,8 @@ handshake13_downgrade (CSP (cparam,sparam)) = do handshake_update_key :: CSP -> IO () handshake_update_key (CSP params) = runTLSPipeSimpleKeyUpdate params -handshake_hashsignatures :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO () +handshake_hashsignatures + :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO () handshake_hashsignatures (clientHashSigs, serverHashSigs) = do tls13 <- generate arbitrary let version = if tls13 then TLS13 else TLS12 diff --git a/core/test/Run.hs b/core/test/Run.hs index 356efd853..cb801e859 100644 --- a/core/test/Run.hs +++ b/core/test/Run.hs @@ -284,7 +284,6 @@ chunkLengths len | len > 0 = [len] | otherwise = [] - runTLSInitFailureGen :: (ClientParams, ServerParams) -> (Context -> IO s) From d7a0fa346106d52cceed2e974739977cf2fc164e Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 08:48:30 +0900 Subject: [PATCH 13/26] hspec for elliptic curves --- core/test/Arbitrary.hs | 3 +++ core/test/HandshakeSpec.hs | 52 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 55 insertions(+) diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index adcb4755f..11252d282 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -185,6 +185,9 @@ otherKnownECGroups = filter (/= defaultECGroup) knownECGroups instance Arbitrary Group where arbitrary = elements knownGroups +instance {-# OVERLAPS #-} Arbitrary [Group] where + arbitrary = sublistOf knownGroups + isCredentialDSA :: (CertificateChain, PrivKey) -> Bool isCredentialDSA (_, PrivKeyDSA _) = True isCredentialDSA _ = False diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index bdad7a5ee..aa80e837a 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -25,6 +25,7 @@ spec = do prop "can negotiate hash and signature" handshake_hashsignatures prop "can negotiate cipher suite" handshake_ciphersuites prop "can negotiate group" handshake_groups + prop "can negotiate elliptic curve" handshake_ec pipe_work :: IO () pipe_work = do @@ -176,3 +177,54 @@ handshake_groups (clientGroups, serverGroups) = do if shouldFail then runTLSInitFailure (clientParam', serverParam') else runTLSPipePredicate (clientParam', serverParam') p + +handshake_ec :: [Group] -> IO () +handshake_ec sigGroups' = do + let versions = [TLS12, TLS13] + ciphers = + [ cipher_ECDHE_ECDSA_AES256GCM_SHA384 + , cipher_ECDHE_ECDSA_AES128CBC_SHA + , cipher_TLS13_AES128GCM_SHA256 + ] + sigGroups = [P256] + ecdhGroups = [X25519, X448] -- always enabled, so no ECDHE failure + hashSignatures = + [ (HashSHA256, SignatureECDSA) + ] + clientVersion <- generate $ elements versions + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([clientVersion], versions) + (ciphers, ciphers) + clientGroups <- generate $ sublistOf sigGroups + clientHashSignatures <- generate $ sublistOf hashSignatures + serverHashSignatures <- generate $ sublistOf hashSignatures + credentials <- generate arbitraryCredentialsOfEachCurve + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedGroups = clientGroups ++ ecdhGroups + , supportedHashSignatures = clientHashSignatures + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedGroups = sigGroups ++ ecdhGroups + , supportedHashSignatures = serverHashSignatures + } + , serverShared = + (serverShared serverParam) + { sharedCredentials = Credentials credentials + } + } + sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures) + ecdsaDenied = + (clientVersion < TLS13 && null clientGroups) + || (clientVersion >= TLS12 && SignatureECDSA `notElem` sigAlgs) + if ecdsaDenied + then runTLSInitFailure (clientParam', serverParam') + else runTLSPipeSimple (clientParam', serverParam') From 19564730b8bfb9cda18dabe4d71bbafbff21eb34 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 09:09:01 +0900 Subject: [PATCH 14/26] hspec for certificate fallback --- core/test/HandshakeSpec.hs | 111 +++++++++++++++++++++++++++++++++++++ 1 file changed, 111 insertions(+) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index aa80e837a..b126546e3 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -1,6 +1,7 @@ module HandshakeSpec where import qualified Data.ByteString as B +import Data.IORef import Data.List import Data.Maybe import Network.TLS @@ -26,6 +27,8 @@ spec = do prop "can negotiate cipher suite" handshake_ciphersuites prop "can negotiate group" handshake_groups prop "can negotiate elliptic curve" handshake_ec + prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher + prop "can fallback for certificate with hash and signature" handshake_cert_fallback_hs pipe_work :: IO () pipe_work = do @@ -228,3 +231,111 @@ handshake_ec sigGroups' = do if ecdsaDenied then runTLSInitFailure (clientParam', serverParam') else runTLSPipeSimple (clientParam', serverParam') + +-- Tests ability to use or ignore client "signature_algorithms" extension when +-- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but +-- the server RSA certificate has a SHA-1 signature that the client does not +-- support. Server may choose the DSA certificate only when cipher +-- DHE_DSA_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA +-- certificate. + +data OC = OC [Cipher] [Cipher] deriving (Show) + +instance Arbitrary OC where + arbitrary = OC <$> sublistOf otherCiphers <*> sublistOf otherCiphers + where + otherCiphers = + [ cipher_ECDHE_RSA_AES256GCM_SHA384 + , cipher_ECDHE_RSA_AES128CBC_SHA + ] + +handshake_cert_fallback_cipher :: OC -> IO () +handshake_cert_fallback_cipher (OC clientCiphers serverCiphers)= do + let clientVersions = [TLS12] + serverVersions = [TLS12] + commonCiphers = [cipher_DHE_RSA_AES128_SHA1] + hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)] + chainRef <- newIORef Nothing + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = hashSignatures + } + , clientHooks = + (clientHooks clientParam) + { onServerCertificate = \_ _ _ chain -> + writeIORef chainRef (Just chain) >> return [] + } + } + runTLSPipeSimple (clientParam', serverParam) + serverChain <- readIORef chainRef + isLeafRSA serverChain `shouldBe` True + +-- Same as above but testing with supportedHashSignatures directly instead of +-- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the +-- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by +-- both client and server, the Ed25519 certificate is selected. Otherwise the +-- server fallbacks to RSA. +-- +-- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 +-- unless client advertises explicit support. Currently this is not enforced by +-- the library, which is useful to test this scenario. SHA-1 could be replaced +-- by another algorithm. + +data OHS = OHS [HashAndSignatureAlgorithm] [HashAndSignatureAlgorithm] deriving (Show) + +instance Arbitrary OHS where + arbitrary = OHS <$> sublistOf otherHS <*> sublistOf otherHS + where + otherHS = [(HashIntrinsic, SignatureEd25519)] + +handshake_cert_fallback_hs :: OHS -> IO () +handshake_cert_fallback_hs (OHS clientHS serverHS)= do + tls13 <- generate arbitrary + let versions = if tls13 then [TLS13] else [TLS12] + ciphers = + [ cipher_ECDHE_RSA_AES128GCM_SHA256 + , cipher_ECDHE_ECDSA_AES128GCM_SHA256 + , cipher_TLS13_AES128GCM_SHA256 + ] + commonHS = + [ (HashSHA256, SignatureRSA) + , (HashIntrinsic, SignatureRSApssRSAeSHA256) + ] + chainRef <- newIORef Nothing + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedHashSignatures = commonHS ++ clientHS + } + , clientHooks = + (clientHooks clientParam) + { onServerCertificate = \_ _ _ chain -> + writeIORef chainRef (Just chain) >> return [] + } + } + serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedHashSignatures = commonHS ++ serverHS + } + } + eddsaDisallowed = + (HashIntrinsic, SignatureEd25519) `notElem` clientHS + || (HashIntrinsic, SignatureEd25519) `notElem` serverHS + runTLSPipeSimple (clientParam', serverParam') + serverChain <- readIORef chainRef + isLeafRSA serverChain `shouldBe` eddsaDisallowed From a041886bfb642d2dbcb2957732b6615a7f0cf304 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 09:18:16 +0900 Subject: [PATCH 15/26] refactoring --- core/test/Arbitrary.hs | 13 ++++--------- core/test/HandshakeSpec.hs | 29 +++++++++++++++++++++++------ core/test/ThreadSpec.hs | 4 ++-- 3 files changed, 29 insertions(+), 17 deletions(-) diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index 11252d282..accf5c96f 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -279,14 +279,14 @@ arbitraryCipherPair connectVersion = do ---------------------------------------------------------------- -newtype CSP = CSP (ClientParams, ServerParams) deriving (Show) - -instance Arbitrary CSP where - arbitrary = CSP <$> arbitraryPairParams +instance {-# OVERLAPS #-} Arbitrary (ClientParams, ServerParams) where + arbitrary = elements knownVersions >>= arbitraryPairParamsAt arbitraryPairParams :: Gen (ClientParams, ServerParams) arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt +---------------------------------------------------------------- + data GGP = GGP [Group] [Group] deriving (Show) instance Arbitrary GGP where @@ -314,11 +314,6 @@ arbitraryGroupPair = do ---------------------------------------------------------------- -newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show) - -instance Arbitrary CSP13 where - arbitrary = CSP13 <$> arbitraryPairParams13 - arbitraryPairParams13 :: Gen (ClientParams, ServerParams) arbitraryPairParams13 = arbitraryPairParamsAt TLS13 diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index b126546e3..1984f2db2 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -30,6 +30,8 @@ spec = do prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher prop "can fallback for certificate with hash and signature" handshake_cert_fallback_hs +-------------------------------------------------------------- + pipe_work :: IO () pipe_work = do pipe <- newPipe @@ -47,8 +49,17 @@ pipe_work = do d2' <- writePipeB pipe d2 >> readPipeA pipe (B.length d2) d2 `shouldBe` d2' -handshake_simple :: CSP -> IO () -handshake_simple (CSP params) = runTLSPipeSimple params +-------------------------------------------------------------- + +handshake_simple :: (ClientParams, ServerParams) -> IO () +handshake_simple = runTLSPipeSimple + +-------------------------------------------------------------- + +newtype CSP13 = CSP13 (ClientParams, ServerParams) deriving (Show) + +instance Arbitrary CSP13 where + arbitrary = CSP13 <$> arbitraryPairParams13 handshake13_simple :: CSP13 -> IO () handshake13_simple (CSP13 params) = runTLSPipeSimple13 params hs Nothing @@ -57,8 +68,10 @@ handshake13_simple (CSP13 params) = runTLSPipeSimple13 params hs Nothing sgrps = supportedGroups $ serverSupported $ snd params hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest -handshake13_downgrade :: CSP -> IO () -handshake13_downgrade (CSP (cparam, sparam)) = do +-------------------------------------------------------------- + +handshake13_downgrade :: (ClientParams, ServerParams) -> IO () +handshake13_downgrade (cparam, sparam) = do versionForced <- generate $ elements (supportedVersions $ clientSupported cparam) let debug' = (serverDebug sparam){debugVersionForced = Just versionForced} @@ -71,8 +84,10 @@ handshake13_downgrade (CSP (cparam, sparam)) = do then runTLSInitFailure params else runTLSPipeSimple params -handshake_update_key :: CSP -> IO () -handshake_update_key (CSP params) = runTLSPipeSimpleKeyUpdate params +handshake_update_key :: (ClientParams, ServerParams) -> IO () +handshake_update_key = runTLSPipeSimpleKeyUpdate + +-------------------------------------------------------------- handshake_hashsignatures :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO () @@ -132,6 +147,8 @@ handshake_ciphersuites (clientCiphers, serverCiphers) = do then runTLSPipeSimple (clientParam, serverParam) else runTLSInitFailure (clientParam, serverParam) +-------------------------------------------------------------- + handshake_groups :: ([Group], [Group]) -> IO () handshake_groups (clientGroups, serverGroups) = do tls13 <- generate arbitrary diff --git a/core/test/ThreadSpec.hs b/core/test/ThreadSpec.hs index b4b978382..6b1c07732 100644 --- a/core/test/ThreadSpec.hs +++ b/core/test/ThreadSpec.hs @@ -11,13 +11,13 @@ import Network.TLS import Test.Hspec import Test.Hspec.QuickCheck -import Arbitrary +import Arbitrary () import Run spec :: Spec spec = do describe "thread safety" $ do - prop "can read/write concurrently" $ \(CSP params) -> + prop "can read/write concurrently" $ \params -> runTLSPipe params tlsServer tlsClient tlsServer :: Context -> Chan [ByteString] -> IO () From 1b6782b98a0e1622d42aaed0c003705e68d72cbc Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 09:21:40 +0900 Subject: [PATCH 16/26] refactoring --- core/test/HandshakeSpec.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 1984f2db2..9a18a3ecb 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -198,15 +198,23 @@ handshake_groups (clientGroups, serverGroups) = do then runTLSInitFailure (clientParam', serverParam') else runTLSPipePredicate (clientParam', serverParam') p -handshake_ec :: [Group] -> IO () -handshake_ec sigGroups' = do +-------------------------------------------------------------- + +newtype SG = SG [Group] deriving (Show) + +instance Arbitrary SG where + arbitrary = SG <$> sublistOf sigGroups + where + sigGroups = [P256] + +handshake_ec :: SG -> IO () +handshake_ec (SG sigGroups) = do let versions = [TLS12, TLS13] ciphers = [ cipher_ECDHE_ECDSA_AES256GCM_SHA384 , cipher_ECDHE_ECDSA_AES128CBC_SHA , cipher_TLS13_AES128GCM_SHA256 ] - sigGroups = [P256] ecdhGroups = [X25519, X448] -- always enabled, so no ECDHE failure hashSignatures = [ (HashSHA256, SignatureECDSA) From bfa657d93b827c41b782d5cc5a15fc16f8cc3124 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 09:24:02 +0900 Subject: [PATCH 17/26] removing unnecessary code --- core/test/Arbitrary.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index accf5c96f..9867ed73c 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -282,9 +282,6 @@ arbitraryCipherPair connectVersion = do instance {-# OVERLAPS #-} Arbitrary (ClientParams, ServerParams) where arbitrary = elements knownVersions >>= arbitraryPairParamsAt -arbitraryPairParams :: Gen (ClientParams, ServerParams) -arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt - ---------------------------------------------------------------- data GGP = GGP [Group] [Group] deriving (Show) From 1cac3623ae88743b1fd8963045c19366524a6669 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 09:38:46 +0900 Subject: [PATCH 18/26] hspec for key usage --- core/test/Certificate.hs | 6 +++--- core/test/HandshakeSpec.hs | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 35 insertions(+), 3 deletions(-) diff --git a/core/test/Certificate.hs b/core/test/Certificate.hs index 951d8cb0d..71c66fecf 100644 --- a/core/test/Certificate.hs +++ b/core/test/Certificate.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -7,7 +8,6 @@ module Certificate ( arbitraryX509WithKey, arbitraryX509WithKeyAndUsage, arbitraryDN, - arbitraryKeyUsage, simpleCertificate, simpleX509, toPubKeyEC, @@ -123,8 +123,8 @@ arbitraryX509 = do let (pubKey, privKey) = getGlobalRSAPair arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) -arbitraryKeyUsage :: Gen [ExtKeyUsageFlag] -arbitraryKeyUsage = sublistOf knownKeyUsage +instance {-# OVERLAPS #-} Arbitrary [ExtKeyUsageFlag] where + arbitrary = sublistOf knownKeyUsage knownKeyUsage :: [ExtKeyUsageFlag] knownKeyUsage = diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 9a18a3ecb..592b60360 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -4,6 +4,7 @@ import qualified Data.ByteString as B import Data.IORef import Data.List import Data.Maybe +import Data.X509 hiding (HashSHA1, HashSHA256) import Network.TLS import Network.TLS.Extra.Cipher import Test.Hspec @@ -29,6 +30,7 @@ spec = do prop "can negotiate elliptic curve" handshake_ec prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher prop "can fallback for certificate with hash and signature" handshake_cert_fallback_hs + prop "can handle key usage" handshake_srv_key_usage -------------------------------------------------------------- @@ -364,3 +366,33 @@ handshake_cert_fallback_hs (OHS clientHS serverHS)= do runTLSPipeSimple (clientParam', serverParam') serverChain <- readIORef chainRef isLeafRSA serverChain `shouldBe` eddsaDisallowed + +handshake_srv_key_usage :: [ExtKeyUsageFlag] -> IO () +handshake_srv_key_usage usageFlags = do + tls13 <- generate arbitrary + let versions = if tls13 then [TLS13] else [TLS12] + ciphers = + [ cipher_ECDHE_RSA_AES128CBC_SHA + , cipher_TLS13_AES128GCM_SHA256 + , cipher_DHE_RSA_AES128_SHA1 + , cipher_AES256_SHA256 + ] + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + (versions, versions) + (ciphers, ciphers) + cred <- generate $ arbitraryRSACredentialWithUsage usageFlags + let serverParam' = + serverParam + { serverShared = + (serverShared serverParam) + { sharedCredentials = Credentials [cred] + } + } + hasDS = KeyUsage_digitalSignature `elem` usageFlags + hasKE = KeyUsage_keyEncipherment `elem` usageFlags + shouldSucceed = hasDS || (hasKE && not tls13) + if shouldSucceed + then runTLSPipeSimple (clientParam, serverParam') + else runTLSInitFailure (clientParam, serverParam') From 32686ee71e8ae4d2c9022814d294ae891f2d8bfe Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 09:41:23 +0900 Subject: [PATCH 19/26] hspec for client authentication --- core/test/Arbitrary.hs | 4 ++-- core/test/HandshakeSpec.hs | 31 +++++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+), 2 deletions(-) diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index 9867ed73c..2bd62d38b 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -201,7 +201,7 @@ arbitraryCredentialsOfEachType' :: Gen [(CertificateChain, PrivKey)] arbitraryCredentialsOfEachType' = do let (pubKey, privKey) = getGlobalRSAPair curveName = defaultECCurve - (dsaPub, dsaPriv) <- arbitraryDSAPair +-- (dsaPub, dsaPriv) <- arbitraryDSAPair (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair (ed448Pub, ed448Priv) <- arbitraryEd448Pair @@ -211,7 +211,7 @@ arbitraryCredentialsOfEachType' = do return (CertificateChain [cert], priv) ) [ (PubKeyRSA pubKey, PrivKeyRSA privKey) - , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) +-- , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 592b60360..d9714591c 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -31,6 +31,7 @@ spec = do prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher prop "can fallback for certificate with hash and signature" handshake_cert_fallback_hs prop "can handle key usage" handshake_srv_key_usage + prop "can authenticate client" handshake_client_auth -------------------------------------------------------------- @@ -396,3 +397,33 @@ handshake_srv_key_usage usageFlags = do if shouldSucceed then runTLSPipeSimple (clientParam, serverParam') else runTLSInitFailure (clientParam, serverParam') + +handshake_client_auth :: (ClientParams, ServerParams) -> IO () +handshake_client_auth (clientParam, serverParam) = do + let clientVersions = supportedVersions $ clientSupported clientParam + serverVersions = supportedVersions $ serverSupported serverParam + version = maximum (clientVersions `intersect` serverVersions) + cred <- generate (arbitraryClientCredential version) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = validateChain cred + } + } + let shouldFail = version == TLS13 && isCredentialDSA cred + if shouldFail + then runTLSInitFailure (clientParam', serverParam') + else runTLSPipeSimple (clientParam', serverParam') + where + validateChain cred chain + | chain == fst cred = return CertificateUsageAccept + | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) From e0e49c1e368895a89d47e80c47eac47098786720 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 09:54:08 +0900 Subject: [PATCH 20/26] hspec for client key usage --- core/test/HandshakeSpec.hs | 35 ++++++++++++++++++++++++++++++++--- 1 file changed, 32 insertions(+), 3 deletions(-) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index d9714591c..2a2e1ab31 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -30,7 +30,8 @@ spec = do prop "can negotiate elliptic curve" handshake_ec prop "can fallback for certificate with cipher" handshake_cert_fallback_cipher prop "can fallback for certificate with hash and signature" handshake_cert_fallback_hs - prop "can handle key usage" handshake_srv_key_usage + prop "can handle server key usage" handshake_server_key_usage + prop "can handle client key usage" handshake_client_key_usage prop "can authenticate client" handshake_client_auth -------------------------------------------------------------- @@ -368,8 +369,10 @@ handshake_cert_fallback_hs (OHS clientHS serverHS)= do serverChain <- readIORef chainRef isLeafRSA serverChain `shouldBe` eddsaDisallowed -handshake_srv_key_usage :: [ExtKeyUsageFlag] -> IO () -handshake_srv_key_usage usageFlags = do +-------------------------------------------------------------- + +handshake_server_key_usage :: [ExtKeyUsageFlag] -> IO () +handshake_server_key_usage usageFlags = do tls13 <- generate arbitrary let versions = if tls13 then [TLS13] else [TLS12] ciphers = @@ -398,6 +401,32 @@ handshake_srv_key_usage usageFlags = do then runTLSPipeSimple (clientParam, serverParam') else runTLSInitFailure (clientParam, serverParam') +handshake_client_key_usage :: [ExtKeyUsageFlag] -> IO () +handshake_client_key_usage usageFlags = do + (clientParam, serverParam) <- generate arbitrary + cred <- generate $ arbitraryRSACredentialWithUsage usageFlags + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags + if shouldSucceed + then runTLSPipeSimple (clientParam', serverParam') + else runTLSInitFailure (clientParam', serverParam') + +-------------------------------------------------------------- + handshake_client_auth :: (ClientParams, ServerParams) -> IO () handshake_client_auth (clientParam, serverParam) = do let clientVersions = supportedVersions $ clientSupported clientParam From 1f520eb38d0d35811453b5e3025f26281407561a Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 10:15:36 +0900 Subject: [PATCH 21/26] hspec for extended master secret --- core/test/Arbitrary.hs | 8 ++--- core/test/HandshakeSpec.hs | 62 ++++++++++++++++++++++++++++++++++++++ core/test/Run.hs | 56 ++++++++++++++++++++++++++++++++++ 3 files changed, 122 insertions(+), 4 deletions(-) diff --git a/core/test/Arbitrary.hs b/core/test/Arbitrary.hs index 2bd62d38b..2119b832f 100644 --- a/core/test/Arbitrary.hs +++ b/core/test/Arbitrary.hs @@ -421,10 +421,10 @@ arbitraryRSACredentialWithUsage usageFlags = do cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ()) return (CertificateChain [cert], PrivKeyRSA privKey) -arbitraryEMSMode :: Gen (EMSMode, EMSMode) -arbitraryEMSMode = (,) <$> gen <*> gen - where - gen = elements [NoEMS, AllowEMS, RequireEMS] +instance {-# OVERLAPS #-} Arbitrary (EMSMode, EMSMode) where + arbitrary = (,) <$> gen <*> gen + where + gen = elements [NoEMS, AllowEMS, RequireEMS] setEMSMode :: (EMSMode, EMSMode) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 2a2e1ab31..a0d020d6f 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -1,5 +1,6 @@ module HandshakeSpec where +import Control.Monad import qualified Data.ByteString as B import Data.IORef import Data.List @@ -33,6 +34,8 @@ spec = do prop "can handle server key usage" handshake_server_key_usage prop "can handle client key usage" handshake_client_key_usage prop "can authenticate client" handshake_client_auth + prop "can handle extended master secret" handshake_ems + prop "can resume with extended master secret" handshake_ems -------------------------------------------------------------- @@ -456,3 +459,62 @@ handshake_client_auth (clientParam, serverParam) = do validateChain cred chain | chain == fst cred = return CertificateUsageAccept | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) + +-------------------------------------------------------------- + +handshake_ems :: (EMSMode, EMSMode) -> IO () +handshake_ems (cems, sems) = do + params <- generate arbitrary + let params' = setEMSMode (cems, sems) params + version = getConnectVersion params' + emsVersion = version >= TLS10 && version <= TLS12 + use = cems /= NoEMS && sems /= NoEMS + require = cems == RequireEMS || sems == RequireEMS + p info = infoExtendedMasterSec info == (emsVersion && use) + if emsVersion && require && not use + then runTLSInitFailure params' + else runTLSPipePredicate params' (maybe False p) + +newtype CompatEMS = CompatEMS (EMSMode,EMSMode) deriving (Show) + +instance Arbitrary CompatEMS where + arbitrary = CompatEMS <$> (arbitrary `suchThat` compatible) + where + compatible (NoEMS, RequireEMS) = False + compatible (RequireEMS, NoEMS) = False + compatible _ = True + +handshake_session_resumption_ems :: (CompatEMS, CompatEMS) -> IO () +handshake_session_resumption_ems (CompatEMS ems, CompatEMS ems2) = do + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + plainParams <- generate arbitrary + let params = + setEMSMode ems $ + setPairParamsSessionManagers sessionManagers plainParams + + runTLSPipeSimple params + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + sessionParams `shouldSatisfy` isJust + let params2 = + setEMSMode ems2 $ + setPairParamsSessionResuming (fromJust sessionParams) params + + let version = getConnectVersion params2 + emsVersion = version >= TLS10 && version <= TLS12 + + if emsVersion && use ems && not (use ems2) + then runTLSInitFailure params2 + else do + runTLSPipeSimple params2 + sessionParams2 <- readClientSessionRef sessionRefs + let sameSession = sessionParams == sessionParams2 + sameUse = use ems == use ems2 + when emsVersion $ (sameSession `shouldBe` sameUse) + where + use (NoEMS, _) = False + use (_, NoEMS) = False + use _ = True diff --git a/core/test/Run.hs b/core/test/Run.hs index cb801e859..7c9933d93 100644 --- a/core/test/Run.hs +++ b/core/test/Run.hs @@ -8,6 +8,11 @@ module Run ( runTLSPipeSimpleKeyUpdate, runTLSPipePredicate, runTLSInitFailure, + readClientSessionRef, + twoSessionRefs, + twoSessionManagers, + setPairParamsSessionManagers, + setPairParamsSessionResuming, ) where import Control.Concurrent @@ -309,3 +314,54 @@ runTLSInitFailureGen params hsServer hsClient = do runTLSInitFailure :: (ClientParams, ServerParams) -> IO () runTLSInitFailure params = runTLSInitFailureGen params handshake handshake + +readClientSessionRef :: (IORef mclient, IORef mserver) -> IO mclient +readClientSessionRef refs = readIORef (fst refs) + +twoSessionRefs :: IO (IORef (Maybe client), IORef (Maybe server)) +twoSessionRefs = (,) <$> newIORef Nothing <*> newIORef Nothing + +-- | simple session manager to store one session id and session data for a single thread. +-- a Real concurrent session manager would use an MVar and have multiples items. +oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager +oneSessionManager ref = + SessionManager + { sessionResume = \myId -> readIORef ref >>= maybeResume False myId + , sessionResumeOnlyOnce = \myId -> readIORef ref >>= maybeResume True myId + , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) + , sessionInvalidate = \_ -> return () + } + where + maybeResume onlyOnce myId (Just (sid, sdata)) + | sid == myId = when onlyOnce (writeIORef ref Nothing) >> return (Just sdata) + maybeResume _ _ _ = return Nothing + +twoSessionManagers + :: (IORef (Maybe (SessionID, SessionData)), IORef (Maybe (SessionID, SessionData))) + -> (SessionManager, SessionManager) +twoSessionManagers (cRef, sRef) = (oneSessionManager cRef, oneSessionManager sRef) + +setPairParamsSessionManagers + :: (SessionManager, SessionManager) + -> (ClientParams, ServerParams) + -> (ClientParams, ServerParams) +setPairParamsSessionManagers (clientManager, serverManager) (clientState, serverState) = (nc, ns) + where + nc = + clientState + { clientShared = updateSessionManager clientManager $ clientShared clientState + } + ns = + serverState + { serverShared = updateSessionManager serverManager $ serverShared serverState + } + updateSessionManager manager shared = shared{sharedSessionManager = manager} + +setPairParamsSessionResuming + :: (SessionID, SessionData) + -> (ClientParams, ServerParams) + -> (ClientParams, ServerParams) +setPairParamsSessionResuming sessionStuff (clientState, serverState) = + ( clientState{clientWantSessionResume = Just sessionStuff} + , serverState + ) From 50b3ce051fdfd75328caffab18fcbb2f4e27eaca Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 10:23:35 +0900 Subject: [PATCH 22/26] hspec for ALPN and SNI --- core/test/HandshakeSpec.hs | 89 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 89 insertions(+) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index a0d020d6f..de46c8fc0 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} + module HandshakeSpec where +import Control.Concurrent import Control.Monad import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L import Data.IORef import Data.List import Data.Maybe @@ -36,6 +40,8 @@ spec = do prop "can authenticate client" handshake_client_auth prop "can handle extended master secret" handshake_ems prop "can resume with extended master secret" handshake_ems + prop "can handle ALPN" handshake_alpn + prop "can handle SNI" handshake_sni -------------------------------------------------------------- @@ -518,3 +524,86 @@ handshake_session_resumption_ems (CompatEMS ems, CompatEMS ems2) = do use (NoEMS, _) = False use (_, NoEMS) = False use _ = True + +-------------------------------------------------------------- + +handshake_alpn :: (ClientParams, ServerParams) -> IO () +handshake_alpn (clientParam, serverParam) = do + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onSuggestALPN = return $ Just ["h2", "http/1.1"] + } + } + serverParam' = + serverParam + { serverHooks = + (serverHooks serverParam) + { onALPNClientSuggest = Just alpn + } + } + params' = (clientParam', serverParam') + runTLSPipe params' tlsServer tlsClient + where + tlsServer ctx queue = do + handshake ctx + checkCtxFinished ctx + proto <- getNegotiatedProtocol ctx + proto `shouldBe` Just "h2" + d <- recvData ctx + writeChan queue [d] + bye ctx + tlsClient queue ctx = do + handshake ctx + checkCtxFinished ctx + proto <- getNegotiatedProtocol ctx + proto `shouldBe` Just "h2" + d <- readChan queue + sendData ctx (L.fromChunks [d]) + byeBye ctx + alpn xs + | "h2" `elem` xs = return "h2" + | otherwise = return "http/1.1" + +handshake_sni :: (ClientParams, ServerParams) -> IO () +handshake_sni (clientParam, serverParam) = do + ref <- newIORef Nothing + let clientParam' = + clientParam + { clientServerIdentification = (serverName, "") + } + serverParam' = + serverParam + { serverHooks = + (serverHooks serverParam) + { onServerNameIndication = onSNI ref + } + } + params' = (clientParam', serverParam') + runTLSPipe params' tlsServer tlsClient + receivedName <- readIORef ref + Just (Just serverName) `shouldBe` receivedName + where + tlsServer ctx queue = do + handshake ctx + checkCtxFinished ctx + sni <- getClientSNI ctx + sni `shouldBe` Just serverName + d <- recvData ctx + writeChan queue [d] + bye ctx + tlsClient queue ctx = do + handshake ctx + checkCtxFinished ctx + sni <- getClientSNI ctx + sni `shouldBe` Just serverName + d <- readChan queue + sendData ctx (L.fromChunks [d]) + byeBye ctx + onSNI ref name = do + mx <- readIORef ref + mx `shouldBe` Nothing + writeIORef ref (Just name) + return (Credentials []) + serverName = "haskell.org" From 724a2d1ce0d255dda3880c1f3cd6e31b94b26006 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 10:28:25 +0900 Subject: [PATCH 23/26] hspec for renegotiation and resumption --- core/test/HandshakeSpec.hs | 49 ++++++++++++++++++++++++++++++++++++++ core/test/Run.hs | 1 + 2 files changed, 50 insertions(+) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index de46c8fc0..3bff4346a 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -42,6 +42,8 @@ spec = do prop "can resume with extended master secret" handshake_ems prop "can handle ALPN" handshake_alpn prop "can handle SNI" handshake_sni + prop "can re-negotiate" handshake_renegotiation + prop "can resume session" handshake_session_resumption -------------------------------------------------------------- @@ -607,3 +609,50 @@ handshake_sni (clientParam, serverParam) = do writeIORef ref (Just name) return (Credentials []) serverName = "haskell.org" + +-------------------------------------------------------------- + +handshake_renegotiation :: (ClientParams, ServerParams) -> IO () +handshake_renegotiation (cparams, sparams) = do + renegDisabled <- generate arbitrary + let sparams' = + sparams + { serverSupported = + (serverSupported sparams) + { supportedClientInitiatedRenegotiation = not renegDisabled + } + } + if renegDisabled || isVersionEnabled TLS13 (cparams, sparams') + then runTLSInitFailureGen (cparams, sparams') hsServer hsClient + else runTLSPipe (cparams, sparams') tlsServer tlsClient + where + tlsServer ctx queue = do + hsServer ctx + checkCtxFinished ctx + d <- recvData ctx + writeChan queue [d] + bye ctx + tlsClient queue ctx = do + hsClient ctx + checkCtxFinished ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + byeBye ctx + hsServer = handshake + hsClient ctx = handshake ctx >> handshake ctx + +handshake_session_resumption :: (ClientParams, ServerParams) -> IO () +handshake_session_resumption plainParams = do + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers plainParams + + runTLSPipeSimple params + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + sessionParams `shouldSatisfy` isJust + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSPipeSimple params2 diff --git a/core/test/Run.hs b/core/test/Run.hs index 7c9933d93..1427491c4 100644 --- a/core/test/Run.hs +++ b/core/test/Run.hs @@ -8,6 +8,7 @@ module Run ( runTLSPipeSimpleKeyUpdate, runTLSPipePredicate, runTLSInitFailure, + runTLSInitFailureGen, readClientSessionRef, twoSessionRefs, twoSessionManagers, From 89b760496ed6746a2a2b24e9ebe51f2a105d6ce1 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 10:35:35 +0900 Subject: [PATCH 24/26] hspec for DH --- core/test/HandshakeSpec.hs | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 3bff4346a..7d908e4ed 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -18,6 +18,7 @@ import Test.QuickCheck import Arbitrary import PipeChan +import PubKey import Run spec :: Spec @@ -44,6 +45,7 @@ spec = do prop "can handle SNI" handshake_sni prop "can re-negotiate" handshake_renegotiation prop "can resume session" handshake_session_resumption + prop "can handshake with DH" handshake_dh -------------------------------------------------------------- @@ -656,3 +658,37 @@ handshake_session_resumption plainParams = do let params2 = setPairParamsSessionResuming (fromJust sessionParams) params runTLSPipeSimple params2 + +-------------------------------------------------------------- + +newtype DHP = DHP (ClientParams, ServerParams) deriving (Show) + +instance Arbitrary DHP where + arbitrary = DHP <$> arbitraryPairParamsWithVersionsAndCiphers + (clientVersions, serverVersions) + (ciphers, ciphers) + where + clientVersions = [TLS12] + serverVersions = [TLS12] + ciphers = [cipher_DHE_RSA_AES128_SHA1] + +handshake_dh :: DHP -> IO () +handshake_dh (DHP (clientParam, serverParam)) = do + let clientParam' = + clientParam + { clientSupported = + (clientSupported clientParam) + { supportedGroups = [] + } + } + let check (dh, shouldFail) = do + let serverParam' = serverParam{serverDHEParams = Just dh} + if shouldFail + then runTLSInitFailure (clientParam', serverParam') + else runTLSPipeSimple (clientParam', serverParam') + mapM_ + check + [ (dhParams512, True) + , (dhParams768, True) + , (dhParams1024, False) + ] From d9621ff0a5dc484ef2a7d8588cf0aa047536b15f Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 11:56:16 +0900 Subject: [PATCH 25/26] hspec for TLS 1.3 --- core/test/HandshakeSpec.hs | 331 ++++++++++++++++++++++++++++++++++++- core/test/Run.hs | 1 + 2 files changed, 331 insertions(+), 1 deletion(-) diff --git a/core/test/HandshakeSpec.hs b/core/test/HandshakeSpec.hs index 7d908e4ed..11a8e4c64 100644 --- a/core/test/HandshakeSpec.hs +++ b/core/test/HandshakeSpec.hs @@ -6,12 +6,14 @@ import Control.Concurrent import Control.Monad import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L +import Data.Default.Class import Data.IORef import Data.List import Data.Maybe -import Data.X509 hiding (HashSHA1, HashSHA256) +import Data.X509 (ExtKeyUsageFlag (..)) import Network.TLS import Network.TLS.Extra.Cipher +import Network.TLS.Internal import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck @@ -46,6 +48,15 @@ spec = do prop "can re-negotiate" handshake_renegotiation prop "can resume session" handshake_session_resumption prop "can handshake with DH" handshake_dh + prop "can handshake with TLS 1.3 Full" handshake13_full + prop "can handshake with TLS 1.3 HRR" handshake13_hrr + prop "can handshake with TLS 1.3 PSK" handshake13_psk + prop "can handshake with TLS 1.3 PSK -> HRR" handshake13_psk_fallback + prop "can handshake with TLS 1.3 RTT0" handshake13_rtt0 + prop "can handshake with TLS 1.3 RTT0 -> PSK" handshake13_rtt0_fallback + prop "can handshake with TLS 1.3 RTT0 length" handshake13_rtt0_length + prop "can handshake with TLS 1.3 EE groups" handshake13_ee_groups + prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth -------------------------------------------------------------- @@ -692,3 +703,321 @@ handshake_dh (DHP (clientParam, serverParam)) = do , (dhParams768, True) , (dhParams1024, False) ] + +-------------------------------------------------------------- + +handshake13_full :: CSP13 -> IO () +handshake13_full (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSPipeSimple13 params FullHandshake Nothing + +handshake13_hrr :: CSP13 -> IO () +handshake13_hrr (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSPipeSimple13 params HelloRetryRequest Nothing + +handshake13_psk :: CSP13 -> IO () +handshake13_psk (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSPipeSimple13 params HelloRetryRequest Nothing + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + sessionParams `shouldSatisfy` isJust + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + + runTLSPipeSimple13 params2 PreSharedKey Nothing + +handshake13_psk_fallback :: CSP13 -> IO () +handshake13_psk_fallback (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = + [ cipher_TLS13_AES128GCM_SHA256 + , cipher_TLS13_AES128CCM_SHA256 + ] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSPipeSimple13 params HelloRetryRequest Nothing + + -- resumption fails because GCM cipher is not supported anymore, full + -- handshake is not possible because X25519 has been removed, so we are + -- back with P256 after hello retry + sessionParams <- readClientSessionRef sessionRefs + sessionParams `shouldSatisfy` isJust + let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params + srv2' = srv2{serverSupported = svrSupported'} + svrSupported' = + def + { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256] + , supportedGroups = [P256] + } + + runTLSPipeSimple13 (cli2, srv2') HelloRetryRequest Nothing + +handshake13_rtt0 :: CSP13 -> IO () +handshake13_rtt0 (CSP13 (cli, srv)) = do + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + cliHooks = + def + { onSuggestALPN = return $ Just ["h2"] + } + svrHooks = + def + { onALPNClientSuggest = Just (\protos -> return $ head protos) + } + params0 = + ( cli + { clientSupported = cliSupported + , clientHooks = cliHooks + } + , srv + { serverSupported = svrSupported + , serverHooks = svrHooks + , serverEarlyDataSize = 2048 + } + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + runTLSPipeSimple13 params HelloRetryRequest Nothing + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + sessionParams `shouldSatisfy` isJust + earlyData <- B.pack <$> generate (someWords8 256) + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + params2 = (pc{clientEarlyData = Just earlyData}, ps) + + runTLSPipeSimple13 params2 RTT0 (Just earlyData) + +handshake13_rtt0_fallback :: IO () +handshake13_rtt0_fallback = do + ticketSize <- generate $ choose (0, 512) + (cli, srv) <- generate arbitraryPairParams13 + group0 <- generate $ elements [P256, X25519] + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [P256, X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [group0] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv + { serverSupported = svrSupported + , serverEarlyDataSize = ticketSize + } + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + + let params = setPairParamsSessionManagers sessionManagers params0 + + let mode = if group0 == P256 then FullHandshake else HelloRetryRequest + runTLSPipeSimple13 params mode Nothing + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + sessionParams `shouldSatisfy` isJust + earlyData <- B.pack <$> generate (someWords8 256) + group2 <- generate $ elements [P256, X25519] + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + svrSupported2 = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [group2] + } + params2 = + ( pc{clientEarlyData = Just earlyData} + , ps + { serverEarlyDataSize = 0 + , serverSupported = svrSupported2 + } + ) + + let mode2 = if ticketSize < 256 then PreSharedKey else RTT0 + runTLSPipeSimple13 params2 mode2 Nothing + +handshake13_rtt0_length :: CSP13 -> IO () +handshake13_rtt0_length (CSP13 (cli, srv)) = do + serverMax <- generate $ choose (0, 33792) + let cliSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + svrSupported = + def + { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] + , supportedGroups = [X25519] + } + params0 = + ( cli{clientSupported = cliSupported} + , srv + { serverSupported = svrSupported + , serverEarlyDataSize = serverMax + } + ) + + sessionRefs <- twoSessionRefs + let sessionManagers = twoSessionManagers sessionRefs + let params = setPairParamsSessionManagers sessionManagers params0 + runTLSPipeSimple13 params FullHandshake Nothing + + -- and resume + sessionParams <- readClientSessionRef sessionRefs + sessionParams `shouldSatisfy` isJust + clientLen <- generate $ choose (0, 33792) + earlyData <- B.pack <$> generate (someWords8 clientLen) + let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params + params2 = (pc{clientEarlyData = Just earlyData}, ps) + (mode, mEarlyData) + | clientLen > serverMax = (PreSharedKey, Nothing) + | otherwise = (RTT0, Just earlyData) + runTLSPipeSimple13 params2 mode mEarlyData + +handshake13_ee_groups :: CSP13 -> IO () +handshake13_ee_groups (CSP13 (cli, srv)) = do + let cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]} + svrSupported = (serverSupported srv){supportedGroups = [X25519, P256]} + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + (_, serverMessages) <- runTLSPipeCapture13 params + let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups + eeMessagesHaveExt = + [ any isSupportedGroups exts + | EncryptedExtensions13 exts <- serverMessages + ] + eeMessagesHaveExt `shouldBe` [True] -- one EE message with extension + +post_handshake_auth :: CSP13 -> IO () +post_handshake_auth (CSP13 (clientParam, serverParam)) = do + cred <- generate (arbitraryClientCredential TLS13) + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverHooks = + (serverHooks serverParam) + { onClientCertificate = validateChain cred + } + } + if isCredentialDSA cred + then runTLSInitFailureGen (clientParam', serverParam') hsServer hsClient + else runTLSPipe (clientParam', serverParam') tlsServer tlsClient + where + validateChain cred chain + | chain == fst cred = return CertificateUsageAccept + | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) + tlsServer ctx queue = do + hsServer ctx + d <- recvData ctx + writeChan queue [d] + bye ctx + tlsClient queue ctx = do + hsClient ctx + d <- readChan queue + sendData ctx (L.fromChunks [d]) + byeBye ctx + hsServer ctx = do + handshake ctx + checkCtxFinished ctx + recvDataAssert ctx "request 1" + _ <- requestCertificate ctx -- single request + sendData ctx "response 1" + recvDataAssert ctx "request 2" + _ <- requestCertificate ctx + _ <- requestCertificate ctx -- two simultaneously + sendData ctx "response 2" + hsClient ctx = do + handshake ctx + checkCtxFinished ctx + sendData ctx "request 1" + recvDataAssert ctx "response 1" + sendData ctx "request 2" + recvDataAssert ctx "response 2" diff --git a/core/test/Run.hs b/core/test/Run.hs index 1427491c4..b80920547 100644 --- a/core/test/Run.hs +++ b/core/test/Run.hs @@ -7,6 +7,7 @@ module Run ( runTLSPipeSimple13, runTLSPipeSimpleKeyUpdate, runTLSPipePredicate, + runTLSPipeCapture13, runTLSInitFailure, runTLSInitFailureGen, readClientSessionRef, From 7aff6c03daeab4eb40861fd5635f6a344e4757b2 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Wed, 6 Dec 2023 11:57:14 +0900 Subject: [PATCH 26/26] removing Tests --- core/Tests/Certificate.hs | 161 ----- core/Tests/Ciphers.hs | 53 -- core/Tests/Connection.hs | 503 --------------- core/Tests/Marshalling.hs | 201 ------ core/Tests/PipeChan.hs | 74 --- core/Tests/PubKey.hs | 157 ----- core/Tests/Tests.hs | 1270 ------------------------------------- 7 files changed, 2419 deletions(-) delete mode 100644 core/Tests/Certificate.hs delete mode 100644 core/Tests/Ciphers.hs delete mode 100644 core/Tests/Connection.hs delete mode 100644 core/Tests/Marshalling.hs delete mode 100644 core/Tests/PipeChan.hs delete mode 100644 core/Tests/PubKey.hs delete mode 100644 core/Tests/Tests.hs diff --git a/core/Tests/Certificate.hs b/core/Tests/Certificate.hs deleted file mode 100644 index d83b7001f..000000000 --- a/core/Tests/Certificate.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Certificate ( - arbitraryX509, - arbitraryX509WithKey, - arbitraryX509WithKeyAndUsage, - arbitraryDN, - arbitraryKeyUsage, - simpleCertificate, - simpleX509, - toPubKeyEC, - toPrivKeyEC, -) where - -import Crypto.Number.Serialize (i2ospOf_) -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.Types as ECC -import Data.ASN1.OID -import qualified Data.ByteString as B -import Data.Hourglass -import Data.X509 -import Test.Tasty.QuickCheck - -import PubKey - -arbitraryDN :: Gen DistinguishedName -arbitraryDN = return $ DistinguishedName [] - -instance Arbitrary Date where - arbitrary = do - y <- choose (1971, 2035) - m <- elements [January .. December] - d <- choose (1, 30) - return $ normalizeDate $ Date y m d - -normalizeDate :: Date -> Date -normalizeDate d = timeConvert (timeConvert d :: Elapsed) - -instance Arbitrary TimeOfDay where - arbitrary = do - h <- choose (0, 23) - mi <- choose (0, 59) - se <- choose (0, 59) - nsec <- return 0 - return $ TimeOfDay (Hours h) (Minutes mi) (Seconds se) nsec - -instance Arbitrary DateTime where - arbitrary = DateTime <$> arbitrary <*> arbitrary - -maxSerial :: Integer -maxSerial = 16777216 - -arbitraryCertificate :: [ExtKeyUsageFlag] -> PubKey -> Gen Certificate -arbitraryCertificate usageFlags pubKey = do - serial <- choose (0, maxSerial) - subjectdn <- arbitraryDN - validity <- (,) <$> arbitrary <*> arbitrary - let sigalg = getSignatureALG pubKey - return $ - Certificate - { certVersion = 3 - , certSerial = serial - , certSignatureAlg = sigalg - , certIssuerDN = issuerdn - , certSubjectDN = subjectdn - , certValidity = validity - , certPubKey = pubKey - , certExtensions = - Extensions $ - Just - [ extensionEncode True $ ExtKeyUsage usageFlags - ] - } - where - issuerdn = DistinguishedName [(getObjectID DnCommonName, "Root CA")] - -simpleCertificate :: PubKey -> Certificate -simpleCertificate pubKey = - Certificate - { certVersion = 3 - , certSerial = 0 - , certSignatureAlg = getSignatureALG pubKey - , certIssuerDN = simpleDN - , certSubjectDN = simpleDN - , certValidity = (time1, time2) - , certPubKey = pubKey - , certExtensions = - Extensions $ - Just - [ extensionEncode True $ - ExtKeyUsage [KeyUsage_digitalSignature, KeyUsage_keyEncipherment] - ] - } - where - time1 = DateTime (Date 1999 January 1) (TimeOfDay 0 0 0 0) - time2 = DateTime (Date 2049 January 1) (TimeOfDay 0 0 0 0) - simpleDN = DistinguishedName [] - -simpleX509 :: PubKey -> SignedCertificate -simpleX509 pubKey = - let cert = simpleCertificate pubKey - sig = replicate 40 1 - sigalg = getSignatureALG pubKey - (signedExact, ()) = objectToSignedExact (\_ -> (B.pack sig, sigalg, ())) cert - in signedExact - -arbitraryX509WithKey :: (PubKey, t) -> Gen SignedCertificate -arbitraryX509WithKey = arbitraryX509WithKeyAndUsage knownKeyUsage - -arbitraryX509WithKeyAndUsage - :: [ExtKeyUsageFlag] -> (PubKey, t) -> Gen SignedCertificate -arbitraryX509WithKeyAndUsage usageFlags (pubKey, _) = do - cert <- arbitraryCertificate usageFlags pubKey - sig <- resize 40 $ listOf1 arbitrary - let sigalg = getSignatureALG pubKey - let (signedExact, ()) = objectToSignedExact (\(!(_)) -> (B.pack sig, sigalg, ())) cert - return signedExact - -arbitraryX509 :: Gen SignedCertificate -arbitraryX509 = do - let (pubKey, privKey) = getGlobalRSAPair - arbitraryX509WithKey (PubKeyRSA pubKey, PrivKeyRSA privKey) - -arbitraryKeyUsage :: Gen [ExtKeyUsageFlag] -arbitraryKeyUsage = sublistOf knownKeyUsage - -knownKeyUsage :: [ExtKeyUsageFlag] -knownKeyUsage = - [ KeyUsage_digitalSignature - , KeyUsage_keyEncipherment - , KeyUsage_keyAgreement - ] - -getSignatureALG :: PubKey -> SignatureALG -getSignatureALG (PubKeyRSA _) = SignatureALG HashSHA1 PubKeyALG_RSA -getSignatureALG (PubKeyDSA _) = SignatureALG HashSHA1 PubKeyALG_DSA -getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC -getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448 -getSignatureALG pubKey = - error $ "getSignatureALG: unsupported public key: " ++ show pubKey - -toPubKeyEC :: ECC.CurveName -> ECDSA.PublicKey -> PubKey -toPubKeyEC curveName key = - let (x, y) = fromPoint $ ECDSA.public_q key - pub = SerializedPoint bs - bs = B.cons 4 (i2ospOf_ bytes x `B.append` i2ospOf_ bytes y) - bits = ECC.curveSizeBits (ECC.getCurveByName curveName) - bytes = (bits + 7) `div` 8 - in PubKeyEC (PubKeyEC_Named curveName pub) - -toPrivKeyEC :: ECC.CurveName -> ECDSA.PrivateKey -> PrivKey -toPrivKeyEC curveName key = - let priv = ECDSA.private_d key - in PrivKeyEC (PrivKeyEC_Named curveName priv) - -fromPoint :: ECC.Point -> (Integer, Integer) -fromPoint (ECC.Point x y) = (x, y) -fromPoint _ = error "fromPoint" diff --git a/core/Tests/Ciphers.hs b/core/Tests/Ciphers.hs deleted file mode 100644 index ad87971b3..000000000 --- a/core/Tests/Ciphers.hs +++ /dev/null @@ -1,53 +0,0 @@ --- Disable this warning so we can still test deprecated functionality. -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - -module Ciphers ( - propertyBulkFunctional, -) where - -import Test.Tasty.QuickCheck - -import qualified Data.ByteString as B -import Network.TLS.Cipher -import Network.TLS.Extra.Cipher - -arbitraryKey :: Bulk -> Gen B.ByteString -arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk) - -arbitraryIV :: Bulk -> Gen B.ByteString -arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk) - -arbitraryText :: Bulk -> Gen B.ByteString -arbitraryText bulk = B.pack `fmap` vector (bulkBlockSize bulk) - -data BulkTest = BulkTest Bulk B.ByteString B.ByteString B.ByteString B.ByteString - deriving (Show, Eq) - -instance Arbitrary BulkTest where - arbitrary = do - bulk <- cipherBulk `fmap` elements ciphersuite_all - BulkTest bulk - <$> arbitraryKey bulk - <*> arbitraryIV bulk - <*> arbitraryText bulk - <*> arbitraryText bulk - -propertyBulkFunctional :: BulkTest -> Bool -propertyBulkFunctional (BulkTest bulk key iv t additional) = - let enc = bulkInit bulk BulkEncrypt key - dec = bulkInit bulk BulkDecrypt key - in case (enc, dec) of - (BulkStateBlock encF, BulkStateBlock decF) -> block encF decF - (BulkStateAEAD encF, BulkStateAEAD decF) -> aead encF decF - (BulkStateStream (BulkStream encF), BulkStateStream (BulkStream decF)) -> stream encF decF - _ -> True - where - block e d = - let (etxt, e_iv) = e iv t - (dtxt, d_iv) = d iv etxt - in dtxt == t && d_iv == e_iv - stream e d = (fst . d . fst . e) t == t - aead e d = - let (encrypted, at) = e iv t additional - (decrypted, at2) = d iv encrypted additional - in decrypted == t && at == at2 diff --git a/core/Tests/Connection.hs b/core/Tests/Connection.hs deleted file mode 100644 index 21f859198..000000000 --- a/core/Tests/Connection.hs +++ /dev/null @@ -1,503 +0,0 @@ --- Disable this warning so we can still test deprecated functionality. -{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} - -module Connection ( - newPairContext, - arbitraryCiphers, - arbitraryVersions, - arbitraryHashSignatures, - arbitraryGroups, - arbitraryKeyUsage, - arbitraryPairParams, - arbitraryPairParams13, - arbitraryPairParamsWithVersionsAndCiphers, - arbitraryClientCredential, - arbitraryCredentialsOfEachCurve, - arbitraryRSACredentialWithUsage, - dhParamsGroup, - getConnectVersion, - isVersionEnabled, - isCustomDHParams, - isLeafRSA, - isCredentialDSA, - arbitraryEMSMode, - setEMSMode, - readClientSessionRef, - twoSessionRefs, - twoSessionManagers, - setPairParamsSessionManagers, - setPairParamsSessionResuming, - withDataPipe, - initiateDataPipe, - byeBye, -) where - -import Certificate -import Control.Concurrent -import Control.Concurrent.Async -import qualified Control.Exception as E -import Control.Monad (unless, when) -import Data.Default.Class -import Data.IORef -import Data.List (intersect) -import Data.X509 -import Network.TLS as TLS -import Network.TLS.Extra -import PipeChan -import PubKey -import Test.Tasty.QuickCheck - -import qualified Data.ByteString as B - -debug :: Bool -debug = False - -knownCiphers :: [Cipher] -knownCiphers = ciphersuite_all ++ ciphersuite_weak - where - ciphersuite_weak = - [ cipher_null_SHA1 - ] - -arbitraryCiphers :: Gen [Cipher] -arbitraryCiphers = listOf1 $ elements knownCiphers - -knownVersions :: [Version] -knownVersions = [TLS13, TLS12] - -arbitraryVersions :: Gen [Version] -arbitraryVersions = sublistOf knownVersions - --- for performance reason ecdsa_secp521r1_sha512 is not tested -knownHashSignatures :: [HashAndSignatureAlgorithm] -knownHashSignatures = - [ (TLS.HashIntrinsic, SignatureRSApssRSAeSHA512) - , (TLS.HashIntrinsic, SignatureRSApssRSAeSHA384) - , (TLS.HashIntrinsic, SignatureRSApssRSAeSHA256) - , (TLS.HashIntrinsic, SignatureEd25519) - , (TLS.HashIntrinsic, SignatureEd448) - , (TLS.HashSHA512, SignatureRSA) - , (TLS.HashSHA384, SignatureRSA) - , (TLS.HashSHA384, SignatureECDSA) - , (TLS.HashSHA256, SignatureRSA) - , (TLS.HashSHA256, SignatureECDSA) - , (TLS.HashSHA1, SignatureRSA) - , (TLS.HashSHA1, SignatureDSA) - ] - -knownHashSignatures13 :: [HashAndSignatureAlgorithm] -knownHashSignatures13 = filter compat knownHashSignatures - where - compat (h, s) = h /= TLS.HashSHA1 && s /= SignatureDSA && s /= SignatureRSA - -arbitraryHashSignatures :: Version -> Gen [HashAndSignatureAlgorithm] -arbitraryHashSignatures v = sublistOf l - where - l = if v < TLS13 then knownHashSignatures else knownHashSignatures13 - --- for performance reason P521, FFDHE6144, FFDHE8192 are not tested -knownGroups, knownECGroups, knownFFGroups :: [Group] -knownECGroups = [P256, P384, X25519, X448] -knownFFGroups = [FFDHE2048, FFDHE3072, FFDHE4096] -knownGroups = knownECGroups ++ knownFFGroups - -defaultECGroup :: Group -defaultECGroup = P256 -- same as defaultECCurve - -otherKnownECGroups :: [Group] -otherKnownECGroups = filter (/= defaultECGroup) knownECGroups - -arbitraryGroups :: Gen [Group] -arbitraryGroups = scale (min 5) $ listOf1 $ elements knownGroups - -isCredentialDSA :: (CertificateChain, PrivKey) -> Bool -isCredentialDSA (_, PrivKeyDSA _) = True -isCredentialDSA _ = False - -arbitraryCredentialsOfEachType :: Gen [(CertificateChain, PrivKey)] -arbitraryCredentialsOfEachType = arbitraryCredentialsOfEachType' >>= shuffle - -arbitraryCredentialsOfEachType' :: Gen [(CertificateChain, PrivKey)] -arbitraryCredentialsOfEachType' = do - let (pubKey, privKey) = getGlobalRSAPair - curveName = defaultECCurve - (dsaPub, dsaPriv) <- arbitraryDSAPair - (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName - (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair - (ed448Pub, ed448Priv) <- arbitraryEd448Pair - mapM - ( \(pub, priv) -> do - cert <- arbitraryX509WithKey (pub, priv) - return (CertificateChain [cert], priv) - ) - [ (PubKeyRSA pubKey, PrivKeyRSA privKey) - , (PubKeyDSA dsaPub, PrivKeyDSA dsaPriv) - , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) - , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) - , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) - ] - -arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)] -arbitraryCredentialsOfEachCurve = arbitraryCredentialsOfEachCurve' >>= shuffle - -arbitraryCredentialsOfEachCurve' :: Gen [(CertificateChain, PrivKey)] -arbitraryCredentialsOfEachCurve' = do - ecdsaPairs <- - mapM - ( \curveName -> do - (ecdsaPub, ecdsaPriv) <- arbitraryECDSAPair curveName - return (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) - ) - knownECCurves - (ed25519Pub, ed25519Priv) <- arbitraryEd25519Pair - (ed448Pub, ed448Priv) <- arbitraryEd448Pair - mapM - ( \(pub, priv) -> do - cert <- arbitraryX509WithKey (pub, priv) - return (CertificateChain [cert], priv) - ) - $ [ (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) - , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) - ] - ++ ecdsaPairs - -dhParamsGroup :: DHParams -> Maybe Group -dhParamsGroup params - | params == ffdhe2048 = Just FFDHE2048 - | params == ffdhe3072 = Just FFDHE3072 - | otherwise = Nothing - -isCustomDHParams :: DHParams -> Bool -isCustomDHParams params = params == dhParams512 - -leafPublicKey :: CertificateChain -> Maybe PubKey -leafPublicKey (CertificateChain []) = Nothing -leafPublicKey (CertificateChain (leaf : _)) = Just (certPubKey $ getCertificate leaf) - -isLeafRSA :: Maybe CertificateChain -> Bool -isLeafRSA chain = case chain >>= leafPublicKey of - Just (PubKeyRSA _) -> True - _ -> False - -arbitraryCipherPair :: Version -> Gen ([Cipher], [Cipher]) -arbitraryCipherPair connectVersion = do - serverCiphers <- - arbitraryCiphers - `suchThat` (\cs -> or [cipherAllowedForVersion connectVersion x | x <- cs]) - clientCiphers <- - arbitraryCiphers - `suchThat` ( \cs -> - or - [ x `elem` serverCiphers - && cipherAllowedForVersion connectVersion x - | x <- cs - ] - ) - return (clientCiphers, serverCiphers) - -arbitraryPairParams :: Gen (ClientParams, ServerParams) -arbitraryPairParams = elements knownVersions >>= arbitraryPairParamsAt - --- Pair of groups so that at least the default EC group P256 and one FF group --- are in common. This makes DHE and ECDHE ciphers always compatible with --- extension "Supported Elliptic Curves" / "Supported Groups". -arbitraryGroupPair :: Gen ([Group], [Group]) -arbitraryGroupPair = do - (serverECGroups, clientECGroups) <- - arbitraryGroupPairWith defaultECGroup otherKnownECGroups - (serverFFGroups, clientFFGroups) <- arbitraryGroupPairFrom knownFFGroups - serverGroups <- shuffle (serverECGroups ++ serverFFGroups) - clientGroups <- shuffle (clientECGroups ++ clientFFGroups) - return (clientGroups, serverGroups) - where - arbitraryGroupPairFrom list = - elements list >>= \e -> - arbitraryGroupPairWith e (filter (/= e) list) - arbitraryGroupPairWith e es = do - s <- sublistOf es - c <- sublistOf es - return (e : s, e : c) - -arbitraryPairParams13 :: Gen (ClientParams, ServerParams) -arbitraryPairParams13 = arbitraryPairParamsAt TLS13 - -arbitraryPairParamsAt :: Version -> Gen (ClientParams, ServerParams) -arbitraryPairParamsAt connectVersion = do - (clientCiphers, serverCiphers) <- arbitraryCipherPair connectVersion - -- Select version lists containing connectVersion, as well as some other - -- versions for which we have compatible ciphers. Criteria about cipher - -- ensure we can test version downgrade. - let allowedVersions = - [ v | v <- knownVersions, or - [ x `elem` serverCiphers - && cipherAllowedForVersion v x - | x <- clientCiphers - ] - ] - allowedVersionsFiltered = filter (<= connectVersion) allowedVersions - -- Server or client is allowed to have versions > connectVersion, but not - -- both simultaneously. - filterSrv <- arbitrary - let (clientAllowedVersions, serverAllowedVersions) - | filterSrv = (allowedVersions, allowedVersionsFiltered) - | otherwise = (allowedVersionsFiltered, allowedVersions) - -- Generate version lists containing less than 127 elements, otherwise the - -- "supported_versions" extension cannot be correctly serialized - clientVersions <- listWithOthers connectVersion 126 clientAllowedVersions - serverVersions <- listWithOthers connectVersion 126 serverAllowedVersions - arbitraryPairParamsWithVersionsAndCiphers - (clientVersions, serverVersions) - (clientCiphers, serverCiphers) - where - listWithOthers :: a -> Int -> [a] -> Gen [a] - listWithOthers fixedElement maxOthers others - | maxOthers < 1 = return [fixedElement] - | otherwise = sized $ \n -> do - num <- choose (0, min n maxOthers) - pos <- choose (0, num) - prefix <- vectorOf pos $ elements others - suffix <- vectorOf (num - pos) $ elements others - return $ prefix ++ (fixedElement : suffix) - -getConnectVersion :: (ClientParams, ServerParams) -> Version -getConnectVersion (cparams, sparams) = maximum (cver `intersect` sver) - where - sver = supportedVersions (serverSupported sparams) - cver = supportedVersions (clientSupported cparams) - -isVersionEnabled :: Version -> (ClientParams, ServerParams) -> Bool -isVersionEnabled ver (cparams, sparams) = - (ver `elem` supportedVersions (serverSupported sparams)) - && (ver `elem` supportedVersions (clientSupported cparams)) - -arbitraryHashSignaturePair - :: Gen ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -arbitraryHashSignaturePair = do - serverHashSignatures <- shuffle knownHashSignatures - clientHashSignatures <- shuffle knownHashSignatures - return (clientHashSignatures, serverHashSignatures) - -arbitraryPairParamsWithVersionsAndCiphers - :: ([Version], [Version]) - -> ([Cipher], [Cipher]) - -> Gen (ClientParams, ServerParams) -arbitraryPairParamsWithVersionsAndCiphers (clientVersions, serverVersions) (clientCiphers, serverCiphers) = do - secNeg <- arbitrary - dhparams <- elements [dhParams512, ffdhe2048, ffdhe3072] - - creds <- arbitraryCredentialsOfEachType - (clientGroups, serverGroups) <- arbitraryGroupPair - (clientHashSignatures, serverHashSignatures) <- arbitraryHashSignaturePair - let serverState = - def - { serverSupported = - def - { supportedCiphers = serverCiphers - , supportedVersions = serverVersions - , supportedSecureRenegotiation = secNeg - , supportedGroups = serverGroups - , supportedHashSignatures = serverHashSignatures - } - , serverDHEParams = Just dhparams - , serverShared = def{sharedCredentials = Credentials creds} - } - let clientState = - (defaultParamsClient "" B.empty) - { clientSupported = - def - { supportedCiphers = clientCiphers - , supportedVersions = clientVersions - , supportedSecureRenegotiation = secNeg - , supportedGroups = clientGroups - , supportedHashSignatures = clientHashSignatures - } - , clientShared = - def - { sharedValidationCache = - ValidationCache - { cacheAdd = \_ _ _ -> return () - , cacheQuery = \_ _ _ -> return ValidationCachePass - } - } - } - return (clientState, serverState) - -arbitraryClientCredential :: Version -> Gen Credential -arbitraryClientCredential _ = arbitraryCredentialsOfEachType' >>= elements - -arbitraryRSACredentialWithUsage - :: [ExtKeyUsageFlag] -> Gen (CertificateChain, PrivKey) -arbitraryRSACredentialWithUsage usageFlags = do - let (pubKey, privKey) = getGlobalRSAPair - cert <- arbitraryX509WithKeyAndUsage usageFlags (PubKeyRSA pubKey, ()) - return (CertificateChain [cert], PrivKeyRSA privKey) - -arbitraryEMSMode :: Gen (EMSMode, EMSMode) -arbitraryEMSMode = (,) <$> gen <*> gen - where - gen = elements [NoEMS, AllowEMS, RequireEMS] - -setEMSMode - :: (EMSMode, EMSMode) - -> (ClientParams, ServerParams) - -> (ClientParams, ServerParams) -setEMSMode (cems, sems) (clientParam, serverParam) = (clientParam', serverParam') - where - clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedExtendedMasterSec = cems - } - } - serverParam' = - serverParam - { serverSupported = - (serverSupported serverParam) - { supportedExtendedMasterSec = sems - } - } - -readClientSessionRef :: (IORef mclient, IORef mserver) -> IO mclient -readClientSessionRef refs = readIORef (fst refs) - -twoSessionRefs :: IO (IORef (Maybe client), IORef (Maybe server)) -twoSessionRefs = (,) <$> newIORef Nothing <*> newIORef Nothing - --- | simple session manager to store one session id and session data for a single thread. --- a Real concurrent session manager would use an MVar and have multiples items. -oneSessionManager :: IORef (Maybe (SessionID, SessionData)) -> SessionManager -oneSessionManager ref = - SessionManager - { sessionResume = \myId -> readIORef ref >>= maybeResume False myId - , sessionResumeOnlyOnce = \myId -> readIORef ref >>= maybeResume True myId - , sessionEstablish = \myId dat -> writeIORef ref $ Just (myId, dat) - , sessionInvalidate = \_ -> return () - } - where - maybeResume onlyOnce myId (Just (sid, sdata)) - | sid == myId = when onlyOnce (writeIORef ref Nothing) >> return (Just sdata) - maybeResume _ _ _ = return Nothing - -twoSessionManagers - :: (IORef (Maybe (SessionID, SessionData)), IORef (Maybe (SessionID, SessionData))) - -> (SessionManager, SessionManager) -twoSessionManagers (cRef, sRef) = (oneSessionManager cRef, oneSessionManager sRef) - -setPairParamsSessionManagers - :: (SessionManager, SessionManager) - -> (ClientParams, ServerParams) - -> (ClientParams, ServerParams) -setPairParamsSessionManagers (clientManager, serverManager) (clientState, serverState) = (nc, ns) - where - nc = - clientState - { clientShared = updateSessionManager clientManager $ clientShared clientState - } - ns = - serverState - { serverShared = updateSessionManager serverManager $ serverShared serverState - } - updateSessionManager manager shared = shared{sharedSessionManager = manager} - -setPairParamsSessionResuming - :: (SessionID, SessionData) - -> (ClientParams, ServerParams) - -> (ClientParams, ServerParams) -setPairParamsSessionResuming sessionStuff (clientState, serverState) = - ( clientState{clientWantSessionResume = Just sessionStuff} - , serverState - ) - -newPairContext - :: PipeChan -> (ClientParams, ServerParams) -> IO (Context, Context) -newPairContext pipe (cParams, sParams) = do - let noFlush = return () - let noClose = return () - - let cBackend = Backend noFlush noClose (writePipeA pipe) (readPipeA pipe) - let sBackend = Backend noFlush noClose (writePipeB pipe) (readPipeB pipe) - cCtx' <- contextNew cBackend cParams - sCtx' <- contextNew sBackend sParams - - contextHookSetLogging cCtx' (logging "client: ") - contextHookSetLogging sCtx' (logging "server: ") - - return (cCtx', sCtx') - where - logging pre = - if debug - then - def - { loggingPacketSent = putStrLn . ((pre ++ ">> ") ++) - , loggingPacketRecv = putStrLn . ((pre ++ "<< ") ++) - } - else def - -withDataPipe - :: (ClientParams, ServerParams) - -> (Context -> Chan result -> IO ()) - -> (Chan start -> Context -> IO ()) - -> ((start -> IO (), IO result) -> IO a) - -> IO a -withDataPipe params tlsServer tlsClient cont = do - -- initial setup - pipe <- newPipe - _ <- runPipe pipe - startQueue <- newChan - resultQueue <- newChan - - (cCtx, sCtx) <- newPairContext pipe params - - withAsync - ( E.catch - (tlsServer sCtx resultQueue) - (printAndRaise "server" (serverSupported $ snd params)) - ) - $ \sAsync -> withAsync - ( E.catch - (tlsClient startQueue cCtx) - (printAndRaise "client" (clientSupported $ fst params)) - ) - $ \cAsync -> do - let readResult = waitBoth cAsync sAsync >> readChan resultQueue - cont (writeChan startQueue, readResult) - where - printAndRaise :: String -> Supported -> E.SomeException -> IO () - printAndRaise s supported e = do - putStrLn $ - s - ++ " exception: " - ++ show e - ++ ", supported: " - ++ show supported - E.throwIO e - -initiateDataPipe - :: (ClientParams, ServerParams) - -> (Context -> IO a1) - -> (Context -> IO a) - -> IO (Either E.SomeException a, Either E.SomeException a1) -initiateDataPipe params tlsServer tlsClient = do - -- initial setup - pipe <- newPipe - _ <- runPipe pipe - - (cCtx, sCtx) <- newPairContext pipe params - - async (tlsServer sCtx) >>= \sAsync -> - async (tlsClient cCtx) >>= \cAsync -> do - sRes <- waitCatch sAsync - cRes <- waitCatch cAsync - return (cRes, sRes) - --- Terminate the write direction and wait to receive the peer EOF. This is --- necessary in situations where we want to confirm the peer status, or to make --- sure to receive late messages like session tickets. In the test suite this --- is used each time application code ends the connection without prior call to --- 'recvData'. -byeBye :: Context -> IO () -byeBye ctx = do - bye ctx - bs <- recvData ctx - unless (B.null bs) $ fail "byeBye: unexpected application data" diff --git a/core/Tests/Marshalling.hs b/core/Tests/Marshalling.hs deleted file mode 100644 index 11107d906..000000000 --- a/core/Tests/Marshalling.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Marshalling ( - someWords8, - prop_header_marshalling_id, - prop_handshake_marshalling_id, - prop_handshake13_marshalling_id, -) where - -import Control.Monad -import Network.TLS -import Network.TLS.Internal -import Test.Tasty.QuickCheck - -import Certificate -import qualified Data.ByteString as B -import Data.Word -import Data.X509 (CertificateChain (..)) - -genByteString :: Int -> Gen B.ByteString -genByteString i = B.pack <$> vector i - -instance Arbitrary Version where - arbitrary = elements [TLS12, TLS13] - -instance Arbitrary ProtocolType where - arbitrary = - elements - [ ProtocolType_ChangeCipherSpec - , ProtocolType_Alert - , ProtocolType_Handshake - , ProtocolType_AppData - ] - -instance Arbitrary Header where - arbitrary = Header <$> arbitrary <*> arbitrary <*> arbitrary - -instance Arbitrary ClientRandom where - arbitrary = ClientRandom <$> genByteString 32 - -instance Arbitrary ServerRandom where - arbitrary = ServerRandom <$> genByteString 32 - -instance Arbitrary Session where - arbitrary = do - i <- choose (1, 2) :: Gen Int - case i of - 2 -> Session . Just <$> genByteString 32 - _ -> return $ Session Nothing - -instance Arbitrary HashAlgorithm where - arbitrary = - elements - [ Network.TLS.HashNone - , Network.TLS.HashMD5 - , Network.TLS.HashSHA1 - , Network.TLS.HashSHA224 - , Network.TLS.HashSHA256 - , Network.TLS.HashSHA384 - , Network.TLS.HashSHA512 - , Network.TLS.HashIntrinsic - ] - -instance Arbitrary SignatureAlgorithm where - arbitrary = - elements - [ SignatureAnonymous - , SignatureRSA - , SignatureDSA - , SignatureECDSA - , SignatureRSApssRSAeSHA256 - , SignatureRSApssRSAeSHA384 - , SignatureRSApssRSAeSHA512 - , SignatureEd25519 - , SignatureEd448 - , SignatureRSApsspssSHA256 - , SignatureRSApsspssSHA384 - , SignatureRSApsspssSHA512 - ] - -instance Arbitrary DigitallySigned where - arbitrary = DigitallySigned <$> arbitrary <*> genByteString 32 - -arbitraryCiphersIDs :: Gen [Word16] -arbitraryCiphersIDs = choose (0, 200) >>= vector - -arbitraryCompressionIDs :: Gen [Word8] -arbitraryCompressionIDs = choose (0, 200) >>= vector - -someWords8 :: Int -> Gen [Word8] -someWords8 = vector - -instance Arbitrary ExtensionRaw where - arbitrary = - let arbitraryContent = choose (0, 40) >>= genByteString - in ExtensionRaw <$> (ExtensionID <$> arbitrary) <*> arbitraryContent - -arbitraryHelloExtensions :: Version -> Gen [ExtensionRaw] -arbitraryHelloExtensions _ver = arbitrary - -instance Arbitrary CertificateType where - arbitrary = - elements - [ CertificateType_RSA_Sign - , CertificateType_DSA_Sign - , CertificateType_ECDSA_Sign - ] - -instance Arbitrary Handshake where - arbitrary = - oneof - [ arbitrary >>= \ver -> - ClientHello ver - <$> arbitrary - <*> arbitrary - <*> arbitraryCiphersIDs - <*> arbitraryCompressionIDs - <*> arbitraryHelloExtensions ver - <*> return Nothing - , arbitrary >>= \ver -> - ServerHello ver - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryHelloExtensions ver - , Certificates . CertificateChain <$> resize 2 (listOf arbitraryX509) - , pure HelloRequest - , pure ServerHelloDone - , ClientKeyXchg . CKX_RSA <$> genByteString 48 - , CertRequest <$> arbitrary <*> arbitrary <*> listOf arbitraryDN - , CertVerify <$> arbitrary - , Finished <$> genByteString 12 - ] - -arbitraryCertReqContext :: Gen B.ByteString -arbitraryCertReqContext = oneof [return B.empty, genByteString 32] - -instance Arbitrary Handshake13 where - arbitrary = - oneof - [ arbitrary >>= \ver -> - ClientHello13 ver - <$> arbitrary - <*> arbitrary - <*> arbitraryCiphersIDs - <*> arbitraryHelloExtensions ver - , arbitrary >>= \ver -> - ServerHello13 - <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitraryHelloExtensions ver - , NewSessionTicket13 - <$> arbitrary - <*> arbitrary - <*> genByteString 32 -- nonce - <*> genByteString 32 -- session ID - <*> arbitrary - , pure EndOfEarlyData13 - , EncryptedExtensions13 <$> arbitrary - , CertRequest13 - <$> arbitraryCertReqContext - <*> arbitrary - , resize 2 (listOf arbitraryX509) >>= \certs -> - Certificate13 - <$> arbitraryCertReqContext - <*> return (CertificateChain certs) - <*> replicateM (length certs) arbitrary - , CertVerify13 <$> arbitrary <*> genByteString 32 - , Finished13 <$> genByteString 12 - , KeyUpdate13 <$> elements [UpdateNotRequested, UpdateRequested] - ] - -{- quickcheck property -} - -prop_header_marshalling_id :: Header -> Bool -prop_header_marshalling_id x = decodeHeader (encodeHeader x) == Right x - -prop_handshake_marshalling_id :: Handshake -> Bool -prop_handshake_marshalling_id x = decodeHs (encodeHandshake x) == Right x - where - decodeHs b = verifyResult (decodeHandshake cp) $ decodeHandshakeRecord b - cp = - CurrentParams - { cParamsVersion = TLS12 - , cParamsKeyXchgType = Just CipherKeyExchange_RSA - } - -prop_handshake13_marshalling_id :: Handshake13 -> Bool -prop_handshake13_marshalling_id x = decodeHs (encodeHandshake13 x) == Right x - where - decodeHs b = verifyResult decodeHandshake13 $ decodeHandshakeRecord13 b - -verifyResult :: (t -> b -> r) -> GetResult (t, b) -> r -verifyResult fn result = - case result of - GotPartial _ -> error "got partial" - GotError e -> error ("got error: " ++ show e) - GotSuccessRemaining _ _ -> error "got remaining byte left" - GotSuccess (ty, content) -> fn ty content diff --git a/core/Tests/PipeChan.hs b/core/Tests/PipeChan.hs deleted file mode 100644 index 8f04fd840..000000000 --- a/core/Tests/PipeChan.hs +++ /dev/null @@ -1,74 +0,0 @@ --- create a similar concept than a unix pipe. -module PipeChan ( - PipeChan (..), - newPipe, - runPipe, - readPipeA, - readPipeB, - writePipeA, - writePipeB, -) where - -import Control.Concurrent -import Control.Monad (forever) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import Data.IORef - --- | represent a unidirectional pipe with a buffered read channel and a write channel -data UniPipeChan = UniPipeChan (Chan ByteString) (Chan ByteString) - -newUniPipeChan :: IO UniPipeChan -newUniPipeChan = UniPipeChan <$> newChan <*> newChan - -runUniPipe :: UniPipeChan -> IO ThreadId -runUniPipe (UniPipeChan r w) = forkIO $ forever $ readChan r >>= writeChan w - -getReadUniPipe :: UniPipeChan -> Chan ByteString -getReadUniPipe (UniPipeChan r _) = r - -getWriteUniPipe :: UniPipeChan -> Chan ByteString -getWriteUniPipe (UniPipeChan _ w) = w - --- | Represent a bidirectional pipe with 2 nodes A and B -data PipeChan - = PipeChan (IORef ByteString) (IORef ByteString) UniPipeChan UniPipeChan - -newPipe :: IO PipeChan -newPipe = - PipeChan - <$> newIORef B.empty - <*> newIORef B.empty - <*> newUniPipeChan - <*> newUniPipeChan - -runPipe :: PipeChan -> IO ThreadId -runPipe (PipeChan _ _ cToS sToC) = runUniPipe cToS >> runUniPipe sToC - -readPipeA :: PipeChan -> Int -> IO ByteString -readPipeA (PipeChan _ b _ s) sz = readBuffered b (getWriteUniPipe s) sz - -writePipeA :: PipeChan -> ByteString -> IO () -writePipeA (PipeChan _ _ c _) = writeChan $ getWriteUniPipe c - -readPipeB :: PipeChan -> Int -> IO ByteString -readPipeB (PipeChan b _ c _) sz = readBuffered b (getWriteUniPipe c) sz - -writePipeB :: PipeChan -> ByteString -> IO () -writePipeB (PipeChan _ _ _ s) = writeChan $ getReadUniPipe s - --- helper to read buffered data. -readBuffered :: IORef ByteString -> Chan ByteString -> Int -> IO ByteString -readBuffered buf chan sz = do - left <- readIORef buf - if B.length left >= sz - then do - let (ret, nleft) = B.splitAt sz left - writeIORef buf nleft - return ret - else do - let newSize = (sz - B.length left) - newData <- readChan chan - writeIORef buf newData - remain <- readBuffered buf chan newSize - return (left `B.append` remain) diff --git a/core/Tests/PubKey.hs b/core/Tests/PubKey.hs deleted file mode 100644 index 25e16330f..000000000 --- a/core/Tests/PubKey.hs +++ /dev/null @@ -1,157 +0,0 @@ -module PubKey ( - arbitraryRSAPair, - arbitraryDSAPair, - arbitraryECDSAPair, - arbitraryEd25519Pair, - arbitraryEd448Pair, - globalRSAPair, - getGlobalRSAPair, - knownECCurves, - defaultECCurve, - dhParams512, - dhParams768, - dhParams1024, - dsaParams, - rsaParams, -) where - -import Test.Tasty.QuickCheck - -import Crypto.Error -import qualified Crypto.PubKey.DH as DH -import qualified Crypto.PubKey.DSA as DSA -import qualified Crypto.PubKey.ECC.ECDSA as ECDSA -import qualified Crypto.PubKey.ECC.Prim as ECC -import qualified Crypto.PubKey.ECC.Types as ECC -import qualified Crypto.PubKey.Ed25519 as Ed25519 -import qualified Crypto.PubKey.Ed448 as Ed448 -import qualified Crypto.PubKey.RSA as RSA -import Crypto.Random -import qualified Data.ByteString as B - -import Control.Concurrent.MVar -import System.IO.Unsafe - -arbitraryRSAPair :: Gen (RSA.PublicKey, RSA.PrivateKey) -arbitraryRSAPair = (rngToRSA . drgNewTest) `fmap` arbitrary - where - rngToRSA :: ChaChaDRG -> (RSA.PublicKey, RSA.PrivateKey) - rngToRSA rng = fst $ withDRG rng arbitraryRSAPairWithRNG - -arbitraryRSAPairWithRNG :: MonadRandom m => m (RSA.PublicKey, RSA.PrivateKey) -arbitraryRSAPairWithRNG = RSA.generate 256 0x10001 - -{-# NOINLINE globalRSAPair #-} -globalRSAPair :: MVar (RSA.PublicKey, RSA.PrivateKey) -globalRSAPair = unsafePerformIO $ do - drg <- drgNew - newMVar (fst $ withDRG drg arbitraryRSAPairWithRNG) - -{-# NOINLINE getGlobalRSAPair #-} -getGlobalRSAPair :: (RSA.PublicKey, RSA.PrivateKey) -getGlobalRSAPair = unsafePerformIO (readMVar globalRSAPair) - -rsaParams :: (RSA.PublicKey, RSA.PrivateKey) -rsaParams = (pub, priv) - where - priv = - RSA.PrivateKey - { RSA.private_pub = pub - , RSA.private_d = d - , RSA.private_p = 0 - , RSA.private_q = 0 - , RSA.private_dP = 0 - , RSA.private_dQ = 0 - , RSA.private_qinv = 0 - } - pub = - RSA.PublicKey - { RSA.public_size = (1024 `div` 8) - , RSA.public_n = n - , RSA.public_e = e - } - n = - 0x00c086b4c6db28ae578d73766d6fdd04b913808a85bf9ad7bcfc9a6ff04d13d2ff75f761ce7db9ee8996e29dc433d19a2d3f748e8d368ba099781d58276e1863a324ae3fb1a061874cd9f3510e54e49727c68de0616964335371cfb63f15ebff8ce8df09c74fb8625f8f58548b90f079a3405f522e738e664d0c645b015664f7c7 - e = 0x10001 - d = - 0x3edc3cae28e4717818b1385ba7088d0038c3e176a606d2a5dbfc38cc46fe500824e62ec312fde04a803f61afac13a5b95c5c9c26b346879b54429083df488b4f29bb7b9722d366d6f5d2b512150a2e950eacfe0fd9dd56b87b0322f74ae3c8d8674ace62bc723f7c05e9295561efd70d7a924c6abac2e482880fc0149d5ad481 - -dhParams512 :: DH.Params -dhParams512 = - DH.Params - { DH.params_p = - 0x00ccaa3884b50789ebea8d39bef8bbc66e20f2a78f537a76f26b4edde5de8b0ff15a8193abf0873cbdc701323a2bf6e860affa6e043fe8300d47e95baf9f6354cb - , DH.params_g = 0x2 - , DH.params_bits = 512 - } - --- from RFC 2409 - -dhParams768 :: DH.Params -dhParams768 = - DH.Params - { DH.params_p = - 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a63a3620ffffffffffffffff - , DH.params_g = 0x2 - , DH.params_bits = 768 - } - -dhParams1024 :: DH.Params -dhParams1024 = - DH.Params - { DH.params_p = - 0xffffffffffffffffc90fdaa22168c234c4c6628b80dc1cd129024e088a67cc74020bbea63b139b22514a08798e3404ddef9519b3cd3a431b302b0a6df25f14374fe1356d6d51c245e485b576625e7ec6f44c42e9a637ed6b0bff5cb6f406b7edee386bfb5a899fa5ae9f24117c4b1fe649286651ece65381ffffffffffffffff - , DH.params_g = 0x2 - , DH.params_bits = 1024 - } - -dsaParams :: DSA.Params -dsaParams = - DSA.Params - { DSA.params_p = - 0x009f356bbc4750645555b02aa3918e85d5e35bdccd56154bfaa3e1801d5fe0faf65355215148ea866d5732fd27eb2f4d222c975767d2eb573513e460eceae327c8ac5da1f4ce765c49a39cae4c904b4e5cc64554d97148f20a2655027a0cf8f70b2550cc1f0c9861ce3a316520ab0588407ea3189d20c78bd52df97e56cbe0bbeb - , DSA.params_q = 0x00f33a57b47de86ff836f9fe0bb060c54ab293133b - , DSA.params_g = - 0x3bb973c4f6eee92d1530f250487735595d778c2e5c8147d67a46ebcba4e6444350d49da8e7da667f9b1dbb22d2108870b9fcfabc353cdfac5218d829f22f69130317cc3b0d724881e34c34b8a2571d411da6458ef4c718df9e826f73e16a035b1dcbc1c62cac7a6604adb3e7930be8257944c6dfdddd655004b98253185775ff - } - -arbitraryDSAPair :: Gen (DSA.PublicKey, DSA.PrivateKey) -arbitraryDSAPair = do - priv <- choose (1, DSA.params_q dsaParams) - let pub = DSA.calculatePublic dsaParams priv - return (DSA.PublicKey dsaParams pub, DSA.PrivateKey dsaParams priv) - --- for performance reason P521 is not tested -knownECCurves :: [ECC.CurveName] -knownECCurves = - [ ECC.SEC_p256r1 - , ECC.SEC_p384r1 - ] - -defaultECCurve :: ECC.CurveName -defaultECCurve = ECC.SEC_p256r1 - -arbitraryECDSAPair :: ECC.CurveName -> Gen (ECDSA.PublicKey, ECDSA.PrivateKey) -arbitraryECDSAPair curveName = do - d <- choose (1, n - 1) - let p = ECC.pointBaseMul curve d - return (ECDSA.PublicKey curve p, ECDSA.PrivateKey curve d) - where - curve = ECC.getCurveByName curveName - n = ECC.ecc_n . ECC.common_curve $ curve - -arbitraryEd25519Pair :: Gen (Ed25519.PublicKey, Ed25519.SecretKey) -arbitraryEd25519Pair = do - bytes <- vectorOf 32 arbitrary - let priv = fromCryptoPassed $ Ed25519.secretKey (B.pack bytes) - return (Ed25519.toPublic priv, priv) - -arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey) -arbitraryEd448Pair = do - bytes <- vectorOf 57 arbitrary - let priv = fromCryptoPassed $ Ed448.secretKey (B.pack bytes) - return (Ed448.toPublic priv, priv) - -fromCryptoPassed :: CryptoFailable a -> a -fromCryptoPassed (CryptoPassed x) = x -fromCryptoPassed _ = error "fromCryptoPassed" diff --git a/core/Tests/Tests.hs b/core/Tests/Tests.hs deleted file mode 100644 index ba57d0bd8..000000000 --- a/core/Tests/Tests.hs +++ /dev/null @@ -1,1270 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -import Test.QuickCheck.Monadic -import Test.Tasty -import Test.Tasty.QuickCheck - -import Ciphers -import Connection -import Marshalling -import PipeChan -import PubKey - -import Data.Default.Class -import Data.Foldable (traverse_) -import Data.List (intersect) -import Data.Maybe - -import Control.Concurrent -import Control.Concurrent.Async -import Control.Monad -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as L -import Network.TLS -import Network.TLS.Extra -import Network.TLS.Internal - -import Data.IORef -import Data.X509 (ExtKeyUsageFlag (..)) - -import System.Timeout - -prop_pipe_work :: PropertyM IO () -prop_pipe_work = do - pipe <- run newPipe - _ <- run (runPipe pipe) - - let bSize = 16 - n <- pick (choose (1, 32)) - - let d1 = B.replicate (bSize * n) 40 - let d2 = B.replicate (bSize * n) 45 - - d1' <- run (writePipeA pipe d1 >> readPipeB pipe (B.length d1)) - d1 `assertEq` d1' - - d2' <- run (writePipeB pipe d2 >> readPipeA pipe (B.length d2)) - d2 `assertEq` d2' - - return () - -chunkLengths :: Int -> [Int] -chunkLengths len - | len > 16384 = 16384 : chunkLengths (len - 16384) - | len > 0 = [len] - | otherwise = [] - -runTLSPipeN - :: Int - -> (ClientParams, ServerParams) - -> (Context -> Chan [C8.ByteString] -> IO ()) - -> (Chan C8.ByteString -> Context -> IO ()) - -> PropertyM IO () -runTLSPipeN n params tlsServer tlsClient = do - -- generate some data to send - ds <- replicateM n $ do - d <- B.pack <$> pick (someWords8 256) - return d - -- send it - m_dsres <- run $ do - withDataPipe params tlsServer tlsClient $ \(writeStart, readResult) -> do - forM_ ds $ \d -> do - writeStart d - -- receive it - timeout 60000000 readResult -- 60 sec - case m_dsres of - Nothing -> error "timed out" - Just dsres -> ds `assertEq` dsres - -runTLSPipe - :: (ClientParams, ServerParams) - -> (Context -> Chan [C8.ByteString] -> IO ()) - -> (Chan C8.ByteString -> Context -> IO ()) - -> PropertyM IO () -runTLSPipe = runTLSPipeN 1 - -runTLSPipePredicate - :: (ClientParams, ServerParams) -> (Maybe Information -> Bool) -> PropertyM IO () -runTLSPipePredicate params p = runTLSPipe params tlsServer tlsClient - where - tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - checkInfoPredicate ctx - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - checkInfoPredicate ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - checkInfoPredicate ctx = do - minfo <- contextGetInformation ctx - unless (p minfo) $ - fail ("unexpected information: " ++ show minfo) - -runTLSPipeSimple :: (ClientParams, ServerParams) -> PropertyM IO () -runTLSPipeSimple params = runTLSPipePredicate params (const True) - -runTLSPipeSimple13 - :: (ClientParams, ServerParams) - -> HandshakeMode13 - -> Maybe C8.ByteString - -> PropertyM IO () -runTLSPipeSimple13 params mode mEarlyData = runTLSPipe params tlsServer tlsClient - where - tlsServer ctx queue = do - handshake ctx - case mEarlyData of - Nothing -> return () - Just ed -> do - let ls = chunkLengths (B.length ed) - chunks <- replicateM (length ls) $ recvData ctx - (ls, ed) `assertEq` (map B.length chunks, B.concat chunks) - d <- recvData ctx - checkCtxFinished ctx - writeChan queue [d] - minfo <- contextGetInformation ctx - Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - minfo <- contextGetInformation ctx - Just mode `assertEq` (minfo >>= infoTLS13HandshakeMode) - byeBye ctx - -runTLSPipeCapture13 - :: (ClientParams, ServerParams) -> PropertyM IO ([Handshake13], [Handshake13]) -runTLSPipeCapture13 params = do - sRef <- run $ newIORef [] - cRef <- run $ newIORef [] - runTLSPipe params (tlsServer sRef) (tlsClient cRef) - sReceived <- run $ readIORef sRef - cReceived <- run $ readIORef cRef - return (reverse sReceived, reverse cReceived) - where - tlsServer ref ctx queue = do - installHook ctx ref - handshake ctx - checkCtxFinished ctx - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient ref queue ctx = do - installHook ctx ref - handshake ctx - checkCtxFinished ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - installHook ctx ref = - let recv hss = modifyIORef ref (hss :) >> return hss - in contextHookSetHandshake13Recv ctx recv - -runTLSPipeSimpleKeyUpdate :: (ClientParams, ServerParams) -> PropertyM IO () -runTLSPipeSimpleKeyUpdate params = runTLSPipeN 3 params tlsServer tlsClient - where - tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - d0 <- recvData ctx - req <- generate $ elements [OneWay, TwoWay] - _ <- updateKey ctx req - d1 <- recvData ctx - d2 <- recvData ctx - writeChan queue [d0, d1, d2] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - d0 <- readChan queue - sendData ctx (L.fromChunks [d0]) - d1 <- readChan queue - sendData ctx (L.fromChunks [d1]) - req <- generate $ elements [OneWay, TwoWay] - _ <- updateKey ctx req - d2 <- readChan queue - sendData ctx (L.fromChunks [d2]) - byeBye ctx - -runTLSInitFailureGen - :: (ClientParams, ServerParams) - -> (Context -> IO s) - -> (Context -> IO c) - -> PropertyM IO () -runTLSInitFailureGen params hsServer hsClient = do - (cRes, sRes) <- run (initiateDataPipe params tlsServer tlsClient) - assertIsLeft cRes - assertIsLeft sRes - where - tlsServer ctx = do - _ <- hsServer ctx - checkCtxFinished ctx - minfo <- contextGetInformation ctx - byeBye ctx - return $ "server success: " ++ show minfo - tlsClient ctx = do - _ <- hsClient ctx - checkCtxFinished ctx - minfo <- contextGetInformation ctx - byeBye ctx - return $ "client success: " ++ show minfo - -runTLSInitFailure :: (ClientParams, ServerParams) -> PropertyM IO () -runTLSInitFailure params = runTLSInitFailureGen params handshake handshake - -prop_handshake_initiate :: PropertyM IO () -prop_handshake_initiate = do - params <- pick arbitraryPairParams - runTLSPipeSimple params - -prop_handshake13_initiate :: PropertyM IO () -prop_handshake13_initiate = do - params <- pick arbitraryPairParams13 - let cgrps = supportedGroups $ clientSupported $ fst params - sgrps = supportedGroups $ serverSupported $ snd params - hs = if head cgrps `elem` sgrps then FullHandshake else HelloRetryRequest - runTLSPipeSimple13 params hs Nothing - -prop_handshake_keyupdate :: PropertyM IO () -prop_handshake_keyupdate = do - params <- pick arbitraryPairParams - runTLSPipeSimpleKeyUpdate params - -prop_handshake13_downgrade :: PropertyM IO () -prop_handshake13_downgrade = do - (cparam, sparam) <- pick arbitraryPairParams - versionForced <- pick $ elements (supportedVersions $ clientSupported cparam) - let debug' = (serverDebug sparam){debugVersionForced = Just versionForced} - sparam' = sparam{serverDebug = debug'} - params = (cparam, sparam') - downgraded = - (isVersionEnabled TLS13 params && versionForced < TLS13) - || (isVersionEnabled TLS12 params && versionForced < TLS12) - if downgraded - then runTLSInitFailure params - else runTLSPipeSimple params - -prop_handshake13_full :: PropertyM IO () -prop_handshake13_full = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - runTLSPipeSimple13 params FullHandshake Nothing - -prop_handshake13_hrr :: PropertyM IO () -prop_handshake13_hrr = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [P256, X25519] - } - svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - runTLSPipeSimple13 params HelloRetryRequest Nothing - -prop_handshake13_psk :: PropertyM IO () -prop_handshake13_psk = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [P256, X25519] - } - svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params0 = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSPipeSimple13 params HelloRetryRequest Nothing - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - - runTLSPipeSimple13 params2 PreSharedKey Nothing - -prop_handshake13_psk_fallback :: PropertyM IO () -prop_handshake13_psk_fallback = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = - def - { supportedCiphers = - [ cipher_TLS13_AES128GCM_SHA256 - , cipher_TLS13_AES128CCM_SHA256 - ] - , supportedGroups = [P256, X25519] - } - svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params0 = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSPipeSimple13 params HelloRetryRequest Nothing - - -- resumption fails because GCM cipher is not supported anymore, full - -- handshake is not possible because X25519 has been removed, so we are - -- back with P256 after hello retry - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params - srv2' = srv2{serverSupported = svrSupported'} - svrSupported' = - def - { supportedCiphers = [cipher_TLS13_AES128CCM_SHA256] - , supportedGroups = [P256] - } - - runTLSPipeSimple13 (cli2, srv2') HelloRetryRequest Nothing - -prop_handshake13_rtt0 :: PropertyM IO () -prop_handshake13_rtt0 = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [P256, X25519] - } - svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - cliHooks = - def - { onSuggestALPN = return $ Just ["h2"] - } - svrHooks = - def - { onALPNClientSuggest = Just (\protos -> return $ head protos) - } - params0 = - ( cli - { clientSupported = cliSupported - , clientHooks = cliHooks - } - , srv - { serverSupported = svrSupported - , serverHooks = svrHooks - , serverEarlyDataSize = 2048 - } - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - runTLSPipeSimple13 params HelloRetryRequest Nothing - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - earlyData <- B.pack <$> pick (someWords8 256) - let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params - params2 = (pc{clientEarlyData = Just earlyData}, ps) - - runTLSPipeSimple13 params2 RTT0 (Just earlyData) - -prop_handshake13_rtt0_fallback :: PropertyM IO () -prop_handshake13_rtt0_fallback = do - ticketSize <- pick $ choose (0, 512) - (cli, srv) <- pick arbitraryPairParams13 - group0 <- pick $ elements [P256, X25519] - let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [P256, X25519] - } - svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [group0] - } - params0 = - ( cli{clientSupported = cliSupported} - , srv - { serverSupported = svrSupported - , serverEarlyDataSize = ticketSize - } - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - let params = setPairParamsSessionManagers sessionManagers params0 - - let mode = if group0 == P256 then FullHandshake else HelloRetryRequest - runTLSPipeSimple13 params mode Nothing - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - earlyData <- B.pack <$> pick (someWords8 256) - group2 <- pick $ elements [P256, X25519] - let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params - svrSupported2 = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [group2] - } - params2 = - ( pc{clientEarlyData = Just earlyData} - , ps - { serverEarlyDataSize = 0 - , serverSupported = svrSupported2 - } - ) - - let mode2 = if ticketSize < 256 then PreSharedKey else RTT0 - runTLSPipeSimple13 params2 mode2 Nothing - -prop_handshake13_rtt0_length :: PropertyM IO () -prop_handshake13_rtt0_length = do - serverMax <- pick $ choose (0, 33792) - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - svrSupported = - def - { supportedCiphers = [cipher_TLS13_AES128GCM_SHA256] - , supportedGroups = [X25519] - } - params0 = - ( cli{clientSupported = cliSupported} - , srv - { serverSupported = svrSupported - , serverEarlyDataSize = serverMax - } - ) - - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - let params = setPairParamsSessionManagers sessionManagers params0 - runTLSPipeSimple13 params FullHandshake Nothing - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - clientLen <- pick $ choose (0, 33792) - earlyData <- B.pack <$> pick (someWords8 clientLen) - let (pc, ps) = setPairParamsSessionResuming (fromJust sessionParams) params - params2 = (pc{clientEarlyData = Just earlyData}, ps) - (mode, mEarlyData) - | clientLen > serverMax = (PreSharedKey, Nothing) - | otherwise = (RTT0, Just earlyData) - runTLSPipeSimple13 params2 mode mEarlyData - -prop_handshake13_ee_groups :: PropertyM IO () -prop_handshake13_ee_groups = do - (cli, srv) <- pick arbitraryPairParams13 - let cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]} - svrSupported = (serverSupported srv){supportedGroups = [X25519, P256]} - params = - ( cli{clientSupported = cliSupported} - , srv{serverSupported = svrSupported} - ) - (_, serverMessages) <- runTLSPipeCapture13 params - let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups - eeMessagesHaveExt = - [ any isSupportedGroups exts - | EncryptedExtensions13 exts <- serverMessages - ] - [True] `assertEq` eeMessagesHaveExt -- one EE message with extension - -prop_handshake_ciphersuites :: PropertyM IO () -prop_handshake_ciphersuites = do - tls13 <- pick arbitrary - let version = if tls13 then TLS13 else TLS12 - clientCiphers <- pick arbitraryCiphers - serverCiphers <- pick arbitraryCiphers - (clientParam, serverParam) <- - pick $ - arbitraryPairParamsWithVersionsAndCiphers - ([version], [version]) - (clientCiphers, serverCiphers) - let adequate = cipherAllowedForVersion version - shouldSucceed = any adequate (clientCiphers `intersect` serverCiphers) - if shouldSucceed - then runTLSPipeSimple (clientParam, serverParam) - else runTLSInitFailure (clientParam, serverParam) - -prop_handshake_hashsignatures :: PropertyM IO () -prop_handshake_hashsignatures = do - tls13 <- pick arbitrary - let version = if tls13 then TLS13 else TLS12 - ciphers = - [ cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_ECDSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_AES128CBC_SHA - , cipher_ECDHE_ECDSA_AES128CBC_SHA - , cipher_DHE_RSA_AES128_SHA1 - , cipher_DHE_DSA_AES128_SHA1 - , cipher_TLS13_AES128GCM_SHA256 - ] - (clientParam, serverParam) <- - pick $ - arbitraryPairParamsWithVersionsAndCiphers - ([version], [version]) - (ciphers, ciphers) - clientHashSigs <- pick $ arbitraryHashSignatures version - serverHashSigs <- pick $ arbitraryHashSignatures version - let clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedHashSignatures = clientHashSigs - } - } - serverParam' = - serverParam - { serverSupported = - (serverSupported serverParam) - { supportedHashSignatures = serverHashSigs - } - } - commonHashSigs = clientHashSigs `intersect` serverHashSigs - shouldFail - | tls13 = all incompatibleWithDefaultCurve commonHashSigs - | otherwise = null commonHashSigs - if shouldFail - then runTLSInitFailure (clientParam', serverParam') - else runTLSPipeSimple (clientParam', serverParam') - where - incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 - incompatibleWithDefaultCurve _ = False - --- Tests ability to use or ignore client "signature_algorithms" extension when --- choosing a server certificate. Here peers allow DHE_RSA_AES128_SHA1 but --- the server RSA certificate has a SHA-1 signature that the client does not --- support. Server may choose the DSA certificate only when cipher --- DHE_DSA_AES128_SHA1 is allowed. Otherwise it must fallback to the RSA --- certificate. -prop_handshake_cert_fallback :: PropertyM IO () -prop_handshake_cert_fallback = do - let clientVersions = [TLS12] - serverVersions = [TLS12] - commonCiphers = [cipher_DHE_RSA_AES128_SHA1] - otherCiphers = - [ cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_AES128CBC_SHA - , cipher_DHE_DSA_AES128_SHA1 - ] - hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)] - chainRef <- run $ newIORef Nothing - clientCiphers <- pick $ sublistOf otherCiphers - serverCiphers <- pick $ sublistOf otherCiphers - (clientParam, serverParam) <- - pick $ - arbitraryPairParamsWithVersionsAndCiphers - (clientVersions, serverVersions) - (clientCiphers ++ commonCiphers, serverCiphers ++ commonCiphers) - let clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedHashSignatures = hashSignatures - } - , clientHooks = - (clientHooks clientParam) - { onServerCertificate = \_ _ _ chain -> - writeIORef chainRef (Just chain) >> return [] - } - } - dssDisallowed = - cipher_DHE_DSA_AES128_SHA1 `notElem` clientCiphers - || cipher_DHE_DSA_AES128_SHA1 `notElem` serverCiphers - runTLSPipeSimple (clientParam', serverParam) - serverChain <- run $ readIORef chainRef - dssDisallowed `assertEq` isLeafRSA serverChain - --- Same as above but testing with supportedHashSignatures directly instead of --- ciphers, and thus allowing TLS13. Peers accept RSA with SHA-256 but the --- server RSA certificate has a SHA-1 signature. When Ed25519 is allowed by --- both client and server, the Ed25519 certificate is selected. Otherwise the --- server fallbacks to RSA. --- --- Note: SHA-1 is supposed to be disallowed in X.509 signatures with TLS13 --- unless client advertises explicit support. Currently this is not enforced by --- the library, which is useful to test this scenario. SHA-1 could be replaced --- by another algorithm. -prop_handshake_cert_fallback_hs :: PropertyM IO () -prop_handshake_cert_fallback_hs = do - tls13 <- pick arbitrary - let versions = if tls13 then [TLS13] else [TLS12] - ciphers = - [ cipher_ECDHE_RSA_AES128GCM_SHA256 - , cipher_ECDHE_ECDSA_AES128GCM_SHA256 - , cipher_TLS13_AES128GCM_SHA256 - ] - commonHS = - [ (HashSHA256, SignatureRSA) - , (HashIntrinsic, SignatureRSApssRSAeSHA256) - ] - otherHS = [(HashIntrinsic, SignatureEd25519)] - chainRef <- run $ newIORef Nothing - clientHS <- pick $ sublistOf otherHS - serverHS <- pick $ sublistOf otherHS - (clientParam, serverParam) <- - pick $ - arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - let clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedHashSignatures = commonHS ++ clientHS - } - , clientHooks = - (clientHooks clientParam) - { onServerCertificate = \_ _ _ chain -> - writeIORef chainRef (Just chain) >> return [] - } - } - serverParam' = - serverParam - { serverSupported = - (serverSupported serverParam) - { supportedHashSignatures = commonHS ++ serverHS - } - } - eddsaDisallowed = - (HashIntrinsic, SignatureEd25519) `notElem` clientHS - || (HashIntrinsic, SignatureEd25519) `notElem` serverHS - runTLSPipeSimple (clientParam', serverParam') - serverChain <- run $ readIORef chainRef - eddsaDisallowed `assertEq` isLeafRSA serverChain - -prop_handshake_groups :: PropertyM IO () -prop_handshake_groups = do - tls13 <- pick arbitrary - let versions = if tls13 then [TLS13] else [TLS12] - ciphers = - [ cipher_ECDHE_RSA_AES256GCM_SHA384 - , cipher_ECDHE_RSA_AES128CBC_SHA - , cipher_DHE_RSA_AES256GCM_SHA384 - , cipher_DHE_RSA_AES128_SHA1 - , cipher_TLS13_AES128GCM_SHA256 - ] - (clientParam, serverParam) <- - pick $ - arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - clientGroups <- pick arbitraryGroups - serverGroups <- pick arbitraryGroups - denyCustom <- pick arbitrary - let groupUsage = - if denyCustom - then GroupUsageUnsupported "custom group denied" - else GroupUsageValid - clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedGroups = clientGroups - } - , clientHooks = - (clientHooks clientParam) - { onCustomFFDHEGroup = \_ _ -> return groupUsage - } - } - serverParam' = - serverParam - { serverSupported = - (serverSupported serverParam) - { supportedGroups = serverGroups - } - } - isCustom = maybe True isCustomDHParams (serverDHEParams serverParam') - mCustomGroup = serverDHEParams serverParam' >>= dhParamsGroup - isClientCustom = maybe True (`notElem` clientGroups) mCustomGroup - commonGroups = clientGroups `intersect` serverGroups - shouldFail = null commonGroups && (tls13 || isClientCustom && denyCustom) - p minfo = isNothing (minfo >>= infoSupportedGroup) == (null commonGroups && isCustom) - if shouldFail - then runTLSInitFailure (clientParam', serverParam') - else runTLSPipePredicate (clientParam', serverParam') p - -prop_handshake_dh :: PropertyM IO () -prop_handshake_dh = do - let clientVersions = [TLS12] - serverVersions = [TLS12] - ciphers = [cipher_DHE_RSA_AES128_SHA1] - (clientParam, serverParam) <- - pick $ - arbitraryPairParamsWithVersionsAndCiphers - (clientVersions, serverVersions) - (ciphers, ciphers) - let clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedGroups = [] - } - } - let check (dh, shouldFail) = do - let serverParam' = serverParam{serverDHEParams = Just dh} - if shouldFail - then runTLSInitFailure (clientParam', serverParam') - else runTLSPipeSimple (clientParam', serverParam') - mapM_ - check - [ (dhParams512, True) - , (dhParams768, True) - , (dhParams1024, False) - ] - -prop_handshake_srv_key_usage :: PropertyM IO () -prop_handshake_srv_key_usage = do - tls13 <- pick arbitrary - let versions = if tls13 then [TLS13] else [TLS12] - ciphers = - [ cipher_ECDHE_RSA_AES128CBC_SHA - , cipher_TLS13_AES128GCM_SHA256 - , cipher_DHE_RSA_AES128_SHA1 - , cipher_AES256_SHA256 - ] - (clientParam, serverParam) <- - pick $ - arbitraryPairParamsWithVersionsAndCiphers - (versions, versions) - (ciphers, ciphers) - usageFlags <- pick arbitraryKeyUsage - cred <- pick $ arbitraryRSACredentialWithUsage usageFlags - let serverParam' = - serverParam - { serverShared = - (serverShared serverParam) - { sharedCredentials = Credentials [cred] - } - } - hasDS = KeyUsage_digitalSignature `elem` usageFlags - hasKE = KeyUsage_keyEncipherment `elem` usageFlags - shouldSucceed = hasDS || (hasKE && not tls13) - if shouldSucceed - then runTLSPipeSimple (clientParam, serverParam') - else runTLSInitFailure (clientParam, serverParam') - -prop_handshake_ec :: PropertyM IO () -prop_handshake_ec = do - let versions = [TLS12, TLS13] - ciphers = - [ cipher_ECDHE_ECDSA_AES256GCM_SHA384 - , cipher_ECDHE_ECDSA_AES128CBC_SHA - , cipher_TLS13_AES128GCM_SHA256 - ] - sigGroups = [P256] - ecdhGroups = [X25519, X448] -- always enabled, so no ECDHE failure - hashSignatures = - [ (HashSHA256, SignatureECDSA) - ] - clientVersion <- pick $ elements versions - (clientParam, serverParam) <- - pick $ - arbitraryPairParamsWithVersionsAndCiphers - ([clientVersion], versions) - (ciphers, ciphers) - clientGroups <- pick $ sublistOf sigGroups - clientHashSignatures <- pick $ sublistOf hashSignatures - serverHashSignatures <- pick $ sublistOf hashSignatures - credentials <- pick arbitraryCredentialsOfEachCurve - let clientParam' = - clientParam - { clientSupported = - (clientSupported clientParam) - { supportedGroups = clientGroups ++ ecdhGroups - , supportedHashSignatures = clientHashSignatures - } - } - serverParam' = - serverParam - { serverSupported = - (serverSupported serverParam) - { supportedGroups = sigGroups ++ ecdhGroups - , supportedHashSignatures = serverHashSignatures - } - , serverShared = - (serverShared serverParam) - { sharedCredentials = Credentials credentials - } - } - sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures) - ecdsaDenied = - (clientVersion < TLS13 && null clientGroups) - || (clientVersion >= TLS12 && SignatureECDSA `notElem` sigAlgs) - if ecdsaDenied - then runTLSInitFailure (clientParam', serverParam') - else runTLSPipeSimple (clientParam', serverParam') - -prop_handshake_client_auth :: PropertyM IO () -prop_handshake_client_auth = do - (clientParam, serverParam) <- pick arbitraryPairParams - let clientVersions = supportedVersions $ clientSupported clientParam - serverVersions = supportedVersions $ serverSupported serverParam - version = maximum (clientVersions `intersect` serverVersions) - cred <- pick (arbitraryClientCredential version) - let clientParam' = - clientParam - { clientHooks = - (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred - } - } - serverParam' = - serverParam - { serverWantClientCert = True - , serverHooks = - (serverHooks serverParam) - { onClientCertificate = validateChain cred - } - } - let shouldFail = version == TLS13 && isCredentialDSA cred - if shouldFail - then runTLSInitFailure (clientParam', serverParam') - else runTLSPipeSimple (clientParam', serverParam') - where - validateChain cred chain - | chain == fst cred = return CertificateUsageAccept - | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) - -prop_post_handshake_auth :: PropertyM IO () -prop_post_handshake_auth = do - (clientParam, serverParam) <- pick arbitraryPairParams13 - cred <- pick (arbitraryClientCredential TLS13) - let clientParam' = - clientParam - { clientHooks = - (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred - } - } - serverParam' = - serverParam - { serverHooks = - (serverHooks serverParam) - { onClientCertificate = validateChain cred - } - } - if isCredentialDSA cred - then runTLSInitFailureGen (clientParam', serverParam') hsServer hsClient - else runTLSPipe (clientParam', serverParam') tlsServer tlsClient - where - validateChain cred chain - | chain == fst cred = return CertificateUsageAccept - | otherwise = return (CertificateUsageReject CertificateRejectUnknownCA) - tlsServer ctx queue = do - hsServer ctx - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - hsClient ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - hsServer ctx = do - handshake ctx - checkCtxFinished ctx - recvDataAssert ctx "request 1" - _ <- requestCertificate ctx -- single request - sendData ctx "response 1" - recvDataAssert ctx "request 2" - _ <- requestCertificate ctx - _ <- requestCertificate ctx -- two simultaneously - sendData ctx "response 2" - hsClient ctx = do - handshake ctx - checkCtxFinished ctx - sendData ctx "request 1" - recvDataAssert ctx "response 1" - sendData ctx "request 2" - recvDataAssert ctx "response 2" - -prop_handshake_clt_key_usage :: PropertyM IO () -prop_handshake_clt_key_usage = do - (clientParam, serverParam) <- pick arbitraryPairParams - usageFlags <- pick arbitraryKeyUsage - cred <- pick $ arbitraryRSACredentialWithUsage usageFlags - let clientParam' = - clientParam - { clientHooks = - (clientHooks clientParam) - { onCertificateRequest = \_ -> return $ Just cred - } - } - serverParam' = - serverParam - { serverWantClientCert = True - , serverHooks = - (serverHooks serverParam) - { onClientCertificate = \_ -> return CertificateUsageAccept - } - } - shouldSucceed = KeyUsage_digitalSignature `elem` usageFlags - if shouldSucceed - then runTLSPipeSimple (clientParam', serverParam') - else runTLSInitFailure (clientParam', serverParam') - -prop_handshake_ems :: PropertyM IO () -prop_handshake_ems = do - (cems, sems) <- pick arbitraryEMSMode - params <- pick arbitraryPairParams - let params' = setEMSMode (cems, sems) params - version = getConnectVersion params' - emsVersion = version >= TLS10 && version <= TLS12 - use = cems /= NoEMS && sems /= NoEMS - require = cems == RequireEMS || sems == RequireEMS - p info = infoExtendedMasterSec info == (emsVersion && use) - if emsVersion && require && not use - then runTLSInitFailure params' - else runTLSPipePredicate params' (maybe False p) - -prop_handshake_session_resumption_ems :: PropertyM IO () -prop_handshake_session_resumption_ems = do - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - plainParams <- pick arbitraryPairParams - ems <- pick (arbitraryEMSMode `suchThat` compatible) - let params = - setEMSMode ems $ - setPairParamsSessionManagers sessionManagers plainParams - - runTLSPipeSimple params - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - ems2 <- pick (arbitraryEMSMode `suchThat` compatible) - let params2 = - setEMSMode ems2 $ - setPairParamsSessionResuming (fromJust sessionParams) params - - let version = getConnectVersion params2 - emsVersion = version >= TLS10 && version <= TLS12 - - if emsVersion && use ems && not (use ems2) - then runTLSInitFailure params2 - else do - runTLSPipeSimple params2 - sessionParams2 <- run $ readClientSessionRef sessionRefs - let sameSession = sessionParams == sessionParams2 - sameUse = use ems == use ems2 - when emsVersion $ assert (sameSession == sameUse) - where - compatible (NoEMS, RequireEMS) = False - compatible (RequireEMS, NoEMS) = False - compatible _ = True - - use (NoEMS, _) = False - use (_, NoEMS) = False - use _ = True - -prop_handshake_alpn :: PropertyM IO () -prop_handshake_alpn = do - (clientParam, serverParam) <- pick arbitraryPairParams - let clientParam' = - clientParam - { clientHooks = - (clientHooks clientParam) - { onSuggestALPN = return $ Just ["h2", "http/1.1"] - } - } - serverParam' = - serverParam - { serverHooks = - (serverHooks serverParam) - { onALPNClientSuggest = Just alpn - } - } - params' = (clientParam', serverParam') - runTLSPipe params' tlsServer tlsClient - where - tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - proto <- getNegotiatedProtocol ctx - Just "h2" `assertEq` proto - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - proto <- getNegotiatedProtocol ctx - Just "h2" `assertEq` proto - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - alpn xs - | "h2" `elem` xs = return "h2" - | otherwise = return "http/1.1" - -prop_handshake_sni :: PropertyM IO () -prop_handshake_sni = do - ref <- run $ newIORef Nothing - (clientParam, serverParam) <- pick arbitraryPairParams - let clientParam' = - clientParam - { clientServerIdentification = (serverName, "") - } - serverParam' = - serverParam - { serverHooks = - (serverHooks serverParam) - { onServerNameIndication = onSNI ref - } - } - params' = (clientParam', serverParam') - runTLSPipe params' tlsServer tlsClient - receivedName <- run $ readIORef ref - Just (Just serverName) `assertEq` receivedName - where - tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - sni <- getClientSNI ctx - Just serverName `assertEq` sni - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - sni <- getClientSNI ctx - Just serverName `assertEq` sni - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - onSNI ref name = - assertEmptyRef ref - >> writeIORef ref (Just name) - >> return (Credentials []) - serverName = "haskell.org" - -prop_handshake_renegotiation :: PropertyM IO () -prop_handshake_renegotiation = do - renegDisabled <- pick arbitrary - (cparams, sparams) <- pick arbitraryPairParams - let sparams' = - sparams - { serverSupported = - (serverSupported sparams) - { supportedClientInitiatedRenegotiation = not renegDisabled - } - } - if renegDisabled || isVersionEnabled TLS13 (cparams, sparams') - then runTLSInitFailureGen (cparams, sparams') hsServer hsClient - else runTLSPipe (cparams, sparams') tlsServer tlsClient - where - tlsServer ctx queue = do - hsServer ctx - checkCtxFinished ctx - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - hsClient ctx - checkCtxFinished ctx - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - hsServer = handshake - hsClient ctx = handshake ctx >> handshake ctx - -prop_handshake_session_resumption :: PropertyM IO () -prop_handshake_session_resumption = do - sessionRefs <- run twoSessionRefs - let sessionManagers = twoSessionManagers sessionRefs - - plainParams <- pick arbitraryPairParams - let params = setPairParamsSessionManagers sessionManagers plainParams - - runTLSPipeSimple params - - -- and resume - sessionParams <- run $ readClientSessionRef sessionRefs - assert (isJust sessionParams) - let params2 = setPairParamsSessionResuming (fromJust sessionParams) params - - runTLSPipeSimple params2 - -prop_thread_safety :: PropertyM IO () -prop_thread_safety = do - params <- pick arbitraryPairParams - runTLSPipe params tlsServer tlsClient - where - tlsServer ctx queue = do - handshake ctx - checkCtxFinished ctx - runReaderWriters ctx "client-value" "server-value" - d <- recvData ctx - writeChan queue [d] - bye ctx - tlsClient queue ctx = do - handshake ctx - checkCtxFinished ctx - runReaderWriters ctx "server-value" "client-value" - d <- readChan queue - sendData ctx (L.fromChunks [d]) - byeBye ctx - runReaderWriters ctx r w = - -- run concurrently 10 readers and 10 writers on the same context - let workers = concat $ replicate 10 [recvDataAssert ctx r, sendData ctx w] - in runConcurrently $ traverse_ Concurrently workers - -assertEq :: (Show a, Monad m, Eq a) => a -> a -> m () -assertEq expected got = - unless (expected == got) $ - error ("got " ++ show got ++ " but was expecting " ++ show expected) - -assertIsLeft :: (Show b, Monad m) => Either a b -> m () -assertIsLeft (Left _) = return () -assertIsLeft (Right b) = error ("got " ++ show b ++ " but was expecting a failure") - -assertEmptyRef :: Show a => IORef (Maybe a) -> IO () -assertEmptyRef ref = - readIORef ref - >>= maybe - (return ()) - ( \a -> - error ("got " ++ show a ++ " but was expecting empty reference") - ) - -recvDataAssert :: Context -> C8.ByteString -> IO () -recvDataAssert ctx expected = do - got <- recvData ctx - assertEq expected got - -checkCtxFinished :: Context -> IO () -checkCtxFinished ctx = do - ctxFinished <- getFinished ctx - unless (isJust ctxFinished) $ - fail "unexpected ctxFinished" - ctxPeerFinished <- getPeerFinished ctx - unless (isJust ctxPeerFinished) $ - fail "unexpected ctxPeerFinished" - -main :: IO () -main = - defaultMain $ - testGroup - "tls" - [ tests_marshalling - , tests_ciphers - , tests_handshake - , tests_thread_safety - ] - where - -- lowlevel tests to check the packet marshalling. - tests_marshalling = - testGroup - "Marshalling" - [ testProperty "Header" prop_header_marshalling_id - , testProperty "Handshake" prop_handshake_marshalling_id - , testProperty "Handshake13" prop_handshake13_marshalling_id - ] - tests_ciphers = - testGroup - "Ciphers" - [testProperty "Bulk" propertyBulkFunctional] - - -- high level tests between a client and server with fake ciphers. - tests_handshake = - testGroup - "Handshakes" - [ testProperty "Setup" (monadicIO prop_pipe_work) - , testProperty "Initiation" (monadicIO prop_handshake_initiate) - , testProperty "Initiation 1.3" (monadicIO prop_handshake13_initiate) - , testProperty "Key update 1.3" (monadicIO prop_handshake_keyupdate) - , testProperty "Downgrade protection" (monadicIO prop_handshake13_downgrade) - , testProperty "Hash and signatures" (monadicIO prop_handshake_hashsignatures) - , testProperty "Cipher suites" (monadicIO prop_handshake_ciphersuites) - , testProperty "Groups" (monadicIO prop_handshake_groups) - , testProperty "Elliptic curves" (monadicIO prop_handshake_ec) - , testProperty - "Certificate fallback (ciphers)" - (monadicIO prop_handshake_cert_fallback) - , testProperty - "Certificate fallback (hash and signatures)" - (monadicIO prop_handshake_cert_fallback_hs) - , testProperty "Server key usage" (monadicIO prop_handshake_srv_key_usage) - , testProperty "Client authentication" (monadicIO prop_handshake_client_auth) - , testProperty "Client key usage" (monadicIO prop_handshake_clt_key_usage) - , testProperty "Extended Master Secret" (monadicIO prop_handshake_ems) - , testProperty - "Extended Master Secret (resumption)" - (monadicIO prop_handshake_session_resumption_ems) - , testProperty "ALPN" (monadicIO prop_handshake_alpn) - , testProperty "SNI" (monadicIO prop_handshake_sni) - , testProperty "Renegotiation" (monadicIO prop_handshake_renegotiation) - , testProperty "Resumption" (monadicIO prop_handshake_session_resumption) - , testProperty "Custom DH" (monadicIO prop_handshake_dh) - , testProperty "TLS 1.3 Full" (monadicIO prop_handshake13_full) - , testProperty "TLS 1.3 HRR" (monadicIO prop_handshake13_hrr) - , testProperty "TLS 1.3 PSK" (monadicIO prop_handshake13_psk) - , testProperty "TLS 1.3 PSK -> HRR" (monadicIO prop_handshake13_psk_fallback) - , testProperty "TLS 1.3 RTT0" (monadicIO prop_handshake13_rtt0) - , testProperty "TLS 1.3 RTT0 -> PSK" (monadicIO prop_handshake13_rtt0_fallback) - , testProperty "TLS 1.3 RTT0 length" (monadicIO prop_handshake13_rtt0_length) - , testProperty "TLS 1.3 EE groups" (monadicIO prop_handshake13_ee_groups) - , testProperty "TLS 1.3 Post-handshake auth" (monadicIO prop_post_handshake_auth) - ] - - -- test concurrent reads and writes - tests_thread_safety = - localOption (QuickCheckTests 10) $ - testProperty "Thread safety" (monadicIO prop_thread_safety)