diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,55 @@ # 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 + format. + [#515](https://github.com/haskell-tls/hs-tls/pull/515) +* Enabling compressed certificate on the client side again. + +## Version 2.2.1 + +* Disabling compressed certificate on the client side. + [#514](https://github.com/haskell-tls/hs-tls/issues/514) + +## Version 2.2.0 + +* Using crypton-asn1-* and time-hourglass. + [#512](https://github.com/haskell-tls/hs-tls/pull/512) +* Major version up due to re-exports. + ## Version 2.1.14 * Supporting P384 and P521 curves. @@ -51,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. @@ -322,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` diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -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 @@ -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'. diff --git a/Network/TLS/Compression.hs b/Network/TLS/Compression.hs --- a/Network/TLS/Compression.hs +++ b/Network/TLS/Compression.hs @@ -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 diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -112,7 +112,7 @@ getTLSCommonParams :: a -> CommonParams getTLSRole :: a -> Role doHandshake :: a -> Context -> IO () - doHandshakeWith :: a -> Context -> Handshake -> IO () + doHandshakeWith :: a -> Context -> HandshakeR -> IO () doRequestCertificate :: a -> Context -> IO Bool doPostHandshakeAuthWith :: a -> Context -> Handshake13 -> IO () diff --git a/Network/TLS/Context/Internal.hs b/Network/TLS/Context/Internal.hs --- a/Network/TLS/Context/Internal.hs +++ b/Network/TLS/Context/Internal.hs @@ -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 @@ -166,7 +168,7 @@ data RoleParams = RoleParams { doHandshake_ :: Context -> IO () - , doHandshakeWith_ :: Context -> Handshake -> IO () + , doHandshakeWith_ :: Context -> HandshakeR -> IO () , doRequestCertificate_ :: Context -> IO Bool , doPostHandshakeAuthWith_ :: Context -> Handshake13 -> IO () } @@ -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] } @@ -271,11 +273,13 @@ data PendingRecvAction = -- | simple pending action. The first 'Bool' is necessity of alignment. - -- The second bool is update transcript hash. - PendingRecvAction Bool Bool (Handshake13 -> IO ()) + PendingRecvAction Bool (Handshake13 -> IO ()) + | PendingRecvActionSelfUpdate Bool (Handshake13R -> IO ()) | -- | pending action taking transcript hash up to preceding message -- The first 'Bool' is necessity of alignment. - PendingRecvActionHash Bool (TranscriptHash -> Handshake13 -> IO ()) + PendingRecvActionHash + Bool + (TranscriptHash -> Handshake13 -> IO ()) updateMeasure :: Context -> (Measurement -> Measurement) -> IO () updateMeasure ctx = modifyIORef' (ctxMeasurement ctx) @@ -322,7 +326,7 @@ { infoVersion = v , infoCipher = c , infoCompression = comp - , infoMainSecret = ms + , infoMainSecret = convert <$> ms , infoExtendedMainSecret = ems , infoClientRandom = cr , infoServerRandom = sr diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -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 @@ -212,10 +212,10 @@ pkt <- recvPacket12 ctx either (onError terminate12) process pkt where - process (Handshake [ch@ClientHello{}]) = - handshakeWith ctx ch >> recvData12 ctx - process (Handshake [hr@HelloRequest]) = - handshakeWith ctx hr >> recvData12 ctx + process (Handshake [ch@ClientHello{}] [b]) = + handshakeWith ctx (ch, b) >> recvData12 ctx + process (Handshake [hr@HelloRequest] [b]) = + handshakeWith ctx (hr, b) >> recvData12 ctx -- UserCanceled should be followed by a close_notify. -- fixme: is it safe to call recvData12? process (Alert [(AlertLevel_Warning, UserCanceled)]) = return B.empty @@ -260,8 +260,8 @@ ("received fatal error: " ++ show desc) (Error_Protocol "remote side fatal error" desc) ) - process (Handshake13 hs) = do - loopHandshake13 hs + process (Handshake13 hs bs) = do + loopHandshake13 $ zip hs bs recvData13 ctx -- when receiving empty appdata, we just retry to get some data. process (AppData13 "") = recvData13 ctx @@ -299,7 +299,7 @@ loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment. - loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do + loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only" @@ -328,16 +328,16 @@ let ticket' = B.copy ticket void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} - loopHandshake13 hs - loopHandshake13 (KeyUpdate13 mode : hs) = do - let multipleKeyUpdate = any isKeyUpdate13 hs + loopHandshake13 hbs + loopHandshake13 ((KeyUpdate13 mode, _b) : hbs) = do + let multipleKeyUpdate = any (\(h, _) -> isKeyUpdate13 h) hbs when multipleKeyUpdate $ do let reason = "Multiple KeyUpdate is not allowed in one record" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason when (ctxQUICMode ctx) $ do let reason = "KeyUpdate is not allowed for QUIC" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason - checkAlignment ctx hs + checkAlignment ctx established <- ctxEstablished ctx -- Though RFC 8446 Sec 4.6.3 does not clearly says, -- unidirectional key update is legal. @@ -350,16 +350,16 @@ -- packet to be sent by another thread before the Tx state is -- updated. when (mode == UpdateRequested) $ withWriteLock ctx $ do - sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] + sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] [] keyUpdate ctx getTxRecordState setTxRecordState - loopHandshake13 hs + loopHandshake13 hbs else do let reason = "received key update before established" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason -- Client only - loopHandshake13 (h@CertRequest13{} : hs) = - postHandshakeAuthWith ctx h >> loopHandshake13 hs - loopHandshake13 (h : hs) = do + loopHandshake13 ((h@CertRequest13{}, _b) : hbs) = + postHandshakeAuthWith ctx h >> loopHandshake13 hbs + loopHandshake13 (hb@(h, _) : hbs) = do rtt0 <- tls13st0RTT <$> getTLS13State ctx when rtt0 $ case h of ServerHello13 SH{..} -> @@ -368,8 +368,8 @@ let reason = "HRR is not allowed for 0-RTT" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason _ -> return () - cont <- popAction ctx h hs - when cont $ loopHandshake13 hs + cont <- popAction ctx hb + when cont $ loopHandshake13 hbs recvHS13 :: Context -> IO Bool -> IO () recvHS13 ctx breakLoop = do @@ -380,8 +380,8 @@ -- UserCanceled MUST be followed by a CloseNotify. process (Alert13 [(AlertLevel_Warning, CloseNotify)]) = tryBye ctx >> setEOF ctx process (Alert13 [(AlertLevel_Fatal, _desc)]) = setEOF ctx - process (Handshake13 hs) = do - loopHandshake13 hs + process (Handshake13 hs bs) = do + loopHandshake13 $ zip hs bs stop <- breakLoop unless stop $ recvHS13 ctx breakLoop process _ = recvHS13 ctx breakLoop @@ -389,7 +389,7 @@ loopHandshake13 [] = return () -- fixme: some implementations send multiple NST at the same time. -- Only the first one is used at this moment. - loopHandshake13 (NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts : hs) = do + loopHandshake13 ((NewSessionTicket13 life add nonce (SessionIDorTicket_ ticket) exts, _b) : hbs) = do role <- usingState_ ctx S.getRole unless (role == ClientRole) $ do let reason = "Session ticket is allowed for client only" @@ -415,17 +415,17 @@ let ticket' = B.copy ticket void $ sessionEstablish (sharedSessionManager $ ctxShared ctx) ticket' sdata modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} - loopHandshake13 hs - loopHandshake13 (h : hs) = do - cont <- popAction ctx h hs - when cont $ loopHandshake13 hs + loopHandshake13 hbs + loopHandshake13 (hb : hbs) = do + cont <- popAction ctx hb + when cont $ loopHandshake13 hbs terminate13 :: Context -> TLSError -> AlertLevel -> AlertDescription -> String -> IO a terminate13 ctx = terminateWithWriteLock ctx (sendPacket13 ctx . Alert13) -popAction :: Context -> Handshake13 -> [Handshake13] -> IO Bool -popAction ctx h hs = do +popAction :: Context -> Handshake13R -> IO Bool +popAction ctx hb@(h, _b) = do mPendingRecvAction <- popPendingRecvAction ctx case mPendingRecvAction of Nothing -> return False @@ -435,14 +435,17 @@ withWriteLock ctx $ handleException ctx $ do case action of - PendingRecvAction needAligned update pa -> do - when needAligned $ checkAlignment ctx hs - when update $ void $ updateTranscriptHash13 ctx h + PendingRecvAction needAligned pa -> do + when needAligned $ checkAlignment ctx + updateTranscriptHash13 ctx hb pa h + PendingRecvActionSelfUpdate needAligned pa -> do + when needAligned $ checkAlignment ctx + pa hb PendingRecvActionHash needAligned pa -> do - when needAligned $ checkAlignment ctx hs + when needAligned $ checkAlignment ctx d <- transcriptHash ctx "Pending action" - void $ updateTranscriptHash13 ctx h + updateTranscriptHash13 ctx hb pa d h -- Client: after receiving SH, app data is coming. -- this loop tries to receive it. @@ -451,8 +454,8 @@ sendCFifNecessary ctx return True -checkAlignment :: Context -> [Handshake13] -> IO () -checkAlignment ctx _hs = do +checkAlignment :: Context -> IO () +checkAlignment ctx = do complete <- isRecvComplete ctx unless complete $ do let reason = "received message not aligned with record boundary" diff --git a/Network/TLS/Crypto.hs b/Network/TLS/Crypto.hs --- a/Network/TLS/Crypto.hs +++ b/Network/TLS/Crypto.hs @@ -7,6 +7,7 @@ HashCtx, hashInit, hashUpdate, + hashUpdates, hashUpdateSSL, hashFinal, module Network.TLS.Crypto.DH, @@ -60,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 ( @@ -77,6 +79,8 @@ import Network.TLS.Crypto.Types import Network.TLS.Imports +---------------------------------------------------------------- + {-# DEPRECATED PublicKey "use PubKey" #-} type PublicKey = PubKey {-# DEPRECATED PrivateKey "use PrivKey" #-} @@ -160,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) @@ -179,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 @@ -223,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) @@ -365,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) diff --git a/Network/TLS/Crypto/DH.hs b/Network/TLS/Crypto/DH.hs --- a/Network/TLS/Crypto/DH.hs +++ b/Network/TLS/Crypto/DH.hs @@ -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. diff --git a/Network/TLS/Crypto/IES.hs b/Network/TLS/Crypto/IES.hs --- a/Network/TLS/Crypto/IES.hs +++ b/Network/TLS/Crypto/IES.hs @@ -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 diff --git a/Network/TLS/Crypto/Types.hs b/Network/TLS/Crypto/Types.hs --- a/Network/TLS/Crypto/Types.hs +++ b/Network/TLS/Crypto/Types.hs @@ -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 diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -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) diff --git a/Network/TLS/Extra/CipherCBC.hs b/Network/TLS/Extra/CipherCBC.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/Extra/CipherCBC.hs @@ -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 + } diff --git a/Network/TLS/Handshake.hs b/Network/TLS/Handshake.hs --- a/Network/TLS/Handshake.hs +++ b/Network/TLS/Handshake.hs @@ -25,9 +25,9 @@ -- This is called automatically by 'recvData', in a context where the read lock -- is already taken. So contrary to 'handshake' above, here we only need to -- call withWriteLock. -handshakeWith :: MonadIO m => Context -> Handshake -> m () -handshakeWith ctx hs = +handshakeWith :: MonadIO m => Context -> HandshakeR -> m () +handshakeWith ctx hsr = liftIO $ withWriteLock ctx $ handleException ctx $ - doHandshakeWith_ (ctxRoleParams ctx) ctx hs + doHandshakeWith_ (ctxRoleParams ctx) ctx hsr diff --git a/Network/TLS/Handshake/Certificate.hs b/Network/TLS/Handshake/Certificate.hs --- a/Network/TLS/Handshake/Certificate.hs +++ b/Network/TLS/Handshake/Certificate.hs @@ -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 diff --git a/Network/TLS/Handshake/Client.hs b/Network/TLS/Handshake/Client.hs --- a/Network/TLS/Handshake/Client.hs +++ b/Network/TLS/Handshake/Client.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Network.TLS.Handshake.Client ( handshakeClient, @@ -26,8 +27,9 @@ ---------------------------------------------------------------- -handshakeClientWith :: ClientParams -> Context -> Handshake -> IO () -handshakeClientWith cparams ctx HelloRequest = handshakeClient cparams ctx +handshakeClientWith + :: ClientParams -> Context -> HandshakeR -> IO () +handshakeClientWith cparams ctx (HelloRequest, _b) = handshakeClient cparams ctx -- xxx handshakeClientWith _ _ _ = throwCore $ Error_Protocol @@ -38,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 @@ -59,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 @@ -70,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, hss, hrr) <- receiveServerHello cparams ctx mparams - -------------------------------- + (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 -> @@ -93,11 +113,9 @@ "server denied TLS 1.3 when connecting with early data" HandshakeFailure | otherwise -> do - recvServerFirstFlight12 cparams ctx hss + recvServerFirstFlight12 cparams ctx hbs sendClientSecondFlight12 cparams ctx recvServerSecondFlight12 cparams ctx - where - groupToSend = listToMaybe groups ---------------------------------------------------------------- @@ -108,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 diff --git a/Network/TLS/Handshake/Client/ClientHello.hs b/Network/TLS/Handshake/Client/ClientHello.hs --- a/Network/TLS/Handshake/Client/ClientHello.hs +++ b/Network/TLS/Handshake/Client/ClientHello.hs @@ -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 @@ -127,17 +140,22 @@ Nothing -> do if hrr then do - chI <- fromJust <$> usingHState ctx getClientHello + (chI, _) <- fromJust <$> usingHState ctx getClientHello let ch0' = ch0{chExtensions = take 1 (chExtensions chI) ++ drop 1 (chExtensions ch0)} - usingHState ctx $ setClientHello ch0' + -- [] will be overridden via + -- encodeUpdateTranscriptHash12 + usingHState ctx $ setClientHello ch0' [] return ch0' else do gEchExt <- greasingEchExt let ch0' = ch0{chExtensions = gEchExt : drop 1 (chExtensions ch0)} - usingHState ctx $ setClientHello ch0' + -- [] will be overridden via + -- encodeUpdateTranscriptHash12 + usingHState ctx $ setClientHello ch0' [] return ch0' Just echParams -> do - usingHState ctx $ setClientHello ch0 + let encoded = encodeHandshake $ ClientHello ch0 + usingHState ctx $ setClientHello ch0 [encoded] mcrandO <- usingHState ctx getOuterClientRandom crandO <- case mcrandO of Nothing -> clientRandom ctx @@ -148,9 +166,11 @@ mpskExt <- randomPreSharedKeyExt createEncryptedClientHello ctx ch0 echParams crandO mpskExt else do - usingHState ctx $ setClientHello ch0 + -- [] will be overridden via + -- encodeUpdateTranscriptHash12 + usingHState ctx $ setClientHello ch0 [] return ch0 - sendPacket12 ctx $ Handshake [ClientHello ch] + sendPacket12 ctx $ Handshake [ClientHello ch] [] mEarlySecInfo <- case rtt0info of Nothing -> return Nothing Just info -> Just <$> getEarlySecretInfo info @@ -162,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 @@ -204,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 $ @@ -244,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) @@ -282,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 = @@ -312,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 @@ -322,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 diff --git a/Network/TLS/Handshake/Client/ServerHello.hs b/Network/TLS/Handshake/Client/ServerHello.hs --- a/Network/TLS/Handshake/Client/ServerHello.hs +++ b/Network/TLS/Handshake/Client/ServerHello.hs @@ -6,6 +6,7 @@ processServerHello13, ) where +import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Cipher @@ -35,12 +36,12 @@ :: ClientParams -> Context -> Maybe (ClientRandom, Session, Version) - -> IO (Version, [Handshake], Bool) + -> IO (Version, [HandshakeR], Bool) receiveServerHello cparams ctx mparams = do chSentTime <- getCurrentTimeFromBase - (sh, hss) <- recvSH + (shb@(sh, _), hbs) <- recvSH processServerHello cparams ctx sh - void $ updateTranscriptHash12 ctx sh + updateTranscriptHash12 ctx shb setRTT ctx chSentTime ver <- usingState_ ctx getVersion unless (maybe True (\(_, _, v) -> v == ver) mparams) $ @@ -51,7 +52,7 @@ -- False otherwise. For 2nd server hello, getTLS13HR returns -- False since it is NOT HRR. hrr <- usingState_ ctx getTLS13HRR - return (ver, hss, hrr) + return (ver, hbs, hrr) where recvSH = do epkt <- recvPacket12 ctx @@ -59,7 +60,7 @@ Left e -> throwCore e Right pkt -> case pkt of Alert a -> throwAlert a - Handshake (h : hs) -> return (h, hs) + Handshake (h : hs) (b : bs) -> return ((h, b), zip hs bs) _ -> unexpected (show pkt) (Just "handshake") throwAlert a = throwCore $ @@ -179,7 +180,7 @@ transitTranscriptHashI ctx "transitI" usedHash isHRR accepted <- checkECHacceptance ctx isHRR usedHash sh when accepted $ do - CH{..} <- fromJust <$> usingHState ctx getClientHello + (CH{..}, _b) <- fromJust <$> usingHState ctx getClientHello usingHState ctx $ setClientRandom chRandom -- inner random when (accepted && not isHRR) $ do copyTranscriptHash ctx "copy" @@ -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) diff --git a/Network/TLS/Handshake/Client/TLS12.hs b/Network/TLS/Handshake/Client/TLS12.hs --- a/Network/TLS/Handshake/Client/TLS12.hs +++ b/Network/TLS/Handshake/Client/TLS12.hs @@ -8,6 +8,7 @@ ) where import Control.Monad.State.Strict +import Data.ByteArray (convert) import qualified Data.ByteString as B import Network.TLS.Cipher @@ -32,14 +33,15 @@ ---------------------------------------------------------------- -recvServerFirstFlight12 :: ClientParams -> Context -> [Handshake] -> IO () -recvServerFirstFlight12 cparams ctx hs = do +recvServerFirstFlight12 + :: ClientParams -> Context -> [HandshakeR] -> IO () +recvServerFirstFlight12 cparams ctx hbs = do resuming <- usingState_ ctx getTLS12SessionResuming if resuming then recvNSTandCCSandFinished ctx else do let st = RecvStateHandshake (expectCertificate cparams ctx) - runRecvStateHS ctx st hs + runRecvStateHS ctx st hbs expectCertificate :: ClientParams -> Context -> Handshake -> IO (RecvState IO) expectCertificate cparams ctx (Certificate (CertificateChain_ certs)) = do @@ -151,7 +153,7 @@ unless (null certs) $ usingHState ctx $ setClientCertSent True - sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] + sendPacket12 ctx $ Handshake [Certificate (CertificateChain_ cc)] [] ---------------------------------------------------------------- @@ -167,19 +169,19 @@ _ -> throwCore $ Error_Protocol "client key exchange unsupported type" HandshakeFailure - sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] + sendPacket12 ctx $ Handshake [ClientKeyXchg ckx] [] mainSecret <- usingHState ctx setMainSec logKey ctx (MainSecret mainSecret) -------------------------------- 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, @@ -194,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 @@ -241,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 $ @@ -254,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) ---------------------------------------------------------------- @@ -283,4 +285,4 @@ -- Fetch all handshake messages up to now. msgs <- usingHState ctx $ B.concat <$> getHandshakeMessages sigDig <- createCertificateVerify ctx ver pubKey mhashSig msgs - sendPacket12 ctx $ Handshake [CertVerify sigDig] + sendPacket12 ctx $ Handshake [CertVerify sigDig] [] diff --git a/Network/TLS/Handshake/Client/TLS13.hs b/Network/TLS/Handshake/Client/TLS13.hs --- a/Network/TLS/Handshake/Client/TLS13.hs +++ b/Network/TLS/Handshake/Client/TLS13.hs @@ -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" @@ -147,12 +147,13 @@ Nothing -> do usingHState ctx $ setTLS13HandshakeMode PreSharedKey usingHState ctx $ setTLS13RTT0Status RTT0Rejected -expectEncryptedExtensions _ p = unexpected (show p) (Just "encrypted extensions") +expectEncryptedExtensions _ h = unexpected (show h) (Just "encrypted extensions") ---------------------------------------------------------------- -- not used in 0-RTT expectCertRequest - :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () + :: MonadIO m + => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertRequest cparams ctx (CertRequest13 token exts) = do processCertRequest13 ctx token exts recvHandshake13 ctx $ expectCertAndVerify cparams ctx @@ -211,10 +212,11 @@ ---------------------------------------------------------------- -- not used in 0-RTT expectCertAndVerify - :: MonadIO m => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () + :: MonadIO m + => ClientParams -> Context -> Handshake13 -> RecvHandshake13M m () expectCertAndVerify cparams ctx (Certificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc expectCertAndVerify cparams ctx (CompressedCertificate13 _ (CertificateChain_ cc) _) = processCertAndVerify cparams ctx cc -expectCertAndVerify _ _ p = unexpected (show p) (Just "server certificate") +expectCertAndVerify _ _ h = unexpected (show h) (Just "server certificate") processCertAndVerify :: MonadIO m @@ -231,11 +233,12 @@ ---------------------------------------------------------------- expectCertVerify - :: MonadIO m => Context -> PubKey -> TranscriptHash -> Handshake13 -> m () + :: MonadIO m + => Context -> PubKey -> TranscriptHash -> Handshake13 -> m () expectCertVerify ctx pubkey (TranscriptHash hChSc) (CertVerify13 (DigitallySigned sigAlg sig)) = do ok <- checkCertVerify ctx pubkey sigAlg sig hChSc unless ok $ decryptError "cannot verify CertificateVerify" -expectCertVerify _ _ _ p = unexpected (show p) (Just "certificate verify") +expectCertVerify _ _ _ h = unexpected (show h) (Just "certificate verify") ---------------------------------------------------------------- @@ -290,7 +293,7 @@ runPacketFlight ctx $ sendChangeCipherSpec13 ctx when (rtt0accepted && not (ctxQUICMode ctx)) $ - sendPacket13 ctx (Handshake13 [EndOfEarlyData13]) + sendPacket13 ctx (Handshake13 [EndOfEarlyData13] []) let clientHandshakeSecret = triClient hkey setTxRecordState ctx usedHash usedCipher clientHandshakeSecret sendClientFlight13 cparams ctx usedHash clientHandshakeSecret @@ -344,7 +347,7 @@ certComp <- usingHState ctx getTLS13CertComp loadClientData13 cc reqtoken certComp rawFinished <- makeFinished ctx usedHash baseKey - loadPacket13 ctx $ Handshake13 [rawFinished] + loadPacket13 ctx $ Handshake13 [rawFinished] [] when (isJust mcc) $ modifyTLS13State ctx $ \st -> st{tls13stSentClientCert = True} @@ -355,7 +358,7 @@ cHashSigs = filter isHashSignatureValid13 $ supportedHashSignatures $ ctxSupported ctx let certtag = if certComp then CompressedCertificate13 else Certificate13 loadPacket13 ctx $ - Handshake13 [certtag token (CertificateChain_ chain) certExts] + Handshake13 [certtag token (CertificateChain_ chain) certExts] [] case certs of [] -> return () _ -> do @@ -364,7 +367,7 @@ sigAlg <- liftIO $ getLocalHashSigAlg ctx signatureCompatible13 cHashSigs pubKey vfy <- makeCertVerify ctx pubKey sigAlg hChSc - loadPacket13 ctx $ Handshake13 [vfy] + loadPacket13 ctx $ Handshake13 [vfy] [] -- loadClientData13 _ _ _ = throwCore $ @@ -373,10 +376,11 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -postHandshakeAuthClientWith :: ClientParams -> Context -> Handshake13 -> IO () -postHandshakeAuthClientWith cparams ctx h@(CertRequest13 certReqCtx exts) = +postHandshakeAuthClientWith + :: ClientParams -> Context -> Handshake13 -> IO () +postHandshakeAuthClientWith cparams ctx (CertRequest13 certReqCtx exts) = bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do - void $ updateTranscriptHash13 ctx h + -- updateTranscriptHash13 ctx h b processCertRequest13 ctx certReqCtx exts (usedHash, _, level, applicationSecretN) <- getTxRecordState ctx unless (level == CryptApplicationSecret) $ @@ -399,19 +403,19 @@ ---------------------------------------------------------------- asyncServerHello13 - :: ClientParams -> Context -> Maybe Group -> Millisecond -> IO () + :: ClientParams -> Context -> [Group] -> Millisecond -> IO () asyncServerHello13 cparams ctx groupSent chSentTime = do setPendingRecvActions ctx - [ PendingRecvAction True False expectServerHello - , PendingRecvAction True True (expectEncryptedExtensions ctx) + [ PendingRecvActionSelfUpdate True expectServerHello + , PendingRecvAction True (expectEncryptedExtensions ctx) , PendingRecvActionHash True expectFinishedAndSet ] where - expectServerHello sh = do + expectServerHello shb@(sh, _) = do setRTT ctx chSentTime processServerHello13 cparams ctx sh - void $ updateTranscriptHash13 ctx sh -- update by myself + updateTranscriptHash13 ctx shb -- update by myself void $ prepareSecondFlight13 ctx groupSent expectFinishedAndSet h sf = do expectFinished cparams ctx h sf diff --git a/Network/TLS/Handshake/Common.hs b/Network/TLS/Handshake/Common.hs --- a/Network/TLS/Handshake/Common.hs +++ b/Network/TLS/Handshake/Common.hs @@ -31,6 +31,7 @@ -- setPeerRecordSizeLimit, generateFinished, + encodeUpdateTranscriptHash12, updateTranscriptHash12, -- startHandshake, @@ -41,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 @@ -132,7 +134,7 @@ enablePeerRecordLimit ctx ver <- usingState_ ctx getVersion verifyData <- VerifyData <$> generateFinished ctx ver role - sendPacket12 ctx (Handshake [Finished verifyData]) + sendPacket12 ctx (Handshake [Finished verifyData] []) usingState_ ctx $ setVerifyDataForSend verifyData contextFlush ctx @@ -141,11 +143,11 @@ | RecvStateHandshake (Handshake -> m (RecvState m)) | RecvStateDone -recvPacketHandshake :: Context -> IO [Handshake] +recvPacketHandshake :: Context -> IO [HandshakeR] recvPacketHandshake ctx = do pkts <- recvPacket12 ctx case pkts of - Right (Handshake l) -> return l + Right (Handshake hss bss) -> return $ zip hss bss Right x@(AppData _) -> do -- If a TLS13 server decides to reject RTT0 data, the server should -- skip records for RTT0 data up to the maximum limit. @@ -161,16 +163,18 @@ -- | process a list of handshakes message in the recv state machine. onRecvStateHandshake - :: Context -> RecvState IO -> [Handshake] -> IO (RecvState IO) + :: Context -> RecvState IO -> [HandshakeR] -> IO (RecvState IO) onRecvStateHandshake _ recvState [] = return recvState -onRecvStateHandshake _ (RecvStatePacket f) hms = f (Handshake hms) -onRecvStateHandshake ctx (RecvStateHandshake f) (x : xs) = do - let finished = isFinished x - unless finished $ void $ updateTranscriptHash12 ctx x - nstate <- f x - when finished $ void $ updateTranscriptHash12 ctx x - onRecvStateHandshake ctx nstate xs -onRecvStateHandshake _ RecvStateDone _xs = unexpected "spurious handshake" Nothing +onRecvStateHandshake _ (RecvStatePacket f) hbs = do + let (hss, bss) = unzip hbs + f (Handshake hss bss) +onRecvStateHandshake ctx (RecvStateHandshake f) (hb@(h, _) : hbs) = do + let finished = isFinished h + unless finished $ void $ updateTranscriptHash12 ctx hb + nstate <- f h + when finished $ void $ updateTranscriptHash12 ctx hb + onRecvStateHandshake ctx nstate hbs +onRecvStateHandshake _ _ _ = unexpected "spurious handshake" Nothing isFinished :: Handshake -> Bool isFinished Finished{} = True @@ -184,8 +188,9 @@ >>= onRecvStateHandshake ctx iniState >>= runRecvState ctx -runRecvStateHS :: Context -> RecvState IO -> [Handshake] -> IO () -runRecvStateHS ctx iniState hs = onRecvStateHandshake ctx iniState hs >>= runRecvState ctx +runRecvStateHS + :: Context -> RecvState IO -> [HandshakeR] -> IO () +runRecvStateHS ctx iniState hbs = onRecvStateHandshake ctx iniState hbs >>= runRecvState ctx ensureRecvComplete :: MonadIO m => Context -> m () ensureRecvComplete ctx = do @@ -239,7 +244,7 @@ , sessionCipher = cipher , sessionCompression = compression , sessionClientSNI = sni - , sessionSecret = ms + , sessionSecret = convert ms , sessionGroup = Nothing , sessionTicketInfo = Nothing , sessionALPN = alpn @@ -359,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 = @@ -376,7 +381,7 @@ generateServerFinished :: Version -> Cipher - -> ByteString + -> Secret -> TranscriptHash -> ByteString generateServerFinished ver ciph = diff --git a/Network/TLS/Handshake/Common13.hs b/Network/TLS/Handshake/Common13.hs --- a/Network/TLS/Handshake/Common13.hs +++ b/Network/TLS/Handshake/Common13.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -36,7 +37,8 @@ calculateApplicationSecret, calculateResumptionSecret, derivePSK, - checkKeyShareKeyLength, + checkClientKeyShareKeyLength, + checkServerKeyShareKeyLength, setRTT, computeConfirm, updateTranscriptHash13, @@ -46,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 (..)) @@ -68,7 +70,6 @@ import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.MAC -import Network.TLS.Packet import Network.TLS.Packet13 import Network.TLS.Parameters import Network.TLS.State @@ -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 ---------------------------------------------------------------- @@ -373,7 +377,8 @@ ---------------------------------------------------------------- -newtype RecvHandshake13M m a = RecvHandshake13M (StateT [Handshake13] m a) +newtype RecvHandshake13M m a + = RecvHandshake13M (StateT [Handshake13R] m a) deriving (Functor, Applicative, Monad, MonadIO) recvHandshake13 @@ -381,7 +386,7 @@ => Context -> (Handshake13 -> RecvHandshake13M m a) -> RecvHandshake13M m a -recvHandshake13 ctx f = getHandshake13 ctx >>= f +recvHandshake13 ctx f = getHandshake13 ctx >>= \(h, _b) -> f h recvHandshake13hash :: MonadIO m @@ -391,21 +396,22 @@ -> RecvHandshake13M m a recvHandshake13hash ctx label f = do d <- transcriptHash ctx label - getHandshake13 ctx >>= f d + getHandshake13 ctx >>= \(h, _b) -> f d h -getHandshake13 :: MonadIO m => Context -> RecvHandshake13M m Handshake13 +getHandshake13 + :: MonadIO m => Context -> RecvHandshake13M m Handshake13R getHandshake13 ctx = RecvHandshake13M $ do currentState <- get case currentState of - (h : hs) -> found h hs - [] -> recvLoop + hb : hbs -> found hb hbs + _ -> recvLoop where - found h hs = liftIO (void $ updateTranscriptHash13 ctx h) >> put hs >> return h + found hb hbs = liftIO (updateTranscriptHash13 ctx hb) >> put hbs >> return hb recvLoop = do epkt <- liftIO (recvPacket13 ctx) case epkt of - Right (Handshake13 []) -> error "invalid recvPacket13 result" - Right (Handshake13 (h : hs)) -> found h hs + Right (Handshake13 [] _) -> error "invalid recvPacket13 result" + Right (Handshake13 (h : hs) (b : bs)) -> found (h, b) $ zip hs bs Right ChangeCipherSpec13 -> do alreadyReceived <- liftIO $ usingHState ctx getCCS13Recv if alreadyReceived @@ -462,11 +468,11 @@ -> Either ByteString (BaseSecret EarlySecret) -> IO (SecretPair EarlySecret) calculateEarlySecret ctx choice maux = do - ch <- fromJust <$> usingHState ctx getClientHello - let hCh = TranscriptHash $ hash usedHash $ encodeHandshake $ ClientHello ch + (_ch, b) <- fromJust <$> usingHState ctx getClientHello + 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 @@ -481,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" @@ -561,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 @@ -591,11 +632,11 @@ :: (MonadFail m, MonadIO m) => Context -> Hash -> ServerHello -> ByteString -> m ByteString computeConfirm ctx usedHash sh label = do - CH{..} <- fromJust <$> liftIO (usingHState ctx getClientHello) + (CH{..}, _b) <- fromJust <$> liftIO (usingHState ctx getClientHello) 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 ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Key.hs b/Network/TLS/Handshake/Key.hs --- a/Network/TLS/Handshake/Key.hs +++ b/Network/TLS/Handshake/Key.hs @@ -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 diff --git a/Network/TLS/Handshake/Server.hs b/Network/TLS/Handshake/Server.hs --- a/Network/TLS/Handshake/Server.hs +++ b/Network/TLS/Handshake/Server.hs @@ -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. @@ -31,43 +33,56 @@ -- and call handshakeServerWith. handshakeServer :: ServerParams -> Context -> IO () handshakeServer sparams ctx = liftIO $ do - hss <- recvPacketHandshake ctx - case hss of - [ch] -> handshake sparams ctx ch - _ -> unexpected (show hss) (Just "client hello") + hbs <- recvPacketHandshake ctx + case hbs of + chb : _ -> handshake sparams ctx chb + _ -> unexpected (show $ fst $ unzip hbs) (Just "client hello") -handshakeServerWith :: ServerParams -> Context -> Handshake -> IO () +handshakeServerWith + :: ServerParams -> Context -> HandshakeR -> IO () handshakeServerWith = handshake -- | 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 -> Handshake -> IO () -handshake sparams ctx (ClientHello ch) = do - (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch +handshake :: ServerParams -> Context -> HandshakeR -> IO () +handshake sparams ctx chb@(ClientHello ch, bs) = do + (chosenVersion, chI, mcrnd) <- processClientHello sparams ctx ch bs if chosenVersion == TLS13 then do -- fixme: we should check if the client random is the same as -- that in the first client hello in the case of hello retry. - (mClientKeyShare, r0, r1) <- + -- r0 :: Cipher, Hash, Bool + (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 + -- , Bool) -- rtt0OK r2 <- sendServerHello13 sparams ctx cliKeyShare r0 r1 chI mcrnd recvClientSecondFlight13 sparams ctx r2 chI else do r <- processClientHello12 sparams ctx chI + updateTranscriptHash12 ctx chb resumeSessionData <- sendServerHello12 sparams ctx r chI recvClientSecondFlight12 sparams ctx resumeSessionData diff --git a/Network/TLS/Handshake/Server/ClientHello.hs b/Network/TLS/Handshake/Server/ClientHello.hs --- a/Network/TLS/Handshake/Server/ClientHello.hs +++ b/Network/TLS/Handshake/Server/ClientHello.hs @@ -29,12 +29,13 @@ :: ServerParams -> Context -> ClientHello + -> [ByteString] -> IO ( Version , ClientHello , Maybe ClientRandom -- Just for ECH to keep the outer one for key log ) -processClientHello sparams ctx ch@CH{..} = do +processClientHello sparams ctx ch@CH{..} b = do established <- ctxEstablished ctx -- renego is not allowed in TLS 1.3 when (established /= NotEstablished) $ do @@ -127,10 +128,12 @@ else return (Nothing, False) case mClientHello' of Just chI -> do - setupI ctx chI + -- chI is created from diff. + -- encodeHandshake is a MUST. + setupI ctx chI $ [encodeHandshake $ ClientHello chI] return (chosenVersion, chI, Just chRandom) _ -> do - setupO ctx ch + setupO ctx ch b when (chosenVersion == TLS13) $ do let hasECHConf = not (null (sharedECHConfigList (serverShared sparams))) when (hasECHConf && not receivedECH) $ @@ -141,19 +144,19 @@ setECHEE True return (chosenVersion, ch, Nothing) -setupI :: Context -> ClientHello -> IO () -setupI ctx chI@CH{..} = do +setupI :: Context -> ClientHello -> [ByteString] -> IO () +setupI ctx chI@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx TLS13 chRandom - usingHState ctx $ setClientHello chI + usingHState ctx $ setClientHello chI b let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName -setupO :: Context -> ClientHello -> IO () -setupO ctx ch@CH{..} = do +setupO :: Context -> ClientHello -> [ByteString] -> IO () +setupO ctx ch@CH{..} b = do hrr <- usingState_ ctx getTLS13HRR unless hrr $ startHandshake ctx chVersion chRandom - usingHState ctx $ setClientHello ch + usingHState ctx $ setClientHello ch b let serverName = getServerName chExtensions maybe (return ()) (usingState_ ctx . setClientSNI) serverName diff --git a/Network/TLS/Handshake/Server/ClientHello12.hs b/Network/TLS/Handshake/Server/ClientHello12.hs --- a/Network/TLS/Handshake/Server/ClientHello12.hs +++ b/Network/TLS/Handshake/Server/ClientHello12.hs @@ -13,7 +13,6 @@ import Network.TLS.Extension import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature -import Network.TLS.IO.Encode import Network.TLS.Imports import Network.TLS.Parameters import Network.TLS.State @@ -46,7 +45,6 @@ Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure let usedCipher = onCipherChoosing hooks TLS12 ciphersFilteredVersion mcred <- chooseCreds usedCipher creds signatureCreds - void $ updateTranscriptHash12 ctx $ ClientHello ch return (usedCipher, mcred) checkSecureRenegotiation :: Context -> ClientHello -> IO () @@ -103,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 diff --git a/Network/TLS/Handshake/Server/ClientHello13.hs b/Network/TLS/Handshake/Server/ClientHello13.hs --- a/Network/TLS/Handshake/Server/ClientHello13.hs +++ b/Network/TLS/Handshake/Server/ClientHello13.hs @@ -3,6 +3,7 @@ module Network.TLS.Handshake.Server.ClientHello13 ( processClientHello13, + SelectKeyShareResult (..), ) where import qualified Data.ByteString as B @@ -16,22 +17,24 @@ import Network.TLS.Handshake.State import Network.TLS.IO.Encode import Network.TLS.Imports -import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.Session import Network.TLS.State import Network.TLS.Struct import Network.TLS.Types +limitSupportedGroups :: Int +limitSupportedGroups = 64 + -- TLS 1.3 or later processClientHello13 :: ServerParams -> Context -> ClientHello -> IO - ( Maybe KeyShareEntry - , (Cipher, Hash, Bool) - , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) + ( SelectKeyShareResult + , (Cipher, Hash, Bool) -- rtt0 + , (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid ) processClientHello13 sparams ctx ch@CH{..} = do when @@ -73,40 +76,57 @@ 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 - clientHello <- fromJust <$> usingHState ctx getClientHello - void $ updateTranscriptHash12 ctx $ ClientHello clientHello - return (mshare, triple, pskEarlySecret) + (ich, b) <- fromJust <$> usingHState ctx getClientHello + updateTranscriptHash12 ctx (ClientHello ich, b) + 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 -> Context - -> (Cipher, Hash, Bool) + -> (Cipher, Hash, Bool) -- rtt0 -> ClientHello - -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) + -> IO (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid pskAndEarlySecret sparams ctx (usedCipher, usedHash, rtt0) CH{..} = do (psk, binderInfo, is0RTTvalid) <- choosePSK earlyKey <- calculateEarlySecret ctx choice (Left psk) @@ -156,9 +176,8 @@ checkBinder _ Nothing = return [] checkBinder earlySecret (Just (binder, n, tlen)) = do - ch <- fromJust <$> usingHState ctx getClientHello - let ech = encodeHandshake $ ClientHello ch - binder' = makePSKBinder earlySecret usedHash tlen ech + (_, b) <- fromJust <$> usingHState ctx getClientHello + let binder' = makePSKBinder earlySecret usedHash tlen $ B.concat b --- xxx unless (binder == binder') $ decryptError "PSK binder validation failed" return [toExtensionRaw $ PreSharedKeyServerHello $ fromIntegral n] diff --git a/Network/TLS/Handshake/Server/Common.hs b/Network/TLS/Handshake/Server/Common.hs --- a/Network/TLS/Handshake/Server/Common.hs +++ b/Network/TLS/Handshake/Server/Common.hs @@ -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. diff --git a/Network/TLS/Handshake/Server/ServerHello12.hs b/Network/TLS/Handshake/Server/ServerHello12.hs --- a/Network/TLS/Handshake/Server/ServerHello12.hs +++ b/Network/TLS/Handshake/Server/ServerHello12.hs @@ -5,6 +5,8 @@ sendServerHello12, ) where +import Data.ByteArray (convert) + import Network.TLS.Cipher import Network.TLS.Compression import Network.TLS.Context.Internal @@ -42,7 +44,7 @@ sh <- makeServerHello sparams ctx usedCipher mcred chExtensions serverSession build <- sendServerFirstFlight sparams ctx usedCipher mcred chExtensions let ff = ServerHello sh : build [ServerHelloDone] - sendPacket12 ctx $ Handshake ff + sendPacket12 ctx $ Handshake ff [] contextFlush ctx Just sessionData -> do usingState_ ctx $ do @@ -50,8 +52,8 @@ setTLS12SessionResuming True sh <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession - sendPacket12 ctx $ Handshake [ServerHello sh] - let mainSecret = sessionSecret sessionData + sendPacket12 ctx $ Handshake [ServerHello sh] [] + 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 diff --git a/Network/TLS/Handshake/Server/ServerHello13.hs b/Network/TLS/Handshake/Server/ServerHello13.hs --- a/Network/TLS/Handshake/Server/ServerHello13.hs +++ b/Network/TLS/Handshake/Server/ServerHello13.hs @@ -36,15 +36,15 @@ :: ServerParams -> Context -> KeyShareEntry - -> (Cipher, Hash, Bool) - -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) + -> (Cipher, Hash, Bool) -- rtt0 + -> (SecretPair EarlySecret, [ExtensionRaw], Bool, Bool) -- authenticated, is0RTTvalid -> ClientHello -> Maybe ClientRandom -> IO ( SecretTriple ApplicationSecret , ClientTrafficSecret HandshakeSecret - , Bool - , Bool + , Bool -- authenticated + , Bool -- rtt0OK ) sendServerHello13 sparams ctx clientKeyShare (usedCipher, usedHash, rtt0) (earlyKey, preSharedKeyExt, authenticated, is0RTTvalid) CH{..} mOuterClientRandom = do let clientEarlySecret = pairClient earlyKey @@ -120,7 +120,7 @@ Just (cred, hashSig) -> sendCertAndVerify cred hashSig zlib let ServerTrafficSecret shs = serverHandshakeSecret rawFinished <- makeFinished ctx usedHash shs - loadPacket13 ctx $ Handshake13 [rawFinished] + loadPacket13 ctx $ Handshake13 [rawFinished] [] return (clientHandshakeSecret, handSecret) ---------------------------------------------------------------- hChSf <- transcriptHash ctx "CH..SF" @@ -204,7 +204,7 @@ , shExtensions = shExts } usingHState ctx $ setECHAccepted True - loadPacket13 ctx $ Handshake13 [ServerHello13 sh'] + loadPacket13 ctx $ Handshake13 [ServerHello13 sh'] [] else do srand <- liftIO $ @@ -220,26 +220,26 @@ , shComp = 0 , shExtensions = shExts } - loadPacket13 ctx $ Handshake13 [ServerHello13 sh] + loadPacket13 ctx $ Handshake13 [ServerHello13 sh] [] sendCertAndVerify cred@(certChain, _) hashSig zlib = do storePrivInfoServer ctx cred when (serverWantClientCert sparams) $ do let certReqCtx = "" -- this must be zero length here. certReq = makeCertRequest sparams ctx certReqCtx True - loadPacket13 ctx $ Handshake13 [certReq] + loadPacket13 ctx $ Handshake13 [certReq] [] usingHState ctx $ setCertReqSent True let CertificateChain cs = certChain ess = replicate (length cs) [] let certtag = if zlib then CompressedCertificate13 else Certificate13 loadPacket13 ctx $ - Handshake13 [certtag "" (CertificateChain_ certChain) ess] + Handshake13 [certtag "" (CertificateChain_ certChain) ess] [] liftIO $ usingState_ ctx $ setServerCertificateChain certChain hChSc <- transcriptHash ctx "CH..SC" pubkey <- getLocalPublicKey ctx vrfy <- makeCertVerify ctx pubkey hashSig hChSc - loadPacket13 ctx $ Handshake13 [vrfy] + loadPacket13 ctx $ Handshake13 [vrfy] [] sendExtensions rtt0OK alpnExt recodeSizeLimitExt = do msni <- liftIO $ usingState_ ctx getClientSNI @@ -285,7 +285,7 @@ ] eeExtensions' <- liftIO $ onEncryptedExtensionsCreating (serverHooks sparams) eeExtensions - loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] + loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] [] credentialsFindForSigning13 :: [HashAndSignatureAlgorithm] @@ -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 diff --git a/Network/TLS/Handshake/Server/TLS12.hs b/Network/TLS/Handshake/Server/TLS12.hs --- a/Network/TLS/Handshake/Server/TLS12.hs +++ b/Network/TLS/Handshake/Server/TLS12.hs @@ -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 @@ -40,7 +41,7 @@ Nothing -> return () Just ticket -> do let life = adjustLifetime $ serverTicketLifetime sparams - sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] + sendPacket12 ctx $ Handshake [NewSessionTicket life ticket] [] sendCCSandFinished ctx ServerRole Just _ -> do _ <- sessionEstablished ctx @@ -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 ---------------------------------------------------------------- diff --git a/Network/TLS/Handshake/Server/TLS13.hs b/Network/TLS/Handshake/Server/TLS13.hs --- a/Network/TLS/Handshake/Server/TLS13.hs +++ b/Network/TLS/Handshake/Server/TLS13.hs @@ -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 @@ -71,7 +70,7 @@ then setPendingRecvActions ctx - [ PendingRecvAction True True $ expectEndOfEarlyData ctx clientHandshakeSecret + [ PendingRecvAction True $ expectEndOfEarlyData ctx clientHandshakeSecret , PendingRecvActionHash True $ expectFinished sparams ctx chExtensions appKey clientHandshakeSecret sfSentTime ] @@ -104,7 +103,10 @@ expectFinished _ _ _ _ _ _ _ hs = unexpected (show hs) (Just "finished 13") expectEndOfEarlyData - :: Context -> ClientTrafficSecret HandshakeSecret -> Handshake13 -> IO () + :: Context + -> ClientTrafficSecret HandshakeSecret + -> Handshake13 + -> IO () expectEndOfEarlyData ctx clientHandshakeSecret EndOfEarlyData13 = do (usedHash, usedCipher, _, _) <- getRxRecordState ctx setRxRecordState ctx usedHash usedCipher clientHandshakeSecret @@ -145,7 +147,7 @@ psk = derivePSK choice resumptionSecret nonce (identity, add) <- generateSession life psk rtt0max rtt let nst = createNewSessionTicket life add nonce identity rtt0max - sendPacket13 ctx $ Handshake13 [nst] + sendPacket13 ctx $ Handshake13 [nst] [] where choice = makeCipherChoice TLS13 usedCipher rtt0max = safeNonNegative32 $ serverEarlyDataSize sparams @@ -179,7 +181,8 @@ | otherwise = fromIntegral i expectCertVerify - :: MonadIO m => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m () + :: MonadIO m + => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m () expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do certs@(CertificateChain cc) <- checkValidClientCertChain ctx "invalid client certificate chain" @@ -237,26 +240,26 @@ let certReq13 = makeCertRequest sparams ctx origCertReqCtx False _ <- withWriteLock ctx $ do bracket (saveHState ctx) (restoreHState ctx) $ \_ -> do - sendPacket13 ctx $ Handshake13 [certReq13] + sendPacket13 ctx $ Handshake13 [certReq13] [] withReadLock ctx $ do - clientCert13 <- getHandshake ctx ref + (clientCert13, bClientCert13) <- getHandshake ctx ref emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13 baseHState <- saveHState ctx - void $ updateTranscriptHash13 ctx certReq13 - void $ updateTranscriptHash13 ctx clientCert13 + updateTranscriptHash13 ctx (clientCert13, bClientCert13) th <- transcriptHash ctx "CH..Cert" unless emptyCert $ do - certVerify13 <- getHandshake ctx ref + (certVerify13, bCertVerify13) <- getHandshake ctx ref expectCertVerify sparams ctx th certVerify13 - void $ updateTranscriptHash13 ctx certVerify13 - finished13 <- getHandshake ctx ref + updateTranscriptHash13 ctx (certVerify13, bCertVerify13) + (finished13, _bFinished13) <- getHandshake ctx ref expectClientFinished ctx finished13 void $ restoreHState ctx baseHState -- fixme return True -- saving appdata and key update? -- error handling -getHandshake :: Context -> IORef [Handshake13] -> IO Handshake13 +getHandshake + :: Context -> IORef [Handshake13R] -> IO Handshake13R getHandshake ctx ref = do hhs <- readIORef ref if null hhs @@ -265,23 +268,23 @@ either (terminate ctx) process ex else chk hhs where - process (Handshake13 iss) = chk iss + process (Handshake13 hss bss) = chk $ zip hss bss process _ = terminate ctx $ Error_Protocol "post handshake authenticated" UnexpectedMessage chk [] = getHandshake ctx ref - chk (KeyUpdate13 mode : hs) = do + chk ((KeyUpdate13 mode, _) : hbs) = do keyUpdate ctx getRxRecordState setRxRecordState -- Write lock wraps both actions because we don't want another -- packet to be sent by another thread before the Tx state is -- updated. when (mode == UpdateRequested) $ withWriteLock ctx $ do - sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] + sendPacket13 ctx $ Handshake13 [KeyUpdate13 UpdateNotRequested] [] keyUpdate ctx getTxRecordState setTxRecordState - chk hs - chk (h : hs) = do - writeIORef ref hs - return h + chk hbs + chk (hb : hbs) = do + writeIORef ref hbs + return hb expectClientCertificate :: ServerParams -> Context -> CertReqContext -> Handshake13 -> IO Bool @@ -343,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 @@ -366,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 @@ -379,6 +382,6 @@ -- Write lock wraps both actions because we don't want another packet to -- be sent by another thread before the Tx state is updated. withWriteLock ctx $ do - sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] + sendPacket13 ctx $ Handshake13 [KeyUpdate13 req] [] keyUpdate ctx getTxRecordState setTxRecordState return tls13 diff --git a/Network/TLS/Handshake/State.hs b/Network/TLS/Handshake/State.hs --- a/Network/TLS/Handshake/State.hs +++ b/Network/TLS/Handshake/State.hs @@ -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 @@ -104,7 +104,7 @@ = -- | Initial state TransHashState0 | -- | A raw CH is stored since hash algo is not chosen yet. - TransHashState1 ByteString + TransHashState1 [ByteString] | -- | Hashed TransHashState2 HashCtx @@ -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] @@ -161,7 +161,7 @@ , hstCCS13Recv :: Bool , hstTLS13OuterClientRandom :: Maybe ClientRandom -- ^ Used for key logging in the case of ECH. - , hstTLS13ClientHello :: Maybe ClientHello + , hstTLS13ClientHello :: Maybe (ClientHello, [ByteString]) -- ^ Inner client hello in the case of ECH. , hstTLS13ECHAccepted :: Bool , hstTLS13ECHEE :: Bool @@ -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}) @@ -403,11 +403,11 @@ setOuterClientRandom :: Maybe ClientRandom -> HandshakeM () setOuterClientRandom mcr = modify' (\hst -> hst{hstTLS13OuterClientRandom = mcr}) -getClientHello :: HandshakeM (Maybe ClientHello) +getClientHello :: HandshakeM (Maybe (ClientHello, [ByteString])) getClientHello = gets hstTLS13ClientHello -setClientHello :: ClientHello -> HandshakeM () -setClientHello ch = modify' $ \hst -> hst{hstTLS13ClientHello = Just ch} +setClientHello :: ClientHello -> [ByteString] -> HandshakeM () +setClientHello ch b = modify' $ \hst -> hst{hstTLS13ClientHello = Just (ch, b)} getECHAccepted :: HandshakeM Bool getECHAccepted = gets hstTLS13ECHAccepted @@ -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} diff --git a/Network/TLS/Handshake/State13.hs b/Network/TLS/Handshake/State13.hs --- a/Network/TLS/Handshake/State13.hs +++ b/Network/TLS/Handshake/State13.hs @@ -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) diff --git a/Network/TLS/Handshake/TranscriptHash.hs b/Network/TLS/Handshake/TranscriptHash.hs --- a/Network/TLS/Handshake/TranscriptHash.hs +++ b/Network/TLS/Handshake/TranscriptHash.hs @@ -40,11 +40,11 @@ transit :: String -> Hash -> Bool -> TransHashState -> TransHashState transit label _ _ st0@TransHashState0 = error $ "transitTranscriptHash " ++ label ++ " " ++ show st0 transit _ _ _ st2@(TransHashState2 _) = st2 -transit _ hashAlg isHRR (TransHashState1 ch) - | isHRR = TransHashState2 $ newWith hsMsg - | otherwise = TransHashState2 $ newWith ch +transit _ hashAlg isHRR (TransHashState1 chs) + | isHRR = TransHashState2 $ hashUpdate (hashInit hashAlg) hsMsg + | otherwise = TransHashState2 $ hashUpdates (hashInit hashAlg) ch where - newWith = hashUpdate $ hashInit hashAlg + ch = reverse chs hsMsg = -- Handshake message: -- typ <-len-> body @@ -55,7 +55,7 @@ , hashedCH ] where - hashedCH = hash hashAlg ch + hashedCH = hashChunks hashAlg ch len = fromIntegral $ B.length hashedCH ---------------------------------------------------------------- @@ -73,9 +73,9 @@ traceTranscriptHash ctx label hstTransHashStateI update :: ByteString -> String -> TransHashState -> TransHashState -update eh _ TransHashState0 = TransHashState1 eh +update eh _ TransHashState0 = TransHashState1 [eh] +update eh _ (TransHashState1 bss) = TransHashState1 (eh : bss) update eh _ (TransHashState2 hctx) = TransHashState2 $ hashUpdate hctx eh -update _ label st = error $ "updateTranscriptHash " ++ label ++ " " ++ show st ---------------------------------------------------------------- diff --git a/Network/TLS/IO.hs b/Network/TLS/IO.hs --- a/Network/TLS/IO.hs +++ b/Network/TLS/IO.hs @@ -114,9 +114,10 @@ -- stHandshakeRecordCont loop (count + 1) else case pktRecv of - Right (Handshake hss) -> do - pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> - Right . Handshake <$> mapM (hookRecvHandshake hooks) hss + Right (Handshake hss bss) -> do + pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do + hss' <- mapM (hookRecvHandshake hooks) hss + return $ Right $ Handshake hss' bss logPacket ctx $ show pkt return pktRecv' Right pkt -> do @@ -131,7 +132,7 @@ isCCS _ = False isEmptyHandshake :: Either TLSError Packet -> Bool -isEmptyHandshake (Right (Handshake [])) = True +isEmptyHandshake (Right (Handshake [] _)) = True isEmptyHandshake _ = False logPacket :: Context -> String -> IO () @@ -174,9 +175,10 @@ loop (count + 1) else do case pktRecv of - Right (Handshake13 hss) -> do - pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> - Right . Handshake13 <$> mapM (hookRecvHandshake13 hooks) hss + Right (Handshake13 hss bss) -> do + pktRecv'@(Right pkt) <- ctxWithHooks ctx $ \hooks -> do + hss' <- mapM (hookRecvHandshake13 hooks) hss + return $ Right $ Handshake13 hss' bss logPacket ctx $ show pkt return pktRecv' Right pkt -> do @@ -187,7 +189,7 @@ return pktRecv isEmptyHandshake13 :: Either TLSError Packet13 -> Bool -isEmptyHandshake13 (Right (Handshake13 [])) = True +isEmptyHandshake13 (Right (Handshake13 [] _)) = True isEmptyHandshake13 _ = False ---------------------------------------------------------------- @@ -196,7 +198,7 @@ isRecvComplete ctx = usingState_ ctx $ do cont12 <- gets stHandshakeRecordCont12 cont13 <- gets stHandshakeRecordCont13 - return $ isNothing cont12 && isNothing cont13 + return $ isNothing (fst cont12) && isNothing (fst cont13) checkValid :: Context -> IO () checkValid ctx = do diff --git a/Network/TLS/IO/Decode.hs b/Network/TLS/IO/Decode.hs --- a/Network/TLS/IO/Decode.hs +++ b/Network/TLS/IO/Decode.hs @@ -7,6 +7,7 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict +import qualified Data.ByteString as BS import Network.TLS.Cipher import Network.TLS.Context.Internal @@ -41,22 +42,30 @@ , cParamsKeyXchgType = keyxchg } -- get back the optional continuation, and parse as many handshake record as possible. - mCont <- gets stHandshakeRecordCont12 - modify' (\st -> st{stHandshakeRecordCont12 = Nothing}) - hss <- parseMany currentParams mCont (fragmentGetBytes fragment) - return $ Handshake hss + (mCont, wirebytes) <- gets stHandshakeRecordCont12 + modify' (\st -> st{stHandshakeRecordCont12 = (Nothing, [])}) + (hss, bss) <- + unzip <$> parseMany currentParams mCont wirebytes (fragmentGetBytes fragment) + return $ Handshake hss bss where - parseMany currentParams mCont bs = + parseMany currentParams mCont wirebytes bs = case fromMaybe decodeHandshakeRecord mCont bs of GotError err -> throwError err - GotPartial cont -> - modify' (\st -> st{stHandshakeRecordCont12 = Just cont}) >> return [] + GotPartial cont -> do + modify' (\st -> st{stHandshakeRecordCont12 = (Just cont, bs : wirebytes)}) + return [] GotSuccess (ty, content) -> - either throwError (return . (: [])) $ decodeHandshake currentParams ty content + case decodeHandshake currentParams ty content of + Left err -> throwError err + Right h -> return [(h, reverse (bs : wirebytes))] GotSuccessRemaining (ty, content) left -> case decodeHandshake currentParams ty content of Left err -> throwError err - Right hh -> (hh :) <$> parseMany currentParams Nothing left + Right h -> do + hbs <- parseMany currentParams Nothing [] left + let len = BS.length bs - BS.length left + bs' = BS.take len bs + return ((h, reverse (bs' : wirebytes)) : hbs) decodePacket12 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type") switchRxEncryption :: Context -> IO () @@ -74,20 +83,27 @@ decodePacket13 _ (Record ProtocolType_AppData _ fragment) = return $ Right $ AppData13 $ fragmentGetBytes fragment decodePacket13 _ (Record ProtocolType_Alert _ fragment) = return (Alert13 `fmapEither` decodeAlerts (fragmentGetBytes fragment)) decodePacket13 ctx (Record ProtocolType_Handshake _ fragment) = usingState ctx $ do - mCont <- gets stHandshakeRecordCont13 - modify' (\st -> st{stHandshakeRecordCont13 = Nothing}) - hss <- parseMany mCont (fragmentGetBytes fragment) - return $ Handshake13 hss + (mCont, wirebytes) <- gets stHandshakeRecordCont13 + modify' (\st -> st{stHandshakeRecordCont13 = (Nothing, [])}) + (hss, bss) <- unzip <$> parseMany mCont wirebytes (fragmentGetBytes fragment) + return $ Handshake13 hss bss where - parseMany mCont bs = + parseMany mCont wirebytes bs = case fromMaybe decodeHandshakeRecord13 mCont bs of GotError err -> throwError err - GotPartial cont -> - modify' (\st -> st{stHandshakeRecordCont13 = Just cont}) >> return [] + GotPartial cont -> do + modify' (\st -> st{stHandshakeRecordCont13 = (Just cont, bs : wirebytes)}) + return [] GotSuccess (ty, content) -> - either throwError (return . (: [])) $ decodeHandshake13 ty content + case decodeHandshake13 ty content of + Left err -> throwError err + Right h -> return [(h, reverse (bs : wirebytes))] GotSuccessRemaining (ty, content) left -> case decodeHandshake13 ty content of Left err -> throwError err - Right hh -> (hh :) <$> parseMany Nothing left + Right h -> do + hbs <- parseMany Nothing [] left + let len = BS.length bs - BS.length left + bs' = BS.take len bs + return ((h, reverse (bs' : wirebytes)) : hbs) decodePacket13 _ _ = return $ Left (Error_Packet_Parsing "unknown protocol type") diff --git a/Network/TLS/IO/Encode.hs b/Network/TLS/IO/Encode.hs --- a/Network/TLS/IO/Encode.hs +++ b/Network/TLS/IO/Encode.hs @@ -2,7 +2,9 @@ encodePacket12, encodePacket13, updateTranscriptHash12, + encodeUpdateTranscriptHash12, updateTranscriptHash13, + encodeUpdateTranscriptHash13, ) where import Control.Concurrent.MVar @@ -47,8 +49,8 @@ -- packets are not fragmented here but by callers of sendPacket, so that the -- empty-packet countermeasure may be applied to each fragment independently. packetToFragments12 :: Context -> Maybe Int -> Packet -> IO [ByteString] -packetToFragments12 ctx mlen (Handshake hss) = - getChunks mlen . B.concat <$> mapM (updateTranscriptHash12 ctx) hss +packetToFragments12 ctx mlen (Handshake hss _) = + getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash12 ctx) hss packetToFragments12 _ _ (Alert a) = return [encodeAlerts a] packetToFragments12 _ _ ChangeCipherSpec = return [encodeChangeCipherSpec] packetToFragments12 _ _ (AppData x) = return [x] @@ -73,17 +75,32 @@ where isCBC tx = maybe False (\c -> bulkBlockSize (cipherBulk c) > 0) (stCipher tx) -updateTranscriptHash12 :: Context -> Handshake -> IO ByteString -updateTranscriptHash12 ctx hs = do +encodeUpdateTranscriptHash12 :: Context -> Handshake -> IO ByteString +encodeUpdateTranscriptHash12 ctx hs = do when (certVerifyHandshakeMaterial hs) $ usingHState ctx $ addHandshakeMessage encoded let label = show $ typeOfHandshake hs when (finishedHandshakeMaterial hs) $ updateTranscriptHash ctx label encoded + when (isClientHello hs) $ do + usingHState ctx $ do + (ch, b) <- fromJust <$> getClientHello + when (null b) $ setClientHello ch [encoded] return encoded where encoded = encodeHandshake hs + isClientHello (ClientHello _) = True + isClientHello _ = False +updateTranscriptHash12 :: Context -> HandshakeR -> IO () +updateTranscriptHash12 ctx (hs, bss) = do + when (certVerifyHandshakeMaterial hs) $ + usingHState ctx $ + mapM_ addHandshakeMessage bss + let label = show $ typeOfHandshake hs + when (finishedHandshakeMaterial hs) $ do + mapM_ (updateTranscriptHash ctx label) bss + ---------------------------------------------------------------- encodePacket13 @@ -100,14 +117,14 @@ fmap mconcat <$> forEitherM records (recordEncode13 recordLayer ctx) packetToFragments13 :: Context -> Maybe Int -> Packet13 -> IO [ByteString] -packetToFragments13 ctx mlen (Handshake13 hss) = - getChunks mlen . B.concat <$> mapM (updateTranscriptHash13 ctx) hss +packetToFragments13 ctx mlen (Handshake13 hss _) = + getChunks mlen . B.concat <$> mapM (encodeUpdateTranscriptHash13 ctx) hss packetToFragments13 _ _ (Alert13 a) = return [encodeAlerts a] packetToFragments13 _ _ (AppData13 x) = return [x] packetToFragments13 _ _ ChangeCipherSpec13 = return [encodeChangeCipherSpec] -updateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString -updateTranscriptHash13 ctx hs +encodeUpdateTranscriptHash13 :: Context -> Handshake13 -> IO ByteString +encodeUpdateTranscriptHash13 ctx hs | isIgnored hs = return encoded | otherwise = do let label = show $ typeOfHandshake13 hs @@ -117,6 +134,15 @@ where encoded = encodeHandshake13 hs - isIgnored NewSessionTicket13{} = True - isIgnored KeyUpdate13{} = True - isIgnored _ = False +updateTranscriptHash13 :: Context -> Handshake13R -> IO () +updateTranscriptHash13 ctx (hs, bss) + | isIgnored hs = return () + | otherwise = do + let label = show $ typeOfHandshake13 hs + mapM_ (updateTranscriptHash ctx label) bss + usingHState ctx $ mapM_ addHandshakeMessage bss + +isIgnored :: Handshake13 -> Bool +isIgnored NewSessionTicket13{} = True +isIgnored KeyUpdate13{} = True +isIgnored _ = False diff --git a/Network/TLS/KeySchedule.hs b/Network/TLS/KeySchedule.hs --- a/Network/TLS/KeySchedule.hs +++ b/Network/TLS/KeySchedule.hs @@ -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 diff --git a/Network/TLS/MAC.hs b/Network/TLS/MAC.hs --- a/Network/TLS/MAC.hs +++ b/Network/TLS/MAC.hs @@ -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 diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -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 ------------------------------------------------------------ diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -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 diff --git a/Network/TLS/QUIC.hs b/Network/TLS/QUIC.hs --- a/Network/TLS/QUIC.hs +++ b/Network/TLS/QUIC.hs @@ -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) diff --git a/Network/TLS/Record/Decrypt.hs b/Network/TLS/Record/Decrypt.hs --- a/Network/TLS/Record/Decrypt.hs +++ b/Network/TLS/Record/Decrypt.hs @@ -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 diff --git a/Network/TLS/Record/Encrypt.hs b/Network/TLS/Record/Encrypt.hs --- a/Network/TLS/Record/Encrypt.hs +++ b/Network/TLS/Record/Encrypt.hs @@ -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 diff --git a/Network/TLS/Record/State.hs b/Network/TLS/Record/State.hs --- a/Network/TLS/Record/State.hs +++ b/Network/TLS/Record/State.hs @@ -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 diff --git a/Network/TLS/State.hs b/Network/TLS/State.hs --- a/Network/TLS/State.hs +++ b/Network/TLS/State.hs @@ -79,7 +79,7 @@ import Network.TLS.Imports import Network.TLS.RNG import Network.TLS.Struct -import Network.TLS.Types (HostName, Role (..), Ticket) +import Network.TLS.Types (HostName, Role (..), Secret, Ticket, WireBytes) import Network.TLS.Wire (GetContinuation) data TLSState = TLSState @@ -93,8 +93,10 @@ stServerCertificateChain :: Maybe CertificateChain , stExtensionALPN :: Bool -- RFC 7301 , stNegotiatedProtocol :: Maybe ByteString -- ALPN protocol - , stHandshakeRecordCont12 :: Maybe (GetContinuation (HandshakeType, ByteString)) - , stHandshakeRecordCont13 :: Maybe (GetContinuation (HandshakeType, ByteString)) + , stHandshakeRecordCont12 + :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes) + , stHandshakeRecordCont13 + :: (Maybe (GetContinuation (HandshakeType, ByteString)), WireBytes) , stClientALPNSuggest :: Maybe [ByteString] , stClientGroupSuggest :: Maybe [Group] , stClientEcPointFormatSuggest :: Maybe [EcPointFormat] @@ -111,7 +113,7 @@ , stTLS13PreSharedKey :: Maybe PreSharedKey , stTLS13HRR :: Bool , stTLS13Cookie :: Maybe Cookie - , stTLS13ExporterSecret :: Maybe ByteString + , stTLS13ExporterSecret :: Maybe Secret , stTLS13ClientSupportsPHA :: Bool -- Post-Handshake Authentication } @@ -136,8 +138,8 @@ , stServerCertificateChain = Nothing , stExtensionALPN = False , stNegotiatedProtocol = Nothing - , stHandshakeRecordCont12 = Nothing - , stHandshakeRecordCont13 = Nothing + , stHandshakeRecordCont12 = (Nothing, []) + , stHandshakeRecordCont13 = (Nothing, []) , stClientALPNSuggest = Nothing , stClientGroupSuggest = Nothing , stClientEcPointFormatSuggest = Nothing @@ -335,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 () diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -118,6 +118,7 @@ hrrRandom, ClientHello (..), ServerHello (..), + HandshakeR, ) where import Data.X509 ( @@ -231,14 +232,14 @@ ---------------------------------------------------------------- data Packet - = Handshake [Handshake] + = Handshake [Handshake] [WireBytes] | Alert [(AlertLevel, AlertDescription)] | ChangeCipherSpec | AppData ByteString deriving (Eq) instance Show Packet where - show (Handshake hs) = "Handshake " ++ show hs + show (Handshake hs _) = "Handshake " ++ show hs show (Alert as) = "Alert " ++ show as show ChangeCipherSpec = "ChangeCipherSpec" show (AppData bs) = "AppData " ++ showBytesHex bs @@ -362,7 +363,7 @@ ---------------------------------------------------------------- -data ServerECDHParams = ServerECDHParams Group GroupPublic +data ServerECDHParams = ServerECDHParams Group GroupPublicA deriving (Show, Eq) ---------------------------------------------------------------- @@ -478,7 +479,7 @@ {- FOURMOLU_DISABLE -} packetType :: Packet -> ProtocolType -packetType (Handshake _) = ProtocolType_Handshake +packetType (Handshake _ _) = ProtocolType_Handshake packetType (Alert _) = ProtocolType_Alert packetType ChangeCipherSpec = ProtocolType_ChangeCipherSpec packetType (AppData _) = ProtocolType_AppData @@ -496,3 +497,5 @@ typeOfHandshake Finished{} = HandshakeType_Finished typeOfHandshake NewSessionTicket{} = HandshakeType_NewSessionTicket {- FOURMOLU_ENABLE -} + +type HandshakeR = (Handshake, WireBytes) diff --git a/Network/TLS/Struct13.hs b/Network/TLS/Struct13.hs --- a/Network/TLS/Struct13.hs +++ b/Network/TLS/Struct13.hs @@ -8,6 +8,7 @@ isKeyUpdate13, TicketNonce (..), SessionIDorTicket_ (..), + Handshake13R, ) where import Network.TLS.Imports @@ -15,7 +16,7 @@ import Network.TLS.Types data Packet13 - = Handshake13 [Handshake13] + = Handshake13 [Handshake13] [WireBytes] | Alert13 [(AlertLevel, AlertDescription)] | ChangeCipherSpec13 | AppData13 ByteString @@ -76,3 +77,5 @@ isKeyUpdate13 :: Handshake13 -> Bool isKeyUpdate13 (KeyUpdate13 _) = True isKeyUpdate13 _ = False + +type Handshake13R = (Handshake13, WireBytes) diff --git a/Network/TLS/Types.hs b/Network/TLS/Types.hs --- a/Network/TLS/Types.hs +++ b/Network/TLS/Types.hs @@ -12,6 +12,7 @@ bigNumFromInteger, defaultRecordSizeLimit, TranscriptHash (..), + WireBytes, ) where import Network.Socket (HostName) @@ -64,3 +65,7 @@ instance Show TranscriptHash where show (TranscriptHash bs) = showBytesHex bs + +---------------------------------------------------------------- + +type WireBytes = [ByteString] diff --git a/Network/TLS/Types/Cipher.hs b/Network/TLS/Types/Cipher.hs --- a/Network/TLS/Types/Cipher.hs +++ b/Network/TLS/Types/Cipher.hs @@ -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)) diff --git a/Network/TLS/Types/Secret.hs b/Network/TLS/Types/Secret.hs --- a/Network/TLS/Types/Secret.hs +++ b/Network/TLS/Types/Secret.hs @@ -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 diff --git a/Network/TLS/Types/Session.hs b/Network/TLS/Types/Session.hs --- a/Network/TLS/Types/Session.hs +++ b/Network/TLS/Types/Session.hs @@ -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 diff --git a/Network/TLS/Util.hs b/Network/TLS/Util.hs --- a/Network/TLS/Util.hs +++ b/Network/TLS/Util.hs @@ -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 diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -380,8 +380,9 @@ { supportedCiphers = serverCiphers , supportedVersions = serverVersions , supportedSecureRenegotiation = secNeg - , supportedGroups = serverGroups , supportedHashSignatures = serverHashSignatures + , supportedGroups = serverGroups + , supportedGroupsTLS13 = [serverGroups] } , serverShared = defaultShared{sharedCredentials = Credentials creds} } diff --git a/test/CiphersSpec.hs b/test/CiphersSpec.hs --- a/test/CiphersSpec.hs +++ b/test/CiphersSpec.hs @@ -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 diff --git a/test/ECHSpec.hs b/test/ECHSpec.hs --- a/test/ECHSpec.hs +++ b/test/ECHSpec.hs @@ -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 diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -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} diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: tls -version: 2.1.14 +version: 2.4.3 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez @@ -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 @@ -113,69 +114,32 @@ Network.TLS.Wire Network.TLS.X509 + default-language: Haskell2010 default-extensions: Strict StrictData - default-language: Haskell2010 - ghc-options: -Wall + ghc-options: -Wall build-depends: base >=4.9 && <5, - asn1-encoding >= 0.9 && < 0.10, - asn1-types >= 0.3 && < 0.4, base16-bytestring, - bytestring >= 0.10 && < 0.13, - cereal >= 0.5.3 && < 0.6, - crypton >= 0.34, - crypton-x509 >= 1.7 && < 1.8, - crypton-x509-store >= 1.6 && < 1.7, - crypton-x509-validation >= 1.6.13 && < 1.7, + bytestring >=0.10 && <0.13, + cereal >=0.5.3 && <0.6, + 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.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, - mtl >= 2.2 && < 2.4, - network >= 3.1, - random >= 1.2 && < 1.4, - serialise >= 0.2 && < 0.3, - transformers >= 0.5 && < 0.7, - unix-time >= 0.4.11 && < 0.5, - zlib >= 0.7 && < 0.8 - -test-suite spec - type: exitcode-stdio-1.0 - main-is: Spec.hs - build-tool-depends: hspec-discover:hspec-discover - hs-source-dirs: test - other-modules: - API - Arbitrary - Certificate - CiphersSpec - ECHSpec - EncodeSpec - HandshakeSpec - PipeChan - PubKey - Run - Session - ThreadSpec - - default-extensions: Strict StrictData - default-language: Haskell2010 - ghc-options: -Wall -threaded -rtsopts - build-depends: - base >=4.9 && <5, - QuickCheck, - asn1-types, - async, - base64-bytestring, - bytestring, - crypton, - crypton-x509, - crypton-x509-validation, - ech-config, - hourglass, - hspec, - serialise, - tls + 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.6, + zlib >=0.7 && <0.8 executable tls-server main-is: tls-server.hs @@ -190,8 +154,8 @@ ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5, - bytestring, base16-bytestring, + bytestring, containers, crypton, crypton-x509-store, @@ -226,7 +190,7 @@ crypton-x509-system, ech-config, network, - network-run >= 0.5, + network-run >=0.5, tls if flag(devel) @@ -234,9 +198,11 @@ else buildable: False -benchmark tls-bench - main-is: Benchmarks.hs - type: exitcode-stdio-1.0 +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + build-tool-depends: hspec-discover:hspec-discover + hs-source-dirs: test other-modules: API Arbitrary @@ -250,29 +216,65 @@ Run Session ThreadSpec - hs-source-dirs: - Benchmarks - test + default-language: Haskell2010 - ghc-options: -Wall + default-extensions: Strict StrictData + ghc-options: -Wall -threaded -rtsopts build-depends: base >=4.9 && <5, + QuickCheck, + async, + base64-bytestring, bytestring, + crypton, + crypton-asn1-types, + crypton-x509, + crypton-x509-validation, + ech-config, + hspec, + ram, + serialise, + time-hourglass, + tls + +benchmark tls-bench + type: exitcode-stdio-1.0 + main-is: Benchmarks.hs + hs-source-dirs: Benchmarks test + other-modules: + API + Arbitrary + Certificate + CiphersSpec + ECHSpec + EncodeSpec + HandshakeSpec + PipeChan + PubKey + Run + Session + ThreadSpec + + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.9 && <5, + QuickCheck, + async, base64-bytestring, + bytestring, containers, - async, - data-default, - hourglass, crypton, + crypton-asn1-types, crypton-x509, crypton-x509-store, crypton-x509-validation, + data-default, ech-config, + hspec, network, network-run, - tls, - asn1-types, - tasty-bench, - QuickCheck, serialise, - hspec + tasty-bench, + time-hourglass, + tls diff --git a/util/Common.hs b/util/Common.hs --- a/util/Common.hs +++ b/util/Common.hs @@ -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