diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,19 +1,67 @@ # Change log for "tls" -## Version 2.4.14 +## Version 2.5.0 -* Require hpke 0.4. +**The `tls-exporter` and `tls-server-end-point` channel bindings were +computed wrongly and now follow RFC 9266 and RFC 5929.** No type changes, so +a downstream build stays green, but `getTLSExporter` and +`getTLSServerEndPoint` return different bytes than they did: two peers that +compare channel bindings have to be upgraded together. `getTLSServerEndPoint` +also returns `Nothing` for an Ed25519 or Ed448 certificate now, whose +signature names no hash for the binding to use, where before it returned a +value computed under the negotiated cipher's hash. + +* Derive `tls-exporter` over the hash of the empty transcript, and + `tls-server-end-point` from the leaf certificate's own DER under its own + signature hash. + [#535](https://github.com/haskell-tls/hs-tls/pull/535) +* Write the exporter secret to the key log as `EXPORTER_SECRET`. + [#535](https://github.com/haskell-tls/hs-tls/pull/535) +* `tls-simpleserver` reports the channel bindings with `--verbose`. + [#535](https://github.com/haskell-tls/hs-tls/pull/535) * Bind the PSK to the transcript after HelloRetryRequest. - This breaks a PSK after HRR with hs-tls 2.4.13 or earlier. + This breaks a PSK after HRR with hs-tls 2.4 or earlier. [#597](https://github.com/haskell-tls/hs-tls/pull/597) +* Keep the CBC MAC check from timing the padding (Lucky Thirteen). + [#598](https://github.com/haskell-tls/hs-tls/pull/598) +* Offer only the signature algorithms that can be signed with. + [#599](https://github.com/haskell-tls/hs-tls/pull/599) +* Carry a signature scheme as one number, `SignatureScheme`, with a pattern + synonym for each IANA name. `HashAlgorithm`, `SignatureAlgorithm` and + `showSignatureScheme` are removed; `HashAndSignatureAlgorithm` remains as a + deprecated synonym. + [#588](https://github.com/haskell-tls/hs-tls/pull/588) +* Export `signatureSchemesForTLS13`. + [#588](https://github.com/haskell-tls/hs-tls/pull/588) * Let application data and HelloRequest come during a TLS 1.2 handshake. [#601](https://github.com/haskell-tls/hs-tls/pull/601) +* Report the signature schemes of the handshake in `Information`. + [#603](https://github.com/haskell-tls/hs-tls/pull/603) +* Let a server choose ciphers in the client's order (`supportedClientCipherOrder`). + [#605](https://github.com/haskell-tls/hs-tls/pull/605) * Tell why a certificate is rejected, and give the chain to `debugError` in PEM. [#606](https://github.com/haskell-tls/hs-tls/pull/606) +* Tell the client certificate on resumption, kept in `SessionData`. + Sessions saved by an earlier version cannot be resumed. + [#607](https://github.com/haskell-tls/hs-tls/pull/607) +* Add `defaultSessionData`. + [#607](https://github.com/haskell-tls/hs-tls/pull/607) +* Refuse a message after one that changes the keys in its record. + [#610](https://github.com/haskell-tls/hs-tls/pull/610) +* Update the keys before the key usage limit (`limitRecordsPerKey`), and keep + the number of updates under 2^48-1. + [#611](https://github.com/haskell-tls/hs-tls/pull/611) * Give each PSK identity its own binder, and accept HelloRetryRequest with only a cookie. [#612](https://github.com/haskell-tls/hs-tls/pull/612) +* Refuse an RSA key shorter than `supportedMinRSAKeySize` in the peer's certificate. + This refuses 1024-bit RSA certificates by default. + [#608](https://github.com/haskell-tls/hs-tls/pull/608) * Check the versions and extensions of the hello messages as RFC 9846 does. [#614](https://github.com/haskell-tls/hs-tls/pull/614) +* Refuse empty handshake records, and raise the default of `limitHandshakeFragment` to 2048. + [#615](https://github.com/haskell-tls/hs-tls/pull/615) +* Skip rejected early data by bytes, up to `max 16384 serverEarlyDataSize`, and only until a record decrypts. + [#616](https://github.com/haskell-tls/hs-tls/pull/616) * Answer a certificate that is not DER with bad_certificate instead of decode_error. [#617](https://github.com/haskell-tls/hs-tls/pull/617) * Answer an empty certificate with decode_error. @@ -32,25 +80,18 @@ [#624](https://github.com/haskell-tls/hs-tls/pull/624) * Answer several KeyUpdates with update_requested with a single KeyUpdate. [#631](https://github.com/haskell-tls/hs-tls/pull/631) +* Refuse an RSA key in the peer's certificate longer than `supportedMaxRSAKeySize` (8192 by default), and a DH prime from a TLS 1.2 server outside `supportedMinDHKeySize` and `supportedMaxDHKeySize` (2048 and 8192 by default). + This refuses 1024-bit custom DH parameters by default. + [#632](https://github.com/haskell-tls/hs-tls/pull/632) * Add `closeNotifyReceived` to tell close_notify from an EOF without it. [#635](https://github.com/haskell-tls/hs-tls/pull/635) * Resume a session only with its SNI on the client. [#636](https://github.com/haskell-tls/hs-tls/pull/636) - -## Version 2.4.13 - -* Keep the CBC MAC check from timing the padding (Lucky Thirteen). - [#598](https://github.com/haskell-tls/hs-tls/pull/598) -* Refuse a message after one that changes the keys in its record. - [#610](https://github.com/haskell-tls/hs-tls/pull/610) -* Skip rejected early data by bytes, up to `max 16384 serverEarlyDataSize`, and only until a record decrypts. - [#616](https://github.com/haskell-tls/hs-tls/pull/616) -* Offer only the signature algorithms that can be signed with. - [#599](https://github.com/haskell-tls/hs-tls/pull/599) -* Refuse empty handshake records, and raise the default of `limitHandshakeFragment` to 2048. - [#615](https://github.com/haskell-tls/hs-tls/pull/615) -* Add `defaultSessionData`. - [#630](https://github.com/haskell-tls/hs-tls/pull/630) +* Let a server choose the purposes accepted in a client certificate (`supportedClientCertificatePurposes`). + [#638](https://github.com/haskell-tls/hs-tls/pull/638) +* Add `requestCertificateAsync`, whose response `recvData` processes, and deprecate `requestCertificate`. + [#633](https://github.com/haskell-tls/hs-tls/pull/633) +* Require hpke 0.4. ## Version 2.4.12 diff --git a/Network/TLS.hs b/Network/TLS.hs --- a/Network/TLS.hs +++ b/Network/TLS.hs @@ -115,6 +115,12 @@ defaultSupported, supportedVersions, supportedCiphers, + supportedMinRSAKeySize, + supportedMaxRSAKeySize, + supportedClientCertificatePurposes, + supportedMinDHKeySize, + supportedMaxDHKeySize, + supportedClientCipherOrder, supportedCompressions, supportedHashSignatures, supportedSecureRenegotiation, @@ -143,6 +149,7 @@ limitHandshakeFragment, limitKeyUpdate, limitRecordSize, + limitRecordsPerKey, -- * Shared parameters @@ -179,6 +186,7 @@ sessionALPN, sessionMaxEarlyDataSize, sessionFlags, + sessionClientCertificate, SessionFlag (..), TLS13TicketInfo, is0RTTPossible, @@ -197,13 +205,10 @@ Version (..), Compression (..), nullCompression, + SignatureScheme (..), HashAndSignatureAlgorithm, supportedSignatureSchemes, - HashAlgorithm (..), - SignatureAlgorithm (..), - pattern MLDSA44, - pattern MLDSA65, - pattern MLDSA87, + signatureSchemesForTLS13, Group (..), supportedNamedGroups, EMSMode (..), @@ -241,6 +246,8 @@ infoTLS13HandshakeMode, infoIsEarlyDataAccepted, infoIsECHAccepted, + infoServerSignatureScheme, + infoClientSignatureScheme, ClientRandom, ServerRandom, unClientRandom, @@ -257,6 +264,8 @@ updateKey, KeyUpdateRequest (..), requestCertificate, + requestCertificateAsync, + PHAResult (..), getTLSUnique, getTLSExporter, getTLSServerEndPoint, @@ -305,6 +314,7 @@ -- ** Crypto Key PubKey (..), PrivKey (..), + ExtKeyUsagePurpose (..), -- ** Ciphers & Predefined ciphers module Network.TLS.Cipher, @@ -317,7 +327,7 @@ clientUseMaxFragmentLength, ) where -import Data.X509 (PrivKey (..), PubKey (..)) +import Data.X509 (ExtKeyUsagePurpose (..), PrivKey (..), PubKey (..)) import Data.X509.Validation hiding (HostName, defaultHooks) import Network.TLS.Backend (Backend (..), HasBackend (..)) @@ -349,18 +359,15 @@ CertificateType (..), ClientRandom (..), Handshake, - HashAlgorithm (..), + SignatureScheme (..), HashAndSignatureAlgorithm, Header (..), ProtocolType (..), ServerRandom (..), - SignatureAlgorithm (..), TLSError (..), TLSException (..), + signatureSchemesForTLS13, supportedSignatureSchemes, - pattern MLDSA44, - pattern MLDSA65, - pattern MLDSA87, ) import Network.TLS.Struct13 (Handshake13) import Network.TLS.Types @@ -370,10 +377,9 @@ type Bytes = ByteString -- | Getting certificates from a client, if any. --- Note that the certificates are not sent by a client --- on resumption even if client authentication is required. --- So, this API would be replaced by the one which can treat --- both cases of full-negotiation and resumption. +-- A client sends no certificate on resumption; then this returns the +-- leaf certificate it was authenticated with in the original connection. +-- That chain was validated then and is not checked again. getClientCertificateChain :: Context -> IO (Maybe CertificateChain) getClientCertificateChain ctx = usingState_ ctx S.getClientCertificateChain diff --git a/Network/TLS/Context.hs b/Network/TLS/Context.hs --- a/Network/TLS/Context.hs +++ b/Network/TLS/Context.hs @@ -76,6 +76,7 @@ import Control.Concurrent.MVar import Control.Monad.State.Strict import Data.IORef +import qualified Data.X509 as X509 import Network.TLS.Backend import Network.TLS.Cipher @@ -87,15 +88,14 @@ handshakeServer, handshakeServerWith, ) -import Network.TLS.Handshake.State13 import Network.TLS.Hooks import Network.TLS.Imports import Network.TLS.KeySchedule import Network.TLS.Measurement -import Network.TLS.Packet import Network.TLS.Parameters import Network.TLS.PostHandshake ( postHandshakeAuthClientWith, + requestCertificateAsyncServer, requestCertificateServer, ) import Network.TLS.RNG @@ -118,6 +118,7 @@ doHandshake :: a -> Context -> IO () doHandshakeWith :: a -> Context -> HandshakeR -> IO () doRequestCertificate :: a -> Context -> IO Bool + doRequestCertificateAsync :: a -> Context -> IO (Bool -> IO PHAResult) doPostHandshakeAuthWith :: a -> Context -> Handshake13R -> IO () instance TLSParams ClientParams where @@ -130,6 +131,7 @@ doHandshake = handshakeClient doHandshakeWith = handshakeClientWith doRequestCertificate _ _ = return False + doRequestCertificateAsync _ _ = return $ \_ -> return PHAUnavailable doPostHandshakeAuthWith = postHandshakeAuthClientWith instance TLSParams ServerParams where @@ -142,6 +144,7 @@ doHandshake = handshakeServer doHandshakeWith = handshakeServerWith doRequestCertificate = requestCertificateServer + doRequestCertificateAsync = requestCertificateAsyncServer doPostHandshakeAuthWith = \_ _ _ -> return () -- | create a new context using the backend and parameters specified. @@ -191,6 +194,7 @@ { doHandshake_ = doHandshake params , doHandshakeWith_ = doHandshakeWith params , doRequestCertificate_ = doRequestCertificate params + , doRequestCertificateAsync_ = doRequestCertificateAsync params , doPostHandshakeAuthWith_ = doPostHandshakeAuthWith params } @@ -302,22 +306,41 @@ return $ case (msecret, mcipher) of (Just secret, Just cipher) -> let h = cipherHash cipher - secret' = deriveSecret h secret label $ TranscriptHash "" + secret' = deriveSecret h secret label $ TranscriptHash $ hash h "" label' = "exporter" value' = hash h context key = hkdfExpandLabel h secret' label' value' outlen in Just key _ -> Nothing --- | Getting the "tls-server-end-point" channel binding for TLS 1.2 --- (RFC5929). For 1.3, there is no specifications for how to create --- it. In this implementation, a certificate chain without --- extensions is hashed like TLS 1.2. +-- | Getting the "tls-server-end-point" channel binding (RFC5929). +-- +-- This hashes the server's leaf certificate, exactly as it appears in the +-- Certificate message, with the hash its own signature names, and with +-- SHA-256 standing in for MD5 and SHA-1. Since it depends on nothing but +-- the certificate, it is computed for TLS 1.2 and for +-- certificate-authenticated TLS 1.3 alike -- though RFC 5929 predates TLS +-- 1.3 and no RFC defines it there. +-- +-- 'Nothing' is returned when there is no server certificate, as on a +-- resumption or with a pre-shared key, and when the certificate's +-- signature names no hash to use: an Ed25519 or Ed448 signature names the +-- whole scheme and the binding is undefined for it. getTLSServerEndPoint :: Context -> IO (Maybe ByteString) getTLSServerEndPoint ctx = do mcc <- usingState_ ctx getServerCertificateChain - case mcc of - Nothing -> return Nothing - Just cc -> do - (usedHash, _, _, _) <- getRxRecordState ctx - return $ Just $ hash usedHash $ encodeCertificate cc + return $ mcc >>= serverEndPoint + where + serverEndPoint (CertificateChain (leaf : _)) = + (\h -> hash h (X509.encodeSignedObject leaf)) <$> certificateSignatureHash leaf + serverEndPoint _ = Nothing + + certificateSignatureHash leaf = + case X509.signedAlg $ X509.getSigned leaf of + X509.SignatureALG X509.HashMD5 _ -> Just SHA256 + X509.SignatureALG X509.HashSHA1 _ -> Just SHA256 + X509.SignatureALG X509.HashSHA224 _ -> Just SHA224 + X509.SignatureALG X509.HashSHA256 _ -> Just SHA256 + X509.SignatureALG X509.HashSHA384 _ -> Just SHA384 + X509.SignatureALG X509.HashSHA512 _ -> Just SHA512 + _ -> Nothing 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 @@ -66,6 +66,7 @@ -- * Misc HandshakeSync (..), + PHAResult (..), TLS13State (..), defaultTLS13State, getTLS13State, @@ -118,6 +119,7 @@ import Network.TLS.Struct13 import Network.TLS.Types import Network.TLS.Util +import Network.TLS.X509 (CertificateChain) -- | A TLS Context keep tls specific state, parameters and backend information. data Context @@ -181,6 +183,7 @@ { doHandshake_ :: Context -> IO () , doHandshakeWith_ :: Context -> HandshakeR -> IO () , doRequestCertificate_ :: Context -> IO Bool + , doRequestCertificateAsync_ :: Context -> IO (Bool -> IO PHAResult) , doPostHandshakeAuthWith_ :: Context -> Handshake13R -> IO () } @@ -228,8 +231,30 @@ -- Actual session id for TLS 1.2, random value for TLS 1.3 , tls13stSession :: Session , tls13stSentExtensions :: [ExtensionID] + , tls13stPHA :: Maybe (MVar PHAResult, TLSError) + -- ^ server: the result of the pending post-handshake authentication, + -- and the error given to the waiters when the connection is closed + , tls13stPHAResponding :: Bool + -- ^ server: the client's response has begun, so nothing else may come + -- until its Finished } +-- | The result of 'Network.TLS.requestCertificateAsync'. +data PHAResult + = -- | The request could not be sent: TLS 1.2, no post_handshake_auth + -- from the client, or another request pending. + PHAUnavailable + | -- | No response yet. Only when not waiting. + PHAPending + | -- | The client was authenticated with this chain. + PHAAccepted CertificateChain + | -- | The client sent an empty certificate, accepted by + -- @onClientCertificate@. + PHADeclined + | -- | The verification failed or the connection was closed. + PHAFailed TLSError + deriving (Eq, Show) + defaultTLS13State :: TLS13State defaultTLS13State = TLS13State @@ -251,6 +276,8 @@ , tls13stHsKey = Nothing , tls13stSession = Session Nothing , tls13stSentExtensions = [] + , tls13stPHA = Nothing + , tls13stPHAResponding = False } getTLS13State :: Context -> IO TLS13State @@ -336,7 +363,7 @@ contextGetInformation ctx = do ver <- usingState_ ctx $ gets stVersion hstate <- getHState ctx - let (ms, ems, cr, sr, hm13, grp, ech) = + let (ms, ems, cr, sr, hm13, grp, ech, ssig, csig) = case hstate of Just st -> ( hstMainSecret st @@ -346,8 +373,11 @@ , if ver == Just TLS13 then Just (hstTLS13HandshakeMode st) else Nothing , hstSupportedGroup st , hstTLS13ECHAccepted st + , hstServerSignatureScheme st + , hstClientSignatureScheme st ) - Nothing -> (Nothing, False, Nothing, Nothing, Nothing, Nothing, False) + Nothing -> + (Nothing, False, Nothing, Nothing, Nothing, Nothing, False, Nothing, Nothing) (cipher, comp) <- readMVar (ctxRxRecordState ctx) <&> \st -> (stCipher st, stCompression st) let accepted = case hstate of @@ -371,6 +401,8 @@ , infoTLS13HandshakeMode = hm13 , infoIsEarlyDataAccepted = accepted , infoIsECHAccepted = ech + , infoServerSignatureScheme = ssig + , infoClientSignatureScheme = csig } _ -> return Nothing @@ -385,7 +417,11 @@ ctxEOF ctx = readIORef $ ctxEOF_ ctx setEOF :: Context -> IO () -setEOF ctx = writeIORef (ctxEOF_ ctx) True +setEOF ctx = do + writeIORef (ctxEOF_ ctx) True + -- Wake up those waiting for a pending post-handshake authentication. + mpha <- tls13stPHA <$> readIORef (ctxTLS13State ctx) + forM_ mpha $ \(mv, err) -> void $ tryPutMVar mv $ PHAFailed err ctxCloseNotify :: Context -> IO Bool ctxCloseNotify ctx = readIORef $ ctxCloseNotify_ ctx diff --git a/Network/TLS/Core.hs b/Network/TLS/Core.hs --- a/Network/TLS/Core.hs +++ b/Network/TLS/Core.hs @@ -26,6 +26,8 @@ updateKey, KeyUpdateRequest (..), requestCertificate, + requestCertificateAsync, + PHAResult (..), ) where import Control.Concurrent (forkIO) @@ -40,6 +42,7 @@ import Network.TLS.Context import Network.TLS.Context.Internal ( + PHAResult (..), incrementTLS13KeyUpdateCount, resetTLS13KeyUpdateCount, ) @@ -61,6 +64,8 @@ import Network.TLS.Struct import Network.TLS.Struct13 import Network.TLS.Types ( + Bulk (..), + Cipher (..), HostName, Role (..), ) @@ -229,6 +234,7 @@ tls13 <- tls13orLater ctx let sendP bs | tls13 = do + updateKeyBeforeLimit ctx sendPacket13 ctx $ AppData13 bs -- a KeyUpdate requested from now on is answered again modifyTLS13State ctx $ \st -> st{tls13stKeyUpdateResponded = False} @@ -248,6 +254,31 @@ mlen <- getPeerRecordLimit ctx -- plaintext, don't adjust for TLS 1.3 mapM_ (mapChunks_ mlen sendP) (L.toChunks dataToSend) +-- RFC 9846 Section 5.5: the keys are updated before the records sent +-- under them reach the limit. Early data cannot do so and stops there. +updateKeyBeforeLimit :: Context -> IO () +updateKeyBeforeLimit ctx = do + (mcipher, level, sqn) <- getTxSequence ctx + case mcipher of + Just cipher | sqn >= recordLimit cipher -> do + updated <- + if level == CryptApplicationSecret + then sendKeyUpdate ctx UpdateNotRequested + else return False + unless updated $ + E.throwIO $ + PostHandshake $ + Error_Misc "the key usage limit is reached" + _ -> return () + where + -- AES-GCM allows 2^24.5 full-size records. The sequence number of + -- ChaCha20-Poly1305 would wrap before its limit. + recordLimit cipher = fromMaybe forCipher $ limitRecordsPerKey $ sharedLimit $ ctxShared ctx + where + forCipher + | bulkName (cipherBulk cipher) == "CHACHA20POLY1305" = 2 ^ (62 :: Int) + | otherwise = 2 ^ (24 :: Int) + -- | Get data out of Data packet, and automatically renegotiate if a Handshake -- ClientHello is received. An empty result means EOF. Use -- 'closeNotifyReceived' to tell an orderly closure from a truncation. @@ -314,6 +345,16 @@ where clearPending = modifyTLS13State ctx $ \st -> st{tls13stPendingRecv = NoPendingRecv} + -- RFC 9846 Section 4.7.2: the client's Certificate, CertificateVerify + -- and Finished appear consecutively. The waiters get this error. + checkPHAResponse = do + responding <- tls13stPHAResponding <$> getTLS13State ctx + when responding $ do + let reason = "message inside a post-handshake authentication response" + err = Error_Protocol reason UnexpectedMessage + modifyTLS13State ctx $ \st -> st{tls13stPHA = fmap (\(mv, _) -> (mv, err)) (tls13stPHA st)} + terminate13 ctx err AlertLevel_Fatal UnexpectedMessage reason + -- RFC 9846 Section 6: the level is ignored. Alerts other than the -- closure ones are error alerts, even at the warning level. -- UserCanceled MUST be followed by a CloseNotify. @@ -331,8 +372,9 @@ loopHandshake13 $ zip hs bs recvData13 ctx -- when receiving empty appdata, we just retry to get some data. - process (AppData13 "") = recvData13 ctx + process (AppData13 "") = checkPHAResponse >> recvData13 ctx process (AppData13 x) = do + checkPHAResponse let chunkLen = C8.length x established <- ctxEstablished ctx case established of @@ -390,6 +432,7 @@ modifyTLS13State ctx $ \st -> st{tls13stRecvNST = True} loopHandshake13 hbs loopHandshake13 ((KeyUpdate13 mode, _b) : hbs) = do + checkPHAResponse when (ctxQUICMode ctx) $ do let reason = "KeyUpdate is not allowed for QUIC" terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason @@ -512,27 +555,29 @@ terminate13 ctx (Error_Misc reason) AlertLevel_Fatal UnexpectedMessage reason Just action -> do -- Pending actions are executed with read+write locks, just - -- like regular handshake code. - withWriteLock ctx $ - handleException ctx $ do - case action of - PendingRecvAction needAligned pa -> do - checkAligned needAligned - updateTranscriptHash13 ctx hb - pa h - PendingRecvActionSelfUpdate needAligned pa -> do - checkAligned needAligned - pa hb - PendingRecvActionHash needAligned pa -> do - checkAligned needAligned - d <- transcriptHash ctx "Pending action" - updateTranscriptHash13 ctx hb - pa d h - -- Client: after receiving SH, app data is coming. - -- this loop tries to receive it. - -- App key must be installed before receiving - -- the app data. - sendCFifNecessary ctx + -- like regular handshake code. A failure has sent an alert, + -- so the connection is closed. + (`E.onException` setEOF ctx) $ + withWriteLock ctx $ + handleException ctx $ do + case action of + PendingRecvAction needAligned pa -> do + checkAligned needAligned + updateTranscriptHash13 ctx hb + pa h + PendingRecvActionSelfUpdate needAligned pa -> do + checkAligned needAligned + pa hb + PendingRecvActionHash needAligned pa -> do + checkAligned needAligned + d <- transcriptHash ctx "Pending action" + updateTranscriptHash13 ctx hb + pa d h + -- Client: after receiving SH, app data is coming. + -- this loop tries to receive it. + -- App key must be installed before receiving + -- the app data. + sendCFifNecessary ctx where -- The write lock is held here, so 'handleException' sends the alert. checkAligned needAligned = when needAligned $ do @@ -597,7 +642,7 @@ -- empty result and this is 'False', the transport was closed without -- close_notify, so the data received may be truncated. -- --- @since 2.4.14 +-- @since 2.5.0 closeNotifyReceived :: MonadIO m => Context -> m Bool closeNotifyReceived = liftIO . ctxCloseNotify diff --git a/Network/TLS/Credentials.hs b/Network/TLS/Credentials.hs --- a/Network/TLS/Credentials.hs +++ b/Network/TLS/Credentials.hs @@ -145,36 +145,55 @@ pub = certPubKey cert signed = getCertificateChainLeaf chain -getHashSignature :: SignedCertificate -> Maybe TLS.HashAndSignatureAlgorithm +getHashSignature :: SignedCertificate -> Maybe TLS.SignatureScheme getHashSignature signed = case signedAlg $ getSigned signed of - SignatureALG hashAlg PubKeyALG_RSA -> convertHash TLS.SignatureRSA hashAlg - SignatureALG hashAlg PubKeyALG_DSA -> convertHash TLS.SignatureDSA hashAlg - SignatureALG hashAlg PubKeyALG_EC -> convertHash TLS.SignatureECDSA hashAlg - SignatureALG X509.HashSHA256 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA256) - SignatureALG X509.HashSHA384 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA384) - SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just (TLS.HashIntrinsic, TLS.SignatureRSApssRSAeSHA512) - SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> Just (TLS.HashIntrinsic, TLS.SignatureEd25519) - SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> Just (TLS.HashIntrinsic, TLS.SignatureEd448) + SignatureALG hashAlg PubKeyALG_RSA -> rsa hashAlg + SignatureALG hashAlg PubKeyALG_DSA -> dsa hashAlg + SignatureALG hashAlg PubKeyALG_EC -> ecdsa hashAlg + SignatureALG X509.HashSHA256 PubKeyALG_RSAPSS -> Just TLS.RSA_PSS_RSAE_SHA256 + SignatureALG X509.HashSHA384 PubKeyALG_RSAPSS -> Just TLS.RSA_PSS_RSAE_SHA384 + SignatureALG X509.HashSHA512 PubKeyALG_RSAPSS -> Just TLS.RSA_PSS_RSAE_SHA512 + SignatureALG_IntrinsicHash PubKeyALG_Ed25519 -> Just TLS.ED25519 + SignatureALG_IntrinsicHash PubKeyALG_Ed448 -> Just TLS.ED448 SignatureALG_IntrinsicHash PubKeyALG_MLDSA44 -> Just TLS.MLDSA44 SignatureALG_IntrinsicHash PubKeyALG_MLDSA65 -> Just TLS.MLDSA65 SignatureALG_IntrinsicHash PubKeyALG_MLDSA87 -> Just TLS.MLDSA87 _ -> Nothing where - convertHash sig X509.HashMD5 = Just (TLS.HashMD5, sig) - convertHash sig X509.HashSHA1 = Just (TLS.HashSHA1, sig) - convertHash sig X509.HashSHA224 = Just (TLS.HashSHA224, sig) - convertHash sig X509.HashSHA256 = Just (TLS.HashSHA256, sig) - convertHash sig X509.HashSHA384 = Just (TLS.HashSHA384, sig) - convertHash sig X509.HashSHA512 = Just (TLS.HashSHA512, sig) - convertHash _ _ = Nothing + -- A certificate can be signed with a combination TLS 1.2 allowed and + -- the registry never named as a scheme, MD5 and SHA-224 among them, so + -- those have names here too. + rsa X509.HashMD5 = Just TLS.RSA_PKCS1_MD5 + rsa X509.HashSHA1 = Just TLS.RSA_PKCS1_SHA1 + rsa X509.HashSHA224 = Just TLS.RSA_PKCS1_SHA224 + rsa X509.HashSHA256 = Just TLS.RSA_PKCS1_SHA256 + rsa X509.HashSHA384 = Just TLS.RSA_PKCS1_SHA384 + rsa X509.HashSHA512 = Just TLS.RSA_PKCS1_SHA512 + rsa _ = Nothing + dsa X509.HashMD5 = Just TLS.DSA_MD5 + dsa X509.HashSHA1 = Just TLS.DSA_SHA1 + dsa X509.HashSHA224 = Just TLS.DSA_SHA224 + dsa X509.HashSHA256 = Just TLS.DSA_SHA256 + dsa X509.HashSHA384 = Just TLS.DSA_SHA384 + dsa X509.HashSHA512 = Just TLS.DSA_SHA512 + dsa _ = Nothing + + ecdsa X509.HashMD5 = Just TLS.ECDSA_MD5 + ecdsa X509.HashSHA1 = Just TLS.ECDSA_SHA1 + ecdsa X509.HashSHA224 = Just TLS.ECDSA_SHA224 + ecdsa X509.HashSHA256 = Just TLS.ECDSA_SECP256R1_SHA256 + ecdsa X509.HashSHA384 = Just TLS.ECDSA_SECP384R1_SHA384 + ecdsa X509.HashSHA512 = Just TLS.ECDSA_SECP521R1_SHA512 + ecdsa _ = Nothing + -- | Checks whether certificate signatures in the chain comply with a list of -- hash/signature algorithm pairs. Currently the verification applies only to -- the signature of the leaf certificate, and when not self-signed. This may -- be extended to additional chain elements in the future. credentialMatchesHashSignatures - :: [TLS.HashAndSignatureAlgorithm] -> Credential -> Bool + :: [TLS.SignatureScheme] -> Credential -> Bool credentialMatchesHashSignatures hashSigs (chain, _) = case chain of CertificateChain [] -> True diff --git a/Network/TLS/Extension.hs b/Network/TLS/Extension.hs --- a/Network/TLS/Extension.hs +++ b/Network/TLS/Extension.hs @@ -117,15 +117,15 @@ import Network.TLS.Crypto.Types import Network.TLS.Error -import Network.TLS.HashAndSignature +import Network.TLS.SignatureScheme import Network.TLS.Imports import Network.TLS.Packet ( getBinaryVersion, getDNames, - getSignatureHashAlgorithm, + getSignatureScheme, putBinaryVersion, putDNames, - putSignatureHashAlgorithm, + putSignatureScheme, ) import Network.TLS.Types (HostName, Ticket, Version) import Network.TLS.Wire @@ -614,7 +614,7 @@ ------------------------------------------------------------ -newtype SignatureAlgorithms = SignatureAlgorithms [HashAndSignatureAlgorithm] +newtype SignatureAlgorithms = SignatureAlgorithms [SignatureScheme] deriving (Show, Eq) instance Extension SignatureAlgorithms where @@ -622,7 +622,7 @@ extensionEncode (SignatureAlgorithms algs) = runPut $ putWord16 (fromIntegral (length algs * 2)) - >> mapM_ putSignatureHashAlgorithm algs + >> mapM_ putSignatureScheme algs extensionDecode MsgTClientHello = decodeSignatureAlgorithms extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithms extensionDecode _ = const Nothing @@ -631,7 +631,7 @@ decodeSignatureAlgorithms = runGetMaybe $ do len <- getWord16 sas <- - getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + getList (fromIntegral len) (getSignatureScheme >>= \sh -> return (2, sh)) leftoverLen <- remaining when (leftoverLen /= 0) $ fail "decodeSignatureAlgorithms: broken length" when (null sas) $ fail "signature algorithms are empty" @@ -988,7 +988,7 @@ ------------------------------------------------------------ -newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [HashAndSignatureAlgorithm] +newtype SignatureAlgorithmsCert = SignatureAlgorithmsCert [SignatureScheme] deriving (Show, Eq) instance Extension SignatureAlgorithmsCert where @@ -996,7 +996,7 @@ extensionEncode (SignatureAlgorithmsCert algs) = runPut $ putWord16 (fromIntegral (length algs * 2)) - >> mapM_ putSignatureHashAlgorithm algs + >> mapM_ putSignatureScheme algs extensionDecode MsgTClientHello = decodeSignatureAlgorithmsCert extensionDecode MsgTCertificateRequest = decodeSignatureAlgorithmsCert extensionDecode _ = const Nothing @@ -1005,7 +1005,7 @@ decodeSignatureAlgorithmsCert = runGetMaybe $ do len <- getWord16 SignatureAlgorithmsCert - <$> getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + <$> getList (fromIntegral len) (getSignatureScheme >>= \sh -> return (2, sh)) ------------------------------------------------------------ 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 @@ -4,12 +4,14 @@ rejectOnException, verifyLeafKeyUsage, verifyLeafKeyUsagePurpose, + verifyLeafKeySize, extractCAname, ) where import qualified Control.Exception as E import Control.Monad (unless) import Control.Monad.State.Strict +import qualified Crypto.PubKey.RSA as RSA import Data.ASN1.Types (asn1CharacterToString) import Data.ByteArray.Encoding (Base (Base64), convertToBase) import qualified Data.ByteString as B @@ -20,6 +22,7 @@ ExtKeyUsage (..), ExtKeyUsageFlag, ExtKeyUsagePurpose (..), + PubKey (PubKeyRSA), encodeSignedObject, extensionGet, getDistinguishedElements, @@ -114,17 +117,38 @@ Just (ExtKeyUsage flags) -> any (`elem` validFlags) flags verifyLeafKeyUsagePurpose - :: MonadIO m => ExtKeyUsagePurpose -> CertificateChain -> m () + :: MonadIO m => [ExtKeyUsagePurpose] -> CertificateChain -> m () verifyLeafKeyUsagePurpose _ (CertificateChain []) = return () -verifyLeafKeyUsagePurpose validPurpose (CertificateChain (signed : _)) = +verifyLeafKeyUsagePurpose validPurposes (CertificateChain (signed : _)) = unless verified $ badCertificate $ - "certificate is not allowed for " ++ show validPurpose + "certificate is not allowed for any of " ++ show validPurposes where cert = getCertificate signed verified = case extensionGet (certExtensions cert) of Nothing -> True - Just (ExtExtendedKeyUsage purposes) -> validPurpose `elem` purposes + Just (ExtExtendedKeyUsage purposes) -> any (`elem` validPurposes) purposes + +-- | The RSA key of the peer's leaf certificate is to be at least +-- 'supportedMinRSAKeySize' and at most 'supportedMaxRSAKeySize' bits. The +-- keys of the rest of the chain are left to the validation of the chain. +verifyLeafKeySize :: MonadIO m => Supported -> CertificateChain -> m () +verifyLeafKeySize _ (CertificateChain []) = return () +verifyLeafKeySize supported (CertificateChain (signed : _)) = + case certPubKey $ getCertificate signed of + PubKeyRSA pk + | bits < minBits -> + badCertificate $ + "RSA key of " ++ show bits ++ " bits is shorter than " ++ show minBits + | maxBits > 0 && bits > maxBits -> + badCertificate $ + "RSA key of " ++ show bits ++ " bits is longer than " ++ show maxBits + where + bits = RSA.public_size pk * 8 + _ -> return () + where + minBits = supportedMinRSAKeySize supported + maxBits = supportedMaxRSAKeySize supported extractCAname :: SignedCertificate -> DistinguishedName extractCAname cert = certSubjectDN $ getCertificate cert diff --git a/Network/TLS/Handshake/Client/Common.hs b/Network/TLS/Handshake/Client/Common.hs --- a/Network/TLS/Handshake/Client/Common.hs +++ b/Network/TLS/Handshake/Client/Common.hs @@ -127,7 +127,8 @@ usage <- either rejectOnException (return . wrapCertificateChecks) result case usage of CertificateUsageAccept -> do - verifyLeafKeyUsagePurpose KeyUsagePurpose_ServerAuth certs + verifyLeafKeyUsagePurpose [KeyUsagePurpose_ServerAuth] certs + verifyLeafKeySize (ctxSupported ctx) certs checkLeafCertificateKeyUsage CertificateUsageReject reason -> certificateRejected ctx (either (const []) id result) certs reason @@ -182,7 +183,7 @@ -- | Return the supported 'CertificateType' values that are -- compatible with at least one supported signature algorithm. supportedCtypes - :: [HashAndSignatureAlgorithm] + :: [SignatureScheme] -> [CertificateType] supportedCtypes hashAlgs = nub $ foldr ctfilter [] hashAlgs @@ -201,7 +202,7 @@ sigAlgsToCertTypes :: Context - -> [HashAndSignatureAlgorithm] + -> [SignatureScheme] -> [CertificateType] sigAlgsToCertTypes ctx hashSigs = filter (`elem` supportedCtypes hashSigs) $ clientSupportedCtypes ctx @@ -309,7 +310,7 @@ ---------------------------------------------------------------- --- | Return a most preferred 'HandAndSignatureAlgorithm' that is compatible with +-- | Return a most preferred 'SignatureScheme' that is compatible with -- the local key and server's signature algorithms (both already saved). Must -- only be called for TLS versions 1.2 and up, with compatibility function -- 'signatureCompatible' or 'signatureCompatible13' based on version. @@ -319,10 +320,10 @@ -- are selected by client preference in @cHashSigs@. getLocalHashSigAlg :: Context - -> (PubKey -> HashAndSignatureAlgorithm -> Bool) - -> [HashAndSignatureAlgorithm] + -> (PubKey -> SignatureScheme -> Bool) + -> [SignatureScheme] -> PubKey - -> IO HashAndSignatureAlgorithm + -> IO SignatureScheme getLocalHashSigAlg ctx isCompatible cHashSigs pubKey = do -- Must be present with TLS 1.2 and up. (Just (_, Just hashSigs, _)) <- usingHState ctx getCertReqCBdata 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 @@ -212,6 +212,19 @@ ffGroup = findFiniteFieldGroup params srvpub = serverDHParamsToPublic serverParams + let bits = dhParamsGetBits params + minBits = supportedMinDHKeySize $ ctxSupported ctx + maxBits = supportedMaxDHKeySize $ ctxSupported ctx + when (bits < minBits) $ + throwCore $ + Error_Protocol + ("DH prime of " ++ show bits ++ " bits is smaller than " ++ show minBits) + InsufficientSecurity + when (maxBits > 0 && bits > maxBits) $ + throwCore $ + Error_Protocol + ("DH prime of " ++ show bits ++ " bits is larger than " ++ show maxBits) + HandshakeFailure unless (maybe False (isSupportedGroup ctx) ffGroup) $ do groupUsage <- onCustomFFDHEGroup (clientHooks cparams) params srvpub 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 @@ -238,7 +238,7 @@ _ -> throwCore $ Error_Protocol "invalid certificate request" HandshakeFailure unsighash :: SignatureAlgorithms - -> Maybe [HashAndSignatureAlgorithm] + -> Maybe [SignatureScheme] unsighash (SignatureAlgorithms a) = Just a ---------------------------------------------------------------- @@ -369,7 +369,7 @@ {- Unused for now uncertsig :: SignatureAlgorithmsCert - -> Maybe [HashAndSignatureAlgorithm] + -> Maybe [SignatureScheme] uncertsig (SignatureAlgorithmsCert a) = Just a -} 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 @@ -22,6 +22,8 @@ ensureRecvComplete, processExtendedMainSecret, getSessionData, + clientLeafCertificate, + restoreClientCertificate, storePrivInfo, isSupportedGroup, checkSupportedGroup, @@ -46,6 +48,7 @@ import Data.ByteArray (convert) import qualified Data.ByteString as B import Data.IORef (modifyIORef') +import Data.X509 (decodeSignedCertificate, encodeSignedObject) import Network.TLS.Cipher import Network.TLS.Compression @@ -255,6 +258,24 @@ usingHState ctx $ setExtendedMainSecret True return True +-- | The DER of the client's leaf certificate, kept in the session. The +-- chain was validated in this handshake; the leaf tells who the client is. +clientLeafCertificate :: Context -> IO (Maybe ByteString) +clientLeafCertificate ctx = do + mcc <- usingState_ ctx getClientCertificateChain + return $ case mcc of + Just (CertificateChain (leaf : _)) -> Just $ encodeSignedObject leaf + _ -> Nothing + +-- | On resumption no certificate is exchanged; the client is the one whose +-- leaf certificate the session kept. +restoreClientCertificate :: Context -> SessionData -> IO () +restoreClientCertificate ctx sd = + case sessionClientCertificate sd + >>= either (const Nothing) Just . decodeSignedCertificate of + Just leaf -> usingState_ ctx $ setClientCertificateChain $ CertificateChain [leaf] + Nothing -> return () + getSessionData :: Context -> IO (Maybe SessionData) getSessionData ctx = do ver <- usingState_ ctx getVersion @@ -263,6 +284,7 @@ ems <- usingHState ctx getExtendedMainSecret cipher <- cipherID <$> usingHState ctx getPendingCipher alpn <- usingState_ ctx getNegotiatedProtocol + clientCert <- clientLeafCertificate ctx let compression = 0 flags = [SessionEMS | ems] case mms of @@ -281,6 +303,7 @@ , sessionALPN = alpn , sessionMaxEarlyDataSize = 0 , sessionFlags = flags + , sessionClientCertificate = clientCert } -- | Store the specified keypair. Whether the public key and private key @@ -467,6 +490,8 @@ , hstMainSecret = hstMainSecret hshake , hstExtendedMainSecret = hstExtendedMainSecret hshake , hstSupportedGroup = hstSupportedGroup hshake + , hstServerSignatureScheme = hstServerSignatureScheme hshake + , hstClientSignatureScheme = hstClientSignatureScheme hshake } updateMeasure ctx resetBytesCounters -- mark the secure connection up and running. 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 @@ -60,7 +60,7 @@ import Network.TLS.Compression import Network.TLS.Extension import Network.TLS.Handshake.Certificate (extractCAname) -import Network.TLS.Handshake.Common (unexpected) +import Network.TLS.Handshake.Common (clientLeafCertificate, unexpected) import Network.TLS.Handshake.Key import Network.TLS.Handshake.Signature import Network.TLS.Handshake.State @@ -156,7 +156,7 @@ :: MonadIO m => Context -> PubKey - -> HashAndSignatureAlgorithm + -> SignatureScheme -> TranscriptHash -> m Handshake13 makeCertVerify ctx pub hs (TranscriptHash hashValue) = do @@ -165,13 +165,14 @@ | role == ClientRole = clientContextString | otherwise = serverContextString target = makeTarget ctxStr hashValue + usingHState ctx $ setSignatureScheme role hs CertVerify13 . DigitallySigned hs <$> sign ctx pub hs target checkCertVerify :: MonadIO m => Context -> PubKey - -> HashAndSignatureAlgorithm + -> SignatureScheme -> Signature -> ByteString -> m Bool @@ -185,7 +186,7 @@ unless (pub `signatureCompatible13` hs) $ throwCore $ Error_Protocol - ("signature algorithm " ++ showSignatureScheme hs ++ " does not fit the public key") + ("signature algorithm " ++ show hs ++ " does not fit the public key") IllegalParameter role <- usingState_ ctx getRole let ctxStr @@ -193,7 +194,9 @@ | otherwise = clientContextString target = makeTarget ctxStr hashValue sigParams = signatureParams pub hs - verifyPublic ctx sigParams target signature + ok <- verifyPublic ctx sigParams target signature + when ok $ usingHState ctx $ setSignatureScheme (invertRole role) hs + return ok makeTarget :: ByteString -> ByteString -> ByteString makeTarget contextString hashValue = runPut $ do @@ -206,7 +209,7 @@ :: MonadIO m => Context -> PubKey - -> HashAndSignatureAlgorithm + -> SignatureScheme -> ByteString -> m Signature sign ctx pub hs target = liftIO $ do @@ -364,6 +367,7 @@ malpn <- usingState_ ctx getNegotiatedProtocol sni <- usingState_ ctx getClientSNI mgrp <- usingHState ctx getSupportedGroup + clientCert <- clientLeafCertificate ctx return SessionData { sessionVersion = ver @@ -376,6 +380,7 @@ , sessionALPN = malpn , sessionMaxEarlyDataSize = maxSize , sessionFlags = [] + , sessionClientCertificate = clientCert } ---------------------------------------------------------------- @@ -449,32 +454,15 @@ -- some hash/signature combinations have been deprecated in TLS13 and should -- not be used -checkHashSignatureValid13 :: HashAndSignatureAlgorithm -> IO () +checkHashSignatureValid13 :: SignatureScheme -> IO () checkHashSignatureValid13 hs = unless (isHashSignatureValid13 hs) $ - let msg = "invalid TLS13 hash and signature algorithm: " ++ showSignatureScheme hs + let msg = "invalid TLS13 hash and signature algorithm: " ++ show hs in throwCore $ Error_Protocol msg IllegalParameter -isHashSignatureValid13 :: HashAndSignatureAlgorithm -> Bool +isHashSignatureValid13 :: SignatureScheme -> Bool isHashSignatureValid13 hs = hs `elem` signatureSchemesForTLS13 -{- -isHashSignatureValid13 (HashIntrinsic, s) = - s - `elem` [ SignatureRSApssRSAeSHA256 - , SignatureRSApssRSAeSHA384 - , SignatureRSApssRSAeSHA512 - , SignatureEd25519 - , SignatureEd448 - , SignatureRSApsspssSHA256 - , SignatureRSApsspssSHA384 - , SignatureRSApsspssSHA512 - ] -isHashSignatureValid13 (h, SignatureECDSA) = - h `elem` [HashSHA256, HashSHA384, HashSHA512] -isHashSignatureValid13 _ = False --} - ---------------------------------------------------------------- calculateEarlySecret @@ -547,6 +535,7 @@ serverApplicationSecret0 = deriveSecret usedHash applicationSecret "s ap traffic" hChSf exporterSecret = deriveSecret usedHash applicationSecret "exp master" hChSf usingState_ ctx $ setTLS13ExporterSecret exporterSecret + logKey ctx $ ExporterSecret exporterSecret let sts0 = ServerTrafficSecret serverApplicationSecret0 :: ServerTrafficSecret ApplicationSecret @@ -699,6 +688,8 @@ , hstTLS13RTT0Status = hstTLS13RTT0Status hshake , hstTLS13ResumptionSecret = hstTLS13ResumptionSecret hshake , hstTLS13ECHAccepted = hstTLS13ECHAccepted hshake + , hstServerSignatureScheme = hstServerSignatureScheme hshake + , hstClientSignatureScheme = hstClientSignatureScheme hshake } -- forget handshake data stored in TLS state usingState_ ctx $ do 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 @@ -174,6 +174,9 @@ instance LogLabel (ClientTrafficSecret ApplicationSecret) where labelAndKey (ClientTrafficSecret key) = ("CLIENT_TRAFFIC_SECRET_0", key) +instance LogLabel ExporterSecret where + labelAndKey (ExporterSecret key) = ("EXPORTER_SECRET", key) + -- NSS Key Log Format -- See https://developer.mozilla.org/en-US/docs/Mozilla/Projects/NSS/Key_Log_Format logKey :: LogLabel a => Context -> a -> IO () 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 @@ -4,6 +4,7 @@ handshakeServer, handshakeServerWith, requestCertificateServer, + requestCertificateAsyncServer, keyUpdate, sendKeyUpdate, respondToKeyUpdate, 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 @@ -47,7 +47,7 @@ checkResumedCipherOffered ctx ch throwCore $ Error_Protocol "no cipher in common with the TLS 1.2 client" HandshakeFailure - usedCipher <- chooseCipher hooks TLS12 ciphersFilteredVersion + usedCipher <- chooseCipher sparams TLS12 (chCiphers ch) ciphersFilteredVersion mcred <- chooseCreds usedCipher creds signatureCreds return (usedCipher, mcred) 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 @@ -12,6 +12,7 @@ import Network.TLS.Context.Internal import Network.TLS.Crypto import Network.TLS.Extension +import Network.TLS.Handshake.Common (restoreClientCertificate) import Network.TLS.Handshake.Common13 import Network.TLS.Handshake.Server.Common import Network.TLS.Handshake.Signature @@ -60,7 +61,7 @@ when (null ciphersFilteredVersion) $ throwCore $ Error_Protocol "no cipher in common with the TLS 1.3 client" HandshakeFailure - usedCipher <- chooseCipher (serverHooks sparams) TLS13 ciphersFilteredVersion + usedCipher <- chooseCipher sparams TLS13 chCiphers ciphersFilteredVersion let usedHash = cipherHash usedCipher rtt0 = lookupAndDecode @@ -209,7 +210,8 @@ isFresh <- checkFreshness tinfo obfAge (isPSKvalid, is0RTTvalid) <- checkSessionEquality sdata if isPSKvalid && isFresh - then + then do + restoreClientCertificate ctx sdata return ( psk , Just (bnd, n :: Int, len) 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 @@ -16,7 +16,7 @@ ) where import Control.Monad.State.Strict -import Data.X509 (ExtKeyUsageFlag (..), ExtKeyUsagePurpose (..)) +import Data.X509 (ExtKeyUsageFlag (..)) import Network.TLS.Cipher import Network.TLS.Context.Internal @@ -31,11 +31,15 @@ import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct +import Network.TLS.Types (CipherId (..)) import Network.TLS.Util (catchException) import Network.TLS.X509 -chooseCipher :: ServerHooks -> Version -> [Cipher] -> IO Cipher -chooseCipher hooks ver candidates = +-- | The candidates come in the order of 'supportedCiphers'; with +-- 'supportedClientCipherOrder' they are put in the order of the client's +-- list before 'onCipherChoosing' sees them. +chooseCipher :: ServerParams -> Version -> [CipherId] -> [Cipher] -> IO Cipher +chooseCipher sparams ver clientCiphers candidates0 = case find ((== cipherID selected) . cipherID) candidates of Just cipher -> return cipher Nothing -> @@ -44,7 +48,11 @@ "onCipherChoosing selected a cipher outside the candidate list" InternalError where - selected = onCipherChoosing hooks ver candidates + candidates + | supportedClientCipherOrder (serverSupported sparams) = + mapMaybe (\(CipherId cid) -> findCipher cid candidates0) $ nub clientCiphers + | otherwise = candidates0 + selected = onCipherChoosing (serverHooks sparams) ver candidates checkValidClientCertChain :: MonadIO m => Context -> String -> m CertificateChain @@ -172,7 +180,10 @@ case usage of CertificateUsageAccept -> do verifyLeafKeyUsage [KeyUsage_digitalSignature] certs - verifyLeafKeyUsagePurpose KeyUsagePurpose_ClientAuth certs + verifyLeafKeyUsagePurpose + (supportedClientCertificatePurposes $ serverSupported sparams) + certs + verifyLeafKeySize (serverSupported sparams) certs CertificateUsageReject reason -> certificateRejected ctx [] certs reason -- Remember cert chain for later use. @@ -186,14 +197,14 @@ -- However here the algorithms are selected according -- to server preference in 'supportedHashSignatures'. hashAndSignaturesInCommon - :: [HashAndSignatureAlgorithm] -> [ExtensionRaw] -> [HashAndSignatureAlgorithm] + :: [SignatureScheme] -> [ExtensionRaw] -> [SignatureScheme] hashAndSignaturesInCommon sHashSigs exts = sHashSigs `intersect` cHashSigs where -- See Section 7.4.1.4.1 of RFC 5246. defVal = - [ (HashSHA1, SignatureECDSA) - , (HashSHA1, SignatureRSA) - , (HashSHA1, SignatureDSA) + [ ECDSA_SHA1 + , RSA_PKCS1_SHA1 + , DSA_SHA1 ] cHashSigs = lookupAndDecode 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 @@ -50,6 +50,7 @@ usingState_ ctx $ do setSession chSession setTLS12SessionResuming True + restoreClientCertificate ctx sessionData sh <- makeServerHello sparams ctx usedCipher mcred chExtensions chSession sendPacket12 ctx $ Handshake [ServerHello sh] [] 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 @@ -299,9 +299,9 @@ loadPacket13 ctx $ Handshake13 [EncryptedExtensions13 eeExtensions'] [] credentialsFindForSigning13 - :: [HashAndSignatureAlgorithm] + :: [SignatureScheme] -> Credentials - -> Maybe (Credential, HashAndSignatureAlgorithm) + -> Maybe (Credential, SignatureScheme) credentialsFindForSigning13 hss0 creds = loop hss0 where loop [] = Nothing @@ -311,7 +311,7 @@ -- See credentialsFindForSigning. credentialsFindForSigning13' - :: HashAndSignatureAlgorithm -> Credentials -> Maybe Credential + :: SignatureScheme -> Credentials -> Maybe Credential credentialsFindForSigning13' sigAlg (Credentials l) = find forSigning l where forSigning cred = case credentialDigitalSignatureKey cred of 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 @@ -1,9 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Network.TLS.Handshake.Server.TLS13 ( recvClientSecondFlight13, requestCertificateServer, + requestCertificateAsyncServer, keyUpdate, sendKeyUpdate, respondToKeyUpdate, @@ -11,6 +13,7 @@ KeyUpdateRequest (..), ) where +import Control.Concurrent.MVar import qualified Control.Exception as E import Control.Monad.State.Strict import Data.IORef @@ -186,7 +189,16 @@ expectCertVerify :: MonadIO m => ServerParams -> Context -> TranscriptHash -> Handshake13 -> m () -expectCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = liftIO $ do +expectCertVerify sparams ctx th h = liftIO $ do + -- Commit the client certificate chain to the context. + certs <- verifyCertVerify sparams ctx th h + usingState_ ctx $ setClientCertificateChain certs + +-- | Like 'expectCertVerify' but returns the chain instead of committing +-- it, which post-handshake authentication does only after Finished. +verifyCertVerify + :: ServerParams -> Context -> TranscriptHash -> Handshake13 -> IO CertificateChain +verifyCertVerify sparams ctx (TranscriptHash hChCc) (CertVerify13 (DigitallySigned sigAlg sig)) = do certs@(CertificateChain cc) <- checkValidClientCertChain ctx "invalid client certificate chain" pubkey <- case cc of @@ -196,33 +208,20 @@ checkDigitalSignatureKey ver pubkey usingHState ctx $ setPublicKey pubkey verif <- checkCertVerify ctx pubkey sigAlg sig hChCc - clientCertVerify sparams ctx certs verif -expectCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") + clientCertVerify sparams verif + return certs +verifyCertVerify _ _ _ hs = unexpected (show hs) (Just "certificate verify 13") -clientCertVerify :: ServerParams -> Context -> CertificateChain -> Bool -> IO () -clientCertVerify sparams ctx certs verif = do - if verif - then do - -- When verification succeeds, commit the - -- client certificate chain to the context. - -- - usingState_ ctx $ setClientCertificateChain certs - return () - else do - -- Either verification failed because of an - -- invalid format (with an error message), or - -- the signature is wrong. In either case, - -- ask the application if it wants to - -- proceed, we will do that. - res <- liftIO $ onUnverifiedClientCert (serverHooks sparams) - if res - then do - -- When verification fails, but the - -- application callbacks accepts, we - -- also commit the client certificate - -- chain to the context. - usingState_ ctx $ setClientCertificateChain certs - else decryptError "verification failed" +clientCertVerify :: ServerParams -> Bool -> IO () +clientCertVerify sparams verif = + unless verif $ do + -- Either verification failed because of an + -- invalid format (with an error message), or + -- the signature is wrong. In either case, + -- ask the application if it wants to + -- proceed, we will do that. + res <- onUnverifiedClientCert (serverHooks sparams) + unless res $ decryptError "verification failed" ---------------------------------------------------------------- @@ -233,7 +232,8 @@ requestCertificateServer sparams ctx = handleEx ctx $ do tls13 <- tls13orLater ctx supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA - let ok = tls13 && supportsPHA + pending <- isJust . tls13stPHA <$> getTLS13State ctx + let ok = tls13 && supportsPHA && not pending if ok then newIORef [] >>= sendCertReqAndRecv else return ok @@ -254,15 +254,80 @@ emptyCert <- expectClientCertificate sparams ctx origCertReqCtx clientCert13 updateTranscriptHash13 ctx (clientCert13, bClientCert13) th <- transcriptHash ctx "CH..Cert" - unless emptyCert $ do - (certVerify13, bCertVerify13) <- getHandshake ctx ref - expectCertVerify sparams ctx th certVerify13 - updateTranscriptHash13 ctx (certVerify13, bCertVerify13) + mcerts <- + if emptyCert + then return Nothing + else do + (certVerify13, bCertVerify13) <- getHandshake ctx ref + certs <- verifyCertVerify sparams ctx th certVerify13 + updateTranscriptHash13 ctx (certVerify13, bCertVerify13) + return $ Just certs (finished13, _bFinished13) <- getHandshake ctx ref - expectClientFinished ctx finished13 + thCf <- transcriptHash ctx "CH.. Context -> IO (Bool -> IO PHAResult) +requestCertificateAsyncServer sparams ctx = withWriteLock ctx $ do + tls13 <- tls13orLater ctx + supportsPHA <- usingState_ ctx getTLS13ClientSupportsPHA + established <- ctxEstablished ctx + pending <- isJust . tls13stPHA <$> getTLS13State ctx + noActions <- null <$> readIORef (ctxPendingRecvActions ctx) + if tls13 && supportsPHA && established == Established && not pending && noActions + then do + mv <- newEmptyMVar + request mv + return $ \block -> + if block + then readMVar mv + else fromMaybe PHAPending <$> tryReadMVar mv + else return $ \_ -> return PHAUnavailable + where + -- The actions are registered before CertificateRequest is sent, so + -- that the response cannot reach 'recvData' first. + request mv = do + certReqCtx <- newCertReqContext ctx + let certReq13 = makeCertRequest sparams ctx certReqCtx False + baseHState <- saveHState ctx + ref <- newIORef Nothing + let certificate = PendingRecvAction False $ \h -> reportTo mv $ do + modifyTLS13State ctx $ \st -> st{tls13stPHAResponding = True} + emptyCert <- expectClientCertificate sparams ctx certReqCtx h + pushPendingRecvAction ctx $ finished mv baseHState ref + unless emptyCert $ + pushPendingRecvAction ctx $ + PendingRecvActionHash False $ \th h' -> reportTo mv $ do + certs <- verifyCertVerify sparams ctx th h' + writeIORef ref $ Just certs + setPendingRecvActions ctx [certificate] + modifyTLS13State ctx $ \st -> st{tls13stPHA = Just (mv, Error_EOF)} + -- This also adds CertificateRequest to the transcript. + sendPacket13 ctx $ Handshake13 [certReq13] [] + -- The chain verified by CertificateVerify is committed only now. + finished mv baseHState ref = PendingRecvActionHash False $ \th h -> reportTo mv $ do + expectClientFinished ctx th h + void $ restoreHState ctx baseHState + mcerts <- readIORef ref + forM_ mcerts $ usingState_ ctx . setClientCertificateChain + modifyTLS13State ctx $ \st -> + st{tls13stPHA = Nothing, tls13stPHAResponding = False} + putMVar mv $ maybe PHADeclined PHAAccepted mcerts + -- The waiters get the error when 'recvData' has sent the alert and + -- closed the connection, so that they do not send close_notify. + reportTo mv f = + f `E.catch` \(e :: E.SomeException) -> do + let err = case E.fromException e of + Just (Uncontextualized e') -> e' + _ -> Error_Misc $ show e + modifyTLS13State ctx $ \st -> st{tls13stPHA = Just (mv, err)} + E.throwIO e + -- saving appdata and key update? -- error handling getHandshake @@ -329,17 +394,16 @@ Error_Protocol "certificate context is wrong" IllegalParameter void $ clientCertificate sparams ctx certs -expectClientFinished :: Context -> Handshake13 -> IO () -expectClientFinished ctx (Finished13 verifyData) = do +expectClientFinished :: Context -> TranscriptHash -> Handshake13 -> IO () +expectClientFinished ctx hChBeforeCf (Finished13 verifyData) = do (usedHash, _, level, applicationSecretN) <- getRxRecordState ctx unless (level == CryptApplicationSecret) $ throwCore $ Error_Protocol "tried post-handshake authentication without application traffic secret" InternalError - hChBeforeCf <- transcriptHash ctx "CH.. TLSError -> IO a terminate ctx err = do @@ -416,18 +480,18 @@ deriving (Eq, Show) -- | Updating application traffic secrets for TLS 1.3. --- If this API is called for TLS 1.3, 'True' is returned. --- Otherwise, 'False' is returned. +-- If the keys are updated, 'True' is returned. +-- Otherwise, that is, for TLS 1.2 or after 2^48-1 updates, 'False' is +-- returned. updateKey :: MonadIO m => Context -> KeyUpdateRequest -> m Bool updateKey ctx way = liftIO $ do tls13 <- tls13orLater ctx - when tls13 $ do - let req = case way of - OneWay -> UpdateNotRequested - TwoWay -> UpdateRequested - -- 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] [] - keyUpdate ctx getTxRecordState setTxRecordState - return tls13 + if tls13 + then do + let req = case way of + OneWay -> UpdateNotRequested + TwoWay -> UpdateRequested + -- 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 $ sendKeyUpdate ctx req + else return False diff --git a/Network/TLS/Handshake/Signature.hs b/Network/TLS/Handshake/Signature.hs --- a/Network/TLS/Handshake/Signature.hs +++ b/Network/TLS/Handshake/Signature.hs @@ -30,6 +30,7 @@ import Network.TLS.Parameters import Network.TLS.State import Network.TLS.Struct +import Network.TLS.Types (invertRole) import Network.TLS.X509 decryptError :: MonadIO m => String -> m a @@ -51,7 +52,7 @@ certificateCompatible (PubKeyMLDSA87 _) _ = True certificateCompatible _ _ = False -signatureCompatible :: PubKey -> HashAndSignatureAlgorithm -> Bool +signatureCompatible :: PubKey -> SignatureScheme -> Bool -- ML-DSA first, and with a refusal for every other kind of key. The RSA -- equations below ignore the first byte, and ML-DSA's second byte is one -- RSASSA-PSS also uses, so an ML-DSA scheme reaching them would be answered @@ -62,21 +63,26 @@ signatureCompatible _ MLDSA44 = False signatureCompatible _ MLDSA65 = False signatureCompatible _ MLDSA87 = False -signatureCompatible (PubKeyRSA pk) (HashSHA1, SignatureRSA) = kxCanUseRSApkcs1 pk SHA1 -signatureCompatible (PubKeyRSA pk) (HashSHA256, SignatureRSA) = kxCanUseRSApkcs1 pk SHA256 -signatureCompatible (PubKeyRSA pk) (HashSHA384, SignatureRSA) = kxCanUseRSApkcs1 pk SHA384 -signatureCompatible (PubKeyRSA pk) (HashSHA512, SignatureRSA) = kxCanUseRSApkcs1 pk SHA512 --- Only what signatureParams implements: a combination it does not, such as +signatureCompatible (PubKeyRSA pk) RSA_PKCS1_SHA1 = kxCanUseRSApkcs1 pk SHA1 +signatureCompatible (PubKeyRSA pk) RSA_PKCS1_SHA256 = kxCanUseRSApkcs1 pk SHA256 +signatureCompatible (PubKeyRSA pk) RSA_PKCS1_SHA384 = kxCanUseRSApkcs1 pk SHA384 +signatureCompatible (PubKeyRSA pk) RSA_PKCS1_SHA512 = kxCanUseRSApkcs1 pk SHA512 +-- Only what signatureParams implements: a scheme it does not, such as -- ecdsa_sha224, must not be chosen and then fail to sign. -signatureCompatible (PubKeyRSA pk) (HashIntrinsic, SignatureRSApssRSAeSHA256) = kxCanUseRSApss pk SHA256 -signatureCompatible (PubKeyRSA pk) (HashIntrinsic, SignatureRSApssRSAeSHA384) = kxCanUseRSApss pk SHA384 -signatureCompatible (PubKeyRSA pk) (HashIntrinsic, SignatureRSApssRSAeSHA512) = kxCanUseRSApss pk SHA512 -signatureCompatible (PubKeyDSA _) (HashSHA1, SignatureDSA) = True -signatureCompatible (PubKeyEC _) (h, SignatureECDSA) = - h `elem` [HashSHA1, HashSHA256, HashSHA384, HashSHA512] -signatureCompatible (PubKeyEd25519 _) (HashIntrinsic, SignatureEd25519) = True -signatureCompatible (PubKeyEd448 _) (HashIntrinsic, SignatureEd448) = True -signatureCompatible _ (_, _) = False +signatureCompatible (PubKeyRSA pk) RSA_PSS_RSAE_SHA256 = kxCanUseRSApss pk SHA256 +signatureCompatible (PubKeyRSA pk) RSA_PSS_RSAE_SHA384 = kxCanUseRSApss pk SHA384 +signatureCompatible (PubKeyRSA pk) RSA_PSS_RSAE_SHA512 = kxCanUseRSApss pk SHA512 +signatureCompatible (PubKeyDSA _) DSA_SHA1 = True +signatureCompatible (PubKeyEC _) sc = + sc + `elem` [ ECDSA_SHA1 + , ECDSA_SECP256R1_SHA256 + , ECDSA_SECP384R1_SHA384 + , ECDSA_SECP521R1_SHA512 + ] +signatureCompatible (PubKeyEd25519 _) ED25519 = True +signatureCompatible (PubKeyEd448 _) ED448 = True +signatureCompatible _ _ = False -- Whether the signature algorithm is for the type of the key, whatever -- its other parameters. @@ -86,53 +92,44 @@ -- which of the two a scheme is. The ML-DSA equations come first for the -- same reason -- an ML-DSA scheme fits no other kind of key, and one -- ML-DSA size does not fit another's key. -keyTypeFits :: PubKey -> HashAndSignatureAlgorithm -> Bool +keyTypeFits :: PubKey -> SignatureScheme -> Bool keyTypeFits (PubKeyMLDSA44 _) hs = hs == MLDSA44 keyTypeFits (PubKeyMLDSA65 _) hs = hs == MLDSA65 keyTypeFits (PubKeyMLDSA87 _) hs = hs == MLDSA87 keyTypeFits _ MLDSA44 = False keyTypeFits _ MLDSA65 = False keyTypeFits _ MLDSA87 = False -keyTypeFits (PubKeyRSA _) (_, s) = - s - `elem` [ SignatureRSA - , SignatureRSApssRSAeSHA256 - , SignatureRSApssRSAeSHA384 - , SignatureRSApssRSAeSHA512 - , SignatureRSApsspssSHA256 - , SignatureRSApsspssSHA384 - , SignatureRSApsspssSHA512 - ] -keyTypeFits (PubKeyDSA _) (_, s) = s == SignatureDSA -keyTypeFits (PubKeyEC _) (_, s) = s == SignatureECDSA -keyTypeFits (PubKeyEd25519 _) (_, s) = s == SignatureEd25519 -keyTypeFits (PubKeyEd448 _) (_, s) = s == SignatureEd448 +keyTypeFits (PubKeyRSA _) sc = sc `elem` (rsaPkcs1Schemes ++ rsaPssSchemes) +keyTypeFits (PubKeyDSA _) sc = sc `elem` dsaSchemes +keyTypeFits (PubKeyEC _) sc = sc `elem` ecdsaSchemes +keyTypeFits (PubKeyEd25519 _) sc = sc == ED25519 +keyTypeFits (PubKeyEd448 _) sc = sc == ED448 keyTypeFits _ _ = False -checkKeyTypeFits :: PubKey -> HashAndSignatureAlgorithm -> IO () +checkKeyTypeFits :: PubKey -> SignatureScheme -> IO () checkKeyTypeFits pubKey hs = unless (pubKey `keyTypeFits` hs) $ throwCore $ Error_Protocol - ( "signature algorithm " - ++ showSignatureScheme hs - ++ " is for another type of key" - ) + ("signature algorithm " ++ show hs ++ " is for another type of key") IllegalParameter -- Same as 'signatureCompatible' but for TLS13: for ECDSA this also checks the --- relation between hash in the HashAndSignatureAlgorithm and elliptic curve -signatureCompatible13 :: PubKey -> HashAndSignatureAlgorithm -> Bool -signatureCompatible13 (PubKeyEC ecPub) (h, SignatureECDSA) = - maybe False (\g -> findEllipticCurveGroup ecPub == Just g) (hashCurve h) +-- relation between hash in the SignatureScheme and elliptic curve +signatureCompatible13 :: PubKey -> SignatureScheme -> Bool +signatureCompatible13 (PubKeyEC ecPub) sc + | sc `elem` ecdsaSchemes = + maybe False (\g -> findEllipticCurveGroup ecPub == Just g) (schemeCurve sc) where - hashCurve HashSHA256 = Just P256 - hashCurve HashSHA384 = Just P384 - hashCurve HashSHA512 = Just P521 - hashCurve _ = Nothing + -- TLS 1.3 names the curve in the scheme; TLS 1.2 did not, and the three + -- schemes that do not name one cannot be used there. + schemeCurve ECDSA_SECP256R1_SHA256 = Just P256 + schemeCurve ECDSA_SECP384R1_SHA384 = Just P384 + schemeCurve ECDSA_SECP521R1_SHA512 = Just P521 + schemeCurve _ = Nothing signatureCompatible13 pub hs = signatureCompatible pub hs --- | Translate a 'HashAndSignatureAlgorithm' to an acceptable 'CertificateType'. +-- | Translate a 'SignatureScheme' to an acceptable 'CertificateType'. -- Perhaps this needs to take supported groups into account, so that, for -- example, if we don't support any shared ECDSA groups with the server, we -- return 'Nothing' rather than 'CertificateType_ECDSA_Sign'. @@ -150,23 +147,22 @@ -- @RSA@ as the only supported client certificate algorithm for TLS 1.3. -- -- FIXME: Add RSA_PSS_PSS signatures when supported. -hashSigToCertType :: HashAndSignatureAlgorithm -> Maybe CertificateType --- -hashSigToCertType (_, SignatureRSA) = Just CertificateType_RSA_Sign --- -hashSigToCertType (_, SignatureDSA) = Just CertificateType_DSA_Sign +hashSigToCertType :: SignatureScheme -> Maybe CertificateType -- -hashSigToCertType (_, SignatureECDSA) = Just CertificateType_ECDSA_Sign +hashSigToCertType sc + | sc `elem` rsaPkcs1Schemes = Just CertificateType_RSA_Sign + | sc `elem` dsaSchemes = Just CertificateType_DSA_Sign + | sc `elem` ecdsaSchemes = Just CertificateType_ECDSA_Sign -- -hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA256) = +hashSigToCertType RSA_PSS_RSAE_SHA256 = Just CertificateType_RSA_Sign -hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA384) = +hashSigToCertType RSA_PSS_RSAE_SHA384 = Just CertificateType_RSA_Sign -hashSigToCertType (HashIntrinsic, SignatureRSApssRSAeSHA512) = +hashSigToCertType RSA_PSS_RSAE_SHA512 = Just CertificateType_RSA_Sign -hashSigToCertType (HashIntrinsic, SignatureEd25519) = +hashSigToCertType ED25519 = Just CertificateType_Ed25519_Sign -hashSigToCertType (HashIntrinsic, SignatureEd448) = +hashSigToCertType ED448 = Just CertificateType_Ed448_Sign -- hashSigToCertType _ = Nothing @@ -189,7 +185,7 @@ when (usedVersion < TLS13 && isMLDSA hashSigAlg) $ throwCore $ Error_Protocol - ("signature algorithm " ++ showSignatureScheme hashSigAlg ++ " is not for " ++ show usedVersion) + ("signature algorithm " ++ show hashSigAlg ++ " is not for " ++ show usedVersion) IllegalParameter checkSupportedHashSignature ctx hashSigAlg checkKeyTypeFits pubKey hashSigAlg @@ -205,7 +201,7 @@ :: Context -> Version -> PubKey - -> HashAndSignatureAlgorithm -- TLS12 only + -> SignatureScheme -- TLS12 only -> ByteString -> IO DigitallySigned createCertificateVerify ctx usedVersion pubKey hashSigAlg msgs = @@ -224,55 +220,56 @@ :: Context -> Version -> PubKey - -> HashAndSignatureAlgorithm -- TLS12 only + -> SignatureScheme -- TLS12 only -> ByteString -> IO CertVerifyData prepareCertificateVerifySignatureData _ctx _usedVersion pubKey hashSigAlg msgs = return (signatureParams pubKey hashSigAlg, msgs) -signatureParams :: PubKey -> HashAndSignatureAlgorithm -> SignatureParams +signatureParams :: PubKey -> SignatureScheme -> SignatureParams -- Which of these is used is decided by the key, and signatureCompatible has -- already refused a scheme that does not fit the key, so an ML-DSA scheme -- cannot arrive at a clause for another kind of key. signatureParams (PubKeyRSA _) hashSigAlg = case hashSigAlg of - (HashSHA512, SignatureRSA) -> RSAParams SHA512 RSApkcs1 - (HashSHA384, SignatureRSA) -> RSAParams SHA384 RSApkcs1 - (HashSHA256, SignatureRSA) -> RSAParams SHA256 RSApkcs1 - (HashSHA1, SignatureRSA) -> RSAParams SHA1 RSApkcs1 - (HashIntrinsic, SignatureRSApssRSAeSHA512) -> RSAParams SHA512 RSApss - (HashIntrinsic, SignatureRSApssRSAeSHA384) -> RSAParams SHA384 RSApss - (HashIntrinsic, SignatureRSApssRSAeSHA256) -> RSAParams SHA256 RSApss - (hsh, SignatureRSA) -> error ("unimplemented RSA signature hash type: " ++ show hsh) - (_, sigAlg) -> - error ("signature algorithm is incompatible with RSA: " ++ show sigAlg) + RSA_PKCS1_SHA512 -> RSAParams SHA512 RSApkcs1 + RSA_PKCS1_SHA384 -> RSAParams SHA384 RSApkcs1 + RSA_PKCS1_SHA256 -> RSAParams SHA256 RSApkcs1 + RSA_PKCS1_SHA1 -> RSAParams SHA1 RSApkcs1 + RSA_PSS_RSAE_SHA512 -> RSAParams SHA512 RSApss + RSA_PSS_RSAE_SHA384 -> RSAParams SHA384 RSApss + RSA_PSS_RSAE_SHA256 -> RSAParams SHA256 RSApss + sc + | sc `elem` rsaPkcs1Schemes || sc `elem` rsaPssSchemes -> + error ("unimplemented RSA signature scheme: " ++ show sc) + | otherwise -> + error ("signature scheme is incompatible with RSA: " ++ show sc) signatureParams (PubKeyDSA _) hashSigAlg = case hashSigAlg of - (HashSHA1, SignatureDSA) -> DSAParams - (_, SignatureDSA) -> error "invalid DSA hash choice, only SHA1 allowed" - (_, sigAlg) -> - error ("signature algorithm is incompatible with DSA: " ++ show sigAlg) + DSA_SHA1 -> DSAParams + sc + | sc `elem` dsaSchemes -> error "invalid DSA hash choice, only SHA1 allowed" + | otherwise -> + error ("signature scheme is incompatible with DSA: " ++ show sc) signatureParams (PubKeyEC _) hashSigAlg = case hashSigAlg of - (HashSHA512, SignatureECDSA) -> ECDSAParams SHA512 - (HashSHA384, SignatureECDSA) -> ECDSAParams SHA384 - (HashSHA256, SignatureECDSA) -> ECDSAParams SHA256 - (HashSHA1, SignatureECDSA) -> ECDSAParams SHA1 - (hsh, SignatureECDSA) -> error ("unimplemented ECDSA signature hash type: " ++ show hsh) - (_, sigAlg) -> - error ("signature algorithm is incompatible with ECDSA: " ++ show sigAlg) + ECDSA_SECP521R1_SHA512 -> ECDSAParams SHA512 + ECDSA_SECP384R1_SHA384 -> ECDSAParams SHA384 + ECDSA_SECP256R1_SHA256 -> ECDSAParams SHA256 + ECDSA_SHA1 -> ECDSAParams SHA1 + sc + | sc `elem` ecdsaSchemes -> + error ("unimplemented ECDSA signature scheme: " ++ show sc) + | otherwise -> + error ("signature scheme is incompatible with ECDSA: " ++ show sc) signatureParams (PubKeyEd25519 _) hashSigAlg = case hashSigAlg of - (HashIntrinsic, SignatureEd25519) -> Ed25519Params - (hsh, SignatureEd25519) -> error ("unimplemented Ed25519 signature hash type: " ++ show hsh) - (_, sigAlg) -> - error ("signature algorithm is incompatible with Ed25519: " ++ show sigAlg) + ED25519 -> Ed25519Params + sc -> error ("signature scheme is incompatible with Ed25519: " ++ show sc) signatureParams (PubKeyEd448 _) hashSigAlg = case hashSigAlg of - (HashIntrinsic, SignatureEd448) -> Ed448Params - (hsh, SignatureEd448) -> error ("unimplemented Ed448 signature hash type: " ++ show hsh) - (_, sigAlg) -> - error ("signature algorithm is incompatible with Ed448: " ++ show sigAlg) + ED448 -> Ed448Params + sc -> error ("signature scheme is incompatible with Ed448: " ++ show sc) signatureParams (PubKeyMLDSA44 _) MLDSA44 = MLDSA44Params signatureParams (PubKeyMLDSA65 _) MLDSA65 = MLDSA65Params signatureParams (PubKeyMLDSA87 _) MLDSA87 = MLDSA87Params @@ -280,11 +277,12 @@ signatureCreateWithCertVerifyData :: Context - -> HashAndSignatureAlgorithm + -> SignatureScheme -> CertVerifyData -> IO DigitallySigned signatureCreateWithCertVerifyData ctx malg (sigParam, toSign) = do role <- usingState_ ctx getRole + usingHState ctx $ setSignatureScheme role malg DigitallySigned malg <$> signPrivate ctx role sigParam toSign signatureVerify :: Context -> DigitallySigned -> PubKey -> ByteString -> IO Bool @@ -314,13 +312,17 @@ -> IO Bool signatureVerifyWithCertVerifyData ctx (DigitallySigned hs bs) (sigParam, toVerify) = do checkSupportedHashSignature ctx hs - verifyPublic ctx sigParam toVerify bs + ok <- verifyPublic ctx sigParam toVerify bs + when ok $ do + role <- usingState_ ctx getRole + usingHState ctx $ setSignatureScheme (invertRole role) hs + return ok digitallySignParams :: Context -> ByteString -> PubKey - -> HashAndSignatureAlgorithm + -> SignatureScheme -> IO DigitallySigned digitallySignParams ctx signatureData pubKey hashSigAlg = let sigParam = signatureParams pubKey hashSigAlg @@ -333,7 +335,7 @@ :: Context -> ServerDHParams -> PubKey - -> HashAndSignatureAlgorithm -- TLS12 only + -> SignatureScheme -- TLS12 only -> IO DigitallySigned digitallySignDHParams ctx serverParams pubKey mhash = do dhParamsData <- @@ -344,7 +346,7 @@ :: Context -> ServerECDHParams -> PubKey - -> HashAndSignatureAlgorithm -- TLS12 only + -> SignatureScheme -- TLS12 only -> IO DigitallySigned digitallySignECDHParams ctx serverParams pubKey mhash = do ecdhParamsData <- @@ -384,8 +386,8 @@ -- verify that the hash and signature selected by the peer is supported in -- the local configuration checkSupportedHashSignature - :: Context -> HashAndSignatureAlgorithm -> IO () + :: Context -> SignatureScheme -> IO () checkSupportedHashSignature ctx hs = unless (hs `elem` supportedHashSignatures (ctxSupported ctx)) $ - let msg = "unsupported hash and signature algorithm: " ++ showSignatureScheme hs + let msg = "unsupported hash and signature algorithm: " ++ show hs in throwCore $ Error_Protocol msg IllegalParameter 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 @@ -48,6 +48,7 @@ setCertReqCBdata, getCertReqCBdata, setCertReqSigAlgsCert, + setSignatureScheme, getCertReqSigAlgsCert, -- * digest accessors @@ -135,7 +136,7 @@ -- ^ Set to Just-value when a TLS13 certificate request is received , hstCertReqCBdata :: Maybe CertReqCBdata -- ^ Set to Just-value when a certificate request is received - , hstCertReqSigAlgsCert :: Maybe [HashAndSignatureAlgorithm] + , hstCertReqSigAlgsCert :: Maybe [SignatureScheme] -- ^ In TLS 1.3, these are separate from the certificate -- issuer signature algorithm hints in the callback data. -- In TLS 1.2 the same list is overloaded for both purposes. @@ -148,6 +149,9 @@ , hstClientCertChain :: Maybe CertificateChain , hstPendingTxState :: Maybe RecordState , hstPendingRxState :: Maybe RecordState + , hstServerSignatureScheme :: Maybe SignatureScheme + , hstClientSignatureScheme :: Maybe SignatureScheme + -- ^ The schemes of the handshake signatures each side made , hstRxSwitched :: Bool -- ^ Set when the peer's ChangeCipherSpec switched the Rx state , hstPendingCipher :: Maybe Cipher @@ -215,7 +219,7 @@ -- present Ed25519 and Ed448 certificates when these become supported. type CertReqCBdata = ( [CertificateType] - , Maybe [HashAndSignatureAlgorithm] + , Maybe [SignatureScheme] , [DistinguishedName] ) @@ -251,6 +255,8 @@ , hstClientCertChain = Nothing , hstPendingTxState = Nothing , hstPendingRxState = Nothing + , hstServerSignatureScheme = Nothing + , hstClientSignatureScheme = Nothing , hstRxSwitched = False , hstPendingCipher = Nothing , hstPendingCompression = nullCompression @@ -448,11 +454,16 @@ getCertReqCBdata :: HandshakeM (Maybe CertReqCBdata) getCertReqCBdata = gets hstCertReqCBdata +-- | Record the scheme of a handshake signature that the given side made. +setSignatureScheme :: Role -> SignatureScheme -> HandshakeM () +setSignatureScheme ServerRole sc = modify' $ \hst -> hst{hstServerSignatureScheme = Just sc} +setSignatureScheme ClientRole sc = modify' $ \hst -> hst{hstClientSignatureScheme = Just sc} + -- Dead code, until we find some use for the extension -setCertReqSigAlgsCert :: Maybe [HashAndSignatureAlgorithm] -> HandshakeM () +setCertReqSigAlgsCert :: Maybe [SignatureScheme] -> HandshakeM () setCertReqSigAlgsCert as = modify' $ \hst -> hst{hstCertReqSigAlgsCert = as} -getCertReqSigAlgsCert :: HandshakeM (Maybe [HashAndSignatureAlgorithm]) +getCertReqSigAlgsCert :: HandshakeM (Maybe [SignatureScheme]) getCertReqSigAlgsCert = gets hstCertReqSigAlgsCert -- 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 @@ -13,6 +13,7 @@ setRxRecordState, getTxLevel, getRxLevel, + getTxSequence, clearTxRecordState, clearRxRecordState, PendingRecvAction (..), @@ -54,6 +55,12 @@ -- So, fromJust causes an error. getTxLevel :: Context -> IO CryptLevel getTxLevel ctx = getXLevel ctx ctxTxRecordState + +-- | The cipher, the level and the sequence number of the next record sent. +getTxSequence :: Context -> IO (Maybe Cipher, CryptLevel, Word64) +getTxSequence ctx = do + tx <- readMVar $ ctxTxRecordState ctx + return (stCipher tx, stCryptLevel tx, msSequence $ stMacState tx) getRxLevel :: Context -> IO CryptLevel getRxLevel ctx = getXLevel ctx ctxRxRecordState diff --git a/Network/TLS/HashAndSignature.hs b/Network/TLS/HashAndSignature.hs deleted file mode 100644 --- a/Network/TLS/HashAndSignature.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# LANGUAGE PatternSynonyms #-} - -module Network.TLS.HashAndSignature ( - HashAlgorithm ( - .., - HashNone, - HashMD5, - HashSHA1, - HashSHA224, - HashSHA256, - HashSHA384, - HashSHA512, - HashIntrinsic, - HashMLDSA - ), - SignatureAlgorithm ( - .., - SignatureAnonymous, - SignatureRSA, - SignatureDSA, - SignatureECDSA, - SignatureRSApssRSAeSHA256, - SignatureRSApssRSAeSHA384, - SignatureRSApssRSAeSHA512, - SignatureEd25519, - SignatureEd448, - SignatureRSApsspssSHA256, - SignatureRSApsspssSHA384, - SignatureRSApsspssSHA512, - SignatureBrainpoolP256, - SignatureBrainpoolP384, - SignatureBrainpoolP512 - ), - HashAndSignatureAlgorithm, - pattern MLDSA44, - pattern MLDSA65, - pattern MLDSA87, - supportedSignatureSchemes, - signatureSchemesForTLS13, - isMLDSA, - showSignatureScheme, -) where - -import Network.TLS.Imports - ------------------------------------------------------------- - -newtype HashAlgorithm = HashAlgorithm {fromHashAlgorithm :: Word8} - deriving (Eq) - -{- FOURMOLU_DISABLE -} -pattern HashNone :: HashAlgorithm -pattern HashNone = HashAlgorithm 0 -pattern HashMD5 :: HashAlgorithm -pattern HashMD5 = HashAlgorithm 1 -pattern HashSHA1 :: HashAlgorithm -pattern HashSHA1 = HashAlgorithm 2 -pattern HashSHA224 :: HashAlgorithm -pattern HashSHA224 = HashAlgorithm 3 -pattern HashSHA256 :: HashAlgorithm -pattern HashSHA256 = HashAlgorithm 4 -pattern HashSHA384 :: HashAlgorithm -pattern HashSHA384 = HashAlgorithm 5 -pattern HashSHA512 :: HashAlgorithm -pattern HashSHA512 = HashAlgorithm 6 -pattern HashIntrinsic :: HashAlgorithm -pattern HashIntrinsic = HashAlgorithm 8 -pattern HashMLDSA :: HashAlgorithm -- not a hash; see MLDSA44 below -pattern HashMLDSA = HashAlgorithm 9 - -instance Show HashAlgorithm where - show HashNone = "None" - show HashMD5 = "MD5" - show HashSHA1 = "SHA1" - show HashSHA224 = "SHA224" - show HashSHA256 = "SHA256" - show HashSHA384 = "SHA384" - show HashSHA512 = "SHA512" - show HashIntrinsic = "TLS13" - show HashMLDSA = "MLDSA" - show (HashAlgorithm x) = "Hash " ++ show x -{- FOURMOLU_ENABLE -} - ------------------------------------------------------------- - -newtype SignatureAlgorithm = SignatureAlgorithm {fromSignatureAlgorithm :: Word8} - deriving (Eq) - -{- FOURMOLU_DISABLE -} -pattern SignatureAnonymous :: SignatureAlgorithm -pattern SignatureAnonymous = SignatureAlgorithm 0 -pattern SignatureRSA :: SignatureAlgorithm -pattern SignatureRSA = SignatureAlgorithm 1 -pattern SignatureDSA :: SignatureAlgorithm -pattern SignatureDSA = SignatureAlgorithm 2 -pattern SignatureECDSA :: SignatureAlgorithm -pattern SignatureECDSA = SignatureAlgorithm 3 --- TLS 1.3 from here -pattern SignatureRSApssRSAeSHA256 :: SignatureAlgorithm -pattern SignatureRSApssRSAeSHA256 = SignatureAlgorithm 4 -pattern SignatureRSApssRSAeSHA384 :: SignatureAlgorithm -pattern SignatureRSApssRSAeSHA384 = SignatureAlgorithm 5 -pattern SignatureRSApssRSAeSHA512 :: SignatureAlgorithm -pattern SignatureRSApssRSAeSHA512 = SignatureAlgorithm 6 -pattern SignatureEd25519 :: SignatureAlgorithm -pattern SignatureEd25519 = SignatureAlgorithm 7 -pattern SignatureEd448 :: SignatureAlgorithm -pattern SignatureEd448 = SignatureAlgorithm 8 -pattern SignatureRSApsspssSHA256 :: SignatureAlgorithm -pattern SignatureRSApsspssSHA256 = SignatureAlgorithm 9 -pattern SignatureRSApsspssSHA384 :: SignatureAlgorithm -pattern SignatureRSApsspssSHA384 = SignatureAlgorithm 10 -pattern SignatureRSApsspssSHA512 :: SignatureAlgorithm -pattern SignatureRSApsspssSHA512 = SignatureAlgorithm 11 -pattern SignatureBrainpoolP256 :: SignatureAlgorithm -- RFC8734 -pattern SignatureBrainpoolP256 = SignatureAlgorithm 26 -pattern SignatureBrainpoolP384 :: SignatureAlgorithm -pattern SignatureBrainpoolP384 = SignatureAlgorithm 27 -pattern SignatureBrainpoolP512 :: SignatureAlgorithm -pattern SignatureBrainpoolP512 = SignatureAlgorithm 28 - -instance Show SignatureAlgorithm where - show SignatureAnonymous = "Anonymous" - show SignatureRSA = "RSA" - show SignatureDSA = "DSA" - show SignatureECDSA = "ECDSA" - show SignatureRSApssRSAeSHA256 = "RSApssRSAeSHA256" - show SignatureRSApssRSAeSHA384 = "RSApssRSAeSHA384" - show SignatureRSApssRSAeSHA512 = "RSApssRSAeSHA512" - show SignatureEd25519 = "Ed25519" - show SignatureEd448 = "Ed448" - show SignatureRSApsspssSHA256 = "RSApsspssSHA256" - show SignatureRSApsspssSHA384 = "RSApsspssSHA384" - show SignatureRSApsspssSHA512 = "RSApsspssSHA512" - show SignatureBrainpoolP256 = "BrainpoolP256" - show SignatureBrainpoolP384 = "BrainpoolP384" - show SignatureBrainpoolP512 = "BrainpoolP512" - show (SignatureAlgorithm x) = "Signature " ++ show x -{- FOURMOLU_ENABLE -} - ------------------------------------------------------------- - -type HashAndSignatureAlgorithm = (HashAlgorithm, SignatureAlgorithm) - --- ML-DSA, from draft-ietf-tls-mldsa: mldsa44(0x0904), mldsa65(0x0905) and --- mldsa87(0x0906). --- --- These are named as whole pairs rather than as a new 'SignatureAlgorithm', --- because neither byte is what it is elsewhere: 0x09 is not a hash, and the --- second byte repeats numbers RSASSA-PSS already uses. Only the pair --- identifies the scheme, so only the pair is given a name, and code that --- decides anything about ML-DSA has to match on both bytes. - --- | Name a signature scheme. --- --- 'show' on the pair cannot do this for ML-DSA. A scheme is a 16-bit --- number that hs-tls carries as the two bytes it is made of, and for ML-DSA --- the size is in the second byte, whose values RSASSA-PSS also uses -- so --- the components alone render mldsa65 as @(MLDSA,RSApssRSAeSHA384)@, which --- names the wrong algorithm. Use this wherever a scheme is put in front of --- a person. -showSignatureScheme :: HashAndSignatureAlgorithm -> String -showSignatureScheme MLDSA44 = "mldsa44" -showSignatureScheme MLDSA65 = "mldsa65" -showSignatureScheme MLDSA87 = "mldsa87" -showSignatureScheme hs = show hs - --- | Is this one of the ML-DSA schemes? They are TLS 1.3 only, so the --- TLS 1.2 paths filter them out and refuse one that arrives anyway. -isMLDSA :: HashAndSignatureAlgorithm -> Bool -isMLDSA MLDSA44 = True -isMLDSA MLDSA65 = True -isMLDSA MLDSA87 = True -isMLDSA _ = False - -{- FOURMOLU_DISABLE -} -pattern MLDSA44 :: HashAndSignatureAlgorithm -pattern MLDSA44 = (HashMLDSA, SignatureAlgorithm 4) -pattern MLDSA65 :: HashAndSignatureAlgorithm -pattern MLDSA65 = (HashMLDSA, SignatureAlgorithm 5) -pattern MLDSA87 :: HashAndSignatureAlgorithm -pattern MLDSA87 = (HashMLDSA, SignatureAlgorithm 6) -{- FOURMOLU_ENABLE -} - -{- FOURMOLU_DISABLE -} -supportedSignatureSchemes :: [HashAndSignatureAlgorithm] -supportedSignatureSchemes = - -- ML-DSA algorithms, TLS 1.3 only - [ MLDSA87 -- mldsa87(0x0906) - , MLDSA65 -- mldsa65(0x0905) - , MLDSA44 -- mldsa44(0x0904) - -- EdDSA algorithms - , (HashIntrinsic, SignatureEd448) -- ed448 (0x0808) - , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807) - -- ECDSA algorithms - , (HashSHA512, SignatureECDSA) -- ecdsa_secp512r1_sha512(0x0603) - , (HashSHA384, SignatureECDSA) -- ecdsa_secp384r1_sha384(0x0503) - , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403) - -- RSASSA-PSS RSAE algorithms - , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_rsae_sha512(0x0806) - , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_rsae_sha384(0x0805) - , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- rsa_pss_rsae_sha256(0x0804) - -- RSASSA-PSS PSS algorithms with - , (HashIntrinsic, SignatureRSApsspssSHA512) -- rsa_pss_pss_sha512(0x080b) - , (HashIntrinsic, SignatureRSApsspssSHA384) -- rsa_pss_pss_sha384(0x080a) - , (HashIntrinsic, SignatureRSApsspssSHA256) -- rsa_pss_pss_sha256(0x0809) - -- RSASSA-PKCS1-v1_5 algorithms - , (HashSHA512, SignatureRSA) -- rsa_pkcs1_sha512(0x0601) - , (HashSHA384, SignatureRSA) -- rsa_pkcs1_sha384(0x0501) - , (HashSHA256, SignatureRSA) -- rsa_pkcs1_sha256(0x0401) - -- Legacy algorithms - , (HashSHA1, SignatureRSA) -- rsa_pkcs1_sha1 (0x0201) - , (HashSHA1, SignatureECDSA) -- ecdsa_sha1 (0x0203) - ] - -signatureSchemesForTLS13 :: [(HashAlgorithm, SignatureAlgorithm)] -signatureSchemesForTLS13 = - -- ML-DSA algorithms - [ MLDSA87 -- mldsa87(0x0906) - , MLDSA65 -- mldsa65(0x0905) - , MLDSA44 -- mldsa44(0x0904) - -- EdDSA algorithms - , (HashIntrinsic, SignatureEd448) -- ed448 (0x0808) - , (HashIntrinsic, SignatureEd25519) -- ed25519(0x0807) - -- ECDSA algorithms - , (HashSHA512, SignatureECDSA) -- ecdsa_secp512r1_sha512(0x0603) - , (HashSHA384, SignatureECDSA) -- ecdsa_secp384r1_sha384(0x0503) - , (HashSHA256, SignatureECDSA) -- ecdsa_secp256r1_sha256(0x0403) - -- RSASSA-PSS RSAE algorithms - , (HashIntrinsic, SignatureRSApssRSAeSHA512) -- rsa_pss_rsae_sha512(0x0806) - , (HashIntrinsic, SignatureRSApssRSAeSHA384) -- rsa_pss_rsae_sha384(0x0805) - , (HashIntrinsic, SignatureRSApssRSAeSHA256) -- rsa_pss_rsae_sha256(0x0804) - -- RSASSA-PSS PSS algorithms with - , (HashIntrinsic, SignatureRSApsspssSHA512) -- rsa_pss_pss_sha512(0x080b) - , (HashIntrinsic, SignatureRSApsspssSHA384) -- rsa_pss_pss_sha384(0x080a) - , (HashIntrinsic, SignatureRSApsspssSHA256) -- rsa_pss_pss_sha256(0x0809) - ] -{- FOURMOLU_ENABLE -} diff --git a/Network/TLS/Packet.hs b/Network/TLS/Packet.hs --- a/Network/TLS/Packet.hs +++ b/Network/TLS/Packet.hs @@ -40,8 +40,8 @@ generateKeyBlock, -- * for extensions parsing - getSignatureHashAlgorithm, - putSignatureHashAlgorithm, + getSignatureScheme, + putSignatureScheme, getBinaryVersion, putBinaryVersion, getClientRandom32, @@ -340,11 +340,11 @@ decodeCertRequest :: CurrentParams -> Get Handshake decodeCertRequest _cp = do certTypes <- map CertificateType <$> getWords8 - sigHashAlgs <- getWord16 >>= getSignatureHashAlgorithms + sigHashAlgs <- getWord16 >>= getSignatureSchemes CertRequest certTypes sigHashAlgs <$> getDNames where - getSignatureHashAlgorithms len = - getList (fromIntegral len) (getSignatureHashAlgorithm >>= \sh -> return (2, sh)) + getSignatureSchemes len = + getList (fromIntegral len) (getSignatureScheme >>= \sh -> return (2, sh)) ---- @@ -430,11 +430,7 @@ _ -> error ("encodeHandshake': cannot handle: " ++ show skg) encodeHandshake' (CertRequest certTypes sigAlgs certAuthorities) = runPut $ do putWords8 (map fromCertificateType certTypes) - putWords16 $ - map - ( \(HashAlgorithm x, SignatureAlgorithm y) -> fromIntegral x * 256 + fromIntegral y - ) - sigAlgs + putWords16 $ map fromSignatureScheme sigAlgs putDNames certAuthorities encodeHandshake' ServerHelloDone = "" encodeHandshake' (CertVerify digitallySigned) = runPut $ putDigitallySigned digitallySigned @@ -530,15 +526,14 @@ ------------------------------------------------------------ -getSignatureHashAlgorithm :: Get HashAndSignatureAlgorithm -getSignatureHashAlgorithm = do - h <- HashAlgorithm <$> getWord8 - s <- SignatureAlgorithm <$> getWord8 - return (h, s) +-- | A scheme is one 16-bit number. It used to be read as two bytes, +-- because TLS 1.2 called them a hash and a signature algorithm, and that is +-- the reading that made @mldsa87@ arrive as @rsa_pss_rsae_sha512@. +getSignatureScheme :: Get SignatureScheme +getSignatureScheme = SignatureScheme <$> getWord16 -putSignatureHashAlgorithm :: HashAndSignatureAlgorithm -> Put -putSignatureHashAlgorithm (HashAlgorithm h, SignatureAlgorithm s) = - putWord8 h >> putWord8 s +putSignatureScheme :: SignatureScheme -> Put +putSignatureScheme = putWord16 . fromSignatureScheme ------------------------------------------------------------ @@ -576,12 +571,12 @@ getDigitallySigned :: Version -> Get DigitallySigned getDigitallySigned _ver = DigitallySigned - <$> getSignatureHashAlgorithm + <$> getSignatureScheme <*> getOpaque16 putDigitallySigned :: DigitallySigned -> Put putDigitallySigned (DigitallySigned h sig) = - putSignatureHashAlgorithm h >> putOpaque16 sig + putSignatureScheme h >> putOpaque16 sig ------------------------------------------------------------ diff --git a/Network/TLS/Packet13.hs b/Network/TLS/Packet13.hs --- a/Network/TLS/Packet13.hs +++ b/Network/TLS/Packet13.hs @@ -73,7 +73,7 @@ putOpaque8 reqctx putExtensions exts encodeHandshake13' (CertVerify13 (DigitallySigned hs sig)) = runPut $ do - putSignatureHashAlgorithm hs + putSignatureScheme hs putOpaque16 sig encodeHandshake13' (Finished13 (VerifyData dat)) = runPut $ putBytes dat encodeHandshake13' (KeyUpdate13 UpdateNotRequested) = runPut $ putWord8 0 @@ -209,7 +209,7 @@ decodeCertVerify13 :: Get Handshake13 decodeCertVerify13 = - CertVerify13 <$> (DigitallySigned <$> getSignatureHashAlgorithm <*> getOpaque16) + CertVerify13 <$> (DigitallySigned <$> getSignatureScheme <*> getOpaque16) decodeFinished13 :: Get Handshake13 decodeFinished13 = Finished13 . VerifyData <$> (remaining >>= getBytes) diff --git a/Network/TLS/Parameters.hs b/Network/TLS/Parameters.hs --- a/Network/TLS/Parameters.hs +++ b/Network/TLS/Parameters.hs @@ -34,6 +34,7 @@ import Control.Concurrent (MVar, newMVar, withMVar) import Crypto.HPKE import Data.Default (Default (def)) +import Data.X509 (ExtKeyUsagePurpose (..)) import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) @@ -244,6 +245,11 @@ -- ^ Server accepts this size of early data in TLS 1.3. 0 (or -- lower) means that the server does not accept early data. -- + -- Early data can be replayed. The server is to accept 0-RTT for the + -- same handshake at most once (RFC 9846 Section 8), which is left to + -- 'sessionResumeOnlyOnce' of the session manager: the in-memory one of + -- tls-session-manager does so, its session ticket one does not. + -- -- Default: 0 , serverTicketLifetime :: Int -- ^ Lifetime in seconds for session tickets generated by the @@ -296,6 +302,48 @@ -- choice. -- -- Default: @[]@ + , supportedMinRSAKeySize :: Int + -- ^ The least size in bits of the RSA key in the peer's leaf + -- certificate. A shorter one is refused with bad_certificate; 0 lets + -- any size through. + -- + -- Default: 2048 + , supportedMaxRSAKeySize :: Int + -- ^ The largest size in bits of the RSA key in the peer's leaf + -- certificate. Verifying with a larger key costs more CPU, which the + -- peer chooses. A longer one is refused with bad_certificate; 0 lets + -- any size through. + -- + -- Default: 8192 + , supportedClientCertificatePurposes :: [ExtKeyUsagePurpose] + -- ^ Server only. A client's leaf certificate with Extended Key Usage + -- is refused with bad_certificate unless it allows one of these. + -- Adding 'KeyUsagePurpose_ServerAuth' accepts a server certificate. + -- + -- Default: @[KeyUsagePurpose_ClientAuth]@ + -- + -- @since 2.5.0 + , supportedMinDHKeySize :: Int + -- ^ The least size in bits of the prime of the DH parameters a TLS 1.2 + -- server sends. A smaller one is refused with insufficient_security + -- before 'onCustomFFDHEGroup' is called; 0 lets any size through. + -- + -- Default: 2048, the size of the smallest group of RFC 7919 + , supportedMaxDHKeySize :: Int + -- ^ The largest size in bits of the prime of the DH parameters a TLS + -- 1.2 server sends. Computing with a larger prime costs more CPU, + -- which the server chooses. A larger one is refused with + -- handshake_failure before 'onCustomFFDHEGroup' is called; 0 lets any + -- size through. + -- + -- Default: 8192, the size of the largest group of RFC 7919 + , supportedClientCipherOrder :: Bool + -- ^ Whether a server chooses among the ciphers in common in the + -- client's order of preference, rather than in the order of + -- 'supportedCiphers'. A client without AES acceleration can then get + -- ChaCha20-Poly1305 from a server that has it. + -- + -- Default: 'False' , supportedCompressions :: [Compression] -- ^ Supported compressions methods. By default only the "null" -- compression is supported, which means no compression will be @@ -303,7 +351,7 @@ -- it causes a connection failure when TLS 1.3 is negotiated. -- -- Default: @[nullCompression]@ - , supportedHashSignatures :: [HashAndSignatureAlgorithm] + , supportedHashSignatures :: [SignatureScheme] -- ^ All supported hash/signature algorithms pair for client -- certificate verification and server signature in (EC)DHE, -- ordered by decreasing priority. @@ -322,24 +370,7 @@ -- will not be used even when listed in the parameter: MD5, SHA-1, -- SHA-224, RSA PKCS#1, DSA. -- - -- Default: - -- - -- @ - -- [ (HashIntrinsic, SignatureEd448) - -- , (HashIntrinsic, SignatureEd25519) - -- , (Struct.HashSHA256, SignatureECDSA) - -- , (Struct.HashSHA384, SignatureECDSA) - -- , (Struct.HashSHA512, SignatureECDSA) - -- , (HashIntrinsic, SignatureRSApssRSAeSHA512) - -- , (HashIntrinsic, SignatureRSApssRSAeSHA384) - -- , (HashIntrinsic, SignatureRSApssRSAeSHA256) - -- , (Struct.HashSHA512, SignatureRSA) - -- , (Struct.HashSHA384, SignatureRSA) - -- , (Struct.HashSHA256, SignatureRSA) - -- , (Struct.HashSHA1, SignatureRSA) - -- , (Struct.HashSHA1, SignatureDSA) - -- ] - -- @ + -- Default: 'supportedSignatureSchemes' , supportedSecureRenegotiation :: Bool -- ^ Secure renegotiation defined in RFC5746. If 'True', clients -- send the renegotiation_info extension. If 'True', servers @@ -450,6 +481,12 @@ Supported { supportedVersions = [TLS13, TLS12] , supportedCiphers = ciphersuite_default + , supportedMinRSAKeySize = 2048 + , supportedMaxRSAKeySize = 8192 + , supportedClientCertificatePurposes = [KeyUsagePurpose_ClientAuth] + , supportedMinDHKeySize = 2048 + , supportedMaxDHKeySize = 8192 + , supportedClientCipherOrder = False , supportedCompressions = [nullCompression] , supportedHashSignatures = Struct.supportedSignatureSchemes , supportedSecureRenegotiation = True @@ -566,7 +603,7 @@ -- document readable. type OnCertificateRequest = ( [CertificateType] - , Maybe [HashAndSignatureAlgorithm] + , Maybe [SignatureScheme] , [DistinguishedName] ) -> IO (Maybe (CertificateChain, PrivKey)) @@ -611,7 +648,7 @@ -- -- The public key in the first certificate, and the matching -- returned private key must be compatible with one of the list of - -- 'HashAndSignatureAlgorithm' value when provided. TLS 1.3 + -- 'SignatureScheme' value when provided. TLS 1.3 -- changes the meaning of the list elements, adding explicit code -- points for each supported pair of hash and signature (public -- key) algorithms, rather than combining separate codes for the @@ -624,14 +661,21 @@ -- -- While the TLS version is not provided to the callback, the -- content of the @signature_algorithms@ list provides a strong - -- hint, since TLS 1.3 servers will generally list RSA pairs with - -- a hash component of 'Intrinsic' (@0x08@). + -- hint, since TLS 1.3 servers will generally list the RSASSA-PSS + -- schemes, whose first octet is @0x08@. -- -- Note that is is the responsibility of this action to select a -- certificate matching one of the requested certificate types -- (public key algorithms). Returning a non-matching one will -- lead to handshake failure later. -- + -- 'sharedCredentials' is for servers: a client sends the certificate + -- this action returns, for example one loaded from files. The CA of + -- the server belongs in 'sharedCAStore'. + -- + -- > cred <- either error id <$> credentialLoadX509 "client.crt" "client.key" + -- > let hooks = defaultClientHooks{onCertificateRequest = \_ -> return (Just cred)} + -- -- Default: returns 'Nothing' anyway. , onServerCertificate :: OnServerCertificate -- ^ Used by the client to validate the server certificate. The @@ -863,6 +907,12 @@ , infoTLS13HandshakeMode :: Maybe HandshakeMode13 , infoIsEarlyDataAccepted :: Bool , infoIsECHAccepted :: Bool + , infoServerSignatureScheme :: Maybe SignatureScheme + -- ^ The scheme of the server's signature: ServerKeyExchange in TLS 1.2, + -- CertificateVerify in TLS 1.3. 'Nothing' on resumption. + , infoClientSignatureScheme :: Maybe SignatureScheme + -- ^ The scheme of the client's CertificateVerify. 'Nothing' without a + -- client certificate or on resumption. } deriving (Show, Eq) @@ -896,6 +946,15 @@ -- disable the limit; they do not disable KeyUpdate processing. -- -- Default: @Just 32@ + , limitRecordsPerKey :: Maybe Word64 + -- ^ The number of TLS 1.3 records sent under a set of keys, after which + -- they are updated with KeyUpdate (RFC 9846 Section 5.5). Early data, + -- which cannot update its keys, is refused there. 'Nothing' means the + -- limit for the cipher: 2^24 for AES and 2^62 for ChaCha20-Poly1305. + -- + -- Default: 'Nothing' + -- + -- @since 2.5.0 } deriving (Eq, Show) @@ -906,4 +965,5 @@ { limitRecordSize = Nothing , limitHandshakeFragment = 2048 , limitKeyUpdate = Just 32 + , limitRecordsPerKey = Nothing } diff --git a/Network/TLS/PostHandshake.hs b/Network/TLS/PostHandshake.hs --- a/Network/TLS/PostHandshake.hs +++ b/Network/TLS/PostHandshake.hs @@ -1,6 +1,8 @@ module Network.TLS.PostHandshake ( requestCertificate, requestCertificateServer, + requestCertificateAsync, + requestCertificateAsyncServer, postHandshakeAuthWith, postHandshakeAuthClientWith, ) where @@ -15,13 +17,32 @@ ---------------------------------------------------------------- -- | Post-handshake certificate request with TLS 1.3. Returns 'False' --- if the request was impossible, i.e. the remote client supports +-- if the request was impossible, i.e. the remote client does not support -- post-handshake authentication or the connection is established in -- TLS 1.2. Returns 'True' if the client authentication succeeds. An -- exception is thrown if the authentication fails. Server only. +-- +-- This reads the client's response by itself, so it must not be called +-- while another thread is in 'recvData', and application data received +-- before the response closes the connection, against RFC 9846 Section 4.7.2. +{-# DEPRECATED + requestCertificate + "Application data before the response closes the connection; use requestCertificateAsync" + #-} requestCertificate :: Context -> IO Bool requestCertificate ctx = checkValid ctx >> doRequestCertificate_ (ctxRoleParams ctx) ctx + +-- | Post-handshake certificate request with TLS 1.3, without waiting for +-- the response. The response is processed by 'recvData', so another +-- thread or the caller itself must keep calling it. The returned action +-- gives the result; with 'True' it blocks until the result is known, with +-- 'False' it returns 'PHAPending' meanwhile. Only one request may be +-- pending. 'getClientCertificateChain' gives the authenticated chain. +-- Server only. +requestCertificateAsync :: Context -> IO (Bool -> IO PHAResult) +requestCertificateAsync ctx = + checkValid ctx >> doRequestCertificateAsync_ (ctxRoleParams ctx) ctx -- | Handle a post-handshake authentication flight with TLS 1.3. This -- is called automatically by 'recvData', in a context where the read diff --git a/Network/TLS/Session.hs b/Network/TLS/Session.hs --- a/Network/TLS/Session.hs +++ b/Network/TLS/Session.hs @@ -13,6 +13,7 @@ -- ^ Used on TLS 1.2\/1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'. , sessionResumeOnlyOnce :: SessionIDorTicket -> IO (Maybe SessionData) -- ^ Used for 0RTT on TLS 1.3 servers to lookup 'SessionData' with 'SessionID' or to decrypt 'Ticket' to get 'SessionData'. + -- It is to return the 'SessionData' at most once for an identity, or early data can be replayed (RFC 9846 Section 8); a manager that keeps no state, as with tickets, cannot. , sessionEstablish :: SessionIDorTicket -> SessionData -> IO (Maybe Ticket) -- ^ Used on TLS 1.2\/1.3 servers to store 'SessionData' with 'SessionID' or to encrypt 'SessionData' to get 'Ticket' ignoring 'SessionID'. Used on TLS 1.2\/1.3 clients to store 'SessionData' with 'SessionIDorTicket' and then return 'Nothing'. For clients, only this field should be set with 'noSessionManager'. , sessionInvalidate :: SessionIDorTicket -> IO () diff --git a/Network/TLS/SignatureScheme.hs b/Network/TLS/SignatureScheme.hs new file mode 100644 --- /dev/null +++ b/Network/TLS/SignatureScheme.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- | TLS signature schemes, as RFC 8446 section 4.2.3 and the IANA +-- TLS SignatureScheme registry name them. +module Network.TLS.SignatureScheme ( + SignatureScheme ( + .., + -- the schemes the IANA registry names + RSA_PKCS1_SHA1, + ECDSA_SHA1, + DSA_SHA1, + RSA_PKCS1_SHA256, + ECDSA_SECP256R1_SHA256, + RSA_PKCS1_SHA384, + ECDSA_SECP384R1_SHA384, + RSA_PKCS1_SHA512, + ECDSA_SECP521R1_SHA512, + RSA_PSS_RSAE_SHA256, + RSA_PSS_RSAE_SHA384, + RSA_PSS_RSAE_SHA512, + ED25519, + ED448, + RSA_PSS_PSS_SHA256, + RSA_PSS_PSS_SHA384, + RSA_PSS_PSS_SHA512, + ECDSA_BRAINPOOLP256R1TLS13_SHA256, + ECDSA_BRAINPOOLP384R1TLS13_SHA384, + ECDSA_BRAINPOOLP512R1TLS13_SHA512, + MLDSA44, + MLDSA65, + MLDSA87, + + -- the TLS 1.2 combinations it does not + RSA_PKCS1_MD5, + DSA_MD5, + ECDSA_MD5, + RSA_PKCS1_SHA224, + DSA_SHA224, + ECDSA_SHA224, + DSA_SHA256, + DSA_SHA384, + DSA_SHA512 + ), + HashAndSignatureAlgorithm, + supportedSignatureSchemes, + signatureSchemesForTLS13, + isMLDSA, + rsaPkcs1Schemes, + rsaPssSchemes, + dsaSchemes, + ecdsaSchemes, +) where + +import Numeric (showHex) + +import Network.TLS.Imports + +-- | A signature scheme: the 16-bit number that travels on the wire, with a +-- name for each one this library knows. +-- +-- A scheme is one number, not a hash and a signature algorithm. TLS 1.2 +-- read the two bytes separately and some of the values still line up that +-- way, but from TLS 1.3 the number is indivisible, and for ML-DSA neither +-- byte means what it does elsewhere -- 0x09 is no hash, and the second byte +-- repeats numbers RSASSA-PSS uses, so @mldsa87@ read byte by byte looks +-- like @rsa_pss_rsae_sha512@. Code that took the halves apart got that +-- wrong, which is why the halves are gone. +-- +-- The names are pattern synonyms with no @COMPLETE@ pragma, so a @case@ +-- over them needs a catch-all and a scheme named in a later release breaks +-- nothing that compiled against this one. 'Show' is written out for the +-- same reason: a program built against an older hs-tls still says something +-- useful about a scheme a newer one produced. +newtype SignatureScheme = SignatureScheme {fromSignatureScheme :: Word16} + deriving (Eq, Ord) + +{- FOURMOLU_DISABLE -} +pattern RSA_PKCS1_SHA1 :: SignatureScheme +pattern RSA_PKCS1_SHA1 = SignatureScheme 0x0201 -- RFC8446, legacy +pattern ECDSA_SHA1 :: SignatureScheme +pattern ECDSA_SHA1 = SignatureScheme 0x0203 -- RFC8446, legacy +pattern DSA_SHA1 :: SignatureScheme +pattern DSA_SHA1 = SignatureScheme 0x0202 -- TLS 1.2 only, no IANA name +pattern RSA_PKCS1_SHA256 :: SignatureScheme +pattern RSA_PKCS1_SHA256 = SignatureScheme 0x0401 +pattern ECDSA_SECP256R1_SHA256 :: SignatureScheme +pattern ECDSA_SECP256R1_SHA256 = SignatureScheme 0x0403 +pattern RSA_PKCS1_SHA384 :: SignatureScheme +pattern RSA_PKCS1_SHA384 = SignatureScheme 0x0501 +pattern ECDSA_SECP384R1_SHA384 :: SignatureScheme +pattern ECDSA_SECP384R1_SHA384 = SignatureScheme 0x0503 +pattern RSA_PKCS1_SHA512 :: SignatureScheme +pattern RSA_PKCS1_SHA512 = SignatureScheme 0x0601 +pattern ECDSA_SECP521R1_SHA512 :: SignatureScheme +pattern ECDSA_SECP521R1_SHA512 = SignatureScheme 0x0603 +pattern RSA_PSS_RSAE_SHA256 :: SignatureScheme +pattern RSA_PSS_RSAE_SHA256 = SignatureScheme 0x0804 +pattern RSA_PSS_RSAE_SHA384 :: SignatureScheme +pattern RSA_PSS_RSAE_SHA384 = SignatureScheme 0x0805 +pattern RSA_PSS_RSAE_SHA512 :: SignatureScheme +pattern RSA_PSS_RSAE_SHA512 = SignatureScheme 0x0806 +pattern ED25519 :: SignatureScheme +pattern ED25519 = SignatureScheme 0x0807 +pattern ED448 :: SignatureScheme +pattern ED448 = SignatureScheme 0x0808 +pattern RSA_PSS_PSS_SHA256 :: SignatureScheme +pattern RSA_PSS_PSS_SHA256 = SignatureScheme 0x0809 +pattern RSA_PSS_PSS_SHA384 :: SignatureScheme +pattern RSA_PSS_PSS_SHA384 = SignatureScheme 0x080a +pattern RSA_PSS_PSS_SHA512 :: SignatureScheme +pattern RSA_PSS_PSS_SHA512 = SignatureScheme 0x080b +pattern ECDSA_BRAINPOOLP256R1TLS13_SHA256 :: SignatureScheme +pattern ECDSA_BRAINPOOLP256R1TLS13_SHA256 = SignatureScheme 0x081a -- RFC8734 +pattern ECDSA_BRAINPOOLP384R1TLS13_SHA384 :: SignatureScheme +pattern ECDSA_BRAINPOOLP384R1TLS13_SHA384 = SignatureScheme 0x081b -- RFC8734 +pattern ECDSA_BRAINPOOLP512R1TLS13_SHA512 :: SignatureScheme +pattern ECDSA_BRAINPOOLP512R1TLS13_SHA512 = SignatureScheme 0x081c -- RFC8734 +pattern MLDSA44 :: SignatureScheme +pattern MLDSA44 = SignatureScheme 0x0904 -- draft-ietf-tls-mldsa +pattern MLDSA65 :: SignatureScheme +pattern MLDSA65 = SignatureScheme 0x0905 -- draft-ietf-tls-mldsa +pattern MLDSA87 :: SignatureScheme +pattern MLDSA87 = SignatureScheme 0x0906 -- draft-ietf-tls-mldsa + +-- TLS 1.2 wrote a hash and a signature algorithm, and some of the +-- combinations it allowed are schemes the registry never named. They still +-- turn up: a certificate can be signed with one, and the peer's +-- signature_algorithms list is matched against the number. +pattern RSA_PKCS1_MD5 :: SignatureScheme +pattern RSA_PKCS1_MD5 = SignatureScheme 0x0101 +pattern DSA_MD5 :: SignatureScheme +pattern DSA_MD5 = SignatureScheme 0x0102 +pattern ECDSA_MD5 :: SignatureScheme +pattern ECDSA_MD5 = SignatureScheme 0x0103 +pattern RSA_PKCS1_SHA224 :: SignatureScheme +pattern RSA_PKCS1_SHA224 = SignatureScheme 0x0301 +pattern DSA_SHA224 :: SignatureScheme +pattern DSA_SHA224 = SignatureScheme 0x0302 +pattern ECDSA_SHA224 :: SignatureScheme +pattern ECDSA_SHA224 = SignatureScheme 0x0303 +pattern DSA_SHA256 :: SignatureScheme +pattern DSA_SHA256 = SignatureScheme 0x0402 +pattern DSA_SHA384 :: SignatureScheme +pattern DSA_SHA384 = SignatureScheme 0x0502 +pattern DSA_SHA512 :: SignatureScheme +pattern DSA_SHA512 = SignatureScheme 0x0602 + +-- | The IANA name, and the number for a scheme this release does not know. +instance Show SignatureScheme where + show RSA_PKCS1_SHA1 = "rsa_pkcs1_sha1" + show ECDSA_SHA1 = "ecdsa_sha1" + show DSA_SHA1 = "dsa_sha1" + show RSA_PKCS1_SHA256 = "rsa_pkcs1_sha256" + show ECDSA_SECP256R1_SHA256 = "ecdsa_secp256r1_sha256" + show RSA_PKCS1_SHA384 = "rsa_pkcs1_sha384" + show ECDSA_SECP384R1_SHA384 = "ecdsa_secp384r1_sha384" + show RSA_PKCS1_SHA512 = "rsa_pkcs1_sha512" + show ECDSA_SECP521R1_SHA512 = "ecdsa_secp521r1_sha512" + show RSA_PSS_RSAE_SHA256 = "rsa_pss_rsae_sha256" + show RSA_PSS_RSAE_SHA384 = "rsa_pss_rsae_sha384" + show RSA_PSS_RSAE_SHA512 = "rsa_pss_rsae_sha512" + show ED25519 = "ed25519" + show ED448 = "ed448" + show RSA_PSS_PSS_SHA256 = "rsa_pss_pss_sha256" + show RSA_PSS_PSS_SHA384 = "rsa_pss_pss_sha384" + show RSA_PSS_PSS_SHA512 = "rsa_pss_pss_sha512" + show ECDSA_BRAINPOOLP256R1TLS13_SHA256 = "ecdsa_brainpoolP256r1tls13_sha256" + show ECDSA_BRAINPOOLP384R1TLS13_SHA384 = "ecdsa_brainpoolP384r1tls13_sha384" + show ECDSA_BRAINPOOLP512R1TLS13_SHA512 = "ecdsa_brainpoolP512r1tls13_sha512" + show MLDSA44 = "mldsa44" + show MLDSA65 = "mldsa65" + show MLDSA87 = "mldsa87" + show RSA_PKCS1_MD5 = "rsa_pkcs1_md5" + show DSA_MD5 = "dsa_md5" + show ECDSA_MD5 = "ecdsa_md5" + show RSA_PKCS1_SHA224 = "rsa_pkcs1_sha224" + show DSA_SHA224 = "dsa_sha224" + show ECDSA_SHA224 = "ecdsa_sha224" + show DSA_SHA256 = "dsa_sha256" + show DSA_SHA384 = "dsa_sha384" + show DSA_SHA512 = "dsa_sha512" + show (SignatureScheme n) = "signature_scheme(0x" ++ hex4 n ++ ")" +{- FOURMOLU_ENABLE -} + +-- | Four hexadecimal digits, as the IANA registry writes a code point. +hex4 :: Word16 -> String +hex4 n = replicate (4 - length digits) '0' ++ digits + where + digits = showHex n "" + +-- | Is this one of the ML-DSA schemes? They are TLS 1.3 only, so the +-- TLS 1.2 paths filter them out and refuse one that arrives anyway. +isMLDSA :: SignatureScheme -> Bool +isMLDSA MLDSA44 = True +isMLDSA MLDSA65 = True +isMLDSA MLDSA87 = True +isMLDSA _ = False + +{- FOURMOLU_DISABLE -} +-- | What a signature scheme used to be called, when it was a pair. +-- +-- Kept so that code which only names the type goes on compiling. Code that +-- took the pair apart cannot be helped by a synonym and has to say which +-- scheme it meant. +type HashAndSignatureAlgorithm = SignatureScheme +{-# DEPRECATED HashAndSignatureAlgorithm "Use SignatureScheme" #-} + +-- | The schemes an RSA key signs under with PKCS#1 v1.5. +rsaPkcs1Schemes :: [SignatureScheme] +rsaPkcs1Schemes = + [ RSA_PKCS1_MD5 + , RSA_PKCS1_SHA1 + , RSA_PKCS1_SHA224 + , RSA_PKCS1_SHA256 + , RSA_PKCS1_SHA384 + , RSA_PKCS1_SHA512 + ] + +-- | The schemes an RSA key signs under with PSS, under either kind of key. +rsaPssSchemes :: [SignatureScheme] +rsaPssSchemes = + [ RSA_PSS_RSAE_SHA256 + , RSA_PSS_RSAE_SHA384 + , RSA_PSS_RSAE_SHA512 + , RSA_PSS_PSS_SHA256 + , RSA_PSS_PSS_SHA384 + , RSA_PSS_PSS_SHA512 + ] + +-- | The schemes a DSA key signs under. +dsaSchemes :: [SignatureScheme] +dsaSchemes = + [ DSA_MD5 + , DSA_SHA1 + , DSA_SHA224 + , DSA_SHA256 + , DSA_SHA384 + , DSA_SHA512 + ] + +-- | The schemes an ECDSA key signs under. +ecdsaSchemes :: [SignatureScheme] +ecdsaSchemes = + [ ECDSA_MD5 + , ECDSA_SHA1 + , ECDSA_SHA224 + , ECDSA_SECP256R1_SHA256 + , ECDSA_SECP384R1_SHA384 + , ECDSA_SECP521R1_SHA512 + ] + +-- | What this library offers, best first. +supportedSignatureSchemes :: [SignatureScheme] +supportedSignatureSchemes = + -- ML-DSA, TLS 1.3 only + [ MLDSA87 + , MLDSA65 + , MLDSA44 + -- EdDSA + , ED448 + , ED25519 + -- ECDSA + , ECDSA_SECP521R1_SHA512 + , ECDSA_SECP384R1_SHA384 + , ECDSA_SECP256R1_SHA256 + -- RSASSA-PSS with an RSAE key + , RSA_PSS_RSAE_SHA512 + , RSA_PSS_RSAE_SHA384 + , RSA_PSS_RSAE_SHA256 + -- RSASSA-PSS with a PSS key + , RSA_PSS_PSS_SHA512 + , RSA_PSS_PSS_SHA384 + , RSA_PSS_PSS_SHA256 + -- RSASSA-PKCS1-v1_5 + , RSA_PKCS1_SHA512 + , RSA_PKCS1_SHA384 + , RSA_PKCS1_SHA256 + -- Legacy + , RSA_PKCS1_SHA1 + , ECDSA_SHA1 + ] + +-- | The subset of 'supportedSignatureSchemes' that TLS 1.3 allows in +-- CertificateVerify. RFC 8446 section 4.2.3 defines the +-- RSASSA-PKCS1-v1_5 schemes, and the two SHA-1 ones, for signatures in +-- certificates only. +signatureSchemesForTLS13 :: [SignatureScheme] +signatureSchemesForTLS13 = + [ MLDSA87 + , MLDSA65 + , MLDSA44 + , ED448 + , ED25519 + , ECDSA_SECP521R1_SHA512 + , ECDSA_SECP384R1_SHA384 + , ECDSA_SECP256R1_SHA256 + , RSA_PSS_RSAE_SHA512 + , RSA_PSS_RSAE_SHA384 + , RSA_PSS_RSAE_SHA256 + , RSA_PSS_PSS_SHA512 + , RSA_PSS_PSS_SHA384 + , RSA_PSS_PSS_SHA256 + ] +{- FOURMOLU_ENABLE -} diff --git a/Network/TLS/Struct.hs b/Network/TLS/Struct.hs --- a/Network/TLS/Struct.hs +++ b/Network/TLS/Struct.hs @@ -110,7 +110,7 @@ Handshake (..), packetType, typeOfHandshake, - module Network.TLS.HashAndSignature, + module Network.TLS.SignatureScheme, ExtensionRaw (..), ExtensionID (..), showCertificateChain, @@ -134,7 +134,7 @@ import Network.TLS.Crypto import Network.TLS.Error import {-# SOURCE #-} Network.TLS.Extension -import Network.TLS.HashAndSignature +import Network.TLS.SignatureScheme import Network.TLS.Imports import Network.TLS.Types @@ -198,7 +198,7 @@ type Signature = ByteString -data DigitallySigned = DigitallySigned HashAndSignatureAlgorithm Signature +data DigitallySigned = DigitallySigned SignatureScheme Signature deriving (Eq) instance Show DigitallySigned where @@ -470,7 +470,7 @@ | ServerKeyXchg ServerKeyXchgAlgorithmData | CertRequest [CertificateType] - [HashAndSignatureAlgorithm] + [SignatureScheme] [DistinguishedName] | CertVerify DigitallySigned | Finished VerifyData 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 @@ -76,6 +76,17 @@ -- | Hold both client and server traffic secrets at the same step. type TrafficSecrets a = (ClientTrafficSecret a, ServerTrafficSecret a) +-- | The exporter main secret, which RFC 8446 section 7.5 derives exported +-- keying material from, and which RFC 9266's @tls-exporter@ channel binding +-- is one use of. +newtype ExporterSecret = ExporterSecret Secret + +instance Show ExporterSecret where + show _ = "" + +instance DebugShow ExporterSecret where + debugShow (ExporterSecret bs) = showBytesHex $ convert bs + -- Main secret for TLS 1.2 or earlier. newtype MainSecret = MainSecret Secret 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 @@ -46,7 +46,11 @@ , sessionALPN :: Maybe ByteString , sessionMaxEarlyDataSize :: Int , sessionFlags :: [SessionFlag] - } -- sessionFromTicket :: Bool + , sessionClientCertificate :: Maybe ByteString + -- ^ On a server, the DER of the leaf certificate the client was + -- authenticated with, so that a resumed connection can tell the client. + } + -- sessionFromTicket :: Bool deriving (Eq, Generic) -- | Everything but @sessionSecret@, which renders as @\@: whoever @@ -82,7 +86,11 @@ . shows (sessionMaxEarlyDataSize sd) . showString ", sessionFlags = " . shows (sessionFlags sd) + . showString ", sessionClientCertificate = " + . showString (maybe "Nothing" derLength (sessionClientCertificate sd)) . showChar '}' + where + derLength der = "Just <" ++ show (B.length der) ++ " bytes>" -- | A 'SessionData' to build one from with record update syntax, so that a -- field added later does not break the code that builds it. @@ -99,6 +107,7 @@ , sessionALPN = Nothing , sessionMaxEarlyDataSize = 0 , sessionFlags = [] + , sessionClientCertificate = Nothing } is0RTTPossible :: SessionData -> Bool diff --git a/test/Arbitrary.hs b/test/Arbitrary.hs --- a/test/Arbitrary.hs +++ b/test/Arbitrary.hs @@ -46,7 +46,7 @@ 2 -> Session . Just <$> genByteString 32 _ -> return $ Session Nothing -instance {-# OVERLAPS #-} Arbitrary [HashAndSignatureAlgorithm] where +instance {-# OVERLAPS #-} Arbitrary [SignatureScheme] where arbitrary = shuffle supportedSignatureSchemes instance Arbitrary DigitallySigned where diff --git a/test/ChannelBindingSpec.hs b/test/ChannelBindingSpec.hs new file mode 100644 --- /dev/null +++ b/test/ChannelBindingSpec.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ChannelBindingSpec where + +import Control.Concurrent.Async (concurrently) +import Crypto.Error (CryptoFailable (..)) +import qualified Crypto.Hash as H +import qualified Crypto.KDF.HKDF as HKDF +import qualified Crypto.PubKey.Ed25519 as Ed25519 +import qualified Crypto.PubKey.Ed448 as Ed448 +import Crypto.Random (seedFromInteger) +import Data.ByteArray (convert) +import Data.ByteArray.Encoding (Base (Base16), convertFromBase) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import Data.IORef +import Data.Word (Word8) +import Data.X509 hiding (HashMD5, HashSHA1, HashSHA256, HashSHA384) +import qualified Data.X509 as X509 +import Network.TLS +import Network.TLS.Extra.Cipher +import Test.Hspec + +import Certificate +import PubKey +import Run + +spec :: Spec +spec = do + describe "tls-exporter" $ do + it "derives what RFC 8446 says, under SHA-256" $ + exporterFollowsRFC H.SHA256 cipher13_AES_128_GCM_SHA256 + it "derives what RFC 8446 says, under SHA-384" $ + exporterFollowsRFC H.SHA384 cipher13_AES_256_GCM_SHA384 + + describe "tls-server-end-point" $ do + it "hashes only a SHA-1-signed leaf with SHA-256 for TLS 1.2" $ do + let credential@(chain, _) = rsaCredential (SignatureALG X509.HashSHA1 PubKeyALG_RSA) + params = + tls12Params + cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 + [ RSA_PKCS1_SHA256 + , RSA_PKCS1_SHA1 + ] + credential + bindings <- runBindings params + endpointValues bindings `shouldBe` both (Just (leafDigest DigestSHA256 chain)) + it "maps an MD5 certificate signature to SHA-256" $ do + let credential@(chain, _) = rsaCredential (SignatureALG X509.HashMD5 PubKeyALG_RSA) + params = + tls12Params + cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 + [ RSA_PKCS1_SHA256 + , RSA_PKCS1_MD5 + ] + credential + bindings <- runBindings params + endpointValues bindings `shouldBe` both (Just (leafDigest DigestSHA256 chain)) + it "uses a SHA-384 certificate signature instead of the cipher hash" $ do + let credential@(chain, _) = rsaCredential (SignatureALG X509.HashSHA384 PubKeyALG_RSA) + params = + tls12Params + cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + [ RSA_PKCS1_SHA384 + , RSA_PKCS1_SHA256 + ] + credential + bindings <- runBindings params + endpointValues bindings `shouldBe` both (Just (leafDigest DigestSHA384 chain)) + it "uses the same leaf-certificate definition for TLS 1.3" $ do + let credential@(chain, _) = rsaCredential (SignatureALG X509.HashSHA256 PubKeyALG_RSA) + params = tls13Params cipher13_AES_256_GCM_SHA384 credential + bindings <- runBindings params + endpointValues bindings `shouldBe` both (Just (leafDigest DigestSHA256 chain)) + it "is undefined for Ed25519 certificates" $ do + bindings <- runBindings $ tls13Params cipher13_AES_128_GCM_SHA256 ed25519Credential + endpointValues bindings `shouldBe` both Nothing + it "is undefined for Ed448 certificates" $ do + bindings <- runBindings $ tls13Params cipher13_AES_128_GCM_SHA256 ed448Credential + endpointValues bindings `shouldBe` both Nothing + +data Bindings = Bindings + { clientBindings :: (Maybe B.ByteString, Maybe B.ByteString) + , serverBindings :: (Maybe B.ByteString, Maybe B.ByteString) + } + +runBindings :: (ClientParams, ServerParams) -> IO Bindings +runBindings params = + withPairContextWith (id, id) params $ \(clientContext, serverContext) -> do + (clientResult, serverResult) <- + concurrently (getBindings clientContext) (getBindings serverContext) + return $ Bindings clientResult serverResult + where + getBindings ctx = do + handshake ctx + (,) <$> getTLSExporter ctx <*> getTLSServerEndPoint ctx + +exporterValues :: Bindings -> (Maybe B.ByteString, Maybe B.ByteString) +exporterValues bindings = + (fst (clientBindings bindings), fst (serverBindings bindings)) + +byteLists :: (Maybe B.ByteString, Maybe B.ByteString) -> (Maybe [Word8], Maybe [Word8]) +byteLists (clientValue, serverValue) = + (B.unpack <$> clientValue, B.unpack <$> serverValue) + +-- | Run a TLS 1.3 handshake, take the exporter main secret out of the key +-- log, and work out the binding from RFC 8446 here, with no help from the +-- code under test. +-- +-- A fixture of the library's own output cannot do this job: break the +-- derivation, regenerate the fixture, and the test passes again. What is +-- written out below is the specification -- HKDF-Expand-Label and +-- Derive-Secret as RFC 8446 section 7.1 defines them, assembled as section +-- 7.5 and RFC 9266 section 2 say -- so the two have to agree for a reason. +exporterFollowsRFC :: H.HashAlgorithm a => a -> Cipher -> Expectation +exporterFollowsRFC alg cipher = do + logged <- newIORef [] + let params = withKeyLogger (\line -> modifyIORef' logged (line :)) $ + tls13Params cipher ed25519Credential + bindings <- runBindings params + secret <- exporterSecretOf <$> readIORef logged + let expected = tlsExporter alg secret + byteLists (exporterValues bindings) + `shouldBe` byteLists (Just expected, Just expected) + +-- | RFC 9266 section 2: @TLS-Exporter("EXPORTER-Channel-Binding", "", 32)@, +-- which RFC 8446 section 7.5 expands to +-- @HKDF-Expand-Label(Derive-Secret(Secret, label, ""), "exporter", +-- Hash(context_value), key_length)@. Both the @""@ that Derive-Secret is +-- given and the empty context value reach HKDF-Expand-Label as @Hash("")@, +-- which is the step that was wrong. +tlsExporter :: H.HashAlgorithm a => a -> B.ByteString -> B.ByteString +tlsExporter alg secret = + expandLabel alg inner "exporter" (emptyHash alg) 32 + where + inner = deriveSecret alg secret "EXPORTER-Channel-Binding" + +-- | RFC 8446 section 7.1, for the empty transcript: +-- @Derive-Secret(Secret, Label, "") = +-- HKDF-Expand-Label(Secret, Label, Transcript-Hash(""), Hash.length)@. +deriveSecret + :: H.HashAlgorithm a => a -> B.ByteString -> B.ByteString -> B.ByteString +deriveSecret alg secret label = + expandLabel alg secret label (emptyHash alg) (H.hashDigestSize alg) + +-- | RFC 8446 section 7.1, written out: the HkdfLabel structure is a 16-bit +-- length, then @"tls13 " ++ Label@ and then the context, each with a +-- one-octet length of its own. +expandLabel + :: H.HashAlgorithm a + => a -> B.ByteString -> B.ByteString -> B.ByteString -> Int -> B.ByteString +expandLabel alg secret label context len = HKDF.expand (prk alg) hkdfLabel len + where + prk :: H.HashAlgorithm h => h -> HKDF.PRK h + prk _ = HKDF.extractSkip secret + hkdfLabel = + B.concat + [ B.pack [fromIntegral (len `div` 256), fromIntegral (len `mod` 256)] + , opaque ("tls13 " <> label) + , opaque context + ] + opaque bs = B.cons (fromIntegral (B.length bs)) bs + +emptyHash :: H.HashAlgorithm a => a -> B.ByteString +emptyHash alg = convert (H.hashWith alg B.empty) + +-- | The exporter main secret, as the NSS key log format writes it: +-- @EXPORTER_SECRET \ \@, in hexadecimal. +exporterSecretOf :: [String] -> B.ByteString +exporterSecretOf ls = case [w | l <- ls, "EXPORTER_SECRET" : _ : w : _ <- [words l]] of + hexed : _ -> case convertFromBase Base16 (C8.pack hexed) of + Right bs -> bs + Left err -> error ("exporterSecretOf: " ++ err) + [] -> error "exporterSecretOf: the key log has no EXPORTER_SECRET line" + +withKeyLogger + :: (String -> IO ()) + -> (ClientParams, ServerParams) + -> (ClientParams, ServerParams) +withKeyLogger logger (cparams, sparams) = + ( cparams + , sparams{serverDebug = (serverDebug sparams){debugKeyLogger = logger}} + ) + +endpointValues :: Bindings -> (Maybe B.ByteString, Maybe B.ByteString) +endpointValues bindings = + (snd (clientBindings bindings), snd (serverBindings bindings)) + +both :: a -> (a, a) +both value = (value, value) + +tls12Params + :: Cipher + -> [SignatureScheme] + -> Credential + -> (ClientParams, ServerParams) +tls12Params cipher hashSignatures = + bindingParams TLS12 cipher hashSignatures + +tls13Params :: Cipher -> Credential -> (ClientParams, ServerParams) +tls13Params cipher = + bindingParams + TLS13 + cipher + [ ED448 + , ED25519 + , RSA_PSS_RSAE_SHA256 + , RSA_PKCS1_SHA256 + ] + +bindingParams + :: Version + -> Cipher + -> [SignatureScheme] + -> Credential + -> (ClientParams, ServerParams) +bindingParams version cipher hashSignatures credential = + (clientParams, serverParams) + where + supported = + defaultSupported + { supportedVersions = [version] + , supportedCiphers = [cipher] + , supportedGroups = [X25519] + , supportedGroupsTLS13 = [[X25519]] + , supportedHashSignatures = hashSignatures + , -- the fixed RSA key of the expected values is 1024 bits + supportedMinRSAKeySize = 1024 + } + clientParams = + (defaultParamsClient "" B.empty) + { clientSupported = supported + , clientHooks = + defaultClientHooks + { onServerCertificate = \_ _ _ _ -> return [] + } + , clientDebug = fixedDebug 1 + } + serverParams = + defaultParamsServer + { serverSupported = supported + , serverShared = + defaultShared + { sharedCredentials = Credentials [credential] + } + , serverDebug = fixedDebug 2 + } + +fixedDebug :: Integer -> DebugParams +fixedDebug seed = defaultDebugParams{debugSeed = Just (seedFromInteger seed)} + +rsaCredential :: SignatureALG -> Credential +rsaCredential signatureAlgorithm = + (CertificateChain [leaf, intermediate], PrivKeyRSA privateKey) + where + (publicKey, privateKey) = rsaParams + publicKey' = PubKeyRSA publicKey + certificate = + (simpleCertificate publicKey') + { certSignatureAlg = signatureAlgorithm + } + (leaf, ()) = + objectToSignedExact + (\_ -> (B.replicate 128 1, signatureAlgorithm, ())) + certificate + intermediate = simpleX509 publicKey' + +ed25519Credential :: Credential +ed25519Credential = + ( CertificateChain [simpleX509 (PubKeyEd25519 publicKey)] + , PrivKeyEd25519 privateKey + ) + where + privateKey = passed $ Ed25519.secretKey (B.pack [0 .. 31]) + publicKey = Ed25519.toPublic privateKey + +ed448Credential :: Credential +ed448Credential = + ( CertificateChain [simpleX509 (PubKeyEd448 publicKey)] + , PrivKeyEd448 privateKey + ) + where + privateKey = passed $ Ed448.secretKey (B.pack [0 .. 56]) + publicKey = Ed448.toPublic privateKey + +passed :: CryptoFailable a -> a +passed (CryptoPassed value) = value +passed (CryptoFailed err) = error (show err) + +data DigestAlgorithm = DigestSHA256 | DigestSHA384 + +leafDigest :: DigestAlgorithm -> CertificateChain -> B.ByteString +leafDigest algorithm (CertificateChain (leaf : _)) = + case algorithm of + DigestSHA256 -> convert (H.hash (encodeSignedObject leaf) :: H.Digest H.SHA256) + DigestSHA384 -> convert (H.hash (encodeSignedObject leaf) :: H.Digest H.SHA384) +leafDigest _ (CertificateChain []) = error "leafDigest: empty certificate chain" diff --git a/test/EncodeSpec.hs b/test/EncodeSpec.hs --- a/test/EncodeSpec.hs +++ b/test/EncodeSpec.hs @@ -218,7 +218,7 @@ trailingCases :: [(String, Bool)] trailingCases = [ ch "supported_groups" $ SupportedGroups [X25519] - , ch "signature_algorithms" $ SignatureAlgorithms [(HashIntrinsic, SignatureRSApssRSAeSHA256)] + , ch "signature_algorithms" $ SignatureAlgorithms [RSA_PSS_RSAE_SHA256] , ch "application_layer_protocol_negotiation" $ ApplicationLayerProtocolNegotiation [B.pack [0x68, 0x32]] , ch "record_size_limit" $ RecordSizeLimit 16385 diff --git a/test/HandshakeSpec.hs b/test/HandshakeSpec.hs --- a/test/HandshakeSpec.hs +++ b/test/HandshakeSpec.hs @@ -2,7 +2,14 @@ module HandshakeSpec where -import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, threadDelay) +import Control.Concurrent ( + MVar, + forkIO, + newEmptyMVar, + putMVar, + takeMVar, + threadDelay, + ) import Control.Concurrent.Async (concurrently_) import qualified Control.Exception as E import Control.Monad @@ -11,6 +18,7 @@ import Crypto.Error (throwCryptoError) import qualified Crypto.Hash as H import qualified Crypto.MAC.HMAC as HMAC +import qualified Crypto.PubKey.DH as DH import Data.Bits (shiftR, xor) import qualified Data.ByteArray as BA import qualified Data.ByteString as B @@ -24,6 +32,7 @@ import Network.TLS import Network.TLS.Extra.Cipher import Network.TLS.Extra.CipherCBC +import Network.TLS.Extra.FFDHE (ffdhe2048, ffdhe8192) import Network.TLS.Internal import Network.TLS.QUIC (errorToAlertDescription, hkdfExpandLabel, hkdfExtract) import Test.Hspec @@ -33,8 +42,9 @@ import API import Arbitrary -import Certificate (arbitraryRSACredentialWithPurpose) +import Certificate (arbitraryRSACredentialWithPurpose, arbitraryX509WithKey) import PipeChan +import PubKey (rsaParams) import Run import Session @@ -106,6 +116,12 @@ it "rejects a TLS 1.3 server certificate restricted to client auth" $ handshake_server_key_purpose TLS13 KeyUsagePurpose_ClientAuth False prop "can handle client key usage" handshake_client_key_usage + it "rejects a client certificate restricted to server auth" $ + handshake_client_key_purpose [KeyUsagePurpose_ClientAuth] False + it "accepts a client certificate for server auth if allowed" $ + handshake_client_key_purpose + [KeyUsagePurpose_ClientAuth, KeyUsagePurpose_ServerAuth] + True prop "can authenticate client" handshake_client_auth it "rejects a TLS 1.3 CertificateVerify algorithm unfit for the key" $ handshake13_client_cert_verify_unfit_sigalg @@ -117,24 +133,52 @@ B.pack [0x30, 0x06, 0x02, 0x01, 0x01, 0x03, 0x01, 0x09] it "rejects a TLS 1.2 CertificateVerify algorithm for another key type" $ handshake12_client_cert_verify_sigalg - (HashSHA256, SignatureECDSA) + ECDSA_SECP256R1_SHA256 rejectedAsIllegalParameter it "rejects a TLS 1.2 CertificateVerify that does not fit the RSA key" $ handshake12_client_cert_verify_sigalg - (HashIntrinsic, SignatureRSApsspssSHA256) + RSA_PSS_PSS_SHA256 rejectedAsDecryptError it "rejects a TLS 1.2 ServerKeyExchange algorithm for another key type" $ handshake12_server_key_xchg_sigalg - (HashSHA256, SignatureECDSA) + ECDSA_SECP256R1_SHA256 rejectedAsIllegalParameter it "rejects a TLS 1.2 ServerKeyExchange that does not fit the RSA key" $ handshake12_server_key_xchg_sigalg - (HashIntrinsic, SignatureRSApsspssSHA256) + RSA_PSS_PSS_SHA256 rejectedAsDecryptError it "refuses a TLS 1.2 signature algorithm it cannot sign with" $ handshake12_unimplemented_sigalg + it "reports the signature schemes of a TLS 1.2 handshake" $ + handshake_info_signature_schemes TLS12 + it "reports the signature schemes of a TLS 1.3 handshake" $ + handshake_info_signature_schemes TLS13 + it "chooses a TLS 1.2 cipher in the client's order when asked" $ + handshake_client_cipher_order + TLS12 + cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 + cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + it "chooses a TLS 1.3 cipher in the client's order when asked" $ + handshake_client_cipher_order + TLS13 + cipher13_CHACHA20_POLY1305_SHA256 + cipher13_AES_128_GCM_SHA256 it "tells why a server certificate is rejected, with the chain in PEM" $ handshake_certificate_rejection_details + it "tells the client certificate on a TLS 1.2 resumption" $ + handshake_client_cert_on_resumption TLS12 + it "tells the client certificate on a TLS 1.3 resumption" $ + handshake_client_cert_on_resumption TLS13 + it "refuses a server certificate with a 1024-bit RSA key" $ + handshake_short_rsa_key False + it "refuses a client certificate with a 1024-bit RSA key" $ + handshake_short_rsa_key True + it "refuses a server certificate with an RSA key over the upper bound" $ + handshake_long_rsa_key False + it "refuses a client certificate with an RSA key over the upper bound" $ + handshake_long_rsa_key True + it "refuses a custom DH prime outside the bounds of its size" $ + handshake_dh_prime_size prop "can receive client authentication failure" handshake_client_auth_fail it "accepts an empty TLS 1.2 client certificate when the hook does" $ handshake_client_auth_empty TLS12 @@ -241,6 +285,15 @@ it "rejects an X25519MLKEM768 key share with a zero X25519 part" $ handshake13_x25519mlkem768_zero_x25519 prop "can handshake with TLS 1.3 Post-handshake auth" post_handshake_auth + prop + "delivers data while an asynchronous post-handshake auth is pending" + post_handshake_auth_async + it "wakes up a thread waiting for an asynchronous post-handshake auth" $ + post_handshake_auth_async_wait True + it "fails an asynchronous post-handshake auth with a rejected certificate" $ + post_handshake_auth_async_wait False + it "commits the client certificate of a post-handshake auth at Finished" $ + post_handshake_auth_async_finished it "keeps record alignment when a slow record follows client auth" handshake13_client_auth_slow_record @@ -394,8 +447,12 @@ params (\ch -> ch{chExtensions = map trailing $ chExtensions ch}) (refusedWith DecodeError) + it "updates the keys before the record limit" $ + handshake13_key_usage_limit it "answers several update_requested with a single KeyUpdate" $ handshake13_single_key_update_response + it "stops early data at the record limit" $ + handshake13_0rtt_key_usage_limit it "rejects a two-byte TLS 1.2 ChangeCipherSpec" $ malformed_ccs_unexpected TLS12 @@ -672,7 +729,7 @@ -------------------------------------------------------------- handshake_hashsignatures - :: ([HashAndSignatureAlgorithm], [HashAndSignatureAlgorithm]) -> IO () + :: ([SignatureScheme], [SignatureScheme]) -> IO () handshake_hashsignatures (clientHashSigs, serverHashSigs) = do tls13 <- generate arbitrary let version = if tls13 then TLS13 else TLS12 @@ -708,8 +765,10 @@ then runTLSFailure (clientParam', serverParam') handshake handshake else runTLSSimple (clientParam', serverParam') where - incompatibleWithDefaultCurve (h, SignatureECDSA) = h /= HashSHA256 - incompatibleWithDefaultCurve _ = False + -- The test credential's EC key is on P-256, so any ECDSA scheme but + -- the one that names P-256 cannot be used with it. + incompatibleWithDefaultCurve sc = + sc `elem` ecdsaSchemes && sc /= ECDSA_SECP256R1_SHA256 handshake_ciphersuites :: ([Cipher], [Cipher]) -> IO () handshake_ciphersuites (clientCiphers, serverCiphers) = do @@ -785,7 +844,7 @@ [ cipher_ECDHE_ECDSA_WITH_AES_256_GCM_SHA384 ] hashSignatures = - [ (HashSHA256, SignatureECDSA) + [ ECDSA_SECP256R1_SHA256 ] (clientParam, serverParam) <- generate $ @@ -817,8 +876,8 @@ { sharedCredentials = Credentials credentials } } - sigAlgs = map snd (clientHashSignatures `intersect` serverHashSignatures) - ecdsaDenied = SignatureECDSA `notElem` sigAlgs + sigAlgs = clientHashSignatures `intersect` serverHashSignatures + ecdsaDenied = not (any (`elem` ecdsaSchemes) sigAlgs) if ecdsaDenied then runTLSFailure (clientParam', serverParam') handshake handshake else runTLSSimple (clientParam', serverParam') @@ -845,7 +904,7 @@ let clientVersions = [TLS12] serverVersions = [TLS12] commonCiphers = [cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256] - hashSignatures = [(HashSHA256, SignatureRSA), (HashSHA1, SignatureDSA)] + hashSignatures = [RSA_PKCS1_SHA256, DSA_SHA1] chainRef <- newIORef Nothing (clientParam, serverParam) <- generate $ @@ -879,13 +938,13 @@ -- the library, which is useful to test this scenario. SHA-1 could be replaced -- by another algorithm. -data OHS = OHS [HashAndSignatureAlgorithm] [HashAndSignatureAlgorithm] +data OHS = OHS [SignatureScheme] [SignatureScheme] deriving (Show) instance Arbitrary OHS where arbitrary = OHS <$> sublistOf otherHS <*> sublistOf otherHS where - otherHS = [(HashIntrinsic, SignatureEd25519)] + otherHS = [ED25519] handshake_cert_fallback_hs :: OHS -> IO () handshake_cert_fallback_hs (OHS clientHS serverHS) = do @@ -897,8 +956,8 @@ , cipher13_AES_128_GCM_SHA256 ] commonHS = - [ (HashSHA256, SignatureRSA) - , (HashIntrinsic, SignatureRSApssRSAeSHA256) + [ RSA_PKCS1_SHA256 + , RSA_PSS_RSAE_SHA256 ] chainRef <- newIORef Nothing (clientParam, serverParam) <- @@ -926,8 +985,8 @@ } } eddsaDisallowed = - (HashIntrinsic, SignatureEd25519) `notElem` clientHS - || (HashIntrinsic, SignatureEd25519) `notElem` serverHS + ED25519 `notElem` clientHS + || ED25519 `notElem` serverHS runTLSSimple (clientParam', serverParam') serverChain <- readIORef chainRef isLeafRSA serverChain `shouldBe` eddsaDisallowed @@ -1010,6 +1069,34 @@ then runTLSSimple (clientParam', serverParam') else runTLSFailure (clientParam', serverParam') handshake handshake +-- The client offers a certificate restricted to server auth. +handshake_client_key_purpose :: [ExtKeyUsagePurpose] -> Bool -> IO () +handshake_client_key_purpose purposes shouldSucceed = do + (clientParam, serverParam) <- generate arbitrary + cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ServerAuth + let clientParam' = + clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + serverParam' = + serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + , serverSupported = + (serverSupported serverParam) + { supportedClientCertificatePurposes = purposes + } + } + if shouldSucceed + then runTLSSimple (clientParam', serverParam') + else runTLSFailure (clientParam', serverParam') handshake handshake + -------------------------------------------------------------- handshake_client_auth :: (ClientParams, ServerParams) -> IO () @@ -1260,7 +1347,7 @@ -- that does not verify, a decrypt_error. The client signs with an -- rsaEncryption key and the server reads the given algorithm. handshake12_client_cert_verify_sigalg - :: HashAndSignatureAlgorithm -> Selector TLSException -> IO () + :: SignatureScheme -> Selector TLSException -> IO () handshake12_client_cert_verify_sigalg alg rejected = do let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 (clientParam, serverParam) <- @@ -1276,7 +1363,7 @@ { onCertificateRequest = \_ -> return $ Just cred } } - acceptUnverified = alg == (HashSHA256, SignatureECDSA) + acceptUnverified = alg == ECDSA_SECP256R1_SHA256 serverParam' = serverParam { serverWantClientCert = True @@ -1300,7 +1387,7 @@ -- The same for the signature of ServerKeyExchange, which the client used to -- answer with an ErrorCall and internal_error. handshake12_server_key_xchg_sigalg - :: HashAndSignatureAlgorithm -> Selector TLSException -> IO () + :: SignatureScheme -> Selector TLSException -> IO () handshake12_server_key_xchg_sigalg alg rejected = do let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 (clientParam, serverParam) <- @@ -1308,7 +1395,7 @@ arbitraryPairParamsWithVersionsAndCiphers ([TLS12], [TLS12]) ([cipher], [cipher]) - let (HashAlgorithm h, SignatureAlgorithm sa) = alg + let code = fromSignatureScheme alg unfit (ServerKeyXchg (SKX_ECDHE_RSA params (DigitallySigned _ sig))) = pure $ ServerKeyXchg (SKX_ECDHE_RSA params (DigitallySigned alg sig)) -- Arriving with ServerHello, it is decoded before the cipher is @@ -1318,7 +1405,9 @@ in pure $ ServerKeyXchg $ SKX_Unparsed $ - B.take off bs <> B.pack [h, sa] <> B.drop (off + 2) bs + B.take off bs + <> B.pack [fromIntegral (code `shiftR` 8), fromIntegral code] + <> B.drop (off + 2) bs unfit hs = pure hs r <- timeout 10000000 $ withPairContextWith (id, id) (clientParam, serverParam) $ \(cctx, sctx) -> do @@ -1334,7 +1423,7 @@ handshake12_unimplemented_sigalg :: IO () handshake12_unimplemented_sigalg = do let cipher = cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 - sha224 = defaultSupported{supportedHashSignatures = [(HashSHA224, SignatureECDSA)]} + sha224 = defaultSupported{supportedHashSignatures = [ECDSA_SHA224]} (clientParam, serverParam) <- generate $ arbitraryPairParamsWithVersionsAndCiphers @@ -1361,6 +1450,172 @@ (void (E.try (handshake cctx) :: IO (Either TLSException ()))) r `shouldSatisfy` isJust +-- A 1024-bit RSA key is shorter than the default supportedMinRSAKeySize. It +-- is refused in the server's certificate or, with True, in the client's; a +-- lower bound lets it through. +handshake_short_rsa_key :: Bool -> IO () +handshake_short_rsa_key clientSide = handshake_rsa_key_size clientSide id lower + where + lower sup = sup{supportedMinRSAKeySize = 1024} + +-- The same key is longer than an upper bound of 512 bits; no upper bound lets +-- it through. +handshake_long_rsa_key :: Bool -> IO () +handshake_long_rsa_key clientSide = + handshake_rsa_key_size clientSide (bounds 512) (bounds 0) + where + bounds n sup = sup{supportedMinRSAKeySize = 0, supportedMaxRSAKeySize = n} + +-- A 1024-bit RSA key in the server's certificate or, with True, in the +-- client's is refused with the first change of the verifier's 'Supported', +-- and accepted with the second. +handshake_rsa_key_size + :: Bool -> (Supported -> Supported) -> (Supported -> Supported) -> IO () +handshake_rsa_key_size clientSide refusing accepting = do + let cipher = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (pub, priv) = rsaParams + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + cert <- generate $ arbitraryX509WithKey (PubKeyRSA pub, ()) + let key = (CertificateChain [cert], PrivKeyRSA priv) + params change + | clientSide = + ( clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just key + } + } + , serverParam + { serverSupported = change (serverSupported serverParam) + , serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + ) + | otherwise = + ( clientParam{clientSupported = change (clientSupported clientParam)} + , serverParam + { serverShared = + (serverShared serverParam){sharedCredentials = Credentials [key]} + } + ) + withPairContextWith (id, id) (params refusing) $ \(cctx, sctx) -> + if clientSide + then + concurrently_ + (handshake sctx `shouldThrow` rejectedAsBadCertificate) + (void (E.try (handshake cctx) :: IO (Either TLSException ()))) + else + concurrently_ + (void (E.try (handshake sctx) :: IO (Either TLSException ()))) + (handshake cctx `shouldThrow` rejectedAsBadCertificate) + runTLSSimple (params accepting) + where + rejectedAsBadCertificate (HandshakeFailed (Error_Protocol _ BadCertificate)) = True + rejectedAsBadCertificate _ = False + +-- A TLS 1.2 server sends DH parameters of its own, outside the client's +-- supportedGroups. The client refuses a prime outside supportedMinDHKeySize +-- and supportedMaxDHKeySize, whether or not it is one. By default one of +-- 1024 or 8194 bits is refused, but ffdhe2048 and ffdhe8192 are not; with an +-- upper bound of 4096 ffdhe8192 is refused too, and with 0 for either bound +-- nothing on that side is. +handshake_dh_prime_size :: IO () +handshake_dh_prime_size = do + let cipher = cipher_DHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([TLS12], [TLS12]) + ([cipher], [cipher]) + let small = DH.Params (2 ^ (1023 :: Int) + 1) 2 1024 + large = DH.Params (2 ^ (8193 :: Int) + 1) 2 8194 + params (minBits, maxBits) dh = + ( clientParam + { clientSupported = + (clientSupported clientParam) + { supportedGroups = [X25519] + , supportedMinDHKeySize = minBits + , supportedMaxDHKeySize = maxBits + } + } + , serverParam{serverDHEParams = Just dh} + ) + refused ad bounds dh = + withPairContextWith (id, id) (params bounds dh) $ \(cctx, sctx) -> + concurrently_ + (void (E.try (handshake sctx) :: IO (Either TLSException ()))) + (handshake cctx `shouldThrow` refusedFor ad "DH prime") + defaults = (2048, 8192) + refused InsufficientSecurity defaults small + refused HandshakeFailure defaults large + runTLSSimple (params defaults ffdhe2048) + runTLSSimple (params defaults ffdhe8192) + refused HandshakeFailure (2048, 4096) ffdhe8192 + runTLSSimple (params (0, 8192) small) + runTLSSimple (params (2048, 0) large) + +-- No certificate is exchanged on resumption; the server tells the leaf the +-- session kept from the full handshake. +handshake_client_cert_on_resumption :: Version -> IO () +handshake_client_cert_on_resumption version = do + let cipher + | version == TLS13 = cipher13_AES_128_GCM_SHA256 + | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([cipher], [cipher]) + cred@(CertificateChain (leaf : _), _) <- + generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth + -- one group, so that no HelloRetryRequest comes in the way + let x25519 sup = sup{supportedGroups = [X25519], supportedGroupsTLS13 = [[X25519]]} + params0 = + ( clientParam + { clientSupported = x25519 (clientSupported clientParam) + , clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + , serverParam + { serverWantClientCert = True + , serverSupported = x25519 (serverSupported serverParam) + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + ) + sessionRefs <- twoSessionRefs + let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0 + if version == TLS13 + then runTLSSimple13 params FullHandshake + else runTLSSimple params + sessionParams <- readClientSessionRef sessionRefs + expectJust "session param should be Just" sessionParams + ref <- newIORef Nothing + let params2 = setPairParamsSessionResuming (fromJust sessionParams) params + withPairContextWith (id, id) params2 $ \(cctx, sctx) -> do + concurrently_ (handshake sctx) (handshake cctx) + info <- contextGetInformation sctx + chain <- getClientCertificateChain sctx + writeIORef ref $ Just (info, chain) + Just (info, chain) <- readIORef ref + -- it was a resumption indeed + let resumed i + | version == TLS13 = infoTLS13HandshakeMode i == Just PreSharedKey + | otherwise = infoTLS12Resumption i + info `shouldSatisfy` maybe False resumed + chain `shouldBe` Just (CertificateChain [leaf]) + -- The exception names the validation failures and the leaf, and debugError -- gets every certificate of the chain in PEM. handshake_certificate_rejection_details :: IO () @@ -1394,6 +1649,75 @@ "[UnknownCA]" `isInfixOf` msg && "subject: " `isInfixOf` msg rejectedWithDetails _ = False +-- The client prefers the first cipher and the server the second. The +-- server's order wins unless supportedClientCipherOrder is set. +handshake_client_cipher_order :: Version -> Cipher -> Cipher -> IO () +handshake_client_cipher_order version first second = do + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([first, second], [second, first]) + let run clientOrder = do + ref <- newIORef Nothing + let serverParam' = + serverParam + { serverSupported = + (serverSupported serverParam) + { supportedClientCipherOrder = clientOrder + } + } + withPairContextWith (id, id) (clientParam, serverParam') $ \(cctx, sctx) -> do + concurrently_ (handshake sctx) (handshake cctx) + contextGetInformation sctx >>= writeIORef ref + fmap (cipherID . infoCipher) <$> readIORef ref + run False `shouldReturn` Just (cipherID second) + run True `shouldReturn` Just (cipherID first) + +-- Both sides report the same schemes: the server's signature always, and the +-- client's CertificateVerify only when it sends a certificate. +handshake_info_signature_schemes :: Version -> IO () +handshake_info_signature_schemes version = do + let cipher + | version == TLS13 = cipher13_AES_128_GCM_SHA256 + | otherwise = cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + (clientParam, serverParam) <- + generate $ + arbitraryPairParamsWithVersionsAndCiphers + ([version], [version]) + ([cipher], [cipher]) + cred <- generate $ arbitraryRSACredentialWithPurpose KeyUsagePurpose_ClientAuth + let withCert send = + ( clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ if send then Just cred else Nothing + } + } + , serverParam + { serverWantClientCert = True + , serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return CertificateUsageAccept + } + } + ) + run params = do + ref <- newIORef Nothing + withPairContextWith (id, id) params $ \(cctx, sctx) -> do + concurrently_ (handshake sctx) (handshake cctx) + ci <- contextGetInformation cctx + si <- contextGetInformation sctx + writeIORef ref $ Just (ci, si) + fromJust <$> readIORef ref + schemes i = (infoServerSignatureScheme =<< i, infoClientSignatureScheme =<< i) + (ci, si) <- run (withCert True) + schemes ci `shouldBe` schemes si + schemes ci `shouldSatisfy` \(sv, cl) -> isJust sv && isJust cl + (ci', si') <- run (withCert False) + schemes ci' `shouldBe` schemes si' + schemes ci' `shouldSatisfy` \(sv, cl) -> isJust sv && isNothing cl + -- A DER ECDSA signature that does not decode is a signature that does not -- verify, a decrypt_error. The client's TLS 1.3 CertificateVerify -- signature is replaced on its way to the server with one that the ASN.1 @@ -1472,7 +1796,7 @@ } unfit (CertVerify13 (DigitallySigned _ sig)) = pure $ - CertVerify13 (DigitallySigned (HashIntrinsic, SignatureRSApsspssSHA256) sig) + CertVerify13 (DigitallySigned RSA_PSS_PSS_SHA256 sig) unfit hs = pure hs r <- timeout 10000000 $ withPairContextWith (id, id) (clientParam', serverParam') $ \(cctx, sctx) -> do @@ -2912,6 +3236,169 @@ _ <- requestCertificate ctx -- two simultaneously sendData ctx "response 2" +type PairParams = (ClientParams, ServerParams) + +-- | Client and server parameters for post-handshake authentication with +-- the credential, which the server accepts or rejects. +phaParams :: Bool -> Credential -> PairParams -> PairParams +phaParams accept cred (clientParam, serverParam) = + ( clientParam + { clientHooks = + (clientHooks clientParam) + { onCertificateRequest = \_ -> return $ Just cred + } + } + , serverParam + { serverHooks = + (serverHooks serverParam) + { onClientCertificate = \_ -> return usage + } + } + ) + where + usage + | accept = CertificateUsageAccept + | otherwise = CertificateUsageReject CertificateRejectUnknownCA + +-- DSA cannot sign in TLS 1.3. +arbitraryPHACredential :: Gen Credential +arbitraryPHACredential = + arbitraryClientCredential TLS13 `suchThat` (not . isCredentialDSA) + +-- | The server requests a certificate without waiting. The client has +-- sent "request 2" before it sees the request; the server's 'recvData' +-- delivers it and later processes the response. +post_handshake_auth_async :: CSP13 -> IO () +post_handshake_auth_async (CSP13 params) = do + cred <- generate arbitraryPHACredential + runTLSSuccess (phaParams True cred params) hsClient (hsServer cred) + where + hsClient ctx = do + handshake ctx + sendData ctx "request 1" + sendData ctx "request 2" + recvDataAssert ctx "response 1" + sendData ctx "request 3" + recvDataAssert ctx "response 3" + hsServer cred ctx = do + handshake ctx + recvDataAssert ctx "request 1" + check <- requestCertificateAsync ctx + -- only one request may be pending + check' <- requestCertificateAsync ctx + check' False `shouldReturn` PHAUnavailable + sendData ctx "response 1" + recvDataAssert ctx "request 2" + recvDataAssert ctx "request 3" + check False `shouldReturn` PHAAccepted (fst cred) + getClientCertificateChain ctx `shouldReturn` Just (fst cred) + sendData ctx "response 3" + +-- | Another thread waits for the result while the server keeps reading. +-- With a rejected certificate, the server's 'recvData' fails and so does +-- the waiting thread. +post_handshake_auth_async_wait :: Bool -> IO () +post_handshake_auth_async_wait accept = do + params <- generate arbitraryPairParams13 + cred <- generate arbitraryPHACredential + let params' = phaParams accept cred params + if accept + then runTLSSuccess params' hsClient (hsServer cred) + else withPairContext params' $ \(cCtx, sCtx) -> + concurrently_ (hsServer cred sCtx) (hsClient cCtx) + where + hsClient ctx = do + handshake ctx + sendData ctx "request 1" + recvDataAssert ctx "response 1" + sendData ctx "request 2" + if accept + then recvDataAssert ctx "response 2" + else void (recvData ctx) `shouldThrow` anyTLSException + hsServer cred ctx = do + handshake ctx + recvDataAssert ctx "request 1" + check <- requestCertificateAsync ctx + result <- newEmptyMVar + _ <- forkIO $ check True >>= putMVar result + sendData ctx "response 1" + if accept + then do + recvDataAssert ctx "request 2" + takeMVar result `shouldReturn` PHAAccepted (fst cred) + sendData ctx "response 2" + else do + void (recvData ctx) `shouldThrow` anyTLSException + takeMVar result >>= (`shouldSatisfy` isFailed) + isFailed (PHAFailed _) = True + isFailed _ = False + +-- | The client's Finished is held back after its CertificateVerify has been +-- verified. Until Finished arrives, the result is pending and the chain is +-- not committed. +post_handshake_auth_async_finished :: IO () +post_handshake_auth_async_finished = do + params <- generate arbitraryPairParams13 + cred <- generate arbitraryPHACredential + let (clientParam, serverParam) = phaParams True cred params + params' = (clientParam, serverParam{serverWantClientCert = False}) + armed <- newIORef False + held <- newEmptyMVar + cvSeen <- newEmptyMVar + withPairContextWith (holdLastRecord armed held, id) params' $ \(cCtx, sCtx) -> do + contextHookSetHandshake13Recv sCtx $ \h -> do + case h of + CertVerify13{} -> putMVar cvSeen () + _ -> return () + return h + concurrently_ (hsServer cred held cvSeen sCtx) (hsClient armed cCtx) + where + hsClient armed ctx = do + handshake ctx + writeIORef armed True + sendData ctx "request 1" + recvDataAssert ctx "response 1" + recvDataAssert ctx "response 2" + sendData ctx "request 2" + hsServer cred held cvSeen ctx = do + handshake ctx + recvDataAssert ctx "request 1" + check <- requestCertificateAsync ctx + sendData ctx "response 1" + received <- newEmptyMVar + _ <- forkIO $ recvData ctx >>= putMVar received + takeMVar cvSeen + threadDelay 100000 -- for CertificateVerify to be processed + check False `shouldReturn` PHAPending + getClientCertificateChain ctx `shouldReturn` Nothing + join $ takeMVar held + check True `shouldReturn` PHAAccepted (fst cred) + getClientCertificateChain ctx `shouldReturn` Just (fst cred) + sendData ctx "response 2" + takeMVar received `shouldReturn` "request 2" + +-- | Once armed, hold back the last record of the next write of several +-- records, and leave the action that sends it. +holdLastRecord :: IORef Bool -> MVar (IO ()) -> Backend -> Backend +holdLastRecord armed held be = + be + { backendSend = \bs -> do + arm <- readIORef armed + case records bs of + rs@(_ : _ : _) | arm -> do + writeIORef armed False + backendSend be $ B.concat $ init rs + putMVar held $ backendSend be $ last rs + _ -> backendSend be bs + } + where + records bs + | B.length bs < 5 = [bs | not (B.null bs)] + | otherwise = + let len = fromIntegral (B.index bs 3) * 256 + fromIntegral (B.index bs 4) + (r, rest) = B.splitAt (5 + len) bs + in r : records rest + -- | After sending a Certificate message, a TLS 1.3 client peeks for a -- client-authentication alert with a deadline of a few RTTs. That peek must -- not abandon a record it has already started reading: the record layer has no @@ -3408,6 +3895,36 @@ ) r `shouldSatisfy` isJust +-- RFC 9846 Section 5.5: with two records allowed under a set of keys, the +-- client updates its keys before the third and the fifth of five records. +-- The server counts the KeyUpdates it receives. +handshake13_key_usage_limit :: IO () +handshake13_key_usage_limit = do + (clientParam, serverParam) <- generate arbitraryPairParams13 + let clientParam' = + clientParam + { clientShared = + (clientShared clientParam) + { sharedLimit = defaultLimit{limitRecordsPerKey = Just 2} + } + } + msgs = ["a", "b", "c", "d", "e"] + updates <- newIORef (0 :: Int) + let count h = do + case h of + KeyUpdate13 _ -> modifyIORef' updates (+ 1) + _ -> return () + return h + withPairContext (clientParam', serverParam) $ \(cctx, sctx) -> + concurrently_ + ( do + handshake sctx + contextHookSetHandshake13Recv sctx count + mapM_ (\m -> recvData sctx `shouldReturn` m) msgs + ) + (handshake cctx >> mapM_ (sendData cctx . L.fromStrict) msgs) + readIORef updates `shouldReturn` 2 + -- RFC 9846 Section 4.6.3: a peer that gets several KeyUpdates with -- update_requested while it sends nothing answers them once. The server -- asks twice, and after the client's data once more. It counts the @@ -3443,6 +3960,38 @@ sendData cctx "y" ) readIORef updates `shouldReturn` 2 + +-- Early data cannot update the keys, so it is refused at the limit. +handshake13_0rtt_key_usage_limit :: IO () +handshake13_0rtt_key_usage_limit = do + (cli, srv) <- generate arbitraryPairParams13 + let params0 = fixGroupsX25519 (cli, srv{serverEarlyDataSize = 2048}) + sessionRefs <- twoSessionRefs + let params = setPairParamsSessionManagers (twoSessionManagers sessionRefs) params0 + runTLSSimple13 params FullHandshake + Just sessionParams <- readClientSessionRef sessionRefs + let (pc, ps) = setPairParamsSessionResuming sessionParams params + pc' = + pc + { clientUseEarlyData = True + , clientShared = + (clientShared pc){sharedLimit = defaultLimit{limitRecordsPerKey = Just 0}} + } + r <- timeout 10000000 $ + withPairContext (pc', ps) $ \(cctx, sctx) -> + concurrently_ + ( void + (E.try (handshake sctx >> recvData sctx) :: IO (Either TLSException B.ByteString)) + ) + ( do + handshake cctx + sendData cctx "early" `shouldThrow` limitReached + bye cctx + ) + r `shouldSatisfy` isJust + where + limitReached (PostHandshake (Error_Misc msg)) = "limit" `isInfixOf` msg + limitReached _ = False -- The client offers an unknown ticket, with a PSK of its own, before the -- one the server issued. Each PSK has its own binder, and the server diff --git a/test/Run.hs b/test/Run.hs --- a/test/Run.hs +++ b/test/Run.hs @@ -362,8 +362,8 @@ withPairContextWith :: (Backend -> Backend, Backend -> Backend) -> (ClientParams, ServerParams) - -> ((Context, Context) -> IO ()) - -> IO () + -> ((Context, Context) -> IO a) + -> IO a withPairContextWith wrapBackends params body = E.bracket (newPairContextWith wrapBackends params) diff --git a/test/SecretSpec.hs b/test/SecretSpec.hs --- a/test/SecretSpec.hs +++ b/test/SecretSpec.hs @@ -48,6 +48,7 @@ , sessionALPN = Nothing , sessionMaxEarlyDataSize = 0 , sessionFlags = [] + , sessionClientCertificate = Nothing } cipher = case ciphersuite_default of c : _ -> c diff --git a/tls.cabal b/tls.cabal --- a/tls.cabal +++ b/tls.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: tls -version: 2.4.14 +version: 2.5.0 license: BSD3 license-file: LICENSE copyright: Vincent Hanquez @@ -81,7 +81,7 @@ Network.TLS.Handshake.State Network.TLS.Handshake.State13 Network.TLS.Handshake.TranscriptHash - Network.TLS.HashAndSignature + Network.TLS.SignatureScheme Network.TLS.Hooks Network.TLS.IO Network.TLS.IO.Decode @@ -131,7 +131,7 @@ crypton-x509-store >=1.10 && <1.11, crypton-x509-validation >=1.10 && <1.11, data-default, - ech-config, + ech-config >=0.0.2, hpke >=0.4.0 && <0.5, mtl >=2.2 && <2.4, network >=3.1, @@ -208,6 +208,7 @@ API Arbitrary Certificate + ChannelBindingSpec CiphersSpec ECHSpec EncodeSpec diff --git a/util/Server.hs b/util/Server.hs --- a/util/Server.hs +++ b/util/Server.hs @@ -1,7 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Server where +import Control.Concurrent +import qualified Control.Exception as E import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as CL8 @@ -50,25 +53,44 @@ sendData ctx $ CL8.fromStrict bs loop +-- A dedicated thread keeps calling 'recvData', which also processes the +-- response to a post-handshake authentication. handleHTML :: Context -> Bool -> ByteString -> IO () handleHTML ctx showRequest ini = do - getLine <- newSource ctx ini - process getLine + chan <- newChan + E.bracket (forkIO $ reader chan) killThread $ \_ -> do + getLine <- newSource chan ini + process getLine where + reader chan = do + r <- E.try $ recvData ctx + case r of + Right bs | bs /= "" -> writeChan chan bs >> reader chan + Right _ -> writeChan chan "" + Left (_ :: E.SomeException) -> writeChan chan "" process getLine = do bs <- getLine when ("GET /keyupdate" `BS.isPrefixOf` bs) $ do r <- updateKey ctx TwoWay putStrLn $ "Updating key..." ++ if r then "OK" else "NG" - when ("GET /secret" `BS.isPrefixOf` bs) $ do - r <- requestCertificate ctx - putStrLn $ "Post handshake authentication..." ++ if r then "OK" else "NG" + mcheck <- + if "GET /secret" `BS.isPrefixOf` bs + then Just <$> requestCertificateAsync ctx + else return Nothing when (bs /= "") $ do when showRequest $ do BS.putStr bs BS.putStr "\n" consume getLine - sendData ctx html + ok <- maybe (return True) authenticated mcheck + when ok $ sendData ctx html + -- The response is sent only after the authentication. + authenticated check = do + r <- check True + putStrLn $ "Post handshake authentication..." ++ show r + return $ case r of + PHAFailed _ -> False + _ -> True consume getLine = do bs <- getLine when (bs /= "") $ do @@ -77,8 +99,8 @@ BS.putStr "\n" consume getLine -newSource :: Context -> ByteString -> IO (IO ByteString) -newSource ctx ini = do +newSource :: Chan ByteString -> ByteString -> IO (IO ByteString) +newSource chan ini = do ref <- newIORef ini return $ getline ref where @@ -87,9 +109,16 @@ bs0 <- readIORef ref case BS.breakSubstring "\n" bs0 of (_, "") -> do - bs1 <- recvData ctx - writeIORef ref (bs0 <> bs1) - getline ref + bs1 <- readChan chan + if bs1 == "" + then do + -- EOF stays for the next call. + writeChan chan "" + writeIORef ref "" + return bs0 + else do + writeIORef ref (bs0 <> bs1) + getline ref (bs1, bs2) -> do writeIORef ref $ BS.drop 1 bs2 return $ BS.dropWhileEnd (== 0x0d) bs1