diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Change log for "tls" +## Version 2.4.10 + +* Support ML-DSA certificates and CertificateVerify, TLS 1.3 only + (draft-ietf-tls-mldsa). + [#583](https://github.com/haskell-tls/hs-tls/pull/583) +* Take ML-KEM from `crypton` instead of the `mlkem` package. + [#583](https://github.com/haskell-tls/hs-tls/pull/583) +* `tls-server`: let `-g` choose the TLS 1.3 groups too. + [#583](https://github.com/haskell-tls/hs-tls/pull/583) + ## Version 2.4.9 * Include CertificateRequest in the post-handshake auth transcript. diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternSynonyms #-} -- | -- Native Haskell TLS protocol implementation for servers and -- clients. @@ -198,6 +199,9 @@ supportedSignatureSchemes, HashAlgorithm (..), SignatureAlgorithm (..), + pattern MLDSA44, + pattern MLDSA65, + pattern MLDSA87, Group (..), supportedNamedGroups, EMSMode (..), @@ -352,6 +356,9 @@ TLSError (..), TLSException (..), supportedSignatureSchemes, + pattern MLDSA44, + pattern MLDSA65, + pattern MLDSA87, ) import Network.TLS.Struct13 (Handshake13) import Network.TLS.Types diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -156,6 +156,9 @@ SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA512) SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> Just (TLS.HashIntrinsic, TLS.SignatureEd25519) SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> Just (TLS.HashIntrinsic, TLS.SignatureEd448) + SignatureALG_IntrinsicHash PubKeyALG_MLDSA44 -> Just TLS.MLDSA44 + SignatureALG_IntrinsicHash PubKeyALG_MLDSA65 -> Just TLS.MLDSA65 + SignatureALG_IntrinsicHash PubKeyALG_MLDSA87 -> Just TLS.MLDSA87 _ -> Nothing where convertHash sig X509.HashMD5 = Just (TLS.HashMD5, sig) diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -54,11 +54,12 @@ import qualified Crypto.PubKey.ECDSA as ECDSA import qualified Crypto.PubKey.Ed25519 as Ed25519 import qualified Crypto.PubKey.Ed448 as Ed448 +import qualified Crypto.PubKey.MLDSA as MLDSA import qualified Crypto.PubKey.RSA as RSA import qualified Crypto.PubKey.RSA.PKCS15 as RSA import qualified Crypto.PubKey.RSA.PSS as PSS import Crypto.Random -import Data.ASN1.BinaryEncoding (BER (..), DER (..)) +import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding import Data.ASN1.Types import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes, convert) @@ -71,6 +72,7 @@ PubKey (..), PubKeyEC (..), SerializedPoint (..), + privkeyMLDSA_key, ) import Data.X509.EC (ecPrivKeyCurveName, ecPubKeyCurveName, unserializePoint) @@ -261,6 +263,13 @@ | ECDSAParams Hash | Ed25519Params | Ed448Params + | -- | Pure ML-DSA with an empty context, which is what + -- draft-ietf-tls-mldsa uses. One constructor per parameter set, + -- since the key fixes it and a signature made under one does not + -- verify under another. + MLDSA44Params + | MLDSA65Params + | MLDSA87Params deriving (Show, Eq) -- Verify that the signature matches the given message, using the @@ -271,38 +280,21 @@ kxVerify (PubKeyRSA pk) (RSAParams alg RSApkcs1) msg sign = rsaVerifyHash alg pk msg sign kxVerify (PubKeyRSA pk) (RSAParams alg RSApss) msg sign = rsapssVerifyHash alg pk msg sign kxVerify (PubKeyDSA pk) DSAParams msg signBS = - case dsaToSignature signBS of - Just sig -> DSA.verify H.SHA1 pk sig msg + case decodeSignatureRS signBS of + Just (r, s) -> DSA.verify H.SHA1 pk DSA.Signature{DSA.sign_r = r, DSA.sign_s = s} msg _ -> False - where - dsaToSignature :: ByteString -> Maybe DSA.Signature - dsaToSignature b = - case decodeASN1' BER b of - Left _ -> Nothing - Right asn1 -> - case asn1 of - Start Sequence : IntVal r : IntVal s : End Sequence : _ -> - Just DSA.Signature{DSA.sign_r = r, DSA.sign_s = s} - _ -> - Nothing kxVerify (PubKeyEC key) (ECDSAParams alg) msg sigBS = fromMaybe False $ join $ withPubKeyEC key verifyProxy verifyClassic Nothing where - decodeSignatureASN1 buildRS = - case decodeASN1' BER sigBS of - Left _ -> Nothing - Right [Start Sequence, IntVal r, IntVal s, End Sequence] -> - Just (buildRS r s) - Right _ -> Nothing verifyProxy prx pubkey = do - rs <- decodeSignatureASN1 (,) + rs <- decodeSignatureRS sigBS signature <- maybeCryptoError $ ECDSA.signatureFromIntegers prx rs verifyF <- withAlg (ECDSA.verify prx) return $ verifyF pubkey signature msg verifyClassic pubkey = do - signature <- decodeSignatureASN1 ECDSA_ECC.Signature + signature <- uncurry ECDSA_ECC.Signature <$> decodeSignatureRS sigBS verifyF <- withAlg ECDSA_ECC.verify return $ verifyF pubkey signature msg withAlg :: (forall hash. H.HashAlgorithm hash => hash -> a) -> Maybe a @@ -322,8 +314,66 @@ case Ed448.signature sigBS of CryptoPassed sig -> Ed448.verify key msg sig _ -> False +-- A signature of the wrong length is refused by the smart constructor, and +-- one of the right length that does not verify returns False. Neither +-- throws, which is what a peer sending a damaged CertificateVerify has to +-- meet with decrypt_error rather than with a crash. +kxVerify (PubKeyMLDSA44 key) MLDSA44Params msg sigBS = mldsaVerify key msg sigBS +kxVerify (PubKeyMLDSA65 key) MLDSA65Params msg sigBS = mldsaVerify key msg sigBS +kxVerify (PubKeyMLDSA87 key) MLDSA87Params msg sigBS = mldsaVerify key msg sigBS kxVerify _ _ _ _ = False +mldsaVerify + :: MLDSA.MLDSA p + => MLDSA.VerificationKey p -> ByteString -> ByteString -> Bool +mldsaVerify key msg sigBS = case MLDSA.signature sigBS of + CryptoPassed sig -> MLDSA.verify key MLDSA.emptyContext msg sig + _ -> False + +-- | Decode a DSA or ECDSA signature: a DER SEQUENCE of two INTEGERs, r +-- and s (RFC 3279 Sections 2.2.2 and 2.2.3). This is done here rather +-- than with crypton-asn1-encoding, whose 'decodeASN1'' throws on some +-- malformed input rather than returning 'Left'. Only DER is accepted: +-- definite lengths in their shortest form, non-negative INTEGERs in +-- theirs, and nothing after the SEQUENCE. +decodeSignatureRS :: ByteString -> Maybe (Integer, Integer) +decodeSignatureRS bs = do + (0x30, body) <- whole bs + (0x02, rbs, rest) <- tlv body + (0x02, sbs) <- whole rest + (,) <$> derInteger rbs <*> derInteger sbs + where + whole b = do + (t, v, rest) <- tlv b + guard $ B.null rest + return (t, v) + tlv b = do + (t, b1) <- B.uncons b + (l0, b2) <- B.uncons b1 + (len, b3) <- case l0 of + _ | l0 < 0x80 -> Just (fromIntegral l0, b2) + 0x81 -> do + (l1, b3) <- B.uncons b2 + guard $ l1 >= 0x80 + Just (fromIntegral l1, b3) + 0x82 -> do + (l1, b3) <- B.uncons b2 + (l2, b4) <- B.uncons b3 + let n = fromIntegral l1 * 256 + fromIntegral l2 :: Int + guard $ n >= 0x100 + Just (n, b4) + _ -> Nothing + guard $ B.length b3 >= len + let (v, rest) = B.splitAt len b3 + return (t, v, rest) + derInteger v = do + (h, t) <- B.uncons v + guard $ h < 0x80 + case B.uncons t of + Just (h2, _) | h == 0 -> guard $ h2 >= 0x80 + _ -> return () + return $ B.foldl' (\acc w -> acc * 256 + fromIntegral w) 0 v + -- Sign the given message using the private key. -- kxSign @@ -366,6 +416,12 @@ return $ Right $ convert $ Ed25519.sign pk pub msg kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg = return $ Right $ convert $ Ed448.sign pk pub msg +kxSign (PrivKeyMLDSA44 pk) (PubKeyMLDSA44 _) MLDSA44Params msg = + Right . convert <$> MLDSA.sign (privkeyMLDSA_key pk) MLDSA.emptyContext msg +kxSign (PrivKeyMLDSA65 pk) (PubKeyMLDSA65 _) MLDSA65Params msg = + Right . convert <$> MLDSA.sign (privkeyMLDSA_key pk) MLDSA.emptyContext msg +kxSign (PrivKeyMLDSA87 pk) (PubKeyMLDSA87 _) MLDSA87Params msg = + Right . convert <$> MLDSA.sign (privkeyMLDSA_key pk) MLDSA.emptyContext msg kxSign _ _ _ _ = return (Left KxUnsupported) diff --git a/Network/TLS/Crypto/IES.hs b/Network/TLS/Crypto/IES.hs --- a/Network/TLS/Crypto/IES.hs +++ b/Network/TLS/Crypto/IES.hs @@ -34,8 +34,8 @@ import Crypto.PubKey.DH (PrivateNumber (..), PublicNumber (..)) import qualified Crypto.PubKey.DH as DH import Crypto.PubKey.ECIES -import Crypto.PubKey.ML_KEM (ML_KEM_1024, ML_KEM_512, ML_KEM_768) -import qualified Crypto.PubKey.ML_KEM as ML +import Crypto.PubKey.MLKEM (MLKEM1024, MLKEM512, MLKEM768) +import qualified Crypto.PubKey.MLKEM as ML import Data.ByteArray (ScrubbedBytes, convert) import qualified Data.ByteArray as BA import Data.Proxy @@ -58,12 +58,12 @@ | GroupPri_FFDHE4096 PrivateNumber | GroupPri_FFDHE6144 PrivateNumber | GroupPri_FFDHE8192 PrivateNumber - | GroupPri_MLKEM512 (ML.DecapsulationKey ML_KEM_512) - | GroupPri_MLKEM768 (ML.DecapsulationKey ML_KEM_768) - | GroupPri_MLKEM1024 (ML.DecapsulationKey ML_KEM_1024) - | GroupPri_X25519MLKEM768 (Scalar Curve_X25519, ML.DecapsulationKey ML_KEM_768) - | GroupPri_P256MLKEM768 (Scalar Curve_P256R1, ML.DecapsulationKey ML_KEM_768) - | GroupPri_P384MLKEM1024 (Scalar Curve_P384R1, ML.DecapsulationKey ML_KEM_1024) + | GroupPri_MLKEM512 (ML.DecapsulationKey MLKEM512) + | GroupPri_MLKEM768 (ML.DecapsulationKey MLKEM768) + | GroupPri_MLKEM1024 (ML.DecapsulationKey MLKEM1024) + | GroupPri_X25519MLKEM768 (Scalar Curve_X25519, ML.DecapsulationKey MLKEM768) + | GroupPri_P256MLKEM768 (Scalar Curve_P256R1, ML.DecapsulationKey MLKEM768) + | GroupPri_P384MLKEM1024 (Scalar Curve_P384R1, ML.DecapsulationKey MLKEM1024) deriving (Eq, Show) {- FOURMOLU_ENABLE -} @@ -79,12 +79,12 @@ | GroupPubA_FFDHE4096 PublicNumber | GroupPubA_FFDHE6144 PublicNumber | GroupPubA_FFDHE8192 PublicNumber - | GroupPubA_MLKEM512 (ML.EncapsulationKey ML_KEM_512) - | GroupPubA_MLKEM768 (ML.EncapsulationKey ML_KEM_768) - | GroupPubA_MLKEM1024 (ML.EncapsulationKey ML_KEM_1024) - | GroupPubA_X25519MLKEM768 (Point Curve_X25519, ML.EncapsulationKey ML_KEM_768) - | GroupPubA_P256MLKEM768 (Point Curve_P256R1, ML.EncapsulationKey ML_KEM_768) - | GroupPubA_P384MLKEM1024 (Point Curve_P384R1, ML.EncapsulationKey ML_KEM_1024) + | GroupPubA_MLKEM512 (ML.EncapsulationKey MLKEM512) + | GroupPubA_MLKEM768 (ML.EncapsulationKey MLKEM768) + | GroupPubA_MLKEM1024 (ML.EncapsulationKey MLKEM1024) + | GroupPubA_X25519MLKEM768 (Point Curve_X25519, ML.EncapsulationKey MLKEM768) + | GroupPubA_P256MLKEM768 (Point Curve_P256R1, ML.EncapsulationKey MLKEM768) + | GroupPubA_P384MLKEM1024 (Point Curve_P384R1, ML.EncapsulationKey MLKEM1024) deriving (Eq, Show) {- FOURMOLU_ENABLE -} @@ -100,12 +100,12 @@ | GroupPubB_FFDHE4096 PublicNumber | GroupPubB_FFDHE6144 PublicNumber | GroupPubB_FFDHE8192 PublicNumber - | GroupPubB_MLKEM512 (ML.Ciphertext ML_KEM_512) - | GroupPubB_MLKEM768 (ML.Ciphertext ML_KEM_768) - | GroupPubB_MLKEM1024 (ML.Ciphertext ML_KEM_1024) - | GroupPubB_X25519MLKEM768 (Point Curve_X25519, ML.Ciphertext ML_KEM_768) - | GroupPubB_P256MLKEM768 (Point Curve_P256R1, ML.Ciphertext ML_KEM_768) - | GroupPubB_P384MLKEM1024 (Point Curve_P384R1, ML.Ciphertext ML_KEM_1024) + | GroupPubB_MLKEM512 (ML.Ciphertext MLKEM512) + | GroupPubB_MLKEM768 (ML.Ciphertext MLKEM768) + | GroupPubB_MLKEM1024 (ML.Ciphertext MLKEM1024) + | GroupPubB_X25519MLKEM768 (Point Curve_X25519, ML.Ciphertext MLKEM768) + | GroupPubB_P256MLKEM768 (Point Curve_P256R1, ML.Ciphertext MLKEM768) + | GroupPubB_P384MLKEM1024 (Point Curve_P384R1, ML.Ciphertext MLKEM1024) deriving (Eq, Show) {- FOURMOLU_ENABLE -} @@ -126,13 +126,27 @@ x448 :: Proxy Curve_X448 x448 = Proxy -mlkem512 :: Proxy ML_KEM_512 +mlkem512 :: Proxy MLKEM512 mlkem512 = Proxy -mlkem768 :: Proxy ML_KEM_768 +-- crypton reports a value it will not accept as a 'CryptoFailable' and has a +-- constructor per type rather than one overloaded 'decode'. These two keep +-- the call sites below in the shape they were. +-- +-- 'ML.encapsulationKey' is the stricter of the two: besides the length it +-- runs the check of FIPS 203 section 7.2, so an encapsulation key whose +-- coefficients are out of range is refused here rather than used. +decodeEK + :: ML.MLKEM p => proxy p -> ByteString -> Maybe (ML.EncapsulationKey p) +decodeEK _ = maybeCryptoError . ML.encapsulationKey + +decodeCT :: ML.MLKEM p => proxy p -> ByteString -> Maybe (ML.Ciphertext p) +decodeCT _ = maybeCryptoError . ML.ciphertext + +mlkem768 :: Proxy MLKEM768 mlkem768 = Proxy -mlkem1024 :: Proxy ML_KEM_1024 +mlkem1024 :: Proxy MLKEM1024 mlkem1024 = Proxy dhParamsForGroup :: Group -> Maybe DH.Params @@ -160,25 +174,25 @@ groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPubA_FFDHE6144 groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPubA_FFDHE8192 groupGenerateKeyPair MLKEM512 = do - (e, d) <- ML.generate mlkem512 + (e, d) <- ML.generateKeyPair mlkem512 return (GroupPri_MLKEM512 d, GroupPubA_MLKEM512 e) groupGenerateKeyPair MLKEM768 = do - (e, d) <- ML.generate mlkem768 + (e, d) <- ML.generateKeyPair mlkem768 return (GroupPri_MLKEM768 d, GroupPubA_MLKEM768 e) groupGenerateKeyPair MLKEM1024 = do - (e, d) <- ML.generate mlkem1024 + (e, d) <- ML.generateKeyPair mlkem1024 return (GroupPri_MLKEM1024 d, GroupPubA_MLKEM1024 e) groupGenerateKeyPair X25519MLKEM768 = do (d1, e1) <- fs' $ curveGenerateKeyPair x25519 - (e2, d2) <- ML.generate mlkem768 + (e2, d2) <- ML.generateKeyPair mlkem768 return (GroupPri_X25519MLKEM768 (d1, d2), GroupPubA_X25519MLKEM768 (e1, e2)) groupGenerateKeyPair P256MLKEM768 = do (d1, e1) <- fs' $ curveGenerateKeyPair p256 - (e2, d2) <- ML.generate mlkem768 + (e2, d2) <- ML.generateKeyPair mlkem768 return (GroupPri_P256MLKEM768 (d1, d2), GroupPubA_P256MLKEM768 (e1, e2)) groupGenerateKeyPair P384MLKEM1024 = do (d1, e1) <- fs' $ curveGenerateKeyPair p384 - (e2, d2) <- ML.generate mlkem1024 + (e2, d2) <- ML.generateKeyPair mlkem1024 return (GroupPri_P384MLKEM1024 (d1, d2), GroupPubA_P384MLKEM1024 (e1, e2)) groupGenerateKeyPair _ = error "groupGenerateKeyPair" @@ -228,6 +242,17 @@ -> r (PrivateNumber, PublicNumber) gen' params expBits = (id &&& DH.calculatePublic params) <$> generatePriv expBits +-- 'ML.encapsulate' takes the parameter set as a proxy and reports a +-- failure, as every KEM in Crypto.KEM does; ML-KEM has none to report. +mlkemEncap + :: (MonadRandom r, ML.MLKEM p) + => proxy p + -> ML.EncapsulationKey p + -> r (Maybe (ML.Ciphertext p, GroupKey)) +mlkemEncap p ek = fmap f <$> fmap maybeCryptoError (ML.encapsulate p ek) + where + f (ct, sec) = (ct, convert sec) + groupEncapsulate :: MonadRandom r => GroupPublicA -> r (Maybe (GroupPublicB, GroupKey)) groupEncapsulate (GroupPubA_P256 pub) = getECDHPubShared GroupPubB_P256 p256 pub @@ -240,41 +265,44 @@ groupEncapsulate (GroupPubA_FFDHE4096 pub) = getDHPubShared ffdhe4096 exp4096 pub GroupPubB_FFDHE4096 groupEncapsulate (GroupPubA_FFDHE6144 pub) = getDHPubShared ffdhe6144 exp6144 pub GroupPubB_FFDHE6144 groupEncapsulate (GroupPubA_FFDHE8192 pub) = getDHPubShared ffdhe8192 exp8192 pub GroupPubB_FFDHE8192 -groupEncapsulate (GroupPubA_MLKEM512 pub) = do - (sec, ct) <- ML.encapsulate pub - return $ Just (GroupPubB_MLKEM512 ct, convert sec) -groupEncapsulate (GroupPubA_MLKEM768 pub) = do - (sec, ct) <- ML.encapsulate pub - return $ Just (GroupPubB_MLKEM768 ct, convert sec) -groupEncapsulate (GroupPubA_MLKEM1024 pub) = do - (sec, ct) <- ML.encapsulate pub - return $ Just (GroupPubB_MLKEM1024 ct, convert sec) +groupEncapsulate (GroupPubA_MLKEM512 pub) = + fmap (\(ct, k) -> (GroupPubB_MLKEM512 ct, k)) <$> mlkemEncap mlkem512 pub +groupEncapsulate (GroupPubA_MLKEM768 pub) = + fmap (\(ct, k) -> (GroupPubB_MLKEM768 ct, k)) <$> mlkemEncap mlkem768 pub +groupEncapsulate (GroupPubA_MLKEM1024 pub) = + fmap (\(ct, k) -> (GroupPubB_MLKEM1024 ct, k)) <$> mlkemEncap mlkem1024 pub -- The classical part of a hybrid can fail as the group alone does: an -- all-zero X25519 public key decodes, but the shared secret derived from -- it is rejected. Nothing is turned into illegal_parameter by the caller. -groupEncapsulate (GroupPubA_X25519MLKEM768 (e1, e2)) = do - mx <- getECDHPubShared' x25519 e1 - case mx of - Nothing -> return Nothing - Just (c1, k1) -> do - (k2, c2) <- ML.encapsulate e2 - -- Sec 4.1: Specifically, the order of shares in the concatenation - -- has been reversed. - return $ Just (GroupPubB_X25519MLKEM768 (c1, c2), convert k2 <> k1) -groupEncapsulate (GroupPubA_P256MLKEM768 (e1, e2)) = do - mx <- getECDHPubShared' p256 e1 - case mx of - Nothing -> return Nothing - Just (c1, k1) -> do - (k2, c2) <- ML.encapsulate e2 - return $ Just (GroupPubB_P256MLKEM768 (c1, c2), k1 <> convert k2) -groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = do - mx <- getECDHPubShared' p384 e1 +groupEncapsulate (GroupPubA_X25519MLKEM768 (e1, e2)) = + hybrid x25519 mlkem768 e1 e2 $ \c1 k1 c2 k2 -> + -- Sec 4.1: Specifically, the order of shares in the concatenation + -- has been reversed. + (GroupPubB_X25519MLKEM768 (c1, c2), k2 <> k1) +groupEncapsulate (GroupPubA_P256MLKEM768 (e1, e2)) = + hybrid p256 mlkem768 e1 e2 $ \c1 k1 c2 k2 -> + (GroupPubB_P256MLKEM768 (c1, c2), k1 <> k2) +groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = + hybrid p384 mlkem1024 e1 e2 $ \c1 k1 c2 k2 -> + (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> k2) + +-- Either half can refuse: the classical one rejects a peer value that would +-- make its secret degenerate, which the caller turns into +-- illegal_parameter. ML-KEM has nothing to refuse, but says so the same +-- way, so both are read alike here. +hybrid + :: (MonadRandom r, EllipticCurveDH curve, ML.MLKEM p) + => Proxy curve + -> Proxy p + -> Point curve + -> ML.EncapsulationKey p + -> (Point curve -> GroupKey -> ML.Ciphertext p -> GroupKey -> (GroupPublicB, GroupKey)) + -> r (Maybe (GroupPublicB, GroupKey)) +hybrid pc pk e1 e2 k = do + mx <- getECDHPubShared' pc e1 case mx of Nothing -> return Nothing - Just (c1, k1) -> do - (k2, c2) <- ML.encapsulate e2 - return $ Just (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> convert k2) + Just (c1, k1) -> fmap (\(c2, k2) -> k c1 k1 c2 k2) <$> mlkemEncap pk e2 dhGroupGetPubShared :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, GroupKey)) @@ -351,22 +379,22 @@ groupDecapsulate (GroupPubB_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcDHShared ffdhe6144 pub pri groupDecapsulate (GroupPubB_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcDHShared ffdhe8192 pub pri groupDecapsulate (GroupPubB_MLKEM512 p) (GroupPri_MLKEM512 s) = - Just $ convert $ ML.decapsulate s p + convert <$> maybeCryptoError (ML.decapsulate mlkem512 s p) groupDecapsulate (GroupPubB_MLKEM768 p) (GroupPri_MLKEM768 s) = - Just $ convert $ ML.decapsulate s p + convert <$> maybeCryptoError (ML.decapsulate mlkem768 s p) groupDecapsulate (GroupPubB_MLKEM1024 p) (GroupPri_MLKEM1024 s) = - Just $ convert $ ML.decapsulate s p + convert <$> maybeCryptoError (ML.decapsulate mlkem1024 s p) groupDecapsulate (GroupPubB_X25519MLKEM768 (p1, p2)) (GroupPri_X25519MLKEM768 (s1, s2)) = do bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 p1 s1 - let bs2 = convert $ ML.decapsulate s2 p2 + bs2 <- convert <$> maybeCryptoError (ML.decapsulate mlkem768 s2 p2) return (bs2 <> bs1) groupDecapsulate (GroupPubB_P256MLKEM768 (p1, p2)) (GroupPri_P256MLKEM768 (s1, s2)) = do bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 p1 s1 - let bs2 = convert $ ML.decapsulate s2 p2 + bs2 <- convert <$> maybeCryptoError (ML.decapsulate mlkem768 s2 p2) return (bs1 <> bs2) groupDecapsulate (GroupPubB_P384MLKEM1024 (p1, p2)) (GroupPri_P384MLKEM1024 (s1, s2)) = do bs1 <- (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 p1 s1 - let bs2 = convert $ ML.decapsulate s2 p2 + bs2 <- convert <$> maybeCryptoError (ML.decapsulate mlkem1024 s2 p2) return (bs1 <> bs2) groupDecapsulate _ _ = Nothing @@ -388,15 +416,15 @@ groupEncodePublicA (GroupPubA_FFDHE4096 p) = enc ffdhe4096 p groupEncodePublicA (GroupPubA_FFDHE6144 p) = enc ffdhe6144 p groupEncodePublicA (GroupPubA_FFDHE8192 p) = enc ffdhe8192 p -groupEncodePublicA (GroupPubA_MLKEM512 p) = ML.encode p -groupEncodePublicA (GroupPubA_MLKEM768 p) = ML.encode p -groupEncodePublicA (GroupPubA_MLKEM1024 p) = ML.encode p +groupEncodePublicA (GroupPubA_MLKEM512 p) = BA.convert p +groupEncodePublicA (GroupPubA_MLKEM768 p) = BA.convert p +groupEncodePublicA (GroupPubA_MLKEM1024 p) = BA.convert p groupEncodePublicA (GroupPubA_X25519MLKEM768 (p1, p2)) = - ML.encode p2 <> encodePoint x25519 p1 + BA.convert p2 <> encodePoint x25519 p1 groupEncodePublicA (GroupPubA_P256MLKEM768 (p1, p2)) = - encodePoint p256 p1 <> ML.encode p2 + encodePoint p256 p1 <> BA.convert p2 groupEncodePublicA (GroupPubA_P384MLKEM1024 (p1, p2)) = - encodePoint p384 p1 <> ML.encode p2 + encodePoint p384 p1 <> BA.convert p2 groupEncodePublicB :: GroupPublicB -> ByteString groupEncodePublicB (GroupPubB_P256 p) = encodePoint p256 p @@ -433,32 +461,32 @@ groupDecodePublicA FFDHE4096 bs = Right . GroupPubA_FFDHE4096 . PublicNumber $ os2ip bs groupDecodePublicA FFDHE6144 bs = Right . GroupPubA_FFDHE6144 . PublicNumber $ os2ip bs groupDecodePublicA FFDHE8192 bs = Right . GroupPubA_FFDHE8192 . PublicNumber $ os2ip bs -groupDecodePublicA MLKEM512 bs = case ML.decode mlkem512 bs of +groupDecodePublicA MLKEM512 bs = case decodeEK mlkem512 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubA_MLKEM512 p -groupDecodePublicA MLKEM768 bs = case ML.decode mlkem768 bs of +groupDecodePublicA MLKEM768 bs = case decodeEK mlkem768 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubA_MLKEM768 p -groupDecodePublicA MLKEM1024 bs = case ML.decode mlkem1024 bs of +groupDecodePublicA MLKEM1024 bs = case decodeEK mlkem1024 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubA_MLKEM1024 p groupDecodePublicA X25519MLKEM768 bs = let (bs1, bs2) = BA.splitAt 1184 bs - in case ML.decode mlkem768 bs1 of + in case decodeEK mlkem768 bs1 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p2 -> Right $ GroupPubA_X25519MLKEM768 (p2, p1) groupDecodePublicA P256MLKEM768 bs = let (bs1, bs2) = BA.splitAt 65 bs - in case ML.decode mlkem768 bs2 of + in case decodeEK mlkem768 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of Nothing -> Left CryptoError_PointFormatInvalid Just p2 -> Right $ GroupPubA_P256MLKEM768 (p2, p1) groupDecodePublicA P384MLKEM1024 bs = let (bs1, bs2) = BA.splitAt 97 bs - in case ML.decode mlkem1024 bs2 of + in case decodeEK mlkem1024 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of Nothing -> Left CryptoError_PointFormatInvalid @@ -476,32 +504,32 @@ groupDecodePublicB FFDHE4096 bs = Right . GroupPubB_FFDHE4096 . PublicNumber $ os2ip bs groupDecodePublicB FFDHE6144 bs = Right . GroupPubB_FFDHE6144 . PublicNumber $ os2ip bs groupDecodePublicB FFDHE8192 bs = Right . GroupPubB_FFDHE8192 . PublicNumber $ os2ip bs -groupDecodePublicB MLKEM512 bs = case ML.decode mlkem512 bs of +groupDecodePublicB MLKEM512 bs = case decodeCT mlkem512 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubB_MLKEM512 p -groupDecodePublicB MLKEM768 bs = case ML.decode mlkem768 bs of +groupDecodePublicB MLKEM768 bs = case decodeCT mlkem768 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubB_MLKEM768 p -groupDecodePublicB MLKEM1024 bs = case ML.decode mlkem1024 bs of +groupDecodePublicB MLKEM1024 bs = case decodeCT mlkem1024 bs of Nothing -> Left CryptoError_PointFormatInvalid Just p -> Right $ GroupPubB_MLKEM1024 p groupDecodePublicB X25519MLKEM768 bs = let (bs1, bs2) = BA.splitAt 1088 bs - in case ML.decode mlkem768 bs1 of + in case decodeCT mlkem768 bs1 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint x25519 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p2 -> Right $ GroupPubB_X25519MLKEM768 (p2, p1) groupDecodePublicB P256MLKEM768 bs = let (bs1, bs2) = BA.splitAt 65 bs - in case ML.decode mlkem768 bs2 of + in case decodeCT mlkem768 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint p256 bs1 of Nothing -> Left CryptoError_PointFormatInvalid Just p2 -> Right $ GroupPubB_P256MLKEM768 (p2, p1) groupDecodePublicB P384MLKEM1024 bs = let (bs1, bs2) = BA.splitAt 97 bs - in case ML.decode mlkem1024 bs2 of + in case decodeCT mlkem1024 bs2 of Nothing -> Left CryptoError_PointFormatInvalid Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of Nothing -> Left CryptoError_PointFormatInvalid diff --git a/Network/TLS/Handshake/Client/ServerHello.hs b/Network/TLS/Handshake/Client/ServerHello.hs --- a/Network/TLS/Handshake/Client/ServerHello.hs +++ b/Network/TLS/Handshake/Client/ServerHello.hs @@ -4,6 +4,7 @@ module Network.TLS.Handshake.Client.ServerHello ( receiveServerHello, processServerHello13, + processRecordSizeLimit, ) where import Data.ByteArray (convert) @@ -179,9 +180,8 @@ then do -- Session is dummy in TLS 1.3. usingState_ ctx $ setSession shSession - processRecordSizeLimit ctx shExtensions True - enableMyRecordLimit ctx - enablePeerRecordLimit ctx + -- RecordSizeLimit comes in EncryptedExtensions in TLS 1.3 + -- (RFC 8449 Section 4), and is processed there. let usedHash = cipherHash usedCipher transitTranscriptHashI ctx "transitI" usedHash isHRR accepted <- checkECHacceptance ctx isHRR usedHash sh @@ -272,6 +272,10 @@ (return ()) (setPeerRecordSizeLimit ctx tls13) ack <- checkPeerRecordLimit ctx + -- RFC 8449 Section 4: a limit that is not negotiated does not + -- bind the peer, so a server that did not send RecordSizeLimit + -- back may send records of any size the protocol permits. + unless ack $ setMyRecordLimit ctx Nothing -- When a client sends RecordSizeLimit, it does not know -- which TLS version the server selects. RecordLimit is -- the length of plaintext. But RecordSizeLimit also diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs --- a/Network/TLS/Handshake/Client/TLS13.hs +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -135,6 +135,12 @@ :: MonadIO m => Context -> Handshake13 -> m () expectEncryptedExtensions ctx (EncryptedExtensions13 eexts) = do liftIO $ do + -- RFC 8449 Section 4: the server's RecordSizeLimit is in + -- EncryptedExtensions. Until it is known, our own limit is not + -- enforced, as the server may not have agreed to it. + processRecordSizeLimit ctx eexts True + enableMyRecordLimit ctx + enablePeerRecordLimit ctx setALPN ctx MsgTEncryptedExtensions eexts modifyTLS13State ctx $ \st -> st{tls13stClientExtensions = eexts} st13 <- usingHState ctx getTLS13RTT0Status diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -185,7 +185,7 @@ unless (pub `signatureCompatible13` hs) $ throwCore $ Error_Protocol - ("signature algorithm " ++ show hs ++ " does not fit the public key") + ("signature algorithm " ++ showSignatureScheme hs ++ " does not fit the public key") IllegalParameter role <- usingState_ ctx getRole let ctxStr @@ -444,7 +444,7 @@ checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO () checkHashSignatureValid13 hs = unless (isHashSignatureValid13 hs) $ - let msg = "invalid TLS13 hash and signature algorithm: " ++ show hs + let msg = "invalid TLS13 hash and signature algorithm: " ++ showSignatureScheme hs in throwCore $ Error_Protocol msg IllegalParameter isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -91,6 +91,9 @@ isDigitalSignatureKey (PubKeyEC _) = True isDigitalSignatureKey (PubKeyEd25519 _) = True isDigitalSignatureKey (PubKeyEd448 _) = True +isDigitalSignatureKey (PubKeyMLDSA44 _) = True +isDigitalSignatureKey (PubKeyMLDSA65 _) = True +isDigitalSignatureKey (PubKeyMLDSA87 _) = True isDigitalSignatureKey _ = False versionCompatible :: PubKey -> Version -> Bool @@ -99,6 +102,9 @@ versionCompatible (PubKeyEC _) v = v >= TLS10 versionCompatible (PubKeyEd25519 _) v = v >= TLS12 versionCompatible (PubKeyEd448 _) v = v >= TLS12 +versionCompatible (PubKeyMLDSA44 _) v = v >= TLS13 +versionCompatible (PubKeyMLDSA65 _) v = v >= TLS13 +versionCompatible (PubKeyMLDSA87 _) v = v >= TLS13 versionCompatible _ _ = False {- FOURMOLU_ENABLE -} @@ -128,6 +134,9 @@ (PubKeyEC _, PrivKeyEC k) -> kxSupportedPrivKeyEC k (PubKeyEd25519 _, PrivKeyEd25519 _) -> True (PubKeyEd448 _, PrivKeyEd448 _) -> True + (PubKeyMLDSA44 _, PrivKeyMLDSA44 _) -> True + (PubKeyMLDSA65 _, PrivKeyMLDSA65 _) -> True + (PubKeyMLDSA87 _, PrivKeyMLDSA87 _) -> True _ -> False getLocalPublicKey :: MonadIO m => Context -> m PubKey diff --git a/Network/TLS/Handshake/Server/ClientHello12.hs b/Network/TLS/Handshake/Server/ClientHello12.hs --- a/Network/TLS/Handshake/Server/ClientHello12.hs +++ b/Network/TLS/Handshake/Server/ClientHello12.hs @@ -172,7 +172,8 @@ -- Build a list of all hash/signature algorithms in common between -- client and server. - hashAndSignatures = supportedHashSignatures supported + -- ML-DSA is TLS 1.3 only (draft-ietf-tls-mldsa). + hashAndSignatures = filter (not . isMLDSA) $ supportedHashSignatures supported possibleHashSigAlgs = hashAndSignaturesInCommon hashAndSignatures chExtensions -- Check that a candidate signature credential will be compatible with diff --git a/Network/TLS/Handshake/Server/Common.hs b/Network/TLS/Handshake/Server/Common.hs --- a/Network/TLS/Handshake/Server/Common.hs +++ b/Network/TLS/Handshake/Server/Common.hs @@ -223,4 +223,10 @@ let mysiz = fromIntegral mylim + if tls13 then 1 else 0 rsl = RecordSizeLimit mysiz return $ Just $ toExtensionRaw rsl - else return Nothing + else do + -- RFC 8449 Section 4: a limit that is not negotiated + -- does not bind the peer, so a client that did not send + -- RecordSizeLimit may send records of any size the + -- protocol permits. + setMyRecordLimit ctx Nothing + return Nothing diff --git a/Network/TLS/Handshake/Server/ServerHello12.hs b/Network/TLS/Handshake/Server/ServerHello12.hs --- a/Network/TLS/Handshake/Server/ServerHello12.hs +++ b/Network/TLS/Handshake/Server/ServerHello12.hs @@ -142,7 +142,7 @@ if serverWantClientCert then do let (certTypes, hashSigs) = - let as = supportedHashSignatures serverSupported + let as = filter (not . isMLDSA) $ supportedHashSignatures serverSupported in (nub $ mapMaybe (fmap certTypeOnWire . hashSigToCertType) as, as) creq = CertRequest @@ -160,7 +160,11 @@ certTypeOnWire CertificateType_Ed448_Sign = CertificateType_ECDSA_Sign certTypeOnWire t = t commonGroups = negotiatedGroupsInCommon (supportedGroups serverSupported) chExts - commonHashSigs = hashAndSignaturesInCommon (supportedHashSignatures serverSupported) chExts + -- ML-DSA is TLS 1.3 only (draft-ietf-tls-mldsa). + commonHashSigs = + hashAndSignaturesInCommon + (filter (not . isMLDSA) $ supportedHashSignatures serverSupported) + chExts setup_DHE = do let possibleFFGroups = commonGroups `intersect` availableFFGroups (dhparams, priv, pub) <- diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -44,9 +44,24 @@ certificateCompatible (PubKeyEC _) cTypes = CertificateType_ECDSA_Sign `elem` cTypes certificateCompatible (PubKeyEd25519 _) _ = True certificateCompatible (PubKeyEd448 _) _ = True +-- ML-DSA has no CertificateType of its own, as EdDSA does not either; what +-- a client may send is decided by signature_algorithms. +certificateCompatible (PubKeyMLDSA44 _) _ = True +certificateCompatible (PubKeyMLDSA65 _) _ = True +certificateCompatible (PubKeyMLDSA87 _) _ = True certificateCompatible _ _ = False signatureCompatible :: PubKey -> HashAndSignatureAlgorithm -> Bool +-- ML-DSA first, and with a refusal for every other kind of key. The RSA +-- equations below ignore the first byte, and ML-DSA's second byte is one +-- RSASSA-PSS also uses, so an ML-DSA scheme reaching them would be answered +-- for as though it were RSASSA-PSS. +signatureCompatible (PubKeyMLDSA44 _) MLDSA44 = True +signatureCompatible (PubKeyMLDSA65 _) MLDSA65 = True +signatureCompatible (PubKeyMLDSA87 _) MLDSA87 = True +signatureCompatible _ MLDSA44 = False +signatureCompatible _ MLDSA65 = False +signatureCompatible _ MLDSA87 = False signatureCompatible (PubKeyRSA pk) (HashSHA1, SignatureRSA) = kxCanUseRSApkcs1 pk SHA1 signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256 signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384 @@ -62,8 +77,20 @@ -- Whether the signature algorithm is for the type of the key, whatever -- its other parameters. -keyTypeFits :: PubKey -> SignatureAlgorithm -> Bool -keyTypeFits (PubKeyRSA _) s = +-- +-- This takes the whole scheme and not its second byte alone, because +-- ML-DSA's second byte is one RSASSA-PSS also uses: only the pair says +-- which of the two a scheme is. The ML-DSA equations come first for the +-- same reason -- an ML-DSA scheme fits no other kind of key, and one +-- ML-DSA size does not fit another's key. +keyTypeFits :: PubKey -> HashAndSignatureAlgorithm -> Bool +keyTypeFits (PubKeyMLDSA44 _) hs = hs == MLDSA44 +keyTypeFits (PubKeyMLDSA65 _) hs = hs == MLDSA65 +keyTypeFits (PubKeyMLDSA87 _) hs = hs == MLDSA87 +keyTypeFits _ MLDSA44 = False +keyTypeFits _ MLDSA65 = False +keyTypeFits _ MLDSA87 = False +keyTypeFits (PubKeyRSA _) (_, s) = s `elem` [ SignatureRSA , SignatureRSApssRSAeSHA256 @@ -73,10 +100,10 @@ , SignatureRSApsspssSHA384 , SignatureRSApsspssSHA512 ] -keyTypeFits (PubKeyDSA _) s = s == SignatureDSA -keyTypeFits (PubKeyEC _) s = s == SignatureECDSA -keyTypeFits (PubKeyEd25519 _) s = s == SignatureEd25519 -keyTypeFits (PubKeyEd448 _) s = s == SignatureEd448 +keyTypeFits (PubKeyDSA _) (_, s) = s == SignatureDSA +keyTypeFits (PubKeyEC _) (_, s) = s == SignatureECDSA +keyTypeFits (PubKeyEd25519 _) (_, s) = s == SignatureEd25519 +keyTypeFits (PubKeyEd448 _) (_, s) = s == SignatureEd448 keyTypeFits _ _ = False -- Same as 'signatureCompatible' but for TLS13: for ECDSA this also checks the @@ -142,12 +169,19 @@ -- an illegal_parameter. One for the right type of key that still does -- not fit it, an RSASSA-PSS one for an rsaEncryption key say, is a -- signature that does not verify, a decrypt_error, which False leads to. -checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg@(_, sigAlg) _) = do +checkCertificateVerify ctx usedVersion pubKey msgs digSig@(DigitallySigned hashSigAlg _) = do + -- ML-DSA is defined for TLS 1.3 only, so naming one here is a field + -- that is incorrect whatever key the peer holds. + when (usedVersion < TLS13 && isMLDSA hashSigAlg) $ + throwCore $ + Error_Protocol + ("signature algorithm " ++ showSignatureScheme hashSigAlg ++ " is not for " ++ show usedVersion) + IllegalParameter checkSupportedHashSignature ctx hashSigAlg - unless (pubKey `keyTypeFits` sigAlg) $ + unless (pubKey `keyTypeFits` hashSigAlg) $ throwCore $ Error_Protocol - ("signature algorithm " ++ show hashSigAlg ++ " is for another type of key") + ("signature algorithm " ++ showSignatureScheme hashSigAlg ++ " is for another type of key") IllegalParameter if pubKey `signatureCompatible` hashSigAlg then doVerify @@ -187,6 +221,9 @@ return (signatureParams pubKey hashSigAlg, msgs) signatureParams :: PubKey -> HashAndSignatureAlgorithm -> SignatureParams +-- Which of these is used is decided by the key, and signatureCompatible has +-- already refused a scheme that does not fit the key, so an ML-DSA scheme +-- cannot arrive at a clause for another kind of key. signatureParams (PubKeyRSA _) hashSigAlg = case hashSigAlg of (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1 @@ -226,6 +263,9 @@ (hsh, SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh) (_, sigAlg) -> error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg) +signatureParams (PubKeyMLDSA44 _) MLDSA44 = MLDSA44Params +signatureParams (PubKeyMLDSA65 _) MLDSA65 = MLDSA65Params +signatureParams (PubKeyMLDSA87 _) MLDSA87 = MLDSA87Params signatureParams pk _ = error ("signatureParams: " ++ pubkeyType pk ++ " is not supported") signatureCreateWithCertVerifyData @@ -332,5 +372,5 @@ :: Context -> HashAndSignatureAlgorithm -> IO () checkSupportedHashSignature ctx hs = unless (hs `elem` supportedHashSignatures (ctxSupported ctx)) $ - let msg = "unsupported hash and signature algorithm: " ++ show hs + let msg = "unsupported hash and signature algorithm: " ++ showSignatureScheme hs in throwCore $ Error_Protocol msg IllegalParameter diff --git a/Network/TLS/HashAndSignature.hs b/Network/TLS/HashAndSignature.hs --- a/Network/TLS/HashAndSignature.hs +++ b/Network/TLS/HashAndSignature.hs @@ -10,7 +10,8 @@ HashSHA256, HashSHA384, HashSHA512, - HashIntrinsic + HashIntrinsic, + HashMLDSA ), SignatureAlgorithm ( .., @@ -31,8 +32,13 @@ SignatureBrainpoolP512 ), HashAndSignatureAlgorithm, + pattern MLDSA44, + pattern MLDSA65, + pattern MLDSA87, supportedSignatureSchemes, signatureSchemesForTLS13, + isMLDSA, + showSignatureScheme, ) where import Network.TLS.Imports @@ -59,6 +65,8 @@ pattern HashSHA512 = HashAlgorithm 6 pattern HashIntrinsic :: HashAlgorithm pattern HashIntrinsic = HashAlgorithm 8 +pattern HashMLDSA :: HashAlgorithm -- not a hash; see MLDSA44 below +pattern HashMLDSA = HashAlgorithm 9 instance Show HashAlgorithm where show HashNone = "None" @@ -69,6 +77,7 @@ show HashSHA384 = "SHA384" show HashSHA512 = "SHA512" show HashIntrinsic = "TLS13" + show HashMLDSA = "MLDSA" show (HashAlgorithm x) = "Hash " ++ show x {- FOURMOLU_ENABLE -} @@ -133,11 +142,55 @@ type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) +-- ML-DSA, from draft-ietf-tls-mldsa: mldsa44(0x0904), mldsa65(0x0905) and +-- mldsa87(0x0906). +-- +-- These are named as whole pairs rather than as a new 'SignatureAlgorithm', +-- because neither byte is what it is elsewhere: 0x09 is not a hash, and the +-- second byte repeats numbers RSASSA-PSS already uses. Only the pair +-- identifies the scheme, so only the pair is given a name, and code that +-- decides anything about ML-DSA has to match on both bytes. + +-- | Name a signature scheme. +-- +-- 'show' on the pair cannot do this for ML-DSA. A scheme is a 16-bit +-- number that hs-tls carries as the two bytes it is made of, and for ML-DSA +-- the size is in the second byte, whose values RSASSA-PSS also uses -- so +-- the components alone render mldsa65 as @(MLDSA,RSApssRSAeSHA384)@, which +-- names the wrong algorithm. Use this wherever a scheme is put in front of +-- a person. +showSignatureScheme :: HashAndSignatureAlgorithm -> String +showSignatureScheme MLDSA44 = "mldsa44" +showSignatureScheme MLDSA65 = "mldsa65" +showSignatureScheme MLDSA87 = "mldsa87" +showSignatureScheme hs = show hs + +-- | Is this one of the ML-DSA schemes? They are TLS 1.3 only, so the +-- TLS 1.2 paths filter them out and refuse one that arrives anyway. +isMLDSA :: HashAndSignatureAlgorithm -> Bool +isMLDSA MLDSA44 = True +isMLDSA MLDSA65 = True +isMLDSA MLDSA87 = True +isMLDSA _ = False + {- FOURMOLU_DISABLE -} +pattern MLDSA44 :: HashAndSignatureAlgorithm +pattern MLDSA44 = (HashMLDSA, SignatureAlgorithm 4) +pattern MLDSA65 :: HashAndSignatureAlgorithm +pattern MLDSA65 = (HashMLDSA, SignatureAlgorithm 5) +pattern MLDSA87 :: HashAndSignatureAlgorithm +pattern MLDSA87 = (HashMLDSA, SignatureAlgorithm 6) +{- FOURMOLU_ENABLE -} + +{- FOURMOLU_DISABLE -} supportedSignatureSchemes :: [HashAndSignatureAlgorithm] supportedSignatureSchemes = + -- ML-DSA algorithms, TLS 1.3 only + [ MLDSA87 -- mldsa87(0x0906) + , MLDSA65 -- mldsa65(0x0905) + , MLDSA44 -- mldsa44(0x0904) -- EdDSA algorithms - [ (HashIntrinsic, SignatureEd448) -- ed448 (0x0808) + , (HashIntrinsic, SignatureEd448) -- ed448 (0x0808) , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807) -- ECDSA algorithms , (HashSHA512, SignatureECDSA) -- ecdsa_secp512r1_sha512(0x0603) @@ -162,8 +215,12 @@ signatureSchemesForTLS13 :: [(HashAlgorithm, SignatureAlgorithm)] signatureSchemesForTLS13 = + -- ML-DSA algorithms + [ MLDSA87 -- mldsa87(0x0906) + , MLDSA65 -- mldsa65(0x0905) + , MLDSA44 -- mldsa44(0x0904) -- EdDSA algorithms - [ (HashIntrinsic, SignatureEd448) -- ed448 (0x0808) + , (HashIntrinsic, SignatureEd448) -- ed448 (0x0808) , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807) -- ECDSA algorithms , (HashSHA512, SignatureECDSA) -- ecdsa_secp512r1_sha512(0x0603) diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -7,7 +7,7 @@ import qualified Data.ByteString as B import Data.List import Data.Word -import Data.X509 (ExtKeyUsageFlag) +import Data.X509 (ExtKeyUsageFlag, privkeyMLDSAFromKey) import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Internal @@ -220,6 +220,22 @@ , (toPubKeyEC curveName ecdsaPub, toPrivKeyEC curveName ecdsaPriv) , (PubKeyEd25519 ed25519Pub, PrivKeyEd25519 ed25519Priv) , (PubKeyEd448 ed448Pub, PrivKeyEd448 ed448Priv) + ] + +-- | One credential per ML-DSA parameter set. +arbitraryCredentialsOfEachMLDSA :: Gen [(CertificateChain, PrivKey)] +arbitraryCredentialsOfEachMLDSA = do + (pub44, priv44) <- arbitraryMLDSA44Pair + (pub65, priv65) <- arbitraryMLDSA65Pair + (pub87, priv87) <- arbitraryMLDSA87Pair + mapM + ( \(pub, priv) -> do + cert <- arbitraryX509WithKey (pub, priv) + return (CertificateChain [cert], priv) + ) + [ (PubKeyMLDSA44 pub44, PrivKeyMLDSA44 (privkeyMLDSAFromKey priv44)) + , (PubKeyMLDSA65 pub65, PrivKeyMLDSA65 (privkeyMLDSAFromKey priv65)) + , (PubKeyMLDSA87 pub87, PrivKeyMLDSA87 (privkeyMLDSAFromKey priv87)) ] arbitraryCredentialsOfEachCurve :: Gen [(CertificateChain, PrivKey)] diff --git a/test/Certificate.hs b/test/Certificate.hs --- a/test/Certificate.hs +++ b/test/Certificate.hs @@ -159,6 +159,9 @@ getSignatureALG (PubKeyEC _) = SignatureALG HashSHA256 PubKeyALG_EC getSignatureALG (PubKeyEd25519 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed25519 getSignatureALG (PubKeyEd448 _) = SignatureALG_IntrinsicHash PubKeyALG_Ed448 +getSignatureALG (PubKeyMLDSA44 _) = SignatureALG_IntrinsicHash PubKeyALG_MLDSA44 +getSignatureALG (PubKeyMLDSA65 _) = SignatureALG_IntrinsicHash PubKeyALG_MLDSA65 +getSignatureALG (PubKeyMLDSA87 _) = SignatureALG_IntrinsicHash PubKeyALG_MLDSA87 getSignatureALG pubKey = error $ "getSignatureALG: unsupported public key: " ++ show pubKey diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -59,6 +59,22 @@ handshake_high_legacy_version TLS12 (Version 0x0309) it "ignores legacy_version when supported_versions is present" $ handshake_high_legacy_version TLS13 TLS13 + it "keeps to the TLS 1.3 server's record size limit" $ + record_size_limit_negotiated TLS13 False + it "keeps to the TLS 1.3 client's record size limit" $ + record_size_limit_negotiated TLS13 True + it "keeps to the TLS 1.2 server's record size limit" $ + record_size_limit_negotiated TLS12 False + it "keeps to the TLS 1.2 client's record size limit" $ + record_size_limit_negotiated TLS12 True + it "ignores the client's record size limit the TLS 1.3 server does not take" $ + record_size_limit_unnegotiated TLS13 True + it "ignores the server's record size limit the TLS 1.3 client did not offer" $ + record_size_limit_unnegotiated TLS13 False + it "ignores the client's record size limit the TLS 1.2 server does not take" $ + record_size_limit_unnegotiated TLS12 True + it "ignores the server's record size limit the TLS 1.2 client did not offer" $ + record_size_limit_unnegotiated TLS12 False it "rejects ec_point_formats without uncompressed" $ handshake12_ec_point_formats (B.pack [1, 1]) @@ -90,6 +106,12 @@ prop "can authenticate client" handshake_client_auth it "rejects a TLS 1.3 CertificateVerify algorithm unfit for the key" $ handshake13_client_cert_verify_unfit_sigalg + it "rejects a primitive SEQUENCE as an ECDSA signature" $ + handshake13_client_cert_verify_malformed_ecdsa $ \sig -> + B.cons (B.head sig `xor` 0x20) (B.tail sig) + it "rejects a BIT STRING in an ECDSA signature" $ + handshake13_client_cert_verify_malformed_ecdsa $ \_ -> + B.pack [0x30, 0x06, 0x02, 0x01, 0x01, 0x03, 0x01, 0x09] it "rejects a TLS 1.2 CertificateVerify algorithm for another key type" $ handshake12_client_cert_verify_sigalg (HashSHA256, SignatureECDSA) @@ -154,6 +176,28 @@ prop "can handshake with TLS 1.3 EE" handshake13_ee_groups prop "can handshake with TLS 1.3 EC groups" handshake13_ec prop "can handshake with TLS 1.3 FFDHE groups" handshake13_ffdhe + mapM_ + ( \grp -> + prop ("can handshake with " ++ show grp) $ + handshake13_kem grp + ) + [ MLKEM512 + , MLKEM768 + , MLKEM1024 + , X25519MLKEM768 + , P256MLKEM768 + , P384MLKEM1024 + ] + mapM_ + ( \(n, nm) -> do + prop ("can handshake with an " ++ nm ++ " server certificate") $ + handshake13_mldsa n + prop ("can handshake with an " ++ nm ++ " client certificate") $ + handshake13_mldsa_client n + ) + [(0, "ML-DSA-44"), (1, "ML-DSA-65"), (2, "ML-DSA-87")] + it "rejects a CertificateVerify whose scheme is not the key's" $ + handshake13_mldsa_wrong_scheme it "rejects an X25519MLKEM768 key share with a zero X25519 part" $ handshake13_x25519mlkem768_zero_x25519 prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth @@ -936,6 +980,49 @@ (void (E.try (handshake cctx) :: IO (Either TLSException ()))) r `shouldSatisfy` isJust +-- A DER ECDSA signature that does not decode is a signature that does not +-- verify, a decrypt_error. The client's TLS 1.3 CertificateVerify +-- signature is replaced on its way to the server with one that the ASN.1 +-- library used to throw on, which ended the handshake with internal_error. +handshake13_client_cert_verify_malformed_ecdsa + :: (B.ByteString -> B.ByteString) -> IO () +handshake13_client_cert_verify_malformed_ecdsa corrupt = do + let cipher = cipher13_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS13], [TLS13]) + ([cipher], [cipher]) + creds <- generate arbitraryCredentialsOfEachType + let cred = head [c | c@(_, PrivKeyEC _) <- creds] + clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + malform (CertVerify13 (DigitallySigned alg sig)) = + pure $ CertVerify13 (DigitallySigned alg (corrupt sig)) + malform hs = pure hs + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do + contextHookSetHandshake13Recv sctx malform + concurrently_ + ((handshake sctx >> recvData sctx) `shouldThrow` rejectedAsDecryptError) + ( void + (E.try (handshake cctx >> recvData cctx) :: IO (Either TLSException B.ByteString)) + ) + r `shouldSatisfy` isJust + rejectedAsDecryptError :: TLSException -> Bool rejectedAsDecryptError (HandshakeFailed (Error_Protocol _ DecryptError)) = True rejectedAsDecryptError _ = False @@ -1053,6 +1140,78 @@ rejectedAsDecodeError (HandshakeFailed (Error_Protocol _ DecodeError)) = True rejectedAsDecodeError _ = False +-- RFC 8449 Section 4: a record size limit binds the peer only when the +-- extension is negotiated. Only one side sets limitRecordSize, so the +-- extension is not negotiated, and a record of 2^14 octets from the other +-- side must be received rather than refused with record_overflow. +record_size_limit_unnegotiated :: Version -> Bool -> IO () +record_size_limit_unnegotiated version clientLimited = do + let cipher + | version == TLS13 = cipher13_AES_128_GCM_SHA256 + | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([cipher], [cipher]) + let limited shared = shared{sharedLimit = (sharedLimit shared){limitRecordSize = Just 1024}} + clientParam' + | clientLimited = clientParam{clientShared = limited $ clientShared clientParam} + | otherwise = clientParam + serverParam' + | clientLimited = serverParam + | otherwise = serverParam{serverShared = limited $ serverShared serverParam} + payload = B.replicate 16384 0x61 + send ctx = handshake ctx >> sendData ctx (L.fromStrict payload) + received <- newIORef B.empty + let recv ctx = do + handshake ctx + let loop acc + | B.length acc >= B.length payload = writeIORef received acc + | otherwise = recvData ctx >>= \bs -> loop (acc <> bs) + loop B.empty + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> + if clientLimited + then concurrently_ (send sctx) (recv cctx) + else concurrently_ (recv sctx) (send cctx) + r `shouldSatisfy` isJust + readIORef received `shouldReturn` payload + +-- RFC 8449 Section 4: with record_size_limit negotiated, each side keeps +-- to the other's limit. Both sides set limitRecordSize, which a TLS 1.3 +-- server returns in EncryptedExtensions, and 2^14 octets sent by one side +-- must reach the other in records within its limit. +record_size_limit_negotiated :: Version -> Bool -> IO () +record_size_limit_negotiated version serverSends = do + let cipher + | version == TLS13 = cipher13_AES_128_GCM_SHA256 + | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([cipher], [cipher]) + let limited shared = shared{sharedLimit = (sharedLimit shared){limitRecordSize = Just 1024}} + clientParam' = clientParam{clientShared = limited $ clientShared clientParam} + serverParam' = serverParam{serverShared = limited $ serverShared serverParam} + payload = B.replicate 16384 0x61 + send ctx = handshake ctx >> sendData ctx (L.fromStrict payload) + received <- newIORef B.empty + let recv ctx = do + handshake ctx + let loop acc + | B.length acc >= B.length payload = writeIORef received acc + | otherwise = recvData ctx >>= \bs -> loop (acc <> bs) + loop B.empty + r <- timeout 10000000 $ + withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> + if serverSends + then concurrently_ (send sctx) (recv cctx) + else concurrently_ (recv sctx) (send cctx) + r `shouldSatisfy` isJust + readIORef received `shouldReturn` payload + handshake_client_auth_fail :: (ClientParams, ServerParams) -> IO () handshake_client_auth_fail (clientParam, serverParam) = do let clientVersions = supportedVersions $ clientSupported clientParam @@ -1493,6 +1652,150 @@ , srv{serverSupported = svrSupported} ) runTLSSimple13 params FullHandshake + +-- A handshake that succeeds, for each group whose key exchange is a KEM. +-- +-- Until this was added the suite had one ML-KEM test and it was a negative +-- one: a zero X25519 part, rejected before any shared secret was computed. +-- Nothing ran encapsulation and decapsulation to the end and checked the two +-- sides reached the same key, which is the one thing a key exchange has to +-- do. An implementation that returned the ciphertext where the secret +-- belongs would have passed everything else here. +handshake13_kem :: Group -> CSP13 -> IO () +handshake13_kem grp (CSP13 (cli, srv)) = do + let cliSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [grp] + } + svrSupported = + defaultSupported + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [grp] + , supportedGroupsTLS13 = [[grp]] + } + params = + ( cli{clientSupported = cliSupported} + , srv{serverSupported = svrSupported} + ) + runTLSSimple13 params FullHandshake + +-- A handshake with an ML-DSA server certificate, and one with an ML-DSA +-- client certificate, for each parameter set. +handshake13_mldsa :: Int -> CSP13 -> IO () +handshake13_mldsa n (CSP13 (cli, srv)) = do + creds <- generate arbitraryCredentialsOfEachMLDSA + let cred = creds !! n + -- one group on both sides, so the mode is a full handshake and not + -- a retry, which is what this is asserting about + cliSupported = + (clientSupported cli) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + } + svrSupported = + (serverSupported srv) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params = + ( cli{clientSupported = cliSupported} + , srv + { serverSupported = svrSupported + , serverShared = + (serverShared srv){sharedCredentials = Credentials [cred]} + } + ) + runTLSSimple13 params FullHandshake + +handshake13_mldsa_client :: Int -> CSP13 -> IO () +handshake13_mldsa_client n (CSP13 (clientParam, serverParam)) = do + creds <- generate arbitraryCredentialsOfEachMLDSA + let cred = creds !! n + clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \chain -> + if chain == fst cred + then return CertificateUsageAccept + else return (CertificateUsageReject CertificateRejectUnknownCA) + } + , serverSupported = + (serverSupported serverParam) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + } + clientParam'' = + clientParam' + { clientSupported = + (clientSupported clientParam) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + } + } + runTLSSimple13 (clientParam'', serverParam') FullHandshake + +-- A CertificateVerify naming a scheme the key cannot have made. +-- +-- The second byte of an ML-DSA scheme is one RSASSA-PSS also uses, so code +-- that looks at it alone answers for the wrong algorithm; this is here to +-- catch that, and to pin the alert, which has to be illegal_parameter and +-- not decrypt_error -- the field is wrong, rather than the signature. +handshake13_mldsa_wrong_scheme :: IO () +handshake13_mldsa_wrong_scheme = do + CSP13 (cli, srv) <- generate arbitrary + creds <- generate arbitraryCredentialsOfEachMLDSA + let cred = head creds -- ML-DSA-44 + cliSupported = + (clientSupported cli) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + } + svrSupported = + (serverSupported srv) + { supportedCiphers = [cipher13_AES_128_GCM_SHA256] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + } + params = + ( cli{clientSupported = cliSupported} + , srv + { serverSupported = svrSupported + , serverShared = + (serverShared srv){sharedCredentials = Credentials [cred]} + } + ) + withPairContextWith (id, id) params $ \(cctx, sctx) -> do + contextHookSetHandshake13Recv cctx relabel + concurrently_ + (handshake cctx `shouldThrow` clientRejectedTheScheme) + (handshake sctx `shouldThrow` anyTLSException) + where + -- The signature is the one ML-DSA-44 made; only the scheme is changed, + -- to another ML-DSA size, which the key cannot have signed under. + relabel (CertVerify13 (DigitallySigned _ sig)) = + pure $ CertVerify13 $ DigitallySigned MLDSA65 sig + relabel hs = pure hs + +-- The reason as well as the alert. Matching the alert alone would also be +-- satisfied by an illegal_parameter raised for some other reason, which is +-- not what this is asking about. +clientRejectedTheScheme :: TLSException -> Bool +clientRejectedTheScheme (HandshakeFailed (Error_Protocol msg alert)) = + alert == IllegalParameter && "does not fit the public key" `isInfixOf` msg +clientRejectedTheScheme _ = False handshake13_hrr :: CSP13 -> IO () handshake13_hrr (CSP13 (cli, srv)) = do diff --git a/test/PubKey.hs b/test/PubKey.hs --- a/test/PubKey.hs +++ b/test/PubKey.hs @@ -4,6 +4,9 @@ arbitraryECDSAPair, arbitraryEd25519Pair, arbitraryEd448Pair, + arbitraryMLDSA44Pair, + arbitraryMLDSA65Pair, + arbitraryMLDSA87Pair, globalRSAPair, getGlobalRSAPair, knownECCurves, @@ -20,8 +23,10 @@ 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.MLDSA as MLDSA import qualified Crypto.PubKey.RSA as RSA import Crypto.Random +import Data.Proxy (Proxy (..)) import qualified Data.ByteString as B import System.IO.Unsafe import Test.QuickCheck @@ -111,6 +116,27 @@ bytes <- vectorOf 32 arbitrary let priv = fromCryptoPassed $ Ed25519.secretKey (B.pack bytes) return (Ed25519.toPublic priv, priv) + +-- ML-DSA, from a seed drawn here, so a run is reproducible from its seed +-- the way the other pairs are. +arbitraryMLDSAPair + :: MLDSA.MLDSA p + => proxy p -> Gen (MLDSA.VerificationKey p, MLDSA.SigningKey p) +arbitraryMLDSAPair p = do + bytes <- vectorOf MLDSA.seedSize arbitrary + return $ fromCryptoPassed $ MLDSA.keyPairFromSeed p (B.pack bytes) + +arbitraryMLDSA44Pair + :: Gen (MLDSA.VerificationKey MLDSA.MLDSA44, MLDSA.SigningKey MLDSA.MLDSA44) +arbitraryMLDSA44Pair = arbitraryMLDSAPair (Proxy :: Proxy MLDSA.MLDSA44) + +arbitraryMLDSA65Pair + :: Gen (MLDSA.VerificationKey MLDSA.MLDSA65, MLDSA.SigningKey MLDSA.MLDSA65) +arbitraryMLDSA65Pair = arbitraryMLDSAPair (Proxy :: Proxy MLDSA.MLDSA65) + +arbitraryMLDSA87Pair + :: Gen (MLDSA.VerificationKey MLDSA.MLDSA87, MLDSA.SigningKey MLDSA.MLDSA87) +arbitraryMLDSA87Pair = arbitraryMLDSAPair (Proxy :: Proxy MLDSA.MLDSA87) arbitraryEd448Pair :: Gen (Ed448.PublicKey, Ed448.SecretKey) arbitraryEd448Pair = do diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: tls -version: 2.4.9 +version: 2.4.10 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez @@ -122,16 +122,15 @@ base16-bytestring, bytestring >=0.10 && <0.13, cereal >=0.5.3 && <0.6, - crypton >=2.1.1 && <2.2, + crypton >=2.1.8 && <2.3, crypton-asn1-encoding >= 0.10.0 && < 0.11, crypton-asn1-types >= 0.4.1 && < 0.5, - crypton-x509 >=1.9 && <1.10, - crypton-x509-store >=1.9 && <1.10, - crypton-x509-validation >=1.9 && <1.10, + crypton-x509 >=1.10 && <1.11, + crypton-x509-store >=1.10 && <1.11, + crypton-x509-validation >=1.10 && <1.11, data-default, ech-config, - hpke >=0.1.0 && <0.3, - mlkem >= 0.2.0 && <0.3, + hpke >=0.3.0 && <0.4, mtl >=2.2 && <2.4, network >=3.1, ram >=0.22.0 && <0.23, diff --git a/util/tls-server.hs b/util/tls-server.hs --- a/util/tls-server.hs +++ b/util/tls-server.hs @@ -157,6 +157,10 @@ | optUseWeakCiphers = supportedGroups defaultSupported -- excluding FFDHE8192 for retry | otherwise = FFDHE8192 `delete` supportedGroups defaultSupported + -- A TLS 1.3 server picks a group from supportedGroupsTLS13, so the + -- groups given with -g go there too. Without -g, the default + -- preference stands. + groupsTLS13 = maybe (supportedGroupsTLS13 defaultSupported) (: []) optGroups when (null groups) $ do putStrLn "Error: unsupported groups" exitFailure @@ -193,6 +197,7 @@ creds optUseWeakCiphers groups + groupsTLS13 smgr keyLog optClientAuth @@ -222,6 +227,7 @@ :: Credentials -> Bool -> [Group] + -> [[Group]] -> SessionManager -> (String -> IO ()) -> Bool @@ -231,7 +237,7 @@ -> (String -> IO ()) -> Maybe HostName -> ServerParams -getServerParams creds weak groups sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey mname = +getServerParams creds weak groups groupsTLS13 sm keyLog clientAuth mstore (ekey, ecnf) printError traceKey mname = defaultParamsServer { serverSupported = supported , serverShared = shared @@ -260,6 +266,7 @@ defaultSupported { supportedCiphers = ciphers , supportedGroups = groups + , supportedGroupsTLS13 = groupsTLS13 , supportedExtendedMainSecret = if weak then AllowEMS else supportedExtendedMainSecret defaultSupported , supportedClientInitiatedRenegotiation =