tls 2.2.2 → 2.4.3
raw patch · 50 files changed
Files
- CHANGELOG.md +35/−3
- Network/TLS.hs +10/−2
- Network/TLS/Compression.hs +1/−1
- Network/TLS/Context/Internal.hs +6/−4
- Network/TLS/Core.hs +1/−1
- Network/TLS/Crypto.hs +18/−21
- Network/TLS/Crypto/DH.hs +6/−5
- Network/TLS/Crypto/IES.hs +370/−123
- Network/TLS/Crypto/Types.hs +58/−11
- Network/TLS/Extension.hs +1/−1
- Network/TLS/Extra/CipherCBC.hs +201/−0
- Network/TLS/Handshake/Certificate.hs +21/−1
- Network/TLS/Handshake/Client.hs +58/−19
- Network/TLS/Handshake/Client/ClientHello.hs +32/−23
- Network/TLS/Handshake/Client/ServerHello.hs +2/−1
- Network/TLS/Handshake/Client/TLS12.hs +7/−6
- Network/TLS/Handshake/Client/TLS13.hs +8/−8
- Network/TLS/Handshake/Common.hs +6/−5
- Network/TLS/Handshake/Common13.hs +82/−43
- Network/TLS/Handshake/Key.hs +13/−11
- Network/TLS/Handshake/Server.hs +16/−8
- Network/TLS/Handshake/Server/ClientHello12.hs +1/−1
- Network/TLS/Handshake/Server/ClientHello13.hs +38/−17
- Network/TLS/Handshake/Server/Common.hs +4/−2
- Network/TLS/Handshake/Server/ServerHello12.hs +6/−4
- Network/TLS/Handshake/Server/ServerHello13.hs +7/−22
- Network/TLS/Handshake/Server/TLS12.hs +18/−14
- Network/TLS/Handshake/Server/TLS13.hs +2/−3
- Network/TLS/Handshake/State.hs +15/−16
- Network/TLS/Handshake/State13.hs +5/−5
- Network/TLS/KeySchedule.hs +10/−7
- Network/TLS/MAC.hs +34/−31
- Network/TLS/Packet.hs +15/−20
- Network/TLS/Parameters.hs +115/−11
- Network/TLS/QUIC.hs +3/−3
- Network/TLS/Record/Decrypt.hs +4/−3
- Network/TLS/Record/Encrypt.hs +5/−4
- Network/TLS/Record/State.hs +5/−4
- Network/TLS/State.hs +4/−4
- Network/TLS/Struct.hs +1/−1
- Network/TLS/Types/Cipher.hs +16/−5
- Network/TLS/Types/Secret.hs +12/−10
- Network/TLS/Types/Session.hs +2/−1
- Network/TLS/Util.hs +19/−10
- test/Arbitrary.hs +2/−1
- test/CiphersSpec.hs +5/−3
- test/ECHSpec.hs +22/−2
- test/HandshakeSpec.hs +73/−5
- tls.cabal +11/−8
- util/Common.hs +19/−11
CHANGELOG.md view
@@ -1,5 +1,37 @@ # Change log for "tls" +## Version 2.4.3++* A server checks clientAuth of ExtendedKeyUsage in a client+ certificate on client authentication.++## Version 2.4.2++* The `Network.TLS.Extra.CipherCBC` module is added.+ [#526](https://github.com/haskell-tls/hs-tls/pull/526)++## Version 2.4.1++* Ensure same `supported_groups` before/after HRR.+* New `clientWantTicket` parameter makes it possible to opt-out of soliciting+ session tickets from servers.++## Version 2.4.0++* Identical to v2.3.1 but major version up as v2.3.1 breaks "quic".++## Version 2.3.1 (deprecated)++* Using ScrubbedBytes for secrets.+* Key echange with ML-KEM.+ [#517](https://github.com/haskell-tls/hs-tls/pull/517)+* Expose get certificate chain function+ [#520](https://github.com/haskell-tls/hs-tls/pull/520)++## Version 2.3.0++* Using "ram" instead of "memory".+ ## Version 2.2.2 * A new architecture to calculate receiver's transcript hash with wire@@ -69,14 +101,14 @@ This feature is automatically used if the peer supports it. * More tests with `tlsfuzzer` especially for client authentication and 0-RTT.-* Implementing a utility funcation, `validateClientCertificate`, for+* Implementing a utility function, `validateClientCertificate`, for client authentication. * Bug fix for echo back logic of Cookie extension. * More pretty show for the internal `Handshake` structure for debugging. ## Version 2.1.6 -* Testing with "tlsfuzzer" again. Now don't send an alert agaist to+* Testing with "tlsfuzzer" again. Now don't send an alert against to peer's alert. Double locking (aka self dead-lock) is fixed. Sending an alert for known-but-cannot-parse extensions. Other corner cases are also fixed.@@ -340,7 +372,7 @@ API CHANGES: - `SessionManager` implementations need to provide a `sessionResumeOnlyOnce`- function to accomodate resumption scenarios with 0-RTT data. The function is+ function to accommodate resumption scenarios with 0-RTT data. The function is called only on the server side. - Data type `SessionData` is extended with four new fields for TLS version 1.3. `SessionManager` implementations that serializes/deserializes `SessionData`
Network/TLS.hs view
@@ -11,7 +11,7 @@ -- protocol, and support RSA and Ephemeral (Elliptic curve and -- regular) Diffie Hellman key exchanges, and many extensions. ----- The tipical usage is:+-- The typical usage is: -- -- > socket <- ... -- > ctx <- contextNew socket <params>@@ -46,6 +46,7 @@ clientUseServerNameIndication, clientWantSessionResume, clientWantSessionResumeList,+ clientWantTicket, clientShared, clientHooks, clientSupported,@@ -88,6 +89,7 @@ onSuggestALPN, onCustomFFDHEGroup, onServerFinished,+ onSelectKeyShareGroups, -- ** Server hooks ServerHooks,@@ -100,6 +102,7 @@ onNewHandshake, onALPNClientSuggest, onEncryptedExtensionsCreating,+ onSelectKeyShare, Measurement, nbHandshakes, bytesReceived,@@ -119,6 +122,7 @@ supportedFallbackScsv, supportedEmptyPacket, supportedGroups,+ supportedGroupsTLS13, -- ** Debug parameters DebugParams,@@ -236,6 +240,7 @@ unServerRandom, HandshakeMode13 (..), getClientCertificateChain,+ getServerCertificateChain, -- ** Negotiated getNegotiatedProtocol,@@ -321,10 +326,10 @@ import Network.TLS.Crypto ( DHParams, DHPublic,- Group (..), KxError (..), supportedNamedGroups, )+import Network.TLS.Extension import Network.TLS.Handshake.State (HandshakeMode13 (..)) import Network.TLS.Hooks import Network.TLS.Imports@@ -361,6 +366,9 @@ -- both cases of full-negotiation and resumption. getClientCertificateChain :: Context -> IO (Maybe CertificateChain) getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain++getServerCertificateChain :: Context -> IO (Maybe CertificateChain)+getServerCertificateChain ctx = usingState_ ctx S.getServerCertificateChain -- $exceptions -- Since 1.8.0, this library only throws exceptions of type 'TLSException'.
Network/TLS/Compression.hs view
@@ -51,7 +51,7 @@ (==) c1 c2 = compressionID c1 == compressionID c2 -- | intersect a list of ids commonly given by the other side with a list of compression--- the function keeps the list of compression in order, to be able to find quickly the prefered+-- the function keeps the list of compression in order, to be able to find quickly the preferred -- compression. compressionIntersectID :: [Compression] -> [Word8] -> [Compression] compressionIntersectID l ids = filter (\c -> compressionID c `elem` ids) l
Network/TLS/Context/Internal.hs view
@@ -88,6 +88,8 @@ import Control.Concurrent.MVar import Control.Exception (throwIO) import Control.Monad.State.Strict+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.IORef import Data.Tuple@@ -185,7 +187,7 @@ { cVersion :: Version , cCipher :: Cipher , cHash :: Hash- , cZero :: ByteString+ , cZero :: Secret } deriving (Show) @@ -193,7 +195,7 @@ makeCipherChoice ver cipher = CipherChoice ver cipher h zero where h = cipherHash cipher- zero = B.replicate (hashDigestSize h) 0+ zero = BA.replicate (hashDigestSize h) 0 data TLS13State = TLS13State { tls13stRecvNST :: Bool -- client@@ -209,7 +211,7 @@ , tls13stClientExtensions :: [ExtensionRaw] -- client , tls13stChoice :: ~CipherChoice -- client , tls13stHsKey :: Maybe (SecretTriple HandshakeSecret) -- client- -- Actuall session id for TLS 1.2, random value for TLS 1.3+ -- Actual session id for TLS 1.2, random value for TLS 1.3 , tls13stSession :: Session , tls13stSentExtensions :: [ExtensionID] }@@ -324,7 +326,7 @@ { infoVersion = v , infoCipher = c , infoCompression = comp- , infoMainSecret = ms+ , infoMainSecret = convert <$> ms , infoExtendedMainSecret = ems , infoClientRandom = cr , infoServerRandom = sr
Network/TLS/Core.hs view
@@ -188,7 +188,7 @@ -- All chunks are protected with the same write lock because we don't -- want to interleave writes from other threads in the middle of our -- possibly large write.- mlen <- getPeerRecordLimit ctx -- plaintext, dont' adjust for TLS 1.3+ mlen <- getPeerRecordLimit ctx -- plaintext, don't adjust for TLS 1.3 mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend) -- | Get data out of Data packet, and automatically renegotiate if a Handshake
Network/TLS/Crypto.hs view
@@ -61,7 +61,8 @@ import Data.ASN1.BinaryEncoding (BER (..), DER (..)) import Data.ASN1.Encoding import Data.ASN1.Types-import qualified Data.ByteArray as B (convert)+import Data.ByteArray (ByteArray, ByteArrayAccess, ScrubbedBytes, convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Data.Proxy import Data.X509 (@@ -78,6 +79,8 @@ import Network.TLS.Crypto.Types import Network.TLS.Imports +----------------------------------------------------------------+ {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-}@@ -161,9 +164,9 @@ HashContextSSL (H.hashUpdate sha1Ctx b2) (H.hashUpdate md5Ctx b1) hashFinal :: HashCtx -> ByteString-hashFinal (HashContext (ContextSimple h)) = B.convert $ H.hashFinalize h+hashFinal (HashContext (ContextSimple h)) = convert $ H.hashFinalize h hashFinal (HashContextSSL sha1Ctx md5Ctx) =- B.concat [B.convert (H.hashFinalize md5Ctx), B.convert (H.hashFinalize sha1Ctx)]+ B.concat [convert (H.hashFinalize md5Ctx), convert (H.hashFinalize sha1Ctx)] data Hash = MD5 | SHA1 | SHA224 | SHA256 | SHA384 | SHA512 | SHA1_MD5 deriving (Show, Eq)@@ -180,20 +183,14 @@ type HashCtx = HashContext -hash :: Hash -> ByteString -> ByteString-hash MD5 b = B.convert . (H.hash :: ByteString -> H.Digest H.MD5) $ b-hash SHA1 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA1) $ b-hash SHA224 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA224) $ b-hash SHA256 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA256) $ b-hash SHA384 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA384) $ b-hash SHA512 b = B.convert . (H.hash :: ByteString -> H.Digest H.SHA512) $ b-hash SHA1_MD5 b =- B.concat [B.convert (md5Hash b), B.convert (sha1Hash b)]- where- sha1Hash :: ByteString -> H.Digest H.SHA1- sha1Hash = H.hash- md5Hash :: ByteString -> H.Digest H.MD5- md5Hash = H.hash+hash :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba+hash MD5 b = convert (H.hash b :: H.Digest H.MD5)+hash SHA1 b = convert (H.hash b :: H.Digest H.SHA1)+hash SHA224 b = convert (H.hash b :: H.Digest H.SHA224)+hash SHA256 b = convert (H.hash b :: H.Digest H.SHA256)+hash SHA384 b = convert (H.hash b :: H.Digest H.SHA384)+hash SHA512 b = convert (H.hash b :: H.Digest H.SHA512)+hash SHA1_MD5 b = BA.concat [hash MD5 b, hash SHA1 b] hashName :: Hash -> String hashName = show@@ -224,12 +221,12 @@ generalizeRSAError (Right x) = Right x kxEncrypt- :: MonadRandom r => PublicKey -> ByteString -> r (Either KxError ByteString)+ :: MonadRandom r => PublicKey -> ScrubbedBytes -> r (Either KxError ByteString) kxEncrypt (PubKeyRSA pk) b = generalizeRSAError <$> RSA.encrypt pk b kxEncrypt _ _ = return (Left KxUnsupported) kxDecrypt- :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ByteString)+ :: MonadRandom r => PrivateKey -> ByteString -> r (Either KxError ScrubbedBytes) kxDecrypt (PrivKeyRSA pk) b = generalizeRSAError <$> RSA.decryptSafer pk b kxDecrypt _ _ = return (Left KxUnsupported) @@ -366,9 +363,9 @@ Just sign -> Right (ECDSA.signatureToIntegers prx sign) unsupported = return $ Left KxUnsupported kxSign (PrivKeyEd25519 pk) (PubKeyEd25519 pub) Ed25519Params msg =- return $ Right $ B.convert $ Ed25519.sign pk pub msg+ return $ Right $ convert $ Ed25519.sign pk pub msg kxSign (PrivKeyEd448 pk) (PubKeyEd448 pub) Ed448Params msg =- return $ Right $ B.convert $ Ed448.sign pk pub msg+ return $ Right $ convert $ Ed448.sign pk pub msg kxSign _ _ _ _ = return (Left KxUnsupported)
Network/TLS/Crypto/DH.hs view
@@ -21,14 +21,15 @@ import Crypto.Number.Basic (numBits) import qualified Crypto.PubKey.DH as DH-import qualified Data.ByteArray as B+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteArray as BA import Network.TLS.RNG type DHPublic = DH.PublicNumber type DHPrivate = DH.PrivateNumber type DHParams = DH.Params-type DHKey = DH.SharedKey+type DHKey = ScrubbedBytes dhPublic :: Integer -> DHPublic dhPublic = DH.PublicNumber@@ -46,12 +47,12 @@ return (priv, pub) dhGetShared :: DHParams -> DHPrivate -> DHPublic -> DHKey-dhGetShared params priv pub =- stripLeadingZeros (DH.getShared params priv pub)+dhGetShared params priv pub = stripLeadingZeros sec where+ DH.SharedKey sec = DH.getShared params priv pub -- strips leading zeros from the result of DH.getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3.- stripLeadingZeros (DH.SharedKey sb) = DH.SharedKey (snd $ B.span (== 0) sb)+ stripLeadingZeros sb = snd $ BA.span (== 0) sb -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.
Network/TLS/Crypto/IES.hs view
@@ -1,4 +1,5 @@ -- | (Elliptic Curve) Integrated Encryption Scheme+-- KEM(Key Encapsulation Mechanism) based APIs -- -- Module : Network.TLS.Crypto.IES -- License : BSD-style@@ -6,16 +7,19 @@ -- Stability : experimental -- Portability : unknown module Network.TLS.Crypto.IES (- GroupPublic,+ GroupPublicA,+ GroupPublicB, GroupPrivate, GroupKey, -- * Group methods groupGenerateKeyPair,- groupGetPubShared,- groupGetShared,- encodeGroupPublic,- decodeGroupPublic,+ groupEncapsulate,+ groupDecapsulate,+ groupEncodePublicA,+ groupDecodePublicA,+ groupEncodePublicB,+ groupDecodePublicB, -- * Compatibility with 'Network.TLS.Crypto.DH' dhParamsForGroup,@@ -24,12 +28,16 @@ ) where import Control.Arrow-import Crypto.ECC+import Crypto.ECC as ECC import Crypto.Error import Crypto.Number.Generate-import Crypto.PubKey.DH hiding (generateParams)+import Crypto.PubKey.DH (PrivateNumber (..), PublicNumber (..))+import qualified Crypto.PubKey.DH as DH import Crypto.PubKey.ECIES-import qualified Data.ByteArray as B+import Crypto.PubKey.ML_KEM (ML_KEM_1024, ML_KEM_512, ML_KEM_768)+import qualified Crypto.PubKey.ML_KEM as ML+import Data.ByteArray (ScrubbedBytes, convert)+import qualified Data.ByteArray as BA import Data.Proxy import Network.TLS.Crypto.Types@@ -38,6 +46,7 @@ import Network.TLS.RNG import Network.TLS.Util.Serialization (i2ospOf_, os2ip) +{- FOURMOLU_DISABLE -} data GroupPrivate = GroupPri_P256 (Scalar Curve_P256R1) | GroupPri_P384 (Scalar Curve_P384R1)@@ -49,23 +58,59 @@ | 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) deriving (Eq, Show)+{- FOURMOLU_ENABLE -} -data GroupPublic- = GroupPub_P256 (Point Curve_P256R1)- | GroupPub_P384 (Point Curve_P384R1)- | GroupPub_P521 (Point Curve_P521R1)- | GroupPub_X255 (Point Curve_X25519)- | GroupPub_X448 (Point Curve_X448)- | GroupPub_FFDHE2048 PublicNumber- | GroupPub_FFDHE3072 PublicNumber- | GroupPub_FFDHE4096 PublicNumber- | GroupPub_FFDHE6144 PublicNumber- | GroupPub_FFDHE8192 PublicNumber+{- FOURMOLU_DISABLE -}+data GroupPublicA+ = GroupPubA_P256 (Point Curve_P256R1)+ | GroupPubA_P384 (Point Curve_P384R1)+ | GroupPubA_P521 (Point Curve_P521R1)+ | GroupPubA_X255 (Point Curve_X25519)+ | GroupPubA_X448 (Point Curve_X448)+ | GroupPubA_FFDHE2048 PublicNumber+ | GroupPubA_FFDHE3072 PublicNumber+ | 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) deriving (Eq, Show)+{- FOURMOLU_ENABLE -} -type GroupKey = SharedSecret+{- FOURMOLU_DISABLE -}+data GroupPublicB+ = GroupPubB_P256 (Point Curve_P256R1)+ | GroupPubB_P384 (Point Curve_P384R1)+ | GroupPubB_P521 (Point Curve_P521R1)+ | GroupPubB_X255 (Point Curve_X25519)+ | GroupPubB_X448 (Point Curve_X448)+ | GroupPubB_FFDHE2048 PublicNumber+ | GroupPubB_FFDHE3072 PublicNumber+ | 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)+ deriving (Eq, Show)+{- FOURMOLU_ENABLE -} +type GroupKey = ScrubbedBytes+ p256 :: Proxy Curve_P256R1 p256 = Proxy @@ -81,7 +126,16 @@ x448 :: Proxy Curve_X448 x448 = Proxy -dhParamsForGroup :: Group -> Maybe Params+mlkem512 :: Proxy ML_KEM_512+mlkem512 = Proxy++mlkem768 :: Proxy ML_KEM_768+mlkem768 = Proxy++mlkem1024 :: Proxy ML_KEM_1024+mlkem1024 = Proxy++dhParamsForGroup :: Group -> Maybe DH.Params dhParamsForGroup FFDHE2048 = Just ffdhe2048 dhParamsForGroup FFDHE3072 = Just ffdhe3072 dhParamsForGroup FFDHE4096 = Just ffdhe4096@@ -89,26 +143,47 @@ dhParamsForGroup FFDHE8192 = Just ffdhe8192 dhParamsForGroup _ = Nothing -groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublic)+groupGenerateKeyPair :: MonadRandom r => Group -> r (GroupPrivate, GroupPublicA) groupGenerateKeyPair P256 =- (GroupPri_P256, GroupPub_P256) `fs` curveGenerateKeyPair p256+ (GroupPri_P256, GroupPubA_P256) `fs` curveGenerateKeyPair p256 groupGenerateKeyPair P384 =- (GroupPri_P384, GroupPub_P384) `fs` curveGenerateKeyPair p384+ (GroupPri_P384, GroupPubA_P384) `fs` curveGenerateKeyPair p384 groupGenerateKeyPair P521 =- (GroupPri_P521, GroupPub_P521) `fs` curveGenerateKeyPair p521+ (GroupPri_P521, GroupPubA_P521) `fs` curveGenerateKeyPair p521 groupGenerateKeyPair X25519 =- (GroupPri_X255, GroupPub_X255) `fs` curveGenerateKeyPair x25519+ (GroupPri_X255, GroupPubA_X255) `fs` curveGenerateKeyPair x25519 groupGenerateKeyPair X448 =- (GroupPri_X448, GroupPub_X448) `fs` curveGenerateKeyPair x448-groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPub_FFDHE2048-groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPub_FFDHE3072-groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPub_FFDHE4096-groupGenerateKeyPair FFDHE6144 = gen ffdhe6144 exp6144 GroupPri_FFDHE6144 GroupPub_FFDHE6144-groupGenerateKeyPair FFDHE8192 = gen ffdhe8192 exp8192 GroupPri_FFDHE8192 GroupPub_FFDHE8192+ (GroupPri_X448, GroupPubA_X448) `fs` curveGenerateKeyPair x448+groupGenerateKeyPair FFDHE2048 = gen ffdhe2048 exp2048 GroupPri_FFDHE2048 GroupPubA_FFDHE2048+groupGenerateKeyPair FFDHE3072 = gen ffdhe3072 exp3072 GroupPri_FFDHE3072 GroupPubA_FFDHE3072+groupGenerateKeyPair FFDHE4096 = gen ffdhe4096 exp4096 GroupPri_FFDHE4096 GroupPubA_FFDHE4096+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+ return (GroupPri_MLKEM512 d, GroupPubA_MLKEM512 e)+groupGenerateKeyPair MLKEM768 = do+ (e, d) <- ML.generate mlkem768+ return (GroupPri_MLKEM768 d, GroupPubA_MLKEM768 e)+groupGenerateKeyPair MLKEM1024 = do+ (e, d) <- ML.generate mlkem1024+ return (GroupPri_MLKEM1024 d, GroupPubA_MLKEM1024 e)+groupGenerateKeyPair X25519MLKEM768 = do+ (d1, e1) <- fs' $ curveGenerateKeyPair x25519+ (e2, d2) <- ML.generate mlkem768+ return (GroupPri_X25519MLKEM768 (d1, d2), GroupPubA_X25519MLKEM768 (e1, e2))+groupGenerateKeyPair P256MLKEM768 = do+ (d1, e1) <- fs' $ curveGenerateKeyPair p256+ (e2, d2) <- ML.generate mlkem768+ return (GroupPri_P256MLKEM768 (d1, d2), GroupPubA_P256MLKEM768 (e1, e2))+groupGenerateKeyPair P384MLKEM1024 = do+ (d1, e1) <- fs' $ curveGenerateKeyPair p384+ (e2, d2) <- ML.generate mlkem1024+ return (GroupPri_P384MLKEM1024 (d1, d2), GroupPubA_P384MLKEM1024 (e1, e2)) groupGenerateKeyPair _ = error "groupGenerateKeyPair" dhGroupGenerateKeyPair- :: MonadRandom r => Group -> r (Params, PrivateNumber, PublicNumber)+ :: MonadRandom r => Group -> r (DH.Params, PrivateNumber, PublicNumber) dhGroupGenerateKeyPair FFDHE2048 = addParams ffdhe2048 (gen' ffdhe2048 exp2048) dhGroupGenerateKeyPair FFDHE3072 = addParams ffdhe3072 (gen' ffdhe3072 exp3072) dhGroupGenerateKeyPair FFDHE4096 = addParams ffdhe4096 (gen' ffdhe4096 exp4096)@@ -116,148 +191,320 @@ dhGroupGenerateKeyPair FFDHE8192 = addParams ffdhe8192 (gen' ffdhe8192 exp8192) dhGroupGenerateKeyPair grp = error ("invalid FFDHE group: " ++ show grp) -addParams :: Functor f => Params -> f (a, b) -> f (Params, a, b)+addParams :: Functor f => DH.Params -> f (a, b) -> f (DH.Params, a, b) addParams params = fmap $ \(a, b) -> (params, a, b) fs :: MonadRandom r- => (Scalar a -> GroupPrivate, Point a -> GroupPublic)+ => (Scalar a -> GroupPrivate, Point a -> GroupPublicA) -> r (KeyPair a)- -> r (GroupPrivate, GroupPublic)+ -> r (GroupPrivate, GroupPublicA) (t1, t2) `fs` action = do keypair <- action let pub = keypairGetPublic keypair pri = keypairGetPrivate keypair return (t1 pri, t2 pub) +fs' :: Monad m => m (KeyPair curve) -> m (Scalar curve, Point curve)+fs' action = do+ keypair <- action+ let pub = keypairGetPublic keypair+ pri = keypairGetPrivate keypair+ return (pri, pub)+ gen :: MonadRandom r- => Params+ => DH.Params -> Int -> (PrivateNumber -> GroupPrivate)- -> (PublicNumber -> GroupPublic)- -> r (GroupPrivate, GroupPublic)+ -> (PublicNumber -> GroupPublicA)+ -> r (GroupPrivate, GroupPublicA) gen params expBits priTag pubTag = (priTag *** pubTag) <$> gen' params expBits gen' :: MonadRandom r- => Params+ => DH.Params -> Int -> r (PrivateNumber, PublicNumber)-gen' params expBits = (id &&& calculatePublic params) <$> generatePriv expBits+gen' params expBits = (id &&& DH.calculatePublic params) <$> generatePriv expBits -groupGetPubShared- :: MonadRandom r => GroupPublic -> r (Maybe (GroupPublic, GroupKey))-groupGetPubShared (GroupPub_P256 pub) =- fmap (first GroupPub_P256) . maybeCryptoError <$> deriveEncrypt p256 pub-groupGetPubShared (GroupPub_P384 pub) =- fmap (first GroupPub_P384) . maybeCryptoError <$> deriveEncrypt p384 pub-groupGetPubShared (GroupPub_P521 pub) =- fmap (first GroupPub_P521) . maybeCryptoError <$> deriveEncrypt p521 pub-groupGetPubShared (GroupPub_X255 pub) =- fmap (first GroupPub_X255) . maybeCryptoError <$> deriveEncrypt x25519 pub-groupGetPubShared (GroupPub_X448 pub) =- fmap (first GroupPub_X448) . maybeCryptoError <$> deriveEncrypt x448 pub-groupGetPubShared (GroupPub_FFDHE2048 pub) = getPubShared ffdhe2048 exp2048 pub GroupPub_FFDHE2048-groupGetPubShared (GroupPub_FFDHE3072 pub) = getPubShared ffdhe3072 exp3072 pub GroupPub_FFDHE3072-groupGetPubShared (GroupPub_FFDHE4096 pub) = getPubShared ffdhe4096 exp4096 pub GroupPub_FFDHE4096-groupGetPubShared (GroupPub_FFDHE6144 pub) = getPubShared ffdhe6144 exp6144 pub GroupPub_FFDHE6144-groupGetPubShared (GroupPub_FFDHE8192 pub) = getPubShared ffdhe8192 exp8192 pub GroupPub_FFDHE8192+groupEncapsulate+ :: MonadRandom r => GroupPublicA -> r (Maybe (GroupPublicB, GroupKey))+groupEncapsulate (GroupPubA_P256 pub) = getECDHPubShared GroupPubB_P256 p256 pub+groupEncapsulate (GroupPubA_P384 pub) = getECDHPubShared GroupPubB_P384 p384 pub+groupEncapsulate (GroupPubA_P521 pub) = getECDHPubShared GroupPubB_P521 p521 pub+groupEncapsulate (GroupPubA_X255 pub) = getECDHPubShared GroupPubB_X255 x25519 pub+groupEncapsulate (GroupPubA_X448 pub) = getECDHPubShared GroupPubB_X448 x448 pub+groupEncapsulate (GroupPubA_FFDHE2048 pub) = getDHPubShared ffdhe2048 exp2048 pub GroupPubB_FFDHE2048+groupEncapsulate (GroupPubA_FFDHE3072 pub) = getDHPubShared ffdhe3072 exp3072 pub GroupPubB_FFDHE3072+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_X25519MLKEM768 (e1, e2)) = do+ (c1, k1) <- fromJust <$> getECDHPubShared' x25519 e1+ (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+ (c1, k1) <- fromJust <$> getECDHPubShared' p256 e1+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P256MLKEM768 (c1, c2), k1 <> convert k2)+groupEncapsulate (GroupPubA_P384MLKEM1024 (e1, e2)) = do+ (c1, k1) <- fromJust <$> getECDHPubShared' p384 e1+ (k2, c2) <- ML.encapsulate e2+ return $ Just (GroupPubB_P384MLKEM1024 (c1, c2), k1 <> convert k2) dhGroupGetPubShared- :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, SharedKey))-dhGroupGetPubShared FFDHE2048 pub = getPubShared' ffdhe2048 exp2048 pub-dhGroupGetPubShared FFDHE3072 pub = getPubShared' ffdhe3072 exp3072 pub-dhGroupGetPubShared FFDHE4096 pub = getPubShared' ffdhe4096 exp4096 pub-dhGroupGetPubShared FFDHE6144 pub = getPubShared' ffdhe6144 exp6144 pub-dhGroupGetPubShared FFDHE8192 pub = getPubShared' ffdhe8192 exp8192 pub+ :: MonadRandom r => Group -> PublicNumber -> r (Maybe (PublicNumber, GroupKey))+dhGroupGetPubShared FFDHE2048 pub = getDHPubShared' ffdhe2048 exp2048 pub+dhGroupGetPubShared FFDHE3072 pub = getDHPubShared' ffdhe3072 exp3072 pub+dhGroupGetPubShared FFDHE4096 pub = getDHPubShared' ffdhe4096 exp4096 pub+dhGroupGetPubShared FFDHE6144 pub = getDHPubShared' ffdhe6144 exp6144 pub+dhGroupGetPubShared FFDHE8192 pub = getDHPubShared' ffdhe8192 exp8192 pub dhGroupGetPubShared _ _ = return Nothing -getPubShared+getECDHPubShared+ :: (MonadRandom m, EllipticCurveDH curve)+ => (Point curve -> GroupPublicB)+ -> proxy curve+ -> Point curve+ -> m (Maybe (GroupPublicB, GroupKey))+getECDHPubShared tag proxy pub = do+ mx <- maybeCryptoError <$> deriveEncrypt proxy pub+ case mx of+ Nothing -> return Nothing+ Just (p, ECC.SharedSecret s) -> return $ Just (tag p, s)++getECDHPubShared'+ :: (MonadRandom m, EllipticCurveDH curve)+ => proxy curve+ -> Point curve+ -> m (Maybe (Point curve, GroupKey))+getECDHPubShared' proxy pub = do+ mx <- maybeCryptoError <$> deriveEncrypt proxy pub+ case mx of+ Nothing -> return Nothing+ Just (p, ECC.SharedSecret s) -> return $ Just (p, s)++getDHPubShared :: MonadRandom r- => Params+ => DH.Params -> Int -> PublicNumber- -> (PublicNumber -> GroupPublic)- -> r (Maybe (GroupPublic, GroupKey))-getPubShared params expBits pub pubTag+ -> (PublicNumber -> GroupPublicB)+ -> r (Maybe (GroupPublicB, GroupKey))+getDHPubShared params expBits pub pubTag | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits- let mypub = calculatePublic params mypri- let SharedKey share = getShared params mypri pub- return $ Just (pubTag mypub, SharedSecret share)+ let mypub = DH.calculatePublic params mypri+ DH.SharedKey share = DH.getShared params mypri pub+ return $ Just (pubTag mypub, share) -getPubShared'+getDHPubShared' :: MonadRandom r- => Params+ => DH.Params -> Int -> PublicNumber- -> r (Maybe (PublicNumber, SharedKey))-getPubShared' params expBits pub+ -> r (Maybe (PublicNumber, GroupKey))+getDHPubShared' params expBits pub | not (valid params pub) = return Nothing | otherwise = do mypri <- generatePriv expBits- let share = stripLeadingZeros (getShared params mypri pub)- return $ Just (calculatePublic params mypri, SharedKey share)+ let share = stripLeadingZeros (DH.getShared params mypri pub)+ return $ Just (DH.calculatePublic params mypri, convert share) -groupGetShared :: GroupPublic -> GroupPrivate -> Maybe GroupKey-groupGetShared (GroupPub_P256 pub) (GroupPri_P256 pri) = maybeCryptoError $ deriveDecrypt p256 pub pri-groupGetShared (GroupPub_P384 pub) (GroupPri_P384 pri) = maybeCryptoError $ deriveDecrypt p384 pub pri-groupGetShared (GroupPub_P521 pub) (GroupPri_P521 pri) = maybeCryptoError $ deriveDecrypt p521 pub pri-groupGetShared (GroupPub_X255 pub) (GroupPri_X255 pri) = maybeCryptoError $ deriveDecrypt x25519 pub pri-groupGetShared (GroupPub_X448 pub) (GroupPri_X448 pri) = maybeCryptoError $ deriveDecrypt x448 pub pri-groupGetShared (GroupPub_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcShared ffdhe2048 pub pri-groupGetShared (GroupPub_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcShared ffdhe3072 pub pri-groupGetShared (GroupPub_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcShared ffdhe4096 pub pri-groupGetShared (GroupPub_FFDHE6144 pub) (GroupPri_FFDHE6144 pri) = calcShared ffdhe6144 pub pri-groupGetShared (GroupPub_FFDHE8192 pub) (GroupPri_FFDHE8192 pri) = calcShared ffdhe8192 pub pri-groupGetShared _ _ = Nothing+unwrap :: SharedSecret -> GroupKey+unwrap (ECC.SharedSecret sec) = sec -calcShared :: Params -> PublicNumber -> PrivateNumber -> Maybe SharedSecret-calcShared params pub pri- | valid params pub = Just $ SharedSecret share+groupDecapsulate :: GroupPublicB -> GroupPrivate -> Maybe GroupKey+groupDecapsulate (GroupPubB_P256 pub) (GroupPri_P256 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p256 pub pri+groupDecapsulate (GroupPubB_P384 pub) (GroupPri_P384 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p384 pub pri+groupDecapsulate (GroupPubB_P521 pub) (GroupPri_P521 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt p521 pub pri+groupDecapsulate (GroupPubB_X255 pub) (GroupPri_X255 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x25519 pub pri+groupDecapsulate (GroupPubB_X448 pub) (GroupPri_X448 pri) = (unwrap <$>) . maybeCryptoError $ deriveDecrypt x448 pub pri+groupDecapsulate (GroupPubB_FFDHE2048 pub) (GroupPri_FFDHE2048 pri) = calcDHShared ffdhe2048 pub pri+groupDecapsulate (GroupPubB_FFDHE3072 pub) (GroupPri_FFDHE3072 pri) = calcDHShared ffdhe3072 pub pri+groupDecapsulate (GroupPubB_FFDHE4096 pub) (GroupPri_FFDHE4096 pri) = calcDHShared ffdhe4096 pub pri+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+groupDecapsulate (GroupPubB_MLKEM768 p) (GroupPri_MLKEM768 s) =+ Just $ convert $ ML.decapsulate s p+groupDecapsulate (GroupPubB_MLKEM1024 p) (GroupPri_MLKEM1024 s) =+ Just $ convert $ ML.decapsulate 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+ 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+ 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+ return (bs1 <> bs2)+groupDecapsulate _ _ = Nothing++calcDHShared :: DH.Params -> PublicNumber -> PrivateNumber -> Maybe GroupKey+calcDHShared params pub pri+ | valid params pub = Just $ convert share | otherwise = Nothing where- SharedKey share = getShared params pri pub+ share = DH.getShared params pri pub -encodeGroupPublic :: GroupPublic -> ByteString-encodeGroupPublic (GroupPub_P256 p) = encodePoint p256 p-encodeGroupPublic (GroupPub_P384 p) = encodePoint p384 p-encodeGroupPublic (GroupPub_P521 p) = encodePoint p521 p-encodeGroupPublic (GroupPub_X255 p) = encodePoint x25519 p-encodeGroupPublic (GroupPub_X448 p) = encodePoint x448 p-encodeGroupPublic (GroupPub_FFDHE2048 p) = enc ffdhe2048 p-encodeGroupPublic (GroupPub_FFDHE3072 p) = enc ffdhe3072 p-encodeGroupPublic (GroupPub_FFDHE4096 p) = enc ffdhe4096 p-encodeGroupPublic (GroupPub_FFDHE6144 p) = enc ffdhe6144 p-encodeGroupPublic (GroupPub_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicA :: GroupPublicA -> ByteString+groupEncodePublicA (GroupPubA_P256 p) = encodePoint p256 p+groupEncodePublicA (GroupPubA_P384 p) = encodePoint p384 p+groupEncodePublicA (GroupPubA_P521 p) = encodePoint p521 p+groupEncodePublicA (GroupPubA_X255 p) = encodePoint x25519 p+groupEncodePublicA (GroupPubA_X448 p) = encodePoint x448 p+groupEncodePublicA (GroupPubA_FFDHE2048 p) = enc ffdhe2048 p+groupEncodePublicA (GroupPubA_FFDHE3072 p) = enc ffdhe3072 p+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_X25519MLKEM768 (p1, p2)) =+ ML.encode p2 <> encodePoint x25519 p1+groupEncodePublicA (GroupPubA_P256MLKEM768 (p1, p2)) =+ encodePoint p256 p1 <> ML.encode p2+groupEncodePublicA (GroupPubA_P384MLKEM1024 (p1, p2)) =+ encodePoint p384 p1 <> ML.encode p2 -enc :: Params -> PublicNumber -> ByteString-enc params (PublicNumber p) = i2ospOf_ ((params_bits params + 7) `div` 8) p+groupEncodePublicB :: GroupPublicB -> ByteString+groupEncodePublicB (GroupPubB_P256 p) = encodePoint p256 p+groupEncodePublicB (GroupPubB_P384 p) = encodePoint p384 p+groupEncodePublicB (GroupPubB_P521 p) = encodePoint p521 p+groupEncodePublicB (GroupPubB_X255 p) = encodePoint x25519 p+groupEncodePublicB (GroupPubB_X448 p) = encodePoint x448 p+groupEncodePublicB (GroupPubB_FFDHE2048 p) = enc ffdhe2048 p+groupEncodePublicB (GroupPubB_FFDHE3072 p) = enc ffdhe3072 p+groupEncodePublicB (GroupPubB_FFDHE4096 p) = enc ffdhe4096 p+groupEncodePublicB (GroupPubB_FFDHE6144 p) = enc ffdhe6144 p+groupEncodePublicB (GroupPubB_FFDHE8192 p) = enc ffdhe8192 p+groupEncodePublicB (GroupPubB_MLKEM512 p) = convert p+groupEncodePublicB (GroupPubB_MLKEM768 p) = convert p+groupEncodePublicB (GroupPubB_MLKEM1024 p) = convert p+groupEncodePublicB (GroupPubB_X25519MLKEM768 (p1, p2)) =+ convert p2 <> encodePoint x25519 p1+groupEncodePublicB (GroupPubB_P256MLKEM768 (p1, p2)) =+ encodePoint p256 p1 <> convert p2+groupEncodePublicB (GroupPubB_P384MLKEM1024 (p1, p2)) =+ encodePoint p384 p1 <> convert p2 -decodeGroupPublic :: Group -> ByteString -> Either CryptoError GroupPublic-decodeGroupPublic P256 bs = eitherCryptoError $ GroupPub_P256 <$> decodePoint p256 bs-decodeGroupPublic P384 bs = eitherCryptoError $ GroupPub_P384 <$> decodePoint p384 bs-decodeGroupPublic P521 bs = eitherCryptoError $ GroupPub_P521 <$> decodePoint p521 bs-decodeGroupPublic X25519 bs = eitherCryptoError $ GroupPub_X255 <$> decodePoint x25519 bs-decodeGroupPublic X448 bs = eitherCryptoError $ GroupPub_X448 <$> decodePoint x448 bs-decodeGroupPublic FFDHE2048 bs = Right . GroupPub_FFDHE2048 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE3072 bs = Right . GroupPub_FFDHE3072 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE4096 bs = Right . GroupPub_FFDHE4096 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE6144 bs = Right . GroupPub_FFDHE6144 . PublicNumber $ os2ip bs-decodeGroupPublic FFDHE8192 bs = Right . GroupPub_FFDHE8192 . PublicNumber $ os2ip bs-decodeGroupPublic _ _ = error "decodeGroupPublic"+enc :: DH.Params -> PublicNumber -> ByteString+enc params (PublicNumber p) = i2ospOf_ ((DH.params_bits params + 7) `div` 8) p +groupDecodePublicA :: Group -> ByteString -> Either CryptoError GroupPublicA+groupDecodePublicA P256 bs = eitherCryptoError $ GroupPubA_P256 <$> decodePoint p256 bs+groupDecodePublicA P384 bs = eitherCryptoError $ GroupPubA_P384 <$> decodePoint p384 bs+groupDecodePublicA P521 bs = eitherCryptoError $ GroupPubA_P521 <$> decodePoint p521 bs+groupDecodePublicA X25519 bs = eitherCryptoError $ GroupPubA_X255 <$> decodePoint x25519 bs+groupDecodePublicA X448 bs = eitherCryptoError $ GroupPubA_X448 <$> decodePoint x448 bs+groupDecodePublicA FFDHE2048 bs = Right . GroupPubA_FFDHE2048 . PublicNumber $ os2ip bs+groupDecodePublicA FFDHE3072 bs = Right . GroupPubA_FFDHE3072 . PublicNumber $ os2ip bs+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+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubA_MLKEM512 p+groupDecodePublicA MLKEM768 bs = case ML.decode mlkem768 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubA_MLKEM768 p+groupDecodePublicA MLKEM1024 bs = case ML.decode 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+ 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+ 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+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubA_P384MLKEM1024 (p2, p1)+groupDecodePublicA _ _ = error "groupDecodePublicA"++groupDecodePublicB :: Group -> ByteString -> Either CryptoError GroupPublicB+groupDecodePublicB P256 bs = eitherCryptoError $ GroupPubB_P256 <$> decodePoint p256 bs+groupDecodePublicB P384 bs = eitherCryptoError $ GroupPubB_P384 <$> decodePoint p384 bs+groupDecodePublicB P521 bs = eitherCryptoError $ GroupPubB_P521 <$> decodePoint p521 bs+groupDecodePublicB X25519 bs = eitherCryptoError $ GroupPubB_X255 <$> decodePoint x25519 bs+groupDecodePublicB X448 bs = eitherCryptoError $ GroupPubB_X448 <$> decodePoint x448 bs+groupDecodePublicB FFDHE2048 bs = Right . GroupPubB_FFDHE2048 . PublicNumber $ os2ip bs+groupDecodePublicB FFDHE3072 bs = Right . GroupPubB_FFDHE3072 . PublicNumber $ os2ip bs+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+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubB_MLKEM512 p+groupDecodePublicB MLKEM768 bs = case ML.decode mlkem768 bs of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p -> Right $ GroupPubB_MLKEM768 p+groupDecodePublicB MLKEM1024 bs = case ML.decode 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+ 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+ 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+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p1 -> case maybeCryptoError $ decodePoint p384 bs1 of+ Nothing -> Left CryptoError_PointFormatInvalid+ Just p2 -> Right $ GroupPubB_P384MLKEM1024 (p2, p1)+groupDecodePublicB _ _ = error "groupDecodePublicB"+ -- Check that group element in not in the 2-element subgroup { 1, p - 1 }. -- See RFC 7919 section 3 and NIST SP 56A rev 2 section 5.6.2.3.1.-valid :: Params -> PublicNumber -> Bool-valid (Params p _ _) (PublicNumber y) = 1 < y && y < p - 1+valid :: DH.Params -> PublicNumber -> Bool+valid (DH.Params p _ _) (PublicNumber y) = 1 < y && y < p - 1 -- strips leading zeros from the result of getShared, as required -- for DH(E) pre-main secret in SSL/TLS before version 1.3.-stripLeadingZeros :: SharedKey -> B.ScrubbedBytes-stripLeadingZeros (SharedKey sb) = snd $ B.span (== 0) sb+stripLeadingZeros :: DH.SharedKey -> ScrubbedBytes+stripLeadingZeros (DH.SharedKey sb) = snd $ BA.span (== 0) sb -- Use short exponents as optimization, see RFC 7919 section 5.2. generatePriv :: MonadRandom r => Int -> r PrivateNumber
Network/TLS/Crypto/Types.hs view
@@ -19,11 +19,19 @@ FFDHE3072, FFDHE4096, FFDHE6144,- FFDHE8192+ FFDHE8192,+ MLKEM512,+ MLKEM768,+ MLKEM1024,+ X25519MLKEM768,+ P256MLKEM768,+ P384MLKEM1024 ), availableFFGroups, availableECGroups,+ availableHybridGroups, supportedNamedGroups,+ supportedNamedGroupsTLS13, KeyExchangeSignatureAlg (..), ) where @@ -55,6 +63,18 @@ pattern FFDHE6144 = Group 259 pattern FFDHE8192 :: Group pattern FFDHE8192 = Group 260+pattern MLKEM512 :: Group+pattern MLKEM512 = Group 512+pattern MLKEM768 :: Group+pattern MLKEM768 = Group 513+pattern MLKEM1024 :: Group+pattern MLKEM1024 = Group 514+pattern X25519MLKEM768 :: Group+pattern X25519MLKEM768 = Group 4588+pattern P256MLKEM768 :: Group+pattern P256MLKEM768 = Group 4587+pattern P384MLKEM1024 :: Group+pattern P384MLKEM1024 = Group 4589 instance Show Group where show P256 = "P256"@@ -67,6 +87,12 @@ show FFDHE4096 = "FFDHE4096" show FFDHE6144 = "FFDHE6144" show FFDHE8192 = "FFDHE8192"+ show MLKEM512 = "MLKEM512"+ show MLKEM768 = "MLKEM768"+ show MLKEM1024 = "MLKEM1024"+ show X25519MLKEM768 = "X25519MLKEM768"+ show P256MLKEM768 = "P256MLKEM768"+ show P384MLKEM1024 = "P384MLKEM1024" show (Group x) = "Group " ++ show x {- FOURMOLU_ENABLE -} @@ -76,18 +102,39 @@ availableECGroups :: [Group] availableECGroups = [P256, P384, P521, X25519, X448] +availableHybridGroups :: [Group]+availableHybridGroups = [X25519MLKEM768, P256MLKEM768, P384MLKEM1024]++-- | A list for named groups. The ordering is for client preference+-- because server preference is not used in our server+-- implementation. supportedNamedGroups :: [Group] supportedNamedGroups =- [ X25519- , X448- , P256- , FFDHE2048- , FFDHE3072- , FFDHE4096- , P384- , FFDHE6144- , FFDHE8192- , P521+ [ X25519 -- 128 bits security+ , P256 -- 128 bits security+ , P384 -- 192 bits security+ , X448 -- 224 bits security+ , P521 -- 256 bits security+ -- , FFDHE2048 -- 103 bits security+ , FFDHE3072 -- 125 bits security+ , FFDHE4096 -- 150 bits security+ , FFDHE6144 -- 175 bits security+ , FFDHE8192 -- 192 bits security+ , X25519MLKEM768+ , P256MLKEM768+ , P384MLKEM1024+ , -- , MLKEM512+ MLKEM768+ , MLKEM1024+ ]++supportedNamedGroupsTLS13 :: [[Group]]+supportedNamedGroupsTLS13 =+ [ [X25519MLKEM768, P256MLKEM768, P384MLKEM1024]+ , [X25519, P256]+ , [P384, X448, P521]+ , [FFDHE2048, FFDHE3072, FFDHE4096, FFDHE6144, FFDHE8192]+ , [MLKEM768, MLKEM1024] ] -- Key-exchange signature algorithm, in close relation to ciphers
Network/TLS/Extension.hs view
@@ -443,7 +443,7 @@ ------------------------------------------------------------ -- | Server Name extension including the name type and the associated name.--- the associated name decoding is dependant of its name type.+-- the associated name decoding is dependent of its name type. -- name type = 0 : hostname newtype ServerName = ServerName [ServerNameType] deriving (Show, Eq)
+ Network/TLS/Extra/CipherCBC.hs view
@@ -0,0 +1,201 @@+module Network.TLS.Extra.CipherCBC (+ -- * TLS 1.2 CBC ciphers with PFS and SHA2+ ciphersuite_pfs_sha2_cbc,+ ciphersuite_ecdhe_sha2_cbc,+ ciphersuite_dhe_rsa_sha2_cbc,++ -- ** Individual CBC ciphers+ cipher_DHE_RSA_AES128_SHA256,+ cipher_DHE_RSA_AES256_SHA256,+ cipher_ECDHE_RSA_AES128CBC_SHA256,+ cipher_ECDHE_RSA_AES256CBC_SHA384,+ cipher_ECDHE_ECDSA_AES128CBC_SHA256,+) where++import Crypto.Cipher.AES+import Crypto.Cipher.Types hiding (Cipher, cipherName)+import Crypto.Error+-- import Crypto.System.CPU+import qualified Data.ByteString as B++import Network.TLS.Cipher+import Network.TLS.Imports+import Network.TLS.Types hiding (IV)++----------------------------------------------------------------++-- | TLS 1.2 AES CBC ciphers with DHE or ECDHE key exchange, ECDSA or RSA+-- authentication and a SHA256 or SHA2384 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_pfs_sha2_cbc :: [Cipher]+ciphersuite_pfs_sha2_cbc =+ [ cipher_ECDHE_ECDSA_AES128CBC_SHA256+ , cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_AES128CBC_SHA256+ , cipher_ECDHE_RSA_AES256CBC_SHA384+ , cipher_DHE_RSA_AES128_SHA256+ , cipher_DHE_RSA_AES256_SHA256+ ]++-- | TLS 1.2 AES CBC ciphers with ECDHE key exchange, ECDSA or RSA+-- authentication and a SHA256 or SHA2384 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_ecdhe_sha2_cbc :: [Cipher]+ciphersuite_ecdhe_sha2_cbc =+ [ cipher_ECDHE_ECDSA_AES128CBC_SHA256+ , cipher_ECDHE_ECDSA_AES256CBC_SHA384+ , cipher_ECDHE_RSA_AES128CBC_SHA256+ , cipher_ECDHE_RSA_AES256CBC_SHA384+ ]++-- | TLS 1.2 AES CBC ciphers with DHE key exchange, RSA authentication and a+-- SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+ciphersuite_dhe_rsa_sha2_cbc :: [Cipher]+ciphersuite_dhe_rsa_sha2_cbc =+ [ cipher_DHE_RSA_AES256_SHA256+ , cipher_DHE_RSA_AES128_SHA256+ ]++----------------------------------------------------------------++-- | TLS 1.2 AES128 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_DHE_RSA_AES128_SHA256 :: Cipher+cipher_DHE_RSA_AES128_SHA256 =+ Cipher+ { cipherID = 0x0067+ , cipherName = "DHE-RSA-AES128-SHA256"+ , cipherBulk = bulk_aes128+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_DHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++-- | TLS 1.2 AES256 CBC, with DHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_DHE_RSA_AES256_SHA256 :: Cipher+cipher_DHE_RSA_AES256_SHA256 =+ cipher_DHE_RSA_AES128_SHA256+ { cipherID = 0x006B+ , cipherName = "DHE-RSA-AES256-SHA256"+ , cipherBulk = bulk_aes256+ }++-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, RSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_RSA_AES128CBC_SHA256 :: Cipher+cipher_ECDHE_RSA_AES128CBC_SHA256 =+ Cipher+ { cipherID = 0xC027+ , cipherName = "ECDHE-RSA-AES128CBC-SHA256"+ , cipherBulk = bulk_aes128+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, RSA authentication and a SHA384 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_RSA_AES256CBC_SHA384 :: Cipher+cipher_ECDHE_RSA_AES256CBC_SHA384 =+ Cipher+ { cipherID = 0xC028+ , cipherName = "ECDHE-RSA-AES256CBC-SHA384"+ , cipherBulk = bulk_aes256+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+ , cipherMinVer = Just TLS12 -- RFC 5288 Sec 4+ }++-- | TLS 1.2 AES128 CBC, with ECDHE key exchange, ECDSA authentication and a SHA256 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_ECDSA_AES128CBC_SHA256 :: Cipher+cipher_ECDHE_ECDSA_AES128CBC_SHA256 =+ Cipher+ { cipherID = 0xc023+ , cipherName = "ECDHE-ECDSA-AES128CBC-SHA256"+ , cipherBulk = bulk_aes128+ , cipherHash = SHA256+ , cipherPRFHash = Just SHA256+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 5289+ }++-- | TLS 1.2 AES256 CBC, with ECDHE key exchange, ECDSA authentication and a SHA384 MAC.+-- For legacy applications only, deprecated in HTTPS.+cipher_ECDHE_ECDSA_AES256CBC_SHA384 :: Cipher+cipher_ECDHE_ECDSA_AES256CBC_SHA384 =+ Cipher+ { cipherID = 0xC024+ , cipherName = "ECDHE-ECDSA-AES256CBC-SHA384"+ , cipherBulk = bulk_aes256+ , cipherHash = SHA384+ , cipherPRFHash = Just SHA384+ , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+ , cipherMinVer = Just TLS12 -- RFC 5289+ }++----------------------------------------------------------------++aes128cbc :: BulkDirection -> BulkKey -> BulkBlock+aes128cbc BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \iv input ->+ let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)+ )+aes128cbc BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES128+ in ( \iv input ->+ let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)+ )++aes256cbc :: BulkDirection -> BulkKey -> BulkBlock+aes256cbc BulkEncrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \iv input ->+ let output = cbcEncrypt ctx (makeIV_ iv) input in (output, takelast 16 output)+ )+aes256cbc BulkDecrypt key =+ let ctx = noFail (cipherInit key) :: AES256+ in ( \iv input ->+ let output = cbcDecrypt ctx (makeIV_ iv) input in (output, takelast 16 input)+ )++makeIV_ :: BlockCipher a => B.ByteString -> IV a+makeIV_ = fromMaybe (error "makeIV_") . makeIV++takelast :: Int -> B.ByteString -> B.ByteString+takelast i b = B.drop (B.length b - i) b++noFail :: CryptoFailable a -> a+noFail = throwCryptoError++----------------------------------------------------------------++bulk_aes128 :: Bulk+bulk_aes128 =+ Bulk+ { bulkName = "AES128"+ , bulkKeySize = 16+ , bulkIVSize = 16+ , bulkExplicitIV = 0+ , bulkAuthTagLen = 0+ , bulkBlockSize = 16+ , bulkF = BulkBlockF aes128cbc+ }++bulk_aes256 :: Bulk+bulk_aes256 =+ Bulk+ { bulkName = "AES256"+ , bulkKeySize = 32+ , bulkIVSize = 16+ , bulkExplicitIV = 0+ , bulkAuthTagLen = 0+ , bulkBlockSize = 16+ , bulkF = BulkBlockF aes256cbc+ }
Network/TLS/Handshake/Certificate.hs view
@@ -3,13 +3,20 @@ badCertificate, rejectOnException, verifyLeafKeyUsage,+ verifyLeafKeyUsagePurpose, extractCAname, ) where import Control.Exception (SomeException) import Control.Monad (unless) import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsage (..), ExtKeyUsageFlag, extensionGet)+import Data.X509 (+ ExtExtendedKeyUsage (..),+ ExtKeyUsage (..),+ ExtKeyUsageFlag,+ ExtKeyUsagePurpose (..),+ extensionGet,+ ) import Network.TLS.Context.Internal import Network.TLS.Struct@@ -46,6 +53,19 @@ case extensionGet (certExtensions cert) of Nothing -> True -- unrestricted cert Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags++verifyLeafKeyUsagePurpose+ :: MonadIO m => ExtKeyUsagePurpose -> CertificateChain -> m ()+verifyLeafKeyUsagePurpose _ (CertificateChain []) = return ()+verifyLeafKeyUsagePurpose validPurpose (CertificateChain (signed : _)) =+ unless verified $+ badCertificate $+ "certificate is not allowed for " ++ show validPurpose+ where+ cert = getCertificate signed+ verified = case extensionGet (certExtensions cert) of+ Nothing -> True+ Just (ExtExtendedKeyUsage purposes) -> validPurpose `elem` purposes extractCAname :: SignedCertificate -> DistinguishedName extractCAname cert = certSubjectDN $ getCertificate cert
Network/TLS/Handshake/Client.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client ( handshakeClient,@@ -39,16 +40,34 @@ -- values intertwined with response from the server. handshakeClient :: ClientParams -> Context -> IO () handshakeClient cparams ctx = do- groups <- case clientSessions cparams of- [] -> return groupsSupported+ grps <- case clientSessions cparams of+ [] ->+ return $+ Groups+ { grpsSupported = groupsSupported+ , grpsSelected = groupsSelected+ } (_, sdata) : _ -> case sessionGroup sdata of- Nothing -> return [] -- TLS 1.2 or earlier+ Nothing ->+ -- TLS 1.2 or earlier+ return $+ Groups+ { grpsSupported = groupsSupported -- for ciphers+ , grpsSelected = []+ } Just grp- | grp `elem` groupsSupported -> return $ grp : filter (/= grp) groupsSupported+ | grp `elem` groupsSupported -> do+ let supported = grp : filter (/= grp) groupsSupported+ return $+ Groups+ { grpsSupported = supported+ , grpsSelected = [grp]+ } | otherwise -> throwCore $ Error_Misc "groupsSupported is incorrect"- handshake cparams ctx groups Nothing+ handshake cparams ctx grps Nothing where groupsSupported = supportedGroups (ctxSupported ctx)+ groupsSelected = onSelectKeyShareGroups (clientHooks cparams) groupsSupported -- https://tools.ietf.org/html/rfc8446#section-4.1.2 says: -- "The client will also send a@@ -60,10 +79,10 @@ handshake :: ClientParams -> Context- -> [Group]+ -> Groups -> Maybe (ClientRandom, Session, Version) -> IO ()-handshake cparams ctx groups mparams = do+handshake cparams ctx grps@Groups{..} mparams = do -------------------------------- -- Sending ClientHello pskinfo@(_, _, rtt0) <- getPreSharedKeyInfo cparams ctx@@ -71,21 +90,21 @@ let async = rtt0 && not (ctxQUICMode ctx) when async $ do chSentTime <- getCurrentTimeFromBase- asyncServerHello13 cparams ctx groupToSend chSentTime+ asyncServerHello13 cparams ctx grpsSelected chSentTime updateMeasure ctx incrementNbHandshakes- crand <- sendClientHello cparams ctx groups mparams pskinfo+ crand <-+ sendClientHello cparams ctx grps mparams pskinfo -------------------------------- -- Receiving ServerHello unless async $ do (ver, hbs, hrr) <- receiveServerHello cparams ctx mparams- -------------------------------- -- Switching to HRR, TLS 1.2 or TLS 1.3 case ver of TLS13 | hrr ->- helloRetry cparams ctx mparams ver crand $ drop 1 groups+ helloRetry cparams ctx mparams ver crand grpsSupported grpsSelected | otherwise -> do- recvServerSecondFlight13 cparams ctx groupToSend+ recvServerSecondFlight13 cparams ctx grpsSelected sendClientSecondFlight13 cparams ctx _ | rtt0 ->@@ -97,8 +116,6 @@ recvServerFirstFlight12 cparams ctx hbs sendClientSecondFlight12 cparams ctx recvServerSecondFlight12 cparams ctx- where- groupToSend = listToMaybe groups ---------------------------------------------------------------- @@ -109,24 +126,46 @@ -> Version -> ClientRandom -> [Group]+ -> [Group] -> IO ()-helloRetry cparams ctx mparams ver crand groups = do- when (null groups) $+helloRetry cparams ctx mparams ver crand groupsSupported groupsSelected = do+ when (null groupsSupported) $ throwCore $- Error_Protocol "group is exhausted in the client side" IllegalParameter+ Error_Protocol "no supported groups on the client side" IllegalParameter when (isJust mparams) $ throwCore $ Error_Protocol "server sent too many hello retries" UnexpectedMessage mks <- usingState_ ctx getTLS13KeyShare case mks of Just (KeyShareHRR selectedGroup)- | selectedGroup `elem` groups -> do+ -- RFC 8446 Sec 4.1.4: the selected_group MUST be in supported_groups+ -- and MUST NOT already have been offered in the initial key_share.+ | selectedGroup `elem` groupsSupported+ && selectedGroup `notElem` groupsSelected -> do usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest clearTxRecordState ctx let cparams' = cparams{clientUseEarlyData = False} runPacketFlight ctx $ sendChangeCipherSpec13 ctx clientSession <- tls13stSession <$> getTLS13State ctx- handshake cparams' ctx [selectedGroup] (Just (crand, clientSession, ver))+ -- RFC 8446 Sec 4.1.2: the second ClientHello MUST be identical+ -- to the first except for the specific listed changes.+ -- supported_groups is NOT on that list, so it must be unchanged.+ let grps =+ Groups+ { grpsSupported = groupsSupported+ , grpsSelected = [selectedGroup]+ }++ handshake+ cparams'+ ctx+ grps+ (Just (crand, clientSession, ver))+ | selectedGroup `elem` groupsSelected ->+ throwCore $+ Error_Protocol+ "server selected a group already offered in key_share"+ IllegalParameter | otherwise -> throwCore $ Error_Protocol "server-selected group is not supported" IllegalParameter
Network/TLS/Handshake/Client/ClientHello.hs view
@@ -5,10 +5,13 @@ module Network.TLS.Handshake.Client.ClientHello ( sendClientHello, getPreSharedKeyInfo,+ Groups (..), ) where import qualified Control.Exception as E-import Crypto.HPKE+import Crypto.HPKE hiding (CipherText, PlainText)+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.ECH.Config import System.Random@@ -41,16 +44,26 @@ ---------------------------------------------------------------- +data Groups = Groups+ { grpsSupported :: [Group]+ -- ^ For supported_group, head is identical to key_share+ , grpsSelected :: [Group]+ -- ^ For key_share+ }+ deriving (Eq, Show)++----------------------------------------------------------------+ sendClientHello :: ClientParams -> Context- -> [Group]+ -> Groups -> Maybe (ClientRandom, Session, Version) -> PreSharedKeyInfo -> IO ClientRandom-sendClientHello cparams ctx groups mparams pskinfo = do+sendClientHello cparams ctx grps mparams pskinfo = do crand <- generateClientHelloParams mparams -- Inner for ECH- sendClientHello' cparams ctx groups crand pskinfo+ sendClientHello' cparams ctx grps crand pskinfo return crand where highestVer = maximum $ supportedVersions $ ctxSupported ctx@@ -89,14 +102,14 @@ sendClientHello' :: ClientParams -> Context- -> [Group]+ -> Groups -> ClientRandom -> ( Maybe ([ByteString], SessionData, CipherChoice, Word32) , Maybe CipherChoice , Bool ) -> IO ()-sendClientHello' cparams ctx groups crand (pskInfo, rtt0info, rtt0) = do+sendClientHello' cparams ctx Groups{..} crand (pskInfo, rtt0info, rtt0) = do let ver = if tls13 then TLS12 else highestVer clientSession <- tls13stSession <$> getTLS13State ctx hrr <- usingState_ ctx getTLS13HRR@@ -169,7 +182,6 @@ highestVer = maximum $ supportedVersions $ ctxSupported ctx tls13 = highestVer >= TLS13 ems = supportedExtendedMainSecret $ ctxSupported ctx- groupToSend = listToMaybe groups -- List of extensions to send in ClientHello, ordered such that we never -- terminate with a zero-length extension. Some buggy implementations@@ -211,11 +223,10 @@ return $ Just $ toExtensionRaw $ ServerName [ServerNameHostName sni] else return Nothing - groupExt =- return $- Just $- toExtensionRaw $- SupportedGroups (supportedGroups $ ctxSupported ctx)+ -- RFC 8446 Sec 4.2.8 says: Each KeyShareEntry value MUST correspond+ -- to a group offered in the "supported_groups" extension and MUST+ -- appear in the same order.+ groupExt = return $ Just $ toExtensionRaw $ SupportedGroups grpsSupported ecPointExt = return $@@ -251,11 +262,12 @@ Nothing -> return Nothing Just siz -> return $ Just $ toExtensionRaw $ RecordSizeLimit $ fromIntegral siz - sessionTicketExt = do+ sessionTicketExt = case clientSessions cparams of (sidOrTkt, _) : _ | isTicket sidOrTkt -> return $ Just $ toExtensionRaw $ SessionTicket sidOrTkt- _ -> return $ Just $ toExtensionRaw $ SessionTicket ""+ _ | clientWantTicket cparams -> return $ Just $ toExtensionRaw $ SessionTicket ""+ | otherwise -> return $ Nothing earlyDataExt | rtt0 = return $ Just $ toExtensionRaw (EarlyDataIndication Nothing)@@ -289,14 +301,11 @@ | tls13 = return $ Just $ toExtensionRaw PostHandshakeAuth | otherwise = return Nothing - -- FIXME keyShareExt- | tls13 = case groupToSend of- Nothing -> return Nothing- Just grp -> do- (cpri, ent) <- makeClientKeyShare ctx grp- usingHState ctx $ setGroupPrivate cpri- return $ Just $ toExtensionRaw $ KeyShareClientHello [ent]+ | tls13 = do+ (grpCpris, ents) <- unzip <$> mapM (makeClientKeyShare ctx) grpsSelected+ usingHState ctx $ setGroupPrivate grpCpris+ return $ Just $ toExtensionRaw $ KeyShareClientHello ents | otherwise = return Nothing secureRenegExt =@@ -319,7 +328,7 @@ pskIdentities = map (\x -> PskIdentity x obfAge) identities -- [zero] is a place holds. -- adjustPreSharedKeyExt will replace them.- binders = replicate (length pskIdentities) zero+ binders = replicate (length pskIdentities) $ convert zero offeredPsks = PreSharedKeyClientHello pskIdentities binders return $ Just $ toExtensionRaw offeredPsks @@ -329,7 +338,7 @@ Nothing -> return Nothing Just (identities, _, choice, _) -> do let zero = cZero choice- zeroR <- getStdRandom $ uniformByteString $ B.length zero+ zeroR <- getStdRandom $ uniformByteString $ BA.length zero obfAgeR <- getStdRandom genWord32 let genPskId x = do xR <- getStdRandom $ uniformByteString $ B.length x
Network/TLS/Handshake/Client/ServerHello.hs view
@@ -6,6 +6,7 @@ processServerHello13, ) where +import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Cipher@@ -245,7 +246,7 @@ when (ems /= emsSession) $ let err = "server resumes a session which is not EMS consistent" in throwCore $ Error_Protocol err HandshakeFailure- let mainSecret = sessionSecret sessionData+ let mainSecret = convert $ sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ClientRole mainSecret logKey ctx (MainSecret mainSecret)
Network/TLS/Handshake/Client/TLS12.hs view
@@ -8,6 +8,7 @@ ) where import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Cipher@@ -175,12 +176,12 @@ -------------------------------- getCKX_RSA- :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+ :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_RSA ctx = do clientVersion <- usingHState ctx $ gets hstClientVersion (xver, prerand) <- usingState_ ctx $ (,) <$> getVersion <*> genRandom 46 - let preMain = encodePreMainSecret clientVersion prerand+ let preMain = convert $ encodePreMainSecret clientVersion prerand setMainSec = setMainSecretFromPre xver ClientRole preMain encryptedPreMain <- do -- SSL3 implementation generally forget this length field since it's redundant,@@ -195,7 +196,7 @@ getCKX_DHE :: ClientParams -> Context- -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+ -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_DHE cparams ctx = do xver <- usingState_ ctx getVersion serverParams <- usingHState ctx getServerDHParams@@ -242,12 +243,12 @@ -------------------------------- getCKX_ECDHE- :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM ByteString)+ :: Context -> IO (ClientKeyXchgAlgorithmData, HandshakeM Secret) getCKX_ECDHE ctx = do ServerECDHParams grp srvpub <- usingHState ctx getServerECDHParams checkSupportedGroup ctx grp usingHState ctx $ setSupportedGroup grp- ecdhePair <- generateECDHEShared ctx srvpub+ ecdhePair <- encapsulateGroup ctx srvpub case ecdhePair of Nothing -> throwCore $@@ -255,7 +256,7 @@ Just (clipub, preMain) -> do xver <- usingState_ ctx getVersion let setMainSec = setMainSecretFromPre xver ClientRole preMain- return (CKX_ECDH $ encodeGroupPublic clipub, setMainSec)+ return (CKX_ECDH $ groupEncodePublicB clipub, setMainSec) ----------------------------------------------------------------
Network/TLS/Handshake/Client/TLS13.hs view
@@ -9,7 +9,7 @@ import Control.Exception (bracket) import Control.Monad.State.Strict-import qualified Data.ByteString as B+import qualified Data.ByteArray as BA import Data.IORef import Network.TLS.Cipher@@ -39,7 +39,7 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -recvServerSecondFlight13 :: ClientParams -> Context -> Maybe Group -> IO ()+recvServerSecondFlight13 :: ClientParams -> Context -> [Group] -> IO () recvServerSecondFlight13 cparams ctx groupSent = do resuming <- prepareSecondFlight13 ctx groupSent runRecvHandshake13 $ do@@ -50,14 +50,14 @@ ---------------------------------------------------------------- prepareSecondFlight13- :: Context -> Maybe Group -> IO Bool+ :: Context -> [Group] -> IO Bool prepareSecondFlight13 ctx groupSent = do choice <- makeCipherChoice TLS13 <$> usingHState ctx getPendingCipher prepareSecondFlight13' ctx groupSent choice prepareSecondFlight13' :: Context- -> Maybe Group+ -> [Group] -> CipherChoice -> IO Bool prepareSecondFlight13' ctx groupSent choice = do@@ -100,10 +100,10 @@ "key exchange not implemented, expected key_share extension" HandshakeFailure let grp = keyShareEntryGroup serverKeyShare- unless (checkKeyShareKeyLength serverKeyShare) $+ unless (checkServerKeyShareKeyLength serverKeyShare) $ throwCore $ Error_Protocol "broken key_share" IllegalParameter- unless (groupSent == Just grp) $+ unless (grp `elem` groupSent) $ throwCore $ Error_Protocol "received incompatible group for (EC)DHE" IllegalParameter usingHState ctx $ setSupportedGroup grp@@ -119,7 +119,7 @@ Nothing -> return (initEarlySecret choice Nothing, False) Just (PreSharedKeyServerHello 0) -> do- unless (B.length sec == hashSize) $+ unless (BA.length sec == hashSize) $ throwCore $ Error_Protocol "selected cipher is incompatible with selected PSK"@@ -403,7 +403,7 @@ ---------------------------------------------------------------- asyncServerHello13- :: ClientParams -> Context -> Maybe Group -> Millisecond -> IO ()+ :: ClientParams -> Context -> [Group] -> Millisecond -> IO () asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx
Network/TLS/Handshake/Common.hs view
@@ -42,6 +42,7 @@ import Control.Concurrent.MVar import Control.Exception (IOException, fromException, handle, throwIO) import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Cipher@@ -243,7 +244,7 @@ , sessionCipher = cipher , sessionCompression = compression , sessionClientSNI = sni- , sessionSecret = ms+ , sessionSecret = convert ms , sessionGroup = Nothing , sessionTicketInfo = Nothing , sessionALPN = alpn@@ -363,15 +364,15 @@ generateServerFinished ver cipher mainSecret thash generateFinished'- :: PRF -> ByteString -> ByteString -> TranscriptHash -> ByteString-generateFinished' prf label mainSecret (TranscriptHash thash) = prf mainSecret seed 12+ :: PRF -> ByteString -> Secret -> TranscriptHash -> ByteString+generateFinished' prf label mainSecret (TranscriptHash thash) = convert $ prf mainSecret seed 12 where seed = label <> thash generateClientFinished :: Version -> Cipher- -> ByteString+ -> Secret -> TranscriptHash -> ByteString generateClientFinished ver ciph =@@ -380,7 +381,7 @@ generateServerFinished :: Version -> Cipher- -> ByteString+ -> Secret -> TranscriptHash -> ByteString generateServerFinished ver ciph =
Network/TLS/Handshake/Common13.hs view
@@ -37,7 +37,8 @@ calculateApplicationSecret, calculateResumptionSecret, derivePSK,- checkKeyShareKeyLength,+ checkClientKeyShareKeyLength,+ checkServerKeyShareKeyLength, setRTT, computeConfirm, updateTranscriptHash13,@@ -47,7 +48,7 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict-import qualified Data.ByteArray as BA+import Data.ByteArray (convert) import qualified Data.ByteString as B import Data.UnixTime import Foreign.C.Types (CTime (..))@@ -79,7 +80,7 @@ ---------------------------------------------------------------- -makeFinished :: MonadIO m => Context -> Hash -> ByteString -> m Handshake13+makeFinished :: MonadIO m => Context -> Hash -> Secret -> m Handshake13 makeFinished ctx usedHash baseKey = do verifyData <- VerifyData . makeVerifyData usedHash baseKey@@ -89,7 +90,7 @@ checkFinished :: MonadIO m- => Context -> Hash -> ByteString -> TranscriptHash -> VerifyData -> m ()+ => Context -> Hash -> Secret -> TranscriptHash -> VerifyData -> m () checkFinished ctx usedHash baseKey (TranscriptHash hashValue) vd@(VerifyData verifyData) = do let verifyData' = makeVerifyData usedHash baseKey $ TranscriptHash hashValue when (B.length verifyData /= B.length verifyData') $@@ -98,7 +99,7 @@ unless (verifyData' == verifyData) $ decryptError "finished verification failed" liftIO $ usingState_ ctx $ setVerifyDataForRecv vd -makeVerifyData :: Hash -> ByteString -> TranscriptHash -> ByteString+makeVerifyData :: Hash -> Secret -> TranscriptHash -> ByteString makeVerifyData usedHash baseKey (TranscriptHash th) = hmac usedHash finishedKey th where@@ -107,38 +108,41 @@ ---------------------------------------------------------------- -makeServerKeyShare :: Context -> KeyShareEntry -> IO (ByteString, KeyShareEntry)+makeClientKeyShare+ :: Context -> Group -> IO ((Group, IES.GroupPrivate), KeyShareEntry)+makeClientKeyShare ctx grp = do+ (cpri, cpub) <- generateGroup ctx grp+ let wcpub = IES.groupEncodePublicA cpub+ clientKeyShare = KeyShareEntry grp wcpub+ return ((grp, cpri), clientKeyShare)++makeServerKeyShare :: Context -> KeyShareEntry -> IO (Secret, KeyShareEntry) makeServerKeyShare ctx (KeyShareEntry grp wcpub) = case ecpub of Left e -> throwCore $ Error_Protocol (show e) IllegalParameter Right cpub -> do- ecdhePair <- generateECDHEShared ctx cpub+ ecdhePair <- encapsulateGroup ctx cpub case ecdhePair of Nothing -> throwCore $ Error_Protocol msgInvalidPublic IllegalParameter Just (spub, share) ->- let wspub = IES.encodeGroupPublic spub+ let wspub = IES.groupEncodePublicB spub serverKeyShare = KeyShareEntry grp wspub- in return (BA.convert share, serverKeyShare)+ in return (share, serverKeyShare) where- ecpub = IES.decodeGroupPublic grp wcpub+ ecpub = IES.groupDecodePublicA grp wcpub msgInvalidPublic = "invalid client " ++ show grp ++ " public key" -makeClientKeyShare :: Context -> Group -> IO (IES.GroupPrivate, KeyShareEntry)-makeClientKeyShare ctx grp = do- (cpri, cpub) <- generateECDHE ctx grp- let wcpub = IES.encodeGroupPublic cpub- clientKeyShare = KeyShareEntry grp wcpub- return (cpri, clientKeyShare)--fromServerKeyShare :: KeyShareEntry -> IES.GroupPrivate -> IO ByteString-fromServerKeyShare (KeyShareEntry grp wspub) cpri = case espub of+fromServerKeyShare+ :: KeyShareEntry -> [(Group, IES.GroupPrivate)] -> IO Secret+fromServerKeyShare (KeyShareEntry grp wspub) grpCpris = case espub of Left e -> throwCore $ Error_Protocol (show e) IllegalParameter- Right spub -> case IES.groupGetShared spub cpri of- Just shared -> return $ BA.convert shared- Nothing ->- throwCore $- Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter+ Right spub -> case lookup grp grpCpris of+ Nothing -> throwCore err+ Just cpri -> case IES.groupDecapsulate spub cpri of+ Just shared -> return shared+ Nothing -> throwCore err where- espub = IES.decodeGroupPublic grp wspub+ err = Error_Protocol "cannot generate a shared secret on (EC)DH" IllegalParameter+ espub = IES.groupDecodePublicB grp wspub ---------------------------------------------------------------- @@ -468,7 +472,7 @@ let hCh = TranscriptHash $ hashChunks usedHash b let earlySecret = case maux of Right (BaseSecret sec) -> sec- Left psk -> hkdfExtract usedHash zero psk+ Left psk -> hkdfExtract usedHash zero (convert psk) clientEarlySecret = deriveSecret usedHash earlySecret "c e traffic" hCh cets = ClientTrafficSecret clientEarlySecret :: ClientTrafficSecret EarlySecret logKey ctx cets@@ -483,13 +487,13 @@ sec = hkdfExtract usedHash zero zeroOrPSK usedHash = cHash choice zero = cZero choice- zeroOrPSK = fromMaybe zero mpsk+ zeroOrPSK = fromMaybe zero (convert <$> mpsk) calculateHandshakeSecret :: Context -> CipherChoice -> BaseSecret EarlySecret- -> ByteString+ -> Secret -> IO (SecretTriple HandshakeSecret) calculateHandshakeSecret ctx choice (BaseSecret sec) ecdhe = do hChSh <- transcriptHash ctx "CH..SH"@@ -563,25 +567,60 @@ ---------------------------------------------------------------- -checkKeyShareKeyLength :: KeyShareEntry -> Bool-checkKeyShareKeyLength ks = keyShareKeyLength grp == B.length key+checkClientKeyShareKeyLength :: KeyShareEntry -> Bool+checkClientKeyShareKeyLength ks = clientKeyShareKeyLength grp == B.length key where grp = keyShareEntryGroup ks key = keyShareEntryKeyExchange ks -keyShareKeyLength :: Group -> Int-keyShareKeyLength P256 = 65 -- 32 * 2 + 1-keyShareKeyLength P384 = 97 -- 48 * 2 + 1-keyShareKeyLength P521 = 133 -- 66 * 2 + 1-keyShareKeyLength X25519 = 32-keyShareKeyLength X448 = 56-keyShareKeyLength FFDHE2048 = 256-keyShareKeyLength FFDHE3072 = 384-keyShareKeyLength FFDHE4096 = 512-keyShareKeyLength FFDHE6144 = 768-keyShareKeyLength FFDHE8192 = 1024-keyShareKeyLength _ = error "keyShareKeyLength"+{- FOURMOLU_DISABLE -}+clientKeyShareKeyLength :: Group -> Int+clientKeyShareKeyLength P256 = 65 -- 32 * 2 + 1+clientKeyShareKeyLength P384 = 97 -- 48 * 2 + 1+clientKeyShareKeyLength P521 = 133 -- 66 * 2 + 1+clientKeyShareKeyLength X25519 = 32+clientKeyShareKeyLength X448 = 56+clientKeyShareKeyLength FFDHE2048 = 256+clientKeyShareKeyLength FFDHE3072 = 384+clientKeyShareKeyLength FFDHE4096 = 512+clientKeyShareKeyLength FFDHE6144 = 768+clientKeyShareKeyLength FFDHE8192 = 1024+clientKeyShareKeyLength MLKEM512 = 800+clientKeyShareKeyLength MLKEM768 = 1184+clientKeyShareKeyLength MLKEM1024 = 1568+clientKeyShareKeyLength X25519MLKEM768 = 1216+clientKeyShareKeyLength P256MLKEM768 = 1249+clientKeyShareKeyLength P384MLKEM1024 = 1665+clientKeyShareKeyLength _ = error "clientKeyShareKeyLength"+{- FOURMOLU_ENABLE -} +checkServerKeyShareKeyLength :: KeyShareEntry -> Bool+checkServerKeyShareKeyLength ks = serverKeyShareKeyLength grp == B.length key+ where+ grp = keyShareEntryGroup ks+ key = keyShareEntryKeyExchange ks++{- FOURMOLU_DISABLE -}+serverKeyShareKeyLength :: Group -> Int+serverKeyShareKeyLength P256 = 65 -- 32 * 2 + 1+serverKeyShareKeyLength P384 = 97 -- 48 * 2 + 1+serverKeyShareKeyLength P521 = 133 -- 66 * 2 + 1+serverKeyShareKeyLength X25519 = 32+serverKeyShareKeyLength X448 = 56+serverKeyShareKeyLength FFDHE2048 = 256+serverKeyShareKeyLength FFDHE3072 = 384+serverKeyShareKeyLength FFDHE4096 = 512+serverKeyShareKeyLength FFDHE6144 = 768+serverKeyShareKeyLength FFDHE8192 = 1024+serverKeyShareKeyLength MLKEM512 = 768+serverKeyShareKeyLength MLKEM768 = 1088+serverKeyShareKeyLength MLKEM1024 = 1568+serverKeyShareKeyLength X25519MLKEM768 = 1120+serverKeyShareKeyLength P256MLKEM768 = 1153+serverKeyShareKeyLength P384MLKEM1024 = 1665+serverKeyShareKeyLength _ = error "clientKeyShareKeyLength"+{- FOURMOLU_ENABLE -}+ setRTT :: Context -> Millisecond -> IO () setRTT ctx chSentTime = do shRecvTime <- getCurrentTimeFromBase@@ -597,7 +636,7 @@ TranscriptHash echConf <- transcriptHashWith ctx "ECH acceptance" $ encodeHandshake13 $ ServerHello13 sh let prk = hkdfExtract usedHash "" $ unClientRandom chRandom- return $ hkdfExpandLabel usedHash prk label echConf 8+ return $ hkdfExpandLabel usedHash (convert prk) label echConf 8 ----------------------------------------------------------------
Network/TLS/Handshake/Key.hs view
@@ -7,8 +7,8 @@ decryptRSA, verifyPublic, generateDHE,- generateECDHE,- generateECDHEShared,+ generateGroup,+ encapsulateGroup, generateFFDHE, generateFFDHEShared, versionCompatible,@@ -20,6 +20,7 @@ ) where import Control.Monad.State.Strict+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Context.Internal@@ -35,7 +36,7 @@ {- if the RSA encryption fails we just return an empty bytestring, and let the protocol - fail by itself; however it would be probably better to just report it since it's an internal problem. -}-encryptRSA :: Context -> ByteString -> IO ByteString+encryptRSA :: Context -> Secret -> IO ByteString encryptRSA ctx content = do publicKey <- usingHState ctx getRemotePublicKey usingState_ ctx $ do@@ -53,7 +54,7 @@ Left err -> error ("sign failed: " ++ show err) Right econtent -> return econtent -decryptRSA :: Context -> ByteString -> IO (Either KxError ByteString)+decryptRSA :: Context -> ByteString -> IO (Either KxError Secret) decryptRSA ctx econtent = do (_, privateKey) <- usingHState ctx getLocalPublicPrivateKeys usingState_ ctx $ do@@ -69,12 +70,12 @@ generateDHE :: Context -> DHParams -> IO (DHPrivate, DHPublic) generateDHE ctx dhp = usingState_ ctx $ withRNG $ dhGenerateKeyPair dhp -generateECDHE :: Context -> Group -> IO (GroupPrivate, GroupPublic)-generateECDHE ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp+generateGroup :: Context -> Group -> IO (GroupPrivate, GroupPublicA)+generateGroup ctx grp = usingState_ ctx $ withRNG $ groupGenerateKeyPair grp -generateECDHEShared- :: Context -> GroupPublic -> IO (Maybe (GroupPublic, GroupKey))-generateECDHEShared ctx pub = usingState_ ctx $ withRNG $ groupGetPubShared pub+encapsulateGroup+ :: Context -> GroupPublicA -> IO (Maybe (GroupPublicB, GroupKey))+encapsulateGroup ctx pub = usingState_ ctx $ withRNG $ groupEncapsulate pub generateFFDHE :: Context -> Group -> IO (DHParams, DHPrivate, DHPublic) generateFFDHE ctx grp = usingState_ ctx $ withRNG $ dhGroupGenerateKeyPair grp@@ -144,7 +145,7 @@ ---------------------------------------------------------------- class LogLabel a where- labelAndKey :: a -> (String, ByteString)+ labelAndKey :: a -> (String, Secret) instance LogLabel MainSecret where labelAndKey (MainSecret key) = ("CLIENT_RANDOM", key)@@ -175,6 +176,7 @@ let crm = fromMaybe (hstClientRandom hst) (hstTLS13OuterClientRandom hst) cr = unClientRandom crm (label, key) = labelAndKey logkey- debugKeyLogger (ctxDebug ctx) $ label ++ " " ++ dump cr ++ " " ++ dump key+ debugKeyLogger (ctxDebug ctx) $+ label ++ " " ++ dump cr ++ " " ++ dump (convert key) where dump = init . drop 1 . showBytesHex
Network/TLS/Handshake/Server.hs view
@@ -14,6 +14,7 @@ import Network.TLS.Context.Internal import Network.TLS.Handshake.Common+import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Server.ClientHello import Network.TLS.Handshake.Server.ClientHello12 import Network.TLS.Handshake.Server.ClientHello13@@ -21,6 +22,7 @@ import Network.TLS.Handshake.Server.ServerHello13 import Network.TLS.Handshake.Server.TLS12 import Network.TLS.Handshake.Server.TLS13+import Network.TLS.Imports import Network.TLS.Struct -- Put the server context in handshake mode.@@ -43,9 +45,9 @@ -- | Put the server context in handshake mode. -- -- Expect a client hello message as parameter.--- This is useful when the client hello has been already poped from the recv layer to inspect the packet.+-- This is useful when the client hello has been already popped from the recv layer to inspect the packet. ----- When the function returns, a new handshake has been succesfully negociated.+-- When the function returns, a new handshake has been successfully negotiated. -- On any error, a HandshakeFailed exception is raised. handshake :: ServerParams -> Context -> HandshakeR -> IO () handshake sparams ctx chb@(ClientHello ch, bs) = do@@ -55,15 +57,21 @@ -- fixme: we should check if the client random is the same as -- that in the first client hello in the case of hello retry. -- r0 :: Cipher, Hash, Bool- (mClientKeyShare, r0, r1) <-+ (keyShareResult, r0, r1) <- processClientHello13 sparams ctx chI- case mClientKeyShare of- Nothing -> do- sendHRR ctx r0 chI $ isJust mcrnd+ case keyShareResult of+ SelectKeyShareNotFound ->+ throwCore $+ Error_Protocol "no group in common with the client for HRR" HandshakeFailure+ SelectKeyShareHRR g -> do+ sendHRR ctx g r0 chI $ isJust mcrnd -- Don't reset ctxEstablished since 0-RTT data- -- would be comming, which should be ignored.+ -- would be coming, which should be ignored. handshakeServer sparams ctx- Just cliKeyShare -> do+ SelectKeyShareFound cliKeyShare -> do+ unless (checkClientKeyShareKeyLength cliKeyShare) $+ throwCore $+ Error_Protocol "broken key_share" IllegalParameter -- r2 :: ( SecretTriple ApplicationSecret -- , ClientTrafficSecret HandshakeSecret -- , Bool -- authenticated
Network/TLS/Handshake/Server/ClientHello12.hs view
@@ -101,7 +101,7 @@ -- Cipher selection is performed in two steps: first server credentials -- are flagged as not suitable for signature if not compatible with- -- negotiated signature parameters. Then ciphers are evalutated from+ -- negotiated signature parameters. Then ciphers are evaluated from -- the resulting credentials. supported = serverSupported sparams
Network/TLS/Handshake/Server/ClientHello13.hs view
@@ -3,6 +3,7 @@ module Network.TLS.Handshake.Server.ClientHello13 ( processClientHello13,+ SelectKeyShareResult (..), ) where import qualified Data.ByteString as B@@ -22,13 +23,16 @@ import Network.TLS.Struct import Network.TLS.Types +limitSupportedGroups :: Int+limitSupportedGroups = 64+ -- TLS 1.3 or later processClientHello13 :: ServerParams -> Context -> ClientHello -> IO- ( Maybe KeyShareEntry+ ( SelectKeyShareResult , (Cipher, Hash, Bool) -- rtt0 , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid )@@ -72,33 +76,50 @@ extract _ = require keyShares <- lookupAndDecodeAndDo EID_KeyShare MsgTClientHello chExtensions require extract- mshare <- findKeyShare keyShares serverGroups+ let clientGroups =+ take limitSupportedGroups $+ lookupAndDecode+ EID_SupportedGroups+ MsgTClientHello+ chExtensions+ []+ (\(SupportedGroups gs) -> gs)+ (mgroup, doHRR) <-+ onSelectKeyShare+ (serverHooks sparams)+ serverGroups+ clientGroups+ $ map keyShareEntryGroup keyShares+ keyshareResult <- case mgroup of+ Nothing -> return SelectKeyShareNotFound+ Just g+ | doHRR -> return $ SelectKeyShareHRR g+ | otherwise -> case filter (\e -> keyShareEntryGroup e == g) keyShares of+ [] -> return SelectKeyShareNotFound+ [x] -> return $ SelectKeyShareFound x+ _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter+ let triple = (usedCipher, usedHash, rtt0) pskEarlySecret <- pskAndEarlySecret sparams ctx triple ch (ich, b) <- fromJust <$> usingHState ctx getClientHello updateTranscriptHash12 ctx (ClientHello ich, b)- return (mshare, triple, pskEarlySecret)+ return (keyshareResult, triple, pskEarlySecret) where ciphersFilteredVersion = intersectCiphers chCiphers serverCiphers serverCiphers = filter (cipherAllowedForVersion TLS13) (supportedCiphers $ serverSupported sparams)- serverGroups = supportedGroups (ctxSupported ctx)+ serverGroups = supportedGroupsTLS13 $ serverSupported sparams -findKeyShare :: [KeyShareEntry] -> [Group] -> IO (Maybe KeyShareEntry)-findKeyShare ks ggs = go ggs- where- go [] = return Nothing- go (g : gs) = case filter (grpEq g) ks of- [] -> go gs- [k] -> do- unless (checkKeyShareKeyLength k) $- throwCore $- Error_Protocol "broken key_share" IllegalParameter- return $ Just k- _ -> throwCore $ Error_Protocol "duplicated key_share" IllegalParameter- grpEq g ent = g == keyShareEntryGroup ent+data SelectKeyShareResult+ = -- | Negotiation failure+ SelectKeyShareNotFound+ | -- | Send a hello retry request with this group+ SelectKeyShareHRR Group+ | -- | Use this key share+ SelectKeyShareFound KeyShareEntry+ deriving (Eq, Show) pskAndEarlySecret :: ServerParams
Network/TLS/Handshake/Server/Common.hs view
@@ -15,7 +15,7 @@ ) where import Control.Monad.State.Strict-import Data.X509 (ExtKeyUsageFlag (..))+import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) import Network.TLS.Context.Internal import Network.TLS.Credentials@@ -151,7 +151,9 @@ (onClientCertificate (serverHooks sparams) certs) rejectOnException case usage of- CertificateUsageAccept -> verifyLeafKeyUsage [KeyUsage_digitalSignature] certs+ CertificateUsageAccept -> do+ verifyLeafKeyUsage [KeyUsage_digitalSignature] certs+ verifyLeafKeyUsagePurpose KeyUsagePurpose_ClientAuth certs CertificateUsageReject reason -> certificateRejected reason -- Remember cert chain for later use.
Network/TLS/Handshake/Server/ServerHello12.hs view
@@ -5,6 +5,8 @@ sendServerHello12, ) where +import Data.ByteArray (convert)+ import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal@@ -51,7 +53,7 @@ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession sendPacket12 ctx $ Handshake [ServerHello sh] []- let mainSecret = sessionSecret sessionData+ let mainSecret = convert $ sessionSecret sessionData usingHState ctx $ setMainSecret TLS12 ServerRole mainSecret logKey ctx $ MainSecret mainSecret sendCCSandFinished ctx ServerRole@@ -91,7 +93,7 @@ | TLS12 < sessionVersion sd = return Nothing -- fixme | CipherId (sessionCipher sd) `notElem` ciphers = throwCore $- Error_Protocol "new cipher is diffrent from the old one" IllegalParameter+ Error_Protocol "new cipher is different from the old one" IllegalParameter | isJust sni && sessionClientSNI sd /= sni = do usingState_ ctx clearClientSNI return Nothing@@ -202,10 +204,10 @@ setup_ECDHE grp = do usingHState ctx $ setSupportedGroup grp- (srvpri, srvpub) <- generateECDHE ctx grp+ (srvpri, srvpub) <- generateGroup ctx grp let serverParams = ServerECDHParams grp srvpub usingHState ctx $ setServerECDHParams serverParams- usingHState ctx $ setGroupPrivate srvpri+ usingHState ctx $ setGroupPrivate [(grp, srvpri)] return serverParams generateSKX_ECDHE kxsAlg = do
Network/TLS/Handshake/Server/ServerHello13.hs view
@@ -313,34 +313,19 @@ ---------------------------------------------------------------- -sendHRR :: Context -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()-sendHRR ctx (usedCipher, usedHash, _) CH{..} isEch = do+sendHRR :: Context -> Group -> (Cipher, Hash, c) -> ClientHello -> Bool -> IO ()+sendHRR ctx g (usedCipher, usedHash, _) CH{..} isEch = do twice <- usingState_ ctx getTLS13HRR when twice $ throwCore $ Error_Protocol "Hello retry not allowed again" HandshakeFailure usingState_ ctx $ setTLS13HRR True failOnEitherError $ setServerHelloParameters13 ctx usedCipher True- let clientGroups =- lookupAndDecode- EID_SupportedGroups- MsgTClientHello- chExtensions- []- (\(SupportedGroups gs) -> gs)- possibleGroups = serverGroups `intersect` clientGroups- case possibleGroups of- [] ->- throwCore $- Error_Protocol "no group in common with the client for HRR" HandshakeFailure- g : _ -> do- hrr <- makeHRR ctx usedCipher usedHash chSession g isEch- usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest- runPacketFlight ctx $ do- loadPacket13 ctx $ Handshake13 [ServerHello13 hrr] []- sendChangeCipherSpec13 ctx- where- serverGroups = supportedGroups (ctxSupported ctx)+ hrr <- makeHRR ctx usedCipher usedHash chSession g isEch+ usingHState ctx $ setTLS13HandshakeMode HelloRetryRequest+ runPacketFlight ctx $ do+ loadPacket13 ctx $ Handshake13 [ServerHello13 hrr] []+ sendChangeCipherSpec13 ctx makeHRR :: Context -> Cipher -> Hash -> Session -> Group -> Bool -> IO ServerHello
Network/TLS/Handshake/Server/TLS12.hs view
@@ -5,6 +5,7 @@ ) where import Control.Monad.State.Strict (gets)+import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Context.Internal@@ -142,10 +143,11 @@ -- BadRecordMac is nonsense but for tlsfuzzer throwCore $ Error_Protocol "invalid client public key" BadRecordMac- Right preMain -> case decodePreMainSecret preMain of- Left _ -> usingHState ctx $ setMainSecretFromPre rver role random+ Right preMain -> case decodePreMainSecret $ convert preMain of+ Left _ -> usingHState ctx $ setMainSecretFromPre rver role $ convert random Right (ver, _)- | ver /= expectedVer -> usingHState ctx $ setMainSecretFromPre rver role random+ | ver /= expectedVer ->+ usingHState ctx $ setMainSecretFromPre rver role $ convert random | otherwise -> usingHState ctx $ setMainSecretFromPre rver role preMain logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_DH clientDHValue) = do@@ -164,21 +166,23 @@ logKey ctx (MainSecret mainSecret) processClientKeyXchg ctx (CKX_ECDH bytes) = do ServerECDHParams grp _ <- usingHState ctx getServerECDHParams- case decodeGroupPublic grp bytes of+ case groupDecodePublicB grp bytes of Left _ -> throwCore $ Error_Protocol "client public key cannot be decoded" IllegalParameter Right clipub -> do- srvpri <- usingHState ctx getGroupPrivate- case groupGetShared clipub srvpri of- Just preMain -> do- rver <- usingState_ ctx getVersion- role <- usingState_ ctx getRole- mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain- logKey ctx (MainSecret mainSecret)- Nothing ->- throwCore $- Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter+ grpSpris <- usingHState ctx getGroupPrivate+ case lookup grp grpSpris of+ Nothing -> throwCore err+ Just srvpri -> case groupDecapsulate clipub srvpri of+ Just preMain -> do+ rver <- usingState_ ctx getVersion+ role <- usingState_ ctx getRole+ mainSecret <- usingHState ctx $ setMainSecretFromPre rver role preMain+ logKey ctx (MainSecret mainSecret)+ Nothing -> throwCore err+ where+ err = Error_Protocol "cannot generate a shared secret on ECDH" IllegalParameter ----------------------------------------------------------------
Network/TLS/Handshake/Server/TLS13.hs view
@@ -11,7 +11,6 @@ import Control.Exception import Control.Monad.State.Strict-import qualified Data.ByteString.Char8 as C8 import Data.IORef import Network.TLS.Cipher@@ -347,7 +346,7 @@ keyUpdate :: Context- -> (Context -> IO (Hash, Cipher, CryptLevel, C8.ByteString))+ -> (Context -> IO (Hash, Cipher, CryptLevel, Secret)) -> (Context -> Hash -> Cipher -> AnyTrafficSecret ApplicationSecret -> IO ()) -> IO () keyUpdate ctx getState setState = do@@ -370,7 +369,7 @@ TwoWay deriving (Eq, Show) --- | Updating appication traffic secrets for TLS 1.3.+-- | Updating application traffic secrets for TLS 1.3. -- If this API is called for TLS 1.3, 'True' is returned. -- Otherwise, 'False' is returned. updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool
Network/TLS/Handshake/State.hs view
@@ -81,7 +81,7 @@ ) where import Control.Monad.State.Strict-import Data.ByteArray (ByteArrayAccess)+import Data.ByteArray (convert) import Data.X509 (CertificateChain) import Network.TLS.Cipher@@ -120,12 +120,12 @@ , hstClientRandom :: ClientRandom -- ^ For ECH, inner client random. , hstServerRandom :: Maybe ServerRandom- , hstMainSecret :: Maybe ByteString+ , hstMainSecret :: Maybe Secret , hstKeyState :: HandshakeKeyState , hstServerDHParams :: Maybe ServerDHParams , hstDHPrivate :: Maybe DHPrivate , hstServerECDHParams :: Maybe ServerECDHParams- , hstGroupPrivate :: Maybe GroupPrivate+ , hstGroupPrivate :: [(Group, GroupPrivate)] , hstTransHashState :: TransHashState , hstTransHashStateI :: TransHashState -- Inner CH for client ECH , hstHandshakeMessages :: [ByteString]@@ -236,7 +236,7 @@ , hstServerDHParams = Nothing , hstDHPrivate = Nothing , hstServerECDHParams = Nothing- , hstGroupPrivate = Nothing+ , hstGroupPrivate = [] , hstTransHashState = TransHashState0 , hstTransHashStateI = TransHashState0 , hstHandshakeMessages = []@@ -303,11 +303,11 @@ getDHPrivate :: HandshakeM DHPrivate getDHPrivate = fromJust <$> gets hstDHPrivate -getGroupPrivate :: HandshakeM GroupPrivate-getGroupPrivate = fromJust <$> gets hstGroupPrivate+getGroupPrivate :: HandshakeM [(Group, GroupPrivate)]+getGroupPrivate = gets hstGroupPrivate -setGroupPrivate :: GroupPrivate -> HandshakeM ()-setGroupPrivate shp = modify' (\hst -> hst{hstGroupPrivate = Just shp})+setGroupPrivate :: [(Group, GroupPrivate)] -> HandshakeM ()+setGroupPrivate shp = modify' (\hst -> hst{hstGroupPrivate = shp}) setExtendedMainSecret :: Bool -> HandshakeM () setExtendedMainSecret b = modify' (\hst -> hst{hstExtendedMainSecret = b})@@ -463,14 +463,13 @@ -- | Generate the main secret from the pre-main secret. setMainSecretFromPre- :: ByteArrayAccess preMain- => Version+ :: Version -- ^ chosen transmission version -> Role -- ^ the role (Client or Server) of the generating side- -> preMain+ -> Secret -- ^ the pre-main secret- -> HandshakeM ByteString+ -> HandshakeM Secret setMainSecretFromPre ver role preMainSecret = do ems <- getExtendedMainSecret secret <- if ems then get >>= genExtendedSecret else genSecret <$> get@@ -499,7 +498,7 @@ -- | Set main secret and as a side effect generate the key block -- with all the right parameters, and setup the pending tx/rx state.-setMainSecret :: Version -> Role -> ByteString -> HandshakeM ()+setMainSecret :: Version -> Role -> Secret -> HandshakeM () setMainSecret ver role mainSecret = modify' $ \hst -> let (pendingTx, pendingRx) = computeKeyBlock hst mainSecret ver role in hst@@ -509,7 +508,7 @@ } computeKeyBlock- :: HandshakeState -> ByteString -> Version -> Role -> (RecordState, RecordState)+ :: HandshakeState -> Secret -> Version -> Role -> (RecordState, RecordState) computeKeyBlock hst mainSecret ver cc = (pendingTx, pendingRx) where cipher = fromJust $ hstPendingCipher hst@@ -538,13 +537,13 @@ cstClient = CryptState { cstKey = bulkInit bulk (BulkEncrypt `orOnServer` BulkDecrypt) cWriteKey- , cstIV = cWriteIV+ , cstIV = convert $ cWriteIV , cstMacSecret = cMACSecret } cstServer = CryptState { cstKey = bulkInit bulk (BulkDecrypt `orOnServer` BulkEncrypt) sWriteKey- , cstIV = sWriteIV+ , cstIV = convert $ sWriteIV , cstMacSecret = sMACSecret } msClient = MacState{msSequence = 0}
Network/TLS/Handshake/State13.hs view
@@ -31,16 +31,16 @@ import Network.TLS.Record.State import Network.TLS.Types -getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)+getTxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getTxRecordState ctx = getXState ctx ctxTxRecordState -getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, ByteString)+getRxRecordState :: Context -> IO (Hash, Cipher, CryptLevel, Secret) getRxRecordState ctx = getXState ctx ctxRxRecordState getXState :: Context -> (Context -> MVar RecordState)- -> IO (Hash, Cipher, CryptLevel, ByteString)+ -> IO (Hash, Cipher, CryptLevel, Secret) getXState ctx func = do tx <- readMVar (func ctx) let usedCipher = fromJust $ stCipher tx@@ -66,7 +66,7 @@ return $ stCryptLevel tx class TrafficSecret ty where- fromTrafficSecret :: ty -> (CryptLevel, ByteString)+ fromTrafficSecret :: ty -> (CryptLevel, Secret) instance HasCryptLevel a => TrafficSecret (AnyTrafficSecret a) where fromTrafficSecret prx@(AnyTrafficSecret s) = (getCryptLevel prx, s)@@ -103,7 +103,7 @@ -> Hash -> Cipher -> CryptLevel- -> ByteString+ -> Secret -> IO () setXState' func encOrDec ctx h cipher lvl secret = modifyMVar_ (func ctx) (\_ -> return rt)
Network/TLS/KeySchedule.hs view
@@ -8,7 +8,7 @@ import qualified Crypto.Hash as H import Crypto.KDF.HKDF-import Data.ByteArray (convert)+import Data.ByteArray (ByteArray, ByteArrayAccess, convert) import qualified Data.ByteString as BS import Network.TLS.Crypto@@ -20,7 +20,8 @@ -- | @HKDF-Extract@ function. Returns the pseudorandom key (PRK) from salt and -- input keying material (IKM).-hkdfExtract :: Hash -> ByteString -> ByteString -> ByteString+hkdfExtract+ :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ba -> ba hkdfExtract SHA1 salt ikm = convert (extract salt ikm :: PRK H.SHA1) hkdfExtract SHA256 salt ikm = convert (extract salt ikm :: PRK H.SHA256) hkdfExtract SHA384 salt ikm = convert (extract salt ikm :: PRK H.SHA384)@@ -29,7 +30,7 @@ ---------------------------------------------------------------- -deriveSecret :: Hash -> ByteString -> ByteString -> TranscriptHash -> ByteString+deriveSecret :: Hash -> Secret -> ByteString -> TranscriptHash -> Secret deriveSecret h secret label (TranscriptHash hashedMsgs) = hkdfExpandLabel h secret label hashedMsgs outlen where@@ -40,12 +41,13 @@ -- | @HKDF-Expand-Label@ function. Returns output keying material of the -- specified length from the PRK, customized for a TLS label and context. hkdfExpandLabel- :: Hash- -> ByteString+ :: (ByteArray ba, ByteArrayAccess ba)+ => Hash+ -> Secret -> ByteString -> ByteString -> Int- -> ByteString+ -> ba hkdfExpandLabel h secret label ctx outlen = expand' h secret hkdfLabel outlen where hkdfLabel = runPut $ do@@ -53,7 +55,8 @@ putOpaque8 ("tls13 " `BS.append` label) putOpaque8 ctx -expand' :: Hash -> ByteString -> ByteString -> Int -> ByteString+expand'+ :: (ByteArray ba, ByteArrayAccess ba) => Hash -> Secret -> ByteString -> Int -> ba expand' SHA1 secret label len = expand (extractSkip secret :: PRK H.SHA1) label len expand' SHA256 secret label len = expand (extractSkip secret :: PRK H.SHA256) label len expand' SHA384 secret label len = expand (extractSkip secret :: PRK H.SHA384) label len
Network/TLS/MAC.hs view
@@ -6,24 +6,25 @@ prf_SHA256, prf_TLS, prf_MD5SHA1,+ PRF, ) where -import qualified Data.ByteArray as B (xor)-import qualified Data.ByteString as B+import Data.ByteArray (ByteArray, ByteArrayAccess)+import qualified Data.ByteArray as BA import Network.TLS.Crypto import Network.TLS.Imports import Network.TLS.Types -type HMAC = ByteString -> ByteString -> ByteString+type HMAC = Secret -> ByteString -> Secret macSSL :: Hash -> HMAC macSSL alg secret msg = f $- B.concat+ BA.concat [ secret- , B.replicate padLen 0x5c- , f $ B.concat [secret, B.replicate padLen 0x36, msg]+ , BA.replicate padLen 0x5c+ , f $ BA.concat [secret, BA.replicate padLen 0x36, BA.convert msg] ] where padLen = case alg of@@ -32,49 +33,51 @@ _ -> error ("internal error: macSSL called with " ++ show alg) f = hash alg -hmac :: Hash -> HMAC-hmac alg secret msg = f $ B.append opad (f $ B.append ipad msg)+hmac :: (ByteArray ba, ByteArrayAccess ba) => Hash -> ba -> ByteString -> ba+hmac alg secret msg = f $ BA.append opad (f $ BA.append ipad $ BA.convert msg) where- opad = B.map (xor 0x5c) k'- ipad = B.map (xor 0x36) k'+ opad = BA.map (0x5c `xor`) k'+ ipad = BA.map (0x36 `xor`) k' f = hash alg bl = hashBlockSize alg - k' = B.append kt pad+ k' = BA.append kt pad where- kt = if B.length secret > fromIntegral bl then f secret else secret- pad = B.replicate (fromIntegral bl - B.length kt) 0+ kt = if BA.length secret > fromIntegral bl then f secret else secret+ pad = BA.replicate (fromIntegral bl - BA.length kt) 0 hmacIter- :: HMAC -> ByteString -> ByteString -> ByteString -> Int -> [ByteString]+ :: HMAC -> Secret -> ByteString -> ByteString -> Int -> [Secret] hmacIter f secret seed aprev len = let an = f secret aprev- in let out = f secret (B.concat [an, seed])- in let digestsize = B.length out+ in let out = f secret (BA.concat [an, BA.convert seed])+ in let digestsize = BA.length out in if digestsize >= len- then [B.take (fromIntegral len) out]- else out : hmacIter f secret seed an (len - digestsize)+ then [BA.take (fromIntegral len) out]+ else out : hmacIter f secret seed (BA.convert an) (len - digestsize) -prf_SHA1 :: ByteString -> ByteString -> Int -> ByteString-prf_SHA1 secret seed len = B.concat $ hmacIter (hmac SHA1) secret seed seed len+type PRF = Secret -> ByteString -> Int -> Secret -prf_MD5 :: ByteString -> ByteString -> Int -> ByteString-prf_MD5 secret seed len = B.concat $ hmacIter (hmac MD5) secret seed seed len+prf_SHA1 :: PRF+prf_SHA1 secret seed len = BA.concat $ hmacIter (hmac SHA1) secret seed seed len -prf_MD5SHA1 :: ByteString -> ByteString -> Int -> ByteString+prf_MD5 :: PRF+prf_MD5 secret seed len = BA.concat $ hmacIter (hmac MD5) secret seed seed len++prf_MD5SHA1 :: PRF prf_MD5SHA1 secret seed len =- B.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len)+ BA.xor (prf_MD5 s1 seed len) (prf_SHA1 s2 seed len) where- slen = B.length secret- s1 = B.take (slen `div` 2 + slen `mod` 2) secret- s2 = B.drop (slen `div` 2) secret+ slen = BA.length secret+ s1 = BA.take (slen `div` 2 + slen `mod` 2) secret+ s2 = BA.drop (slen `div` 2) secret -prf_SHA256 :: ByteString -> ByteString -> Int -> ByteString-prf_SHA256 secret seed len = B.concat $ hmacIter (hmac SHA256) secret seed seed len+prf_SHA256 :: PRF+prf_SHA256 secret seed len = BA.concat $ hmacIter (hmac SHA256) secret seed seed len -- | For now we ignore the version, but perhaps some day the PRF will depend -- not only on the cipher PRF algorithm, but also on the protocol version.-prf_TLS :: Version -> Hash -> ByteString -> ByteString -> Int -> ByteString+prf_TLS :: Version -> Hash -> PRF prf_TLS _ halg secret seed len =- B.concat $ hmacIter (hmac halg) secret seed seed len+ BA.concat $ hmacIter (hmac halg) secret seed seed len
Network/TLS/Packet.hs view
@@ -61,8 +61,7 @@ getPRF, ) where -import Data.ByteArray (ByteArrayAccess)-import qualified Data.ByteArray as B (convert)+import Data.ByteArray (ByteArrayAccess, convert) import qualified Data.ByteString as B import Data.X509 ( CertificateChain,@@ -518,7 +517,7 @@ -- ECParameters ECCurveType: curve name type grp <- Group <$> getWord16 -- ECParameters NamedCurve mxy <- getOpaque8 -- ECPoint- case decodeGroupPublic grp mxy of+ case groupDecodePublicA grp mxy of Left e -> fail $ "getServerECDHParams: " ++ show e Right grppub -> return $ ServerECDHParams grp grppub _ -> fail "getServerECDHParams: unknown type for ECDH Params"@@ -528,7 +527,7 @@ putServerECDHParams (ServerECDHParams (Group grp) grppub) = do putWord8 3 -- ECParameters ECCurveType putWord16 grp -- ECParameters NamedCurve- putOpaque8 $ encodeGroupPublic grppub -- ECPoint+ putOpaque8 $ groupEncodePublicA grppub -- ECPoint ------------------------------------------------------------ @@ -556,8 +555,6 @@ ------------------------------------------------------------ -- generate things for packet content -type PRF = ByteString -> ByteString -> Int -> ByteString- -- | The TLS12 PRF is cipher specific, and some TLS12 algorithms use SHA384 -- instead of the default SHA256. getPRF :: Version -> Cipher -> PRF@@ -567,25 +564,23 @@ | otherwise = prf_TLS ver $ fromMaybe SHA256 $ cipherPRFHash ciph generateMainSecret_TLS- :: ByteArrayAccess preMain- => PRF- -> preMain+ :: PRF+ -> Secret -> ClientRandom -> ServerRandom- -> ByteString+ -> Secret generateMainSecret_TLS prf preMainSecret (ClientRandom c) (ServerRandom s) =- prf (B.convert preMainSecret) seed 48+ prf preMainSecret seed 48 where seed = B.concat ["master secret", c, s] generateMainSecret- :: ByteArrayAccess preMain- => Version+ :: Version -> Cipher- -> preMain+ -> Secret -> ClientRandom -> ServerRandom- -> ByteString+ -> Secret generateMainSecret v c = generateMainSecret_TLS $ getPRF v c generateExtendedMainSecret@@ -594,14 +589,14 @@ -> Cipher -> preMain -> ByteString- -> ByteString+ -> Secret generateExtendedMainSecret v c preMainSecret sessionHash =- getPRF v c (B.convert preMainSecret) seed 48+ getPRF v c (convert preMainSecret) seed 48 where seed = B.append "extended master secret" sessionHash generateKeyBlock_TLS- :: PRF -> ClientRandom -> ServerRandom -> ByteString -> Int -> ByteString+ :: PRF -> ClientRandom -> ServerRandom -> Secret -> Int -> Secret generateKeyBlock_TLS prf (ClientRandom c) (ServerRandom s) mainSecret kbsize = prf mainSecret seed kbsize where@@ -612,9 +607,9 @@ -> Cipher -> ClientRandom -> ServerRandom- -> ByteString+ -> Secret -> Int- -> ByteString+ -> Secret generateKeyBlock v c = generateKeyBlock_TLS $ getPRF v c ------------------------------------------------------------
Network/TLS/Parameters.hs view
@@ -65,7 +65,7 @@ -- -- Default: 'Nothing' , debugPrintSeed :: Seed -> IO ()- -- ^ Add a way to print the seed that was randomly generated. re-using the same seed+ -- ^ Add a way to print the seed that was randomly generated. reusing the same seed -- will reproduce the same randomness with 'debugSeed' -- -- Default: no printing@@ -153,6 +153,16 @@ -- specified for TLS 1.2 but only the first entry is used. -- -- Default: '[]'+ , clientWantTicket :: Bool+ -- ^ Whether to solicit TLS 1.2 session tickets (or TLS 1.3+ -- resumption PSKs) from servers. With a 'False' setting,+ -- stateless clients that never do resumption can avoid+ -- wasting server and client resources used to generate,+ -- transmit and process tickets that will never be used.+ --+ -- Default: 'True'+ --+ -- @since 2.4.1 , clientShared :: Shared -- ^ See the default value of 'Shared'. , clientHooks :: ClientHooks@@ -192,6 +202,7 @@ , clientUseServerNameIndication = True , clientWantSessionResume = Nothing , clientWantSessionResumeList = []+ , clientWantTicket = True , clientShared = def , clientHooks = def , clientSupported = def@@ -274,7 +285,7 @@ -- the server side, the highest version that is less or equal than -- the client version will be chosen. --- -- Versions should be listed in preference order, i.e. higher+ -- Versions should be listed in preferred order, i.e. higher -- versions first. -- -- Default: @[TLS13,TLS12]@@@ -373,10 +384,23 @@ -- secure, but might help in rare cases. -- -- Default: 'True'+ , supportedHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]+ -- ^ Client only.+ --+ -- @since 2.1.9 , supportedGroups :: [Group] -- ^ A list of supported elliptic curves and finite-field groups- -- in the preferred order.+ -- in preferred order. --+ -- * TLS 1.3 client: this list is used as the 1st argument to+ -- 'onSelectKeyShareGroups' to select groups in "key_share".+ -- This list is also used as values of "supported_groups".+ -- * TLS 1.3 server: this list is not used.+ -- * TLS 1.2 client: this list is also used as values of+ -- "supported_groups".+ -- * TLS 1.2 server: this list is used to select a key exchange+ -- mechanism.+ -- -- The list is sent to the server as part of the -- "supported_groups" extension. It is used in both clients and -- servers to restrict accepted groups in DH key exchange. Up@@ -386,11 +410,18 @@ -- The default value includes all groups with security strength -- of 128 bits or more. --- -- Default: @[X25519,X448,P256,FFDHE2048,FFDHE3072,FFDHE4096,P384,FFDHE6144,FFDHE8192,P521]@- , supportedHPKE :: [(KEM_ID, KDF_ID, AEAD_ID)]- -- ^ Client only.+ -- Default: @[X25519,P256,P384,X448,P521,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192,X25519MLKEM768,P256MLKEM768,P384MLKEM1024,MLKEM768,MLKEM1024]@+ , supportedGroupsTLS13 :: [[Group]]+ -- ^ The inside @[Group]@ is the list of @Group@ at the same level+ -- in preferred order. The inside @[Group]@s are also listed in+ -- preferred order. --- -- @since 2.1.9+ -- TLS 1.3 server: this is used as the 1st argument to+ -- 'onSelectKeyShare'.+ --+ -- Default: @[[X25519MLKEM768,P256MLKEM768,P384MLKEM1024],[X25519,P256],[P384,X448,P521],[FFDHE2048,FFDHE3072,FFDHE4096,FFDHE6144,FFDHE8192],[MLKEM768,MLKEM1024]]@+ --+ -- @since 2.2.3 } deriving (Show, Eq) @@ -427,8 +458,9 @@ , supportedSession = True , supportedFallbackScsv = True , supportedEmptyPacket = True- , supportedGroups = supportedNamedGroups , supportedHPKE = defaultHPKE+ , supportedGroups = supportedNamedGroups+ , supportedGroupsTLS13 = supportedNamedGroupsTLS13 } instance Default Supported where@@ -637,11 +669,44 @@ -- (3) rejecting unless 1 < dh_p && pub < dh_p - 1 -- (4) rejecting if dh_size < 1024 (to prevent Logjam attack) --- -- See RFC 7919 section 3.1 for recommandations.+ -- See RFC 7919 section 3.1 for recommendations. , onServerFinished :: Information -> IO () -- ^ When a handshake is done, this hook can check `Information`.+ , onSelectKeyShareGroups :: [Group] -> [Group]+ -- ^ A function to select groups in "key_share" by TLS 1.3 client.+ --+ -- Client's 'supportedGroups' is passed as the 1st argument.+ --+ -- The default function specifies a pair of hybrid (classical ++ -- post quantum) group and classical group to transit from+ -- classical key exchange to hybrid key exchange. With the+ -- default value of 'supportedGroups', X25519MLKEM and X25519+ -- are chosen.+ --+ -- Middleboxes may drop a ClientHello that contains large+ -- X2219MLKEM. In such environment, @take 1@, which selects+ -- X22519 only with the default value, is maybe a good+ -- candidate.+ --+ -- In the case where X22519 is only contained in "key_share", a+ -- wise-server without nasty middleboxes may ask the client to+ -- send X2219MLKEM via HelloRetryRequest as X2219MLKEM is+ -- specified in "supported_groups".+ --+ -- @since 2.2.3 } +defaultOnSelectKeyShareGroups :: [Group] -> [Group]+defaultOnSelectKeyShareGroups groups = take 1 hs ++ take 1 es+ where+ (hs, es) = partition isHybrid groups++isHybrid :: Group -> Bool+isHybrid X25519MLKEM768 = True+isHybrid P256MLKEM768 = True+isHybrid P384MLKEM1024 = True+isHybrid _ = False+ defaultClientHooks :: ClientHooks defaultClientHooks = ClientHooks@@ -650,6 +715,7 @@ , onSuggestALPN = return Nothing , onCustomFFDHEGroup = defaultGroupUsage 1024 , onServerFinished = \_ -> return ()+ , onSelectKeyShareGroups = defaultOnSelectKeyShareGroups } instance Show ClientHooks where@@ -668,7 +734,7 @@ -- of the certificate. This verification is performed by the -- library internally. --- -- Default: returns the followings:+ -- Default: returns the following: -- -- @ -- CertificateUsageReject (CertificateRejectOther "no client certificates expected")@@ -684,7 +750,7 @@ -- client version and the client list of ciphers. -- -- This could be useful with old clients and as a workaround to- -- the BEAST (where RC4 is sometimes prefered with TLS < 1.1)+ -- the BEAST (where RC4 is sometimes preferred with TLS < 1.1) -- -- The client cipher list cannot be empty. --@@ -719,6 +785,29 @@ -- of TLS 1.3. -- -- Default: 'return'+ , onSelectKeyShare+ :: [[Group]]+ -> [Group]+ -> [Group]+ -> IO (Maybe Group, Bool)+ -- ^ A function to select one key share by TLS 1.3 server.+ --+ -- The 1st argument is server's 'supportedGroupsTLS13'.+ -- The 2nd arguments is client's groups in "supported_groups"+ -- The 3rd arguments is client's groups in "key_share".+ --+ -- 'True' in the result indicates sending a hello retry request+ -- with this group.+ --+ -- The default function targets @[Group]@ in the first argument in+ -- order. If there is a common group among the "key_share"+ -- groups, it will use that group for key exchange.+ -- Alternatively, if there is a common group among the+ -- "supported_groups" groups, it will instruct to send the+ -- HelloRetryRequest using that group. Otherwise, it will check+ -- the next @[Group]@.+ --+ -- @since 2.2.3 } -- | Default value for 'ServerHooks'@@ -737,12 +826,27 @@ , onNewHandshake = \_ -> return True , onALPNClientSuggest = Nothing , onEncryptedExtensionsCreating = return+ , onSelectKeyShare = defaultOnSelectKeyShare } instance Show ServerHooks where show _ = "ServerHooks" instance Default ServerHooks where def = defaultServerHooks++defaultOnSelectKeyShare+ :: [[Group]] -- Server groups+ -> [Group] -- Client's groups in "supported_groups"+ -> [Group] -- Client's groups in "key_share"+ -> IO (Maybe Group, Bool)+defaultOnSelectKeyShare serverSupportedLoL clientSupportedGroups clientKeyShareGroups = go serverSupportedLoL+ where+ go [] = return (Nothing, False)+ go (gs : gss) = case gs `intersect` clientKeyShareGroups of+ [] -> case gs `intersect` clientSupportedGroups of+ [] -> go gss+ h : _ -> return (Just h, True)+ g : _ -> return (Just g, False) -- | Information related to a running context, e.g. current cipher data Information = Information
Network/TLS/QUIC.hs view
@@ -116,7 +116,7 @@ { quicSend :: [(CryptLevel, ByteString)] -> IO () -- ^ Called by TLS so that QUIC sends one or more handshake fragments. The -- content transiting on this API is the plaintext of the fragments and- -- QUIC responsability is to encrypt this payload with the key material+ -- QUIC responsibility is to encrypt this payload with the key material -- given for the specified level and an appropriate encryption scheme. -- -- The size of the fragments may exceed QUIC datagram limits so QUIC may@@ -194,7 +194,7 @@ let qexts = filterQTP exts when (null qexts) $ do throwCore $- Error_Protocol "QUIC transport parameters are mssing" MissingExtension+ Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallApplicationKeys appSecInfo) @@ -222,7 +222,7 @@ let qexts = filterQTP exts when (null qexts) $ do throwCore $- Error_Protocol "QUIC transport parameters are mssing" MissingExtension+ Error_Protocol "QUIC transport parameters are missing" MissingExtension quicNotifyExtensions callbacks ctx qexts quicInstallKeys callbacks ctx (InstallEarlyKeys mEarlySecInfo) quicInstallKeys callbacks ctx (InstallHandshakeKeys handSecInfo)
Network/TLS/Record/Decrypt.hs view
@@ -6,7 +6,8 @@ import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag (..))-import qualified Data.ByteArray as B (convert, xor)+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Cipher@@ -180,11 +181,11 @@ | otherwise = B.concat [encodedSeq, encodeHeader hdr] sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq nonce- | nonceExpLen == 0 = B.xor iv sqnc+ | nonceExpLen == 0 = BA.xor iv sqnc | otherwise = iv `B.append` enonce (content, authTag2) = decryptF nonce econtent' ad - when (AuthTag (B.convert authTag) /= authTag2) $+ when (AuthTag (convert authTag) /= authTag2) $ throwError $ Error_Protocol "bad record mac on AEAD" BadRecordMac
Network/TLS/Record/Encrypt.hs view
@@ -13,7 +13,8 @@ import Control.Monad.State.Strict import Crypto.Cipher.Types (AuthTag (..))-import qualified Data.ByteArray as B (convert, xor)+import Data.ByteArray (convert)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Cipher@@ -117,12 +118,12 @@ | otherwise = B.concat [encodedSeq, encodeHeader hdr] sqnc = B.replicate (ivlen - 8) 0 `B.append` encodedSeq nonce- | nonceExpLen == 0 = B.xor iv sqnc+ | nonceExpLen == 0 = BA.xor iv sqnc | otherwise = B.concat [iv, encodedSeq] (e, AuthTag authtag) = encryptF nonce content ad econtent- | nonceExpLen == 0 = e `B.append` B.convert authtag- | otherwise = B.concat [encodedSeq, e, B.convert authtag]+ | nonceExpLen == 0 = e `B.append` convert authtag+ | otherwise = B.concat [encodedSeq, e, convert authtag] modify' incrRecordState return econtent
Network/TLS/Record/State.hs view
@@ -22,6 +22,7 @@ ) where import Control.Monad.State.Strict+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Cipher@@ -36,10 +37,10 @@ data CryptState = CryptState { cstKey :: BulkState- , cstIV :: ByteString+ , cstIV :: IV , -- In TLS 1.2 or earlier, this holds mac secret. -- In TLS 1.3, this holds application traffic secret N.- cstMacSecret :: ByteString+ cstMacSecret :: Secret } deriving (Show) @@ -130,7 +131,7 @@ { stCipher = Nothing , stCompression = nullCompression , stCryptLevel = CryptInitial- , stCryptState = CryptState BulkStateUninitialized B.empty B.empty+ , stCryptState = CryptState BulkStateUninitialized B.empty BA.empty , stMacState = MacState 0 } @@ -153,7 +154,7 @@ :: Version -> RecordState -> Header -> ByteString -> (ByteString, RecordState) computeDigest _ver tstate hdr content = (digest, incrRecordState tstate) where- digest = macF (cstMacSecret cst) msg+ digest = BA.convert $ macF (cstMacSecret cst) msg cst = stCryptState tstate cipher = fromJust $ stCipher tstate hashA = cipherHash cipher
Network/TLS/State.hs view
@@ -79,7 +79,7 @@ import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Struct-import Network.TLS.Types (HostName, Role (..), Ticket, WireBytes)+import Network.TLS.Types (HostName, Role (..), Secret, Ticket, WireBytes) import Network.TLS.Wire (GetContinuation) data TLSState = TLSState@@ -113,7 +113,7 @@ , stTLS13PreSharedKey :: Maybe PreSharedKey , stTLS13HRR :: Bool , stTLS13Cookie :: Maybe Cookie- , stTLS13ExporterSecret :: Maybe ByteString+ , stTLS13ExporterSecret :: Maybe Secret , stTLS13ClientSupportsPHA :: Bool -- Post-Handshake Authentication } @@ -337,10 +337,10 @@ getTLS12SessionTicket :: TLSSt (Maybe Ticket) getTLS12SessionTicket = gets stTLS12SessionTicket -setTLS13ExporterSecret :: ByteString -> TLSSt ()+setTLS13ExporterSecret :: Secret -> TLSSt () setTLS13ExporterSecret key = modify' (\st -> st{stTLS13ExporterSecret = Just key}) -getTLS13ExporterSecret :: TLSSt (Maybe ByteString)+getTLS13ExporterSecret :: TLSSt (Maybe Secret) getTLS13ExporterSecret = gets stTLS13ExporterSecret setTLS13KeyShare :: Maybe KeyShare -> TLSSt ()
Network/TLS/Struct.hs view
@@ -363,7 +363,7 @@ ---------------------------------------------------------------- -data ServerECDHParams = ServerECDHParams Group GroupPublic+data ServerECDHParams = ServerECDHParams Group GroupPublicA deriving (Show, Eq) ----------------------------------------------------------------
Network/TLS/Types/Cipher.hs view
@@ -4,6 +4,7 @@ module Network.TLS.Types.Cipher where import Crypto.Cipher.Types (AuthTag)+import Data.ByteArray (ScrubbedBytes) import Data.IORef import GHC.Generics import System.IO.Unsafe (unsafePerformIO)@@ -15,6 +16,16 @@ ---------------------------------------------------------------- +type PlainText = ByteString+type CipherText = ByteString+type Secret = ScrubbedBytes+type Key = ScrubbedBytes+type IV = ByteString+type Nonce = ByteString -- aka IV+type AddDat = ByteString++----------------------------------------------------------------+ -- | Cipher identification type CipherID = Word16 @@ -106,12 +117,12 @@ data BulkDirection = BulkEncrypt | BulkDecrypt deriving (Show, Eq) -type BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV)--type BulkKey = ByteString-type BulkIV = ByteString-type BulkNonce = ByteString+type BulkKey = Secret+type BulkIV = Nonce+type BulkNonce = Nonce type BulkAdditionalData = ByteString++type BulkBlock = BulkIV -> ByteString -> (ByteString, BulkIV) newtype BulkStream = BulkStream (ByteString -> (ByteString, BulkStream))
Network/TLS/Types/Secret.hs view
@@ -1,6 +1,8 @@ module Network.TLS.Types.Secret where +import Data.ByteArray (convert) import Network.TLS.Imports+import Network.TLS.Types.Cipher -- | Phantom type indicating early traffic secret. data EarlySecret@@ -13,29 +15,29 @@ data ResumptionSecret -newtype BaseSecret a = BaseSecret ByteString+newtype BaseSecret a = BaseSecret Secret instance Show (BaseSecret a) where- show (BaseSecret bs) = showBytesHex bs+ show (BaseSecret bs) = showBytesHex $ convert bs -newtype AnyTrafficSecret a = AnyTrafficSecret ByteString+newtype AnyTrafficSecret a = AnyTrafficSecret Secret instance Show (AnyTrafficSecret a) where- show (AnyTrafficSecret bs) = showBytesHex bs+ show (AnyTrafficSecret bs) = showBytesHex $ convert bs -- | A client traffic secret, typed with a parameter indicating a step in the -- TLS key schedule.-newtype ClientTrafficSecret a = ClientTrafficSecret ByteString+newtype ClientTrafficSecret a = ClientTrafficSecret Secret instance Show (ClientTrafficSecret a) where- show (ClientTrafficSecret bs) = showBytesHex bs+ show (ClientTrafficSecret bs) = showBytesHex $ convert bs -- | A server traffic secret, typed with a parameter indicating a step in the -- TLS key schedule.-newtype ServerTrafficSecret a = ServerTrafficSecret ByteString+newtype ServerTrafficSecret a = ServerTrafficSecret Secret instance Show (ServerTrafficSecret a) where- show (ServerTrafficSecret bs) = showBytesHex bs+ show (ServerTrafficSecret bs) = showBytesHex $ convert bs data SecretTriple a = SecretTriple { triBase :: BaseSecret a@@ -54,7 +56,7 @@ type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a) -- Main secret for TLS 1.2 or earlier.-newtype MainSecret = MainSecret ByteString+newtype MainSecret = MainSecret Secret instance Show MainSecret where- show (MainSecret bs) = showBytesHex bs+ show (MainSecret bs) = showBytesHex $ convert bs
Network/TLS/Types/Session.hs view
@@ -38,7 +38,8 @@ , sessionCipher :: CipherID , sessionCompression :: CompressionID , sessionClientSNI :: Maybe HostName- , sessionSecret :: ByteString+ , -- ScrubbedBytes is not an instance of Generic, sigh.+ sessionSecret :: ByteString , sessionGroup :: Maybe Group , sessionTicketInfo :: Maybe TLS13TicketInfo , sessionALPN :: Maybe ByteString
Network/TLS/Util.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Network.TLS.Util ( sub,@@ -19,6 +20,8 @@ import Control.Concurrent.MVar import Control.Exception (SomeAsyncException (..)) import qualified Control.Exception as E+import Data.ByteArray (ScrubbedBytes)+import qualified Data.ByteArray as BA import qualified Data.ByteString as B import Network.TLS.Imports@@ -46,18 +49,24 @@ (p3, _) = B.splitAt d3 r2 partition6- :: ByteString+ :: ScrubbedBytes -> (Int, Int, Int, Int, Int, Int)- -> Maybe (ByteString, ByteString, ByteString, ByteString, ByteString, ByteString)-partition6 bytes (d1, d2, d3, d4, d5, d6) = if B.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6)+ -> Maybe+ ( ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ , ScrubbedBytes+ )+partition6 bytes (d1, d2, d3, d4, d5, d6) = if BA.length bytes < s then Nothing else Just (p1, p2, p3, p4, p5, p6) where- s = sum [d1, d2, d3, d4, d5, d6]- (p1, r1) = B.splitAt d1 bytes- (p2, r2) = B.splitAt d2 r1- (p3, r3) = B.splitAt d3 r2- (p4, r4) = B.splitAt d4 r3- (p5, r5) = B.splitAt d5 r4- (p6, _) = B.splitAt d6 r5+ slice' (beg, len) = BA.unsafeSlice bytes beg len+ lens = [d1, d2, d3, d4, d5, d6]+ s = sum lens+ begs = scanl (+) 0 lens+ ys = zip begs lens+ [p1, p2, p3, p4, p5, p6] = map slice' ys -- | This is a strict version of &&. (&&!) :: Bool -> Bool -> Bool
test/Arbitrary.hs view
@@ -380,8 +380,9 @@ { supportedCiphers = serverCiphers , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg- , supportedGroups = serverGroups , supportedHashSignatures = serverHashSignatures+ , supportedGroups = serverGroups+ , supportedGroupsTLS13 = [serverGroups] } , serverShared = defaultShared{sharedCredentials = Credentials creds} }
test/CiphersSpec.hs view
@@ -1,5 +1,6 @@ module CiphersSpec where +import qualified Data.ByteArray as BA import Data.ByteString (ByteString) import qualified Data.ByteString as B import Network.TLS.Cipher@@ -52,8 +53,8 @@ decrypted `shouldBe` t at `shouldBe` at2 -arbitraryKey :: Bulk -> Gen B.ByteString-arbitraryKey bulk = B.pack `fmap` vector (bulkKeySize bulk)+arbitraryKey :: Bulk -> Gen BA.ScrubbedBytes+arbitraryKey bulk = BA.pack `fmap` vector (bulkKeySize bulk) arbitraryIV :: Bulk -> Gen B.ByteString arbitraryIV bulk = B.pack `fmap` vector (bulkIVSize bulk + bulkExplicitIV bulk)@@ -61,7 +62,8 @@ 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+data BulkTest+ = BulkTest Bulk BA.ScrubbedBytes B.ByteString B.ByteString B.ByteString deriving (Show, Eq) instance Arbitrary BulkTest where
test/ECHSpec.hs view
@@ -56,6 +56,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params = setParams@@ -75,6 +76,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params = setParams@@ -94,6 +96,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params0 = setParams@@ -126,6 +129,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params0 = setParams@@ -162,6 +166,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params0 = setParams@@ -187,6 +192,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_CCM_SHA256] , supportedGroups = [P256]+ , supportedGroupsTLS13 = [[P256]] } runTLSSimple13ECH (cli2, srv2') HelloRetryRequest@@ -202,6 +208,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } cliHooks = defaultClientHooks@@ -256,6 +263,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group0]+ , supportedGroupsTLS13 = [[group0]] } params = setParams@@ -286,6 +294,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group1]+ , supportedGroupsTLS13 = [[group1]] } params1 = ( pc{clientUseEarlyData = True}@@ -319,7 +328,11 @@ EC cgrps <- generate arbitrary EC sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps}- svrSupported = (serverSupported srv){supportedGroups = sgrps}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = sgrps+ , supportedGroupsTLS13 = [sgrps]+ } params = setParams ( cli{clientSupported = cliSupported}@@ -332,7 +345,12 @@ FFDHE cgrps <- generate arbitrary FFDHE sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps}- svrSupported = (serverSupported srv){supportedGroups = sgrps}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = sgrps+ , supportedGroupsTLS13 = [sgrps]+ }+ params = setParams ( cli{clientSupported = cliSupported}@@ -351,6 +369,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params = ( cli@@ -379,6 +398,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params = ( cli
test/HandshakeSpec.hs view
@@ -11,6 +11,7 @@ import Data.X509 (ExtKeyUsageFlag (..)) import Network.TLS import Network.TLS.Extra.Cipher+import Network.TLS.Extra.CipherCBC import Network.TLS.Internal import Test.Hspec import Test.Hspec.QuickCheck@@ -47,6 +48,7 @@ prop "can resume with extended main secret" handshake_resumption_ems prop "can handle ALPN" handshake_alpn prop "can handle SNI" handshake_sni+ prop "can handshake with TLS 1.2 CBC" handshake_cbc prop "can re-negotiate with TLS 1.2" handshake12_renegotiation prop "can resume session with TLS 1.2" handshake12_session_resumption prop "can resume session ticket with TLS 1.2" handshake12_session_ticket@@ -102,6 +104,48 @@ -------------------------------------------------------------- +handshake_cbc :: IO ()+handshake_cbc = do+ clientCiphers <- generate $ cipherGen >>= shuffle+ serverCiphers <- generate $ cipherGen >>= shuffle+ clientGroups <- generate $ groupGen >>= shuffle+ serverGroups <- generate $ groupGen >>= shuffle+ (clientParam, serverParam) <- generate $+ arbitraryPairParamsWithVersionsAndCiphers+ ([TLS12], [TLS12])+ (clientCiphers, serverCiphers)+ let clientParam' = clientParam {+ clientSupported = (clientSupported clientParam)+ { supportedGroups = clientGroups } }+ serverParam' = serverParam {+ serverSupported = (serverSupported serverParam)+ { supportedGroups = serverGroups } }+ let ciphers = clientCiphers `intersect` serverCiphers+ groups = clientGroups `intersect` serverGroups+ in if compat ciphers groups+ then runTLSSimple (clientParam', serverParam')+ else runTLSFailure (clientParam', serverParam') handshake handshake+ where+ groupGen :: Gen [Group]+ groupGen = sublistOf grps `suchThat` (not . null)+ where+ grps = [X25519, P256, P384, FFDHE2048, FFDHE3072, FFDHE4096]++ cipherGen :: Gen [Cipher]+ cipherGen = sublistOf ciphersuite_pfs_sha2_cbc `suchThat` (not . null)++ compat :: [Cipher] -> [Group] -> Bool+ compat [] _ = False+ compat _ [] = False+ compat ciphers groups =+ let mustdh = all (== CipherKeyExchange_DHE_RSA) $ map cipherKeyExchange ciphers+ mustec = all (/= CipherKeyExchange_DHE_RSA) $ map cipherKeyExchange ciphers+ havedh = any (`elem` [FFDHE2048, FFDHE3072, FFDHE4096]) groups+ haveec = any (`elem` [X25519, P256, P384]) groups+ in ((not mustdh || havedh) && (not mustec || haveec))++--------------------------------------------------------------+ handshake13_downgrade :: (ClientParams, ServerParams) -> IO () handshake13_downgrade (cparam, sparam) = do versionForced <-@@ -209,6 +253,7 @@ { serverSupported = (serverSupported serverParam) { supportedGroups = serverGroups+ , supportedGroupsTLS13 = [serverGroups] } } commonGroups = clientGroups `intersect` serverGroups@@ -258,6 +303,7 @@ { serverSupported = (serverSupported serverParam) { supportedGroups = sigGroups+ , supportedGroupsTLS13 = [sigGroups] , supportedHashSignatures = serverHashSignatures } , serverShared =@@ -680,6 +726,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params = ( cli{clientSupported = cliSupported}@@ -698,6 +745,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params = ( cli{clientSupported = cliSupported}@@ -716,6 +764,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params0 = ( cli{clientSupported = cliSupported}@@ -747,6 +796,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params0 = ( cli{clientSupported = cliSupported}@@ -782,6 +832,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } params0 = ( cli{clientSupported = cliSupported}@@ -801,11 +852,13 @@ sessionParams <- readClientSessionRef sessionRefs expectJust "session param should be Just" sessionParams let (cli2, srv2) = setPairParamsSessionResuming (fromJust sessionParams) params- srv2' = srv2{serverSupported = svrSupported'}+ srv2' =+ srv2{serverSupported = svrSupported'} svrSupported' = defaultSupported { supportedCiphers = [cipher13_AES_128_CCM_SHA256] , supportedGroups = [P256]+ , supportedGroupsTLS13 = [[P256]] } runTLSSimple13 (cli2, srv2') HelloRetryRequest@@ -821,6 +874,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [X25519]+ , supportedGroupsTLS13 = [[X25519]] } cliHooks = defaultClientHooks@@ -874,6 +928,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group0]+ , supportedGroupsTLS13 = [[group0]] } params = ( cli{clientSupported = cliSupported}@@ -903,6 +958,7 @@ defaultSupported { supportedCiphers = [cipher13_AES_128_GCM_SHA256] , supportedGroups = [group1]+ , supportedGroupsTLS13 = [[group1]] } params1 = ( pc{clientUseEarlyData = True}@@ -936,13 +992,17 @@ let -- The client prefers P256 cliSupported = (clientSupported cli){supportedGroups = [P256, X25519]} -- The server prefers X25519- svrSupported = (serverSupported srv){supportedGroups = [X25519, P256]}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = [X25519, P256]+ , supportedGroupsTLS13 = [[X25519, P256]]+ } params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported} ) (_, serverMessages) <- runTLSCapture13 params- -- The server should tell X25519 in supported_groups in EE to clinet+ -- The server should tell X25519 in supported_groups in EE to client let isSupportedGroups (ExtensionRaw eid _) = eid == EID_SupportedGroups eeMessagesHaveExt = [ any isSupportedGroups exts@@ -955,7 +1015,11 @@ EC cgrps <- generate arbitrary EC sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps}- svrSupported = (serverSupported srv){supportedGroups = sgrps}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = sgrps+ , supportedGroupsTLS13 = [sgrps]+ } params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported}@@ -967,7 +1031,11 @@ FFDHE cgrps <- generate arbitrary FFDHE sgrps <- generate arbitrary let cliSupported = (clientSupported cli){supportedGroups = cgrps}- svrSupported = (serverSupported srv){supportedGroups = sgrps}+ svrSupported =+ (serverSupported srv)+ { supportedGroups = sgrps+ , supportedGroupsTLS13 = [sgrps]+ } params = ( cli{clientSupported = cliSupported} , srv{serverSupported = svrSupported}
tls.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls-version: 2.2.2+version: 2.4.3 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez <vincent@snarc.org>@@ -34,6 +34,7 @@ Network.TLS.Internal Network.TLS.Extra Network.TLS.Extra.Cipher+ Network.TLS.Extra.CipherCBC Network.TLS.Extra.FFDHE Network.TLS.QUIC @@ -121,22 +122,23 @@ base16-bytestring, bytestring >=0.10 && <0.13, cereal >=0.5.3 && <0.6,- crypton >=0.34,+ crypton >=1.1.2 && <1.2, crypton-asn1-encoding >= 0.10.0 && < 0.11, crypton-asn1-types >= 0.4.1 && < 0.5,- crypton-x509 >=1.8 && <1.9,- crypton-x509-store >=1.8 && <1.9,- crypton-x509-validation >=1.8 && <1.9,+ crypton-x509 >=1.9 && <1.10,+ crypton-x509-store >=1.9 && <1.10,+ crypton-x509-validation >=1.9 && <1.10, data-default, ech-config,- hpke,- memory >=0.18 && <0.19,+ hpke >=0.1.0 && <0.2,+ mlkem >= 0.2.0 && <0.3, mtl >=2.2 && <2.4, network >=3.1,+ ram >=0.22.0 && <0.23, random >=1.2 && <1.4, serialise >=0.2 && <0.3, transformers >=0.5 && <0.7,- unix-time >=0.4.11 && <0.5,+ unix-time >=0.4.11 && <0.6, zlib >=0.7 && <0.8 executable tls-server@@ -230,6 +232,7 @@ crypton-x509-validation, ech-config, hspec,+ ram, serialise, time-hourglass, tls
util/Common.hs view
@@ -36,19 +36,27 @@ , ("ffdhe8192", ffdhe8192) ] +{- FOURMOLU_DISABLE -} namedGroups :: [(String, Group)] namedGroups =- [ ("ffdhe2048", FFDHE2048)- , ("ffdhe3072", FFDHE3072)- , ("ffdhe4096", FFDHE4096)- , ("ffdhe6144", FFDHE6144)- , ("ffdhe8192", FFDHE8192)- , ("p256", P256)- , ("p384", P384)- , ("p521", P521)- , ("x25519", X25519)- , ("x448", X448)+ [ ("ffdhe2048", FFDHE2048)+ , ("ffdhe3072", FFDHE3072)+ , ("ffdhe4096", FFDHE4096)+ , ("ffdhe6144", FFDHE6144)+ , ("ffdhe8192", FFDHE8192)+ , ("p256", P256)+ , ("p384", P384)+ , ("p521", P521)+ , ("x25519", X25519)+ , ("x448", X448)+ , ("mlkem512", MLKEM512)+ , ("mlkem768", MLKEM768)+ , ("mlkem1024", MLKEM1024)+ , ("x25519mlkem768", X25519MLKEM768)+ , ("p256mlkem768", P256MLKEM768)+ , ("p384mlkem1024", P384MLKEM1024) ]+{- FOURMOLU_ENABLE -} readNumber :: (Num a, Read a) => String -> Maybe a readNumber s@@ -103,7 +111,7 @@ minfo <- contextGetInformation ctx case minfo of Nothing -> do- putStrLn "Erro: information cannot be obtained"+ putStrLn "Error: information cannot be obtained" exitFailure Just info -> return info